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 #include "defaults.h"
  93 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
  94
  95 #define FFECOM_GCC_INCLUDE 1    /* Enable -I. */
  96
  97 /* BEGIN stuff from gcc/cccp.c.  */
  98
  99 /* The following symbols should be autoconfigured:
 100         HAVE_FCNTL_H
 101         HAVE_STDLIB_H
 102         HAVE_SYS_TIME_H
 103         HAVE_UNISTD_H
 104         STDC_HEADERS
 105         TIME_WITH_SYS_TIME
 106    In the mean time, we'll get by with approximations based
 107    on existing GCC configuration symbols.  */
 108
 109 #ifdef POSIX
 110 # ifndef HAVE_STDLIB_H
 111 # define HAVE_STDLIB_H 1
 112 # endif
 113 # ifndef HAVE_UNISTD_H
 114 # define HAVE_UNISTD_H 1
 115 # endif
 116 # ifndef STDC_HEADERS
 117 # define STDC_HEADERS 1
 118 # endif
 119 #endif /* defined (POSIX) */
 120
 121 #if defined (POSIX) || (defined (USG) && !defined (VMS))
 122 # ifndef HAVE_FCNTL_H
 123 # define HAVE_FCNTL_H 1
 124 # endif
 125 #endif
 126
 127 #ifdef RLIMIT_STACK
 128 # include <sys/resource.h>
 129 #endif
 130
 131 #if HAVE_FCNTL_H
 132 # include <fcntl.h>
 133 #endif
 134
 135 /* This defines "errno" properly for VMS, and gives us EACCES. */
 136 #include <errno.h>
 137
 138 #if HAVE_STDLIB_H
 139 # include <stdlib.h>
 140 #else
 141 char *getenv ();
 142 #endif
 143
 144 #if HAVE_UNISTD_H
 145 # include <unistd.h>
 146 #endif
 147
 148 /* VMS-specific definitions */
 149 #ifdef VMS
 150 #include <descrip.h>
 151 #define O_RDONLY        0       /* Open arg for Read/Only  */
 152 #define O_WRONLY        1       /* Open arg for Write/Only */
 153 #define read(fd,buf,size)       VMS_read (fd,buf,size)
 154 #define write(fd,buf,size)      VMS_write (fd,buf,size)
 155 #define open(fname,mode,prot)   VMS_open (fname,mode,prot)
 156 #define fopen(fname,mode)       VMS_fopen (fname,mode)
 157 #define freopen(fname,mode,ofile) VMS_freopen (fname,mode,ofile)
 158 #define strncat(dst,src,cnt) VMS_strncat (dst,src,cnt)
 159 #define fstat(fd,stbuf)         VMS_fstat (fd,stbuf)
 160 static int VMS_fstat (), VMS_stat ();
 161 static char * VMS_strncat ();
 162 static int VMS_read ();
 163 static int VMS_write ();
 164 static int VMS_open ();
 165 static FILE * VMS_fopen ();
 166 static FILE * VMS_freopen ();
 167 static void hack_vms_include_specification ();
 168 typedef struct { unsigned :16, :16, :16; } vms_ino_t;
 169 #define ino_t vms_ino_t
 170 #define INCLUDE_LEN_FUDGE 10    /* leave room for VMS syntax conversion */
 171 #endif /* VMS */
 172
 173 #ifndef O_RDONLY
 174 #define O_RDONLY 0
 175 #endif
 176
 177 /* END stuff from gcc/cccp.c.  */
 178
 179 #define FFECOM_DETERMINE_TYPES 1 /* for com.h */
 180 #include "com.h"
 181 #include "bad.h"
 182 #include "bld.h"
 183 #include "equiv.h"
 184 #include "expr.h"
 185 #include "implic.h"
 186 #include "info.h"
 187 #include "malloc.h"
 188 #include "src.h"
 189 #include "st.h"
 190 #include "storag.h"
 191 #include "symbol.h"
 192 #include "target.h"
 193 #include "top.h"
 194 #include "type.h"
 195
 196 /* Externals defined here.  */
 197
 198 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 199
 200 /* ~~gcc/tree.h *should* declare this, because toplev.c and dwarfout.c
 201    reference it.  */
 202
 203 const char * const language_string = "GNU F77";
 204
 205 /* Stream for reading from the input file.  */
 206 FILE *finput;
 207
 208 /* These definitions parallel those in c-decl.c so that code from that
 209    module can be used pretty much as is.  Much of these defs aren't
 210    otherwise used, i.e. by g77 code per se, except some of them are used
 211    to build some of them that are.  The ones that are global (i.e. not
 212    "static") are those that ste.c and such might use (directly
 213    or by using com macros that reference them in their definitions).  */
 214
 215 tree string_type_node;
 216
 217 /* The rest of these are inventions for g77, though there might be
 218    similar things in the C front end.  As they are found, these
 219    inventions should be renamed to be canonical.  Note that only
 220    the ones currently required to be global are so.  */
 221
 222 static tree ffecom_tree_fun_type_void;
 223
 224 tree ffecom_integer_type_node;  /* Abbrev for _tree_type[blah][blah]. */
 225 tree ffecom_integer_zero_node;  /* Like *_*_* with g77's integer type. */
 226 tree ffecom_integer_one_node;   /* " */
 227 tree ffecom_tree_type[FFEINFO_basictype][FFEINFO_kindtype];
 228
 229 /* _fun_type things are the f2c-specific versions.  For -fno-f2c,
 230    just use build_function_type and build_pointer_type on the
 231    appropriate _tree_type array element.  */
 232
 233 static tree ffecom_tree_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
 234 static tree ffecom_tree_ptr_to_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
 235 static tree ffecom_tree_subr_type;
 236 static tree ffecom_tree_ptr_to_subr_type;
 237 static tree ffecom_tree_blockdata_type;
 238
 239 static tree ffecom_tree_xargc_;
 240
 241 ffecomSymbol ffecom_symbol_null_
 242 =
 243 {
 244   NULL_TREE,
 245   NULL_TREE,
 246   NULL_TREE,
 247   NULL_TREE,
 248   false
 249 };
 250 ffeinfoKindtype ffecom_pointer_kind_ = FFEINFO_basictypeNONE;
 251 ffeinfoKindtype ffecom_label_kind_ = FFEINFO_basictypeNONE;
 252
 253 int ffecom_f2c_typecode_[FFEINFO_basictype][FFEINFO_kindtype];
 254 tree ffecom_f2c_integer_type_node;
 255 tree ffecom_f2c_ptr_to_integer_type_node;
 256 tree ffecom_f2c_address_type_node;
 257 tree ffecom_f2c_real_type_node;
 258 tree ffecom_f2c_ptr_to_real_type_node;
 259 tree ffecom_f2c_doublereal_type_node;
 260 tree ffecom_f2c_complex_type_node;
 261 tree ffecom_f2c_doublecomplex_type_node;
 262 tree ffecom_f2c_longint_type_node;
 263 tree ffecom_f2c_logical_type_node;
 264 tree ffecom_f2c_flag_type_node;
 265 tree ffecom_f2c_ftnlen_type_node;
 266 tree ffecom_f2c_ftnlen_zero_node;
 267 tree ffecom_f2c_ftnlen_one_node;
 268 tree ffecom_f2c_ftnlen_two_node;
 269 tree ffecom_f2c_ptr_to_ftnlen_type_node;
 270 tree ffecom_f2c_ftnint_type_node;
 271 tree ffecom_f2c_ptr_to_ftnint_type_node;
 272 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 273
 274 /* Simple definitions and enumerations. */
 275
 276 #ifndef FFECOM_sizeMAXSTACKITEM
 277 #define FFECOM_sizeMAXSTACKITEM 32*1024 /* Keep user-declared things
 278                                            larger than this # bytes
 279                                            off stack if possible. */
 280 #endif
 281
 282 /* For systems that have large enough stacks, they should define
 283    this to 0, and here, for ease of use later on, we just undefine
 284    it if it is 0.  */
 285
 286 #if FFECOM_sizeMAXSTACKITEM == 0
 287 #undef FFECOM_sizeMAXSTACKITEM
 288 #endif
 289
 290 typedef enum
 291   {
 292     FFECOM_rttypeVOID_,
 293     FFECOM_rttypeVOIDSTAR_,     /* C's `void *' type. */
 294     FFECOM_rttypeFTNINT_,       /* f2c's `ftnint' type. */
 295     FFECOM_rttypeINTEGER_,      /* f2c's `integer' type. */
 296     FFECOM_rttypeLONGINT_,      /* f2c's `longint' type. */
 297     FFECOM_rttypeLOGICAL_,      /* f2c's `logical' type. */
 298     FFECOM_rttypeREAL_F2C_,     /* f2c's `real' returned as `double'. */
 299     FFECOM_rttypeREAL_GNU_,     /* `real' returned as such. */
 300     FFECOM_rttypeCOMPLEX_F2C_,  /* f2c's `complex' returned via 1st arg. */
 301     FFECOM_rttypeCOMPLEX_GNU_,  /* f2c's `complex' returned directly. */
 302     FFECOM_rttypeDOUBLE_,       /* C's `double' type. */
 303     FFECOM_rttypeDOUBLEREAL_,   /* f2c's `doublereal' type. */
 304     FFECOM_rttypeDBLCMPLX_F2C_, /* f2c's `doublecomplex' returned via 1st arg. */
 305     FFECOM_rttypeDBLCMPLX_GNU_, /* f2c's `doublecomplex' returned directly. */
 306     FFECOM_rttypeCHARACTER_,    /* f2c `char *'/`ftnlen' pair. */
 307     FFECOM_rttype_
 308   } ffecomRttype_;
 309
 310 /* Internal typedefs. */
 311
 312 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 313 typedef struct _ffecom_concat_list_ ffecomConcatList_;
 314 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 315
 316 /* Private include files. */
 317
 318
 319 /* Internal structure definitions. */
 320
 321 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 322 struct _ffecom_concat_list_
 323   {
 324     ffebld *exprs;
 325     int count;
 326     int max;
 327     ffetargetCharacterSize minlen;
 328     ffetargetCharacterSize maxlen;
 329   };
 330 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 331
 332 /* Static functions (internal). */
 333
 334 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 335 static tree ffecom_arglist_expr_ (const char *argstring, ffebld args);
 336 static tree ffecom_widest_expr_type_ (ffebld list);
 337 static bool ffecom_overlap_ (tree dest_decl, tree dest_offset,
 338                              tree dest_size, tree source_tree,
 339                              ffebld source, bool scalar_arg);
 340 static bool ffecom_args_overlapping_ (tree dest_tree, ffebld dest,
 341                                       tree args, tree callee_commons,
 342                                       bool scalar_args);
 343 static tree ffecom_build_f2c_string_ (int i, const char *s);
 344 static tree ffecom_call_ (tree fn, ffeinfoKindtype kt,
 345                           bool is_f2c_complex, tree type,
 346                           tree args, tree dest_tree,
 347                           ffebld dest, bool *dest_used,
 348                           tree callee_commons, bool scalar_args, tree hook);
 349 static tree ffecom_call_binop_ (tree fn, ffeinfoKindtype kt,
 350                                 bool is_f2c_complex, tree type,
 351                                 ffebld left, ffebld right,
 352                                 tree dest_tree, ffebld dest,
 353                                 bool *dest_used, tree callee_commons,
 354                                 bool scalar_args, bool ref, tree hook);
 355 static void ffecom_char_args_x_ (tree *xitem, tree *length,
 356                                  ffebld expr, bool with_null);
 357 static tree ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy);
 358 static tree ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s);
 359 static ffecomConcatList_
 360   ffecom_concat_list_gather_ (ffecomConcatList_ catlist,
 361                               ffebld expr,
 362                               ffetargetCharacterSize max);
 363 static void ffecom_concat_list_kill_ (ffecomConcatList_ catlist);
 364 static ffecomConcatList_ ffecom_concat_list_new_ (ffebld expr,
 365                                                 ffetargetCharacterSize max);
 366 static void ffecom_debug_kludge_ (tree aggr, const char *aggr_type,
 367                                   ffesymbol member, tree member_type,
 368                                   ffetargetOffset offset);
 369 static void ffecom_do_entry_ (ffesymbol fn, int entrynum);
 370 static tree ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
 371                           bool *dest_used, bool assignp, bool widenp);
 372 static tree ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
 373                                     ffebld dest, bool *dest_used);
 374 static tree ffecom_expr_power_integer_ (ffebld expr);
 375 static void ffecom_expr_transform_ (ffebld expr);
 376 static void ffecom_f2c_make_type_ (tree *type, int tcode, const char *name);
 377 static void ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
 378                                       int code);
 379 static ffeglobal ffecom_finish_global_ (ffeglobal global);
 380 static ffesymbol ffecom_finish_symbol_transform_ (ffesymbol s);
 381 static tree ffecom_get_appended_identifier_ (char us, const char *text);
 382 static tree ffecom_get_external_identifier_ (ffesymbol s);
 383 static tree ffecom_get_identifier_ (const char *text);
 384 static tree ffecom_gen_sfuncdef_ (ffesymbol s,
 385                                   ffeinfoBasictype bt,
 386                                   ffeinfoKindtype kt);
 387 static const char *ffecom_gfrt_args_ (ffecomGfrt ix);
 388 static tree ffecom_gfrt_tree_ (ffecomGfrt ix);
 389 static tree ffecom_init_zero_ (tree decl);
 390 static tree ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
 391                                      tree *maybe_tree);
 392 static tree ffecom_intrinsic_len_ (ffebld expr);
 393 static void ffecom_let_char_ (tree dest_tree,
 394                               tree dest_length,
 395                               ffetargetCharacterSize dest_size,
 396                               ffebld source);
 397 static void ffecom_make_gfrt_ (ffecomGfrt ix);
 398 static void ffecom_member_phase1_ (ffestorag mst, ffestorag st);
 399 static void ffecom_member_phase2_ (ffestorag mst, ffestorag st);
 400 static void ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size,
 401                                       ffebld source);
 402 static void ffecom_push_dummy_decls_ (ffebld dumlist,
 403                                       bool stmtfunc);
 404 static void ffecom_start_progunit_ (void);
 405 static ffesymbol ffecom_sym_transform_ (ffesymbol s);
 406 static ffesymbol ffecom_sym_transform_assign_ (ffesymbol s);
 407 static void ffecom_transform_common_ (ffesymbol s);
 408 static void ffecom_transform_equiv_ (ffestorag st);
 409 static tree ffecom_transform_namelist_ (ffesymbol s);
 410 static void ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
 411                                        tree t);
 412 static void ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
 413                                        tree *size, tree tree);
 414 static tree ffecom_tree_divide_ (tree tree_type, tree left, tree right,
 415                                  tree dest_tree, ffebld dest,
 416                                  bool *dest_used, tree hook);
 417 static tree ffecom_type_localvar_ (ffesymbol s,
 418                                    ffeinfoBasictype bt,
 419                                    ffeinfoKindtype kt);
 420 static tree ffecom_type_namelist_ (void);
 421 static tree ffecom_type_vardesc_ (void);
 422 static tree ffecom_vardesc_ (ffebld expr);
 423 static tree ffecom_vardesc_array_ (ffesymbol s);
 424 static tree ffecom_vardesc_dims_ (ffesymbol s);
 425 static tree ffecom_convert_narrow_ (tree type, tree expr);
 426 static tree ffecom_convert_widen_ (tree type, tree expr);
 427 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 428
 429 /* These are static functions that parallel those found in the C front
 430    end and thus have the same names.  */
 431
 432 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 433 static tree bison_rule_compstmt_ (void);
 434 static void bison_rule_pushlevel_ (void);
 435 static void delete_block (tree block);
 436 static int duplicate_decls (tree newdecl, tree olddecl);
 437 static void finish_decl (tree decl, tree init, bool is_top_level);
 438 static void finish_function (int nested);
 439 static const char *lang_printable_name (tree decl, int v);
 440 static tree lookup_name_current_level (tree name);
 441 static struct binding_level *make_binding_level (void);
 442 static void pop_f_function_context (void);
 443 static void push_f_function_context (void);
 444 static void push_parm_decl (tree parm);
 445 static tree pushdecl_top_level (tree decl);
 446 static int kept_level_p (void);
 447 static tree storedecls (tree decls);
 448 static void store_parm_decls (int is_main_program);
 449 static tree start_decl (tree decl, bool is_top_level);
 450 static void start_function (tree name, tree type, int nested, int public);
 451 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 452 #if FFECOM_GCC_INCLUDE
 453 static void ffecom_file_ (const char *name);
 454 static void ffecom_initialize_char_syntax_ (void);
 455 static void ffecom_close_include_ (FILE *f);
 456 static int ffecom_decode_include_option_ (char *spec);
 457 static FILE *ffecom_open_include_ (char *name, ffewhereLine l,
 458                                    ffewhereColumn c);
 459 #endif  /* FFECOM_GCC_INCLUDE */
 460
 461 /* Static objects accessed by functions in this module. */
 462
 463 static ffesymbol ffecom_primary_entry_ = NULL;
 464 static ffesymbol ffecom_nested_entry_ = NULL;
 465 static ffeinfoKind ffecom_primary_entry_kind_;
 466 static bool ffecom_primary_entry_is_proc_;
 467 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 468 static tree ffecom_outer_function_decl_;
 469 static tree ffecom_previous_function_decl_;
 470 static tree ffecom_which_entrypoint_decl_;
 471 static tree ffecom_float_zero_ = NULL_TREE;
 472 static tree ffecom_float_half_ = NULL_TREE;
 473 static tree ffecom_double_zero_ = NULL_TREE;
 474 static tree ffecom_double_half_ = NULL_TREE;
 475 static tree ffecom_func_result_;/* For functions. */
 476 static tree ffecom_func_length_;/* For CHARACTER fns. */
 477 static ffebld ffecom_list_blockdata_;
 478 static ffebld ffecom_list_common_;
 479 static ffebld ffecom_master_arglist_;
 480 static ffeinfoBasictype ffecom_master_bt_;
 481 static ffeinfoKindtype ffecom_master_kt_;
 482 static ffetargetCharacterSize ffecom_master_size_;
 483 static int ffecom_num_fns_ = 0;
 484 static int ffecom_num_entrypoints_ = 0;
 485 static bool ffecom_is_altreturning_ = FALSE;
 486 static tree ffecom_multi_type_node_;
 487 static tree ffecom_multi_retval_;
 488 static tree
 489   ffecom_multi_fields_[FFEINFO_basictype][FFEINFO_kindtype];
 490 static bool ffecom_member_namelisted_;  /* _member_phase1_ namelisted? */
 491 static bool ffecom_doing_entry_ = FALSE;
 492 static bool ffecom_transform_only_dummies_ = FALSE;
 493 static int ffecom_typesize_pointer_;
 494 static int ffecom_typesize_integer1_;
 495
 496 /* Holds pointer-to-function expressions.  */
 497
 498 static tree ffecom_gfrt_[FFECOM_gfrt]
 499 =
 500 {
 501 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NULL_TREE,
 502 #include "com-rt.def"
 503 #undef DEFGFRT
 504 };
 505
 506 /* Holds the external names of the functions.  */
 507
 508 static const char *ffecom_gfrt_name_[FFECOM_gfrt]
 509 =
 510 {
 511 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NAME,
 512 #include "com-rt.def"
 513 #undef DEFGFRT
 514 };
 515
 516 /* Whether the function returns.  */
 517
 518 static bool ffecom_gfrt_volatile_[FFECOM_gfrt]
 519 =
 520 {
 521 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) VOLATILE,
 522 #include "com-rt.def"
 523 #undef DEFGFRT
 524 };
 525
 526 /* Whether the function returns type complex.  */
 527
 528 static bool ffecom_gfrt_complex_[FFECOM_gfrt]
 529 =
 530 {
 531 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) COMPLEX,
 532 #include "com-rt.def"
 533 #undef DEFGFRT
 534 };
 535
 536 /* Whether the function is const
 537    (i.e., has no side effects and only depends on its arguments).  */
 538
 539 static bool ffecom_gfrt_const_[FFECOM_gfrt]
 540 =
 541 {
 542 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) CONST,
 543 #include "com-rt.def"
 544 #undef DEFGFRT
 545 };
 546
 547 /* Type code for the function return value.  */
 548
 549 static ffecomRttype_ ffecom_gfrt_type_[FFECOM_gfrt]
 550 =
 551 {
 552 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) TYPE,
 553 #include "com-rt.def"
 554 #undef DEFGFRT
 555 };
 556
 557 /* String of codes for the function's arguments.  */
 558
 559 static const char *ffecom_gfrt_argstring_[FFECOM_gfrt]
 560 =
 561 {
 562 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) ARGS,
 563 #include "com-rt.def"
 564 #undef DEFGFRT
 565 };
 566 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 567
 568 /* Internal macros. */
 569
 570 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 571
 572 /* We let tm.h override the types used here, to handle trivial differences
 573    such as the choice of unsigned int or long unsigned int for size_t.
 574    When machines start needing nontrivial differences in the size type,
 575    it would be best to do something here to figure out automatically
 576    from other information what type to use.  */
 577
 578 #ifndef SIZE_TYPE
 579 #define SIZE_TYPE "long unsigned int"
 580 #endif
 581
 582 #define ffecom_concat_list_count_(catlist) ((catlist).count)
 583 #define ffecom_concat_list_expr_(catlist,i) ((catlist).exprs[(i)])
 584 #define ffecom_concat_list_maxlen_(catlist) ((catlist).maxlen)
 585 #define ffecom_concat_list_minlen_(catlist) ((catlist).minlen)
 586
 587 #define ffecom_char_args_(i,l,e) ffecom_char_args_x_((i),(l),(e),FALSE)
 588 #define ffecom_char_args_with_null_(i,l,e) ffecom_char_args_x_((i),(l),(e),TRUE)
 589
 590 /* For each binding contour we allocate a binding_level structure
 591  * which records the names defined in that contour.
 592  * Contours include:
 593  *  0) the global one
 594  *  1) one for each function definition,
 595  *     where internal declarations of the parameters appear.
 596  *
 597  * The current meaning of a name can be found by searching the levels from
 598  * the current one out to the global one.
 599  */
 600
 601 /* Note that the information in the `names' component of the global contour
 602    is duplicated in the IDENTIFIER_GLOBAL_VALUEs of all identifiers.  */
 603
 604 struct binding_level
 605   {
 606     /* A chain of _DECL nodes for all variables, constants, functions,
 607        and typedef types.  These are in the reverse of the order supplied.
 608      */
 609     tree names;
 610
 611     /* For each level (except not the global one),
 612        a chain of BLOCK nodes for all the levels
 613        that were entered and exited one level down.  */
 614     tree blocks;
 615
 616     /* The BLOCK node for this level, if one has been preallocated.
 617        If 0, the BLOCK is allocated (if needed) when the level is popped.  */
 618     tree this_block;
 619
 620     /* The binding level which this one is contained in (inherits from).  */
 621     struct binding_level *level_chain;
 622
 623     /* 0: no ffecom_prepare_* functions called at this level yet;
 624        1: ffecom_prepare* functions called, except not ffecom_prepare_end;
 625        2: ffecom_prepare_end called.  */
 626     int prep_state;
 627   };
 628
 629 #define NULL_BINDING_LEVEL (struct binding_level *) NULL
 630
 631 /* The binding level currently in effect.  */
 632
 633 static struct binding_level *current_binding_level;
 634
 635 /* A chain of binding_level structures awaiting reuse.  */
 636
 637 static struct binding_level *free_binding_level;
 638
 639 /* The outermost binding level, for names of file scope.
 640    This is created when the compiler is started and exists
 641    through the entire run.  */
 642
 643 static struct binding_level *global_binding_level;
 644
 645 /* Binding level structures are initialized by copying this one.  */
 646
 647 static struct binding_level clear_binding_level
 648 =
 649 {NULL, NULL, NULL, NULL_BINDING_LEVEL, 0};
 650
 651 /* Language-dependent contents of an identifier.  */
 652
 653 struct lang_identifier
 654   {
 655     struct tree_identifier ignore;
 656     tree global_value, local_value, label_value;
 657     bool invented;
 658   };
 659
 660 /* Macros for access to language-specific slots in an identifier.  */
 661 /* Each of these slots contains a DECL node or null.  */
 662
 663 /* This represents the value which the identifier has in the
 664    file-scope namespace.  */
 665 #define IDENTIFIER_GLOBAL_VALUE(NODE)   \
 666   (((struct lang_identifier *)(NODE))->global_value)
 667 /* This represents the value which the identifier has in the current
 668    scope.  */
 669 #define IDENTIFIER_LOCAL_VALUE(NODE)    \
 670   (((struct lang_identifier *)(NODE))->local_value)
 671 /* This represents the value which the identifier has as a label in
 672    the current label scope.  */
 673 #define IDENTIFIER_LABEL_VALUE(NODE)    \
 674   (((struct lang_identifier *)(NODE))->label_value)
 675 /* This is nonzero if the identifier was "made up" by g77 code.  */
 676 #define IDENTIFIER_INVENTED(NODE)       \
 677   (((struct lang_identifier *)(NODE))->invented)
 678
 679 /* In identifiers, C uses the following fields in a special way:
 680    TREE_PUBLIC        to record that there was a previous local extern decl.
 681    TREE_USED          to record that such a decl was used.
 682    TREE_ADDRESSABLE   to record that the address of such a decl was used.  */
 683
 684 /* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function
 685    that have names.  Here so we can clear out their names' definitions
 686    at the end of the function.  */
 687
 688 static tree named_labels;
 689
 690 /* A list of LABEL_DECLs from outer contexts that are currently shadowed.  */
 691
 692 static tree shadowed_labels;
 693
 694 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 695 \f
 696 /* Return the subscript expression, modified to do range-checking.
 697
 698    `array' is the array to be checked against.
 699    `element' is the subscript expression to check.
 700    `dim' is the dimension number (starting at 0).
 701    `total_dims' is the total number of dimensions (0 for CHARACTER substring).
 702 */
 703
 704 static tree
 705 ffecom_subscript_check_ (tree array, tree element, int dim, int total_dims,
 706                          const char *array_name)
 707 {
 708   tree low = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
 709   tree high = TYPE_MAX_VALUE (TYPE_DOMAIN (array));
 710   tree cond;
 711   tree die;
 712   tree args;
 713
 714   if (element == error_mark_node)
 715     return element;
 716
 717   if (TREE_TYPE (low) != TREE_TYPE (element))
 718     {
 719       if (TYPE_PRECISION (TREE_TYPE (low))
 720           > TYPE_PRECISION (TREE_TYPE (element)))
 721         element = convert (TREE_TYPE (low), element);
 722       else
 723         {
 724           low = convert (TREE_TYPE (element), low);
 725           if (high)
 726             high = convert (TREE_TYPE (element), high);
 727         }
 728     }
 729
 730   element = ffecom_save_tree (element);
 731   cond = ffecom_2 (LE_EXPR, integer_type_node,
 732                    low,
 733                    element);
 734   if (high)
 735     {
 736       cond = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
 737                        cond,
 738                        ffecom_2 (LE_EXPR, integer_type_node,
 739                                  element,
 740                                  high));
 741     }
 742
 743   {
 744     int len;
 745     char *proc;
 746     char *var;
 747     tree arg3;
 748     tree arg2;
 749     tree arg1;
 750     tree arg4;
 751
 752     switch (total_dims)
 753       {
 754       case 0:
 755         var = xmalloc (strlen (array_name) + 20);
 756         sprintf (var, "%s[%s-substring]",
 757                  array_name,
 758                  dim ? "end" : "start");
 759         len = strlen (var) + 1;
 760         arg1 = build_string (len, var);
 761         free (var);
 762         break;
 763
 764       case 1:
 765         len = strlen (array_name) + 1;
 766         arg1 = build_string (len, array_name);
 767         break;
 768
 769       default:
 770         var = xmalloc (strlen (array_name) + 40);
 771         sprintf (var, "%s[subscript-%d-of-%d]",
 772                  array_name,
 773                  dim + 1, total_dims);
 774         len = strlen (var) + 1;
 775         arg1 = build_string (len, var);
 776         free (var);
 777         break;
 778       }
 779
 780     TREE_TYPE (arg1)
 781       = build_type_variant (build_array_type (char_type_node,
 782                                               build_range_type
 783                                               (integer_type_node,
 784                                                integer_one_node,
 785                                                build_int_2 (len, 0))),
 786                             1, 0);
 787     TREE_CONSTANT (arg1) = 1;
 788     TREE_STATIC (arg1) = 1;
 789     arg1 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg1)),
 790                      arg1);
 791
 792     /* s_rnge adds one to the element to print it, so bias against
 793        that -- want to print a faithful *subscript* value.  */
 794     arg2 = convert (ffecom_f2c_ftnint_type_node,
 795                     ffecom_2 (MINUS_EXPR,
 796                               TREE_TYPE (element),
 797                               element,
 798                               convert (TREE_TYPE (element),
 799                                        integer_one_node)));
 800
 801     proc = xmalloc ((len = strlen (input_filename)
 802                      + IDENTIFIER_LENGTH (DECL_NAME (current_function_decl))
 803                      + 2));
 804
 805     sprintf (&proc[0], "%s/%s",
 806              input_filename,
 807              IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
 808     arg3 = build_string (len, proc);
 809
 810     free (proc);
 811
 812     TREE_TYPE (arg3)
 813       = build_type_variant (build_array_type (char_type_node,
 814                                               build_range_type
 815                                               (integer_type_node,
 816                                                integer_one_node,
 817                                                build_int_2 (len, 0))),
 818                             1, 0);
 819     TREE_CONSTANT (arg3) = 1;
 820     TREE_STATIC (arg3) = 1;
 821     arg3 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg3)),
 822                      arg3);
 823
 824     arg4 = convert (ffecom_f2c_ftnint_type_node,
 825                     build_int_2 (lineno, 0));
 826
 827     arg1 = build_tree_list (NULL_TREE, arg1);
 828     arg2 = build_tree_list (NULL_TREE, arg2);
 829     arg3 = build_tree_list (NULL_TREE, arg3);
 830     arg4 = build_tree_list (NULL_TREE, arg4);
 831     TREE_CHAIN (arg3) = arg4;
 832     TREE_CHAIN (arg2) = arg3;
 833     TREE_CHAIN (arg1) = arg2;
 834
 835     args = arg1;
 836   }
 837   die = ffecom_call_gfrt (FFECOM_gfrtRANGE,
 838                           args, NULL_TREE);
 839   TREE_SIDE_EFFECTS (die) = 1;
 840
 841   element = ffecom_3 (COND_EXPR,
 842                       TREE_TYPE (element),
 843                       cond,
 844                       element,
 845                       die);
 846
 847   return element;
 848 }
 849
 850 /* Return the computed element of an array reference.
 851
 852    `item' is NULL_TREE, or the transformed pointer to the array.
 853    `expr' is the original opARRAYREF expression, which is transformed
 854      if `item' is NULL_TREE.
 855    `want_ptr' is non-zero if a pointer to the element, instead of
 856      the element itself, is to be returned.  */
 857
 858 static tree
 859 ffecom_arrayref_ (tree item, ffebld expr, int want_ptr)
 860 {
 861   ffebld dims[FFECOM_dimensionsMAX];
 862   int i;
 863   int total_dims;
 864   int flatten = ffe_is_flatten_arrays ();
 865   int need_ptr;
 866   tree array;
 867   tree element;
 868   tree tree_type;
 869   tree tree_type_x;
 870   const char *array_name;
 871   ffetype type;
 872   ffebld list;
 873
 874   if (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER)
 875     array_name = ffesymbol_text (ffebld_symter (ffebld_left (expr)));
 876   else
 877     array_name = "[expr?]";
 878
 879   /* Build up ARRAY_REFs in reverse order (since we're column major
 880      here in Fortran land). */
 881
 882   for (i = 0, list = ffebld_right (expr);
 883        list != NULL;
 884        ++i, list = ffebld_trail (list))
 885     {
 886       dims[i] = ffebld_head (list);
 887       type = ffeinfo_type (ffebld_basictype (dims[i]),
 888                            ffebld_kindtype (dims[i]));
 889       if (! flatten
 890           && ffecom_typesize_pointer_ > ffecom_typesize_integer1_
 891           && ffetype_size (type) > ffecom_typesize_integer1_)
 892         /* E.g. ARRAY(INDEX), given INTEGER*8 INDEX, on a system with 64-bit
 893            pointers and 32-bit integers.  Do the full 64-bit pointer
 894            arithmetic, for codes using arrays for nonstandard heap-like
 895            work.  */
 896         flatten = 1;
 897     }
 898
 899   total_dims = i;
 900
 901   need_ptr = want_ptr || flatten;
 902
 903   if (! item)
 904     {
 905       if (need_ptr)
 906         item = ffecom_ptr_to_expr (ffebld_left (expr));
 907       else
 908         item = ffecom_expr (ffebld_left (expr));
 909
 910       if (item == error_mark_node)
 911         return item;
 912
 913       if (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereFLEETING
 914           && ! mark_addressable (item))
 915         return error_mark_node;
 916     }
 917
 918   if (item == error_mark_node)
 919     return item;
 920
 921   if (need_ptr)
 922     {
 923       tree min;
 924
 925       for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
 926            i >= 0;
 927            --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array)))
 928         {
 929           min = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
 930           element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
 931           if (flag_bounds_check)
 932             element = ffecom_subscript_check_ (array, element, i, total_dims,
 933                                                array_name);
 934           if (element == error_mark_node)
 935             return element;
 936
 937           /* Widen integral arithmetic as desired while preserving
 938              signedness.  */
 939           tree_type = TREE_TYPE (element);
 940           tree_type_x = tree_type;
 941           if (tree_type
 942               && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
 943               && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
 944             tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
 945
 946           if (TREE_TYPE (min) != tree_type_x)
 947             min = convert (tree_type_x, min);
 948           if (TREE_TYPE (element) != tree_type_x)
 949             element = convert (tree_type_x, element);
 950
 951           item = ffecom_2 (PLUS_EXPR,
 952                            build_pointer_type (TREE_TYPE (array)),
 953                            item,
 954                            size_binop (MULT_EXPR,
 955                                        size_in_bytes (TREE_TYPE (array)),
 956                                        convert (sizetype,
 957                                                 fold (build (MINUS_EXPR,
 958                                                              tree_type_x,
 959                                                              element, min)))));
 960         }
 961       if (! want_ptr)
 962         {
 963           item = ffecom_1 (INDIRECT_REF,
 964                            TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
 965                            item);
 966         }
 967     }
 968   else
 969     {
 970       for (--i;
 971            i >= 0;
 972            --i)
 973         {
 974           array = TYPE_MAIN_VARIANT (TREE_TYPE (item));
 975
 976           element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
 977           if (flag_bounds_check)
 978             element = ffecom_subscript_check_ (array, element, i, total_dims,
 979                                                array_name);
 980           if (element == error_mark_node)
 981             return element;
 982
 983           /* Widen integral arithmetic as desired while preserving
 984              signedness.  */
 985           tree_type = TREE_TYPE (element);
 986           tree_type_x = tree_type;
 987           if (tree_type
 988               && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
 989               && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
 990             tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
 991
 992           element = convert (tree_type_x, element);
 993
 994           item = ffecom_2 (ARRAY_REF,
 995                            TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
 996                            item,
 997                            element);
 998         }
 999     }
1000
1001   return item;
1002 }
1003
1004 /* This is like gcc's stabilize_reference -- in fact, most of the code
1005    comes from that -- but it handles the situation where the reference
1006    is going to have its subparts picked at, and it shouldn't change
1007    (or trigger extra invocations of functions in the subtrees) due to
1008    this.  save_expr is a bit overzealous, because we don't need the
1009    entire thing calculated and saved like a temp.  So, for DECLs, no
1010    change is needed, because these are stable aggregates, and ARRAY_REF
1011    and such might well be stable too, but for things like calculations,
1012    we do need to calculate a snapshot of a value before picking at it.  */
1013
1014 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1015 static tree
1016 ffecom_stabilize_aggregate_ (tree ref)
1017 {
1018   tree result;
1019   enum tree_code code = TREE_CODE (ref);
1020
1021   switch (code)
1022     {
1023     case VAR_DECL:
1024     case PARM_DECL:
1025     case RESULT_DECL:
1026       /* No action is needed in this case.  */
1027       return ref;
1028
1029     case NOP_EXPR:
1030     case CONVERT_EXPR:
1031     case FLOAT_EXPR:
1032     case FIX_TRUNC_EXPR:
1033     case FIX_FLOOR_EXPR:
1034     case FIX_ROUND_EXPR:
1035     case FIX_CEIL_EXPR:
1036       result = build_nt (code, stabilize_reference (TREE_OPERAND (ref, 0)));
1037       break;
1038
1039     case INDIRECT_REF:
1040       result = build_nt (INDIRECT_REF,
1041                          stabilize_reference_1 (TREE_OPERAND (ref, 0)));
1042       break;
1043
1044     case COMPONENT_REF:
1045       result = build_nt (COMPONENT_REF,
1046                          stabilize_reference (TREE_OPERAND (ref, 0)),
1047                          TREE_OPERAND (ref, 1));
1048       break;
1049
1050     case BIT_FIELD_REF:
1051       result = build_nt (BIT_FIELD_REF,
1052                          stabilize_reference (TREE_OPERAND (ref, 0)),
1053                          stabilize_reference_1 (TREE_OPERAND (ref, 1)),
1054                          stabilize_reference_1 (TREE_OPERAND (ref, 2)));
1055       break;
1056
1057     case ARRAY_REF:
1058       result = build_nt (ARRAY_REF,
1059                          stabilize_reference (TREE_OPERAND (ref, 0)),
1060                          stabilize_reference_1 (TREE_OPERAND (ref, 1)));
1061       break;
1062
1063     case COMPOUND_EXPR:
1064       result = build_nt (COMPOUND_EXPR,
1065                          stabilize_reference_1 (TREE_OPERAND (ref, 0)),
1066                          stabilize_reference (TREE_OPERAND (ref, 1)));
1067       break;
1068
1069     case RTL_EXPR:
1070       abort ();
1071
1072
1073     default:
1074       return save_expr (ref);
1075
1076     case ERROR_MARK:
1077       return error_mark_node;
1078     }
1079
1080   TREE_TYPE (result) = TREE_TYPE (ref);
1081   TREE_READONLY (result) = TREE_READONLY (ref);
1082   TREE_SIDE_EFFECTS (result) = TREE_SIDE_EFFECTS (ref);
1083   TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref);
1084
1085   return result;
1086 }
1087 #endif
1088
1089 /* A rip-off of gcc's convert.c convert_to_complex function,
1090    reworked to handle complex implemented as C structures
1091    (RECORD_TYPE with two fields, real and imaginary `r' and `i').  */
1092
1093 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1094 static tree
1095 ffecom_convert_to_complex_ (tree type, tree expr)
1096 {
1097   register enum tree_code form = TREE_CODE (TREE_TYPE (expr));
1098   tree subtype;
1099
1100   assert (TREE_CODE (type) == RECORD_TYPE);
1101
1102   subtype = TREE_TYPE (TYPE_FIELDS (type));
1103
1104   if (form == REAL_TYPE || form == INTEGER_TYPE || form == ENUMERAL_TYPE)
1105     {
1106       expr = convert (subtype, expr);
1107       return ffecom_2 (COMPLEX_EXPR, type, expr,
1108                        convert (subtype, integer_zero_node));
1109     }
1110
1111   if (form == RECORD_TYPE)
1112     {
1113       tree elt_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr)));
1114       if (TYPE_MAIN_VARIANT (elt_type) == TYPE_MAIN_VARIANT (subtype))
1115         return expr;
1116       else
1117         {
1118           expr = save_expr (expr);
1119           return ffecom_2 (COMPLEX_EXPR,
1120                            type,
1121                            convert (subtype,
1122                                     ffecom_1 (REALPART_EXPR,
1123                                               TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1124                                               expr)),
1125                            convert (subtype,
1126                                     ffecom_1 (IMAGPART_EXPR,
1127                                               TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1128                                               expr)));
1129         }
1130     }
1131
1132   if (form == POINTER_TYPE || form == REFERENCE_TYPE)
1133     error ("pointer value used where a complex was expected");
1134   else
1135     error ("aggregate value used where a complex was expected");
1136
1137   return ffecom_2 (COMPLEX_EXPR, type,
1138                    convert (subtype, integer_zero_node),
1139                    convert (subtype, integer_zero_node));
1140 }
1141 #endif
1142
1143 /* Like gcc's convert(), but crashes if widening might happen.  */
1144
1145 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1146 static tree
1147 ffecom_convert_narrow_ (type, expr)
1148      tree type, expr;
1149 {
1150   register tree e = expr;
1151   register enum tree_code code = TREE_CODE (type);
1152
1153   if (type == TREE_TYPE (e)
1154       || TREE_CODE (e) == ERROR_MARK)
1155     return e;
1156   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1157     return fold (build1 (NOP_EXPR, type, e));
1158   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1159       || code == ERROR_MARK)
1160     return error_mark_node;
1161   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1162     {
1163       assert ("void value not ignored as it ought to be" == NULL);
1164       return error_mark_node;
1165     }
1166   assert (code != VOID_TYPE);
1167   if ((code != RECORD_TYPE)
1168       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1169     assert ("converting COMPLEX to REAL" == NULL);
1170   assert (code != ENUMERAL_TYPE);
1171   if (code == INTEGER_TYPE)
1172     {
1173       assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1174                && TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)))
1175               || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1176                   && (TYPE_PRECISION (type)
1177                       == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1178       return fold (convert_to_integer (type, e));
1179     }
1180   if (code == POINTER_TYPE)
1181     {
1182       assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1183       return fold (convert_to_pointer (type, e));
1184     }
1185   if (code == REAL_TYPE)
1186     {
1187       assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1188       assert (TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)));
1189       return fold (convert_to_real (type, e));
1190     }
1191   if (code == COMPLEX_TYPE)
1192     {
1193       assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1194       assert (TYPE_PRECISION (TREE_TYPE (type)) <= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1195       return fold (convert_to_complex (type, e));
1196     }
1197   if (code == RECORD_TYPE)
1198     {
1199       assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1200       /* Check that at least the first field name agrees.  */
1201       assert (DECL_NAME (TYPE_FIELDS (type))
1202               == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1203       assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1204               <= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1205       if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1206           == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1207         return e;
1208       return fold (ffecom_convert_to_complex_ (type, e));
1209     }
1210
1211   assert ("conversion to non-scalar type requested" == NULL);
1212   return error_mark_node;
1213 }
1214 #endif
1215
1216 /* Like gcc's convert(), but crashes if narrowing might happen.  */
1217
1218 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1219 static tree
1220 ffecom_convert_widen_ (type, expr)
1221      tree type, expr;
1222 {
1223   register tree e = expr;
1224   register enum tree_code code = TREE_CODE (type);
1225
1226   if (type == TREE_TYPE (e)
1227       || TREE_CODE (e) == ERROR_MARK)
1228     return e;
1229   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1230     return fold (build1 (NOP_EXPR, type, e));
1231   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1232       || code == ERROR_MARK)
1233     return error_mark_node;
1234   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1235     {
1236       assert ("void value not ignored as it ought to be" == NULL);
1237       return error_mark_node;
1238     }
1239   assert (code != VOID_TYPE);
1240   if ((code != RECORD_TYPE)
1241       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1242     assert ("narrowing COMPLEX to REAL" == NULL);
1243   assert (code != ENUMERAL_TYPE);
1244   if (code == INTEGER_TYPE)
1245     {
1246       assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1247                && TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)))
1248               || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1249                   && (TYPE_PRECISION (type)
1250                       == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1251       return fold (convert_to_integer (type, e));
1252     }
1253   if (code == POINTER_TYPE)
1254     {
1255       assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1256       return fold (convert_to_pointer (type, e));
1257     }
1258   if (code == REAL_TYPE)
1259     {
1260       assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1261       assert (TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)));
1262       return fold (convert_to_real (type, e));
1263     }
1264   if (code == COMPLEX_TYPE)
1265     {
1266       assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1267       assert (TYPE_PRECISION (TREE_TYPE (type)) >= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1268       return fold (convert_to_complex (type, e));
1269     }
1270   if (code == RECORD_TYPE)
1271     {
1272       assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1273       /* Check that at least the first field name agrees.  */
1274       assert (DECL_NAME (TYPE_FIELDS (type))
1275               == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1276       assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1277               >= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1278       if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1279           == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1280         return e;
1281       return fold (ffecom_convert_to_complex_ (type, e));
1282     }
1283
1284   assert ("conversion to non-scalar type requested" == NULL);
1285   return error_mark_node;
1286 }
1287 #endif
1288
1289 /* Handles making a COMPLEX type, either the standard
1290    (but buggy?) gbe way, or the safer (but less elegant?)
1291    f2c way.  */
1292
1293 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1294 static tree
1295 ffecom_make_complex_type_ (tree subtype)
1296 {
1297   tree type;
1298   tree realfield;
1299   tree imagfield;
1300
1301   if (ffe_is_emulate_complex ())
1302     {
1303       type = make_node (RECORD_TYPE);
1304       realfield = ffecom_decl_field (type, NULL_TREE, "r", subtype);
1305       imagfield = ffecom_decl_field (type, realfield, "i", subtype);
1306       TYPE_FIELDS (type) = realfield;
1307       layout_type (type);
1308     }
1309   else
1310     {
1311       type = make_node (COMPLEX_TYPE);
1312       TREE_TYPE (type) = subtype;
1313       layout_type (type);
1314     }
1315
1316   return type;
1317 }
1318 #endif
1319
1320 /* Chooses either the gbe or the f2c way to build a
1321    complex constant.  */
1322
1323 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1324 static tree
1325 ffecom_build_complex_constant_ (tree type, tree realpart, tree imagpart)
1326 {
1327   tree bothparts;
1328
1329   if (ffe_is_emulate_complex ())
1330     {
1331       bothparts = build_tree_list (TYPE_FIELDS (type), realpart);
1332       TREE_CHAIN (bothparts) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), imagpart);
1333       bothparts = build (CONSTRUCTOR, type, NULL_TREE, bothparts);
1334     }
1335   else
1336     {
1337       bothparts = build_complex (type, realpart, imagpart);
1338     }
1339
1340   return bothparts;
1341 }
1342 #endif
1343
1344 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1345 static tree
1346 ffecom_arglist_expr_ (const char *c, ffebld expr)
1347 {
1348   tree list;
1349   tree *plist = &list;
1350   tree trail = NULL_TREE;       /* Append char length args here. */
1351   tree *ptrail = &trail;
1352   tree length;
1353   ffebld exprh;
1354   tree item;
1355   bool ptr = FALSE;
1356   tree wanted = NULL_TREE;
1357   static char zed[] = "0";
1358
1359   if (c == NULL)
1360     c = &zed[0];
1361
1362   while (expr != NULL)
1363     {
1364       if (*c != '\0')
1365         {
1366           ptr = FALSE;
1367           if (*c == '&')
1368             {
1369               ptr = TRUE;
1370               ++c;
1371             }
1372           switch (*(c++))
1373             {
1374             case '\0':
1375               ptr = TRUE;
1376               wanted = NULL_TREE;
1377               break;
1378
1379             case 'a':
1380               assert (ptr);
1381               wanted = NULL_TREE;
1382               break;
1383
1384             case 'c':
1385               wanted = ffecom_f2c_complex_type_node;
1386               break;
1387
1388             case 'd':
1389               wanted = ffecom_f2c_doublereal_type_node;
1390               break;
1391
1392             case 'e':
1393               wanted = ffecom_f2c_doublecomplex_type_node;
1394               break;
1395
1396             case 'f':
1397               wanted = ffecom_f2c_real_type_node;
1398               break;
1399
1400             case 'i':
1401               wanted = ffecom_f2c_integer_type_node;
1402               break;
1403
1404             case 'j':
1405               wanted = ffecom_f2c_longint_type_node;
1406               break;
1407
1408             default:
1409               assert ("bad argstring code" == NULL);
1410               wanted = NULL_TREE;
1411               break;
1412             }
1413         }
1414
1415       exprh = ffebld_head (expr);
1416       if (exprh == NULL)
1417         wanted = NULL_TREE;
1418
1419       if ((wanted == NULL_TREE)
1420           || (ptr
1421               && (TYPE_MODE
1422                   (ffecom_tree_type[ffeinfo_basictype (ffebld_info (exprh))]
1423                    [ffeinfo_kindtype (ffebld_info (exprh))])
1424                    == TYPE_MODE (wanted))))
1425         *plist
1426           = build_tree_list (NULL_TREE,
1427                              ffecom_arg_ptr_to_expr (exprh,
1428                                                      &length));
1429       else
1430         {
1431           item = ffecom_arg_expr (exprh, &length);
1432           item = ffecom_convert_widen_ (wanted, item);
1433           if (ptr)
1434             {
1435               item = ffecom_1 (ADDR_EXPR,
1436                                build_pointer_type (TREE_TYPE (item)),
1437                                item);
1438             }
1439           *plist
1440             = build_tree_list (NULL_TREE,
1441                                item);
1442         }
1443
1444       plist = &TREE_CHAIN (*plist);
1445       expr = ffebld_trail (expr);
1446       if (length != NULL_TREE)
1447         {
1448           *ptrail = build_tree_list (NULL_TREE, length);
1449           ptrail = &TREE_CHAIN (*ptrail);
1450         }
1451     }
1452
1453   /* We've run out of args in the call; if the implementation expects
1454      more, supply null pointers for them, which the implementation can
1455      check to see if an arg was omitted. */
1456
1457   while (*c != '\0' && *c != '0')
1458     {
1459       if (*c == '&')
1460         ++c;
1461       else
1462         assert ("missing arg to run-time routine!" == NULL);
1463
1464       switch (*(c++))
1465         {
1466         case '\0':
1467         case 'a':
1468         case 'c':
1469         case 'd':
1470         case 'e':
1471         case 'f':
1472         case 'i':
1473         case 'j':
1474           break;
1475
1476         default:
1477           assert ("bad arg string code" == NULL);
1478           break;
1479         }
1480       *plist
1481         = build_tree_list (NULL_TREE,
1482                            null_pointer_node);
1483       plist = &TREE_CHAIN (*plist);
1484     }
1485
1486   *plist = trail;
1487
1488   return list;
1489 }
1490 #endif
1491
1492 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1493 static tree
1494 ffecom_widest_expr_type_ (ffebld list)
1495 {
1496   ffebld item;
1497   ffebld widest = NULL;
1498   ffetype type;
1499   ffetype widest_type = NULL;
1500   tree t;
1501
1502   for (; list != NULL; list = ffebld_trail (list))
1503     {
1504       item = ffebld_head (list);
1505       if (item == NULL)
1506         continue;
1507       if ((widest != NULL)
1508           && (ffeinfo_basictype (ffebld_info (item))
1509               != ffeinfo_basictype (ffebld_info (widest))))
1510         continue;
1511       type = ffeinfo_type (ffeinfo_basictype (ffebld_info (item)),
1512                            ffeinfo_kindtype (ffebld_info (item)));
1513       if ((widest == FFEINFO_kindtypeNONE)
1514           || (ffetype_size (type)
1515               > ffetype_size (widest_type)))
1516         {
1517           widest = item;
1518           widest_type = type;
1519         }
1520     }
1521
1522   assert (widest != NULL);
1523   t = ffecom_tree_type[ffeinfo_basictype (ffebld_info (widest))]
1524     [ffeinfo_kindtype (ffebld_info (widest))];
1525   assert (t != NULL_TREE);
1526   return t;
1527 }
1528 #endif
1529
1530 /* Check whether a partial overlap between two expressions is possible.
1531
1532    Can *starting* to write a portion of expr1 change the value
1533    computed (perhaps already, *partially*) by expr2?
1534
1535    Currently, this is a concern only for a COMPLEX expr1.  But if it
1536    isn't in COMMON or local EQUIVALENCE, since we don't support
1537    aliasing of arguments, it isn't a concern.  */
1538
1539 static bool
1540 ffecom_possible_partial_overlap_ (ffebld expr1, ffebld expr2 ATTRIBUTE_UNUSED)
1541 {
1542   ffesymbol sym;
1543   ffestorag st;
1544
1545   switch (ffebld_op (expr1))
1546     {
1547     case FFEBLD_opSYMTER:
1548       sym = ffebld_symter (expr1);
1549       break;
1550
1551     case FFEBLD_opARRAYREF:
1552       if (ffebld_op (ffebld_left (expr1)) != FFEBLD_opSYMTER)
1553         return FALSE;
1554       sym = ffebld_symter (ffebld_left (expr1));
1555       break;
1556
1557     default:
1558       return FALSE;
1559     }
1560
1561   if (ffesymbol_where (sym) != FFEINFO_whereCOMMON
1562       && (ffesymbol_where (sym) != FFEINFO_whereLOCAL
1563           || ! (st = ffesymbol_storage (sym))
1564           || ! ffestorag_parent (st)))
1565     return FALSE;
1566
1567   /* It's in COMMON or local EQUIVALENCE.  */
1568
1569   return TRUE;
1570 }
1571
1572 /* Check whether dest and source might overlap.  ffebld versions of these
1573    might or might not be passed, will be NULL if not.
1574
1575    The test is really whether source_tree is modifiable and, if modified,
1576    might overlap destination such that the value(s) in the destination might
1577    change before it is finally modified.  dest_* are the canonized
1578    destination itself.  */
1579
1580 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1581 static bool
1582 ffecom_overlap_ (tree dest_decl, tree dest_offset, tree dest_size,
1583                  tree source_tree, ffebld source UNUSED,
1584                  bool scalar_arg)
1585 {
1586   tree source_decl;
1587   tree source_offset;
1588   tree source_size;
1589   tree t;
1590
1591   if (source_tree == NULL_TREE)
1592     return FALSE;
1593
1594   switch (TREE_CODE (source_tree))
1595     {
1596     case ERROR_MARK:
1597     case IDENTIFIER_NODE:
1598     case INTEGER_CST:
1599     case REAL_CST:
1600     case COMPLEX_CST:
1601     case STRING_CST:
1602     case CONST_DECL:
1603     case VAR_DECL:
1604     case RESULT_DECL:
1605     case FIELD_DECL:
1606     case MINUS_EXPR:
1607     case MULT_EXPR:
1608     case TRUNC_DIV_EXPR:
1609     case CEIL_DIV_EXPR:
1610     case FLOOR_DIV_EXPR:
1611     case ROUND_DIV_EXPR:
1612     case TRUNC_MOD_EXPR:
1613     case CEIL_MOD_EXPR:
1614     case FLOOR_MOD_EXPR:
1615     case ROUND_MOD_EXPR:
1616     case RDIV_EXPR:
1617     case EXACT_DIV_EXPR:
1618     case FIX_TRUNC_EXPR:
1619     case FIX_CEIL_EXPR:
1620     case FIX_FLOOR_EXPR:
1621     case FIX_ROUND_EXPR:
1622     case FLOAT_EXPR:
1623     case EXPON_EXPR:
1624     case NEGATE_EXPR:
1625     case MIN_EXPR:
1626     case MAX_EXPR:
1627     case ABS_EXPR:
1628     case FFS_EXPR:
1629     case LSHIFT_EXPR:
1630     case RSHIFT_EXPR:
1631     case LROTATE_EXPR:
1632     case RROTATE_EXPR:
1633     case BIT_IOR_EXPR:
1634     case BIT_XOR_EXPR:
1635     case BIT_AND_EXPR:
1636     case BIT_ANDTC_EXPR:
1637     case BIT_NOT_EXPR:
1638     case TRUTH_ANDIF_EXPR:
1639     case TRUTH_ORIF_EXPR:
1640     case TRUTH_AND_EXPR:
1641     case TRUTH_OR_EXPR:
1642     case TRUTH_XOR_EXPR:
1643     case TRUTH_NOT_EXPR:
1644     case LT_EXPR:
1645     case LE_EXPR:
1646     case GT_EXPR:
1647     case GE_EXPR:
1648     case EQ_EXPR:
1649     case NE_EXPR:
1650     case COMPLEX_EXPR:
1651     case CONJ_EXPR:
1652     case REALPART_EXPR:
1653     case IMAGPART_EXPR:
1654     case LABEL_EXPR:
1655     case COMPONENT_REF:
1656       return FALSE;
1657
1658     case COMPOUND_EXPR:
1659       return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1660                               TREE_OPERAND (source_tree, 1), NULL,
1661                               scalar_arg);
1662
1663     case MODIFY_EXPR:
1664       return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1665                               TREE_OPERAND (source_tree, 0), NULL,
1666                               scalar_arg);
1667
1668     case CONVERT_EXPR:
1669     case NOP_EXPR:
1670     case NON_LVALUE_EXPR:
1671     case PLUS_EXPR:
1672       if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1673         return TRUE;
1674
1675       ffecom_tree_canonize_ptr_ (&source_decl, &source_offset,
1676                                  source_tree);
1677       source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1678       break;
1679
1680     case COND_EXPR:
1681       return
1682         ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1683                          TREE_OPERAND (source_tree, 1), NULL,
1684                          scalar_arg)
1685           || ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1686                               TREE_OPERAND (source_tree, 2), NULL,
1687                               scalar_arg);
1688
1689
1690     case ADDR_EXPR:
1691       ffecom_tree_canonize_ref_ (&source_decl, &source_offset,
1692                                  &source_size,
1693                                  TREE_OPERAND (source_tree, 0));
1694       break;
1695
1696     case PARM_DECL:
1697       if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1698         return TRUE;
1699
1700       source_decl = source_tree;
1701       source_offset = bitsize_zero_node;
1702       source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1703       break;
1704
1705     case SAVE_EXPR:
1706     case REFERENCE_EXPR:
1707     case PREDECREMENT_EXPR:
1708     case PREINCREMENT_EXPR:
1709     case POSTDECREMENT_EXPR:
1710     case POSTINCREMENT_EXPR:
1711     case INDIRECT_REF:
1712     case ARRAY_REF:
1713     case CALL_EXPR:
1714     default:
1715       return TRUE;
1716     }
1717
1718   /* Come here when source_decl, source_offset, and source_size filled
1719      in appropriately.  */
1720
1721   if (source_decl == NULL_TREE)
1722     return FALSE;               /* No decl involved, so no overlap. */
1723
1724   if (source_decl != dest_decl)
1725     return FALSE;               /* Different decl, no overlap. */
1726
1727   if (TREE_CODE (dest_size) == ERROR_MARK)
1728     return TRUE;                /* Assignment into entire assumed-size
1729                                    array?  Shouldn't happen.... */
1730
1731   t = ffecom_2 (LE_EXPR, integer_type_node,
1732                 ffecom_2 (PLUS_EXPR, TREE_TYPE (dest_offset),
1733                           dest_offset,
1734                           convert (TREE_TYPE (dest_offset),
1735                                    dest_size)),
1736                 convert (TREE_TYPE (dest_offset),
1737                          source_offset));
1738
1739   if (integer_onep (t))
1740     return FALSE;               /* Destination precedes source. */
1741
1742   if (!scalar_arg
1743       || (source_size == NULL_TREE)
1744       || (TREE_CODE (source_size) == ERROR_MARK)
1745       || integer_zerop (source_size))
1746     return TRUE;                /* No way to tell if dest follows source. */
1747
1748   t = ffecom_2 (LE_EXPR, integer_type_node,
1749                 ffecom_2 (PLUS_EXPR, TREE_TYPE (source_offset),
1750                           source_offset,
1751                           convert (TREE_TYPE (source_offset),
1752                                    source_size)),
1753                 convert (TREE_TYPE (source_offset),
1754                          dest_offset));
1755
1756   if (integer_onep (t))
1757     return FALSE;               /* Destination follows source. */
1758
1759   return TRUE;          /* Destination and source overlap. */
1760 }
1761 #endif
1762
1763 /* Check whether dest might overlap any of a list of arguments or is
1764    in a COMMON area the callee might know about (and thus modify).  */
1765
1766 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1767 static bool
1768 ffecom_args_overlapping_ (tree dest_tree, ffebld dest UNUSED,
1769                           tree args, tree callee_commons,
1770                           bool scalar_args)
1771 {
1772   tree arg;
1773   tree dest_decl;
1774   tree dest_offset;
1775   tree dest_size;
1776
1777   ffecom_tree_canonize_ref_ (&dest_decl, &dest_offset, &dest_size,
1778                              dest_tree);
1779
1780   if (dest_decl == NULL_TREE)
1781     return FALSE;               /* Seems unlikely! */
1782
1783   /* If the decl cannot be determined reliably, or if its in COMMON
1784      and the callee isn't known to not futz with COMMON via other
1785      means, overlap might happen.  */
1786
1787   if ((TREE_CODE (dest_decl) == ERROR_MARK)
1788       || ((callee_commons != NULL_TREE)
1789           && TREE_PUBLIC (dest_decl)))
1790     return TRUE;
1791
1792   for (; args != NULL_TREE; args = TREE_CHAIN (args))
1793     {
1794       if (((arg = TREE_VALUE (args)) != NULL_TREE)
1795           && ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1796                               arg, NULL, scalar_args))
1797         return TRUE;
1798     }
1799
1800   return FALSE;
1801 }
1802 #endif
1803
1804 /* Build a string for a variable name as used by NAMELIST.  This means that
1805    if we're using the f2c library, we build an uppercase string, since
1806    f2c does this.  */
1807
1808 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1809 static tree
1810 ffecom_build_f2c_string_ (int i, const char *s)
1811 {
1812   if (!ffe_is_f2c_library ())
1813     return build_string (i, s);
1814
1815   {
1816     char *tmp;
1817     const char *p;
1818     char *q;
1819     char space[34];
1820     tree t;
1821
1822     if (((size_t) i) > ARRAY_SIZE (space))
1823       tmp = malloc_new_ks (malloc_pool_image (), "f2c_string", i);
1824     else
1825       tmp = &space[0];
1826
1827     for (p = s, q = tmp; *p != '\0'; ++p, ++q)
1828       *q = TOUPPER (*p);
1829     *q = '\0';
1830
1831     t = build_string (i, tmp);
1832
1833     if (((size_t) i) > ARRAY_SIZE (space))
1834       malloc_kill_ks (malloc_pool_image (), tmp, i);
1835
1836     return t;
1837   }
1838 }
1839
1840 #endif
1841 /* Returns CALL_EXPR or equivalent with given type (pass NULL_TREE for
1842    type to just get whatever the function returns), handling the
1843    f2c value-returning convention, if required, by prepending
1844    to the arglist a pointer to a temporary to receive the return value.  */
1845
1846 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1847 static tree
1848 ffecom_call_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1849               tree type, tree args, tree dest_tree,
1850               ffebld dest, bool *dest_used, tree callee_commons,
1851               bool scalar_args, tree hook)
1852 {
1853   tree item;
1854   tree tempvar;
1855
1856   if (dest_used != NULL)
1857     *dest_used = FALSE;
1858
1859   if (is_f2c_complex)
1860     {
1861       if ((dest_used == NULL)
1862           || (dest == NULL)
1863           || (ffeinfo_basictype (ffebld_info (dest))
1864               != FFEINFO_basictypeCOMPLEX)
1865           || (ffeinfo_kindtype (ffebld_info (dest)) != kt)
1866           || ((type != NULL_TREE) && (TREE_TYPE (dest_tree) != type))
1867           || ffecom_args_overlapping_ (dest_tree, dest, args,
1868                                        callee_commons,
1869                                        scalar_args))
1870         {
1871 #ifdef HOHO
1872           tempvar = ffecom_make_tempvar (ffecom_tree_type
1873                                          [FFEINFO_basictypeCOMPLEX][kt],
1874                                          FFETARGET_charactersizeNONE,
1875                                          -1);
1876 #else
1877           tempvar = hook;
1878           assert (tempvar);
1879 #endif
1880         }
1881       else
1882         {
1883           *dest_used = TRUE;
1884           tempvar = dest_tree;
1885           type = NULL_TREE;
1886         }
1887
1888       item
1889         = build_tree_list (NULL_TREE,
1890                            ffecom_1 (ADDR_EXPR,
1891                                      build_pointer_type (TREE_TYPE (tempvar)),
1892                                      tempvar));
1893       TREE_CHAIN (item) = args;
1894
1895       item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1896                         item, NULL_TREE);
1897
1898       if (tempvar != dest_tree)
1899         item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item, tempvar);
1900     }
1901   else
1902     item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1903                       args, NULL_TREE);
1904
1905   if ((type != NULL_TREE) && (TREE_TYPE (item) != type))
1906     item = ffecom_convert_narrow_ (type, item);
1907
1908   return item;
1909 }
1910 #endif
1911
1912 /* Given two arguments, transform them and make a call to the given
1913    function via ffecom_call_.  */
1914
1915 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1916 static tree
1917 ffecom_call_binop_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1918                     tree type, ffebld left, ffebld right,
1919                     tree dest_tree, ffebld dest, bool *dest_used,
1920                     tree callee_commons, bool scalar_args, bool ref, tree hook)
1921 {
1922   tree left_tree;
1923   tree right_tree;
1924   tree left_length;
1925   tree right_length;
1926
1927   if (ref)
1928     {
1929       /* Pass arguments by reference.  */
1930       left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
1931       right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
1932     }
1933   else
1934     {
1935       /* Pass arguments by value.  */
1936       left_tree = ffecom_arg_expr (left, &left_length);
1937       right_tree = ffecom_arg_expr (right, &right_length);
1938     }
1939
1940
1941   left_tree = build_tree_list (NULL_TREE, left_tree);
1942   right_tree = build_tree_list (NULL_TREE, right_tree);
1943   TREE_CHAIN (left_tree) = right_tree;
1944
1945   if (left_length != NULL_TREE)
1946     {
1947       left_length = build_tree_list (NULL_TREE, left_length);
1948       TREE_CHAIN (right_tree) = left_length;
1949     }
1950
1951   if (right_length != NULL_TREE)
1952     {
1953       right_length = build_tree_list (NULL_TREE, right_length);
1954       if (left_length != NULL_TREE)
1955         TREE_CHAIN (left_length) = right_length;
1956       else
1957         TREE_CHAIN (right_tree) = right_length;
1958     }
1959
1960   return ffecom_call_ (fn, kt, is_f2c_complex, type, left_tree,
1961                        dest_tree, dest, dest_used, callee_commons,
1962                        scalar_args, hook);
1963 }
1964 #endif
1965
1966 /* Return ptr/length args for char subexpression
1967
1968    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
1969    subexpressions by constructing the appropriate trees for the ptr-to-
1970    character-text and length-of-character-text arguments in a calling
1971    sequence.
1972
1973    Note that if with_null is TRUE, and the expression is an opCONTER,
1974    a null byte is appended to the string.  */
1975
1976 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1977 static void
1978 ffecom_char_args_x_ (tree *xitem, tree *length, ffebld expr, bool with_null)
1979 {
1980   tree item;
1981   tree high;
1982   ffetargetCharacter1 val;
1983   ffetargetCharacterSize newlen;
1984
1985   switch (ffebld_op (expr))
1986     {
1987     case FFEBLD_opCONTER:
1988       val = ffebld_constant_character1 (ffebld_conter (expr));
1989       newlen = ffetarget_length_character1 (val);
1990       if (with_null)
1991         {
1992           /* Begin FFETARGET-NULL-KLUDGE.  */
1993           if (newlen != 0)
1994             ++newlen;
1995         }
1996       *length = build_int_2 (newlen, 0);
1997       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
1998       high = build_int_2 (newlen, 0);
1999       TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
2000       item = build_string (newlen,
2001                            ffetarget_text_character1 (val));
2002       /* End FFETARGET-NULL-KLUDGE.  */
2003       TREE_TYPE (item)
2004         = build_type_variant
2005           (build_array_type
2006            (char_type_node,
2007             build_range_type
2008             (ffecom_f2c_ftnlen_type_node,
2009              ffecom_f2c_ftnlen_one_node,
2010              high)),
2011            1, 0);
2012       TREE_CONSTANT (item) = 1;
2013       TREE_STATIC (item) = 1;
2014       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
2015                        item);
2016       break;
2017
2018     case FFEBLD_opSYMTER:
2019       {
2020         ffesymbol s = ffebld_symter (expr);
2021
2022         item = ffesymbol_hook (s).decl_tree;
2023         if (item == NULL_TREE)
2024           {
2025             s = ffecom_sym_transform_ (s);
2026             item = ffesymbol_hook (s).decl_tree;
2027           }
2028         if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
2029           {
2030             if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
2031               *length = ffesymbol_hook (s).length_tree;
2032             else
2033               {
2034                 *length = build_int_2 (ffesymbol_size (s), 0);
2035                 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2036               }
2037           }
2038         else if (item == error_mark_node)
2039           *length = error_mark_node;
2040         else
2041           /* FFEINFO_kindFUNCTION.  */
2042           *length = NULL_TREE;
2043         if (!ffesymbol_hook (s).addr
2044             && (item != error_mark_node))
2045           item = ffecom_1 (ADDR_EXPR,
2046                            build_pointer_type (TREE_TYPE (item)),
2047                            item);
2048       }
2049       break;
2050
2051     case FFEBLD_opARRAYREF:
2052       {
2053         ffecom_char_args_ (&item, length, ffebld_left (expr));
2054
2055         if (item == error_mark_node || *length == error_mark_node)
2056           {
2057             item = *length = error_mark_node;
2058             break;
2059           }
2060
2061         item = ffecom_arrayref_ (item, expr, 1);
2062       }
2063       break;
2064
2065     case FFEBLD_opSUBSTR:
2066       {
2067         ffebld start;
2068         ffebld end;
2069         ffebld thing = ffebld_right (expr);
2070         tree start_tree;
2071         tree end_tree;
2072         const char *char_name;
2073         ffebld left_symter;
2074         tree array;
2075
2076         assert (ffebld_op (thing) == FFEBLD_opITEM);
2077         start = ffebld_head (thing);
2078         thing = ffebld_trail (thing);
2079         assert (ffebld_trail (thing) == NULL);
2080         end = ffebld_head (thing);
2081
2082         /* Determine name for pretty-printing range-check errors.  */
2083         for (left_symter = ffebld_left (expr);
2084              left_symter && ffebld_op (left_symter) == FFEBLD_opARRAYREF;
2085              left_symter = ffebld_left (left_symter))
2086           ;
2087         if (ffebld_op (left_symter) == FFEBLD_opSYMTER)
2088           char_name = ffesymbol_text (ffebld_symter (left_symter));
2089         else
2090           char_name = "[expr?]";
2091
2092         ffecom_char_args_ (&item, length, ffebld_left (expr));
2093
2094         if (item == error_mark_node || *length == error_mark_node)
2095           {
2096             item = *length = error_mark_node;
2097             break;
2098           }
2099
2100         array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
2101
2102         /* ~~~~Handle INTEGER*8 start/end, a la FFEBLD_opARRAYREF.  */
2103
2104         if (start == NULL)
2105           {
2106             if (end == NULL)
2107               ;
2108             else
2109               {
2110                 end_tree = ffecom_expr (end);
2111                 if (flag_bounds_check)
2112                   end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2113                                                       char_name);
2114                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2115                                     end_tree);
2116
2117                 if (end_tree == error_mark_node)
2118                   {
2119                     item = *length = error_mark_node;
2120                     break;
2121                   }
2122
2123                 *length = end_tree;
2124               }
2125           }
2126         else
2127           {
2128             start_tree = ffecom_expr (start);
2129             if (flag_bounds_check)
2130               start_tree = ffecom_subscript_check_ (array, start_tree, 0, 0,
2131                                                     char_name);
2132             start_tree = convert (ffecom_f2c_ftnlen_type_node,
2133                                   start_tree);
2134
2135             if (start_tree == error_mark_node)
2136               {
2137                 item = *length = error_mark_node;
2138                 break;
2139               }
2140
2141             start_tree = ffecom_save_tree (start_tree);
2142
2143             item = ffecom_2 (PLUS_EXPR, TREE_TYPE (item),
2144                              item,
2145                              ffecom_2 (MINUS_EXPR,
2146                                        TREE_TYPE (start_tree),
2147                                        start_tree,
2148                                        ffecom_f2c_ftnlen_one_node));
2149
2150             if (end == NULL)
2151               {
2152                 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2153                                     ffecom_f2c_ftnlen_one_node,
2154                                     ffecom_2 (MINUS_EXPR,
2155                                               ffecom_f2c_ftnlen_type_node,
2156                                               *length,
2157                                               start_tree));
2158               }
2159             else
2160               {
2161                 end_tree = ffecom_expr (end);
2162                 if (flag_bounds_check)
2163                   end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2164                                                       char_name);
2165                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2166                                     end_tree);
2167
2168                 if (end_tree == error_mark_node)
2169                   {
2170                     item = *length = error_mark_node;
2171                     break;
2172                   }
2173
2174                 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2175                                     ffecom_f2c_ftnlen_one_node,
2176                                     ffecom_2 (MINUS_EXPR,
2177                                               ffecom_f2c_ftnlen_type_node,
2178                                               end_tree, start_tree));
2179               }
2180           }
2181       }
2182       break;
2183
2184     case FFEBLD_opFUNCREF:
2185       {
2186         ffesymbol s = ffebld_symter (ffebld_left (expr));
2187         tree tempvar;
2188         tree args;
2189         ffetargetCharacterSize size = ffeinfo_size (ffebld_info (expr));
2190         ffecomGfrt ix;
2191
2192         if (size == FFETARGET_charactersizeNONE)
2193           /* ~~Kludge alert!  This should someday be fixed. */
2194           size = 24;
2195
2196         *length = build_int_2 (size, 0);
2197         TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2198
2199         if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
2200             == FFEINFO_whereINTRINSIC)
2201           {
2202             if (size == 1)
2203               {
2204                 /* Invocation of an intrinsic returning CHARACTER*1.  */
2205                 item = ffecom_expr_intrinsic_ (expr, NULL_TREE,
2206                                                NULL, NULL);
2207                 break;
2208               }
2209             ix = ffeintrin_gfrt_direct (ffebld_symter_implementation (ffebld_left (expr)));
2210             assert (ix != FFECOM_gfrt);
2211             item = ffecom_gfrt_tree_ (ix);
2212           }
2213         else
2214           {
2215             ix = FFECOM_gfrt;
2216             item = ffesymbol_hook (s).decl_tree;
2217             if (item == NULL_TREE)
2218               {
2219                 s = ffecom_sym_transform_ (s);
2220                 item = ffesymbol_hook (s).decl_tree;
2221               }
2222             if (item == error_mark_node)
2223               {
2224                 item = *length = error_mark_node;
2225                 break;
2226               }
2227
2228             if (!ffesymbol_hook (s).addr)
2229               item = ffecom_1_fn (item);
2230           }
2231
2232 #ifdef HOHO
2233         tempvar = ffecom_push_tempvar (char_type_node, size, -1, TRUE);
2234 #else
2235         tempvar = ffebld_nonter_hook (expr);
2236         assert (tempvar);
2237 #endif
2238         tempvar = ffecom_1 (ADDR_EXPR,
2239                             build_pointer_type (TREE_TYPE (tempvar)),
2240                             tempvar);
2241
2242         args = build_tree_list (NULL_TREE, tempvar);
2243
2244         if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)       /* Sfunc args by value. */
2245           TREE_CHAIN (args) = ffecom_list_expr (ffebld_right (expr));
2246         else
2247           {
2248             TREE_CHAIN (args) = build_tree_list (NULL_TREE, *length);
2249             if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
2250               {
2251                 TREE_CHAIN (TREE_CHAIN (args))
2252                   = ffecom_arglist_expr_ (ffecom_gfrt_args_ (ix),
2253                                           ffebld_right (expr));
2254               }
2255             else
2256               {
2257                 TREE_CHAIN (TREE_CHAIN (args))
2258                   = ffecom_list_ptr_to_expr (ffebld_right (expr));
2259               }
2260           }
2261
2262         item = ffecom_3s (CALL_EXPR,
2263                           TREE_TYPE (TREE_TYPE (TREE_TYPE (item))),
2264                           item, args, NULL_TREE);
2265         item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item,
2266                          tempvar);
2267       }
2268       break;
2269
2270     case FFEBLD_opCONVERT:
2271
2272       ffecom_char_args_ (&item, length, ffebld_left (expr));
2273
2274       if (item == error_mark_node || *length == error_mark_node)
2275         {
2276           item = *length = error_mark_node;
2277           break;
2278         }
2279
2280       if ((ffebld_size_known (ffebld_left (expr))
2281            == FFETARGET_charactersizeNONE)
2282           || (ffebld_size_known (ffebld_left (expr)) < (ffebld_size (expr))))
2283         {                       /* Possible blank-padding needed, copy into
2284                                    temporary. */
2285           tree tempvar;
2286           tree args;
2287           tree newlen;
2288
2289 #ifdef HOHO
2290           tempvar = ffecom_make_tempvar (char_type_node,
2291                                          ffebld_size (expr), -1);
2292 #else
2293           tempvar = ffebld_nonter_hook (expr);
2294           assert (tempvar);
2295 #endif
2296           tempvar = ffecom_1 (ADDR_EXPR,
2297                               build_pointer_type (TREE_TYPE (tempvar)),
2298                               tempvar);
2299
2300           newlen = build_int_2 (ffebld_size (expr), 0);
2301           TREE_TYPE (newlen) = ffecom_f2c_ftnlen_type_node;
2302
2303           args = build_tree_list (NULL_TREE, tempvar);
2304           TREE_CHAIN (args) = build_tree_list (NULL_TREE, item);
2305           TREE_CHAIN (TREE_CHAIN (args)) = build_tree_list (NULL_TREE, newlen);
2306           TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (args)))
2307             = build_tree_list (NULL_TREE, *length);
2308
2309           item = ffecom_call_gfrt (FFECOM_gfrtCOPY, args, NULL_TREE);
2310           TREE_SIDE_EFFECTS (item) = 1;
2311           item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), fold (item),
2312                            tempvar);
2313           *length = newlen;
2314         }
2315       else
2316         {                       /* Just truncate the length. */
2317           *length = build_int_2 (ffebld_size (expr), 0);
2318           TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2319         }
2320       break;
2321
2322     default:
2323       assert ("bad op for single char arg expr" == NULL);
2324       item = NULL_TREE;
2325       break;
2326     }
2327
2328   *xitem = item;
2329 }
2330 #endif
2331
2332 /* Check the size of the type to be sure it doesn't overflow the
2333    "portable" capacities of the compiler back end.  `dummy' types
2334    can generally overflow the normal sizes as long as the computations
2335    themselves don't overflow.  A particular target of the back end
2336    must still enforce its size requirements, though, and the back
2337    end takes care of this in stor-layout.c.  */
2338
2339 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2340 static tree
2341 ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy)
2342 {
2343   if (TREE_CODE (type) == ERROR_MARK)
2344     return type;
2345
2346   if (TYPE_SIZE (type) == NULL_TREE)
2347     return type;
2348
2349   if (TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST)
2350     return type;
2351
2352   if ((tree_int_cst_sgn (TYPE_SIZE (type)) < 0)
2353       || (!dummy && (((TREE_INT_CST_HIGH (TYPE_SIZE (type)) != 0))
2354                      || TREE_OVERFLOW (TYPE_SIZE (type)))))
2355     {
2356       ffebad_start (FFEBAD_ARRAY_LARGE);
2357       ffebad_string (ffesymbol_text (s));
2358       ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s));
2359       ffebad_finish ();
2360
2361       return error_mark_node;
2362     }
2363
2364   return type;
2365 }
2366 #endif
2367
2368 /* Builds a length argument (PARM_DECL).  Also wraps type in an array type
2369    where the dimension info is (1:size) where <size> is ffesymbol_size(s) if
2370    known, length_arg if not known (FFETARGET_charactersizeNONE).  */
2371
2372 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2373 static tree
2374 ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s)
2375 {
2376   ffetargetCharacterSize sz = ffesymbol_size (s);
2377   tree highval;
2378   tree tlen;
2379   tree type = *xtype;
2380
2381   if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
2382     tlen = NULL_TREE;           /* A statement function, no length passed. */
2383   else
2384     {
2385       if (ffesymbol_where (s) == FFEINFO_whereDUMMY)
2386         tlen = ffecom_get_invented_identifier ("__g77_length_%s",
2387                                                ffesymbol_text (s));
2388       else
2389         tlen = ffecom_get_invented_identifier ("__g77_%s", "length");
2390       tlen = build_decl (PARM_DECL, tlen, ffecom_f2c_ftnlen_type_node);
2391 #if BUILT_FOR_270
2392       DECL_ARTIFICIAL (tlen) = 1;
2393 #endif
2394     }
2395
2396   if (sz == FFETARGET_charactersizeNONE)
2397     {
2398       assert (tlen != NULL_TREE);
2399       highval = variable_size (tlen);
2400     }
2401   else
2402     {
2403       highval = build_int_2 (sz, 0);
2404       TREE_TYPE (highval) = ffecom_f2c_ftnlen_type_node;
2405     }
2406
2407   type = build_array_type (type,
2408                            build_range_type (ffecom_f2c_ftnlen_type_node,
2409                                              ffecom_f2c_ftnlen_one_node,
2410                                              highval));
2411
2412   *xtype = type;
2413   return tlen;
2414 }
2415
2416 #endif
2417 /* ffecom_concat_list_gather_ -- Gather list of concatenated string exprs
2418
2419    ffecomConcatList_ catlist;
2420    ffebld expr;  // expr of CHARACTER basictype.
2421    ffetargetCharacterSize max;  // max chars to gather or _...NONE if no max
2422    catlist = ffecom_concat_list_gather_(catlist,expr,max);
2423
2424    Scans expr for character subexpressions, updates and returns catlist
2425    accordingly.  */
2426
2427 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2428 static ffecomConcatList_
2429 ffecom_concat_list_gather_ (ffecomConcatList_ catlist, ffebld expr,
2430                             ffetargetCharacterSize max)
2431 {
2432   ffetargetCharacterSize sz;
2433
2434 recurse:                        /* :::::::::::::::::::: */
2435
2436   if (expr == NULL)
2437     return catlist;
2438
2439   if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen >= max))
2440     return catlist;             /* Don't append any more items. */
2441
2442   switch (ffebld_op (expr))
2443     {
2444     case FFEBLD_opCONTER:
2445     case FFEBLD_opSYMTER:
2446     case FFEBLD_opARRAYREF:
2447     case FFEBLD_opFUNCREF:
2448     case FFEBLD_opSUBSTR:
2449     case FFEBLD_opCONVERT:      /* Callers should strip this off beforehand
2450                                    if they don't need to preserve it. */
2451       if (catlist.count == catlist.max)
2452         {                       /* Make a (larger) list. */
2453           ffebld *newx;
2454           int newmax;
2455
2456           newmax = (catlist.max == 0) ? 8 : catlist.max * 2;
2457           newx = malloc_new_ks (malloc_pool_image (), "catlist",
2458                                 newmax * sizeof (newx[0]));
2459           if (catlist.max != 0)
2460             {
2461               memcpy (newx, catlist.exprs, catlist.max * sizeof (newx[0]));
2462               malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2463                               catlist.max * sizeof (newx[0]));
2464             }
2465           catlist.max = newmax;
2466           catlist.exprs = newx;
2467         }
2468       if ((sz = ffebld_size_known (expr)) != FFETARGET_charactersizeNONE)
2469         catlist.minlen += sz;
2470       else
2471         ++catlist.minlen;       /* Not true for F90; can be 0 length. */
2472       if ((sz = ffebld_size_max (expr)) == FFETARGET_charactersizeNONE)
2473         catlist.maxlen = sz;
2474       else
2475         catlist.maxlen += sz;
2476       if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen > max))
2477         {                       /* This item overlaps (or is beyond) the end
2478                                    of the destination. */
2479           switch (ffebld_op (expr))
2480             {
2481             case FFEBLD_opCONTER:
2482             case FFEBLD_opSYMTER:
2483             case FFEBLD_opARRAYREF:
2484             case FFEBLD_opFUNCREF:
2485             case FFEBLD_opSUBSTR:
2486               /* ~~Do useful truncations here. */
2487               break;
2488
2489             default:
2490               assert ("op changed or inconsistent switches!" == NULL);
2491               break;
2492             }
2493         }
2494       catlist.exprs[catlist.count++] = expr;
2495       return catlist;
2496
2497     case FFEBLD_opPAREN:
2498       expr = ffebld_left (expr);
2499       goto recurse;             /* :::::::::::::::::::: */
2500
2501     case FFEBLD_opCONCATENATE:
2502       catlist = ffecom_concat_list_gather_ (catlist, ffebld_left (expr), max);
2503       expr = ffebld_right (expr);
2504       goto recurse;             /* :::::::::::::::::::: */
2505
2506 #if 0                           /* Breaks passing small actual arg to larger
2507                                    dummy arg of sfunc */
2508     case FFEBLD_opCONVERT:
2509       expr = ffebld_left (expr);
2510       {
2511         ffetargetCharacterSize cmax;
2512
2513         cmax = catlist.len + ffebld_size_known (expr);
2514
2515         if ((max == FFETARGET_charactersizeNONE) || (max > cmax))
2516           max = cmax;
2517       }
2518       goto recurse;             /* :::::::::::::::::::: */
2519 #endif
2520
2521     case FFEBLD_opANY:
2522       return catlist;
2523
2524     default:
2525       assert ("bad op in _gather_" == NULL);
2526       return catlist;
2527     }
2528 }
2529
2530 #endif
2531 /* ffecom_concat_list_kill_ -- Kill list of concatenated string exprs
2532
2533    ffecomConcatList_ catlist;
2534    ffecom_concat_list_kill_(catlist);
2535
2536    Anything allocated within the list info is deallocated.  */
2537
2538 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2539 static void
2540 ffecom_concat_list_kill_ (ffecomConcatList_ catlist)
2541 {
2542   if (catlist.max != 0)
2543     malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2544                     catlist.max * sizeof (catlist.exprs[0]));
2545 }
2546
2547 #endif
2548 /* Make list of concatenated string exprs.
2549
2550    Returns a flattened list of concatenated subexpressions given a
2551    tree of such expressions.  */
2552
2553 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2554 static ffecomConcatList_
2555 ffecom_concat_list_new_ (ffebld expr, ffetargetCharacterSize max)
2556 {
2557   ffecomConcatList_ catlist;
2558
2559   catlist.maxlen = catlist.minlen = catlist.max = catlist.count = 0;
2560   return ffecom_concat_list_gather_ (catlist, expr, max);
2561 }
2562
2563 #endif
2564
2565 /* Provide some kind of useful info on member of aggregate area,
2566    since current g77/gcc technology does not provide debug info
2567    on these members.  */
2568
2569 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2570 static void
2571 ffecom_debug_kludge_ (tree aggr, const char *aggr_type, ffesymbol member,
2572                       tree member_type UNUSED, ffetargetOffset offset)
2573 {
2574   tree value;
2575   tree decl;
2576   int len;
2577   char *buff;
2578   char space[120];
2579 #if 0
2580   tree type_id;
2581
2582   for (type_id = member_type;
2583        TREE_CODE (type_id) != IDENTIFIER_NODE;
2584        )
2585     {
2586       switch (TREE_CODE (type_id))
2587         {
2588         case INTEGER_TYPE:
2589         case REAL_TYPE:
2590           type_id = TYPE_NAME (type_id);
2591           break;
2592
2593         case ARRAY_TYPE:
2594         case COMPLEX_TYPE:
2595           type_id = TREE_TYPE (type_id);
2596           break;
2597
2598         default:
2599           assert ("no IDENTIFIER_NODE for type!" == NULL);
2600           type_id = error_mark_node;
2601           break;
2602         }
2603     }
2604 #endif
2605
2606   if (ffecom_transform_only_dummies_
2607       || !ffe_is_debug_kludge ())
2608     return;     /* Can't do this yet, maybe later. */
2609
2610   len = 60
2611     + strlen (aggr_type)
2612     + IDENTIFIER_LENGTH (DECL_NAME (aggr));
2613 #if 0
2614     + IDENTIFIER_LENGTH (type_id);
2615 #endif
2616
2617   if (((size_t) len) >= ARRAY_SIZE (space))
2618     buff = malloc_new_ks (malloc_pool_image (), "debug_kludge", len + 1);
2619   else
2620     buff = &space[0];
2621
2622   sprintf (&buff[0], "At (%s) `%s' plus %ld bytes",
2623            aggr_type,
2624            IDENTIFIER_POINTER (DECL_NAME (aggr)),
2625            (long int) offset);
2626
2627   value = build_string (len, buff);
2628   TREE_TYPE (value)
2629     = build_type_variant (build_array_type (char_type_node,
2630                                             build_range_type
2631                                             (integer_type_node,
2632                                              integer_one_node,
2633                                              build_int_2 (strlen (buff), 0))),
2634                           1, 0);
2635   decl = build_decl (VAR_DECL,
2636                      ffecom_get_identifier_ (ffesymbol_text (member)),
2637                      TREE_TYPE (value));
2638   TREE_CONSTANT (decl) = 1;
2639   TREE_STATIC (decl) = 1;
2640   DECL_INITIAL (decl) = error_mark_node;
2641   DECL_IN_SYSTEM_HEADER (decl) = 1;     /* Don't let -Wunused complain. */
2642   decl = start_decl (decl, FALSE);
2643   finish_decl (decl, value, FALSE);
2644
2645   if (buff != &space[0])
2646     malloc_kill_ks (malloc_pool_image (), buff, len + 1);
2647 }
2648 #endif
2649
2650 /* ffecom_do_entry_ -- Do compilation of a particular entrypoint
2651
2652    ffesymbol fn;  // the SUBROUTINE, FUNCTION, or ENTRY symbol itself
2653    int i;  // entry# for this entrypoint (used by master fn)
2654    ffecom_do_entrypoint_(s,i);
2655
2656    Makes a public entry point that calls our private master fn (already
2657    compiled).  */
2658
2659 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2660 static void
2661 ffecom_do_entry_ (ffesymbol fn, int entrynum)
2662 {
2663   ffebld item;
2664   tree type;                    /* Type of function. */
2665   tree multi_retval;            /* Var holding return value (union). */
2666   tree result;                  /* Var holding result. */
2667   ffeinfoBasictype bt;
2668   ffeinfoKindtype kt;
2669   ffeglobal g;
2670   ffeglobalType gt;
2671   bool charfunc;                /* All entry points return same type
2672                                    CHARACTER. */
2673   bool cmplxfunc;               /* Use f2c way of returning COMPLEX. */
2674   bool multi;                   /* Master fn has multiple return types. */
2675   bool altreturning = FALSE;    /* This entry point has alternate returns. */
2676   int old_lineno = lineno;
2677   const char *old_input_filename = input_filename;
2678
2679   input_filename = ffesymbol_where_filename (fn);
2680   lineno = ffesymbol_where_filelinenum (fn);
2681
2682   ffecom_doing_entry_ = TRUE;   /* Don't bother with array dimensions. */
2683
2684   switch (ffecom_primary_entry_kind_)
2685     {
2686     case FFEINFO_kindFUNCTION:
2687
2688       /* Determine actual return type for function. */
2689
2690       gt = FFEGLOBAL_typeFUNC;
2691       bt = ffesymbol_basictype (fn);
2692       kt = ffesymbol_kindtype (fn);
2693       if (bt == FFEINFO_basictypeNONE)
2694         {
2695           ffeimplic_establish_symbol (fn);
2696           if (ffesymbol_funcresult (fn) != NULL)
2697             ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
2698           bt = ffesymbol_basictype (fn);
2699           kt = ffesymbol_kindtype (fn);
2700         }
2701
2702       if (bt == FFEINFO_basictypeCHARACTER)
2703         charfunc = TRUE, cmplxfunc = FALSE;
2704       else if ((bt == FFEINFO_basictypeCOMPLEX)
2705                && ffesymbol_is_f2c (fn))
2706         charfunc = FALSE, cmplxfunc = TRUE;
2707       else
2708         charfunc = cmplxfunc = FALSE;
2709
2710       if (charfunc)
2711         type = ffecom_tree_fun_type_void;
2712       else if (ffesymbol_is_f2c (fn))
2713         type = ffecom_tree_fun_type[bt][kt];
2714       else
2715         type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
2716
2717       if ((type == NULL_TREE)
2718           || (TREE_TYPE (type) == NULL_TREE))
2719         type = ffecom_tree_fun_type_void;       /* _sym_exec_transition. */
2720
2721       multi = (ffecom_master_bt_ == FFEINFO_basictypeNONE);
2722       break;
2723
2724     case FFEINFO_kindSUBROUTINE:
2725       gt = FFEGLOBAL_typeSUBR;
2726       bt = FFEINFO_basictypeNONE;
2727       kt = FFEINFO_kindtypeNONE;
2728       if (ffecom_is_altreturning_)
2729         {                       /* Am _I_ altreturning? */
2730           for (item = ffesymbol_dummyargs (fn);
2731                item != NULL;
2732                item = ffebld_trail (item))
2733             {
2734               if (ffebld_op (ffebld_head (item)) == FFEBLD_opSTAR)
2735                 {
2736                   altreturning = TRUE;
2737                   break;
2738                 }
2739             }
2740           if (altreturning)
2741             type = ffecom_tree_subr_type;
2742           else
2743             type = ffecom_tree_fun_type_void;
2744         }
2745       else
2746         type = ffecom_tree_fun_type_void;
2747       charfunc = FALSE;
2748       cmplxfunc = FALSE;
2749       multi = FALSE;
2750       break;
2751
2752     default:
2753       assert ("say what??" == NULL);
2754       /* Fall through. */
2755     case FFEINFO_kindANY:
2756       gt = FFEGLOBAL_typeANY;
2757       bt = FFEINFO_basictypeNONE;
2758       kt = FFEINFO_kindtypeNONE;
2759       type = error_mark_node;
2760       charfunc = FALSE;
2761       cmplxfunc = FALSE;
2762       multi = FALSE;
2763       break;
2764     }
2765
2766   /* build_decl uses the current lineno and input_filename to set the decl
2767      source info.  So, I've putzed with ffestd and ffeste code to update that
2768      source info to point to the appropriate statement just before calling
2769      ffecom_do_entrypoint (which calls this fn).  */
2770
2771   start_function (ffecom_get_external_identifier_ (fn),
2772                   type,
2773                   0,            /* nested/inline */
2774                   1);           /* TREE_PUBLIC */
2775
2776   if (((g = ffesymbol_global (fn)) != NULL)
2777       && ((ffeglobal_type (g) == gt)
2778           || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
2779     {
2780       ffeglobal_set_hook (g, current_function_decl);
2781     }
2782
2783   /* Reset args in master arg list so they get retransitioned. */
2784
2785   for (item = ffecom_master_arglist_;
2786        item != NULL;
2787        item = ffebld_trail (item))
2788     {
2789       ffebld arg;
2790       ffesymbol s;
2791
2792       arg = ffebld_head (item);
2793       if (ffebld_op (arg) != FFEBLD_opSYMTER)
2794         continue;               /* Alternate return or some such thing. */
2795       s = ffebld_symter (arg);
2796       ffesymbol_hook (s).decl_tree = NULL_TREE;
2797       ffesymbol_hook (s).length_tree = NULL_TREE;
2798     }
2799
2800   /* Build dummy arg list for this entry point. */
2801
2802   if (charfunc || cmplxfunc)
2803     {                           /* Prepend arg for where result goes. */
2804       tree type;
2805       tree length;
2806
2807       if (charfunc)
2808         type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
2809       else
2810         type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
2811
2812       result = ffecom_get_invented_identifier ("__g77_%s", "result");
2813
2814       /* Make length arg _and_ enhance type info for CHAR arg itself.  */
2815
2816       if (charfunc)
2817         length = ffecom_char_enhance_arg_ (&type, fn);
2818       else
2819         length = NULL_TREE;     /* Not ref'd if !charfunc. */
2820
2821       type = build_pointer_type (type);
2822       result = build_decl (PARM_DECL, result, type);
2823
2824       push_parm_decl (result);
2825       ffecom_func_result_ = result;
2826
2827       if (charfunc)
2828         {
2829           push_parm_decl (length);
2830           ffecom_func_length_ = length;
2831         }
2832     }
2833   else
2834     result = DECL_RESULT (current_function_decl);
2835
2836   ffecom_push_dummy_decls_ (ffesymbol_dummyargs (fn), FALSE);
2837
2838   store_parm_decls (0);
2839
2840   ffecom_start_compstmt ();
2841   /* Disallow temp vars at this level.  */
2842   current_binding_level->prep_state = 2;
2843
2844   /* Make local var to hold return type for multi-type master fn. */
2845
2846   if (multi)
2847     {
2848       multi_retval = ffecom_get_invented_identifier ("__g77_%s",
2849                                                      "multi_retval");
2850       multi_retval = build_decl (VAR_DECL, multi_retval,
2851                                  ffecom_multi_type_node_);
2852       multi_retval = start_decl (multi_retval, FALSE);
2853       finish_decl (multi_retval, NULL_TREE, FALSE);
2854     }
2855   else
2856     multi_retval = NULL_TREE;   /* Not actually ref'd if !multi. */
2857
2858   /* Here we emit the actual code for the entry point. */
2859
2860   {
2861     ffebld list;
2862     ffebld arg;
2863     ffesymbol s;
2864     tree arglist = NULL_TREE;
2865     tree *plist = &arglist;
2866     tree prepend;
2867     tree call;
2868     tree actarg;
2869     tree master_fn;
2870
2871     /* Prepare actual arg list based on master arg list. */
2872
2873     for (list = ffecom_master_arglist_;
2874          list != NULL;
2875          list = ffebld_trail (list))
2876       {
2877         arg = ffebld_head (list);
2878         if (ffebld_op (arg) != FFEBLD_opSYMTER)
2879           continue;
2880         s = ffebld_symter (arg);
2881         if (ffesymbol_hook (s).decl_tree == NULL_TREE
2882             || ffesymbol_hook (s).decl_tree == error_mark_node)
2883           actarg = null_pointer_node;   /* We don't have this arg. */
2884         else
2885           actarg = ffesymbol_hook (s).decl_tree;
2886         *plist = build_tree_list (NULL_TREE, actarg);
2887         plist = &TREE_CHAIN (*plist);
2888       }
2889
2890     /* This code appends the length arguments for character
2891        variables/arrays.  */
2892
2893     for (list = ffecom_master_arglist_;
2894          list != NULL;
2895          list = ffebld_trail (list))
2896       {
2897         arg = ffebld_head (list);
2898         if (ffebld_op (arg) != FFEBLD_opSYMTER)
2899           continue;
2900         s = ffebld_symter (arg);
2901         if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
2902           continue;             /* Only looking for CHARACTER arguments. */
2903         if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
2904           continue;             /* Only looking for variables and arrays. */
2905         if (ffesymbol_hook (s).length_tree == NULL_TREE
2906             || ffesymbol_hook (s).length_tree == error_mark_node)
2907           actarg = ffecom_f2c_ftnlen_zero_node; /* We don't have this arg. */
2908         else
2909           actarg = ffesymbol_hook (s).length_tree;
2910         *plist = build_tree_list (NULL_TREE, actarg);
2911         plist = &TREE_CHAIN (*plist);
2912       }
2913
2914     /* Prepend character-value return info to actual arg list. */
2915
2916     if (charfunc)
2917       {
2918         prepend = build_tree_list (NULL_TREE, ffecom_func_result_);
2919         TREE_CHAIN (prepend)
2920           = build_tree_list (NULL_TREE, ffecom_func_length_);
2921         TREE_CHAIN (TREE_CHAIN (prepend)) = arglist;
2922         arglist = prepend;
2923       }
2924
2925     /* Prepend multi-type return value to actual arg list. */
2926
2927     if (multi)
2928       {
2929         prepend
2930           = build_tree_list (NULL_TREE,
2931                              ffecom_1 (ADDR_EXPR,
2932                               build_pointer_type (TREE_TYPE (multi_retval)),
2933                                        multi_retval));
2934         TREE_CHAIN (prepend) = arglist;
2935         arglist = prepend;
2936       }
2937
2938     /* Prepend my entry-point number to the actual arg list. */
2939
2940     prepend = build_tree_list (NULL_TREE, build_int_2 (entrynum, 0));
2941     TREE_CHAIN (prepend) = arglist;
2942     arglist = prepend;
2943
2944     /* Build the call to the master function. */
2945
2946     master_fn = ffecom_1_fn (ffecom_previous_function_decl_);
2947     call = ffecom_3s (CALL_EXPR,
2948                       TREE_TYPE (TREE_TYPE (TREE_TYPE (master_fn))),
2949                       master_fn, arglist, NULL_TREE);
2950
2951     /* Decide whether the master function is a function or subroutine, and
2952        handle the return value for my entry point. */
2953
2954     if (charfunc || ((ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
2955                      && !altreturning))
2956       {
2957         expand_expr_stmt (call);
2958         expand_null_return ();
2959       }
2960     else if (multi && cmplxfunc)
2961       {
2962         expand_expr_stmt (call);
2963         result
2964           = ffecom_1 (INDIRECT_REF,
2965                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
2966                       result);
2967         result = ffecom_modify (NULL_TREE, result,
2968                                 ffecom_2 (COMPONENT_REF, TREE_TYPE (result),
2969                                           multi_retval,
2970                                           ffecom_multi_fields_[bt][kt]));
2971         expand_expr_stmt (result);
2972         expand_null_return ();
2973       }
2974     else if (multi)
2975       {
2976         expand_expr_stmt (call);
2977         result
2978           = ffecom_modify (NULL_TREE, result,
2979                            convert (TREE_TYPE (result),
2980                                     ffecom_2 (COMPONENT_REF,
2981                                               ffecom_tree_type[bt][kt],
2982                                               multi_retval,
2983                                               ffecom_multi_fields_[bt][kt])));
2984         expand_return (result);
2985       }
2986     else if (cmplxfunc)
2987       {
2988         result
2989           = ffecom_1 (INDIRECT_REF,
2990                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
2991                       result);
2992         result = ffecom_modify (NULL_TREE, result, call);
2993         expand_expr_stmt (result);
2994         expand_null_return ();
2995       }
2996     else
2997       {
2998         result = ffecom_modify (NULL_TREE,
2999                                 result,
3000                                 convert (TREE_TYPE (result),
3001                                          call));
3002         expand_return (result);
3003       }
3004   }
3005
3006   ffecom_end_compstmt ();
3007
3008   finish_function (0);
3009
3010   lineno = old_lineno;
3011   input_filename = old_input_filename;
3012
3013   ffecom_doing_entry_ = FALSE;
3014 }
3015
3016 #endif
3017 /* Transform expr into gcc tree with possible destination
3018
3019    Recursive descent on expr while making corresponding tree nodes and
3020    attaching type info and such.  If destination supplied and compatible
3021    with temporary that would be made in certain cases, temporary isn't
3022    made, destination used instead, and dest_used flag set TRUE.  */
3023
3024 #if FFECOM_targetCURRENT == FFECOM_targetGCC
3025 static tree
3026 ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
3027               bool *dest_used, bool assignp, bool widenp)
3028 {
3029   tree item;
3030   tree list;
3031   tree args;
3032   ffeinfoBasictype bt;
3033   ffeinfoKindtype kt;
3034   tree t;
3035   tree dt;                      /* decl_tree for an ffesymbol. */
3036   tree tree_type, tree_type_x;
3037   tree left, right;
3038   ffesymbol s;
3039   enum tree_code code;
3040
3041   assert (expr != NULL);
3042
3043   if (dest_used != NULL)
3044     *dest_used = FALSE;
3045
3046   bt = ffeinfo_basictype (ffebld_info (expr));
3047   kt = ffeinfo_kindtype (ffebld_info (expr));
3048   tree_type = ffecom_tree_type[bt][kt];
3049
3050   /* Widen integral arithmetic as desired while preserving signedness.  */
3051   tree_type_x = NULL_TREE;
3052   if (widenp && tree_type
3053       && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
3054       && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
3055     tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
3056
3057   switch (ffebld_op (expr))
3058     {
3059     case FFEBLD_opACCTER:
3060       {
3061         ffebitCount i;
3062         ffebit bits = ffebld_accter_bits (expr);
3063         ffetargetOffset source_offset = 0;
3064         ffetargetOffset dest_offset = ffebld_accter_pad (expr);
3065         tree purpose;
3066
3067         assert (dest_offset == 0
3068                 || (bt == FFEINFO_basictypeCHARACTER
3069                     && kt == FFEINFO_kindtypeCHARACTER1));
3070
3071         list = item = NULL;
3072         for (;;)
3073           {
3074             ffebldConstantUnion cu;
3075             ffebitCount length;
3076             bool value;
3077             ffebldConstantArray ca = ffebld_accter (expr);
3078
3079             ffebit_test (bits, source_offset, &value, &length);
3080             if (length == 0)
3081               break;
3082
3083             if (value)
3084               {
3085                 for (i = 0; i < length; ++i)
3086                   {
3087                     cu = ffebld_constantarray_get (ca, bt, kt,
3088                                                    source_offset + i);
3089
3090                     t = ffecom_constantunion (&cu, bt, kt, tree_type);
3091
3092                     if (i == 0
3093                         && dest_offset != 0)
3094                       purpose = build_int_2 (dest_offset, 0);
3095                     else
3096                       purpose = NULL_TREE;
3097
3098                     if (list == NULL_TREE)
3099                       list = item = build_tree_list (purpose, t);
3100                     else
3101                       {
3102                         TREE_CHAIN (item) = build_tree_list (purpose, t);
3103                         item = TREE_CHAIN (item);
3104                       }
3105                   }
3106               }
3107             source_offset += length;
3108             dest_offset += length;
3109           }
3110       }
3111
3112       item = build_int_2 ((ffebld_accter_size (expr)
3113                            + ffebld_accter_pad (expr)) - 1, 0);
3114       ffebit_kill (ffebld_accter_bits (expr));
3115       TREE_TYPE (item) = ffecom_integer_type_node;
3116       item
3117         = build_array_type
3118           (tree_type,
3119            build_range_type (ffecom_integer_type_node,
3120                              ffecom_integer_zero_node,
3121                              item));
3122       list = build (CONSTRUCTOR, item, NULL_TREE, list);
3123       TREE_CONSTANT (list) = 1;
3124       TREE_STATIC (list) = 1;
3125       return list;
3126
3127     case FFEBLD_opARRTER:
3128       {
3129         ffetargetOffset i;
3130
3131         list = NULL_TREE;
3132         if (ffebld_arrter_pad (expr) == 0)
3133           item = NULL_TREE;
3134         else
3135           {
3136             assert (bt == FFEINFO_basictypeCHARACTER
3137                     && kt == FFEINFO_kindtypeCHARACTER1);
3138
3139             /* Becomes PURPOSE first time through loop.  */
3140             item = build_int_2 (ffebld_arrter_pad (expr), 0);
3141           }
3142
3143         for (i = 0; i < ffebld_arrter_size (expr); ++i)
3144           {
3145             ffebldConstantUnion cu
3146             = ffebld_constantarray_get (ffebld_arrter (expr), bt, kt, i);
3147
3148             t = ffecom_constantunion (&cu, bt, kt, tree_type);
3149
3150             if (list == NULL_TREE)
3151               /* Assume item is PURPOSE first time through loop.  */
3152               list = item = build_tree_list (item, t);
3153             else
3154               {
3155                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
3156                 item = TREE_CHAIN (item);
3157               }
3158           }
3159       }
3160
3161       item = build_int_2 ((ffebld_arrter_size (expr)
3162                           + ffebld_arrter_pad (expr)) - 1, 0);
3163       TREE_TYPE (item) = ffecom_integer_type_node;
3164       item
3165         = build_array_type
3166           (tree_type,
3167            build_range_type (ffecom_integer_type_node,
3168                              ffecom_integer_zero_node,
3169                              item));
3170       list = build (CONSTRUCTOR, item, NULL_TREE, list);
3171       TREE_CONSTANT (list) = 1;
3172       TREE_STATIC (list) = 1;
3173       return list;
3174
3175     case FFEBLD_opCONTER:
3176       assert (ffebld_conter_pad (expr) == 0);
3177       item
3178         = ffecom_constantunion (&ffebld_constant_union (ffebld_conter (expr)),
3179                                 bt, kt, tree_type);
3180       return item;
3181
3182     case FFEBLD_opSYMTER:
3183       if ((ffebld_symter_generic (expr) != FFEINTRIN_genNONE)
3184           || (ffebld_symter_specific (expr) != FFEINTRIN_specNONE))
3185         return ffecom_ptr_to_expr (expr);       /* Same as %REF(intrinsic). */
3186       s = ffebld_symter (expr);
3187       t = ffesymbol_hook (s).decl_tree;
3188
3189       if (assignp)
3190         {                       /* ASSIGN'ed-label expr. */
3191           if (ffe_is_ugly_assign ())
3192             {
3193               /* User explicitly wants ASSIGN'ed variables to be at the same
3194                  memory address as the variables when used in non-ASSIGN
3195                  contexts.  That can make old, arcane, non-standard code
3196                  work, but don't try to do it when a pointer wouldn't fit
3197                  in the normal variable (take other approach, and warn,
3198                  instead).  */
3199
3200               if (t == NULL_TREE)
3201                 {
3202                   s = ffecom_sym_transform_ (s);
3203                   t = ffesymbol_hook (s).decl_tree;
3204                   assert (t != NULL_TREE);
3205                 }
3206
3207               if (t == error_mark_node)
3208                 return t;
3209
3210               if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t)))
3211                   >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
3212                 {
3213                   if (ffesymbol_hook (s).addr)
3214                     t = ffecom_1 (INDIRECT_REF,
3215                                   TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3216                   return t;
3217                 }
3218
3219               if (ffesymbol_hook (s).assign_tree == NULL_TREE)
3220                 {
3221                   ffebad_start_msg ("ASSIGN'ed label cannot fit into `%A' at %0 -- using wider sibling",
3222                                     FFEBAD_severityWARNING);
3223                   ffebad_string (ffesymbol_text (s));
3224                   ffebad_here (0, ffesymbol_where_line (s),
3225                                ffesymbol_where_column (s));
3226                   ffebad_finish ();
3227                 }
3228             }
3229
3230           /* Don't use the normal variable's tree for ASSIGN, though mark
3231              it as in the system header (housekeeping).  Use an explicit,
3232              specially created sibling that is known to be wide enough
3233              to hold pointers to labels.  */
3234
3235           if (t != NULL_TREE
3236               && TREE_CODE (t) == VAR_DECL)
3237             DECL_IN_SYSTEM_HEADER (t) = 1;      /* Don't let -Wunused complain. */
3238
3239           t = ffesymbol_hook (s).assign_tree;
3240           if (t == NULL_TREE)
3241             {
3242               s = ffecom_sym_transform_assign_ (s);
3243               t = ffesymbol_hook (s).assign_tree;
3244               assert (t != NULL_TREE);
3245             }
3246         }
3247       else
3248         {
3249           if (t == NULL_TREE)
3250             {
3251               s = ffecom_sym_transform_ (s);
3252               t = ffesymbol_hook (s).decl_tree;
3253               assert (t != NULL_TREE);
3254             }
3255           if (ffesymbol_hook (s).addr)
3256             t = ffecom_1 (INDIRECT_REF,
3257                           TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3258         }
3259       return t;
3260
3261     case FFEBLD_opARRAYREF:
3262       return ffecom_arrayref_ (NULL_TREE, expr, 0);
3263
3264     case FFEBLD_opUPLUS:
3265       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3266       return ffecom_1 (NOP_EXPR, tree_type, left);
3267
3268     case FFEBLD_opPAREN:
3269       /* ~~~Make sure Fortran rules respected here */
3270       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3271       return ffecom_1 (NOP_EXPR, tree_type, left);
3272
3273     case FFEBLD_opUMINUS:
3274       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3275       if (tree_type_x)
3276         {
3277           tree_type = tree_type_x;
3278           left = convert (tree_type, left);
3279         }
3280       return ffecom_1 (NEGATE_EXPR, tree_type, left);
3281
3282     case FFEBLD_opADD:
3283       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3284       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3285       if (tree_type_x)
3286         {
3287           tree_type = tree_type_x;
3288           left = convert (tree_type, left);
3289           right = convert (tree_type, right);
3290         }
3291       return ffecom_2 (PLUS_EXPR, tree_type, left, right);
3292
3293     case FFEBLD_opSUBTRACT:
3294       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3295       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3296       if (tree_type_x)
3297         {
3298           tree_type = tree_type_x;
3299           left = convert (tree_type, left);
3300           right = convert (tree_type, right);
3301         }
3302       return ffecom_2 (MINUS_EXPR, tree_type, left, right);
3303
3304     case FFEBLD_opMULTIPLY:
3305       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3306       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3307       if (tree_type_x)
3308         {
3309           tree_type = tree_type_x;
3310           left = convert (tree_type, left);
3311           right = convert (tree_type, right);
3312         }
3313       return ffecom_2 (MULT_EXPR, tree_type, left, right);
3314
3315     case FFEBLD_opDIVIDE:
3316       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3317       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3318       if (tree_type_x)
3319         {
3320           tree_type = tree_type_x;
3321           left = convert (tree_type, left);
3322           right = convert (tree_type, right);
3323         }
3324       return ffecom_tree_divide_ (tree_type, left, right,
3325                                   dest_tree, dest, dest_used,
3326                                   ffebld_nonter_hook (expr));
3327
3328     case FFEBLD_opPOWER:
3329       {
3330         ffebld left = ffebld_left (expr);
3331         ffebld right = ffebld_right (expr);
3332         ffecomGfrt code;
3333         ffeinfoKindtype rtkt;
3334         ffeinfoKindtype ltkt;
3335         bool ref = TRUE;
3336
3337         switch (ffeinfo_basictype (ffebld_info (right)))
3338           {
3339
3340           case FFEINFO_basictypeINTEGER:
3341             if (1 || optimize)
3342               {
3343                 item = ffecom_expr_power_integer_ (expr);
3344                 if (item != NULL_TREE)
3345                   return item;
3346               }
3347
3348             rtkt = FFEINFO_kindtypeINTEGER1;
3349             switch (ffeinfo_basictype (ffebld_info (left)))
3350               {
3351               case FFEINFO_basictypeINTEGER:
3352                 if ((ffeinfo_kindtype (ffebld_info (left))
3353                     == FFEINFO_kindtypeINTEGER4)
3354                     || (ffeinfo_kindtype (ffebld_info (right))
3355                         == FFEINFO_kindtypeINTEGER4))
3356                   {
3357                     code = FFECOM_gfrtPOW_QQ;
3358                     ltkt = FFEINFO_kindtypeINTEGER4;
3359                     rtkt = FFEINFO_kindtypeINTEGER4;
3360                   }
3361                 else
3362                   {
3363                     code = FFECOM_gfrtPOW_II;
3364                     ltkt = FFEINFO_kindtypeINTEGER1;
3365                   }
3366                 break;
3367
3368               case FFEINFO_basictypeREAL:
3369                 if (ffeinfo_kindtype (ffebld_info (left))
3370                     == FFEINFO_kindtypeREAL1)
3371                   {
3372                     code = FFECOM_gfrtPOW_RI;
3373                     ltkt = FFEINFO_kindtypeREAL1;
3374                   }
3375                 else
3376                   {
3377                     code = FFECOM_gfrtPOW_DI;
3378                     ltkt = FFEINFO_kindtypeREAL2;
3379                   }
3380                 break;
3381
3382               case FFEINFO_basictypeCOMPLEX:
3383                 if (ffeinfo_kindtype (ffebld_info (left))
3384                     == FFEINFO_kindtypeREAL1)
3385                   {
3386                     code = FFECOM_gfrtPOW_CI;   /* Overlapping result okay. */
3387                     ltkt = FFEINFO_kindtypeREAL1;
3388                   }
3389                 else
3390                   {
3391                     code = FFECOM_gfrtPOW_ZI;   /* Overlapping result okay. */
3392                     ltkt = FFEINFO_kindtypeREAL2;
3393                   }
3394                 break;
3395
3396               default:
3397                 assert ("bad pow_*i" == NULL);
3398                 code = FFECOM_gfrtPOW_CI;       /* Overlapping result okay. */
3399                 ltkt = FFEINFO_kindtypeREAL1;
3400                 break;
3401               }
3402             if (ffeinfo_kindtype (ffebld_info (left)) != ltkt)
3403               left = ffeexpr_convert (left, NULL, NULL,
3404                                       ffeinfo_basictype (ffebld_info (left)),
3405                                       ltkt, 0,
3406                                       FFETARGET_charactersizeNONE,
3407                                       FFEEXPR_contextLET);
3408             if (ffeinfo_kindtype (ffebld_info (right)) != rtkt)
3409               right = ffeexpr_convert (right, NULL, NULL,
3410                                        FFEINFO_basictypeINTEGER,
3411                                        rtkt, 0,
3412                                        FFETARGET_charactersizeNONE,
3413                                        FFEEXPR_contextLET);
3414             break;
3415
3416           case FFEINFO_basictypeREAL:
3417             if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3418               left = ffeexpr_convert (left, NULL, NULL, FFEINFO_basictypeREAL,
3419                                       FFEINFO_kindtypeREALDOUBLE, 0,
3420                                       FFETARGET_charactersizeNONE,
3421                                       FFEEXPR_contextLET);
3422             if (ffeinfo_kindtype (ffebld_info (right))
3423                 == FFEINFO_kindtypeREAL1)
3424               right = ffeexpr_convert (right, NULL, NULL,
3425                                        FFEINFO_basictypeREAL,
3426                                        FFEINFO_kindtypeREALDOUBLE, 0,
3427                                        FFETARGET_charactersizeNONE,
3428                                        FFEEXPR_contextLET);
3429             /* We used to call FFECOM_gfrtPOW_DD here,
3430                which passes arguments by reference.  */
3431             code = FFECOM_gfrtL_POW;
3432             /* Pass arguments by value. */
3433             ref  = FALSE;
3434             break;
3435
3436           case FFEINFO_basictypeCOMPLEX:
3437             if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3438               left = ffeexpr_convert (left, NULL, NULL,
3439                                       FFEINFO_basictypeCOMPLEX,
3440                                       FFEINFO_kindtypeREALDOUBLE, 0,
3441                                       FFETARGET_charactersizeNONE,
3442                                       FFEEXPR_contextLET);
3443             if (ffeinfo_kindtype (ffebld_info (right))
3444                 == FFEINFO_kindtypeREAL1)
3445               right = ffeexpr_convert (right, NULL, NULL,
3446                                        FFEINFO_basictypeCOMPLEX,
3447                                        FFEINFO_kindtypeREALDOUBLE, 0,
3448                                        FFETARGET_charactersizeNONE,
3449                                        FFEEXPR_contextLET);
3450             code = FFECOM_gfrtPOW_ZZ;   /* Overlapping result okay. */
3451             ref = TRUE;                 /* Pass arguments by reference. */
3452             break;
3453
3454           default:
3455             assert ("bad pow_x*" == NULL);
3456             code = FFECOM_gfrtPOW_II;
3457             break;
3458           }
3459         return ffecom_call_binop_ (ffecom_gfrt_tree_ (code),
3460                                    ffecom_gfrt_kindtype (code),
3461                                    (ffe_is_f2c_library ()
3462                                     && ffecom_gfrt_complex_[code]),
3463                                    tree_type, left, right,
3464                                    dest_tree, dest, dest_used,
3465                                    NULL_TREE, FALSE, ref,
3466                                    ffebld_nonter_hook (expr));
3467       }
3468
3469     case FFEBLD_opNOT:
3470       switch (bt)
3471         {
3472         case FFEINFO_basictypeLOGICAL:
3473           item = ffecom_truth_value_invert (ffecom_expr (ffebld_left (expr)));
3474           return convert (tree_type, item);
3475
3476         case FFEINFO_basictypeINTEGER:
3477           return ffecom_1 (BIT_NOT_EXPR, tree_type,
3478                            ffecom_expr (ffebld_left (expr)));
3479
3480         default:
3481           assert ("NOT bad basictype" == NULL);
3482           /* Fall through. */
3483         case FFEINFO_basictypeANY:
3484           return error_mark_node;
3485         }
3486       break;
3487
3488     case FFEBLD_opFUNCREF:
3489       assert (ffeinfo_basictype (ffebld_info (expr))
3490               != FFEINFO_basictypeCHARACTER);
3491       /* Fall through.   */
3492     case FFEBLD_opSUBRREF:
3493       if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
3494           == FFEINFO_whereINTRINSIC)
3495         {                       /* Invocation of an intrinsic. */
3496           item = ffecom_expr_intrinsic_ (expr, dest_tree, dest,
3497                                          dest_used);
3498           return item;
3499         }
3500       s = ffebld_symter (ffebld_left (expr));
3501       dt = ffesymbol_hook (s).decl_tree;
3502       if (dt == NULL_TREE)
3503         {
3504           s = ffecom_sym_transform_ (s);
3505           dt = ffesymbol_hook (s).decl_tree;
3506         }
3507       if (dt == error_mark_node)
3508         return dt;
3509
3510       if (ffesymbol_hook (s).addr)
3511         item = dt;
3512       else
3513         item = ffecom_1_fn (dt);
3514
3515       if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
3516         args = ffecom_list_expr (ffebld_right (expr));
3517       else
3518         args = ffecom_list_ptr_to_expr (ffebld_right (expr));
3519
3520       if (args == error_mark_node)
3521         return error_mark_node;
3522
3523       item = ffecom_call_ (item, kt,
3524                            ffesymbol_is_f2c (s)
3525                            && (bt == FFEINFO_basictypeCOMPLEX)
3526                            && (ffesymbol_where (s)
3527                                != FFEINFO_whereCONSTANT),
3528                            tree_type,
3529                            args,
3530                            dest_tree, dest, dest_used,
3531                            error_mark_node, FALSE,
3532                            ffebld_nonter_hook (expr));
3533       TREE_SIDE_EFFECTS (item) = 1;
3534       return item;
3535
3536     case FFEBLD_opAND:
3537       switch (bt)
3538         {
3539         case FFEINFO_basictypeLOGICAL:
3540           item
3541             = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3542                        ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3543                      ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3544           return convert (tree_type, item);
3545
3546         case FFEINFO_basictypeINTEGER:
3547           return ffecom_2 (BIT_AND_EXPR, tree_type,
3548                            ffecom_expr (ffebld_left (expr)),
3549                            ffecom_expr (ffebld_right (expr)));
3550
3551         default:
3552           assert ("AND bad basictype" == NULL);
3553           /* Fall through. */
3554         case FFEINFO_basictypeANY:
3555           return error_mark_node;
3556         }
3557       break;
3558
3559     case FFEBLD_opOR:
3560       switch (bt)
3561         {
3562         case FFEINFO_basictypeLOGICAL:
3563           item
3564             = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
3565                        ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3566                      ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3567           return convert (tree_type, item);
3568
3569         case FFEINFO_basictypeINTEGER:
3570           return ffecom_2 (BIT_IOR_EXPR, tree_type,
3571                            ffecom_expr (ffebld_left (expr)),
3572                            ffecom_expr (ffebld_right (expr)));
3573
3574         default:
3575           assert ("OR bad basictype" == NULL);
3576           /* Fall through. */
3577         case FFEINFO_basictypeANY:
3578           return error_mark_node;
3579         }
3580       break;
3581
3582     case FFEBLD_opXOR:
3583     case FFEBLD_opNEQV:
3584       switch (bt)
3585         {
3586         case FFEINFO_basictypeLOGICAL:
3587           item
3588             = ffecom_2 (NE_EXPR, integer_type_node,
3589                         ffecom_expr (ffebld_left (expr)),
3590                         ffecom_expr (ffebld_right (expr)));
3591           return convert (tree_type, ffecom_truth_value (item));
3592
3593         case FFEINFO_basictypeINTEGER:
3594           return ffecom_2 (BIT_XOR_EXPR, tree_type,
3595                            ffecom_expr (ffebld_left (expr)),
3596                            ffecom_expr (ffebld_right (expr)));
3597
3598         default:
3599           assert ("XOR/NEQV bad basictype" == NULL);
3600           /* Fall through. */
3601         case FFEINFO_basictypeANY:
3602           return error_mark_node;
3603         }
3604       break;
3605
3606     case FFEBLD_opEQV:
3607       switch (bt)
3608         {
3609         case FFEINFO_basictypeLOGICAL:
3610           item
3611             = ffecom_2 (EQ_EXPR, integer_type_node,
3612                         ffecom_expr (ffebld_left (expr)),
3613                         ffecom_expr (ffebld_right (expr)));
3614           return convert (tree_type, ffecom_truth_value (item));
3615
3616         case FFEINFO_basictypeINTEGER:
3617           return
3618             ffecom_1 (BIT_NOT_EXPR, tree_type,
3619                       ffecom_2 (BIT_XOR_EXPR, tree_type,
3620                                 ffecom_expr (ffebld_left (expr)),
3621                                 ffecom_expr (ffebld_right (expr))));
3622
3623         default:
3624           assert ("EQV bad basictype" == NULL);
3625           /* Fall through. */
3626         case FFEINFO_basictypeANY:
3627           return error_mark_node;
3628         }
3629       break;
3630
3631     case FFEBLD_opCONVERT:
3632       if (ffebld_op (ffebld_left (expr)) == FFEBLD_opANY)
3633         return error_mark_node;
3634
3635       switch (bt)
3636         {
3637         case FFEINFO_basictypeLOGICAL:
3638         case FFEINFO_basictypeINTEGER:
3639         case FFEINFO_basictypeREAL:
3640           return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3641
3642         case FFEINFO_basictypeCOMPLEX:
3643           switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3644             {
3645             case FFEINFO_basictypeINTEGER:
3646             case FFEINFO_basictypeLOGICAL:
3647             case FFEINFO_basictypeREAL:
3648               item = ffecom_expr (ffebld_left (expr));
3649               if (item == error_mark_node)
3650                 return error_mark_node;
3651               /* convert() takes care of converting to the subtype first,
3652                  at least in gcc-2.7.2. */
3653               item = convert (tree_type, item);
3654               return item;
3655
3656             case FFEINFO_basictypeCOMPLEX:
3657               return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3658
3659             default:
3660               assert ("CONVERT COMPLEX bad basictype" == NULL);
3661               /* Fall through. */
3662             case FFEINFO_basictypeANY:
3663               return error_mark_node;
3664             }
3665           break;
3666
3667         default:
3668           assert ("CONVERT bad basictype" == NULL);
3669           /* Fall through. */
3670         case FFEINFO_basictypeANY:
3671           return error_mark_node;
3672         }
3673       break;
3674
3675     case FFEBLD_opLT:
3676       code = LT_EXPR;
3677       goto relational;          /* :::::::::::::::::::: */
3678
3679     case FFEBLD_opLE:
3680       code = LE_EXPR;
3681       goto relational;          /* :::::::::::::::::::: */
3682
3683     case FFEBLD_opEQ:
3684       code = EQ_EXPR;
3685       goto relational;          /* :::::::::::::::::::: */
3686
3687     case FFEBLD_opNE:
3688       code = NE_EXPR;
3689       goto relational;          /* :::::::::::::::::::: */
3690
3691     case FFEBLD_opGT:
3692       code = GT_EXPR;
3693       goto relational;          /* :::::::::::::::::::: */
3694
3695     case FFEBLD_opGE:
3696       code = GE_EXPR;
3697
3698     relational:         /* :::::::::::::::::::: */
3699       switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3700         {
3701         case FFEINFO_basictypeLOGICAL:
3702         case FFEINFO_basictypeINTEGER:
3703         case FFEINFO_basictypeREAL:
3704           item = ffecom_2 (code, integer_type_node,
3705                            ffecom_expr (ffebld_left (expr)),
3706                            ffecom_expr (ffebld_right (expr)));
3707           return convert (tree_type, item);
3708
3709         case FFEINFO_basictypeCOMPLEX:
3710           assert (code == EQ_EXPR || code == NE_EXPR);
3711           {
3712             tree real_type;
3713             tree arg1 = ffecom_expr (ffebld_left (expr));
3714             tree arg2 = ffecom_expr (ffebld_right (expr));
3715
3716             if (arg1 == error_mark_node || arg2 == error_mark_node)
3717               return error_mark_node;
3718
3719             arg1 = ffecom_save_tree (arg1);
3720             arg2 = ffecom_save_tree (arg2);
3721
3722             if (TREE_CODE (TREE_TYPE (arg1)) == COMPLEX_TYPE)
3723               {
3724                 real_type = TREE_TYPE (TREE_TYPE (arg1));
3725                 assert (real_type == TREE_TYPE (TREE_TYPE (arg2)));
3726               }
3727             else
3728               {
3729                 real_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg1)));
3730                 assert (real_type == TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg2))));
3731               }
3732
3733             item
3734               = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3735                           ffecom_2 (EQ_EXPR, integer_type_node,
3736                                   ffecom_1 (REALPART_EXPR, real_type, arg1),
3737                                  ffecom_1 (REALPART_EXPR, real_type, arg2)),
3738                           ffecom_2 (EQ_EXPR, integer_type_node,
3739                                   ffecom_1 (IMAGPART_EXPR, real_type, arg1),
3740                                     ffecom_1 (IMAGPART_EXPR, real_type,
3741                                               arg2)));
3742             if (code == EQ_EXPR)
3743               item = ffecom_truth_value (item);
3744             else
3745               item = ffecom_truth_value_invert (item);
3746             return convert (tree_type, item);
3747           }
3748
3749         case FFEINFO_basictypeCHARACTER:
3750           {
3751             ffebld left = ffebld_left (expr);
3752             ffebld right = ffebld_right (expr);
3753             tree left_tree;
3754             tree right_tree;
3755             tree left_length;
3756             tree right_length;
3757
3758             /* f2c run-time functions do the implicit blank-padding for us,
3759                so we don't usually have to implement blank-padding ourselves.
3760                (The exception is when we pass an argument to a separately
3761                compiled statement function -- if we know the arg is not the
3762                same length as the dummy, we must truncate or extend it.  If
3763                we "inline" statement functions, that necessity goes away as
3764                well.)
3765
3766                Strip off the CONVERT operators that blank-pad.  (Truncation by
3767                CONVERT shouldn't happen here, but it can happen in
3768                assignments.) */
3769
3770             while (ffebld_op (left) == FFEBLD_opCONVERT)
3771               left = ffebld_left (left);
3772             while (ffebld_op (right) == FFEBLD_opCONVERT)
3773               right = ffebld_left (right);
3774
3775             left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
3776             right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
3777
3778             if (left_tree == error_mark_node || left_length == error_mark_node
3779                 || right_tree == error_mark_node
3780                 || right_length == error_mark_node)
3781               return error_mark_node;
3782
3783             if ((ffebld_size_known (left) == 1)
3784                 && (ffebld_size_known (right) == 1))
3785               {
3786                 left_tree
3787                   = ffecom_1 (INDIRECT_REF,
3788                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3789                               left_tree);
3790                 right_tree
3791                   = ffecom_1 (INDIRECT_REF,
3792                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3793                               right_tree);
3794
3795                 item
3796                   = ffecom_2 (code, integer_type_node,
3797                               ffecom_2 (ARRAY_REF,
3798                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3799                                         left_tree,
3800                                         integer_one_node),
3801                               ffecom_2 (ARRAY_REF,
3802                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3803                                         right_tree,
3804                                         integer_one_node));
3805               }
3806             else
3807               {
3808                 item = build_tree_list (NULL_TREE, left_tree);
3809                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, right_tree);
3810                 TREE_CHAIN (TREE_CHAIN (item)) = build_tree_list (NULL_TREE,
3811                                                                left_length);
3812                 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
3813                   = build_tree_list (NULL_TREE, right_length);
3814                 item = ffecom_call_gfrt (FFECOM_gfrtCMP, item, NULL_TREE);
3815                 item = ffecom_2 (code, integer_type_node,
3816                                  item,
3817                                  convert (TREE_TYPE (item),
3818                                           integer_zero_node));
3819               }
3820             item = convert (tree_type, item);
3821           }
3822
3823           return item;
3824
3825         default:
3826           assert ("relational bad basictype" == NULL);
3827           /* Fall through. */
3828         case FFEINFO_basictypeANY:
3829           return error_mark_node;
3830         }
3831       break;
3832
3833     case FFEBLD_opPERCENT_LOC:
3834       item = ffecom_arg_ptr_to_expr (ffebld_left (expr), &list);
3835       return convert (tree_type, item);
3836
3837     case FFEBLD_opITEM:
3838     case FFEBLD_opSTAR:
3839     case FFEBLD_opBOUNDS:
3840     case FFEBLD_opREPEAT:
3841     case FFEBLD_opLABTER:
3842     case FFEBLD_opLABTOK:
3843     case FFEBLD_opIMPDO:
3844     case FFEBLD_opCONCATENATE:
3845     case FFEBLD_opSUBSTR:
3846     default:
3847       assert ("bad op" == NULL);
3848       /* Fall through. */
3849     case FFEBLD_opANY:
3850       return error_mark_node;
3851     }
3852
3853 #if 1
3854   assert ("didn't think anything got here anymore!!" == NULL);
3855 #else
3856   switch (ffebld_arity (expr))
3857     {
3858     case 2:
3859       TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3860       TREE_OPERAND (item, 1) = ffecom_expr (ffebld_right (expr));
3861       if (TREE_OPERAND (item, 0) == error_mark_node
3862           || TREE_OPERAND (item, 1) == error_mark_node)
3863         return error_mark_node;
3864       break;
3865
3866     case 1:
3867       TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3868       if (TREE_OPERAND (item, 0) == error_mark_node)
3869         return error_mark_node;
3870       break;
3871
3872     default:
3873       break;
3874     }
3875
3876   return fold (item);
3877 #endif
3878 }
3879
3880 #endif
3881 /* Returns the tree that does the intrinsic invocation.
3882
3883    Note: this function applies only to intrinsics returning
3884    CHARACTER*1 or non-CHARACTER results, and to intrinsic
3885    subroutines.  */
3886
3887 #if FFECOM_targetCURRENT == FFECOM_targetGCC
3888 static tree
3889 ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
3890                         ffebld dest, bool *dest_used)
3891 {
3892   tree expr_tree;
3893   tree saved_expr1;             /* For those who need it. */
3894   tree saved_expr2;             /* For those who need it. */
3895   ffeinfoBasictype bt;
3896   ffeinfoKindtype kt;
3897   tree tree_type;
3898   tree arg1_type;
3899   tree real_type;               /* REAL type corresponding to COMPLEX. */
3900   tree tempvar;
3901   ffebld list = ffebld_right (expr);    /* List of (some) args. */
3902   ffebld arg1;                  /* For handy reference. */
3903   ffebld arg2;
3904   ffebld arg3;
3905   ffeintrinImp codegen_imp;
3906   ffecomGfrt gfrt;
3907
3908   assert (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER);
3909
3910   if (dest_used != NULL)
3911     *dest_used = FALSE;
3912
3913   bt = ffeinfo_basictype (ffebld_info (expr));
3914   kt = ffeinfo_kindtype (ffebld_info (expr));
3915   tree_type = ffecom_tree_type[bt][kt];
3916
3917   if (list != NULL)
3918     {
3919       arg1 = ffebld_head (list);
3920       if (arg1 != NULL && ffebld_op (arg1) == FFEBLD_opANY)
3921         return error_mark_node;
3922       if ((list = ffebld_trail (list)) != NULL)
3923         {
3924           arg2 = ffebld_head (list);
3925           if (arg2 != NULL && ffebld_op (arg2) == FFEBLD_opANY)
3926             return error_mark_node;
3927           if ((list = ffebld_trail (list)) != NULL)
3928             {
3929               arg3 = ffebld_head (list);
3930               if (arg3 != NULL && ffebld_op (arg3) == FFEBLD_opANY)
3931                 return error_mark_node;
3932             }
3933           else
3934             arg3 = NULL;
3935         }
3936       else
3937         arg2 = arg3 = NULL;
3938     }
3939   else
3940     arg1 = arg2 = arg3 = NULL;
3941
3942   /* <list> ends up at the opITEM of the 3rd arg, or NULL if there are < 3
3943      args.  This is used by the MAX/MIN expansions. */
3944
3945   if (arg1 != NULL)
3946     arg1_type = ffecom_tree_type
3947       [ffeinfo_basictype (ffebld_info (arg1))]
3948       [ffeinfo_kindtype (ffebld_info (arg1))];
3949   else
3950     arg1_type = NULL_TREE;      /* Really not needed, but might catch bugs
3951                                    here. */
3952
3953   /* There are several ways for each of the cases in the following switch
3954      statements to exit (from simplest to use to most complicated):
3955
3956      break;  (when expr_tree == NULL)
3957
3958      A standard call is made to the specific intrinsic just as if it had been
3959      passed in as a dummy procedure and called as any old procedure.  This
3960      method can produce slower code but in some cases it's the easiest way for
3961      now.  However, if a (presumably faster) direct call is available,
3962      that is used, so this is the easiest way in many more cases now.
3963
3964      gfrt = FFECOM_gfrtWHATEVER;
3965      break;
3966
3967      gfrt contains the gfrt index of a library function to call, passing the
3968      argument(s) by value rather than by reference.  Used when a more
3969      careful choice of library function is needed than that provided
3970      by the vanilla `break;'.
3971
3972      return expr_tree;
3973
3974      The expr_tree has been completely set up and is ready to be returned
3975      as is.  No further actions are taken.  Use this when the tree is not
3976      in the simple form for one of the arity_n labels.   */
3977
3978   /* For info on how the switch statement cases were written, see the files
3979      enclosed in comments below the switch statement. */
3980
3981   codegen_imp = ffebld_symter_implementation (ffebld_left (expr));
3982   gfrt = ffeintrin_gfrt_direct (codegen_imp);
3983   if (gfrt == FFECOM_gfrt)
3984     gfrt = ffeintrin_gfrt_indirect (codegen_imp);
3985
3986   switch (codegen_imp)
3987     {
3988     case FFEINTRIN_impABS:
3989     case FFEINTRIN_impCABS:
3990     case FFEINTRIN_impCDABS:
3991     case FFEINTRIN_impDABS:
3992     case FFEINTRIN_impIABS:
3993       if (ffeinfo_basictype (ffebld_info (arg1))
3994           == FFEINFO_basictypeCOMPLEX)
3995         {
3996           if (kt == FFEINFO_kindtypeREAL1)
3997             gfrt = FFECOM_gfrtCABS;
3998           else if (kt == FFEINFO_kindtypeREAL2)
3999             gfrt = FFECOM_gfrtCDABS;
4000           break;
4001         }
4002       return ffecom_1 (ABS_EXPR, tree_type,
4003                        convert (tree_type, ffecom_expr (arg1)));
4004
4005     case FFEINTRIN_impACOS:
4006     case FFEINTRIN_impDACOS:
4007       break;
4008
4009     case FFEINTRIN_impAIMAG:
4010     case FFEINTRIN_impDIMAG:
4011     case FFEINTRIN_impIMAGPART:
4012       if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
4013         arg1_type = TREE_TYPE (arg1_type);
4014       else
4015         arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
4016
4017       return
4018         convert (tree_type,
4019                  ffecom_1 (IMAGPART_EXPR, arg1_type,
4020                            ffecom_expr (arg1)));
4021
4022     case FFEINTRIN_impAINT:
4023     case FFEINTRIN_impDINT:
4024 #if 0
4025       /* ~~Someday implement FIX_TRUNC_EXPR yielding same type as arg.  */
4026       return ffecom_1 (FIX_TRUNC_EXPR, tree_type, ffecom_expr (arg1));
4027 #else /* in the meantime, must use floor to avoid range problems with ints */
4028       /* r__1 = r1 >= 0 ? floor(r1) : -floor(-r1); */
4029       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4030       return
4031         convert (tree_type,
4032                  ffecom_3 (COND_EXPR, double_type_node,
4033                            ffecom_truth_value
4034                            (ffecom_2 (GE_EXPR, integer_type_node,
4035                                       saved_expr1,
4036                                       convert (arg1_type,
4037                                                ffecom_float_zero_))),
4038                            ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4039                                              build_tree_list (NULL_TREE,
4040                                                   convert (double_type_node,
4041                                                            saved_expr1)),
4042                                              NULL_TREE),
4043                            ffecom_1 (NEGATE_EXPR, double_type_node,
4044                                      ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4045                                                  build_tree_list (NULL_TREE,
4046                                                   convert (double_type_node,
4047                                                       ffecom_1 (NEGATE_EXPR,
4048                                                                 arg1_type,
4049                                                                saved_expr1))),
4050                                                        NULL_TREE)
4051                                      ))
4052                  );
4053 #endif
4054
4055     case FFEINTRIN_impANINT:
4056     case FFEINTRIN_impDNINT:
4057 #if 0                           /* This way of doing it won't handle real
4058                                    numbers of large magnitudes. */
4059       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4060       expr_tree = convert (tree_type,
4061                            convert (integer_type_node,
4062                                     ffecom_3 (COND_EXPR, tree_type,
4063                                               ffecom_truth_value
4064                                               (ffecom_2 (GE_EXPR,
4065                                                          integer_type_node,
4066                                                          saved_expr1,
4067                                                        ffecom_float_zero_)),
4068                                               ffecom_2 (PLUS_EXPR,
4069                                                         tree_type,
4070                                                         saved_expr1,
4071                                                         ffecom_float_half_),
4072                                               ffecom_2 (MINUS_EXPR,
4073                                                         tree_type,
4074                                                         saved_expr1,
4075                                                      ffecom_float_half_))));
4076       return expr_tree;
4077 #else /* So we instead call floor. */
4078       /* r__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1) */
4079       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4080       return
4081         convert (tree_type,
4082                  ffecom_3 (COND_EXPR, double_type_node,
4083                            ffecom_truth_value
4084                            (ffecom_2 (GE_EXPR, integer_type_node,
4085                                       saved_expr1,
4086                                       convert (arg1_type,
4087                                                ffecom_float_zero_))),
4088                            ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4089                                              build_tree_list (NULL_TREE,
4090                                                   convert (double_type_node,
4091                                                            ffecom_2 (PLUS_EXPR,
4092                                                                      arg1_type,
4093                                                                      saved_expr1,
4094                                                                      convert (arg1_type,
4095                                                                               ffecom_float_half_)))),
4096                                              NULL_TREE),
4097                            ffecom_1 (NEGATE_EXPR, double_type_node,
4098                                      ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4099                                                        build_tree_list (NULL_TREE,
4100                                                                         convert (double_type_node,
4101                                                                                  ffecom_2 (MINUS_EXPR,
4102                                                                                            arg1_type,
4103                                                                                            convert (arg1_type,
4104                                                                                                     ffecom_float_half_),
4105                                                                                            saved_expr1))),
4106                                                        NULL_TREE))
4107                            )
4108                  );
4109 #endif
4110
4111     case FFEINTRIN_impASIN:
4112     case FFEINTRIN_impDASIN:
4113     case FFEINTRIN_impATAN:
4114     case FFEINTRIN_impDATAN:
4115     case FFEINTRIN_impATAN2:
4116     case FFEINTRIN_impDATAN2:
4117       break;
4118
4119     case FFEINTRIN_impCHAR:
4120     case FFEINTRIN_impACHAR:
4121 #ifdef HOHO
4122       tempvar = ffecom_make_tempvar (char_type_node, 1, -1);
4123 #else
4124       tempvar = ffebld_nonter_hook (expr);
4125       assert (tempvar);
4126 #endif
4127       {
4128         tree tmv = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (tempvar)));
4129
4130         expr_tree = ffecom_modify (tmv,
4131                                    ffecom_2 (ARRAY_REF, tmv, tempvar,
4132                                              integer_one_node),
4133                                    convert (tmv, ffecom_expr (arg1)));
4134       }
4135       expr_tree = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar),
4136                             expr_tree,
4137                             tempvar);
4138       expr_tree = ffecom_1 (ADDR_EXPR,
4139                             build_pointer_type (TREE_TYPE (expr_tree)),
4140                             expr_tree);
4141       return expr_tree;
4142
4143     case FFEINTRIN_impCMPLX:
4144     case FFEINTRIN_impDCMPLX:
4145       if (arg2 == NULL)
4146         return
4147           convert (tree_type, ffecom_expr (arg1));
4148
4149       real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4150       return
4151         ffecom_2 (COMPLEX_EXPR, tree_type,
4152                   convert (real_type, ffecom_expr (arg1)),
4153                   convert (real_type,
4154                            ffecom_expr (arg2)));
4155
4156     case FFEINTRIN_impCOMPLEX:
4157       return
4158         ffecom_2 (COMPLEX_EXPR, tree_type,
4159                   ffecom_expr (arg1),
4160                   ffecom_expr (arg2));
4161
4162     case FFEINTRIN_impCONJG:
4163     case FFEINTRIN_impDCONJG:
4164       {
4165         tree arg1_tree;
4166
4167         real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4168         arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4169         return
4170           ffecom_2 (COMPLEX_EXPR, tree_type,
4171                     ffecom_1 (REALPART_EXPR, real_type, arg1_tree),
4172                     ffecom_1 (NEGATE_EXPR, real_type,
4173                               ffecom_1 (IMAGPART_EXPR, real_type, arg1_tree)));
4174       }
4175
4176     case FFEINTRIN_impCOS:
4177     case FFEINTRIN_impCCOS:
4178     case FFEINTRIN_impCDCOS:
4179     case FFEINTRIN_impDCOS:
4180       if (bt == FFEINFO_basictypeCOMPLEX)
4181         {
4182           if (kt == FFEINFO_kindtypeREAL1)
4183             gfrt = FFECOM_gfrtCCOS;     /* Overlapping result okay. */
4184           else if (kt == FFEINFO_kindtypeREAL2)
4185             gfrt = FFECOM_gfrtCDCOS;    /* Overlapping result okay. */
4186         }
4187       break;
4188
4189     case FFEINTRIN_impCOSH:
4190     case FFEINTRIN_impDCOSH:
4191       break;
4192
4193     case FFEINTRIN_impDBLE:
4194     case FFEINTRIN_impDFLOAT:
4195     case FFEINTRIN_impDREAL:
4196     case FFEINTRIN_impFLOAT:
4197     case FFEINTRIN_impIDINT:
4198     case FFEINTRIN_impIFIX:
4199     case FFEINTRIN_impINT2:
4200     case FFEINTRIN_impINT8:
4201     case FFEINTRIN_impINT:
4202     case FFEINTRIN_impLONG:
4203     case FFEINTRIN_impREAL:
4204     case FFEINTRIN_impSHORT:
4205     case FFEINTRIN_impSNGL:
4206       return convert (tree_type, ffecom_expr (arg1));
4207
4208     case FFEINTRIN_impDIM:
4209     case FFEINTRIN_impDDIM:
4210     case FFEINTRIN_impIDIM:
4211       saved_expr1 = ffecom_save_tree (convert (tree_type,
4212                                                ffecom_expr (arg1)));
4213       saved_expr2 = ffecom_save_tree (convert (tree_type,
4214                                                ffecom_expr (arg2)));
4215       return
4216         ffecom_3 (COND_EXPR, tree_type,
4217                   ffecom_truth_value
4218                   (ffecom_2 (GT_EXPR, integer_type_node,
4219                              saved_expr1,
4220                              saved_expr2)),
4221                   ffecom_2 (MINUS_EXPR, tree_type,
4222                             saved_expr1,
4223                             saved_expr2),
4224                   convert (tree_type, ffecom_float_zero_));
4225
4226     case FFEINTRIN_impDPROD:
4227       return
4228         ffecom_2 (MULT_EXPR, tree_type,
4229                   convert (tree_type, ffecom_expr (arg1)),
4230                   convert (tree_type, ffecom_expr (arg2)));
4231
4232     case FFEINTRIN_impEXP:
4233     case FFEINTRIN_impCDEXP:
4234     case FFEINTRIN_impCEXP:
4235     case FFEINTRIN_impDEXP:
4236       if (bt == FFEINFO_basictypeCOMPLEX)
4237         {
4238           if (kt == FFEINFO_kindtypeREAL1)
4239             gfrt = FFECOM_gfrtCEXP;     /* Overlapping result okay. */
4240           else if (kt == FFEINFO_kindtypeREAL2)
4241             gfrt = FFECOM_gfrtCDEXP;    /* Overlapping result okay. */
4242         }
4243       break;
4244
4245     case FFEINTRIN_impICHAR:
4246     case FFEINTRIN_impIACHAR:
4247 #if 0                           /* The simple approach. */
4248       ffecom_char_args_ (&expr_tree, &saved_expr1 /* Ignored */ , arg1);
4249       expr_tree
4250         = ffecom_1 (INDIRECT_REF,
4251                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4252                     expr_tree);
4253       expr_tree
4254         = ffecom_2 (ARRAY_REF,
4255                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4256                     expr_tree,
4257                     integer_one_node);
4258       return convert (tree_type, expr_tree);
4259 #else /* The more interesting (and more optimal) approach. */
4260       expr_tree = ffecom_intrinsic_ichar_ (tree_type, arg1, &saved_expr1);
4261       expr_tree = ffecom_3 (COND_EXPR, tree_type,
4262                             saved_expr1,
4263                             expr_tree,
4264                             convert (tree_type, integer_zero_node));
4265       return expr_tree;
4266 #endif
4267
4268     case FFEINTRIN_impINDEX:
4269       break;
4270
4271     case FFEINTRIN_impLEN:
4272 #if 0
4273       break;                                    /* The simple approach. */
4274 #else
4275       return ffecom_intrinsic_len_ (arg1);      /* The more optimal approach. */
4276 #endif
4277
4278     case FFEINTRIN_impLGE:
4279     case FFEINTRIN_impLGT:
4280     case FFEINTRIN_impLLE:
4281     case FFEINTRIN_impLLT:
4282       break;
4283
4284     case FFEINTRIN_impLOG:
4285     case FFEINTRIN_impALOG:
4286     case FFEINTRIN_impCDLOG:
4287     case FFEINTRIN_impCLOG:
4288     case FFEINTRIN_impDLOG:
4289       if (bt == FFEINFO_basictypeCOMPLEX)
4290         {
4291           if (kt == FFEINFO_kindtypeREAL1)
4292             gfrt = FFECOM_gfrtCLOG;     /* Overlapping result okay. */
4293           else if (kt == FFEINFO_kindtypeREAL2)
4294             gfrt = FFECOM_gfrtCDLOG;    /* Overlapping result okay. */
4295         }
4296       break;
4297
4298     case FFEINTRIN_impLOG10:
4299     case FFEINTRIN_impALOG10:
4300     case FFEINTRIN_impDLOG10:
4301       if (gfrt != FFECOM_gfrt)
4302         break;  /* Already picked one, stick with it. */
4303
4304       if (kt == FFEINFO_kindtypeREAL1)
4305         /* We used to call FFECOM_gfrtALOG10 here.  */
4306         gfrt = FFECOM_gfrtL_LOG10;
4307       else if (kt == FFEINFO_kindtypeREAL2)
4308         /* We used to call FFECOM_gfrtDLOG10 here.  */
4309         gfrt = FFECOM_gfrtL_LOG10;
4310       break;
4311
4312     case FFEINTRIN_impMAX:
4313     case FFEINTRIN_impAMAX0:
4314     case FFEINTRIN_impAMAX1:
4315     case FFEINTRIN_impDMAX1:
4316     case FFEINTRIN_impMAX0:
4317     case FFEINTRIN_impMAX1:
4318       if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4319         arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4320       else
4321         arg1_type = tree_type;
4322       expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4323                             convert (arg1_type, ffecom_expr (arg1)),
4324                             convert (arg1_type, ffecom_expr (arg2)));
4325       for (; list != NULL; list = ffebld_trail (list))
4326         {
4327           if ((ffebld_head (list) == NULL)
4328               || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4329             continue;
4330           expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4331                                 expr_tree,
4332                                 convert (arg1_type,
4333                                          ffecom_expr (ffebld_head (list))));
4334         }
4335       return convert (tree_type, expr_tree);
4336
4337     case FFEINTRIN_impMIN:
4338     case FFEINTRIN_impAMIN0:
4339     case FFEINTRIN_impAMIN1:
4340     case FFEINTRIN_impDMIN1:
4341     case FFEINTRIN_impMIN0:
4342     case FFEINTRIN_impMIN1:
4343       if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4344         arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4345       else
4346         arg1_type = tree_type;
4347       expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4348                             convert (arg1_type, ffecom_expr (arg1)),
4349                             convert (arg1_type, ffecom_expr (arg2)));
4350       for (; list != NULL; list = ffebld_trail (list))
4351         {
4352           if ((ffebld_head (list) == NULL)
4353               || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4354             continue;
4355           expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4356                                 expr_tree,
4357                                 convert (arg1_type,
4358                                          ffecom_expr (ffebld_head (list))));
4359         }
4360       return convert (tree_type, expr_tree);
4361
4362     case FFEINTRIN_impMOD:
4363     case FFEINTRIN_impAMOD:
4364     case FFEINTRIN_impDMOD:
4365       if (bt != FFEINFO_basictypeREAL)
4366         return ffecom_2 (TRUNC_MOD_EXPR, tree_type,
4367                          convert (tree_type, ffecom_expr (arg1)),
4368                          convert (tree_type, ffecom_expr (arg2)));
4369
4370       if (kt == FFEINFO_kindtypeREAL1)
4371         /* We used to call FFECOM_gfrtAMOD here.  */
4372         gfrt = FFECOM_gfrtL_FMOD;
4373       else if (kt == FFEINFO_kindtypeREAL2)
4374         /* We used to call FFECOM_gfrtDMOD here.  */
4375         gfrt = FFECOM_gfrtL_FMOD;
4376       break;
4377
4378     case FFEINTRIN_impNINT:
4379     case FFEINTRIN_impIDNINT:
4380 #if 0
4381       /* ~~Ideally FIX_ROUND_EXPR would be implemented, but it ain't yet.  */
4382       return ffecom_1 (FIX_ROUND_EXPR, tree_type, ffecom_expr (arg1));
4383 #else
4384       /* i__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1); */
4385       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4386       return
4387         convert (ffecom_integer_type_node,
4388                  ffecom_3 (COND_EXPR, arg1_type,
4389                            ffecom_truth_value
4390                            (ffecom_2 (GE_EXPR, integer_type_node,
4391                                       saved_expr1,
4392                                       convert (arg1_type,
4393                                                ffecom_float_zero_))),
4394                            ffecom_2 (PLUS_EXPR, arg1_type,
4395                                      saved_expr1,
4396                                      convert (arg1_type,
4397                                               ffecom_float_half_)),
4398                            ffecom_2 (MINUS_EXPR, arg1_type,
4399                                      saved_expr1,
4400                                      convert (arg1_type,
4401                                               ffecom_float_half_))));
4402 #endif
4403
4404     case FFEINTRIN_impSIGN:
4405     case FFEINTRIN_impDSIGN:
4406     case FFEINTRIN_impISIGN:
4407       {
4408         tree arg2_tree = ffecom_expr (arg2);
4409
4410         saved_expr1
4411           = ffecom_save_tree
4412           (ffecom_1 (ABS_EXPR, tree_type,
4413                      convert (tree_type,
4414                               ffecom_expr (arg1))));
4415         expr_tree
4416           = ffecom_3 (COND_EXPR, tree_type,
4417                       ffecom_truth_value
4418                       (ffecom_2 (GE_EXPR, integer_type_node,
4419                                  arg2_tree,
4420                                  convert (TREE_TYPE (arg2_tree),
4421                                           integer_zero_node))),
4422                       saved_expr1,
4423                       ffecom_1 (NEGATE_EXPR, tree_type, saved_expr1));
4424         /* Make sure SAVE_EXPRs get referenced early enough. */
4425         expr_tree
4426           = ffecom_2 (COMPOUND_EXPR, tree_type,
4427                       convert (void_type_node, saved_expr1),
4428                       expr_tree);
4429       }
4430       return expr_tree;
4431
4432     case FFEINTRIN_impSIN:
4433     case FFEINTRIN_impCDSIN:
4434     case FFEINTRIN_impCSIN:
4435     case FFEINTRIN_impDSIN:
4436       if (bt == FFEINFO_basictypeCOMPLEX)
4437         {
4438           if (kt == FFEINFO_kindtypeREAL1)
4439             gfrt = FFECOM_gfrtCSIN;     /* Overlapping result okay. */
4440           else if (kt == FFEINFO_kindtypeREAL2)
4441             gfrt = FFECOM_gfrtCDSIN;    /* Overlapping result okay. */
4442         }
4443       break;
4444
4445     case FFEINTRIN_impSINH:
4446     case FFEINTRIN_impDSINH:
4447       break;
4448
4449     case FFEINTRIN_impSQRT:
4450     case FFEINTRIN_impCDSQRT:
4451     case FFEINTRIN_impCSQRT:
4452     case FFEINTRIN_impDSQRT:
4453       if (bt == FFEINFO_basictypeCOMPLEX)
4454         {
4455           if (kt == FFEINFO_kindtypeREAL1)
4456             gfrt = FFECOM_gfrtCSQRT;    /* Overlapping result okay. */
4457           else if (kt == FFEINFO_kindtypeREAL2)
4458             gfrt = FFECOM_gfrtCDSQRT;   /* Overlapping result okay. */
4459         }
4460       break;
4461
4462     case FFEINTRIN_impTAN:
4463     case FFEINTRIN_impDTAN:
4464     case FFEINTRIN_impTANH:
4465     case FFEINTRIN_impDTANH:
4466       break;
4467
4468     case FFEINTRIN_impREALPART:
4469       if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
4470         arg1_type = TREE_TYPE (arg1_type);
4471       else
4472         arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
4473
4474       return
4475         convert (tree_type,
4476                  ffecom_1 (REALPART_EXPR, arg1_type,
4477                            ffecom_expr (arg1)));
4478
4479     case FFEINTRIN_impIAND:
4480     case FFEINTRIN_impAND:
4481       return ffecom_2 (BIT_AND_EXPR, tree_type,
4482                        convert (tree_type,
4483                                 ffecom_expr (arg1)),
4484                        convert (tree_type,
4485                                 ffecom_expr (arg2)));
4486
4487     case FFEINTRIN_impIOR:
4488     case FFEINTRIN_impOR:
4489       return ffecom_2 (BIT_IOR_EXPR, tree_type,
4490                        convert (tree_type,
4491                                 ffecom_expr (arg1)),
4492                        convert (tree_type,
4493                                 ffecom_expr (arg2)));
4494
4495     case FFEINTRIN_impIEOR:
4496     case FFEINTRIN_impXOR:
4497       return ffecom_2 (BIT_XOR_EXPR, tree_type,
4498                        convert (tree_type,
4499                                 ffecom_expr (arg1)),
4500                        convert (tree_type,
4501                                 ffecom_expr (arg2)));
4502
4503     case FFEINTRIN_impLSHIFT:
4504       return ffecom_2 (LSHIFT_EXPR, tree_type,
4505                        ffecom_expr (arg1),
4506                        convert (integer_type_node,
4507                                 ffecom_expr (arg2)));
4508
4509     case FFEINTRIN_impRSHIFT:
4510       return ffecom_2 (RSHIFT_EXPR, tree_type,
4511                        ffecom_expr (arg1),
4512                        convert (integer_type_node,
4513                                 ffecom_expr (arg2)));
4514
4515     case FFEINTRIN_impNOT:
4516       return ffecom_1 (BIT_NOT_EXPR, tree_type, ffecom_expr (arg1));
4517
4518     case FFEINTRIN_impBIT_SIZE:
4519       return convert (tree_type, TYPE_SIZE (arg1_type));
4520
4521     case FFEINTRIN_impBTEST:
4522       {
4523         ffetargetLogical1 true;
4524         ffetargetLogical1 false;
4525         tree true_tree;
4526         tree false_tree;
4527
4528         ffetarget_logical1 (&true, TRUE);
4529         ffetarget_logical1 (&false, FALSE);
4530         if (true == 1)
4531           true_tree = convert (tree_type, integer_one_node);
4532         else
4533           true_tree = convert (tree_type, build_int_2 (true, 0));
4534         if (false == 0)
4535           false_tree = convert (tree_type, integer_zero_node);
4536         else
4537           false_tree = convert (tree_type, build_int_2 (false, 0));
4538
4539         return
4540           ffecom_3 (COND_EXPR, tree_type,
4541                     ffecom_truth_value
4542                     (ffecom_2 (EQ_EXPR, integer_type_node,
4543                                ffecom_2 (BIT_AND_EXPR, arg1_type,
4544                                          ffecom_expr (arg1),
4545                                          ffecom_2 (LSHIFT_EXPR, arg1_type,
4546                                                    convert (arg1_type,
4547                                                           integer_one_node),
4548                                                    convert (integer_type_node,
4549                                                             ffecom_expr (arg2)))),
4550                                convert (arg1_type,
4551                                         integer_zero_node))),
4552                     false_tree,
4553                     true_tree);
4554       }
4555
4556     case FFEINTRIN_impIBCLR:
4557       return
4558         ffecom_2 (BIT_AND_EXPR, tree_type,
4559                   ffecom_expr (arg1),
4560                   ffecom_1 (BIT_NOT_EXPR, tree_type,
4561                             ffecom_2 (LSHIFT_EXPR, tree_type,
4562                                       convert (tree_type,
4563                                                integer_one_node),
4564                                       convert (integer_type_node,
4565                                                ffecom_expr (arg2)))));
4566
4567     case FFEINTRIN_impIBITS:
4568       {
4569         tree arg3_tree = ffecom_save_tree (convert (integer_type_node,
4570                                                     ffecom_expr (arg3)));
4571         tree uns_type
4572         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4573
4574         expr_tree
4575           = ffecom_2 (BIT_AND_EXPR, tree_type,
4576                       ffecom_2 (RSHIFT_EXPR, tree_type,
4577                                 ffecom_expr (arg1),
4578                                 convert (integer_type_node,
4579                                          ffecom_expr (arg2))),
4580                       convert (tree_type,
4581                                ffecom_2 (RSHIFT_EXPR, uns_type,
4582                                          ffecom_1 (BIT_NOT_EXPR,
4583                                                    uns_type,
4584                                                    convert (uns_type,
4585                                                         integer_zero_node)),
4586                                          ffecom_2 (MINUS_EXPR,
4587                                                    integer_type_node,
4588                                                    TYPE_SIZE (uns_type),
4589                                                    arg3_tree))));
4590 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4591         expr_tree
4592           = ffecom_3 (COND_EXPR, tree_type,
4593                       ffecom_truth_value
4594                       (ffecom_2 (NE_EXPR, integer_type_node,
4595                                  arg3_tree,
4596                                  integer_zero_node)),
4597                       expr_tree,
4598                       convert (tree_type, integer_zero_node));
4599 #endif
4600       }
4601       return expr_tree;
4602
4603     case FFEINTRIN_impIBSET:
4604       return
4605         ffecom_2 (BIT_IOR_EXPR, tree_type,
4606                   ffecom_expr (arg1),
4607                   ffecom_2 (LSHIFT_EXPR, tree_type,
4608                             convert (tree_type, integer_one_node),
4609                             convert (integer_type_node,
4610                                      ffecom_expr (arg2))));
4611
4612     case FFEINTRIN_impISHFT:
4613       {
4614         tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4615         tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4616                                                     ffecom_expr (arg2)));
4617         tree uns_type
4618         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4619
4620         expr_tree
4621           = ffecom_3 (COND_EXPR, tree_type,
4622                       ffecom_truth_value
4623                       (ffecom_2 (GE_EXPR, integer_type_node,
4624                                  arg2_tree,
4625                                  integer_zero_node)),
4626                       ffecom_2 (LSHIFT_EXPR, tree_type,
4627                                 arg1_tree,
4628                                 arg2_tree),
4629                       convert (tree_type,
4630                                ffecom_2 (RSHIFT_EXPR, uns_type,
4631                                          convert (uns_type, arg1_tree),
4632                                          ffecom_1 (NEGATE_EXPR,
4633                                                    integer_type_node,
4634                                                    arg2_tree))));
4635 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4636         expr_tree
4637           = ffecom_3 (COND_EXPR, tree_type,
4638                       ffecom_truth_value
4639                       (ffecom_2 (NE_EXPR, integer_type_node,
4640                                  arg2_tree,
4641                                  TYPE_SIZE (uns_type))),
4642                       expr_tree,
4643                       convert (tree_type, integer_zero_node));
4644 #endif
4645         /* Make sure SAVE_EXPRs get referenced early enough. */
4646         expr_tree
4647           = ffecom_2 (COMPOUND_EXPR, tree_type,
4648                       convert (void_type_node, arg1_tree),
4649                       ffecom_2 (COMPOUND_EXPR, tree_type,
4650                                 convert (void_type_node, arg2_tree),
4651                                 expr_tree));
4652       }
4653       return expr_tree;
4654
4655     case FFEINTRIN_impISHFTC:
4656       {
4657         tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4658         tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4659                                                     ffecom_expr (arg2)));
4660         tree arg3_tree = (arg3 == NULL) ? TYPE_SIZE (tree_type)
4661         : ffecom_save_tree (convert (integer_type_node, ffecom_expr (arg3)));
4662         tree shift_neg;
4663         tree shift_pos;
4664         tree mask_arg1;
4665         tree masked_arg1;
4666         tree uns_type
4667         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4668
4669         mask_arg1
4670           = ffecom_2 (LSHIFT_EXPR, tree_type,
4671                       ffecom_1 (BIT_NOT_EXPR, tree_type,
4672                                 convert (tree_type, integer_zero_node)),
4673                       arg3_tree);
4674 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4675         mask_arg1
4676           = ffecom_3 (COND_EXPR, tree_type,
4677                       ffecom_truth_value
4678                       (ffecom_2 (NE_EXPR, integer_type_node,
4679                                  arg3_tree,
4680                                  TYPE_SIZE (uns_type))),
4681                       mask_arg1,
4682                       convert (tree_type, integer_zero_node));
4683 #endif
4684         mask_arg1 = ffecom_save_tree (mask_arg1);
4685         masked_arg1
4686           = ffecom_2 (BIT_AND_EXPR, tree_type,
4687                       arg1_tree,
4688                       ffecom_1 (BIT_NOT_EXPR, tree_type,
4689                                 mask_arg1));
4690         masked_arg1 = ffecom_save_tree (masked_arg1);
4691         shift_neg
4692           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4693                       convert (tree_type,
4694                                ffecom_2 (RSHIFT_EXPR, uns_type,
4695                                          convert (uns_type, masked_arg1),
4696                                          ffecom_1 (NEGATE_EXPR,
4697                                                    integer_type_node,
4698                                                    arg2_tree))),
4699                       ffecom_2 (LSHIFT_EXPR, tree_type,
4700                                 arg1_tree,
4701                                 ffecom_2 (PLUS_EXPR, integer_type_node,
4702                                           arg2_tree,
4703                                           arg3_tree)));
4704         shift_pos
4705           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4706                       ffecom_2 (LSHIFT_EXPR, tree_type,
4707                                 arg1_tree,
4708                                 arg2_tree),
4709                       convert (tree_type,
4710                                ffecom_2 (RSHIFT_EXPR, uns_type,
4711                                          convert (uns_type, masked_arg1),
4712                                          ffecom_2 (MINUS_EXPR,
4713                                                    integer_type_node,
4714                                                    arg3_tree,
4715                                                    arg2_tree))));
4716         expr_tree
4717           = ffecom_3 (COND_EXPR, tree_type,
4718                       ffecom_truth_value
4719                       (ffecom_2 (LT_EXPR, integer_type_node,
4720                                  arg2_tree,
4721                                  integer_zero_node)),
4722                       shift_neg,
4723                       shift_pos);
4724         expr_tree
4725           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4726                       ffecom_2 (BIT_AND_EXPR, tree_type,
4727                                 mask_arg1,
4728                                 arg1_tree),
4729                       ffecom_2 (BIT_AND_EXPR, tree_type,
4730                                 ffecom_1 (BIT_NOT_EXPR, tree_type,
4731                                           mask_arg1),
4732                                 expr_tree));
4733         expr_tree
4734           = ffecom_3 (COND_EXPR, tree_type,
4735                       ffecom_truth_value
4736                       (ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
4737                                  ffecom_2 (EQ_EXPR, integer_type_node,
4738                                            ffecom_1 (ABS_EXPR,
4739                                                      integer_type_node,
4740                                                      arg2_tree),
4741                                            arg3_tree),
4742                                  ffecom_2 (EQ_EXPR, integer_type_node,
4743                                            arg2_tree,
4744                                            integer_zero_node))),
4745                       arg1_tree,
4746                       expr_tree);
4747         /* Make sure SAVE_EXPRs get referenced early enough. */
4748         expr_tree
4749           = ffecom_2 (COMPOUND_EXPR, tree_type,
4750                       convert (void_type_node, arg1_tree),
4751                       ffecom_2 (COMPOUND_EXPR, tree_type,
4752                                 convert (void_type_node, arg2_tree),
4753                                 ffecom_2 (COMPOUND_EXPR, tree_type,
4754                                           convert (void_type_node,
4755                                                    mask_arg1),
4756                                           ffecom_2 (COMPOUND_EXPR, tree_type,
4757                                                     convert (void_type_node,
4758                                                              masked_arg1),
4759                                                     expr_tree))));
4760         expr_tree
4761           = ffecom_2 (COMPOUND_EXPR, tree_type,
4762                       convert (void_type_node,
4763                                arg3_tree),
4764                       expr_tree);
4765       }
4766       return expr_tree;
4767
4768     case FFEINTRIN_impLOC:
4769       {
4770         tree arg1_tree = ffecom_expr (arg1);
4771
4772         expr_tree
4773           = convert (tree_type,
4774                      ffecom_1 (ADDR_EXPR,
4775                                build_pointer_type (TREE_TYPE (arg1_tree)),
4776                                arg1_tree));
4777       }
4778       return expr_tree;
4779
4780     case FFEINTRIN_impMVBITS:
4781       {
4782         tree arg1_tree;
4783         tree arg2_tree;
4784         tree arg3_tree;
4785         ffebld arg4 = ffebld_head (ffebld_trail (list));
4786         tree arg4_tree;
4787         tree arg4_type;
4788         ffebld arg5 = ffebld_head (ffebld_trail (ffebld_trail (list)));
4789         tree arg5_tree;
4790         tree prep_arg1;
4791         tree prep_arg4;
4792         tree arg5_plus_arg3;
4793
4794         arg2_tree = convert (integer_type_node,
4795                              ffecom_expr (arg2));
4796         arg3_tree = ffecom_save_tree (convert (integer_type_node,
4797                                                ffecom_expr (arg3)));
4798         arg4_tree = ffecom_expr_rw (NULL_TREE, arg4);
4799         arg4_type = TREE_TYPE (arg4_tree);
4800
4801         arg1_tree = ffecom_save_tree (convert (arg4_type,
4802                                                ffecom_expr (arg1)));
4803
4804         arg5_tree = ffecom_save_tree (convert (integer_type_node,
4805                                                ffecom_expr (arg5)));
4806
4807         prep_arg1
4808           = ffecom_2 (LSHIFT_EXPR, arg4_type,
4809                       ffecom_2 (BIT_AND_EXPR, arg4_type,
4810                                 ffecom_2 (RSHIFT_EXPR, arg4_type,
4811                                           arg1_tree,
4812                                           arg2_tree),
4813                                 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4814                                           ffecom_2 (LSHIFT_EXPR, arg4_type,
4815                                                     ffecom_1 (BIT_NOT_EXPR,
4816                                                               arg4_type,
4817                                                               convert
4818                                                               (arg4_type,
4819                                                         integer_zero_node)),
4820                                                     arg3_tree))),
4821                       arg5_tree);
4822         arg5_plus_arg3
4823           = ffecom_save_tree (ffecom_2 (PLUS_EXPR, arg4_type,
4824                                         arg5_tree,
4825                                         arg3_tree));
4826         prep_arg4
4827           = ffecom_2 (LSHIFT_EXPR, arg4_type,
4828                       ffecom_1 (BIT_NOT_EXPR, arg4_type,
4829                                 convert (arg4_type,
4830                                          integer_zero_node)),
4831                       arg5_plus_arg3);
4832 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4833         prep_arg4
4834           = ffecom_3 (COND_EXPR, arg4_type,
4835                       ffecom_truth_value
4836                       (ffecom_2 (NE_EXPR, integer_type_node,
4837                                  arg5_plus_arg3,
4838                                  convert (TREE_TYPE (arg5_plus_arg3),
4839                                           TYPE_SIZE (arg4_type)))),
4840                       prep_arg4,
4841                       convert (arg4_type, integer_zero_node));
4842 #endif
4843         prep_arg4
4844           = ffecom_2 (BIT_AND_EXPR, arg4_type,
4845                       arg4_tree,
4846                       ffecom_2 (BIT_IOR_EXPR, arg4_type,
4847                                 prep_arg4,
4848                                 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4849                                           ffecom_2 (LSHIFT_EXPR, arg4_type,
4850                                                     ffecom_1 (BIT_NOT_EXPR,
4851                                                               arg4_type,
4852                                                               convert
4853                                                               (arg4_type,
4854                                                         integer_zero_node)),
4855                                                     arg5_tree))));
4856         prep_arg1
4857           = ffecom_2 (BIT_IOR_EXPR, arg4_type,
4858                       prep_arg1,
4859                       prep_arg4);
4860 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4861         prep_arg1
4862           = ffecom_3 (COND_EXPR, arg4_type,
4863                       ffecom_truth_value
4864                       (ffecom_2 (NE_EXPR, integer_type_node,
4865                                  arg3_tree,
4866                                  convert (TREE_TYPE (arg3_tree),
4867                                           integer_zero_node))),
4868                       prep_arg1,
4869                       arg4_tree);
4870         prep_arg1
4871           = ffecom_3 (COND_EXPR, arg4_type,
4872                       ffecom_truth_value
4873                       (ffecom_2 (NE_EXPR, integer_type_node,
4874                                  arg3_tree,
4875                                  convert (TREE_TYPE (arg3_tree),
4876                                           TYPE_SIZE (arg4_type)))),
4877                       prep_arg1,
4878                       arg1_tree);
4879 #endif
4880         expr_tree
4881           = ffecom_2s (MODIFY_EXPR, void_type_node,
4882                        arg4_tree,
4883                        prep_arg1);
4884         /* Make sure SAVE_EXPRs get referenced early enough. */
4885         expr_tree
4886           = ffecom_2 (COMPOUND_EXPR, void_type_node,
4887                       arg1_tree,
4888                       ffecom_2 (COMPOUND_EXPR, void_type_node,
4889                                 arg3_tree,
4890                                 ffecom_2 (COMPOUND_EXPR, void_type_node,
4891                                           arg5_tree,
4892                                           ffecom_2 (COMPOUND_EXPR, void_type_node,
4893                                                     arg5_plus_arg3,
4894                                                     expr_tree))));
4895         expr_tree
4896           = ffecom_2 (COMPOUND_EXPR, void_type_node,
4897                       arg4_tree,
4898                       expr_tree);
4899
4900       }
4901       return expr_tree;
4902
4903     case FFEINTRIN_impDERF:
4904     case FFEINTRIN_impERF:
4905     case FFEINTRIN_impDERFC:
4906     case FFEINTRIN_impERFC:
4907       break;
4908
4909     case FFEINTRIN_impIARGC:
4910       /* extern int xargc; i__1 = xargc - 1; */
4911       expr_tree = ffecom_2 (MINUS_EXPR, TREE_TYPE (ffecom_tree_xargc_),
4912                             ffecom_tree_xargc_,
4913                             convert (TREE_TYPE (ffecom_tree_xargc_),
4914                                      integer_one_node));
4915       return expr_tree;
4916
4917     case FFEINTRIN_impSIGNAL_func:
4918     case FFEINTRIN_impSIGNAL_subr:
4919       {
4920         tree arg1_tree;
4921         tree arg2_tree;
4922         tree arg3_tree;
4923
4924         arg1_tree = convert (ffecom_f2c_integer_type_node,
4925                              ffecom_expr (arg1));
4926         arg1_tree = ffecom_1 (ADDR_EXPR,
4927                               build_pointer_type (TREE_TYPE (arg1_tree)),
4928                               arg1_tree);
4929
4930         /* Pass procedure as a pointer to it, anything else by value.  */
4931         if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
4932           arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
4933         else
4934           arg2_tree = ffecom_ptr_to_expr (arg2);
4935         arg2_tree = convert (TREE_TYPE (null_pointer_node),
4936                              arg2_tree);
4937
4938         if (arg3 != NULL)
4939           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
4940         else
4941           arg3_tree = NULL_TREE;
4942
4943         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4944         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4945         TREE_CHAIN (arg1_tree) = arg2_tree;
4946
4947         expr_tree
4948           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4949                           ffecom_gfrt_kindtype (gfrt),
4950                           FALSE,
4951                           ((codegen_imp == FFEINTRIN_impSIGNAL_subr) ?
4952                            NULL_TREE :
4953                            tree_type),
4954                           arg1_tree,
4955                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4956                           ffebld_nonter_hook (expr));
4957
4958         if (arg3_tree != NULL_TREE)
4959           expr_tree
4960             = ffecom_modify (NULL_TREE, arg3_tree,
4961                              convert (TREE_TYPE (arg3_tree),
4962                                       expr_tree));
4963       }
4964       return expr_tree;
4965
4966     case FFEINTRIN_impALARM:
4967       {
4968         tree arg1_tree;
4969         tree arg2_tree;
4970         tree arg3_tree;
4971
4972         arg1_tree = convert (ffecom_f2c_integer_type_node,
4973                              ffecom_expr (arg1));
4974         arg1_tree = ffecom_1 (ADDR_EXPR,
4975                               build_pointer_type (TREE_TYPE (arg1_tree)),
4976                               arg1_tree);
4977
4978         /* Pass procedure as a pointer to it, anything else by value.  */
4979         if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
4980           arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
4981         else
4982           arg2_tree = ffecom_ptr_to_expr (arg2);
4983         arg2_tree = convert (TREE_TYPE (null_pointer_node),
4984                              arg2_tree);
4985
4986         if (arg3 != NULL)
4987           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
4988         else
4989           arg3_tree = NULL_TREE;
4990
4991         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4992         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4993         TREE_CHAIN (arg1_tree) = arg2_tree;
4994
4995         expr_tree
4996           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4997                           ffecom_gfrt_kindtype (gfrt),
4998                           FALSE,
4999                           NULL_TREE,
5000                           arg1_tree,
5001                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5002                           ffebld_nonter_hook (expr));
5003
5004         if (arg3_tree != NULL_TREE)
5005           expr_tree
5006             = ffecom_modify (NULL_TREE, arg3_tree,
5007                              convert (TREE_TYPE (arg3_tree),
5008                                       expr_tree));
5009       }
5010       return expr_tree;
5011
5012     case FFEINTRIN_impCHDIR_subr:
5013     case FFEINTRIN_impFDATE_subr:
5014     case FFEINTRIN_impFGET_subr:
5015     case FFEINTRIN_impFPUT_subr:
5016     case FFEINTRIN_impGETCWD_subr:
5017     case FFEINTRIN_impHOSTNM_subr:
5018     case FFEINTRIN_impSYSTEM_subr:
5019     case FFEINTRIN_impUNLINK_subr:
5020       {
5021         tree arg1_len = integer_zero_node;
5022         tree arg1_tree;
5023         tree arg2_tree;
5024
5025         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5026
5027         if (arg2 != NULL)
5028           arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
5029         else
5030           arg2_tree = NULL_TREE;
5031
5032         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5033         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5034         TREE_CHAIN (arg1_tree) = arg1_len;
5035
5036         expr_tree
5037           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5038                           ffecom_gfrt_kindtype (gfrt),
5039                           FALSE,
5040                           NULL_TREE,
5041                           arg1_tree,
5042                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5043                           ffebld_nonter_hook (expr));
5044
5045         if (arg2_tree != NULL_TREE)
5046           expr_tree
5047             = ffecom_modify (NULL_TREE, arg2_tree,
5048                              convert (TREE_TYPE (arg2_tree),
5049                                       expr_tree));
5050       }
5051       return expr_tree;
5052
5053     case FFEINTRIN_impEXIT:
5054       if (arg1 != NULL)
5055         break;
5056
5057       expr_tree = build_tree_list (NULL_TREE,
5058                                    ffecom_1 (ADDR_EXPR,
5059                                              build_pointer_type
5060                                              (ffecom_integer_type_node),
5061                                              integer_zero_node));
5062
5063       return
5064         ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5065                       ffecom_gfrt_kindtype (gfrt),
5066                       FALSE,
5067                       void_type_node,
5068                       expr_tree,
5069                       NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5070                       ffebld_nonter_hook (expr));
5071
5072     case FFEINTRIN_impFLUSH:
5073       if (arg1 == NULL)
5074         gfrt = FFECOM_gfrtFLUSH;
5075       else
5076         gfrt = FFECOM_gfrtFLUSH1;
5077       break;
5078
5079     case FFEINTRIN_impCHMOD_subr:
5080     case FFEINTRIN_impLINK_subr:
5081     case FFEINTRIN_impRENAME_subr:
5082     case FFEINTRIN_impSYMLNK_subr:
5083       {
5084         tree arg1_len = integer_zero_node;
5085         tree arg1_tree;
5086         tree arg2_len = integer_zero_node;
5087         tree arg2_tree;
5088         tree arg3_tree;
5089
5090         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5091         arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
5092         if (arg3 != NULL)
5093           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5094         else
5095           arg3_tree = NULL_TREE;
5096
5097         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5098         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5099         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5100         arg2_len = build_tree_list (NULL_TREE, arg2_len);
5101         TREE_CHAIN (arg1_tree) = arg2_tree;
5102         TREE_CHAIN (arg2_tree) = arg1_len;
5103         TREE_CHAIN (arg1_len) = arg2_len;
5104         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5105                                   ffecom_gfrt_kindtype (gfrt),
5106                                   FALSE,
5107                                   NULL_TREE,
5108                                   arg1_tree,
5109                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5110                                   ffebld_nonter_hook (expr));
5111         if (arg3_tree != NULL_TREE)
5112           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5113                                      convert (TREE_TYPE (arg3_tree),
5114                                               expr_tree));
5115       }
5116       return expr_tree;
5117
5118     case FFEINTRIN_impLSTAT_subr:
5119     case FFEINTRIN_impSTAT_subr:
5120       {
5121         tree arg1_len = integer_zero_node;
5122         tree arg1_tree;
5123         tree arg2_tree;
5124         tree arg3_tree;
5125
5126         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5127
5128         arg2_tree = ffecom_ptr_to_expr (arg2);
5129
5130         if (arg3 != NULL)
5131           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5132         else
5133           arg3_tree = NULL_TREE;
5134
5135         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5136         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5137         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5138         TREE_CHAIN (arg1_tree) = arg2_tree;
5139         TREE_CHAIN (arg2_tree) = arg1_len;
5140         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5141                                   ffecom_gfrt_kindtype (gfrt),
5142                                   FALSE,
5143                                   NULL_TREE,
5144                                   arg1_tree,
5145                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5146                                   ffebld_nonter_hook (expr));
5147         if (arg3_tree != NULL_TREE)
5148           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5149                                      convert (TREE_TYPE (arg3_tree),
5150                                               expr_tree));
5151       }
5152       return expr_tree;
5153
5154     case FFEINTRIN_impFGETC_subr:
5155     case FFEINTRIN_impFPUTC_subr:
5156       {
5157         tree arg1_tree;
5158         tree arg2_tree;
5159         tree arg2_len = integer_zero_node;
5160         tree arg3_tree;
5161
5162         arg1_tree = convert (ffecom_f2c_integer_type_node,
5163                              ffecom_expr (arg1));
5164         arg1_tree = ffecom_1 (ADDR_EXPR,
5165                               build_pointer_type (TREE_TYPE (arg1_tree)),
5166                               arg1_tree);
5167
5168         arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
5169         if (arg3 != NULL)
5170           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5171         else
5172           arg3_tree = NULL_TREE;
5173
5174         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5175         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5176         arg2_len = build_tree_list (NULL_TREE, arg2_len);
5177         TREE_CHAIN (arg1_tree) = arg2_tree;
5178         TREE_CHAIN (arg2_tree) = arg2_len;
5179
5180         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5181                                   ffecom_gfrt_kindtype (gfrt),
5182                                   FALSE,
5183                                   NULL_TREE,
5184                                   arg1_tree,
5185                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5186                                   ffebld_nonter_hook (expr));
5187         if (arg3_tree != NULL_TREE)
5188           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5189                                      convert (TREE_TYPE (arg3_tree),
5190                                               expr_tree));
5191       }
5192       return expr_tree;
5193
5194     case FFEINTRIN_impFSTAT_subr:
5195       {
5196         tree arg1_tree;
5197         tree arg2_tree;
5198         tree arg3_tree;
5199
5200         arg1_tree = convert (ffecom_f2c_integer_type_node,
5201                              ffecom_expr (arg1));
5202         arg1_tree = ffecom_1 (ADDR_EXPR,
5203                               build_pointer_type (TREE_TYPE (arg1_tree)),
5204                               arg1_tree);
5205
5206         arg2_tree = convert (ffecom_f2c_ptr_to_integer_type_node,
5207                              ffecom_ptr_to_expr (arg2));
5208
5209         if (arg3 == NULL)
5210           arg3_tree = NULL_TREE;
5211         else
5212           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5213
5214         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5215         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5216         TREE_CHAIN (arg1_tree) = arg2_tree;
5217         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5218                                   ffecom_gfrt_kindtype (gfrt),
5219                                   FALSE,
5220                                   NULL_TREE,
5221                                   arg1_tree,
5222                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5223                                   ffebld_nonter_hook (expr));
5224         if (arg3_tree != NULL_TREE) {
5225           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5226                                      convert (TREE_TYPE (arg3_tree),
5227                                               expr_tree));
5228         }
5229       }
5230       return expr_tree;
5231
5232     case FFEINTRIN_impKILL_subr:
5233       {
5234         tree arg1_tree;
5235         tree arg2_tree;
5236         tree arg3_tree;
5237
5238         arg1_tree = convert (ffecom_f2c_integer_type_node,
5239                              ffecom_expr (arg1));
5240         arg1_tree = ffecom_1 (ADDR_EXPR,
5241                               build_pointer_type (TREE_TYPE (arg1_tree)),
5242                               arg1_tree);
5243
5244         arg2_tree = convert (ffecom_f2c_integer_type_node,
5245                              ffecom_expr (arg2));
5246         arg2_tree = ffecom_1 (ADDR_EXPR,
5247                               build_pointer_type (TREE_TYPE (arg2_tree)),
5248                               arg2_tree);
5249
5250         if (arg3 == NULL)
5251           arg3_tree = NULL_TREE;
5252         else
5253           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5254
5255         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5256         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5257         TREE_CHAIN (arg1_tree) = arg2_tree;
5258         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5259                                   ffecom_gfrt_kindtype (gfrt),
5260                                   FALSE,
5261                                   NULL_TREE,
5262                                   arg1_tree,
5263                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5264                                   ffebld_nonter_hook (expr));
5265         if (arg3_tree != NULL_TREE) {
5266           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5267                                      convert (TREE_TYPE (arg3_tree),
5268                                               expr_tree));
5269         }
5270       }
5271       return expr_tree;
5272
5273     case FFEINTRIN_impCTIME_subr:
5274     case FFEINTRIN_impTTYNAM_subr:
5275       {
5276         tree arg1_len = integer_zero_node;
5277         tree arg1_tree;
5278         tree arg2_tree;
5279
5280         arg1_tree = ffecom_arg_ptr_to_expr (arg2, &arg1_len);
5281
5282         arg2_tree = convert (((codegen_imp == FFEINTRIN_impCTIME_subr) ?
5283                               ffecom_f2c_longint_type_node :
5284                               ffecom_f2c_integer_type_node),
5285                              ffecom_expr (arg1));
5286         arg2_tree = ffecom_1 (ADDR_EXPR,
5287                               build_pointer_type (TREE_TYPE (arg2_tree)),
5288                               arg2_tree);
5289
5290         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5291         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5292         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5293         TREE_CHAIN (arg1_len) = arg2_tree;
5294         TREE_CHAIN (arg1_tree) = arg1_len;
5295
5296         expr_tree
5297           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5298                           ffecom_gfrt_kindtype (gfrt),
5299                           FALSE,
5300                           NULL_TREE,
5301                           arg1_tree,
5302                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5303                           ffebld_nonter_hook (expr));
5304         TREE_SIDE_EFFECTS (expr_tree) = 1;
5305       }
5306       return expr_tree;
5307
5308     case FFEINTRIN_impIRAND:
5309     case FFEINTRIN_impRAND:
5310       /* Arg defaults to 0 (normal random case) */
5311       {
5312         tree arg1_tree;
5313
5314         if (arg1 == NULL)
5315           arg1_tree = ffecom_integer_zero_node;
5316         else
5317           arg1_tree = ffecom_expr (arg1);
5318         arg1_tree = convert (ffecom_f2c_integer_type_node,
5319                              arg1_tree);
5320         arg1_tree = ffecom_1 (ADDR_EXPR,
5321                               build_pointer_type (TREE_TYPE (arg1_tree)),
5322                               arg1_tree);
5323         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5324
5325         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5326                                   ffecom_gfrt_kindtype (gfrt),
5327                                   FALSE,
5328                                   ((codegen_imp == FFEINTRIN_impIRAND) ?
5329                                    ffecom_f2c_integer_type_node :
5330                                    ffecom_f2c_real_type_node),
5331                                   arg1_tree,
5332                                   dest_tree, dest, dest_used,
5333                                   NULL_TREE, TRUE,
5334                                   ffebld_nonter_hook (expr));
5335       }
5336       return expr_tree;
5337
5338     case FFEINTRIN_impFTELL_subr:
5339     case FFEINTRIN_impUMASK_subr:
5340       {
5341         tree arg1_tree;
5342         tree arg2_tree;
5343
5344         arg1_tree = convert (ffecom_f2c_integer_type_node,
5345                              ffecom_expr (arg1));
5346         arg1_tree = ffecom_1 (ADDR_EXPR,
5347                               build_pointer_type (TREE_TYPE (arg1_tree)),
5348                               arg1_tree);
5349
5350         if (arg2 == NULL)
5351           arg2_tree = NULL_TREE;
5352         else
5353           arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
5354
5355         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5356                                   ffecom_gfrt_kindtype (gfrt),
5357                                   FALSE,
5358                                   NULL_TREE,
5359                                   build_tree_list (NULL_TREE, arg1_tree),
5360                                   NULL_TREE, NULL, NULL, NULL_TREE,
5361                                   TRUE,
5362                                   ffebld_nonter_hook (expr));
5363         if (arg2_tree != NULL_TREE) {
5364           expr_tree = ffecom_modify (NULL_TREE, arg2_tree,
5365                                      convert (TREE_TYPE (arg2_tree),
5366                                               expr_tree));
5367         }
5368       }
5369       return expr_tree;
5370
5371     case FFEINTRIN_impCPU_TIME:
5372     case FFEINTRIN_impSECOND_subr:
5373       {
5374         tree arg1_tree;
5375
5376         arg1_tree = ffecom_expr_w (NULL_TREE, arg1);
5377
5378         expr_tree
5379           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5380                           ffecom_gfrt_kindtype (gfrt),
5381                           FALSE,
5382                           NULL_TREE,
5383                           NULL_TREE,
5384                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5385                           ffebld_nonter_hook (expr));
5386
5387         expr_tree
5388           = ffecom_modify (NULL_TREE, arg1_tree,
5389                            convert (TREE_TYPE (arg1_tree),
5390                                     expr_tree));
5391       }
5392       return expr_tree;
5393
5394     case FFEINTRIN_impDTIME_subr:
5395     case FFEINTRIN_impETIME_subr:
5396       {
5397         tree arg1_tree;
5398         tree result_tree;
5399
5400         result_tree = ffecom_expr_w (NULL_TREE, arg2);
5401
5402         arg1_tree = ffecom_ptr_to_expr (arg1);
5403
5404         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5405                                   ffecom_gfrt_kindtype (gfrt),
5406                                   FALSE,
5407                                   NULL_TREE,
5408                                   build_tree_list (NULL_TREE, arg1_tree),
5409                                   NULL_TREE, NULL, NULL, NULL_TREE,
5410                                   TRUE,
5411                                   ffebld_nonter_hook (expr));
5412         expr_tree = ffecom_modify (NULL_TREE, result_tree,
5413                                    convert (TREE_TYPE (result_tree),
5414                                             expr_tree));
5415       }
5416       return expr_tree;
5417
5418       /* Straightforward calls of libf2c routines: */
5419     case FFEINTRIN_impABORT:
5420     case FFEINTRIN_impACCESS:
5421     case FFEINTRIN_impBESJ0:
5422     case FFEINTRIN_impBESJ1:
5423     case FFEINTRIN_impBESJN:
5424     case FFEINTRIN_impBESY0:
5425     case FFEINTRIN_impBESY1:
5426     case FFEINTRIN_impBESYN:
5427     case FFEINTRIN_impCHDIR_func:
5428     case FFEINTRIN_impCHMOD_func:
5429     case FFEINTRIN_impDATE:
5430     case FFEINTRIN_impDATE_AND_TIME:
5431     case FFEINTRIN_impDBESJ0:
5432     case FFEINTRIN_impDBESJ1:
5433     case FFEINTRIN_impDBESJN:
5434     case FFEINTRIN_impDBESY0:
5435     case FFEINTRIN_impDBESY1:
5436     case FFEINTRIN_impDBESYN:
5437     case FFEINTRIN_impDTIME_func:
5438     case FFEINTRIN_impETIME_func:
5439     case FFEINTRIN_impFGETC_func:
5440     case FFEINTRIN_impFGET_func:
5441     case FFEINTRIN_impFNUM:
5442     case FFEINTRIN_impFPUTC_func:
5443     case FFEINTRIN_impFPUT_func:
5444     case FFEINTRIN_impFSEEK:
5445     case FFEINTRIN_impFSTAT_func:
5446     case FFEINTRIN_impFTELL_func:
5447     case FFEINTRIN_impGERROR:
5448     case FFEINTRIN_impGETARG:
5449     case FFEINTRIN_impGETCWD_func:
5450     case FFEINTRIN_impGETENV:
5451     case FFEINTRIN_impGETGID:
5452     case FFEINTRIN_impGETLOG:
5453     case FFEINTRIN_impGETPID:
5454     case FFEINTRIN_impGETUID:
5455     case FFEINTRIN_impGMTIME:
5456     case FFEINTRIN_impHOSTNM_func:
5457     case FFEINTRIN_impIDATE_unix:
5458     case FFEINTRIN_impIDATE_vxt:
5459     case FFEINTRIN_impIERRNO:
5460     case FFEINTRIN_impISATTY:
5461     case FFEINTRIN_impITIME:
5462     case FFEINTRIN_impKILL_func:
5463     case FFEINTRIN_impLINK_func:
5464     case FFEINTRIN_impLNBLNK:
5465     case FFEINTRIN_impLSTAT_func:
5466     case FFEINTRIN_impLTIME:
5467     case FFEINTRIN_impMCLOCK8:
5468     case FFEINTRIN_impMCLOCK:
5469     case FFEINTRIN_impPERROR:
5470     case FFEINTRIN_impRENAME_func:
5471     case FFEINTRIN_impSECNDS:
5472     case FFEINTRIN_impSECOND_func:
5473     case FFEINTRIN_impSLEEP:
5474     case FFEINTRIN_impSRAND:
5475     case FFEINTRIN_impSTAT_func:
5476     case FFEINTRIN_impSYMLNK_func:
5477     case FFEINTRIN_impSYSTEM_CLOCK:
5478     case FFEINTRIN_impSYSTEM_func:
5479     case FFEINTRIN_impTIME8:
5480     case FFEINTRIN_impTIME_unix:
5481     case FFEINTRIN_impTIME_vxt:
5482     case FFEINTRIN_impUMASK_func:
5483     case FFEINTRIN_impUNLINK_func:
5484       break;
5485
5486     case FFEINTRIN_impCTIME_func:       /* CHARACTER functions not handled here. */
5487     case FFEINTRIN_impFDATE_func:       /* CHARACTER functions not handled here. */
5488     case FFEINTRIN_impTTYNAM_func:      /* CHARACTER functions not handled here. */
5489     case FFEINTRIN_impNONE:
5490     case FFEINTRIN_imp:         /* Hush up gcc warning. */
5491       fprintf (stderr, "No %s implementation.\n",
5492                ffeintrin_name_implementation (ffebld_symter_implementation (ffebld_left (expr))));
5493       assert ("unimplemented intrinsic" == NULL);
5494       return error_mark_node;
5495     }
5496
5497   assert (gfrt != FFECOM_gfrt); /* Must have an implementation! */
5498
5499   expr_tree = ffecom_arglist_expr_ (ffecom_gfrt_args_ (gfrt),
5500                                     ffebld_right (expr));
5501
5502   return ffecom_call_ (ffecom_gfrt_tree_ (gfrt), ffecom_gfrt_kindtype (gfrt),
5503                        (ffe_is_f2c_library () && ffecom_gfrt_complex_[gfrt]),
5504                        tree_type,
5505                        expr_tree, dest_tree, dest, dest_used,
5506                        NULL_TREE, TRUE,
5507                        ffebld_nonter_hook (expr));
5508
5509   /* See bottom of this file for f2c transforms used to determine
5510      many of the above implementations.  The info seems to confuse
5511      Emacs's C mode indentation, which is why it's been moved to
5512      the bottom of this source file.  */
5513 }
5514
5515 #endif
5516 /* For power (exponentiation) where right-hand operand is type INTEGER,
5517    generate in-line code to do it the fast way (which, if the operand
5518    is a constant, might just mean a series of multiplies).  */
5519
5520 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5521 static tree
5522 ffecom_expr_power_integer_ (ffebld expr)
5523 {
5524   tree l = ffecom_expr (ffebld_left (expr));
5525   tree r = ffecom_expr (ffebld_right (expr));
5526   tree ltype = TREE_TYPE (l);
5527   tree rtype = TREE_TYPE (r);
5528   tree result = NULL_TREE;
5529
5530   if (l == error_mark_node
5531       || r == error_mark_node)
5532     return error_mark_node;
5533
5534   if (TREE_CODE (r) == INTEGER_CST)
5535     {
5536       int sgn = tree_int_cst_sgn (r);
5537
5538       if (sgn == 0)
5539         return convert (ltype, integer_one_node);
5540
5541       if ((TREE_CODE (ltype) == INTEGER_TYPE)
5542           && (sgn < 0))
5543         {
5544           /* Reciprocal of integer is either 0, -1, or 1, so after
5545              calculating that (which we leave to the back end to do
5546              or not do optimally), don't bother with any multiplying.  */
5547
5548           result = ffecom_tree_divide_ (ltype,
5549                                         convert (ltype, integer_one_node),
5550                                         l,
5551                                         NULL_TREE, NULL, NULL, NULL_TREE);
5552           r = ffecom_1 (NEGATE_EXPR,
5553                         rtype,
5554                         r);
5555           if ((TREE_INT_CST_LOW (r) & 1) == 0)
5556             result = ffecom_1 (ABS_EXPR, rtype,
5557                                result);
5558         }
5559
5560       /* Generate appropriate series of multiplies, preceded
5561          by divide if the exponent is negative.  */
5562
5563       l = save_expr (l);
5564
5565       if (sgn < 0)
5566         {
5567           l = ffecom_tree_divide_ (ltype,
5568                                    convert (ltype, integer_one_node),
5569                                    l,
5570                                    NULL_TREE, NULL, NULL,
5571                                    ffebld_nonter_hook (expr));
5572           r = ffecom_1 (NEGATE_EXPR, rtype, r);
5573           assert (TREE_CODE (r) == INTEGER_CST);
5574
5575           if (tree_int_cst_sgn (r) < 0)
5576             {                   /* The "most negative" number.  */
5577               r = ffecom_1 (NEGATE_EXPR, rtype,
5578                             ffecom_2 (RSHIFT_EXPR, rtype,
5579                                       r,
5580                                       integer_one_node));
5581               l = save_expr (l);
5582               l = ffecom_2 (MULT_EXPR, ltype,
5583                             l,
5584                             l);
5585             }
5586         }
5587
5588       for (;;)
5589         {
5590           if (TREE_INT_CST_LOW (r) & 1)
5591             {
5592               if (result == NULL_TREE)
5593                 result = l;
5594               else
5595                 result = ffecom_2 (MULT_EXPR, ltype,
5596                                    result,
5597                                    l);
5598             }
5599
5600           r = ffecom_2 (RSHIFT_EXPR, rtype,
5601                         r,
5602                         integer_one_node);
5603           if (integer_zerop (r))
5604             break;
5605           assert (TREE_CODE (r) == INTEGER_CST);
5606
5607           l = save_expr (l);
5608           l = ffecom_2 (MULT_EXPR, ltype,
5609                         l,
5610                         l);
5611         }
5612       return result;
5613     }
5614
5615   /* Though rhs isn't a constant, in-line code cannot be expanded
5616      while transforming dummies
5617      because the back end cannot be easily convinced to generate
5618      stores (MODIFY_EXPR), handle temporaries, and so on before
5619      all the appropriate rtx's have been generated for things like
5620      dummy args referenced in rhs -- which doesn't happen until
5621      store_parm_decls() is called (expand_function_start, I believe,
5622      does the actual rtx-stuffing of PARM_DECLs).
5623
5624      So, in this case, let the caller generate the call to the
5625      run-time-library function to evaluate the power for us.  */
5626
5627   if (ffecom_transform_only_dummies_)
5628     return NULL_TREE;
5629
5630   /* Right-hand operand not a constant, expand in-line code to figure
5631      out how to do the multiplies, &c.
5632
5633      The returned expression is expressed this way in GNU C, where l and
5634      r are the "inputs":
5635
5636      ({ typeof (r) rtmp = r;
5637         typeof (l) ltmp = l;
5638         typeof (l) result;
5639
5640         if (rtmp == 0)
5641           result = 1;
5642         else
5643           {
5644             if ((basetypeof (l) == basetypeof (int))
5645                 && (rtmp < 0))
5646               {
5647                 result = ((typeof (l)) 1) / ltmp;
5648                 if ((ltmp < 0) && (((-rtmp) & 1) == 0))
5649                   result = -result;
5650               }
5651             else
5652               {
5653                 result = 1;
5654                 if ((basetypeof (l) != basetypeof (int))
5655                     && (rtmp < 0))
5656                   {
5657                     ltmp = ((typeof (l)) 1) / ltmp;
5658                     rtmp = -rtmp;
5659                     if (rtmp < 0)
5660                       {
5661                         rtmp = -(rtmp >> 1);
5662                         ltmp *= ltmp;
5663                       }
5664                   }
5665                 for (;;)
5666                   {
5667                     if (rtmp & 1)
5668                       result *= ltmp;
5669                     if ((rtmp >>= 1) == 0)
5670                       break;
5671                     ltmp *= ltmp;
5672                   }
5673               }
5674           }
5675         result;
5676      })
5677
5678      Note that some of the above is compile-time collapsable, such as
5679      the first part of the if statements that checks the base type of
5680      l against int.  The if statements are phrased that way to suggest
5681      an easy way to generate the if/else constructs here, knowing that
5682      the back end should (and probably does) eliminate the resulting
5683      dead code (either the int case or the non-int case), something
5684      it couldn't do without the redundant phrasing, requiring explicit
5685      dead-code elimination here, which would be kind of difficult to
5686      read.  */
5687
5688   {
5689     tree rtmp;
5690     tree ltmp;
5691     tree divide;
5692     tree basetypeof_l_is_int;
5693     tree se;
5694     tree t;
5695
5696     basetypeof_l_is_int
5697       = build_int_2 ((TREE_CODE (ltype) == INTEGER_TYPE), 0);
5698
5699     se = expand_start_stmt_expr ();
5700
5701     ffecom_start_compstmt ();
5702
5703 #ifndef HAHA
5704     rtmp = ffecom_make_tempvar ("power_r", rtype,
5705                                 FFETARGET_charactersizeNONE, -1);
5706     ltmp = ffecom_make_tempvar ("power_l", ltype,
5707                                 FFETARGET_charactersizeNONE, -1);
5708     result = ffecom_make_tempvar ("power_res", ltype,
5709                                   FFETARGET_charactersizeNONE, -1);
5710     if (TREE_CODE (ltype) == COMPLEX_TYPE
5711         || TREE_CODE (ltype) == RECORD_TYPE)
5712       divide = ffecom_make_tempvar ("power_div", ltype,
5713                                     FFETARGET_charactersizeNONE, -1);
5714     else
5715       divide = NULL_TREE;
5716 #else  /* HAHA */
5717     {
5718       tree hook;
5719
5720       hook = ffebld_nonter_hook (expr);
5721       assert (hook);
5722       assert (TREE_CODE (hook) == TREE_VEC);
5723       assert (TREE_VEC_LENGTH (hook) == 4);
5724       rtmp = TREE_VEC_ELT (hook, 0);
5725       ltmp = TREE_VEC_ELT (hook, 1);
5726       result = TREE_VEC_ELT (hook, 2);
5727       divide = TREE_VEC_ELT (hook, 3);
5728       if (TREE_CODE (ltype) == COMPLEX_TYPE
5729           || TREE_CODE (ltype) == RECORD_TYPE)
5730         assert (divide);
5731       else
5732         assert (! divide);
5733     }
5734 #endif  /* HAHA */
5735
5736     expand_expr_stmt (ffecom_modify (void_type_node,
5737                                      rtmp,
5738                                      r));
5739     expand_expr_stmt (ffecom_modify (void_type_node,
5740                                      ltmp,
5741                                      l));
5742     expand_start_cond (ffecom_truth_value
5743                        (ffecom_2 (EQ_EXPR, integer_type_node,
5744                                   rtmp,
5745                                   convert (rtype, integer_zero_node))),
5746                        0);
5747     expand_expr_stmt (ffecom_modify (void_type_node,
5748                                      result,
5749                                      convert (ltype, integer_one_node)));
5750     expand_start_else ();
5751     if (! integer_zerop (basetypeof_l_is_int))
5752       {
5753         expand_start_cond (ffecom_2 (LT_EXPR, integer_type_node,
5754                                      rtmp,
5755                                      convert (rtype,
5756                                               integer_zero_node)),
5757                            0);
5758         expand_expr_stmt (ffecom_modify (void_type_node,
5759                                          result,
5760                                          ffecom_tree_divide_
5761                                          (ltype,
5762                                           convert (ltype, integer_one_node),
5763                                           ltmp,
5764                                           NULL_TREE, NULL, NULL,
5765                                           divide)));
5766         expand_start_cond (ffecom_truth_value
5767                            (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5768                                       ffecom_2 (LT_EXPR, integer_type_node,
5769                                                 ltmp,
5770                                                 convert (ltype,
5771                                                          integer_zero_node)),
5772                                       ffecom_2 (EQ_EXPR, integer_type_node,
5773                                                 ffecom_2 (BIT_AND_EXPR,
5774                                                           rtype,
5775                                                           ffecom_1 (NEGATE_EXPR,
5776                                                                     rtype,
5777                                                                     rtmp),
5778                                                           convert (rtype,
5779                                                                    integer_one_node)),
5780                                                 convert (rtype,
5781                                                          integer_zero_node)))),
5782                            0);
5783         expand_expr_stmt (ffecom_modify (void_type_node,
5784                                          result,
5785                                          ffecom_1 (NEGATE_EXPR,
5786                                                    ltype,
5787                                                    result)));
5788         expand_end_cond ();
5789         expand_start_else ();
5790       }
5791     expand_expr_stmt (ffecom_modify (void_type_node,
5792                                      result,
5793                                      convert (ltype, integer_one_node)));
5794     expand_start_cond (ffecom_truth_value
5795                        (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5796                                   ffecom_truth_value_invert
5797                                   (basetypeof_l_is_int),
5798                                   ffecom_2 (LT_EXPR, integer_type_node,
5799                                             rtmp,
5800                                             convert (rtype,
5801                                                      integer_zero_node)))),
5802                        0);
5803     expand_expr_stmt (ffecom_modify (void_type_node,
5804                                      ltmp,
5805                                      ffecom_tree_divide_
5806                                      (ltype,
5807                                       convert (ltype, integer_one_node),
5808                                       ltmp,
5809                                       NULL_TREE, NULL, NULL,
5810                                       divide)));
5811     expand_expr_stmt (ffecom_modify (void_type_node,
5812                                      rtmp,
5813                                      ffecom_1 (NEGATE_EXPR, rtype,
5814                                                rtmp)));
5815     expand_start_cond (ffecom_truth_value
5816                        (ffecom_2 (LT_EXPR, integer_type_node,
5817                                   rtmp,
5818                                   convert (rtype, integer_zero_node))),
5819                        0);
5820     expand_expr_stmt (ffecom_modify (void_type_node,
5821                                      rtmp,
5822                                      ffecom_1 (NEGATE_EXPR, rtype,
5823                                                ffecom_2 (RSHIFT_EXPR,
5824                                                          rtype,
5825                                                          rtmp,
5826                                                          integer_one_node))));
5827     expand_expr_stmt (ffecom_modify (void_type_node,
5828                                      ltmp,
5829                                      ffecom_2 (MULT_EXPR, ltype,
5830                                                ltmp,
5831                                                ltmp)));
5832     expand_end_cond ();
5833     expand_end_cond ();
5834     expand_start_loop (1);
5835     expand_start_cond (ffecom_truth_value
5836                        (ffecom_2 (BIT_AND_EXPR, rtype,
5837                                   rtmp,
5838                                   convert (rtype, integer_one_node))),
5839                        0);
5840     expand_expr_stmt (ffecom_modify (void_type_node,
5841                                      result,
5842                                      ffecom_2 (MULT_EXPR, ltype,
5843                                                result,
5844                                                ltmp)));
5845     expand_end_cond ();
5846     expand_exit_loop_if_false (NULL,
5847                                ffecom_truth_value
5848                                (ffecom_modify (rtype,
5849                                                rtmp,
5850                                                ffecom_2 (RSHIFT_EXPR,
5851                                                          rtype,
5852                                                          rtmp,
5853                                                          integer_one_node))));
5854     expand_expr_stmt (ffecom_modify (void_type_node,
5855                                      ltmp,
5856                                      ffecom_2 (MULT_EXPR, ltype,
5857                                                ltmp,
5858                                                ltmp)));
5859     expand_end_loop ();
5860     expand_end_cond ();
5861     if (!integer_zerop (basetypeof_l_is_int))
5862       expand_end_cond ();
5863     expand_expr_stmt (result);
5864
5865     t = ffecom_end_compstmt ();
5866
5867     result = expand_end_stmt_expr (se);
5868
5869     /* This code comes from c-parse.in, after its expand_end_stmt_expr.  */
5870
5871     if (TREE_CODE (t) == BLOCK)
5872       {
5873         /* Make a BIND_EXPR for the BLOCK already made.  */
5874         result = build (BIND_EXPR, TREE_TYPE (result),
5875                         NULL_TREE, result, t);
5876         /* Remove the block from the tree at this point.
5877            It gets put back at the proper place
5878            when the BIND_EXPR is expanded.  */
5879         delete_block (t);
5880       }
5881     else
5882       result = t;
5883   }
5884
5885   return result;
5886 }
5887
5888 #endif
5889 /* ffecom_expr_transform_ -- Transform symbols in expr
5890
5891    ffebld expr;  // FFE expression.
5892    ffecom_expr_transform_ (expr);
5893
5894    Recursive descent on expr while transforming any untransformed SYMTERs.  */
5895
5896 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5897 static void
5898 ffecom_expr_transform_ (ffebld expr)
5899 {
5900   tree t;
5901   ffesymbol s;
5902
5903 tail_recurse:                   /* :::::::::::::::::::: */
5904
5905   if (expr == NULL)
5906     return;
5907
5908   switch (ffebld_op (expr))
5909     {
5910     case FFEBLD_opSYMTER:
5911       s = ffebld_symter (expr);
5912       t = ffesymbol_hook (s).decl_tree;
5913       if ((t == NULL_TREE)
5914           && ((ffesymbol_kind (s) != FFEINFO_kindNONE)
5915               || ((ffesymbol_where (s) != FFEINFO_whereNONE)
5916                   && (ffesymbol_where (s) != FFEINFO_whereINTRINSIC))))
5917         {
5918           s = ffecom_sym_transform_ (s);
5919           t = ffesymbol_hook (s).decl_tree;     /* Sfunc expr non-dummy,
5920                                                    DIMENSION expr? */
5921         }
5922       break;                    /* Ok if (t == NULL) here. */
5923
5924     case FFEBLD_opITEM:
5925       ffecom_expr_transform_ (ffebld_head (expr));
5926       expr = ffebld_trail (expr);
5927       goto tail_recurse;        /* :::::::::::::::::::: */
5928
5929     default:
5930       break;
5931     }
5932
5933   switch (ffebld_arity (expr))
5934     {
5935     case 2:
5936       ffecom_expr_transform_ (ffebld_left (expr));
5937       expr = ffebld_right (expr);
5938       goto tail_recurse;        /* :::::::::::::::::::: */
5939
5940     case 1:
5941       expr = ffebld_left (expr);
5942       goto tail_recurse;        /* :::::::::::::::::::: */
5943
5944     default:
5945       break;
5946     }
5947
5948   return;
5949 }
5950
5951 #endif
5952 /* Make a type based on info in live f2c.h file.  */
5953
5954 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5955 static void
5956 ffecom_f2c_make_type_ (tree *type, int tcode, const char *name)
5957 {
5958   switch (tcode)
5959     {
5960     case FFECOM_f2ccodeCHAR:
5961       *type = make_signed_type (CHAR_TYPE_SIZE);
5962       break;
5963
5964     case FFECOM_f2ccodeSHORT:
5965       *type = make_signed_type (SHORT_TYPE_SIZE);
5966       break;
5967
5968     case FFECOM_f2ccodeINT:
5969       *type = make_signed_type (INT_TYPE_SIZE);
5970       break;
5971
5972     case FFECOM_f2ccodeLONG:
5973       *type = make_signed_type (LONG_TYPE_SIZE);
5974       break;
5975
5976     case FFECOM_f2ccodeLONGLONG:
5977       *type = make_signed_type (LONG_LONG_TYPE_SIZE);
5978       break;
5979
5980     case FFECOM_f2ccodeCHARPTR:
5981       *type = build_pointer_type (DEFAULT_SIGNED_CHAR
5982                                   ? signed_char_type_node
5983                                   : unsigned_char_type_node);
5984       break;
5985
5986     case FFECOM_f2ccodeFLOAT:
5987       *type = make_node (REAL_TYPE);
5988       TYPE_PRECISION (*type) = FLOAT_TYPE_SIZE;
5989       layout_type (*type);
5990       break;
5991
5992     case FFECOM_f2ccodeDOUBLE:
5993       *type = make_node (REAL_TYPE);
5994       TYPE_PRECISION (*type) = DOUBLE_TYPE_SIZE;
5995       layout_type (*type);
5996       break;
5997
5998     case FFECOM_f2ccodeLONGDOUBLE:
5999       *type = make_node (REAL_TYPE);
6000       TYPE_PRECISION (*type) = LONG_DOUBLE_TYPE_SIZE;
6001       layout_type (*type);
6002       break;
6003
6004     case FFECOM_f2ccodeTWOREALS:
6005       *type = ffecom_make_complex_type_ (ffecom_f2c_real_type_node);
6006       break;
6007
6008     case FFECOM_f2ccodeTWODOUBLEREALS:
6009       *type = ffecom_make_complex_type_ (ffecom_f2c_doublereal_type_node);
6010       break;
6011
6012     default:
6013       assert ("unexpected FFECOM_f2ccodeXYZZY!" == NULL);
6014       *type = error_mark_node;
6015       return;
6016     }
6017
6018   pushdecl (build_decl (TYPE_DECL,
6019                         ffecom_get_invented_identifier ("__g77_f2c_%s", name),
6020                         *type));
6021 }
6022
6023 #endif
6024 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6025 /* Set the f2c list-directed-I/O code for whatever (integral) type has the
6026    given size.  */
6027
6028 static void
6029 ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
6030                           int code)
6031 {
6032   int j;
6033   tree t;
6034
6035   for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
6036     if ((t = ffecom_tree_type[bt][j]) != NULL_TREE
6037         && compare_tree_int (TYPE_SIZE (t), size) == 0)
6038       {
6039         assert (code != -1);
6040         ffecom_f2c_typecode_[bt][j] = code;
6041         code = -1;
6042       }
6043 }
6044
6045 #endif
6046 /* Finish up globals after doing all program units in file
6047
6048    Need to handle only uninitialized COMMON areas.  */
6049
6050 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6051 static ffeglobal
6052 ffecom_finish_global_ (ffeglobal global)
6053 {
6054   tree cbtype;
6055   tree cbt;
6056   tree size;
6057
6058   if (ffeglobal_type (global) != FFEGLOBAL_typeCOMMON)
6059       return global;
6060
6061   if (ffeglobal_common_init (global))
6062       return global;
6063
6064   cbt = ffeglobal_hook (global);
6065   if ((cbt == NULL_TREE)
6066       || !ffeglobal_common_have_size (global))
6067     return global;              /* No need to make common, never ref'd. */
6068
6069   DECL_EXTERNAL (cbt) = 0;
6070
6071   /* Give the array a size now.  */
6072
6073   size = build_int_2 ((ffeglobal_common_size (global)
6074                       + ffeglobal_common_pad (global)) - 1,
6075                       0);
6076
6077   cbtype = TREE_TYPE (cbt);
6078   TYPE_DOMAIN (cbtype) = build_range_type (integer_type_node,
6079                                            integer_zero_node,
6080                                            size);
6081   if (!TREE_TYPE (size))
6082     TREE_TYPE (size) = TYPE_DOMAIN (cbtype);
6083   layout_type (cbtype);
6084
6085   cbt = start_decl (cbt, FALSE);
6086   assert (cbt == ffeglobal_hook (global));
6087
6088   finish_decl (cbt, NULL_TREE, FALSE);
6089
6090   return global;
6091 }
6092
6093 #endif
6094 /* Finish up any untransformed symbols.  */
6095
6096 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6097 static ffesymbol
6098 ffecom_finish_symbol_transform_ (ffesymbol s)
6099 {
6100   if ((s == NULL) || (TREE_CODE (current_function_decl) == ERROR_MARK))
6101     return s;
6102
6103   /* It's easy to know to transform an untransformed symbol, to make sure
6104      we put out debugging info for it.  But COMMON variables, unlike
6105      EQUIVALENCE ones, aren't given declarations in addition to the
6106      tree expressions that specify offsets, because COMMON variables
6107      can be referenced in the outer scope where only dummy arguments
6108      (PARM_DECLs) should really be seen.  To be safe, just don't do any
6109      VAR_DECLs for COMMON variables when we transform them for real
6110      use, and therefore we do all the VAR_DECL creating here.  */
6111
6112   if (ffesymbol_hook (s).decl_tree == NULL_TREE)
6113     {
6114       if (ffesymbol_kind (s) != FFEINFO_kindNONE
6115           || (ffesymbol_where (s) != FFEINFO_whereNONE
6116               && ffesymbol_where (s) != FFEINFO_whereINTRINSIC
6117               && ffesymbol_where (s) != FFEINFO_whereDUMMY))
6118         /* Not transformed, and not CHARACTER*(*), and not a dummy
6119            argument, which can happen only if the entry point names
6120            it "rides in on" are all invalidated for other reasons.  */
6121         s = ffecom_sym_transform_ (s);
6122     }
6123
6124   if ((ffesymbol_where (s) == FFEINFO_whereCOMMON)
6125       && (ffesymbol_hook (s).decl_tree != error_mark_node))
6126     {
6127       /* This isn't working, at least for dbxout.  The .s file looks
6128          okay to me (burley), but in gdb 4.9 at least, the variables
6129          appear to reside somewhere outside of the common area, so
6130          it doesn't make sense to mislead anyone by generating the info
6131          on those variables until this is fixed.  NOTE: Same problem
6132          with EQUIVALENCE, sadly...see similar #if later.  */
6133       ffecom_member_phase2_ (ffesymbol_storage (ffesymbol_common (s)),
6134                              ffesymbol_storage (s));
6135     }
6136
6137   return s;
6138 }
6139
6140 #endif
6141 /* Append underscore(s) to name before calling get_identifier.  "us"
6142    is nonzero if the name already contains an underscore and thus
6143    needs two underscores appended.  */
6144
6145 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6146 static tree
6147 ffecom_get_appended_identifier_ (char us, const char *name)
6148 {
6149   int i;
6150   char *newname;
6151   tree id;
6152
6153   newname = xmalloc ((i = strlen (name)) + 1
6154                      + ffe_is_underscoring ()
6155                      + us);
6156   memcpy (newname, name, i);
6157   newname[i] = '_';
6158   newname[i + us] = '_';
6159   newname[i + 1 + us] = '\0';
6160   id = get_identifier (newname);
6161
6162   free (newname);
6163
6164   return id;
6165 }
6166
6167 #endif
6168 /* Decide whether to append underscore to name before calling
6169    get_identifier.  */
6170
6171 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6172 static tree
6173 ffecom_get_external_identifier_ (ffesymbol s)
6174 {
6175   char us;
6176   const char *name = ffesymbol_text (s);
6177
6178   /* If name is a built-in name, just return it as is.  */
6179
6180   if (!ffe_is_underscoring ()
6181       || (strcmp (name, FFETARGET_nameBLANK_COMMON) == 0)
6182 #if FFETARGET_isENFORCED_MAIN_NAME
6183       || (strcmp (name, FFETARGET_nameENFORCED_NAME) == 0)
6184 #else
6185       || (strcmp (name, FFETARGET_nameUNNAMED_MAIN) == 0)
6186 #endif
6187       || (strcmp (name, FFETARGET_nameUNNAMED_BLOCK_DATA) == 0))
6188     return get_identifier (name);
6189
6190   us = ffe_is_second_underscore ()
6191     ? (strchr (name, '_') != NULL)
6192       : 0;
6193
6194   return ffecom_get_appended_identifier_ (us, name);
6195 }
6196
6197 #endif
6198 /* Decide whether to append underscore to internal name before calling
6199    get_identifier.
6200
6201    This is for non-external, top-function-context names only.  Transform
6202    identifier so it doesn't conflict with the transformed result
6203    of using a _different_ external name.  E.g. if "CALL FOO" is
6204    transformed into "FOO_();", then the variable in "FOO_ = 3"
6205    must be transformed into something that does not conflict, since
6206    these two things should be independent.
6207
6208    The transformation is as follows.  If the name does not contain
6209    an underscore, there is no possible conflict, so just return.
6210    If the name does contain an underscore, then transform it just
6211    like we transform an external identifier.  */
6212
6213 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6214 static tree
6215 ffecom_get_identifier_ (const char *name)
6216 {
6217   /* If name does not contain an underscore, just return it as is.  */
6218
6219   if (!ffe_is_underscoring ()
6220       || (strchr (name, '_') == NULL))
6221     return get_identifier (name);
6222
6223   return ffecom_get_appended_identifier_ (ffe_is_second_underscore (),
6224                                           name);
6225 }
6226
6227 #endif
6228 /* ffecom_gen_sfuncdef_ -- Generate definition of statement function
6229
6230    tree t;
6231    ffesymbol s;  // kindFUNCTION, whereIMMEDIATE.
6232    t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s),
6233          ffesymbol_kindtype(s));
6234
6235    Call after setting up containing function and getting trees for all
6236    other symbols.  */
6237
6238 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6239 static tree
6240 ffecom_gen_sfuncdef_ (ffesymbol s, ffeinfoBasictype bt, ffeinfoKindtype kt)
6241 {
6242   ffebld expr = ffesymbol_sfexpr (s);
6243   tree type;
6244   tree func;
6245   tree result;
6246   bool charfunc = (bt == FFEINFO_basictypeCHARACTER);
6247   static bool recurse = FALSE;
6248   int old_lineno = lineno;
6249   const char *old_input_filename = input_filename;
6250
6251   ffecom_nested_entry_ = s;
6252
6253   /* For now, we don't have a handy pointer to where the sfunc is actually
6254      defined, though that should be easy to add to an ffesymbol. (The
6255      token/where info available might well point to the place where the type
6256      of the sfunc is declared, especially if that precedes the place where
6257      the sfunc itself is defined, which is typically the case.)  We should
6258      put out a null pointer rather than point somewhere wrong, but I want to
6259      see how it works at this point.  */
6260
6261   input_filename = ffesymbol_where_filename (s);
6262   lineno = ffesymbol_where_filelinenum (s);
6263
6264   /* Pretransform the expression so any newly discovered things belong to the
6265      outer program unit, not to the statement function. */
6266
6267   ffecom_expr_transform_ (expr);
6268
6269   /* Make sure no recursive invocation of this fn (a specific case of failing
6270      to pretransform an sfunc's expression, i.e. where its expression
6271      references another untransformed sfunc) happens. */
6272
6273   assert (!recurse);
6274   recurse = TRUE;
6275
6276   push_f_function_context ();
6277
6278   if (charfunc)
6279     type = void_type_node;
6280   else
6281     {
6282       type = ffecom_tree_type[bt][kt];
6283       if (type == NULL_TREE)
6284         type = integer_type_node;       /* _sym_exec_transition reports
6285                                            error. */
6286     }
6287
6288   start_function (ffecom_get_identifier_ (ffesymbol_text (s)),
6289                   build_function_type (type, NULL_TREE),
6290                   1,            /* nested/inline */
6291                   0);           /* TREE_PUBLIC */
6292
6293   /* We don't worry about COMPLEX return values here, because this is
6294      entirely internal to our code, and gcc has the ability to return COMPLEX
6295      directly as a value.  */
6296
6297   if (charfunc)
6298     {                           /* Prepend arg for where result goes. */
6299       tree type;
6300
6301       type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
6302
6303       result = ffecom_get_invented_identifier ("__g77_%s", "result");
6304
6305       ffecom_char_enhance_arg_ (&type, s);      /* Ignore returned length. */
6306
6307       type = build_pointer_type (type);
6308       result = build_decl (PARM_DECL, result, type);
6309
6310       push_parm_decl (result);
6311     }
6312   else
6313     result = NULL_TREE;         /* Not ref'd if !charfunc. */
6314
6315   ffecom_push_dummy_decls_ (ffesymbol_dummyargs (s), TRUE);
6316
6317   store_parm_decls (0);
6318
6319   ffecom_start_compstmt ();
6320
6321   if (expr != NULL)
6322     {
6323       if (charfunc)
6324         {
6325           ffetargetCharacterSize sz = ffesymbol_size (s);
6326           tree result_length;
6327
6328           result_length = build_int_2 (sz, 0);
6329           TREE_TYPE (result_length) = ffecom_f2c_ftnlen_type_node;
6330
6331           ffecom_prepare_let_char_ (sz, expr);
6332
6333           ffecom_prepare_end ();
6334
6335           ffecom_let_char_ (result, result_length, sz, expr);
6336           expand_null_return ();
6337         }
6338       else
6339         {
6340           ffecom_prepare_expr (expr);
6341
6342           ffecom_prepare_end ();
6343
6344           expand_return (ffecom_modify (NULL_TREE,
6345                                         DECL_RESULT (current_function_decl),
6346                                         ffecom_expr (expr)));
6347         }
6348     }
6349
6350   ffecom_end_compstmt ();
6351
6352   func = current_function_decl;
6353   finish_function (1);
6354
6355   pop_f_function_context ();
6356
6357   recurse = FALSE;
6358
6359   lineno = old_lineno;
6360   input_filename = old_input_filename;
6361
6362   ffecom_nested_entry_ = NULL;
6363
6364   return func;
6365 }
6366
6367 #endif
6368
6369 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6370 static const char *
6371 ffecom_gfrt_args_ (ffecomGfrt ix)
6372 {
6373   return ffecom_gfrt_argstring_[ix];
6374 }
6375
6376 #endif
6377 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6378 static tree
6379 ffecom_gfrt_tree_ (ffecomGfrt ix)
6380 {
6381   if (ffecom_gfrt_[ix] == NULL_TREE)
6382     ffecom_make_gfrt_ (ix);
6383
6384   return ffecom_1 (ADDR_EXPR,
6385                    build_pointer_type (TREE_TYPE (ffecom_gfrt_[ix])),
6386                    ffecom_gfrt_[ix]);
6387 }
6388
6389 #endif
6390 /* Return initialize-to-zero expression for this VAR_DECL.  */
6391
6392 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6393 /* A somewhat evil way to prevent the garbage collector
6394    from collecting 'tree' structures.  */
6395 #define NUM_TRACKED_CHUNK 63
6396 static struct tree_ggc_tracker
6397 {
6398   struct tree_ggc_tracker *next;
6399   tree trees[NUM_TRACKED_CHUNK];
6400 } *tracker_head = NULL;
6401
6402 static void
6403 mark_tracker_head (void *arg)
6404 {
6405   struct tree_ggc_tracker *head;
6406   int i;
6407
6408   for (head = * (struct tree_ggc_tracker **) arg;
6409        head != NULL;
6410        head = head->next)
6411   {
6412     ggc_mark (head);
6413     for (i = 0; i < NUM_TRACKED_CHUNK; i++)
6414       ggc_mark_tree (head->trees[i]);
6415   }
6416 }
6417
6418 void
6419 ffecom_save_tree_forever (tree t)
6420 {
6421   int i;
6422   if (tracker_head != NULL)
6423     for (i = 0; i < NUM_TRACKED_CHUNK; i++)
6424       if (tracker_head->trees[i] == NULL)
6425         {
6426           tracker_head->trees[i] = t;
6427           return;
6428         }
6429
6430   {
6431     /* Need to allocate a new block.  */
6432     struct tree_ggc_tracker *old_head = tracker_head;
6433
6434     tracker_head = ggc_alloc (sizeof (*tracker_head));
6435     tracker_head->next = old_head;
6436     tracker_head->trees[0] = t;
6437     for (i = 1; i < NUM_TRACKED_CHUNK; i++)
6438       tracker_head->trees[i] = NULL;
6439   }
6440 }
6441
6442 static tree
6443 ffecom_init_zero_ (tree decl)
6444 {
6445   tree init;
6446   int incremental = TREE_STATIC (decl);
6447   tree type = TREE_TYPE (decl);
6448
6449   if (incremental)
6450     {
6451       make_decl_rtl (decl, NULL);
6452       assemble_variable (decl, TREE_PUBLIC (decl) ? 1 : 0, 0, 1);
6453     }
6454
6455   if ((TREE_CODE (type) != ARRAY_TYPE)
6456       && (TREE_CODE (type) != RECORD_TYPE)
6457       && (TREE_CODE (type) != UNION_TYPE)
6458       && !incremental)
6459     init = convert (type, integer_zero_node);
6460   else if (!incremental)
6461     {
6462       init = build (CONSTRUCTOR, type, NULL_TREE, NULL_TREE);
6463       TREE_CONSTANT (init) = 1;
6464       TREE_STATIC (init) = 1;
6465     }
6466   else
6467     {
6468       assemble_zeros (int_size_in_bytes (type));
6469       init = error_mark_node;
6470     }
6471
6472   return init;
6473 }
6474
6475 #endif
6476 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6477 static tree
6478 ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
6479                          tree *maybe_tree)
6480 {
6481   tree expr_tree;
6482   tree length_tree;
6483
6484   switch (ffebld_op (arg))
6485     {
6486     case FFEBLD_opCONTER:       /* For F90, check 0-length. */
6487       if (ffetarget_length_character1
6488           (ffebld_constant_character1
6489            (ffebld_conter (arg))) == 0)
6490         {
6491           *maybe_tree = integer_zero_node;
6492           return convert (tree_type, integer_zero_node);
6493         }
6494
6495       *maybe_tree = integer_one_node;
6496       expr_tree = build_int_2 (*ffetarget_text_character1
6497                                (ffebld_constant_character1
6498                                 (ffebld_conter (arg))),
6499                                0);
6500       TREE_TYPE (expr_tree) = tree_type;
6501       return expr_tree;
6502
6503     case FFEBLD_opSYMTER:
6504     case FFEBLD_opARRAYREF:
6505     case FFEBLD_opFUNCREF:
6506     case FFEBLD_opSUBSTR:
6507       ffecom_char_args_ (&expr_tree, &length_tree, arg);
6508
6509       if ((expr_tree == error_mark_node)
6510           || (length_tree == error_mark_node))
6511         {
6512           *maybe_tree = error_mark_node;
6513           return error_mark_node;
6514         }
6515
6516       if (integer_zerop (length_tree))
6517         {
6518           *maybe_tree = integer_zero_node;
6519           return convert (tree_type, integer_zero_node);
6520         }
6521
6522       expr_tree
6523         = ffecom_1 (INDIRECT_REF,
6524                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6525                     expr_tree);
6526       expr_tree
6527         = ffecom_2 (ARRAY_REF,
6528                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6529                     expr_tree,
6530                     integer_one_node);
6531       expr_tree = convert (tree_type, expr_tree);
6532
6533       if (TREE_CODE (length_tree) == INTEGER_CST)
6534         *maybe_tree = integer_one_node;
6535       else                      /* Must check length at run time.  */
6536         *maybe_tree
6537           = ffecom_truth_value
6538             (ffecom_2 (GT_EXPR, integer_type_node,
6539                        length_tree,
6540                        ffecom_f2c_ftnlen_zero_node));
6541       return expr_tree;
6542
6543     case FFEBLD_opPAREN:
6544     case FFEBLD_opCONVERT:
6545       if (ffeinfo_size (ffebld_info (arg)) == 0)
6546         {
6547           *maybe_tree = integer_zero_node;
6548           return convert (tree_type, integer_zero_node);
6549         }
6550       return ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6551                                       maybe_tree);
6552
6553     case FFEBLD_opCONCATENATE:
6554       {
6555         tree maybe_left;
6556         tree maybe_right;
6557         tree expr_left;
6558         tree expr_right;
6559
6560         expr_left = ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6561                                              &maybe_left);
6562         expr_right = ffecom_intrinsic_ichar_ (tree_type, ffebld_right (arg),
6563                                               &maybe_right);
6564         *maybe_tree = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
6565                                 maybe_left,
6566                                 maybe_right);
6567         expr_tree = ffecom_3 (COND_EXPR, tree_type,
6568                               maybe_left,
6569                               expr_left,
6570                               expr_right);
6571         return expr_tree;
6572       }
6573
6574     default:
6575       assert ("bad op in ICHAR" == NULL);
6576       return error_mark_node;
6577     }
6578 }
6579
6580 #endif
6581 /* ffecom_intrinsic_len_ -- Return length info for char arg (LEN())
6582
6583    tree length_arg;
6584    ffebld expr;
6585    length_arg = ffecom_intrinsic_len_ (expr);
6586
6587    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
6588    subexpressions by constructing the appropriate tree for the
6589    length-of-character-text argument in a calling sequence.  */
6590
6591 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6592 static tree
6593 ffecom_intrinsic_len_ (ffebld expr)
6594 {
6595   ffetargetCharacter1 val;
6596   tree length;
6597
6598   switch (ffebld_op (expr))
6599     {
6600     case FFEBLD_opCONTER:
6601       val = ffebld_constant_character1 (ffebld_conter (expr));
6602       length = build_int_2 (ffetarget_length_character1 (val), 0);
6603       TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6604       break;
6605
6606     case FFEBLD_opSYMTER:
6607       {
6608         ffesymbol s = ffebld_symter (expr);
6609         tree item;
6610
6611         item = ffesymbol_hook (s).decl_tree;
6612         if (item == NULL_TREE)
6613           {
6614             s = ffecom_sym_transform_ (s);
6615             item = ffesymbol_hook (s).decl_tree;
6616           }
6617         if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
6618           {
6619             if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
6620               length = ffesymbol_hook (s).length_tree;
6621             else
6622               {
6623                 length = build_int_2 (ffesymbol_size (s), 0);
6624                 TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6625               }
6626           }
6627         else if (item == error_mark_node)
6628           length = error_mark_node;
6629         else                    /* FFEINFO_kindFUNCTION: */
6630           length = NULL_TREE;
6631       }
6632       break;
6633
6634     case FFEBLD_opARRAYREF:
6635       length = ffecom_intrinsic_len_ (ffebld_left (expr));
6636       break;
6637
6638     case FFEBLD_opSUBSTR:
6639       {
6640         ffebld start;
6641         ffebld end;
6642         ffebld thing = ffebld_right (expr);
6643         tree start_tree;
6644         tree end_tree;
6645
6646         assert (ffebld_op (thing) == FFEBLD_opITEM);
6647         start = ffebld_head (thing);
6648         thing = ffebld_trail (thing);
6649         assert (ffebld_trail (thing) == NULL);
6650         end = ffebld_head (thing);
6651
6652         length = ffecom_intrinsic_len_ (ffebld_left (expr));
6653
6654         if (length == error_mark_node)
6655           break;
6656
6657         if (start == NULL)
6658           {
6659             if (end == NULL)
6660               ;
6661             else
6662               {
6663                 length = convert (ffecom_f2c_ftnlen_type_node,
6664                                   ffecom_expr (end));
6665               }
6666           }
6667         else
6668           {
6669             start_tree = convert (ffecom_f2c_ftnlen_type_node,
6670                                   ffecom_expr (start));
6671
6672             if (start_tree == error_mark_node)
6673               {
6674                 length = error_mark_node;
6675                 break;
6676               }
6677
6678             if (end == NULL)
6679               {
6680                 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6681                                    ffecom_f2c_ftnlen_one_node,
6682                                    ffecom_2 (MINUS_EXPR,
6683                                              ffecom_f2c_ftnlen_type_node,
6684                                              length,
6685                                              start_tree));
6686               }
6687             else
6688               {
6689                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
6690                                     ffecom_expr (end));
6691
6692                 if (end_tree == error_mark_node)
6693                   {
6694                     length = error_mark_node;
6695                     break;
6696                   }
6697
6698                 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6699                                    ffecom_f2c_ftnlen_one_node,
6700                                    ffecom_2 (MINUS_EXPR,
6701                                              ffecom_f2c_ftnlen_type_node,
6702                                              end_tree, start_tree));
6703               }
6704           }
6705       }
6706       break;
6707
6708     case FFEBLD_opCONCATENATE:
6709       length
6710         = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6711                     ffecom_intrinsic_len_ (ffebld_left (expr)),
6712                     ffecom_intrinsic_len_ (ffebld_right (expr)));
6713       break;
6714
6715     case FFEBLD_opFUNCREF:
6716     case FFEBLD_opCONVERT:
6717       length = build_int_2 (ffebld_size (expr), 0);
6718       TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6719       break;
6720
6721     default:
6722       assert ("bad op for single char arg expr" == NULL);
6723       length = ffecom_f2c_ftnlen_zero_node;
6724       break;
6725     }
6726
6727   assert (length != NULL_TREE);
6728
6729   return length;
6730 }
6731
6732 #endif
6733 /* Handle CHARACTER assignments.
6734
6735    Generates code to do the assignment.  Used by ordinary assignment
6736    statement handler ffecom_let_stmt and by statement-function
6737    handler to generate code for a statement function.  */
6738
6739 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6740 static void
6741 ffecom_let_char_ (tree dest_tree, tree dest_length,
6742                   ffetargetCharacterSize dest_size, ffebld source)
6743 {
6744   ffecomConcatList_ catlist;
6745   tree source_length;
6746   tree source_tree;
6747   tree expr_tree;
6748
6749   if ((dest_tree == error_mark_node)
6750       || (dest_length == error_mark_node))
6751     return;
6752
6753   assert (dest_tree != NULL_TREE);
6754   assert (dest_length != NULL_TREE);
6755
6756   /* Source might be an opCONVERT, which just means it is a different size
6757      than the destination.  Since the underlying implementation here handles
6758      that (directly or via the s_copy or s_cat run-time-library functions),
6759      we don't need the "convenience" of an opCONVERT that tells us to
6760      truncate or blank-pad, particularly since the resulting implementation
6761      would probably be slower than otherwise. */
6762
6763   while (ffebld_op (source) == FFEBLD_opCONVERT)
6764     source = ffebld_left (source);
6765
6766   catlist = ffecom_concat_list_new_ (source, dest_size);
6767   switch (ffecom_concat_list_count_ (catlist))
6768     {
6769     case 0:                     /* Shouldn't happen, but in case it does... */
6770       ffecom_concat_list_kill_ (catlist);
6771       source_tree = null_pointer_node;
6772       source_length = ffecom_f2c_ftnlen_zero_node;
6773       expr_tree = build_tree_list (NULL_TREE, dest_tree);
6774       TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6775       TREE_CHAIN (TREE_CHAIN (expr_tree))
6776         = build_tree_list (NULL_TREE, dest_length);
6777       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6778         = build_tree_list (NULL_TREE, source_length);
6779
6780       expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6781       TREE_SIDE_EFFECTS (expr_tree) = 1;
6782
6783       expand_expr_stmt (expr_tree);
6784
6785       return;
6786
6787     case 1:                     /* The (fairly) easy case. */
6788       ffecom_char_args_ (&source_tree, &source_length,
6789                          ffecom_concat_list_expr_ (catlist, 0));
6790       ffecom_concat_list_kill_ (catlist);
6791       assert (source_tree != NULL_TREE);
6792       assert (source_length != NULL_TREE);
6793
6794       if ((source_tree == error_mark_node)
6795           || (source_length == error_mark_node))
6796         return;
6797
6798       if (dest_size == 1)
6799         {
6800           dest_tree
6801             = ffecom_1 (INDIRECT_REF,
6802                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6803                                                       (dest_tree))),
6804                         dest_tree);
6805           dest_tree
6806             = ffecom_2 (ARRAY_REF,
6807                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6808                                                       (dest_tree))),
6809                         dest_tree,
6810                         integer_one_node);
6811           source_tree
6812             = ffecom_1 (INDIRECT_REF,
6813                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6814                                                       (source_tree))),
6815                         source_tree);
6816           source_tree
6817             = ffecom_2 (ARRAY_REF,
6818                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6819                                                       (source_tree))),
6820                         source_tree,
6821                         integer_one_node);
6822
6823           expr_tree = ffecom_modify (void_type_node, dest_tree, source_tree);
6824
6825           expand_expr_stmt (expr_tree);
6826
6827           return;
6828         }
6829
6830       expr_tree = build_tree_list (NULL_TREE, dest_tree);
6831       TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6832       TREE_CHAIN (TREE_CHAIN (expr_tree))
6833         = build_tree_list (NULL_TREE, dest_length);
6834       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6835         = build_tree_list (NULL_TREE, source_length);
6836
6837       expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6838       TREE_SIDE_EFFECTS (expr_tree) = 1;
6839
6840       expand_expr_stmt (expr_tree);
6841
6842       return;
6843
6844     default:                    /* Must actually concatenate things. */
6845       break;
6846     }
6847
6848   /* Heavy-duty concatenation. */
6849
6850   {
6851     int count = ffecom_concat_list_count_ (catlist);
6852     int i;
6853     tree lengths;
6854     tree items;
6855     tree length_array;
6856     tree item_array;
6857     tree citem;
6858     tree clength;
6859
6860 #ifdef HOHO
6861     length_array
6862       = lengths
6863       = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
6864                              FFETARGET_charactersizeNONE, count, TRUE);
6865     item_array = items = ffecom_push_tempvar (ffecom_f2c_address_type_node,
6866                                               FFETARGET_charactersizeNONE,
6867                                               count, TRUE);
6868 #else
6869     {
6870       tree hook;
6871
6872       hook = ffebld_nonter_hook (source);
6873       assert (hook);
6874       assert (TREE_CODE (hook) == TREE_VEC);
6875       assert (TREE_VEC_LENGTH (hook) == 2);
6876       length_array = lengths = TREE_VEC_ELT (hook, 0);
6877       item_array = items = TREE_VEC_ELT (hook, 1);
6878     }
6879 #endif
6880
6881     for (i = 0; i < count; ++i)
6882       {
6883         ffecom_char_args_ (&citem, &clength,
6884                            ffecom_concat_list_expr_ (catlist, i));
6885         if ((citem == error_mark_node)
6886             || (clength == error_mark_node))
6887           {
6888             ffecom_concat_list_kill_ (catlist);
6889             return;
6890           }
6891
6892         items
6893           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
6894                       ffecom_modify (void_type_node,
6895                                      ffecom_2 (ARRAY_REF,
6896                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
6897                                                item_array,
6898                                                build_int_2 (i, 0)),
6899                                      citem),
6900                       items);
6901         lengths
6902           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
6903                       ffecom_modify (void_type_node,
6904                                      ffecom_2 (ARRAY_REF,
6905                    TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
6906                                                length_array,
6907                                                build_int_2 (i, 0)),
6908                                      clength),
6909                       lengths);
6910       }
6911
6912     expr_tree = build_tree_list (NULL_TREE, dest_tree);
6913     TREE_CHAIN (expr_tree)
6914       = build_tree_list (NULL_TREE,
6915                          ffecom_1 (ADDR_EXPR,
6916                                    build_pointer_type (TREE_TYPE (items)),
6917                                    items));
6918     TREE_CHAIN (TREE_CHAIN (expr_tree))
6919       = build_tree_list (NULL_TREE,
6920                          ffecom_1 (ADDR_EXPR,
6921                                    build_pointer_type (TREE_TYPE (lengths)),
6922                                    lengths));
6923     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6924       = build_tree_list
6925         (NULL_TREE,
6926          ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
6927                    convert (ffecom_f2c_ftnlen_type_node,
6928                             build_int_2 (count, 0))));
6929     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree))))
6930       = build_tree_list (NULL_TREE, dest_length);
6931
6932     expr_tree = ffecom_call_gfrt (FFECOM_gfrtCAT, expr_tree, NULL_TREE);
6933     TREE_SIDE_EFFECTS (expr_tree) = 1;
6934
6935     expand_expr_stmt (expr_tree);
6936   }
6937
6938   ffecom_concat_list_kill_ (catlist);
6939 }
6940
6941 #endif
6942 /* ffecom_make_gfrt_ -- Make initial info for run-time routine
6943
6944    ffecomGfrt ix;
6945    ffecom_make_gfrt_(ix);
6946
6947    Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL
6948    for the indicated run-time routine (ix).  */
6949
6950 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6951 static void
6952 ffecom_make_gfrt_ (ffecomGfrt ix)
6953 {
6954   tree t;
6955   tree ttype;
6956
6957   switch (ffecom_gfrt_type_[ix])
6958     {
6959     case FFECOM_rttypeVOID_:
6960       ttype = void_type_node;
6961       break;
6962
6963     case FFECOM_rttypeVOIDSTAR_:
6964       ttype = TREE_TYPE (null_pointer_node);    /* `void *'. */
6965       break;
6966
6967     case FFECOM_rttypeFTNINT_:
6968       ttype = ffecom_f2c_ftnint_type_node;
6969       break;
6970
6971     case FFECOM_rttypeINTEGER_:
6972       ttype = ffecom_f2c_integer_type_node;
6973       break;
6974
6975     case FFECOM_rttypeLONGINT_:
6976       ttype = ffecom_f2c_longint_type_node;
6977       break;
6978
6979     case FFECOM_rttypeLOGICAL_:
6980       ttype = ffecom_f2c_logical_type_node;
6981       break;
6982
6983     case FFECOM_rttypeREAL_F2C_:
6984       ttype = double_type_node;
6985       break;
6986
6987     case FFECOM_rttypeREAL_GNU_:
6988       ttype = float_type_node;
6989       break;
6990
6991     case FFECOM_rttypeCOMPLEX_F2C_:
6992       ttype = void_type_node;
6993       break;
6994
6995     case FFECOM_rttypeCOMPLEX_GNU_:
6996       ttype = ffecom_f2c_complex_type_node;
6997       break;
6998
6999     case FFECOM_rttypeDOUBLE_:
7000       ttype = double_type_node;
7001       break;
7002
7003     case FFECOM_rttypeDOUBLEREAL_:
7004       ttype = ffecom_f2c_doublereal_type_node;
7005       break;
7006
7007     case FFECOM_rttypeDBLCMPLX_F2C_:
7008       ttype = void_type_node;
7009       break;
7010
7011     case FFECOM_rttypeDBLCMPLX_GNU_:
7012       ttype = ffecom_f2c_doublecomplex_type_node;
7013       break;
7014
7015     case FFECOM_rttypeCHARACTER_:
7016       ttype = void_type_node;
7017       break;
7018
7019     default:
7020       ttype = NULL;
7021       assert ("bad rttype" == NULL);
7022       break;
7023     }
7024
7025   ttype = build_function_type (ttype, NULL_TREE);
7026   t = build_decl (FUNCTION_DECL,
7027                   get_identifier (ffecom_gfrt_name_[ix]),
7028                   ttype);
7029   DECL_EXTERNAL (t) = 1;
7030   TREE_READONLY (t) = ffecom_gfrt_const_[ix] ? 1 : 0;
7031   TREE_PUBLIC (t) = 1;
7032   TREE_THIS_VOLATILE (t) = ffecom_gfrt_volatile_[ix] ? 1 : 0;
7033
7034   /* Sanity check:  A function that's const cannot be volatile.  */
7035
7036   assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_volatile_[ix] : 1);
7037
7038   /* Sanity check: A function that's const cannot return complex.  */
7039
7040   assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_complex_[ix] : 1);
7041
7042   t = start_decl (t, TRUE);
7043
7044   finish_decl (t, NULL_TREE, TRUE);
7045
7046   ffecom_gfrt_[ix] = t;
7047 }
7048
7049 #endif
7050 /* Phase 1 pass over each member of a COMMON/EQUIVALENCE group.  */
7051
7052 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7053 static void
7054 ffecom_member_phase1_ (ffestorag mst UNUSED, ffestorag st)
7055 {
7056   ffesymbol s = ffestorag_symbol (st);
7057
7058   if (ffesymbol_namelisted (s))
7059     ffecom_member_namelisted_ = TRUE;
7060 }
7061
7062 #endif
7063 /* Phase 2 pass over each member of a COMMON/EQUIVALENCE group.  Declare
7064    the member so debugger will see it.  Otherwise nobody should be
7065    referencing the member.  */
7066
7067 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7068 static void
7069 ffecom_member_phase2_ (ffestorag mst, ffestorag st)
7070 {
7071   ffesymbol s;
7072   tree t;
7073   tree mt;
7074   tree type;
7075
7076   if ((mst == NULL)
7077       || ((mt = ffestorag_hook (mst)) == NULL)
7078       || (mt == error_mark_node))
7079     return;
7080
7081   if ((st == NULL)
7082       || ((s = ffestorag_symbol (st)) == NULL))
7083     return;
7084
7085   type = ffecom_type_localvar_ (s,
7086                                 ffesymbol_basictype (s),
7087                                 ffesymbol_kindtype (s));
7088   if (type == error_mark_node)
7089     return;
7090
7091   t = build_decl (VAR_DECL,
7092                   ffecom_get_identifier_ (ffesymbol_text (s)),
7093                   type);
7094
7095   TREE_STATIC (t) = TREE_STATIC (mt);
7096   DECL_INITIAL (t) = NULL_TREE;
7097   TREE_ASM_WRITTEN (t) = 1;
7098   TREE_USED (t) = 1;
7099
7100   DECL_RTL (t)
7101     = gen_rtx (MEM, TYPE_MODE (type),
7102                plus_constant (XEXP (DECL_RTL (mt), 0),
7103                               ffestorag_modulo (mst)
7104                               + ffestorag_offset (st)
7105                               - ffestorag_offset (mst)));
7106
7107   t = start_decl (t, FALSE);
7108
7109   finish_decl (t, NULL_TREE, FALSE);
7110 }
7111
7112 #endif
7113 /* Prepare source expression for assignment into a destination perhaps known
7114    to be of a specific size.  */
7115
7116 static void
7117 ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size, ffebld source)
7118 {
7119   ffecomConcatList_ catlist;
7120   int count;
7121   int i;
7122   tree ltmp;
7123   tree itmp;
7124   tree tempvar = NULL_TREE;
7125
7126   while (ffebld_op (source) == FFEBLD_opCONVERT)
7127     source = ffebld_left (source);
7128
7129   catlist = ffecom_concat_list_new_ (source, dest_size);
7130   count = ffecom_concat_list_count_ (catlist);
7131
7132   if (count >= 2)
7133     {
7134       ltmp
7135         = ffecom_make_tempvar ("let_char_len", ffecom_f2c_ftnlen_type_node,
7136                                FFETARGET_charactersizeNONE, count);
7137       itmp
7138         = ffecom_make_tempvar ("let_char_item", ffecom_f2c_address_type_node,
7139                                FFETARGET_charactersizeNONE, count);
7140
7141       tempvar = make_tree_vec (2);
7142       TREE_VEC_ELT (tempvar, 0) = ltmp;
7143       TREE_VEC_ELT (tempvar, 1) = itmp;
7144     }
7145
7146   for (i = 0; i < count; ++i)
7147     ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist, i));
7148
7149   ffecom_concat_list_kill_ (catlist);
7150
7151   if (tempvar)
7152     {
7153       ffebld_nonter_set_hook (source, tempvar);
7154       current_binding_level->prep_state = 1;
7155     }
7156 }
7157
7158 /* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order
7159
7160    Ignores STAR (alternate-return) dummies.  All other get exec-transitioned
7161    (which generates their trees) and then their trees get push_parm_decl'd.
7162
7163    The second arg is TRUE if the dummies are for a statement function, in
7164    which case lengths are not pushed for character arguments (since they are
7165    always known by both the caller and the callee, though the code allows
7166    for someday permitting CHAR*(*) stmtfunc dummies).  */
7167
7168 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7169 static void
7170 ffecom_push_dummy_decls_ (ffebld dummy_list, bool stmtfunc)
7171 {
7172   ffebld dummy;
7173   ffebld dumlist;
7174   ffesymbol s;
7175   tree parm;
7176
7177   ffecom_transform_only_dummies_ = TRUE;
7178
7179   /* First push the parms corresponding to actual dummy "contents".  */
7180
7181   for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7182     {
7183       dummy = ffebld_head (dumlist);
7184       switch (ffebld_op (dummy))
7185         {
7186         case FFEBLD_opSTAR:
7187         case FFEBLD_opANY:
7188           continue;             /* Forget alternate returns. */
7189
7190         default:
7191           break;
7192         }
7193       assert (ffebld_op (dummy) == FFEBLD_opSYMTER);
7194       s = ffebld_symter (dummy);
7195       parm = ffesymbol_hook (s).decl_tree;
7196       if (parm == NULL_TREE)
7197         {
7198           s = ffecom_sym_transform_ (s);
7199           parm = ffesymbol_hook (s).decl_tree;
7200           assert (parm != NULL_TREE);
7201         }
7202       if (parm != error_mark_node)
7203         push_parm_decl (parm);
7204     }
7205
7206   /* Then, for CHARACTER dummies, push the parms giving their lengths.  */
7207
7208   for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7209     {
7210       dummy = ffebld_head (dumlist);
7211       switch (ffebld_op (dummy))
7212         {
7213         case FFEBLD_opSTAR:
7214         case FFEBLD_opANY:
7215           continue;             /* Forget alternate returns, they mean
7216                                    NOTHING! */
7217
7218         default:
7219           break;
7220         }
7221       s = ffebld_symter (dummy);
7222       if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
7223         continue;               /* Only looking for CHARACTER arguments. */
7224       if (stmtfunc && (ffesymbol_size (s) != FFETARGET_charactersizeNONE))
7225         continue;               /* Stmtfunc arg with known size needs no
7226                                    length param. */
7227       if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
7228         continue;               /* Only looking for variables and arrays. */
7229       parm = ffesymbol_hook (s).length_tree;
7230       assert (parm != NULL_TREE);
7231       if (parm != error_mark_node)
7232         push_parm_decl (parm);
7233     }
7234
7235   ffecom_transform_only_dummies_ = FALSE;
7236 }
7237
7238 #endif
7239 /* ffecom_start_progunit_ -- Beginning of program unit
7240
7241    Does GNU back end stuff necessary to teach it about the start of its
7242    equivalent of a Fortran program unit.  */
7243
7244 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7245 static void
7246 ffecom_start_progunit_ ()
7247 {
7248   ffesymbol fn = ffecom_primary_entry_;
7249   ffebld arglist;
7250   tree id;                      /* Identifier (name) of function. */
7251   tree type;                    /* Type of function. */
7252   tree result;                  /* Result of function. */
7253   ffeinfoBasictype bt;
7254   ffeinfoKindtype kt;
7255   ffeglobal g;
7256   ffeglobalType gt;
7257   ffeglobalType egt = FFEGLOBAL_type;
7258   bool charfunc;
7259   bool cmplxfunc;
7260   bool altentries = (ffecom_num_entrypoints_ != 0);
7261   bool multi
7262   = altentries
7263   && (ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
7264   && (ffecom_master_bt_ == FFEINFO_basictypeNONE);
7265   bool main_program = FALSE;
7266   int old_lineno = lineno;
7267   const char *old_input_filename = input_filename;
7268
7269   assert (fn != NULL);
7270   assert (ffesymbol_hook (fn).decl_tree == NULL_TREE);
7271
7272   input_filename = ffesymbol_where_filename (fn);
7273   lineno = ffesymbol_where_filelinenum (fn);
7274
7275   switch (ffecom_primary_entry_kind_)
7276     {
7277     case FFEINFO_kindPROGRAM:
7278       main_program = TRUE;
7279       gt = FFEGLOBAL_typeMAIN;
7280       bt = FFEINFO_basictypeNONE;
7281       kt = FFEINFO_kindtypeNONE;
7282       type = ffecom_tree_fun_type_void;
7283       charfunc = FALSE;
7284       cmplxfunc = FALSE;
7285       break;
7286
7287     case FFEINFO_kindBLOCKDATA:
7288       gt = FFEGLOBAL_typeBDATA;
7289       bt = FFEINFO_basictypeNONE;
7290       kt = FFEINFO_kindtypeNONE;
7291       type = ffecom_tree_fun_type_void;
7292       charfunc = FALSE;
7293       cmplxfunc = FALSE;
7294       break;
7295
7296     case FFEINFO_kindFUNCTION:
7297       gt = FFEGLOBAL_typeFUNC;
7298       egt = FFEGLOBAL_typeEXT;
7299       bt = ffesymbol_basictype (fn);
7300       kt = ffesymbol_kindtype (fn);
7301       if (bt == FFEINFO_basictypeNONE)
7302         {
7303           ffeimplic_establish_symbol (fn);
7304           if (ffesymbol_funcresult (fn) != NULL)
7305             ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
7306           bt = ffesymbol_basictype (fn);
7307           kt = ffesymbol_kindtype (fn);
7308         }
7309
7310       if (multi)
7311         charfunc = cmplxfunc = FALSE;
7312       else if (bt == FFEINFO_basictypeCHARACTER)
7313         charfunc = TRUE, cmplxfunc = FALSE;
7314       else if ((bt == FFEINFO_basictypeCOMPLEX)
7315                && ffesymbol_is_f2c (fn)
7316                && !altentries)
7317         charfunc = FALSE, cmplxfunc = TRUE;
7318       else
7319         charfunc = cmplxfunc = FALSE;
7320
7321       if (multi || charfunc)
7322         type = ffecom_tree_fun_type_void;
7323       else if (ffesymbol_is_f2c (fn) && !altentries)
7324         type = ffecom_tree_fun_type[bt][kt];
7325       else
7326         type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
7327
7328       if ((type == NULL_TREE)
7329           || (TREE_TYPE (type) == NULL_TREE))
7330         type = ffecom_tree_fun_type_void;       /* _sym_exec_transition. */
7331       break;
7332
7333     case FFEINFO_kindSUBROUTINE:
7334       gt = FFEGLOBAL_typeSUBR;
7335       egt = FFEGLOBAL_typeEXT;
7336       bt = FFEINFO_basictypeNONE;
7337       kt = FFEINFO_kindtypeNONE;
7338       if (ffecom_is_altreturning_)
7339         type = ffecom_tree_subr_type;
7340       else
7341         type = ffecom_tree_fun_type_void;
7342       charfunc = FALSE;
7343       cmplxfunc = FALSE;
7344       break;
7345
7346     default:
7347       assert ("say what??" == NULL);
7348       /* Fall through. */
7349     case FFEINFO_kindANY:
7350       gt = FFEGLOBAL_typeANY;
7351       bt = FFEINFO_basictypeNONE;
7352       kt = FFEINFO_kindtypeNONE;
7353       type = error_mark_node;
7354       charfunc = FALSE;
7355       cmplxfunc = FALSE;
7356       break;
7357     }
7358
7359   if (altentries)
7360     {
7361       id = ffecom_get_invented_identifier ("__g77_masterfun_%s",
7362                                            ffesymbol_text (fn));
7363     }
7364 #if FFETARGET_isENFORCED_MAIN
7365   else if (main_program)
7366     id = get_identifier (FFETARGET_nameENFORCED_MAIN_NAME);
7367 #endif
7368   else
7369     id = ffecom_get_external_identifier_ (fn);
7370
7371   start_function (id,
7372                   type,
7373                   0,            /* nested/inline */
7374                   !altentries); /* TREE_PUBLIC */
7375
7376   TREE_USED (current_function_decl) = 1;        /* Avoid spurious warning if altentries. */
7377
7378   if (!altentries
7379       && ((g = ffesymbol_global (fn)) != NULL)
7380       && ((ffeglobal_type (g) == gt)
7381           || (ffeglobal_type (g) == egt)))
7382     {
7383       ffeglobal_set_hook (g, current_function_decl);
7384     }
7385
7386   /* Arg handling needs exec-transitioned ffesymbols to work with.  But
7387      exec-transitioning needs current_function_decl to be filled in.  So we
7388      do these things in two phases. */
7389
7390   if (altentries)
7391     {                           /* 1st arg identifies which entrypoint. */
7392       ffecom_which_entrypoint_decl_
7393         = build_decl (PARM_DECL,
7394                       ffecom_get_invented_identifier ("__g77_%s",
7395                                                       "which_entrypoint"),
7396                       integer_type_node);
7397       push_parm_decl (ffecom_which_entrypoint_decl_);
7398     }
7399
7400   if (charfunc
7401       || cmplxfunc
7402       || multi)
7403     {                           /* Arg for result (return value). */
7404       tree type;
7405       tree length;
7406
7407       if (charfunc)
7408         type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
7409       else if (cmplxfunc)
7410         type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
7411       else
7412         type = ffecom_multi_type_node_;
7413
7414       result = ffecom_get_invented_identifier ("__g77_%s", "result");
7415
7416       /* Make length arg _and_ enhance type info for CHAR arg itself.  */
7417
7418       if (charfunc)
7419         length = ffecom_char_enhance_arg_ (&type, fn);
7420       else
7421         length = NULL_TREE;     /* Not ref'd if !charfunc. */
7422
7423       type = build_pointer_type (type);
7424       result = build_decl (PARM_DECL, result, type);
7425
7426       push_parm_decl (result);
7427       if (multi)
7428         ffecom_multi_retval_ = result;
7429       else
7430         ffecom_func_result_ = result;
7431
7432       if (charfunc)
7433         {
7434           push_parm_decl (length);
7435           ffecom_func_length_ = length;
7436         }
7437     }
7438
7439   if (ffecom_primary_entry_is_proc_)
7440     {
7441       if (altentries)
7442         arglist = ffecom_master_arglist_;
7443       else
7444         arglist = ffesymbol_dummyargs (fn);
7445       ffecom_push_dummy_decls_ (arglist, FALSE);
7446     }
7447
7448   if (TREE_CODE (current_function_decl) != ERROR_MARK)
7449     store_parm_decls (main_program ? 1 : 0);
7450
7451   ffecom_start_compstmt ();
7452   /* Disallow temp vars at this level.  */
7453   current_binding_level->prep_state = 2;
7454
7455   lineno = old_lineno;
7456   input_filename = old_input_filename;
7457
7458   /* This handles any symbols still untransformed, in case -g specified.
7459      This used to be done in ffecom_finish_progunit, but it turns out to
7460      be necessary to do it here so that statement functions are
7461      expanded before code.  But don't bother for BLOCK DATA.  */
7462
7463   if (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
7464     ffesymbol_drive (ffecom_finish_symbol_transform_);
7465 }
7466
7467 #endif
7468 /* ffecom_sym_transform_ -- Transform FFE sym into backend sym
7469
7470    ffesymbol s;
7471    ffecom_sym_transform_(s);
7472
7473    The ffesymbol_hook info for s is updated with appropriate backend info
7474    on the symbol.  */
7475
7476 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7477 static ffesymbol
7478 ffecom_sym_transform_ (ffesymbol s)
7479 {
7480   tree t;                       /* Transformed thingy. */
7481   tree tlen;                    /* Length if CHAR*(*). */
7482   bool addr;                    /* Is t the address of the thingy? */
7483   ffeinfoBasictype bt;
7484   ffeinfoKindtype kt;
7485   ffeglobal g;
7486   int old_lineno = lineno;
7487   const char *old_input_filename = input_filename;
7488
7489   /* Must ensure special ASSIGN variables are declared at top of outermost
7490      block, else they'll end up in the innermost block when their first
7491      ASSIGN is seen, which leaves them out of scope when they're the
7492      subject of a GOTO or I/O statement.
7493
7494      We make this variable even if -fugly-assign.  Just let it go unused,
7495      in case it turns out there are cases where we really want to use this
7496      variable anyway (e.g. ASSIGN to INTEGER*2 variable).  */
7497
7498   if (! ffecom_transform_only_dummies_
7499       && ffesymbol_assigned (s)
7500       && ! ffesymbol_hook (s).assign_tree)
7501     s = ffecom_sym_transform_assign_ (s);
7502
7503   if (ffesymbol_sfdummyparent (s) == NULL)
7504     {
7505       input_filename = ffesymbol_where_filename (s);
7506       lineno = ffesymbol_where_filelinenum (s);
7507     }
7508   else
7509     {
7510       ffesymbol sf = ffesymbol_sfdummyparent (s);
7511
7512       input_filename = ffesymbol_where_filename (sf);
7513       lineno = ffesymbol_where_filelinenum (sf);
7514     }
7515
7516   bt = ffeinfo_basictype (ffebld_info (s));
7517   kt = ffeinfo_kindtype (ffebld_info (s));
7518
7519   t = NULL_TREE;
7520   tlen = NULL_TREE;
7521   addr = FALSE;
7522
7523   switch (ffesymbol_kind (s))
7524     {
7525     case FFEINFO_kindNONE:
7526       switch (ffesymbol_where (s))
7527         {
7528         case FFEINFO_whereDUMMY:        /* Subroutine or function. */
7529           assert (ffecom_transform_only_dummies_);
7530
7531           /* Before 0.4, this could be ENTITY/DUMMY, but see
7532              ffestu_sym_end_transition -- no longer true (in particular, if
7533              it could be an ENTITY, it _will_ be made one, so that
7534              possibility won't come through here).  So we never make length
7535              arg for CHARACTER type.  */
7536
7537           t = build_decl (PARM_DECL,
7538                           ffecom_get_identifier_ (ffesymbol_text (s)),
7539                           ffecom_tree_ptr_to_subr_type);
7540 #if BUILT_FOR_270
7541           DECL_ARTIFICIAL (t) = 1;
7542 #endif
7543           addr = TRUE;
7544           break;
7545
7546         case FFEINFO_whereGLOBAL:       /* Subroutine or function. */
7547           assert (!ffecom_transform_only_dummies_);
7548
7549           if (((g = ffesymbol_global (s)) != NULL)
7550               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7551                   || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7552                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
7553               && (ffeglobal_hook (g) != NULL_TREE)
7554               && ffe_is_globals ())
7555             {
7556               t = ffeglobal_hook (g);
7557               break;
7558             }
7559
7560           t = build_decl (FUNCTION_DECL,
7561                           ffecom_get_external_identifier_ (s),
7562                           ffecom_tree_subr_type);       /* Assume subr. */
7563           DECL_EXTERNAL (t) = 1;
7564           TREE_PUBLIC (t) = 1;
7565
7566           t = start_decl (t, FALSE);
7567           finish_decl (t, NULL_TREE, FALSE);
7568
7569           if ((g != NULL)
7570               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7571                   || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7572                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
7573             ffeglobal_set_hook (g, t);
7574
7575           ffecom_save_tree_forever (t);
7576
7577           break;
7578
7579         default:
7580           assert ("NONE where unexpected" == NULL);
7581           /* Fall through. */
7582         case FFEINFO_whereANY:
7583           break;
7584         }
7585       break;
7586
7587     case FFEINFO_kindENTITY:
7588       switch (ffeinfo_where (ffesymbol_info (s)))
7589         {
7590
7591         case FFEINFO_whereCONSTANT:
7592           /* ~~Debugging info needed? */
7593           assert (!ffecom_transform_only_dummies_);
7594           t = error_mark_node;  /* Shouldn't ever see this in expr. */
7595           break;
7596
7597         case FFEINFO_whereLOCAL:
7598           assert (!ffecom_transform_only_dummies_);
7599
7600           {
7601             ffestorag st = ffesymbol_storage (s);
7602             tree type;
7603
7604             if ((st != NULL)
7605                 && (ffestorag_size (st) == 0))
7606               {
7607                 t = error_mark_node;
7608                 break;
7609               }
7610
7611             type = ffecom_type_localvar_ (s, bt, kt);
7612
7613             if (type == error_mark_node)
7614               {
7615                 t = error_mark_node;
7616                 break;
7617               }
7618
7619             if ((st != NULL)
7620                 && (ffestorag_parent (st) != NULL))
7621               {                 /* Child of EQUIVALENCE parent. */
7622                 ffestorag est;
7623                 tree et;
7624                 ffetargetOffset offset;
7625
7626                 est = ffestorag_parent (st);
7627                 ffecom_transform_equiv_ (est);
7628
7629                 et = ffestorag_hook (est);
7630                 assert (et != NULL_TREE);
7631
7632                 if (! TREE_STATIC (et))
7633                   put_var_into_stack (et);
7634
7635                 offset = ffestorag_modulo (est)
7636                   + ffestorag_offset (ffesymbol_storage (s))
7637                   - ffestorag_offset (est);
7638
7639                 ffecom_debug_kludge_ (et, "EQUIVALENCE", s, type, offset);
7640
7641                 /* (t_type *) (((char *) &et) + offset) */
7642
7643                 t = convert (string_type_node,  /* (char *) */
7644                              ffecom_1 (ADDR_EXPR,
7645                                        build_pointer_type (TREE_TYPE (et)),
7646                                        et));
7647                 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
7648                               t,
7649                               build_int_2 (offset, 0));
7650                 t = convert (build_pointer_type (type),
7651                              t);
7652                 TREE_CONSTANT (t) = staticp (et);
7653
7654                 addr = TRUE;
7655               }
7656             else
7657               {
7658                 tree initexpr;
7659                 bool init = ffesymbol_is_init (s);
7660
7661                 t = build_decl (VAR_DECL,
7662                                 ffecom_get_identifier_ (ffesymbol_text (s)),
7663                                 type);
7664
7665                 if (init
7666                     || ffesymbol_namelisted (s)
7667 #ifdef FFECOM_sizeMAXSTACKITEM
7668                     || ((st != NULL)
7669                         && (ffestorag_size (st) > FFECOM_sizeMAXSTACKITEM))
7670 #endif
7671                     || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
7672                         && (ffecom_primary_entry_kind_
7673                             != FFEINFO_kindBLOCKDATA)
7674                         && (ffesymbol_is_save (s) || ffe_is_saveall ())))
7675                   TREE_STATIC (t) = !ffesymbol_attr (s, FFESYMBOL_attrADJUSTABLE);
7676                 else
7677                   TREE_STATIC (t) = 0;  /* No need to make static. */
7678
7679                 if (init || ffe_is_init_local_zero ())
7680                   DECL_INITIAL (t) = error_mark_node;
7681
7682                 /* Keep -Wunused from complaining about var if it
7683                    is used as sfunc arg or DATA implied-DO.  */
7684                 if (ffesymbol_attrs (s) & FFESYMBOL_attrsSFARG)
7685                   DECL_IN_SYSTEM_HEADER (t) = 1;
7686
7687                 t = start_decl (t, FALSE);
7688
7689                 if (init)
7690                   {
7691                     if (ffesymbol_init (s) != NULL)
7692                       initexpr = ffecom_expr (ffesymbol_init (s));
7693                     else
7694                       initexpr = ffecom_init_zero_ (t);
7695                   }
7696                 else if (ffe_is_init_local_zero ())
7697                   initexpr = ffecom_init_zero_ (t);
7698                 else
7699                   initexpr = NULL_TREE; /* Not ref'd if !init. */
7700
7701                 finish_decl (t, initexpr, FALSE);
7702
7703                 if (st != NULL && DECL_SIZE (t) != error_mark_node)
7704                   {
7705                     assert (TREE_CODE (DECL_SIZE_UNIT (t)) == INTEGER_CST);
7706                     assert (0 == compare_tree_int (DECL_SIZE_UNIT (t),
7707                                                    ffestorag_size (st)));
7708                   }
7709               }
7710           }
7711           break;
7712
7713         case FFEINFO_whereRESULT:
7714           assert (!ffecom_transform_only_dummies_);
7715
7716           if (bt == FFEINFO_basictypeCHARACTER)
7717             {                   /* Result is already in list of dummies, use
7718                                    it (& length). */
7719               t = ffecom_func_result_;
7720               tlen = ffecom_func_length_;
7721               addr = TRUE;
7722               break;
7723             }
7724           if ((ffecom_num_entrypoints_ == 0)
7725               && (bt == FFEINFO_basictypeCOMPLEX)
7726               && (ffesymbol_is_f2c (ffecom_primary_entry_)))
7727             {                   /* Result is already in list of dummies, use
7728                                    it. */
7729               t = ffecom_func_result_;
7730               addr = TRUE;
7731               break;
7732             }
7733           if (ffecom_func_result_ != NULL_TREE)
7734             {
7735               t = ffecom_func_result_;
7736               break;
7737             }
7738           if ((ffecom_num_entrypoints_ != 0)
7739               && (ffecom_master_bt_ == FFEINFO_basictypeNONE))
7740             {
7741               assert (ffecom_multi_retval_ != NULL_TREE);
7742               t = ffecom_1 (INDIRECT_REF, ffecom_multi_type_node_,
7743                             ffecom_multi_retval_);
7744               t = ffecom_2 (COMPONENT_REF, ffecom_tree_type[bt][kt],
7745                             t, ffecom_multi_fields_[bt][kt]);
7746
7747               break;
7748             }
7749
7750           t = build_decl (VAR_DECL,
7751                           ffecom_get_identifier_ (ffesymbol_text (s)),
7752                           ffecom_tree_type[bt][kt]);
7753           TREE_STATIC (t) = 0;  /* Put result on stack. */
7754           t = start_decl (t, FALSE);
7755           finish_decl (t, NULL_TREE, FALSE);
7756
7757           ffecom_func_result_ = t;
7758
7759           break;
7760
7761         case FFEINFO_whereDUMMY:
7762           {
7763             tree type;
7764             ffebld dl;
7765             ffebld dim;
7766             tree low;
7767             tree high;
7768             tree old_sizes;
7769             bool adjustable = FALSE;    /* Conditionally adjustable? */
7770
7771             type = ffecom_tree_type[bt][kt];
7772             if (ffesymbol_sfdummyparent (s) != NULL)
7773               {
7774                 if (current_function_decl == ffecom_outer_function_decl_)
7775                   {                     /* Exec transition before sfunc
7776                                            context; get it later. */
7777                     break;
7778                   }
7779                 t = ffecom_get_identifier_ (ffesymbol_text
7780                                             (ffesymbol_sfdummyparent (s)));
7781               }
7782             else
7783               t = ffecom_get_identifier_ (ffesymbol_text (s));
7784
7785             assert (ffecom_transform_only_dummies_);
7786
7787             old_sizes = get_pending_sizes ();
7788             put_pending_sizes (old_sizes);
7789
7790             if (bt == FFEINFO_basictypeCHARACTER)
7791               tlen = ffecom_char_enhance_arg_ (&type, s);
7792             type = ffecom_check_size_overflow_ (s, type, TRUE);
7793
7794             for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
7795               {
7796                 if (type == error_mark_node)
7797                   break;
7798
7799                 dim = ffebld_head (dl);
7800                 assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
7801                 if ((ffebld_left (dim) == NULL) || ffecom_doing_entry_)
7802                   low = ffecom_integer_one_node;
7803                 else
7804                   low = ffecom_expr (ffebld_left (dim));
7805                 assert (ffebld_right (dim) != NULL);
7806                 if ((ffebld_op (ffebld_right (dim)) == FFEBLD_opSTAR)
7807                     || ffecom_doing_entry_)
7808                   {
7809                     /* Used to just do high=low.  But for ffecom_tree_
7810                        canonize_ref_, it probably is important to correctly
7811                        assess the size.  E.g. given COMPLEX C(*),CFUNC and
7812                        C(2)=CFUNC(C), overlap can happen, while it can't
7813                        for, say, C(1)=CFUNC(C(2)).  */
7814                     /* Even more recently used to set to INT_MAX, but that
7815                        broke when some overflow checking went into the back
7816                        end.  Now we just leave the upper bound unspecified.  */
7817                     high = NULL;
7818                   }
7819                 else
7820                   high = ffecom_expr (ffebld_right (dim));
7821
7822                 /* Determine whether array is conditionally adjustable,
7823                    to decide whether back-end magic is needed.
7824
7825                    Normally the front end uses the back-end function
7826                    variable_size to wrap SAVE_EXPR's around expressions
7827                    affecting the size/shape of an array so that the
7828                    size/shape info doesn't change during execution
7829                    of the compiled code even though variables and
7830                    functions referenced in those expressions might.
7831
7832                    variable_size also makes sure those saved expressions
7833                    get evaluated immediately upon entry to the
7834                    compiled procedure -- the front end normally doesn't
7835                    have to worry about that.
7836
7837                    However, there is a problem with this that affects
7838                    g77's implementation of entry points, and that is
7839                    that it is _not_ true that each invocation of the
7840                    compiled procedure is permitted to evaluate
7841                    array size/shape info -- because it is possible
7842                    that, for some invocations, that info is invalid (in
7843                    which case it is "promised" -- i.e. a violation of
7844                    the Fortran standard -- that the compiled code
7845                    won't reference the array or its size/shape
7846                    during that particular invocation).
7847
7848                    To phrase this in C terms, consider this gcc function:
7849
7850                      void foo (int *n, float (*a)[*n])
7851                      {
7852                        // a is "pointer to array ...", fyi.
7853                      }
7854
7855                    Suppose that, for some invocations, it is permitted
7856                    for a caller of foo to do this:
7857
7858                        foo (NULL, NULL);
7859
7860                    Now the _written_ code for foo can take such a call
7861                    into account by either testing explicitly for whether
7862                    (a == NULL) || (n == NULL) -- presumably it is
7863                    not permitted to reference *a in various fashions
7864                    if (n == NULL) I suppose -- or it can avoid it by
7865                    looking at other info (other arguments, static/global
7866                    data, etc.).
7867
7868                    However, this won't work in gcc 2.5.8 because it'll
7869                    automatically emit the code to save the "*n"
7870                    expression, which'll yield a NULL dereference for
7871                    the "foo (NULL, NULL)" call, something the code
7872                    for foo cannot prevent.
7873
7874                    g77 definitely needs to avoid executing such
7875                    code anytime the pointer to the adjustable array
7876                    is NULL, because even if its bounds expressions
7877                    don't have any references to possible "absent"
7878                    variables like "*n" -- say all variable references
7879                    are to COMMON variables, i.e. global (though in C,
7880                    local static could actually make sense) -- the
7881                    expressions could yield other run-time problems
7882                    for allowably "dead" values in those variables.
7883
7884                    For example, let's consider a more complicated
7885                    version of foo:
7886
7887                      extern int i;
7888                      extern int j;
7889
7890                      void foo (float (*a)[i/j])
7891                      {
7892                        ...
7893                      }
7894
7895                    The above is (essentially) quite valid for Fortran
7896                    but, again, for a call like "foo (NULL);", it is
7897                    permitted for i and j to be undefined when the
7898                    call is made.  If j happened to be zero, for
7899                    example, emitting the code to evaluate "i/j"
7900                    could result in a run-time error.
7901
7902                    Offhand, though I don't have my F77 or F90
7903                    standards handy, it might even be valid for a
7904                    bounds expression to contain a function reference,
7905                    in which case I doubt it is permitted for an
7906                    implementation to invoke that function in the
7907                    Fortran case involved here (invocation of an
7908                    alternate ENTRY point that doesn't have the adjustable
7909                    array as one of its arguments).
7910
7911                    So, the code that the compiler would normally emit
7912                    to preevaluate the size/shape info for an
7913                    adjustable array _must not_ be executed at run time
7914                    in certain cases.  Specifically, for Fortran,
7915                    the case is when the pointer to the adjustable
7916                    array == NULL.  (For gnu-ish C, it might be nice
7917                    for the source code itself to specify an expression
7918                    that, if TRUE, inhibits execution of the code.  Or
7919                    reverse the sense for elegance.)
7920
7921                    (Note that g77 could use a different test than NULL,
7922                    actually, since it happens to always pass an
7923                    integer to the called function that specifies which
7924                    entry point is being invoked.  Hmm, this might
7925                    solve the next problem.)
7926
7927                    One way a user could, I suppose, write "foo" so
7928                    it works is to insert COND_EXPR's for the
7929                    size/shape info so the dangerous stuff isn't
7930                    actually done, as in:
7931
7932                      void foo (int *n, float (*a)[(a == NULL) ? 0 : *n])
7933                      {
7934                        ...
7935                      }
7936
7937                    The next problem is that the front end needs to
7938                    be able to tell the back end about the array's
7939                    decl _before_ it tells it about the conditional
7940                    expression to inhibit evaluation of size/shape info,
7941                    as shown above.
7942
7943                    To solve this, the front end needs to be able
7944                    to give the back end the expression to inhibit
7945                    generation of the preevaluation code _after_
7946                    it makes the decl for the adjustable array.
7947
7948                    Until then, the above example using the COND_EXPR
7949                    doesn't pass muster with gcc because the "(a == NULL)"
7950                    part has a reference to "a", which is still
7951                    undefined at that point.
7952
7953                    g77 will therefore use a different mechanism in the
7954                    meantime.  */
7955
7956                 if (!adjustable
7957                     && ((TREE_CODE (low) != INTEGER_CST)
7958                         || (high && TREE_CODE (high) != INTEGER_CST)))
7959                   adjustable = TRUE;
7960
7961 #if 0                           /* Old approach -- see below. */
7962                 if (TREE_CODE (low) != INTEGER_CST)
7963                   low = ffecom_3 (COND_EXPR, integer_type_node,
7964                                   ffecom_adjarray_passed_ (s),
7965                                   low,
7966                                   ffecom_integer_zero_node);
7967
7968                 if (high && TREE_CODE (high) != INTEGER_CST)
7969                   high = ffecom_3 (COND_EXPR, integer_type_node,
7970                                    ffecom_adjarray_passed_ (s),
7971                                    high,
7972                                    ffecom_integer_zero_node);
7973 #endif
7974
7975                 /* ~~~gcc/stor-layout.c (layout_type) should do this,
7976                    probably.  Fixes 950302-1.f.  */
7977
7978                 if (TREE_CODE (low) != INTEGER_CST)
7979                   low = variable_size (low);
7980
7981                 /* ~~~Similarly, this fixes dumb0.f.  The C front end
7982                    does this, which is why dumb0.c would work.  */
7983
7984                 if (high && TREE_CODE (high) != INTEGER_CST)
7985                   high = variable_size (high);
7986
7987                 type
7988                   = build_array_type
7989                     (type,
7990                      build_range_type (ffecom_integer_type_node,
7991                                        low, high));
7992                 type = ffecom_check_size_overflow_ (s, type, TRUE);
7993               }
7994
7995             if (type == error_mark_node)
7996               {
7997                 t = error_mark_node;
7998                 break;
7999               }
8000
8001             if ((ffesymbol_sfdummyparent (s) == NULL)
8002                  || (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER))
8003               {
8004                 type = build_pointer_type (type);
8005                 addr = TRUE;
8006               }
8007
8008             t = build_decl (PARM_DECL, t, type);
8009 #if BUILT_FOR_270
8010             DECL_ARTIFICIAL (t) = 1;
8011 #endif
8012
8013             /* If this arg is present in every entry point's list of
8014                dummy args, then we're done.  */
8015
8016             if (ffesymbol_numentries (s)
8017                 == (ffecom_num_entrypoints_ + 1))
8018               break;
8019
8020 #if 1
8021
8022             /* If variable_size in stor-layout has been called during
8023                the above, then get_pending_sizes should have the
8024                yet-to-be-evaluated saved expressions pending.
8025                Make the whole lot of them get emitted, conditionally
8026                on whether the array decl ("t" above) is not NULL.  */
8027
8028             {
8029               tree sizes = get_pending_sizes ();
8030               tree tem;
8031
8032               for (tem = sizes;
8033                    tem != old_sizes;
8034                    tem = TREE_CHAIN (tem))
8035                 {
8036                   tree temv = TREE_VALUE (tem);
8037
8038                   if (sizes == tem)
8039                     sizes = temv;
8040                   else
8041                     sizes
8042                       = ffecom_2 (COMPOUND_EXPR,
8043                                   TREE_TYPE (sizes),
8044                                   temv,
8045                                   sizes);
8046                 }
8047
8048               if (sizes != tem)
8049                 {
8050                   sizes
8051                     = ffecom_3 (COND_EXPR,
8052                                 TREE_TYPE (sizes),
8053                                 ffecom_2 (NE_EXPR,
8054                                           integer_type_node,
8055                                           t,
8056                                           null_pointer_node),
8057                                 sizes,
8058                                 convert (TREE_TYPE (sizes),
8059                                          integer_zero_node));
8060                   sizes = ffecom_save_tree (sizes);
8061
8062                   sizes
8063                     = tree_cons (NULL_TREE, sizes, tem);
8064                 }
8065
8066               if (sizes)
8067                 put_pending_sizes (sizes);
8068             }
8069
8070 #else
8071 #if 0
8072             if (adjustable
8073                 && (ffesymbol_numentries (s)
8074                     != ffecom_num_entrypoints_ + 1))
8075               DECL_SOMETHING (t)
8076                 = ffecom_2 (NE_EXPR, integer_type_node,
8077                             t,
8078                             null_pointer_node);
8079 #else
8080 #if 0
8081             if (adjustable
8082                 && (ffesymbol_numentries (s)
8083                     != ffecom_num_entrypoints_ + 1))
8084               {
8085                 ffebad_start (FFEBAD_MISSING_ADJARRAY_UNSUPPORTED);
8086                 ffebad_here (0, ffesymbol_where_line (s),
8087                              ffesymbol_where_column (s));
8088                 ffebad_string (ffesymbol_text (s));
8089                 ffebad_finish ();
8090               }
8091 #endif
8092 #endif
8093 #endif
8094           }
8095           break;
8096
8097         case FFEINFO_whereCOMMON:
8098           {
8099             ffesymbol cs;
8100             ffeglobal cg;
8101             tree ct;
8102             ffestorag st = ffesymbol_storage (s);
8103             tree type;
8104
8105             cs = ffesymbol_common (s);  /* The COMMON area itself.  */
8106             if (st != NULL)     /* Else not laid out. */
8107               {
8108                 ffecom_transform_common_ (cs);
8109                 st = ffesymbol_storage (s);
8110               }
8111
8112             type = ffecom_type_localvar_ (s, bt, kt);
8113
8114             cg = ffesymbol_global (cs); /* The global COMMON info.  */
8115             if ((cg == NULL)
8116                 || (ffeglobal_type (cg) != FFEGLOBAL_typeCOMMON))
8117               ct = NULL_TREE;
8118             else
8119               ct = ffeglobal_hook (cg); /* The common area's tree.  */
8120
8121             if ((ct == NULL_TREE)
8122                 || (st == NULL)
8123                 || (type == error_mark_node))
8124               t = error_mark_node;
8125             else
8126               {
8127                 ffetargetOffset offset;
8128                 ffestorag cst;
8129
8130                 cst = ffestorag_parent (st);
8131                 assert (cst == ffesymbol_storage (cs));
8132
8133                 offset = ffestorag_modulo (cst)
8134                   + ffestorag_offset (st)
8135                   - ffestorag_offset (cst);
8136
8137                 ffecom_debug_kludge_ (ct, "COMMON", s, type, offset);
8138
8139                 /* (t_type *) (((char *) &ct) + offset) */
8140
8141                 t = convert (string_type_node,  /* (char *) */
8142                              ffecom_1 (ADDR_EXPR,
8143                                        build_pointer_type (TREE_TYPE (ct)),
8144                                        ct));
8145                 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
8146                               t,
8147                               build_int_2 (offset, 0));
8148                 t = convert (build_pointer_type (type),
8149                              t);
8150                 TREE_CONSTANT (t) = 1;
8151
8152                 addr = TRUE;
8153               }
8154           }
8155           break;
8156
8157         case FFEINFO_whereIMMEDIATE:
8158         case FFEINFO_whereGLOBAL:
8159         case FFEINFO_whereFLEETING:
8160         case FFEINFO_whereFLEETING_CADDR:
8161         case FFEINFO_whereFLEETING_IADDR:
8162         case FFEINFO_whereINTRINSIC:
8163         case FFEINFO_whereCONSTANT_SUBOBJECT:
8164         default:
8165           assert ("ENTITY where unheard of" == NULL);
8166           /* Fall through. */
8167         case FFEINFO_whereANY:
8168           t = error_mark_node;
8169           break;
8170         }
8171       break;
8172
8173     case FFEINFO_kindFUNCTION:
8174       switch (ffeinfo_where (ffesymbol_info (s)))
8175         {
8176         case FFEINFO_whereLOCAL:        /* Me. */
8177           assert (!ffecom_transform_only_dummies_);
8178           t = current_function_decl;
8179           break;
8180
8181         case FFEINFO_whereGLOBAL:
8182           assert (!ffecom_transform_only_dummies_);
8183
8184           if (((g = ffesymbol_global (s)) != NULL)
8185               && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8186                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8187               && (ffeglobal_hook (g) != NULL_TREE)
8188               && ffe_is_globals ())
8189             {
8190               t = ffeglobal_hook (g);
8191               break;
8192             }
8193
8194           if (ffesymbol_is_f2c (s)
8195               && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8196             t = ffecom_tree_fun_type[bt][kt];
8197           else
8198             t = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
8199
8200           t = build_decl (FUNCTION_DECL,
8201                           ffecom_get_external_identifier_ (s),
8202                           t);
8203           DECL_EXTERNAL (t) = 1;
8204           TREE_PUBLIC (t) = 1;
8205
8206           t = start_decl (t, FALSE);
8207           finish_decl (t, NULL_TREE, FALSE);
8208
8209           if ((g != NULL)
8210               && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8211                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8212             ffeglobal_set_hook (g, t);
8213
8214           ffecom_save_tree_forever (t);
8215
8216           break;
8217
8218         case FFEINFO_whereDUMMY:
8219           assert (ffecom_transform_only_dummies_);
8220
8221           if (ffesymbol_is_f2c (s)
8222               && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8223             t = ffecom_tree_ptr_to_fun_type[bt][kt];
8224           else
8225             t = build_pointer_type
8226               (build_function_type (ffecom_tree_type[bt][kt], NULL_TREE));
8227
8228           t = build_decl (PARM_DECL,
8229                           ffecom_get_identifier_ (ffesymbol_text (s)),
8230                           t);
8231 #if BUILT_FOR_270
8232           DECL_ARTIFICIAL (t) = 1;
8233 #endif
8234           addr = TRUE;
8235           break;
8236
8237         case FFEINFO_whereCONSTANT:     /* Statement function. */
8238           assert (!ffecom_transform_only_dummies_);
8239           t = ffecom_gen_sfuncdef_ (s, bt, kt);
8240           break;
8241
8242         case FFEINFO_whereINTRINSIC:
8243           assert (!ffecom_transform_only_dummies_);
8244           break;                /* Let actual references generate their
8245                                    decls. */
8246
8247         default:
8248           assert ("FUNCTION where unheard of" == NULL);
8249           /* Fall through. */
8250         case FFEINFO_whereANY:
8251           t = error_mark_node;
8252           break;
8253         }
8254       break;
8255
8256     case FFEINFO_kindSUBROUTINE:
8257       switch (ffeinfo_where (ffesymbol_info (s)))
8258         {
8259         case FFEINFO_whereLOCAL:        /* Me. */
8260           assert (!ffecom_transform_only_dummies_);
8261           t = current_function_decl;
8262           break;
8263
8264         case FFEINFO_whereGLOBAL:
8265           assert (!ffecom_transform_only_dummies_);
8266
8267           if (((g = ffesymbol_global (s)) != NULL)
8268               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8269                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8270               && (ffeglobal_hook (g) != NULL_TREE)
8271               && ffe_is_globals ())
8272             {
8273               t = ffeglobal_hook (g);
8274               break;
8275             }
8276
8277           t = build_decl (FUNCTION_DECL,
8278                           ffecom_get_external_identifier_ (s),
8279                           ffecom_tree_subr_type);
8280           DECL_EXTERNAL (t) = 1;
8281           TREE_PUBLIC (t) = 1;
8282
8283           t = start_decl (t, FALSE);
8284           finish_decl (t, NULL_TREE, FALSE);
8285
8286           if ((g != NULL)
8287               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8288                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8289             ffeglobal_set_hook (g, t);
8290
8291           ffecom_save_tree_forever (t);
8292
8293           break;
8294
8295         case FFEINFO_whereDUMMY:
8296           assert (ffecom_transform_only_dummies_);
8297
8298           t = build_decl (PARM_DECL,
8299                           ffecom_get_identifier_ (ffesymbol_text (s)),
8300                           ffecom_tree_ptr_to_subr_type);
8301 #if BUILT_FOR_270
8302           DECL_ARTIFICIAL (t) = 1;
8303 #endif
8304           addr = TRUE;
8305           break;
8306
8307         case FFEINFO_whereINTRINSIC:
8308           assert (!ffecom_transform_only_dummies_);
8309           break;                /* Let actual references generate their
8310                                    decls. */
8311
8312         default:
8313           assert ("SUBROUTINE where unheard of" == NULL);
8314           /* Fall through. */
8315         case FFEINFO_whereANY:
8316           t = error_mark_node;
8317           break;
8318         }
8319       break;
8320
8321     case FFEINFO_kindPROGRAM:
8322       switch (ffeinfo_where (ffesymbol_info (s)))
8323         {
8324         case FFEINFO_whereLOCAL:        /* Me. */
8325           assert (!ffecom_transform_only_dummies_);
8326           t = current_function_decl;
8327           break;
8328
8329         case FFEINFO_whereCOMMON:
8330         case FFEINFO_whereDUMMY:
8331         case FFEINFO_whereGLOBAL:
8332         case FFEINFO_whereRESULT:
8333         case FFEINFO_whereFLEETING:
8334         case FFEINFO_whereFLEETING_CADDR:
8335         case FFEINFO_whereFLEETING_IADDR:
8336         case FFEINFO_whereIMMEDIATE:
8337         case FFEINFO_whereINTRINSIC:
8338         case FFEINFO_whereCONSTANT:
8339         case FFEINFO_whereCONSTANT_SUBOBJECT:
8340         default:
8341           assert ("PROGRAM where unheard of" == NULL);
8342           /* Fall through. */
8343         case FFEINFO_whereANY:
8344           t = error_mark_node;
8345           break;
8346         }
8347       break;
8348
8349     case FFEINFO_kindBLOCKDATA:
8350       switch (ffeinfo_where (ffesymbol_info (s)))
8351         {
8352         case FFEINFO_whereLOCAL:        /* Me. */
8353           assert (!ffecom_transform_only_dummies_);
8354           t = current_function_decl;
8355           break;
8356
8357         case FFEINFO_whereGLOBAL:
8358           assert (!ffecom_transform_only_dummies_);
8359
8360           t = build_decl (FUNCTION_DECL,
8361                           ffecom_get_external_identifier_ (s),
8362                           ffecom_tree_blockdata_type);
8363           DECL_EXTERNAL (t) = 1;
8364           TREE_PUBLIC (t) = 1;
8365
8366           t = start_decl (t, FALSE);
8367           finish_decl (t, NULL_TREE, FALSE);
8368
8369           ffecom_save_tree_forever (t);
8370
8371           break;
8372
8373         case FFEINFO_whereCOMMON:
8374         case FFEINFO_whereDUMMY:
8375         case FFEINFO_whereRESULT:
8376         case FFEINFO_whereFLEETING:
8377         case FFEINFO_whereFLEETING_CADDR:
8378         case FFEINFO_whereFLEETING_IADDR:
8379         case FFEINFO_whereIMMEDIATE:
8380         case FFEINFO_whereINTRINSIC:
8381         case FFEINFO_whereCONSTANT:
8382         case FFEINFO_whereCONSTANT_SUBOBJECT:
8383         default:
8384           assert ("BLOCKDATA where unheard of" == NULL);
8385           /* Fall through. */
8386         case FFEINFO_whereANY:
8387           t = error_mark_node;
8388           break;
8389         }
8390       break;
8391
8392     case FFEINFO_kindCOMMON:
8393       switch (ffeinfo_where (ffesymbol_info (s)))
8394         {
8395         case FFEINFO_whereLOCAL:
8396           assert (!ffecom_transform_only_dummies_);
8397           ffecom_transform_common_ (s);
8398           break;
8399
8400         case FFEINFO_whereNONE:
8401         case FFEINFO_whereCOMMON:
8402         case FFEINFO_whereDUMMY:
8403         case FFEINFO_whereGLOBAL:
8404         case FFEINFO_whereRESULT:
8405         case FFEINFO_whereFLEETING:
8406         case FFEINFO_whereFLEETING_CADDR:
8407         case FFEINFO_whereFLEETING_IADDR:
8408         case FFEINFO_whereIMMEDIATE:
8409         case FFEINFO_whereINTRINSIC:
8410         case FFEINFO_whereCONSTANT:
8411         case FFEINFO_whereCONSTANT_SUBOBJECT:
8412         default:
8413           assert ("COMMON where unheard of" == NULL);
8414           /* Fall through. */
8415         case FFEINFO_whereANY:
8416           t = error_mark_node;
8417           break;
8418         }
8419       break;
8420
8421     case FFEINFO_kindCONSTRUCT:
8422       switch (ffeinfo_where (ffesymbol_info (s)))
8423         {
8424         case FFEINFO_whereLOCAL:
8425           assert (!ffecom_transform_only_dummies_);
8426           break;
8427
8428         case FFEINFO_whereNONE:
8429         case FFEINFO_whereCOMMON:
8430         case FFEINFO_whereDUMMY:
8431         case FFEINFO_whereGLOBAL:
8432         case FFEINFO_whereRESULT:
8433         case FFEINFO_whereFLEETING:
8434         case FFEINFO_whereFLEETING_CADDR:
8435         case FFEINFO_whereFLEETING_IADDR:
8436         case FFEINFO_whereIMMEDIATE:
8437         case FFEINFO_whereINTRINSIC:
8438         case FFEINFO_whereCONSTANT:
8439         case FFEINFO_whereCONSTANT_SUBOBJECT:
8440         default:
8441           assert ("CONSTRUCT where unheard of" == NULL);
8442           /* Fall through. */
8443         case FFEINFO_whereANY:
8444           t = error_mark_node;
8445           break;
8446         }
8447       break;
8448
8449     case FFEINFO_kindNAMELIST:
8450       switch (ffeinfo_where (ffesymbol_info (s)))
8451         {
8452         case FFEINFO_whereLOCAL:
8453           assert (!ffecom_transform_only_dummies_);
8454           t = ffecom_transform_namelist_ (s);
8455           break;
8456
8457         case FFEINFO_whereNONE:
8458         case FFEINFO_whereCOMMON:
8459         case FFEINFO_whereDUMMY:
8460         case FFEINFO_whereGLOBAL:
8461         case FFEINFO_whereRESULT:
8462         case FFEINFO_whereFLEETING:
8463         case FFEINFO_whereFLEETING_CADDR:
8464         case FFEINFO_whereFLEETING_IADDR:
8465         case FFEINFO_whereIMMEDIATE:
8466         case FFEINFO_whereINTRINSIC:
8467         case FFEINFO_whereCONSTANT:
8468         case FFEINFO_whereCONSTANT_SUBOBJECT:
8469         default:
8470           assert ("NAMELIST where unheard of" == NULL);
8471           /* Fall through. */
8472         case FFEINFO_whereANY:
8473           t = error_mark_node;
8474           break;
8475         }
8476       break;
8477
8478     default:
8479       assert ("kind unheard of" == NULL);
8480       /* Fall through. */
8481     case FFEINFO_kindANY:
8482       t = error_mark_node;
8483       break;
8484     }
8485
8486   ffesymbol_hook (s).decl_tree = t;
8487   ffesymbol_hook (s).length_tree = tlen;
8488   ffesymbol_hook (s).addr = addr;
8489
8490   lineno = old_lineno;
8491   input_filename = old_input_filename;
8492
8493   return s;
8494 }
8495
8496 #endif
8497 /* Transform into ASSIGNable symbol.
8498
8499    Symbol has already been transformed, but for whatever reason, the
8500    resulting decl_tree has been deemed not usable for an ASSIGN target.
8501    (E.g. it isn't wide enough to hold a pointer.)  So, here we invent
8502    another local symbol of type void * and stuff that in the assign_tree
8503    argument.  The F77/F90 standards allow this implementation.  */
8504
8505 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8506 static ffesymbol
8507 ffecom_sym_transform_assign_ (ffesymbol s)
8508 {
8509   tree t;                       /* Transformed thingy. */
8510   int old_lineno = lineno;
8511   const char *old_input_filename = input_filename;
8512
8513   if (ffesymbol_sfdummyparent (s) == NULL)
8514     {
8515       input_filename = ffesymbol_where_filename (s);
8516       lineno = ffesymbol_where_filelinenum (s);
8517     }
8518   else
8519     {
8520       ffesymbol sf = ffesymbol_sfdummyparent (s);
8521
8522       input_filename = ffesymbol_where_filename (sf);
8523       lineno = ffesymbol_where_filelinenum (sf);
8524     }
8525
8526   assert (!ffecom_transform_only_dummies_);
8527
8528   t = build_decl (VAR_DECL,
8529                   ffecom_get_invented_identifier ("__g77_ASSIGN_%s",
8530                                                    ffesymbol_text (s)),
8531                   TREE_TYPE (null_pointer_node));
8532
8533   switch (ffesymbol_where (s))
8534     {
8535     case FFEINFO_whereLOCAL:
8536       /* Unlike for regular vars, SAVE status is easy to determine for
8537          ASSIGNed vars, since there's no initialization, there's no
8538          effective storage association (so "SAVE J" does not apply to
8539          K even given "EQUIVALENCE (J,K)"), there's no size issue
8540          to worry about, etc.  */
8541       if ((ffesymbol_is_save (s) || ffe_is_saveall ())
8542           && (ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8543           && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA))
8544         TREE_STATIC (t) = 1;    /* SAVEd in proc, make static. */
8545       else
8546         TREE_STATIC (t) = 0;    /* No need to make static. */
8547       break;
8548
8549     case FFEINFO_whereCOMMON:
8550       TREE_STATIC (t) = 1;      /* Assume COMMONs always SAVEd. */
8551       break;
8552
8553     case FFEINFO_whereDUMMY:
8554       /* Note that twinning a DUMMY means the caller won't see
8555          the ASSIGNed value.  But both F77 and F90 allow implementations
8556          to do this, i.e. disallow Fortran code that would try and
8557          take advantage of actually putting a label into a variable
8558          via a dummy argument (or any other storage association, for
8559          that matter).  */
8560       TREE_STATIC (t) = 0;
8561       break;
8562
8563     default:
8564       TREE_STATIC (t) = 0;
8565       break;
8566     }
8567
8568   t = start_decl (t, FALSE);
8569   finish_decl (t, NULL_TREE, FALSE);
8570
8571   ffesymbol_hook (s).assign_tree = t;
8572
8573   lineno = old_lineno;
8574   input_filename = old_input_filename;
8575
8576   return s;
8577 }
8578
8579 #endif
8580 /* Implement COMMON area in back end.
8581
8582    Because COMMON-based variables can be referenced in the dimension
8583    expressions of dummy (adjustable) arrays, and because dummies
8584    (in the gcc back end) need to be put in the outer binding level
8585    of a function (which has two binding levels, the outer holding
8586    the dummies and the inner holding the other vars), special care
8587    must be taken to handle COMMON areas.
8588
8589    The current strategy is basically to always tell the back end about
8590    the COMMON area as a top-level external reference to just a block
8591    of storage of the master type of that area (e.g. integer, real,
8592    character, whatever -- not a structure).  As a distinct action,
8593    if initial values are provided, tell the back end about the area
8594    as a top-level non-external (initialized) area and remember not to
8595    allow further initialization or expansion of the area.  Meanwhile,
8596    if no initialization happens at all, tell the back end about
8597    the largest size we've seen declared so the space does get reserved.
8598    (This function doesn't handle all that stuff, but it does some
8599    of the important things.)
8600
8601    Meanwhile, for COMMON variables themselves, just keep creating
8602    references like *((float *) (&common_area + offset)) each time
8603    we reference the variable.  In other words, don't make a VAR_DECL
8604    or any kind of component reference (like we used to do before 0.4),
8605    though we might do that as well just for debugging purposes (and
8606    stuff the rtl with the appropriate offset expression).  */
8607
8608 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8609 static void
8610 ffecom_transform_common_ (ffesymbol s)
8611 {
8612   ffestorag st = ffesymbol_storage (s);
8613   ffeglobal g = ffesymbol_global (s);
8614   tree cbt;
8615   tree cbtype;
8616   tree init;
8617   tree high;
8618   bool is_init = ffestorag_is_init (st);
8619
8620   assert (st != NULL);
8621
8622   if ((g == NULL)
8623       || (ffeglobal_type (g) != FFEGLOBAL_typeCOMMON))
8624     return;
8625
8626   /* First update the size of the area in global terms.  */
8627
8628   ffeglobal_size_common (s, ffestorag_size (st));
8629
8630   if (!ffeglobal_common_init (g))
8631     is_init = FALSE;    /* No explicit init, don't let erroneous joins init. */
8632
8633   cbt = ffeglobal_hook (g);
8634
8635   /* If we already have declared this common block for a previous program
8636      unit, and either we already initialized it or we don't have new
8637      initialization for it, just return what we have without changing it.  */
8638
8639   if ((cbt != NULL_TREE)
8640       && (!is_init
8641           || !DECL_EXTERNAL (cbt)))
8642     {
8643       if (st->hook == NULL) ffestorag_set_hook (st, cbt);
8644       return;
8645     }
8646
8647   /* Process inits.  */
8648
8649   if (is_init)
8650     {
8651       if (ffestorag_init (st) != NULL)
8652         {
8653           ffebld sexp;
8654
8655           /* Set the padding for the expression, so ffecom_expr
8656              knows to insert that many zeros.  */
8657           switch (ffebld_op (sexp = ffestorag_init (st)))
8658             {
8659             case FFEBLD_opCONTER:
8660               ffebld_conter_set_pad (sexp, ffestorag_modulo (st));
8661               break;
8662
8663             case FFEBLD_opARRTER:
8664               ffebld_arrter_set_pad (sexp, ffestorag_modulo (st));
8665               break;
8666
8667             case FFEBLD_opACCTER:
8668               ffebld_accter_set_pad (sexp, ffestorag_modulo (st));
8669               break;
8670
8671             default:
8672               assert ("bad op for cmn init (pad)" == NULL);
8673               break;
8674             }
8675
8676           init = ffecom_expr (sexp);
8677           if (init == error_mark_node)
8678             {                   /* Hopefully the back end complained! */
8679               init = NULL_TREE;
8680               if (cbt != NULL_TREE)
8681                 return;
8682             }
8683         }
8684       else
8685         init = error_mark_node;
8686     }
8687   else
8688     init = NULL_TREE;
8689
8690   /* cbtype must be permanently allocated!  */
8691
8692   /* Allocate the MAX of the areas so far, seen filewide.  */
8693   high = build_int_2 ((ffeglobal_common_size (g)
8694                        + ffeglobal_common_pad (g)) - 1, 0);
8695   TREE_TYPE (high) = ffecom_integer_type_node;
8696
8697   if (init)
8698     cbtype = build_array_type (char_type_node,
8699                                build_range_type (integer_type_node,
8700                                                  integer_zero_node,
8701                                                  high));
8702   else
8703     cbtype = build_array_type (char_type_node, NULL_TREE);
8704
8705   if (cbt == NULL_TREE)
8706     {
8707       cbt
8708         = build_decl (VAR_DECL,
8709                       ffecom_get_external_identifier_ (s),
8710                       cbtype);
8711       TREE_STATIC (cbt) = 1;
8712       TREE_PUBLIC (cbt) = 1;
8713     }
8714   else
8715     {
8716       assert (is_init);
8717       TREE_TYPE (cbt) = cbtype;
8718     }
8719   DECL_EXTERNAL (cbt) = init ? 0 : 1;
8720   DECL_INITIAL (cbt) = init ? error_mark_node : NULL_TREE;
8721
8722   cbt = start_decl (cbt, TRUE);
8723   if (ffeglobal_hook (g) != NULL)
8724     assert (cbt == ffeglobal_hook (g));
8725
8726   assert (!init || !DECL_EXTERNAL (cbt));
8727
8728   /* Make sure that any type can live in COMMON and be referenced
8729      without getting a bus error.  We could pick the most restrictive
8730      alignment of all entities actually placed in the COMMON, but
8731      this seems easy enough.  */
8732
8733   DECL_ALIGN (cbt) = BIGGEST_ALIGNMENT;
8734   DECL_USER_ALIGN (cbt) = 0;
8735
8736   if (is_init && (ffestorag_init (st) == NULL))
8737     init = ffecom_init_zero_ (cbt);
8738
8739   finish_decl (cbt, init, TRUE);
8740
8741   if (is_init)
8742     ffestorag_set_init (st, ffebld_new_any ());
8743
8744   if (init)
8745     {
8746       assert (DECL_SIZE_UNIT (cbt) != NULL_TREE);
8747       assert (TREE_CODE (DECL_SIZE_UNIT (cbt)) == INTEGER_CST);
8748       assert (0 == compare_tree_int (DECL_SIZE_UNIT (cbt),
8749                                      (ffeglobal_common_size (g)
8750                                       + ffeglobal_common_pad (g))));
8751     }
8752
8753   ffeglobal_set_hook (g, cbt);
8754
8755   ffestorag_set_hook (st, cbt);
8756
8757   ffecom_save_tree_forever (cbt);
8758 }
8759
8760 #endif
8761 /* Make master area for local EQUIVALENCE.  */
8762
8763 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8764 static void
8765 ffecom_transform_equiv_ (ffestorag eqst)
8766 {
8767   tree eqt;
8768   tree eqtype;
8769   tree init;
8770   tree high;
8771   bool is_init = ffestorag_is_init (eqst);
8772
8773   assert (eqst != NULL);
8774
8775   eqt = ffestorag_hook (eqst);
8776
8777   if (eqt != NULL_TREE)
8778     return;
8779
8780   /* Process inits.  */
8781
8782   if (is_init)
8783     {
8784       if (ffestorag_init (eqst) != NULL)
8785         {
8786           ffebld sexp;
8787
8788           /* Set the padding for the expression, so ffecom_expr
8789              knows to insert that many zeros.  */
8790           switch (ffebld_op (sexp = ffestorag_init (eqst)))
8791             {
8792             case FFEBLD_opCONTER:
8793               ffebld_conter_set_pad (sexp, ffestorag_modulo (eqst));
8794               break;
8795
8796             case FFEBLD_opARRTER:
8797               ffebld_arrter_set_pad (sexp, ffestorag_modulo (eqst));
8798               break;
8799
8800             case FFEBLD_opACCTER:
8801               ffebld_accter_set_pad (sexp, ffestorag_modulo (eqst));
8802               break;
8803
8804             default:
8805               assert ("bad op for eqv init (pad)" == NULL);
8806               break;
8807             }
8808
8809           init = ffecom_expr (sexp);
8810           if (init == error_mark_node)
8811             init = NULL_TREE;   /* Hopefully the back end complained! */
8812         }
8813       else
8814         init = error_mark_node;
8815     }
8816   else if (ffe_is_init_local_zero ())
8817     init = error_mark_node;
8818   else
8819     init = NULL_TREE;
8820
8821   ffecom_member_namelisted_ = FALSE;
8822   ffestorag_drive (ffestorag_list_equivs (eqst),
8823                    &ffecom_member_phase1_,
8824                    eqst);
8825
8826   high = build_int_2 ((ffestorag_size (eqst)
8827                        + ffestorag_modulo (eqst)) - 1, 0);
8828   TREE_TYPE (high) = ffecom_integer_type_node;
8829
8830   eqtype = build_array_type (char_type_node,
8831                              build_range_type (ffecom_integer_type_node,
8832                                                ffecom_integer_zero_node,
8833                                                high));
8834
8835   eqt = build_decl (VAR_DECL,
8836                     ffecom_get_invented_identifier ("__g77_equiv_%s",
8837                                                     ffesymbol_text
8838                                                     (ffestorag_symbol (eqst))),
8839                     eqtype);
8840   DECL_EXTERNAL (eqt) = 0;
8841   if (is_init
8842       || ffecom_member_namelisted_
8843 #ifdef FFECOM_sizeMAXSTACKITEM
8844       || (ffestorag_size (eqst) > FFECOM_sizeMAXSTACKITEM)
8845 #endif
8846       || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8847           && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
8848           && (ffestorag_is_save (eqst) || ffe_is_saveall ())))
8849     TREE_STATIC (eqt) = 1;
8850   else
8851     TREE_STATIC (eqt) = 0;
8852   TREE_PUBLIC (eqt) = 0;
8853   TREE_ADDRESSABLE (eqt) = 1;  /* Ensure non-register allocation */
8854   DECL_CONTEXT (eqt) = current_function_decl;
8855   if (init)
8856     DECL_INITIAL (eqt) = error_mark_node;
8857   else
8858     DECL_INITIAL (eqt) = NULL_TREE;
8859
8860   eqt = start_decl (eqt, FALSE);
8861
8862   /* Make sure that any type can live in EQUIVALENCE and be referenced
8863      without getting a bus error.  We could pick the most restrictive
8864      alignment of all entities actually placed in the EQUIVALENCE, but
8865      this seems easy enough.  */
8866
8867   DECL_ALIGN (eqt) = BIGGEST_ALIGNMENT;
8868   DECL_USER_ALIGN (eqt) = 0;
8869
8870   if ((!is_init && ffe_is_init_local_zero ())
8871       || (is_init && (ffestorag_init (eqst) == NULL)))
8872     init = ffecom_init_zero_ (eqt);
8873
8874   finish_decl (eqt, init, FALSE);
8875
8876   if (is_init)
8877     ffestorag_set_init (eqst, ffebld_new_any ());
8878
8879   {
8880     assert (TREE_CODE (DECL_SIZE_UNIT (eqt)) == INTEGER_CST);
8881     assert (0 == compare_tree_int (DECL_SIZE_UNIT (eqt),
8882                                    (ffestorag_size (eqst)
8883                                     + ffestorag_modulo (eqst))));
8884   }
8885
8886   ffestorag_set_hook (eqst, eqt);
8887
8888   ffestorag_drive (ffestorag_list_equivs (eqst),
8889                    &ffecom_member_phase2_,
8890                    eqst);
8891 }
8892
8893 #endif
8894 /* Implement NAMELIST in back end.  See f2c/format.c for more info.  */
8895
8896 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8897 static tree
8898 ffecom_transform_namelist_ (ffesymbol s)
8899 {
8900   tree nmlt;
8901   tree nmltype = ffecom_type_namelist_ ();
8902   tree nmlinits;
8903   tree nameinit;
8904   tree varsinit;
8905   tree nvarsinit;
8906   tree field;
8907   tree high;
8908   int i;
8909   static int mynumber = 0;
8910
8911   nmlt = build_decl (VAR_DECL,
8912                      ffecom_get_invented_identifier ("__g77_namelist_%d",
8913                                                      mynumber++),
8914                      nmltype);
8915   TREE_STATIC (nmlt) = 1;
8916   DECL_INITIAL (nmlt) = error_mark_node;
8917
8918   nmlt = start_decl (nmlt, FALSE);
8919
8920   /* Process inits.  */
8921
8922   i = strlen (ffesymbol_text (s));
8923
8924   high = build_int_2 (i, 0);
8925   TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
8926
8927   nameinit = ffecom_build_f2c_string_ (i + 1,
8928                                        ffesymbol_text (s));
8929   TREE_TYPE (nameinit)
8930     = build_type_variant
8931     (build_array_type
8932      (char_type_node,
8933       build_range_type (ffecom_f2c_ftnlen_type_node,
8934                         ffecom_f2c_ftnlen_one_node,
8935                         high)),
8936      1, 0);
8937   TREE_CONSTANT (nameinit) = 1;
8938   TREE_STATIC (nameinit) = 1;
8939   nameinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (nameinit)),
8940                        nameinit);
8941
8942   varsinit = ffecom_vardesc_array_ (s);
8943   varsinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (varsinit)),
8944                        varsinit);
8945   TREE_CONSTANT (varsinit) = 1;
8946   TREE_STATIC (varsinit) = 1;
8947
8948   {
8949     ffebld b;
8950
8951     for (i = 0, b = ffesymbol_namelist (s); b != NULL; b = ffebld_trail (b))
8952       ++i;
8953   }
8954   nvarsinit = build_int_2 (i, 0);
8955   TREE_TYPE (nvarsinit) = integer_type_node;
8956   TREE_CONSTANT (nvarsinit) = 1;
8957   TREE_STATIC (nvarsinit) = 1;
8958
8959   nmlinits = build_tree_list ((field = TYPE_FIELDS (nmltype)), nameinit);
8960   TREE_CHAIN (nmlinits) = build_tree_list ((field = TREE_CHAIN (field)),
8961                                            varsinit);
8962   TREE_CHAIN (TREE_CHAIN (nmlinits))
8963     = build_tree_list ((field = TREE_CHAIN (field)), nvarsinit);
8964
8965   nmlinits = build (CONSTRUCTOR, nmltype, NULL_TREE, nmlinits);
8966   TREE_CONSTANT (nmlinits) = 1;
8967   TREE_STATIC (nmlinits) = 1;
8968
8969   finish_decl (nmlt, nmlinits, FALSE);
8970
8971   nmlt = ffecom_1 (ADDR_EXPR, build_pointer_type (nmltype), nmlt);
8972
8973   return nmlt;
8974 }
8975
8976 #endif
8977
8978 /* A subroutine of ffecom_tree_canonize_ref_.  The incoming tree is
8979    analyzed on the assumption it is calculating a pointer to be
8980    indirected through.  It must return the proper decl and offset,
8981    taking into account different units of measurements for offsets.  */
8982
8983 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8984 static void
8985 ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
8986                            tree t)
8987 {
8988   switch (TREE_CODE (t))
8989     {
8990     case NOP_EXPR:
8991     case CONVERT_EXPR:
8992     case NON_LVALUE_EXPR:
8993       ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
8994       break;
8995
8996     case PLUS_EXPR:
8997       ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
8998       if ((*decl == NULL_TREE)
8999           || (*decl == error_mark_node))
9000         break;
9001
9002       if (TREE_CODE (TREE_OPERAND (t, 1)) == INTEGER_CST)
9003         {
9004           /* An offset into COMMON.  */
9005           *offset = fold (build (PLUS_EXPR, TREE_TYPE (*offset),
9006                                  *offset, TREE_OPERAND (t, 1)));
9007           /* Convert offset (presumably in bytes) into canonical units
9008              (presumably bits).  */
9009           *offset = size_binop (MULT_EXPR,
9010                                 convert (bitsizetype, *offset),
9011                                 TYPE_SIZE (TREE_TYPE (TREE_TYPE (t))));
9012           break;
9013         }
9014       /* Not a COMMON reference, so an unrecognized pattern.  */
9015       *decl = error_mark_node;
9016       break;
9017
9018     case PARM_DECL:
9019       *decl = t;
9020       *offset = bitsize_zero_node;
9021       break;
9022
9023     case ADDR_EXPR:
9024       if (TREE_CODE (TREE_OPERAND (t, 0)) == VAR_DECL)
9025         {
9026           /* A reference to COMMON.  */
9027           *decl = TREE_OPERAND (t, 0);
9028           *offset = bitsize_zero_node;
9029           break;
9030         }
9031       /* Fall through.  */
9032     default:
9033       /* Not a COMMON reference, so an unrecognized pattern.  */
9034       *decl = error_mark_node;
9035       break;
9036     }
9037 }
9038 #endif
9039
9040 /* Given a tree that is possibly intended for use as an lvalue, return
9041    information representing a canonical view of that tree as a decl, an
9042    offset into that decl, and a size for the lvalue.
9043
9044    If there's no applicable decl, NULL_TREE is returned for the decl,
9045    and the other fields are left undefined.
9046
9047    If the tree doesn't fit the recognizable forms, an ERROR_MARK node
9048    is returned for the decl, and the other fields are left undefined.
9049
9050    Otherwise, the decl returned currently is either a VAR_DECL or a
9051    PARM_DECL.
9052
9053    The offset returned is always valid, but of course not necessarily
9054    a constant, and not necessarily converted into the appropriate
9055    type, leaving that up to the caller (so as to avoid that overhead
9056    if the decls being looked at are different anyway).
9057
9058    If the size cannot be determined (e.g. an adjustable array),
9059    an ERROR_MARK node is returned for the size.  Otherwise, the
9060    size returned is valid, not necessarily a constant, and not
9061    necessarily converted into the appropriate type as with the
9062    offset.
9063
9064    Note that the offset and size expressions are expressed in the
9065    base storage units (usually bits) rather than in the units of
9066    the type of the decl, because two decls with different types
9067    might overlap but with apparently non-overlapping array offsets,
9068    whereas converting the array offsets to consistant offsets will
9069    reveal the overlap.  */
9070
9071 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9072 static void
9073 ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
9074                            tree *size, tree t)
9075 {
9076   /* The default path is to report a nonexistant decl.  */
9077   *decl = NULL_TREE;
9078
9079   if (t == NULL_TREE)
9080     return;
9081
9082   switch (TREE_CODE (t))
9083     {
9084     case ERROR_MARK:
9085     case IDENTIFIER_NODE:
9086     case INTEGER_CST:
9087     case REAL_CST:
9088     case COMPLEX_CST:
9089     case STRING_CST:
9090     case CONST_DECL:
9091     case PLUS_EXPR:
9092     case MINUS_EXPR:
9093     case MULT_EXPR:
9094     case TRUNC_DIV_EXPR:
9095     case CEIL_DIV_EXPR:
9096     case FLOOR_DIV_EXPR:
9097     case ROUND_DIV_EXPR:
9098     case TRUNC_MOD_EXPR:
9099     case CEIL_MOD_EXPR:
9100     case FLOOR_MOD_EXPR:
9101     case ROUND_MOD_EXPR:
9102     case RDIV_EXPR:
9103     case EXACT_DIV_EXPR:
9104     case FIX_TRUNC_EXPR:
9105     case FIX_CEIL_EXPR:
9106     case FIX_FLOOR_EXPR:
9107     case FIX_ROUND_EXPR:
9108     case FLOAT_EXPR:
9109     case EXPON_EXPR:
9110     case NEGATE_EXPR:
9111     case MIN_EXPR:
9112     case MAX_EXPR:
9113     case ABS_EXPR:
9114     case FFS_EXPR:
9115     case LSHIFT_EXPR:
9116     case RSHIFT_EXPR:
9117     case LROTATE_EXPR:
9118     case RROTATE_EXPR:
9119     case BIT_IOR_EXPR:
9120     case BIT_XOR_EXPR:
9121     case BIT_AND_EXPR:
9122     case BIT_ANDTC_EXPR:
9123     case BIT_NOT_EXPR:
9124     case TRUTH_ANDIF_EXPR:
9125     case TRUTH_ORIF_EXPR:
9126     case TRUTH_AND_EXPR:
9127     case TRUTH_OR_EXPR:
9128     case TRUTH_XOR_EXPR:
9129     case TRUTH_NOT_EXPR:
9130     case LT_EXPR:
9131     case LE_EXPR:
9132     case GT_EXPR:
9133     case GE_EXPR:
9134     case EQ_EXPR:
9135     case NE_EXPR:
9136     case COMPLEX_EXPR:
9137     case CONJ_EXPR:
9138     case REALPART_EXPR:
9139     case IMAGPART_EXPR:
9140     case LABEL_EXPR:
9141     case COMPONENT_REF:
9142     case COMPOUND_EXPR:
9143     case ADDR_EXPR:
9144       return;
9145
9146     case VAR_DECL:
9147     case PARM_DECL:
9148       *decl = t;
9149       *offset = bitsize_zero_node;
9150       *size = TYPE_SIZE (TREE_TYPE (t));
9151       return;
9152
9153     case ARRAY_REF:
9154       {
9155         tree array = TREE_OPERAND (t, 0);
9156         tree element = TREE_OPERAND (t, 1);
9157         tree init_offset;
9158
9159         if ((array == NULL_TREE)
9160             || (element == NULL_TREE))
9161           {
9162             *decl = error_mark_node;
9163             return;
9164           }
9165
9166         ffecom_tree_canonize_ref_ (decl, &init_offset, size,
9167                                    array);
9168         if ((*decl == NULL_TREE)
9169             || (*decl == error_mark_node))
9170           return;
9171
9172         /* Calculate ((element - base) * NBBY) + init_offset.  */
9173         *offset = fold (build (MINUS_EXPR, TREE_TYPE (element),
9174                                element,
9175                                TYPE_MIN_VALUE (TYPE_DOMAIN
9176                                                (TREE_TYPE (array)))));
9177
9178         *offset = size_binop (MULT_EXPR,
9179                               convert (bitsizetype, *offset),
9180                               TYPE_SIZE (TREE_TYPE (TREE_TYPE (array))));
9181
9182         *offset = size_binop (PLUS_EXPR, init_offset, *offset);
9183
9184         *size = TYPE_SIZE (TREE_TYPE (t));
9185         return;
9186       }
9187
9188     case INDIRECT_REF:
9189
9190       /* Most of this code is to handle references to COMMON.  And so
9191          far that is useful only for calling library functions, since
9192          external (user) functions might reference common areas.  But
9193          even calling an external function, it's worthwhile to decode
9194          COMMON references because if not storing into COMMON, we don't
9195          want COMMON-based arguments to gratuitously force use of a
9196          temporary.  */
9197
9198       *size = TYPE_SIZE (TREE_TYPE (t));
9199
9200       ffecom_tree_canonize_ptr_ (decl, offset,
9201                                  TREE_OPERAND (t, 0));
9202
9203       return;
9204
9205     case CONVERT_EXPR:
9206     case NOP_EXPR:
9207     case MODIFY_EXPR:
9208     case NON_LVALUE_EXPR:
9209     case RESULT_DECL:
9210     case FIELD_DECL:
9211     case COND_EXPR:             /* More cases than we can handle. */
9212     case SAVE_EXPR:
9213     case REFERENCE_EXPR:
9214     case PREDECREMENT_EXPR:
9215     case PREINCREMENT_EXPR:
9216     case POSTDECREMENT_EXPR:
9217     case POSTINCREMENT_EXPR:
9218     case CALL_EXPR:
9219     default:
9220       *decl = error_mark_node;
9221       return;
9222     }
9223 }
9224 #endif
9225
9226 /* Do divide operation appropriate to type of operands.  */
9227
9228 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9229 static tree
9230 ffecom_tree_divide_ (tree tree_type, tree left, tree right,
9231                      tree dest_tree, ffebld dest, bool *dest_used,
9232                      tree hook)
9233 {
9234   if ((left == error_mark_node)
9235       || (right == error_mark_node))
9236     return error_mark_node;
9237
9238   switch (TREE_CODE (tree_type))
9239     {
9240     case INTEGER_TYPE:
9241       return ffecom_2 (TRUNC_DIV_EXPR, tree_type,
9242                        left,
9243                        right);
9244
9245     case COMPLEX_TYPE:
9246       if (! optimize_size)
9247         return ffecom_2 (RDIV_EXPR, tree_type,
9248                          left,
9249                          right);
9250       {
9251         ffecomGfrt ix;
9252
9253         if (TREE_TYPE (tree_type)
9254             == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9255           ix = FFECOM_gfrtDIV_CC;       /* Overlapping result okay. */
9256         else
9257           ix = FFECOM_gfrtDIV_ZZ;       /* Overlapping result okay. */
9258
9259         left = ffecom_1 (ADDR_EXPR,
9260                          build_pointer_type (TREE_TYPE (left)),
9261                          left);
9262         left = build_tree_list (NULL_TREE, left);
9263         right = ffecom_1 (ADDR_EXPR,
9264                           build_pointer_type (TREE_TYPE (right)),
9265                           right);
9266         right = build_tree_list (NULL_TREE, right);
9267         TREE_CHAIN (left) = right;
9268
9269         return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9270                              ffecom_gfrt_kindtype (ix),
9271                              ffe_is_f2c_library (),
9272                              tree_type,
9273                              left,
9274                              dest_tree, dest, dest_used,
9275                              NULL_TREE, TRUE, hook);
9276       }
9277       break;
9278
9279     case RECORD_TYPE:
9280       {
9281         ffecomGfrt ix;
9282
9283         if (TREE_TYPE (TYPE_FIELDS (tree_type))
9284             == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9285           ix = FFECOM_gfrtDIV_CC;       /* Overlapping result okay. */
9286         else
9287           ix = FFECOM_gfrtDIV_ZZ;       /* Overlapping result okay. */
9288
9289         left = ffecom_1 (ADDR_EXPR,
9290                          build_pointer_type (TREE_TYPE (left)),
9291                          left);
9292         left = build_tree_list (NULL_TREE, left);
9293         right = ffecom_1 (ADDR_EXPR,
9294                           build_pointer_type (TREE_TYPE (right)),
9295                           right);
9296         right = build_tree_list (NULL_TREE, right);
9297         TREE_CHAIN (left) = right;
9298
9299         return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9300                              ffecom_gfrt_kindtype (ix),
9301                              ffe_is_f2c_library (),
9302                              tree_type,
9303                              left,
9304                              dest_tree, dest, dest_used,
9305                              NULL_TREE, TRUE, hook);
9306       }
9307       break;
9308
9309     default:
9310       return ffecom_2 (RDIV_EXPR, tree_type,
9311                        left,
9312                        right);
9313     }
9314 }
9315
9316 #endif
9317 /* Build type info for non-dummy variable.  */
9318
9319 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9320 static tree
9321 ffecom_type_localvar_ (ffesymbol s, ffeinfoBasictype bt,
9322                        ffeinfoKindtype kt)
9323 {
9324   tree type;
9325   ffebld dl;
9326   ffebld dim;
9327   tree lowt;
9328   tree hight;
9329
9330   type = ffecom_tree_type[bt][kt];
9331   if (bt == FFEINFO_basictypeCHARACTER)
9332     {
9333       hight = build_int_2 (ffesymbol_size (s), 0);
9334       TREE_TYPE (hight) = ffecom_f2c_ftnlen_type_node;
9335
9336       type
9337         = build_array_type
9338           (type,
9339            build_range_type (ffecom_f2c_ftnlen_type_node,
9340                              ffecom_f2c_ftnlen_one_node,
9341                              hight));
9342       type = ffecom_check_size_overflow_ (s, type, FALSE);
9343     }
9344
9345   for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
9346     {
9347       if (type == error_mark_node)
9348         break;
9349
9350       dim = ffebld_head (dl);
9351       assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
9352
9353       if (ffebld_left (dim) == NULL)
9354         lowt = integer_one_node;
9355       else
9356         lowt = ffecom_expr (ffebld_left (dim));
9357
9358       if (TREE_CODE (lowt) != INTEGER_CST)
9359         lowt = variable_size (lowt);
9360
9361       assert (ffebld_right (dim) != NULL);
9362       hight = ffecom_expr (ffebld_right (dim));
9363
9364       if (TREE_CODE (hight) != INTEGER_CST)
9365         hight = variable_size (hight);
9366
9367       type = build_array_type (type,
9368                                build_range_type (ffecom_integer_type_node,
9369                                                  lowt, hight));
9370       type = ffecom_check_size_overflow_ (s, type, FALSE);
9371     }
9372
9373   return type;
9374 }
9375
9376 #endif
9377 /* Build Namelist type.  */
9378
9379 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9380 static tree
9381 ffecom_type_namelist_ ()
9382 {
9383   static tree type = NULL_TREE;
9384
9385   if (type == NULL_TREE)
9386     {
9387       static tree namefield, varsfield, nvarsfield;
9388       tree vardesctype;
9389
9390       vardesctype = ffecom_type_vardesc_ ();
9391
9392       type = make_node (RECORD_TYPE);
9393
9394       vardesctype = build_pointer_type (build_pointer_type (vardesctype));
9395
9396       namefield = ffecom_decl_field (type, NULL_TREE, "name",
9397                                      string_type_node);
9398       varsfield = ffecom_decl_field (type, namefield, "vars", vardesctype);
9399       nvarsfield = ffecom_decl_field (type, varsfield, "nvars",
9400                                       integer_type_node);
9401
9402       TYPE_FIELDS (type) = namefield;
9403       layout_type (type);
9404
9405       ggc_add_tree_root (&type, 1);
9406     }
9407
9408   return type;
9409 }
9410
9411 #endif
9412
9413 /* Build Vardesc type.  */
9414
9415 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9416 static tree
9417 ffecom_type_vardesc_ ()
9418 {
9419   static tree type = NULL_TREE;
9420   static tree namefield, addrfield, dimsfield, typefield;
9421
9422   if (type == NULL_TREE)
9423     {
9424       type = make_node (RECORD_TYPE);
9425
9426       namefield = ffecom_decl_field (type, NULL_TREE, "name",
9427                                      string_type_node);
9428       addrfield = ffecom_decl_field (type, namefield, "addr",
9429                                      string_type_node);
9430       dimsfield = ffecom_decl_field (type, addrfield, "dims",
9431                                      ffecom_f2c_ptr_to_ftnlen_type_node);
9432       typefield = ffecom_decl_field (type, dimsfield, "type",
9433                                      integer_type_node);
9434
9435       TYPE_FIELDS (type) = namefield;
9436       layout_type (type);
9437
9438       ggc_add_tree_root (&type, 1);
9439     }
9440
9441   return type;
9442 }
9443
9444 #endif
9445
9446 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9447 static tree
9448 ffecom_vardesc_ (ffebld expr)
9449 {
9450   ffesymbol s;
9451
9452   assert (ffebld_op (expr) == FFEBLD_opSYMTER);
9453   s = ffebld_symter (expr);
9454
9455   if (ffesymbol_hook (s).vardesc_tree == NULL_TREE)
9456     {
9457       int i;
9458       tree vardesctype = ffecom_type_vardesc_ ();
9459       tree var;
9460       tree nameinit;
9461       tree dimsinit;
9462       tree addrinit;
9463       tree typeinit;
9464       tree field;
9465       tree varinits;
9466       static int mynumber = 0;
9467
9468       var = build_decl (VAR_DECL,
9469                         ffecom_get_invented_identifier ("__g77_vardesc_%d",
9470                                                         mynumber++),
9471                         vardesctype);
9472       TREE_STATIC (var) = 1;
9473       DECL_INITIAL (var) = error_mark_node;
9474
9475       var = start_decl (var, FALSE);
9476
9477       /* Process inits.  */
9478
9479       nameinit = ffecom_build_f2c_string_ ((i = strlen (ffesymbol_text (s)))
9480                                            + 1,
9481                                            ffesymbol_text (s));
9482       TREE_TYPE (nameinit)
9483         = build_type_variant
9484         (build_array_type
9485          (char_type_node,
9486           build_range_type (integer_type_node,
9487                             integer_one_node,
9488                             build_int_2 (i, 0))),
9489          1, 0);
9490       TREE_CONSTANT (nameinit) = 1;
9491       TREE_STATIC (nameinit) = 1;
9492       nameinit = ffecom_1 (ADDR_EXPR,
9493                            build_pointer_type (TREE_TYPE (nameinit)),
9494                            nameinit);
9495
9496       addrinit = ffecom_arg_ptr_to_expr (expr, &typeinit);
9497
9498       dimsinit = ffecom_vardesc_dims_ (s);
9499
9500       if (typeinit == NULL_TREE)
9501         {
9502           ffeinfoBasictype bt = ffesymbol_basictype (s);
9503           ffeinfoKindtype kt = ffesymbol_kindtype (s);
9504           int tc = ffecom_f2c_typecode (bt, kt);
9505
9506           assert (tc != -1);
9507           typeinit = build_int_2 (tc, (tc < 0) ? -1 : 0);
9508         }
9509       else
9510         typeinit = ffecom_1 (NEGATE_EXPR, TREE_TYPE (typeinit), typeinit);
9511
9512       varinits = build_tree_list ((field = TYPE_FIELDS (vardesctype)),
9513                                   nameinit);
9514       TREE_CHAIN (varinits) = build_tree_list ((field = TREE_CHAIN (field)),
9515                                                addrinit);
9516       TREE_CHAIN (TREE_CHAIN (varinits))
9517         = build_tree_list ((field = TREE_CHAIN (field)), dimsinit);
9518       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (varinits)))
9519         = build_tree_list ((field = TREE_CHAIN (field)), typeinit);
9520
9521       varinits = build (CONSTRUCTOR, vardesctype, NULL_TREE, varinits);
9522       TREE_CONSTANT (varinits) = 1;
9523       TREE_STATIC (varinits) = 1;
9524
9525       finish_decl (var, varinits, FALSE);
9526
9527       var = ffecom_1 (ADDR_EXPR, build_pointer_type (vardesctype), var);
9528
9529       ffesymbol_hook (s).vardesc_tree = var;
9530     }
9531
9532   return ffesymbol_hook (s).vardesc_tree;
9533 }
9534
9535 #endif
9536 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9537 static tree
9538 ffecom_vardesc_array_ (ffesymbol s)
9539 {
9540   ffebld b;
9541   tree list;
9542   tree item = NULL_TREE;
9543   tree var;
9544   int i;
9545   static int mynumber = 0;
9546
9547   for (i = 0, list = NULL_TREE, b = ffesymbol_namelist (s);
9548        b != NULL;
9549        b = ffebld_trail (b), ++i)
9550     {
9551       tree t;
9552
9553       t = ffecom_vardesc_ (ffebld_head (b));
9554
9555       if (list == NULL_TREE)
9556         list = item = build_tree_list (NULL_TREE, t);
9557       else
9558         {
9559           TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9560           item = TREE_CHAIN (item);
9561         }
9562     }
9563
9564   item = build_array_type (build_pointer_type (ffecom_type_vardesc_ ()),
9565                            build_range_type (integer_type_node,
9566                                              integer_one_node,
9567                                              build_int_2 (i, 0)));
9568   list = build (CONSTRUCTOR, item, NULL_TREE, list);
9569   TREE_CONSTANT (list) = 1;
9570   TREE_STATIC (list) = 1;
9571
9572   var = ffecom_get_invented_identifier ("__g77_vardesc_array_%d", mynumber++);
9573   var = build_decl (VAR_DECL, var, item);
9574   TREE_STATIC (var) = 1;
9575   DECL_INITIAL (var) = error_mark_node;
9576   var = start_decl (var, FALSE);
9577   finish_decl (var, list, FALSE);
9578
9579   return var;
9580 }
9581
9582 #endif
9583 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9584 static tree
9585 ffecom_vardesc_dims_ (ffesymbol s)
9586 {
9587   if (ffesymbol_dims (s) == NULL)
9588     return convert (ffecom_f2c_ptr_to_ftnlen_type_node,
9589                     integer_zero_node);
9590
9591   {
9592     ffebld b;
9593     ffebld e;
9594     tree list;
9595     tree backlist;
9596     tree item = NULL_TREE;
9597     tree var;
9598     tree numdim;
9599     tree numelem;
9600     tree baseoff = NULL_TREE;
9601     static int mynumber = 0;
9602
9603     numdim = build_int_2 ((int) ffesymbol_rank (s), 0);
9604     TREE_TYPE (numdim) = ffecom_f2c_ftnlen_type_node;
9605
9606     numelem = ffecom_expr (ffesymbol_arraysize (s));
9607     TREE_TYPE (numelem) = ffecom_f2c_ftnlen_type_node;
9608
9609     list = NULL_TREE;
9610     backlist = NULL_TREE;
9611     for (b = ffesymbol_dims (s), e = ffesymbol_extents (s);
9612          b != NULL;
9613          b = ffebld_trail (b), e = ffebld_trail (e))
9614       {
9615         tree t;
9616         tree low;
9617         tree back;
9618
9619         if (ffebld_trail (b) == NULL)
9620           t = NULL_TREE;
9621         else
9622           {
9623             t = convert (ffecom_f2c_ftnlen_type_node,
9624                          ffecom_expr (ffebld_head (e)));
9625
9626             if (list == NULL_TREE)
9627               list = item = build_tree_list (NULL_TREE, t);
9628             else
9629               {
9630                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9631                 item = TREE_CHAIN (item);
9632               }
9633           }
9634
9635         if (ffebld_left (ffebld_head (b)) == NULL)
9636           low = ffecom_integer_one_node;
9637         else
9638           low = ffecom_expr (ffebld_left (ffebld_head (b)));
9639         low = convert (ffecom_f2c_ftnlen_type_node, low);
9640
9641         back = build_tree_list (low, t);
9642         TREE_CHAIN (back) = backlist;
9643         backlist = back;
9644       }
9645
9646     for (item = backlist; item != NULL_TREE; item = TREE_CHAIN (item))
9647       {
9648         if (TREE_VALUE (item) == NULL_TREE)
9649           baseoff = TREE_PURPOSE (item);
9650         else
9651           baseoff = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
9652                               TREE_PURPOSE (item),
9653                               ffecom_2 (MULT_EXPR,
9654                                         ffecom_f2c_ftnlen_type_node,
9655                                         TREE_VALUE (item),
9656                                         baseoff));
9657       }
9658
9659     /* backlist now dead, along with all TREE_PURPOSEs on it.  */
9660
9661     baseoff = build_tree_list (NULL_TREE, baseoff);
9662     TREE_CHAIN (baseoff) = list;
9663
9664     numelem = build_tree_list (NULL_TREE, numelem);
9665     TREE_CHAIN (numelem) = baseoff;
9666
9667     numdim = build_tree_list (NULL_TREE, numdim);
9668     TREE_CHAIN (numdim) = numelem;
9669
9670     item = build_array_type (ffecom_f2c_ftnlen_type_node,
9671                              build_range_type (integer_type_node,
9672                                                integer_zero_node,
9673                                                build_int_2
9674                                                ((int) ffesymbol_rank (s)
9675                                                 + 2, 0)));
9676     list = build (CONSTRUCTOR, item, NULL_TREE, numdim);
9677     TREE_CONSTANT (list) = 1;
9678     TREE_STATIC (list) = 1;
9679
9680     var = ffecom_get_invented_identifier ("__g77_dims_%d", mynumber++);
9681     var = build_decl (VAR_DECL, var, item);
9682     TREE_STATIC (var) = 1;
9683     DECL_INITIAL (var) = error_mark_node;
9684     var = start_decl (var, FALSE);
9685     finish_decl (var, list, FALSE);
9686
9687     var = ffecom_1 (ADDR_EXPR, build_pointer_type (item), var);
9688
9689     return var;
9690   }
9691 }
9692
9693 #endif
9694 /* Essentially does a "fold (build1 (code, type, node))" while checking
9695    for certain housekeeping things.
9696
9697    NOTE: for building an ADDR_EXPR around a FUNCTION_DECL, use
9698    ffecom_1_fn instead.  */
9699
9700 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9701 tree
9702 ffecom_1 (enum tree_code code, tree type, tree node)
9703 {
9704   tree item;
9705
9706   if ((node == error_mark_node)
9707       || (type == error_mark_node))
9708     return error_mark_node;
9709
9710   if (code == ADDR_EXPR)
9711     {
9712       if (!mark_addressable (node))
9713         assert ("can't mark_addressable this node!" == NULL);
9714     }
9715
9716   switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9717     {
9718       tree realtype;
9719
9720     case REALPART_EXPR:
9721       item = build (COMPONENT_REF, type, node, TYPE_FIELDS (TREE_TYPE (node)));
9722       break;
9723
9724     case IMAGPART_EXPR:
9725       item = build (COMPONENT_REF, type, node, TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (node))));
9726       break;
9727
9728
9729     case NEGATE_EXPR:
9730       if (TREE_CODE (type) != RECORD_TYPE)
9731         {
9732           item = build1 (code, type, node);
9733           break;
9734         }
9735       node = ffecom_stabilize_aggregate_ (node);
9736       realtype = TREE_TYPE (TYPE_FIELDS (type));
9737       item =
9738         ffecom_2 (COMPLEX_EXPR, type,
9739                   ffecom_1 (NEGATE_EXPR, realtype,
9740                             ffecom_1 (REALPART_EXPR, realtype,
9741                                       node)),
9742                   ffecom_1 (NEGATE_EXPR, realtype,
9743                             ffecom_1 (IMAGPART_EXPR, realtype,
9744                                       node)));
9745       break;
9746
9747     default:
9748       item = build1 (code, type, node);
9749       break;
9750     }
9751
9752   if (TREE_SIDE_EFFECTS (node))
9753     TREE_SIDE_EFFECTS (item) = 1;
9754   if ((code == ADDR_EXPR) && staticp (node))
9755     TREE_CONSTANT (item) = 1;
9756   return fold (item);
9757 }
9758 #endif
9759
9760 /* Like ffecom_1 (ADDR_EXPR, TREE_TYPE (node), node), except
9761    handles TREE_CODE (node) == FUNCTION_DECL.  In particular,
9762    does not set TREE_ADDRESSABLE (because calling an inline
9763    function does not mean the function needs to be separately
9764    compiled).  */
9765
9766 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9767 tree
9768 ffecom_1_fn (tree node)
9769 {
9770   tree item;
9771   tree type;
9772
9773   if (node == error_mark_node)
9774     return error_mark_node;
9775
9776   type = build_type_variant (TREE_TYPE (node),
9777                              TREE_READONLY (node),
9778                              TREE_THIS_VOLATILE (node));
9779   item = build1 (ADDR_EXPR,
9780                  build_pointer_type (type), node);
9781   if (TREE_SIDE_EFFECTS (node))
9782     TREE_SIDE_EFFECTS (item) = 1;
9783   if (staticp (node))
9784     TREE_CONSTANT (item) = 1;
9785   return fold (item);
9786 }
9787 #endif
9788
9789 /* Essentially does a "fold (build (code, type, node1, node2))" while
9790    checking for certain housekeeping things.  */
9791
9792 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9793 tree
9794 ffecom_2 (enum tree_code code, tree type, tree node1,
9795           tree node2)
9796 {
9797   tree item;
9798
9799   if ((node1 == error_mark_node)
9800       || (node2 == error_mark_node)
9801       || (type == error_mark_node))
9802     return error_mark_node;
9803
9804   switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9805     {
9806       tree a, b, c, d, realtype;
9807
9808     case CONJ_EXPR:
9809       assert ("no CONJ_EXPR support yet" == NULL);
9810       return error_mark_node;
9811
9812     case COMPLEX_EXPR:
9813       item = build_tree_list (TYPE_FIELDS (type), node1);
9814       TREE_CHAIN (item) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), node2);
9815       item = build (CONSTRUCTOR, type, NULL_TREE, item);
9816       break;
9817
9818     case PLUS_EXPR:
9819       if (TREE_CODE (type) != RECORD_TYPE)
9820         {
9821           item = build (code, type, node1, node2);
9822           break;
9823         }
9824       node1 = ffecom_stabilize_aggregate_ (node1);
9825       node2 = ffecom_stabilize_aggregate_ (node2);
9826       realtype = TREE_TYPE (TYPE_FIELDS (type));
9827       item =
9828         ffecom_2 (COMPLEX_EXPR, type,
9829                   ffecom_2 (PLUS_EXPR, realtype,
9830                             ffecom_1 (REALPART_EXPR, realtype,
9831                                       node1),
9832                             ffecom_1 (REALPART_EXPR, realtype,
9833                                       node2)),
9834                   ffecom_2 (PLUS_EXPR, realtype,
9835                             ffecom_1 (IMAGPART_EXPR, realtype,
9836                                       node1),
9837                             ffecom_1 (IMAGPART_EXPR, realtype,
9838                                       node2)));
9839       break;
9840
9841     case MINUS_EXPR:
9842       if (TREE_CODE (type) != RECORD_TYPE)
9843         {
9844           item = build (code, type, node1, node2);
9845           break;
9846         }
9847       node1 = ffecom_stabilize_aggregate_ (node1);
9848       node2 = ffecom_stabilize_aggregate_ (node2);
9849       realtype = TREE_TYPE (TYPE_FIELDS (type));
9850       item =
9851         ffecom_2 (COMPLEX_EXPR, type,
9852                   ffecom_2 (MINUS_EXPR, realtype,
9853                             ffecom_1 (REALPART_EXPR, realtype,
9854                                       node1),
9855                             ffecom_1 (REALPART_EXPR, realtype,
9856                                       node2)),
9857                   ffecom_2 (MINUS_EXPR, realtype,
9858                             ffecom_1 (IMAGPART_EXPR, realtype,
9859                                       node1),
9860                             ffecom_1 (IMAGPART_EXPR, realtype,
9861                                       node2)));
9862       break;
9863
9864     case MULT_EXPR:
9865       if (TREE_CODE (type) != RECORD_TYPE)
9866         {
9867           item = build (code, type, node1, node2);
9868           break;
9869         }
9870       node1 = ffecom_stabilize_aggregate_ (node1);
9871       node2 = ffecom_stabilize_aggregate_ (node2);
9872       realtype = TREE_TYPE (TYPE_FIELDS (type));
9873       a = save_expr (ffecom_1 (REALPART_EXPR, realtype,
9874                                node1));
9875       b = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
9876                                node1));
9877       c = save_expr (ffecom_1 (REALPART_EXPR, realtype,
9878                                node2));
9879       d = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
9880                                node2));
9881       item =
9882         ffecom_2 (COMPLEX_EXPR, type,
9883                   ffecom_2 (MINUS_EXPR, realtype,
9884                             ffecom_2 (MULT_EXPR, realtype,
9885                                       a,
9886                                       c),
9887                             ffecom_2 (MULT_EXPR, realtype,
9888                                       b,
9889                                       d)),
9890                   ffecom_2 (PLUS_EXPR, realtype,
9891                             ffecom_2 (MULT_EXPR, realtype,
9892                                       a,
9893                                       d),
9894                             ffecom_2 (MULT_EXPR, realtype,
9895                                       c,
9896                                       b)));
9897       break;
9898
9899     case EQ_EXPR:
9900       if ((TREE_CODE (node1) != RECORD_TYPE)
9901           && (TREE_CODE (node2) != RECORD_TYPE))
9902         {
9903           item = build (code, type, node1, node2);
9904           break;
9905         }
9906       assert (TREE_CODE (node1) == RECORD_TYPE);
9907       assert (TREE_CODE (node2) == RECORD_TYPE);
9908       node1 = ffecom_stabilize_aggregate_ (node1);
9909       node2 = ffecom_stabilize_aggregate_ (node2);
9910       realtype = TREE_TYPE (TYPE_FIELDS (type));
9911       item =
9912         ffecom_2 (TRUTH_ANDIF_EXPR, type,
9913                   ffecom_2 (code, type,
9914                             ffecom_1 (REALPART_EXPR, realtype,
9915                                       node1),
9916                             ffecom_1 (REALPART_EXPR, realtype,
9917                                       node2)),
9918                   ffecom_2 (code, type,
9919                             ffecom_1 (IMAGPART_EXPR, realtype,
9920                                       node1),
9921                             ffecom_1 (IMAGPART_EXPR, realtype,
9922                                       node2)));
9923       break;
9924
9925     case NE_EXPR:
9926       if ((TREE_CODE (node1) != RECORD_TYPE)
9927           && (TREE_CODE (node2) != RECORD_TYPE))
9928         {
9929           item = build (code, type, node1, node2);
9930           break;
9931         }
9932       assert (TREE_CODE (node1) == RECORD_TYPE);
9933       assert (TREE_CODE (node2) == RECORD_TYPE);
9934       node1 = ffecom_stabilize_aggregate_ (node1);
9935       node2 = ffecom_stabilize_aggregate_ (node2);
9936       realtype = TREE_TYPE (TYPE_FIELDS (type));
9937       item =
9938         ffecom_2 (TRUTH_ORIF_EXPR, type,
9939                   ffecom_2 (code, type,
9940                             ffecom_1 (REALPART_EXPR, realtype,
9941                                       node1),
9942                             ffecom_1 (REALPART_EXPR, realtype,
9943                                       node2)),
9944                   ffecom_2 (code, type,
9945                             ffecom_1 (IMAGPART_EXPR, realtype,
9946                                       node1),
9947                             ffecom_1 (IMAGPART_EXPR, realtype,
9948                                       node2)));
9949       break;
9950
9951     default:
9952       item = build (code, type, node1, node2);
9953       break;
9954     }
9955
9956   if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2))
9957     TREE_SIDE_EFFECTS (item) = 1;
9958   return fold (item);
9959 }
9960
9961 #endif
9962 /* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint
9963
9964    ffesymbol s;  // the ENTRY point itself
9965    if (ffecom_2pass_advise_entrypoint(s))
9966        // the ENTRY point has been accepted
9967
9968    Does whatever compiler needs to do when it learns about the entrypoint,
9969    like determine the return type of the master function, count the
9970    number of entrypoints, etc.  Returns FALSE if the return type is
9971    not compatible with the return type(s) of other entrypoint(s).
9972
9973    NOTE: for every call to this fn that returns TRUE, _do_entrypoint must
9974    later (after _finish_progunit) be called with the same entrypoint(s)
9975    as passed to this fn for which TRUE was returned.
9976
9977    03-Jan-92  JCB  2.0
9978       Return FALSE if the return type conflicts with previous entrypoints.  */
9979
9980 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9981 bool
9982 ffecom_2pass_advise_entrypoint (ffesymbol entry)
9983 {
9984   ffebld list;                  /* opITEM. */
9985   ffebld mlist;                 /* opITEM. */
9986   ffebld plist;                 /* opITEM. */
9987   ffebld arg;                   /* ffebld_head(opITEM). */
9988   ffebld item;                  /* opITEM. */
9989   ffesymbol s;                  /* ffebld_symter(arg). */
9990   ffeinfoBasictype bt = ffesymbol_basictype (entry);
9991   ffeinfoKindtype kt = ffesymbol_kindtype (entry);
9992   ffetargetCharacterSize size = ffesymbol_size (entry);
9993   bool ok;
9994
9995   if (ffecom_num_entrypoints_ == 0)
9996     {                           /* First entrypoint, make list of main
9997                                    arglist's dummies. */
9998       assert (ffecom_primary_entry_ != NULL);
9999
10000       ffecom_master_bt_ = ffesymbol_basictype (ffecom_primary_entry_);
10001       ffecom_master_kt_ = ffesymbol_kindtype (ffecom_primary_entry_);
10002       ffecom_master_size_ = ffesymbol_size (ffecom_primary_entry_);
10003
10004       for (plist = NULL, list = ffesymbol_dummyargs (ffecom_primary_entry_);
10005            list != NULL;
10006            list = ffebld_trail (list))
10007         {
10008           arg = ffebld_head (list);
10009           if (ffebld_op (arg) != FFEBLD_opSYMTER)
10010             continue;           /* Alternate return or some such thing. */
10011           item = ffebld_new_item (arg, NULL);
10012           if (plist == NULL)
10013             ffecom_master_arglist_ = item;
10014           else
10015             ffebld_set_trail (plist, item);
10016           plist = item;
10017         }
10018     }
10019
10020   /* If necessary, scan entry arglist for alternate returns.  Do this scan
10021      apparently redundantly (it's done below to UNIONize the arglists) so
10022      that we don't complain about RETURN 1 if an offending ENTRY is the only
10023      one with an alternate return.  */
10024
10025   if (!ffecom_is_altreturning_)
10026     {
10027       for (list = ffesymbol_dummyargs (entry);
10028            list != NULL;
10029            list = ffebld_trail (list))
10030         {
10031           arg = ffebld_head (list);
10032           if (ffebld_op (arg) == FFEBLD_opSTAR)
10033             {
10034               ffecom_is_altreturning_ = TRUE;
10035               break;
10036             }
10037         }
10038     }
10039
10040   /* Now check type compatibility. */
10041
10042   switch (ffecom_master_bt_)
10043     {
10044     case FFEINFO_basictypeNONE:
10045       ok = (bt != FFEINFO_basictypeCHARACTER);
10046       break;
10047
10048     case FFEINFO_basictypeCHARACTER:
10049       ok
10050         = (bt == FFEINFO_basictypeCHARACTER)
10051         && (kt == ffecom_master_kt_)
10052         && (size == ffecom_master_size_);
10053       break;
10054
10055     case FFEINFO_basictypeANY:
10056       return FALSE;             /* Just don't bother. */
10057
10058     default:
10059       if (bt == FFEINFO_basictypeCHARACTER)
10060         {
10061           ok = FALSE;
10062           break;
10063         }
10064       ok = TRUE;
10065       if ((bt != ffecom_master_bt_) || (kt != ffecom_master_kt_))
10066         {
10067           ffecom_master_bt_ = FFEINFO_basictypeNONE;
10068           ffecom_master_kt_ = FFEINFO_kindtypeNONE;
10069         }
10070       break;
10071     }
10072
10073   if (!ok)
10074     {
10075       ffebad_start (FFEBAD_ENTRY_CONFLICTS);
10076       ffest_ffebad_here_current_stmt (0);
10077       ffebad_finish ();
10078       return FALSE;             /* Can't handle entrypoint. */
10079     }
10080
10081   /* Entrypoint type compatible with previous types. */
10082
10083   ++ffecom_num_entrypoints_;
10084
10085   /* Master-arg-list = UNION(Master-arg-list,entry-arg-list). */
10086
10087   for (list = ffesymbol_dummyargs (entry);
10088        list != NULL;
10089        list = ffebld_trail (list))
10090     {
10091       arg = ffebld_head (list);
10092       if (ffebld_op (arg) != FFEBLD_opSYMTER)
10093         continue;               /* Alternate return or some such thing. */
10094       s = ffebld_symter (arg);
10095       for (plist = NULL, mlist = ffecom_master_arglist_;
10096            mlist != NULL;
10097            plist = mlist, mlist = ffebld_trail (mlist))
10098         {                       /* plist points to previous item for easy
10099                                    appending of arg. */
10100           if (ffebld_symter (ffebld_head (mlist)) == s)
10101             break;              /* Already have this arg in the master list. */
10102         }
10103       if (mlist != NULL)
10104         continue;               /* Already have this arg in the master list. */
10105
10106       /* Append this arg to the master list. */
10107
10108       item = ffebld_new_item (arg, NULL);
10109       if (plist == NULL)
10110         ffecom_master_arglist_ = item;
10111       else
10112         ffebld_set_trail (plist, item);
10113     }
10114
10115   return TRUE;
10116 }
10117
10118 #endif
10119 /* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint
10120
10121    ffesymbol s;  // the ENTRY point itself
10122    ffecom_2pass_do_entrypoint(s);
10123
10124    Does whatever compiler needs to do to make the entrypoint actually
10125    happen.  Must be called for each entrypoint after
10126    ffecom_finish_progunit is called.  */
10127
10128 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10129 void
10130 ffecom_2pass_do_entrypoint (ffesymbol entry)
10131 {
10132   static int mfn_num = 0;
10133   static int ent_num;
10134
10135   if (mfn_num != ffecom_num_fns_)
10136     {                           /* First entrypoint for this program unit. */
10137       ent_num = 1;
10138       mfn_num = ffecom_num_fns_;
10139       ffecom_do_entry_ (ffecom_primary_entry_, 0);
10140     }
10141   else
10142     ++ent_num;
10143
10144   --ffecom_num_entrypoints_;
10145
10146   ffecom_do_entry_ (entry, ent_num);
10147 }
10148
10149 #endif
10150
10151 /* Essentially does a "fold (build (code, type, node1, node2))" while
10152    checking for certain housekeeping things.  Always sets
10153    TREE_SIDE_EFFECTS.  */
10154
10155 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10156 tree
10157 ffecom_2s (enum tree_code code, tree type, tree node1,
10158            tree node2)
10159 {
10160   tree item;
10161
10162   if ((node1 == error_mark_node)
10163       || (node2 == error_mark_node)
10164       || (type == error_mark_node))
10165     return error_mark_node;
10166
10167   item = build (code, type, node1, node2);
10168   TREE_SIDE_EFFECTS (item) = 1;
10169   return fold (item);
10170 }
10171
10172 #endif
10173 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10174    checking for certain housekeeping things.  */
10175
10176 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10177 tree
10178 ffecom_3 (enum tree_code code, tree type, tree node1,
10179           tree node2, tree node3)
10180 {
10181   tree item;
10182
10183   if ((node1 == error_mark_node)
10184       || (node2 == error_mark_node)
10185       || (node3 == error_mark_node)
10186       || (type == error_mark_node))
10187     return error_mark_node;
10188
10189   item = build (code, type, node1, node2, node3);
10190   if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2)
10191       || (node3 != NULL_TREE && TREE_SIDE_EFFECTS (node3)))
10192     TREE_SIDE_EFFECTS (item) = 1;
10193   return fold (item);
10194 }
10195
10196 #endif
10197 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10198    checking for certain housekeeping things.  Always sets
10199    TREE_SIDE_EFFECTS.  */
10200
10201 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10202 tree
10203 ffecom_3s (enum tree_code code, tree type, tree node1,
10204            tree node2, tree node3)
10205 {
10206   tree item;
10207
10208   if ((node1 == error_mark_node)
10209       || (node2 == error_mark_node)
10210       || (node3 == error_mark_node)
10211       || (type == error_mark_node))
10212     return error_mark_node;
10213
10214   item = build (code, type, node1, node2, node3);
10215   TREE_SIDE_EFFECTS (item) = 1;
10216   return fold (item);
10217 }
10218
10219 #endif
10220
10221 /* ffecom_arg_expr -- Transform argument expr into gcc tree
10222
10223    See use by ffecom_list_expr.
10224
10225    If expression is NULL, returns an integer zero tree.  If it is not
10226    a CHARACTER expression, returns whatever ffecom_expr
10227    returns and sets the length return value to NULL_TREE.  Otherwise
10228    generates code to evaluate the character expression, returns the proper
10229    pointer to the result, but does NOT set the length return value to a tree
10230    that specifies the length of the result.  (In other words, the length
10231    variable is always set to NULL_TREE, because a length is never passed.)
10232
10233    21-Dec-91  JCB  1.1
10234       Don't set returned length, since nobody needs it (yet; someday if
10235       we allow CHARACTER*(*) dummies to statement functions, we'll need
10236       it).  */
10237
10238 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10239 tree
10240 ffecom_arg_expr (ffebld expr, tree *length)
10241 {
10242   tree ign;
10243
10244   *length = NULL_TREE;
10245
10246   if (expr == NULL)
10247     return integer_zero_node;
10248
10249   if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10250     return ffecom_expr (expr);
10251
10252   return ffecom_arg_ptr_to_expr (expr, &ign);
10253 }
10254
10255 #endif
10256 /* Transform expression into constant argument-pointer-to-expression tree.
10257
10258    If the expression can be transformed into a argument-pointer-to-expression
10259    tree that is constant, that is done, and the tree returned.  Else
10260    NULL_TREE is returned.
10261
10262    That way, a caller can attempt to provide compile-time initialization
10263    of a variable and, if that fails, *then* choose to start a new block
10264    and resort to using temporaries, as appropriate.  */
10265
10266 tree
10267 ffecom_arg_ptr_to_const_expr (ffebld expr, tree *length)
10268 {
10269   if (! expr)
10270     return integer_zero_node;
10271
10272   if (ffebld_op (expr) == FFEBLD_opANY)
10273     {
10274       if (length)
10275         *length = error_mark_node;
10276       return error_mark_node;
10277     }
10278
10279   if (ffebld_arity (expr) == 0
10280       && (ffebld_op (expr) != FFEBLD_opSYMTER
10281           || ffebld_where (expr) == FFEINFO_whereCOMMON
10282           || ffebld_where (expr) == FFEINFO_whereGLOBAL
10283           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10284     {
10285       tree t;
10286
10287       t = ffecom_arg_ptr_to_expr (expr, length);
10288       assert (TREE_CONSTANT (t));
10289       assert (! length || TREE_CONSTANT (*length));
10290       return t;
10291     }
10292
10293   if (length
10294       && ffebld_size (expr) != FFETARGET_charactersizeNONE)
10295     *length = build_int_2 (ffebld_size (expr), 0);
10296   else if (length)
10297     *length = NULL_TREE;
10298   return NULL_TREE;
10299 }
10300
10301 /* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree
10302
10303    See use by ffecom_list_ptr_to_expr.
10304
10305    If expression is NULL, returns an integer zero tree.  If it is not
10306    a CHARACTER expression, returns whatever ffecom_ptr_to_expr
10307    returns and sets the length return value to NULL_TREE.  Otherwise
10308    generates code to evaluate the character expression, returns the proper
10309    pointer to the result, AND sets the length return value to a tree that
10310    specifies the length of the result.
10311
10312    If the length argument is NULL, this is a slightly special
10313    case of building a FORMAT expression, that is, an expression that
10314    will be used at run time without regard to length.  For the current
10315    implementation, which uses the libf2c library, this means it is nice
10316    to append a null byte to the end of the expression, where feasible,
10317    to make sure any diagnostic about the FORMAT string terminates at
10318    some useful point.
10319
10320    For now, treat %REF(char-expr) as the same as char-expr with a NULL
10321    length argument.  This might even be seen as a feature, if a null
10322    byte can always be appended.  */
10323
10324 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10325 tree
10326 ffecom_arg_ptr_to_expr (ffebld expr, tree *length)
10327 {
10328   tree item;
10329   tree ign_length;
10330   ffecomConcatList_ catlist;
10331
10332   if (length != NULL)
10333     *length = NULL_TREE;
10334
10335   if (expr == NULL)
10336     return integer_zero_node;
10337
10338   switch (ffebld_op (expr))
10339     {
10340     case FFEBLD_opPERCENT_VAL:
10341       if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10342         return ffecom_expr (ffebld_left (expr));
10343       {
10344         tree temp_exp;
10345         tree temp_length;
10346
10347         temp_exp = ffecom_arg_ptr_to_expr (ffebld_left (expr), &temp_length);
10348         if (temp_exp == error_mark_node)
10349           return error_mark_node;
10350
10351         return ffecom_1 (INDIRECT_REF, TREE_TYPE (TREE_TYPE (temp_exp)),
10352                          temp_exp);
10353       }
10354
10355     case FFEBLD_opPERCENT_REF:
10356       if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10357         return ffecom_ptr_to_expr (ffebld_left (expr));
10358       if (length != NULL)
10359         {
10360           ign_length = NULL_TREE;
10361           length = &ign_length;
10362         }
10363       expr = ffebld_left (expr);
10364       break;
10365
10366     case FFEBLD_opPERCENT_DESCR:
10367       switch (ffeinfo_basictype (ffebld_info (expr)))
10368         {
10369 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10370         case FFEINFO_basictypeHOLLERITH:
10371 #endif
10372         case FFEINFO_basictypeCHARACTER:
10373           break;                /* Passed by descriptor anyway. */
10374
10375         default:
10376           item = ffecom_ptr_to_expr (expr);
10377           if (item != error_mark_node)
10378             *length = TYPE_SIZE (TREE_TYPE (TREE_TYPE (item)));
10379           break;
10380         }
10381       break;
10382
10383     default:
10384       break;
10385     }
10386
10387 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10388   if ((ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeHOLLERITH)
10389       && (length != NULL))
10390     {                           /* Pass Hollerith by descriptor. */
10391       ffetargetHollerith h;
10392
10393       assert (ffebld_op (expr) == FFEBLD_opCONTER);
10394       h = ffebld_cu_val_hollerith (ffebld_constant_union
10395                                    (ffebld_conter (expr)));
10396       *length
10397         = build_int_2 (h.length, 0);
10398       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10399     }
10400 #endif
10401
10402   if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10403     return ffecom_ptr_to_expr (expr);
10404
10405   assert (ffeinfo_kindtype (ffebld_info (expr))
10406           == FFEINFO_kindtypeCHARACTER1);
10407
10408   while (ffebld_op (expr) == FFEBLD_opPAREN)
10409     expr = ffebld_left (expr);
10410
10411   catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
10412   switch (ffecom_concat_list_count_ (catlist))
10413     {
10414     case 0:                     /* Shouldn't happen, but in case it does... */
10415       if (length != NULL)
10416         {
10417           *length = ffecom_f2c_ftnlen_zero_node;
10418           TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10419         }
10420       ffecom_concat_list_kill_ (catlist);
10421       return null_pointer_node;
10422
10423     case 1:                     /* The (fairly) easy case. */
10424       if (length == NULL)
10425         ffecom_char_args_with_null_ (&item, &ign_length,
10426                                      ffecom_concat_list_expr_ (catlist, 0));
10427       else
10428         ffecom_char_args_ (&item, length,
10429                            ffecom_concat_list_expr_ (catlist, 0));
10430       ffecom_concat_list_kill_ (catlist);
10431       assert (item != NULL_TREE);
10432       return item;
10433
10434     default:                    /* Must actually concatenate things. */
10435       break;
10436     }
10437
10438   {
10439     int count = ffecom_concat_list_count_ (catlist);
10440     int i;
10441     tree lengths;
10442     tree items;
10443     tree length_array;
10444     tree item_array;
10445     tree citem;
10446     tree clength;
10447     tree temporary;
10448     tree num;
10449     tree known_length;
10450     ffetargetCharacterSize sz;
10451
10452     sz = ffecom_concat_list_maxlen_ (catlist);
10453     /* ~~Kludge! */
10454     assert (sz != FFETARGET_charactersizeNONE);
10455
10456 #ifdef HOHO
10457     length_array
10458       = lengths
10459       = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
10460                              FFETARGET_charactersizeNONE, count, TRUE);
10461     item_array
10462       = items
10463       = ffecom_push_tempvar (ffecom_f2c_address_type_node,
10464                              FFETARGET_charactersizeNONE, count, TRUE);
10465     temporary = ffecom_push_tempvar (char_type_node,
10466                                      sz, -1, TRUE);
10467 #else
10468     {
10469       tree hook;
10470
10471       hook = ffebld_nonter_hook (expr);
10472       assert (hook);
10473       assert (TREE_CODE (hook) == TREE_VEC);
10474       assert (TREE_VEC_LENGTH (hook) == 3);
10475       length_array = lengths = TREE_VEC_ELT (hook, 0);
10476       item_array = items = TREE_VEC_ELT (hook, 1);
10477       temporary = TREE_VEC_ELT (hook, 2);
10478     }
10479 #endif
10480
10481     known_length = ffecom_f2c_ftnlen_zero_node;
10482
10483     for (i = 0; i < count; ++i)
10484       {
10485         if ((i == count)
10486             && (length == NULL))
10487           ffecom_char_args_with_null_ (&citem, &clength,
10488                                        ffecom_concat_list_expr_ (catlist, i));
10489         else
10490           ffecom_char_args_ (&citem, &clength,
10491                              ffecom_concat_list_expr_ (catlist, i));
10492         if ((citem == error_mark_node)
10493             || (clength == error_mark_node))
10494           {
10495             ffecom_concat_list_kill_ (catlist);
10496             *length = error_mark_node;
10497             return error_mark_node;
10498           }
10499
10500         items
10501           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
10502                       ffecom_modify (void_type_node,
10503                                      ffecom_2 (ARRAY_REF,
10504                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
10505                                                item_array,
10506                                                build_int_2 (i, 0)),
10507                                      citem),
10508                       items);
10509         clength = ffecom_save_tree (clength);
10510         if (length != NULL)
10511           known_length
10512             = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
10513                         known_length,
10514                         clength);
10515         lengths
10516           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
10517                       ffecom_modify (void_type_node,
10518                                      ffecom_2 (ARRAY_REF,
10519                    TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
10520                                                length_array,
10521                                                build_int_2 (i, 0)),
10522                                      clength),
10523                       lengths);
10524       }
10525
10526     temporary = ffecom_1 (ADDR_EXPR,
10527                           build_pointer_type (TREE_TYPE (temporary)),
10528                           temporary);
10529
10530     item = build_tree_list (NULL_TREE, temporary);
10531     TREE_CHAIN (item)
10532       = build_tree_list (NULL_TREE,
10533                          ffecom_1 (ADDR_EXPR,
10534                                    build_pointer_type (TREE_TYPE (items)),
10535                                    items));
10536     TREE_CHAIN (TREE_CHAIN (item))
10537       = build_tree_list (NULL_TREE,
10538                          ffecom_1 (ADDR_EXPR,
10539                                    build_pointer_type (TREE_TYPE (lengths)),
10540                                    lengths));
10541     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
10542       = build_tree_list
10543         (NULL_TREE,
10544          ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
10545                    convert (ffecom_f2c_ftnlen_type_node,
10546                             build_int_2 (count, 0))));
10547     num = build_int_2 (sz, 0);
10548     TREE_TYPE (num) = ffecom_f2c_ftnlen_type_node;
10549     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item))))
10550       = build_tree_list (NULL_TREE, num);
10551
10552     item = ffecom_call_gfrt (FFECOM_gfrtCAT, item, NULL_TREE);
10553     TREE_SIDE_EFFECTS (item) = 1;
10554     item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (temporary),
10555                      item,
10556                      temporary);
10557
10558     if (length != NULL)
10559       *length = known_length;
10560   }
10561
10562   ffecom_concat_list_kill_ (catlist);
10563   assert (item != NULL_TREE);
10564   return item;
10565 }
10566
10567 #endif
10568 /* Generate call to run-time function.
10569
10570    The first arg is the GNU Fortran Run-Time function index, the second
10571    arg is the list of arguments to pass to it.  Returned is the expression
10572    (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the
10573    result (which may be void).  */
10574
10575 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10576 tree
10577 ffecom_call_gfrt (ffecomGfrt ix, tree args, tree hook)
10578 {
10579   return ffecom_call_ (ffecom_gfrt_tree_ (ix),
10580                        ffecom_gfrt_kindtype (ix),
10581                        ffe_is_f2c_library () && ffecom_gfrt_complex_[ix],
10582                        NULL_TREE, args, NULL_TREE, NULL,
10583                        NULL, NULL_TREE, TRUE, hook);
10584 }
10585 #endif
10586
10587 /* Transform constant-union to tree.  */
10588
10589 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10590 tree
10591 ffecom_constantunion (ffebldConstantUnion *cu, ffeinfoBasictype bt,
10592                       ffeinfoKindtype kt, tree tree_type)
10593 {
10594   tree item;
10595
10596   switch (bt)
10597     {
10598     case FFEINFO_basictypeINTEGER:
10599       {
10600         int val;
10601
10602         switch (kt)
10603           {
10604 #if FFETARGET_okINTEGER1
10605           case FFEINFO_kindtypeINTEGER1:
10606             val = ffebld_cu_val_integer1 (*cu);
10607             break;
10608 #endif
10609
10610 #if FFETARGET_okINTEGER2
10611           case FFEINFO_kindtypeINTEGER2:
10612             val = ffebld_cu_val_integer2 (*cu);
10613             break;
10614 #endif
10615
10616 #if FFETARGET_okINTEGER3
10617           case FFEINFO_kindtypeINTEGER3:
10618             val = ffebld_cu_val_integer3 (*cu);
10619             break;
10620 #endif
10621
10622 #if FFETARGET_okINTEGER4
10623           case FFEINFO_kindtypeINTEGER4:
10624             val = ffebld_cu_val_integer4 (*cu);
10625             break;
10626 #endif
10627
10628           default:
10629             assert ("bad INTEGER constant kind type" == NULL);
10630             /* Fall through. */
10631           case FFEINFO_kindtypeANY:
10632             return error_mark_node;
10633           }
10634         item = build_int_2 (val, (val < 0) ? -1 : 0);
10635         TREE_TYPE (item) = tree_type;
10636       }
10637       break;
10638
10639     case FFEINFO_basictypeLOGICAL:
10640       {
10641         int val;
10642
10643         switch (kt)
10644           {
10645 #if FFETARGET_okLOGICAL1
10646           case FFEINFO_kindtypeLOGICAL1:
10647             val = ffebld_cu_val_logical1 (*cu);
10648             break;
10649 #endif
10650
10651 #if FFETARGET_okLOGICAL2
10652           case FFEINFO_kindtypeLOGICAL2:
10653             val = ffebld_cu_val_logical2 (*cu);
10654             break;
10655 #endif
10656
10657 #if FFETARGET_okLOGICAL3
10658           case FFEINFO_kindtypeLOGICAL3:
10659             val = ffebld_cu_val_logical3 (*cu);
10660             break;
10661 #endif
10662
10663 #if FFETARGET_okLOGICAL4
10664           case FFEINFO_kindtypeLOGICAL4:
10665             val = ffebld_cu_val_logical4 (*cu);
10666             break;
10667 #endif
10668
10669           default:
10670             assert ("bad LOGICAL constant kind type" == NULL);
10671             /* Fall through. */
10672           case FFEINFO_kindtypeANY:
10673             return error_mark_node;
10674           }
10675         item = build_int_2 (val, (val < 0) ? -1 : 0);
10676         TREE_TYPE (item) = tree_type;
10677       }
10678       break;
10679
10680     case FFEINFO_basictypeREAL:
10681       {
10682         REAL_VALUE_TYPE val;
10683
10684         switch (kt)
10685           {
10686 #if FFETARGET_okREAL1
10687           case FFEINFO_kindtypeREAL1:
10688             val = ffetarget_value_real1 (ffebld_cu_val_real1 (*cu));
10689             break;
10690 #endif
10691
10692 #if FFETARGET_okREAL2
10693           case FFEINFO_kindtypeREAL2:
10694             val = ffetarget_value_real2 (ffebld_cu_val_real2 (*cu));
10695             break;
10696 #endif
10697
10698 #if FFETARGET_okREAL3
10699           case FFEINFO_kindtypeREAL3:
10700             val = ffetarget_value_real3 (ffebld_cu_val_real3 (*cu));
10701             break;
10702 #endif
10703
10704 #if FFETARGET_okREAL4
10705           case FFEINFO_kindtypeREAL4:
10706             val = ffetarget_value_real4 (ffebld_cu_val_real4 (*cu));
10707             break;
10708 #endif
10709
10710           default:
10711             assert ("bad REAL constant kind type" == NULL);
10712             /* Fall through. */
10713           case FFEINFO_kindtypeANY:
10714             return error_mark_node;
10715           }
10716         item = build_real (tree_type, val);
10717       }
10718       break;
10719
10720     case FFEINFO_basictypeCOMPLEX:
10721       {
10722         REAL_VALUE_TYPE real;
10723         REAL_VALUE_TYPE imag;
10724         tree el_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
10725
10726         switch (kt)
10727           {
10728 #if FFETARGET_okCOMPLEX1
10729           case FFEINFO_kindtypeREAL1:
10730             real = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).real);
10731             imag = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).imaginary);
10732             break;
10733 #endif
10734
10735 #if FFETARGET_okCOMPLEX2
10736           case FFEINFO_kindtypeREAL2:
10737             real = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).real);
10738             imag = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).imaginary);
10739             break;
10740 #endif
10741
10742 #if FFETARGET_okCOMPLEX3
10743           case FFEINFO_kindtypeREAL3:
10744             real = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).real);
10745             imag = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).imaginary);
10746             break;
10747 #endif
10748
10749 #if FFETARGET_okCOMPLEX4
10750           case FFEINFO_kindtypeREAL4:
10751             real = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).real);
10752             imag = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).imaginary);
10753             break;
10754 #endif
10755
10756           default:
10757             assert ("bad REAL constant kind type" == NULL);
10758             /* Fall through. */
10759           case FFEINFO_kindtypeANY:
10760             return error_mark_node;
10761           }
10762         item = ffecom_build_complex_constant_ (tree_type,
10763                                                build_real (el_type, real),
10764                                                build_real (el_type, imag));
10765       }
10766       break;
10767
10768     case FFEINFO_basictypeCHARACTER:
10769       {                         /* Happens only in DATA and similar contexts. */
10770         ffetargetCharacter1 val;
10771
10772         switch (kt)
10773           {
10774 #if FFETARGET_okCHARACTER1
10775           case FFEINFO_kindtypeLOGICAL1:
10776             val = ffebld_cu_val_character1 (*cu);
10777             break;
10778 #endif
10779
10780           default:
10781             assert ("bad CHARACTER constant kind type" == NULL);
10782             /* Fall through. */
10783           case FFEINFO_kindtypeANY:
10784             return error_mark_node;
10785           }
10786         item = build_string (ffetarget_length_character1 (val),
10787                              ffetarget_text_character1 (val));
10788         TREE_TYPE (item)
10789           = build_type_variant (build_array_type (char_type_node,
10790                                                   build_range_type
10791                                                   (integer_type_node,
10792                                                    integer_one_node,
10793                                                    build_int_2
10794                                                 (ffetarget_length_character1
10795                                                  (val), 0))),
10796                                 1, 0);
10797       }
10798       break;
10799
10800     case FFEINFO_basictypeHOLLERITH:
10801       {
10802         ffetargetHollerith h;
10803
10804         h = ffebld_cu_val_hollerith (*cu);
10805
10806         /* If not at least as wide as default INTEGER, widen it.  */
10807         if (h.length >= FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE)
10808           item = build_string (h.length, h.text);
10809         else
10810           {
10811             char str[FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE];
10812
10813             memcpy (str, h.text, h.length);
10814             memset (&str[h.length], ' ',
10815                     FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE
10816                     - h.length);
10817             item = build_string (FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE,
10818                                  str);
10819           }
10820         TREE_TYPE (item)
10821           = build_type_variant (build_array_type (char_type_node,
10822                                                   build_range_type
10823                                                   (integer_type_node,
10824                                                    integer_one_node,
10825                                                    build_int_2
10826                                                    (h.length, 0))),
10827                                 1, 0);
10828       }
10829       break;
10830
10831     case FFEINFO_basictypeTYPELESS:
10832       {
10833         ffetargetInteger1 ival;
10834         ffetargetTypeless tless;
10835         ffebad error;
10836
10837         tless = ffebld_cu_val_typeless (*cu);
10838         error = ffetarget_convert_integer1_typeless (&ival, tless);
10839         assert (error == FFEBAD);
10840
10841         item = build_int_2 ((int) ival, 0);
10842       }
10843       break;
10844
10845     default:
10846       assert ("not yet on constant type" == NULL);
10847       /* Fall through. */
10848     case FFEINFO_basictypeANY:
10849       return error_mark_node;
10850     }
10851
10852   TREE_CONSTANT (item) = 1;
10853
10854   return item;
10855 }
10856
10857 #endif
10858
10859 /* Transform expression into constant tree.
10860
10861    If the expression can be transformed into a tree that is constant,
10862    that is done, and the tree returned.  Else NULL_TREE is returned.
10863
10864    That way, a caller can attempt to provide compile-time initialization
10865    of a variable and, if that fails, *then* choose to start a new block
10866    and resort to using temporaries, as appropriate.  */
10867
10868 tree
10869 ffecom_const_expr (ffebld expr)
10870 {
10871   if (! expr)
10872     return integer_zero_node;
10873
10874   if (ffebld_op (expr) == FFEBLD_opANY)
10875     return error_mark_node;
10876
10877   if (ffebld_arity (expr) == 0
10878       && (ffebld_op (expr) != FFEBLD_opSYMTER
10879 #if NEWCOMMON
10880           /* ~~Enable once common/equivalence is handled properly?  */
10881           || ffebld_where (expr) == FFEINFO_whereCOMMON
10882 #endif
10883           || ffebld_where (expr) == FFEINFO_whereGLOBAL
10884           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10885     {
10886       tree t;
10887
10888       t = ffecom_expr (expr);
10889       assert (TREE_CONSTANT (t));
10890       return t;
10891     }
10892
10893   return NULL_TREE;
10894 }
10895
10896 /* Handy way to make a field in a struct/union.  */
10897
10898 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10899 tree
10900 ffecom_decl_field (tree context, tree prevfield,
10901                    const char *name, tree type)
10902 {
10903   tree field;
10904
10905   field = build_decl (FIELD_DECL, get_identifier (name), type);
10906   DECL_CONTEXT (field) = context;
10907   DECL_ALIGN (field) = 0;
10908   DECL_USER_ALIGN (field) = 0;
10909   if (prevfield != NULL_TREE)
10910     TREE_CHAIN (prevfield) = field;
10911
10912   return field;
10913 }
10914
10915 #endif
10916
10917 void
10918 ffecom_close_include (FILE *f)
10919 {
10920 #if FFECOM_GCC_INCLUDE
10921   ffecom_close_include_ (f);
10922 #endif
10923 }
10924
10925 int
10926 ffecom_decode_include_option (char *spec)
10927 {
10928 #if FFECOM_GCC_INCLUDE
10929   return ffecom_decode_include_option_ (spec);
10930 #else
10931   return 1;
10932 #endif
10933 }
10934
10935 /* End a compound statement (block).  */
10936
10937 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10938 tree
10939 ffecom_end_compstmt (void)
10940 {
10941   return bison_rule_compstmt_ ();
10942 }
10943 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
10944
10945 /* ffecom_end_transition -- Perform end transition on all symbols
10946
10947    ffecom_end_transition();
10948
10949    Calls ffecom_sym_end_transition for each global and local symbol.  */
10950
10951 void
10952 ffecom_end_transition ()
10953 {
10954 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10955   ffebld item;
10956 #endif
10957
10958   if (ffe_is_ffedebug ())
10959     fprintf (dmpout, "; end_stmt_transition\n");
10960
10961 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10962   ffecom_list_blockdata_ = NULL;
10963   ffecom_list_common_ = NULL;
10964 #endif
10965
10966   ffesymbol_drive (ffecom_sym_end_transition);
10967   if (ffe_is_ffedebug ())
10968     {
10969       ffestorag_report ();
10970 #if FFECOM_targetCURRENT == FFECOM_targetFFE
10971       ffesymbol_report_all ();
10972 #endif
10973     }
10974
10975 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10976   ffecom_start_progunit_ ();
10977
10978   for (item = ffecom_list_blockdata_;
10979        item != NULL;
10980        item = ffebld_trail (item))
10981     {
10982       ffebld callee;
10983       ffesymbol s;
10984       tree dt;
10985       tree t;
10986       tree var;
10987       static int number = 0;
10988
10989       callee = ffebld_head (item);
10990       s = ffebld_symter (callee);
10991       t = ffesymbol_hook (s).decl_tree;
10992       if (t == NULL_TREE)
10993         {
10994           s = ffecom_sym_transform_ (s);
10995           t = ffesymbol_hook (s).decl_tree;
10996         }
10997
10998       dt = build_pointer_type (TREE_TYPE (t));
10999
11000       var = build_decl (VAR_DECL,
11001                         ffecom_get_invented_identifier ("__g77_forceload_%d",
11002                                                         number++),
11003                         dt);
11004       DECL_EXTERNAL (var) = 0;
11005       TREE_STATIC (var) = 1;
11006       TREE_PUBLIC (var) = 0;
11007       DECL_INITIAL (var) = error_mark_node;
11008       TREE_USED (var) = 1;
11009
11010       var = start_decl (var, FALSE);
11011
11012       t = ffecom_1 (ADDR_EXPR, dt, t);
11013
11014       finish_decl (var, t, FALSE);
11015     }
11016
11017   /* This handles any COMMON areas that weren't referenced but have, for
11018      example, important initial data.  */
11019
11020   for (item = ffecom_list_common_;
11021        item != NULL;
11022        item = ffebld_trail (item))
11023     ffecom_transform_common_ (ffebld_symter (ffebld_head (item)));
11024
11025   ffecom_list_common_ = NULL;
11026 #endif
11027 }
11028
11029 /* ffecom_exec_transition -- Perform exec transition on all symbols
11030
11031    ffecom_exec_transition();
11032
11033    Calls ffecom_sym_exec_transition for each global and local symbol.
11034    Make sure error updating not inhibited.  */
11035
11036 void
11037 ffecom_exec_transition ()
11038 {
11039   bool inhibited;
11040
11041   if (ffe_is_ffedebug ())
11042     fprintf (dmpout, "; exec_stmt_transition\n");
11043
11044   inhibited = ffebad_inhibit ();
11045   ffebad_set_inhibit (FALSE);
11046
11047   ffesymbol_drive (ffecom_sym_exec_transition); /* Don't retract! */
11048   ffeequiv_exec_transition ();  /* Handle all pending EQUIVALENCEs. */
11049   if (ffe_is_ffedebug ())
11050     {
11051       ffestorag_report ();
11052 #if FFECOM_targetCURRENT == FFECOM_targetFFE
11053       ffesymbol_report_all ();
11054 #endif
11055     }
11056
11057   if (inhibited)
11058     ffebad_set_inhibit (TRUE);
11059 }
11060
11061 /* Handle assignment statement.
11062
11063    Convert dest and source using ffecom_expr, then join them
11064    with an ASSIGN op and pass the whole thing to expand_expr_stmt.  */
11065
11066 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11067 void
11068 ffecom_expand_let_stmt (ffebld dest, ffebld source)
11069 {
11070   tree dest_tree;
11071   tree dest_length;
11072   tree source_tree;
11073   tree expr_tree;
11074
11075   if (ffeinfo_basictype (ffebld_info (dest)) != FFEINFO_basictypeCHARACTER)
11076     {
11077       bool dest_used;
11078       tree assign_temp;
11079
11080       /* This attempts to replicate the test below, but must not be
11081          true when the test below is false.  (Always err on the side
11082          of creating unused temporaries, to avoid ICEs.)  */
11083       if (ffebld_op (dest) != FFEBLD_opSYMTER
11084           || ((dest_tree = ffesymbol_hook (ffebld_symter (dest)).decl_tree)
11085               && (TREE_CODE (dest_tree) != VAR_DECL
11086                   || TREE_ADDRESSABLE (dest_tree))))
11087         {
11088           ffecom_prepare_expr_ (source, dest);
11089           dest_used = TRUE;
11090         }
11091       else
11092         {
11093           ffecom_prepare_expr_ (source, NULL);
11094           dest_used = FALSE;
11095         }
11096
11097       ffecom_prepare_expr_w (NULL_TREE, dest);
11098
11099       /* For COMPLEX assignment like C1=C2, if partial overlap is possible,
11100          create a temporary through which the assignment is to take place,
11101          since MODIFY_EXPR doesn't handle partial overlap properly.  */
11102       if (ffebld_basictype (dest) == FFEINFO_basictypeCOMPLEX
11103           && ffecom_possible_partial_overlap_ (dest, source))
11104         {
11105           assign_temp = ffecom_make_tempvar ("complex_let",
11106                                              ffecom_tree_type
11107                                              [ffebld_basictype (dest)]
11108                                              [ffebld_kindtype (dest)],
11109                                              FFETARGET_charactersizeNONE,
11110                                              -1);
11111         }
11112       else
11113         assign_temp = NULL_TREE;
11114
11115       ffecom_prepare_end ();
11116
11117       dest_tree = ffecom_expr_w (NULL_TREE, dest);
11118       if (dest_tree == error_mark_node)
11119         return;
11120
11121       if ((TREE_CODE (dest_tree) != VAR_DECL)
11122           || TREE_ADDRESSABLE (dest_tree))
11123         source_tree = ffecom_expr_ (source, dest_tree, dest, &dest_used,
11124                                     FALSE, FALSE);
11125       else
11126         {
11127           assert (! dest_used);
11128           dest_used = FALSE;
11129           source_tree = ffecom_expr (source);
11130         }
11131       if (source_tree == error_mark_node)
11132         return;
11133
11134       if (dest_used)
11135         expr_tree = source_tree;
11136       else if (assign_temp)
11137         {
11138 #ifdef MOVE_EXPR
11139           /* The back end understands a conceptual move (evaluate source;
11140              store into dest), so use that, in case it can determine
11141              that it is going to use, say, two registers as temporaries
11142              anyway.  So don't use the temp (and someday avoid generating
11143              it, once this code starts triggering regularly).  */
11144           expr_tree = ffecom_2s (MOVE_EXPR, void_type_node,
11145                                  dest_tree,
11146                                  source_tree);
11147 #else
11148           expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
11149                                  assign_temp,
11150                                  source_tree);
11151           expand_expr_stmt (expr_tree);
11152           expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
11153                                  dest_tree,
11154                                  assign_temp);
11155 #endif
11156         }
11157       else
11158         expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
11159                                dest_tree,
11160                                source_tree);
11161
11162       expand_expr_stmt (expr_tree);
11163       return;
11164     }
11165
11166   ffecom_prepare_let_char_ (ffebld_size_known (dest), source);
11167   ffecom_prepare_expr_w (NULL_TREE, dest);
11168
11169   ffecom_prepare_end ();
11170
11171   ffecom_char_args_ (&dest_tree, &dest_length, dest);
11172   ffecom_let_char_ (dest_tree, dest_length, ffebld_size_known (dest),
11173                     source);
11174 }
11175
11176 #endif
11177 /* ffecom_expr -- Transform expr into gcc tree
11178
11179    tree t;
11180    ffebld expr;  // FFE expression.
11181    tree = ffecom_expr(expr);
11182
11183    Recursive descent on expr while making corresponding tree nodes and
11184    attaching type info and such.  */
11185
11186 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11187 tree
11188 ffecom_expr (ffebld expr)
11189 {
11190   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, FALSE, FALSE);
11191 }
11192
11193 #endif
11194 /* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT.  */
11195
11196 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11197 tree
11198 ffecom_expr_assign (ffebld expr)
11199 {
11200   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
11201 }
11202
11203 #endif
11204 /* Like ffecom_expr_rw, but return tree usable for ASSIGN.  */
11205
11206 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11207 tree
11208 ffecom_expr_assign_w (ffebld expr)
11209 {
11210   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
11211 }
11212
11213 #endif
11214 /* Transform expr for use as into read/write tree and stabilize the
11215    reference.  Not for use on CHARACTER expressions.
11216
11217    Recursive descent on expr while making corresponding tree nodes and
11218    attaching type info and such.  */
11219
11220 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11221 tree
11222 ffecom_expr_rw (tree type, ffebld expr)
11223 {
11224   assert (expr != NULL);
11225   /* Different target types not yet supported.  */
11226   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
11227
11228   return stabilize_reference (ffecom_expr (expr));
11229 }
11230
11231 #endif
11232 /* Transform expr for use as into write tree and stabilize the
11233    reference.  Not for use on CHARACTER expressions.
11234
11235    Recursive descent on expr while making corresponding tree nodes and
11236    attaching type info and such.  */
11237
11238 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11239 tree
11240 ffecom_expr_w (tree type, ffebld expr)
11241 {
11242   assert (expr != NULL);
11243   /* Different target types not yet supported.  */
11244   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
11245
11246   return stabilize_reference (ffecom_expr (expr));
11247 }
11248
11249 #endif
11250 /* Do global stuff.  */
11251
11252 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11253 void
11254 ffecom_finish_compile ()
11255 {
11256   assert (ffecom_outer_function_decl_ == NULL_TREE);
11257   assert (current_function_decl == NULL_TREE);
11258
11259   ffeglobal_drive (ffecom_finish_global_);
11260 }
11261
11262 #endif
11263 /* Public entry point for front end to access finish_decl.  */
11264
11265 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11266 void
11267 ffecom_finish_decl (tree decl, tree init, bool is_top_level)
11268 {
11269   assert (!is_top_level);
11270   finish_decl (decl, init, FALSE);
11271 }
11272
11273 #endif
11274 /* Finish a program unit.  */
11275
11276 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11277 void
11278 ffecom_finish_progunit ()
11279 {
11280   ffecom_end_compstmt ();
11281
11282   ffecom_previous_function_decl_ = current_function_decl;
11283   ffecom_which_entrypoint_decl_ = NULL_TREE;
11284
11285   finish_function (0);
11286 }
11287
11288 #endif
11289
11290 /* Wrapper for get_identifier.  pattern is sprintf-like.  */
11291
11292 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11293 tree
11294 ffecom_get_invented_identifier (const char *pattern, ...)
11295 {
11296   tree decl;
11297   char *nam;
11298   va_list ap;
11299
11300   va_start (ap, pattern);
11301   if (vasprintf (&nam, pattern, ap) == 0)
11302     abort ();
11303   va_end (ap);
11304   decl = get_identifier (nam);
11305   free (nam);
11306   IDENTIFIER_INVENTED (decl) = 1;
11307   return decl;
11308 }
11309
11310 ffeinfoBasictype
11311 ffecom_gfrt_basictype (ffecomGfrt gfrt)
11312 {
11313   assert (gfrt < FFECOM_gfrt);
11314
11315   switch (ffecom_gfrt_type_[gfrt])
11316     {
11317     case FFECOM_rttypeVOID_:
11318     case FFECOM_rttypeVOIDSTAR_:
11319       return FFEINFO_basictypeNONE;
11320
11321     case FFECOM_rttypeFTNINT_:
11322       return FFEINFO_basictypeINTEGER;
11323
11324     case FFECOM_rttypeINTEGER_:
11325       return FFEINFO_basictypeINTEGER;
11326
11327     case FFECOM_rttypeLONGINT_:
11328       return FFEINFO_basictypeINTEGER;
11329
11330     case FFECOM_rttypeLOGICAL_:
11331       return FFEINFO_basictypeLOGICAL;
11332
11333     case FFECOM_rttypeREAL_F2C_:
11334     case FFECOM_rttypeREAL_GNU_:
11335       return FFEINFO_basictypeREAL;
11336
11337     case FFECOM_rttypeCOMPLEX_F2C_:
11338     case FFECOM_rttypeCOMPLEX_GNU_:
11339       return FFEINFO_basictypeCOMPLEX;
11340
11341     case FFECOM_rttypeDOUBLE_:
11342     case FFECOM_rttypeDOUBLEREAL_:
11343       return FFEINFO_basictypeREAL;
11344
11345     case FFECOM_rttypeDBLCMPLX_F2C_:
11346     case FFECOM_rttypeDBLCMPLX_GNU_:
11347       return FFEINFO_basictypeCOMPLEX;
11348
11349     case FFECOM_rttypeCHARACTER_:
11350       return FFEINFO_basictypeCHARACTER;
11351
11352     default:
11353       return FFEINFO_basictypeANY;
11354     }
11355 }
11356
11357 ffeinfoKindtype
11358 ffecom_gfrt_kindtype (ffecomGfrt gfrt)
11359 {
11360   assert (gfrt < FFECOM_gfrt);
11361
11362   switch (ffecom_gfrt_type_[gfrt])
11363     {
11364     case FFECOM_rttypeVOID_:
11365     case FFECOM_rttypeVOIDSTAR_:
11366       return FFEINFO_kindtypeNONE;
11367
11368     case FFECOM_rttypeFTNINT_:
11369       return FFEINFO_kindtypeINTEGER1;
11370
11371     case FFECOM_rttypeINTEGER_:
11372       return FFEINFO_kindtypeINTEGER1;
11373
11374     case FFECOM_rttypeLONGINT_:
11375       return FFEINFO_kindtypeINTEGER4;
11376
11377     case FFECOM_rttypeLOGICAL_:
11378       return FFEINFO_kindtypeLOGICAL1;
11379
11380     case FFECOM_rttypeREAL_F2C_:
11381     case FFECOM_rttypeREAL_GNU_:
11382       return FFEINFO_kindtypeREAL1;
11383
11384     case FFECOM_rttypeCOMPLEX_F2C_:
11385     case FFECOM_rttypeCOMPLEX_GNU_:
11386       return FFEINFO_kindtypeREAL1;
11387
11388     case FFECOM_rttypeDOUBLE_:
11389     case FFECOM_rttypeDOUBLEREAL_:
11390       return FFEINFO_kindtypeREAL2;
11391
11392     case FFECOM_rttypeDBLCMPLX_F2C_:
11393     case FFECOM_rttypeDBLCMPLX_GNU_:
11394       return FFEINFO_kindtypeREAL2;
11395
11396     case FFECOM_rttypeCHARACTER_:
11397       return FFEINFO_kindtypeCHARACTER1;
11398
11399     default:
11400       return FFEINFO_kindtypeANY;
11401     }
11402 }
11403
11404 void
11405 ffecom_init_0 ()
11406 {
11407   tree endlink;
11408   int i;
11409   int j;
11410   tree t;
11411   tree field;
11412   ffetype type;
11413   ffetype base_type;
11414   tree double_ftype_double;
11415   tree float_ftype_float;
11416   tree ldouble_ftype_ldouble;
11417   tree ffecom_tree_ptr_to_fun_type_void;
11418
11419   /* This block of code comes from the now-obsolete cktyps.c.  It checks
11420      whether the compiler environment is buggy in known ways, some of which
11421      would, if not explicitly checked here, result in subtle bugs in g77.  */
11422
11423   if (ffe_is_do_internal_checks ())
11424     {
11425       static char names[][12]
11426         =
11427       {"bar", "bletch", "foo", "foobar"};
11428       char *name;
11429       unsigned long ul;
11430       double fl;
11431
11432       name = bsearch ("foo", &names[0], ARRAY_SIZE (names), sizeof (names[0]),
11433                       (int (*)(const void *, const void *)) strcmp);
11434       if (name != (char *) &names[2])
11435         {
11436           assert ("bsearch doesn't work, #define FFEPROJ_BSEARCH 0 in proj.h"
11437                   == NULL);
11438           abort ();
11439         }
11440
11441       ul = strtoul ("123456789", NULL, 10);
11442       if (ul != 123456789L)
11443         {
11444           assert ("strtoul doesn't have enough range, #define FFEPROJ_STRTOUL 0\
11445  in proj.h" == NULL);
11446           abort ();
11447         }
11448
11449       fl = atof ("56.789");
11450       if ((fl < 56.788) || (fl > 56.79))
11451         {
11452           assert ("atof not type double, fix your #include <stdio.h>"
11453                   == NULL);
11454           abort ();
11455         }
11456     }
11457
11458 #if FFECOM_GCC_INCLUDE
11459   ffecom_initialize_char_syntax_ ();
11460 #endif
11461
11462   ffecom_outer_function_decl_ = NULL_TREE;
11463   current_function_decl = NULL_TREE;
11464   named_labels = NULL_TREE;
11465   current_binding_level = NULL_BINDING_LEVEL;
11466   free_binding_level = NULL_BINDING_LEVEL;
11467   /* Make the binding_level structure for global names.  */
11468   pushlevel (0);
11469   global_binding_level = current_binding_level;
11470   current_binding_level->prep_state = 2;
11471
11472   build_common_tree_nodes (1);
11473
11474   /* Define `int' and `char' first so that dbx will output them first.  */
11475   pushdecl (build_decl (TYPE_DECL, get_identifier ("int"),
11476                         integer_type_node));
11477   pushdecl (build_decl (TYPE_DECL, get_identifier ("char"),
11478                         char_type_node));
11479   pushdecl (build_decl (TYPE_DECL, get_identifier ("long int"),
11480                         long_integer_type_node));
11481   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned int"),
11482                         unsigned_type_node));
11483   pushdecl (build_decl (TYPE_DECL, get_identifier ("long unsigned int"),
11484                         long_unsigned_type_node));
11485   pushdecl (build_decl (TYPE_DECL, get_identifier ("long long int"),
11486                         long_long_integer_type_node));
11487   pushdecl (build_decl (TYPE_DECL, get_identifier ("long long unsigned int"),
11488                         long_long_unsigned_type_node));
11489   pushdecl (build_decl (TYPE_DECL, get_identifier ("short int"),
11490                         short_integer_type_node));
11491   pushdecl (build_decl (TYPE_DECL, get_identifier ("short unsigned int"),
11492                         short_unsigned_type_node));
11493
11494   /* Set the sizetype before we make other types.  This *should* be the
11495      first type we create.  */
11496
11497   set_sizetype
11498     (TREE_TYPE (IDENTIFIER_GLOBAL_VALUE (get_identifier (SIZE_TYPE))));
11499   ffecom_typesize_pointer_
11500     = TREE_INT_CST_LOW (TYPE_SIZE (sizetype)) / BITS_PER_UNIT;
11501
11502   build_common_tree_nodes_2 (0);
11503
11504   /* Define both `signed char' and `unsigned char'.  */
11505   pushdecl (build_decl (TYPE_DECL, get_identifier ("signed char"),
11506                         signed_char_type_node));
11507
11508   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned char"),
11509                         unsigned_char_type_node));
11510
11511   pushdecl (build_decl (TYPE_DECL, get_identifier ("float"),
11512                         float_type_node));
11513   pushdecl (build_decl (TYPE_DECL, get_identifier ("double"),
11514                         double_type_node));
11515   pushdecl (build_decl (TYPE_DECL, get_identifier ("long double"),
11516                         long_double_type_node));
11517
11518   /* For now, override what build_common_tree_nodes has done.  */
11519   complex_integer_type_node = ffecom_make_complex_type_ (integer_type_node);
11520   complex_float_type_node = ffecom_make_complex_type_ (float_type_node);
11521   complex_double_type_node = ffecom_make_complex_type_ (double_type_node);
11522   complex_long_double_type_node
11523     = ffecom_make_complex_type_ (long_double_type_node);
11524
11525   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex int"),
11526                         complex_integer_type_node));
11527   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex float"),
11528                         complex_float_type_node));
11529   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex double"),
11530                         complex_double_type_node));
11531   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex long double"),
11532                         complex_long_double_type_node));
11533
11534   pushdecl (build_decl (TYPE_DECL, get_identifier ("void"),
11535                         void_type_node));
11536   /* We are not going to have real types in C with less than byte alignment,
11537      so we might as well not have any types that claim to have it.  */
11538   TYPE_ALIGN (void_type_node) = BITS_PER_UNIT;
11539   TYPE_USER_ALIGN (void_type_node) = 0;
11540
11541   string_type_node = build_pointer_type (char_type_node);
11542
11543   ffecom_tree_fun_type_void
11544     = build_function_type (void_type_node, NULL_TREE);
11545
11546   ffecom_tree_ptr_to_fun_type_void
11547     = build_pointer_type (ffecom_tree_fun_type_void);
11548
11549   endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE);
11550
11551   float_ftype_float
11552     = build_function_type (float_type_node,
11553                            tree_cons (NULL_TREE, float_type_node, endlink));
11554
11555   double_ftype_double
11556     = build_function_type (double_type_node,
11557                            tree_cons (NULL_TREE, double_type_node, endlink));
11558
11559   ldouble_ftype_ldouble
11560     = build_function_type (long_double_type_node,
11561                            tree_cons (NULL_TREE, long_double_type_node,
11562                                       endlink));
11563
11564   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11565     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11566       {
11567         ffecom_tree_type[i][j] = NULL_TREE;
11568         ffecom_tree_fun_type[i][j] = NULL_TREE;
11569         ffecom_tree_ptr_to_fun_type[i][j] = NULL_TREE;
11570         ffecom_f2c_typecode_[i][j] = -1;
11571       }
11572
11573   /* Set up standard g77 types.  Note that INTEGER and LOGICAL are set
11574      to size FLOAT_TYPE_SIZE because they have to be the same size as
11575      REAL, which also is FLOAT_TYPE_SIZE, according to the standard.
11576      Compiler options and other such stuff that change the ways these
11577      types are set should not affect this particular setup.  */
11578
11579   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1]
11580     = t = make_signed_type (FLOAT_TYPE_SIZE);
11581   pushdecl (build_decl (TYPE_DECL, get_identifier ("integer"),
11582                         t));
11583   type = ffetype_new ();
11584   base_type = type;
11585   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER1,
11586                     type);
11587   ffetype_set_ams (type,
11588                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11589                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11590   ffetype_set_star (base_type,
11591                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11592                     type);
11593   ffetype_set_kind (base_type, 1, type);
11594   ffecom_typesize_integer1_ = ffetype_size (type);
11595   assert (ffetype_size (type) == sizeof (ffetargetInteger1));
11596
11597   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER1]
11598     = t = make_unsigned_type (FLOAT_TYPE_SIZE); /* HOLLERITH means unsigned. */
11599   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned"),
11600                         t));
11601
11602   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER2]
11603     = t = make_signed_type (CHAR_TYPE_SIZE);
11604   pushdecl (build_decl (TYPE_DECL, get_identifier ("byte"),
11605                         t));
11606   type = ffetype_new ();
11607   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER2,
11608                     type);
11609   ffetype_set_ams (type,
11610                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11611                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11612   ffetype_set_star (base_type,
11613                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11614                     type);
11615   ffetype_set_kind (base_type, 3, type);
11616   assert (ffetype_size (type) == sizeof (ffetargetInteger2));
11617
11618   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER2]
11619     = t = make_unsigned_type (CHAR_TYPE_SIZE);
11620   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned byte"),
11621                         t));
11622
11623   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER3]
11624     = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11625   pushdecl (build_decl (TYPE_DECL, get_identifier ("word"),
11626                         t));
11627   type = ffetype_new ();
11628   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER3,
11629                     type);
11630   ffetype_set_ams (type,
11631                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11632                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11633   ffetype_set_star (base_type,
11634                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11635                     type);
11636   ffetype_set_kind (base_type, 6, type);
11637   assert (ffetype_size (type) == sizeof (ffetargetInteger3));
11638
11639   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER3]
11640     = t = make_unsigned_type (CHAR_TYPE_SIZE * 2);
11641   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned word"),
11642                         t));
11643
11644   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER4]
11645     = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11646   pushdecl (build_decl (TYPE_DECL, get_identifier ("integer4"),
11647                         t));
11648   type = ffetype_new ();
11649   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER4,
11650                     type);
11651   ffetype_set_ams (type,
11652                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11653                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11654   ffetype_set_star (base_type,
11655                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11656                     type);
11657   ffetype_set_kind (base_type, 2, type);
11658   assert (ffetype_size (type) == sizeof (ffetargetInteger4));
11659
11660   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER4]
11661     = t = make_unsigned_type (FLOAT_TYPE_SIZE * 2);
11662   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned4"),
11663                         t));
11664
11665 #if 0
11666   if (ffe_is_do_internal_checks ()
11667       && LONG_TYPE_SIZE != FLOAT_TYPE_SIZE
11668       && LONG_TYPE_SIZE != CHAR_TYPE_SIZE
11669       && LONG_TYPE_SIZE != SHORT_TYPE_SIZE
11670       && LONG_TYPE_SIZE != LONG_LONG_TYPE_SIZE)
11671     {
11672       fprintf (stderr, "Sorry, no g77 support for LONG_TYPE_SIZE (%d bits) yet.\n",
11673                LONG_TYPE_SIZE);
11674     }
11675 #endif
11676
11677   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL1]
11678     = t = make_signed_type (FLOAT_TYPE_SIZE);
11679   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical"),
11680                         t));
11681   type = ffetype_new ();
11682   base_type = type;
11683   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL1,
11684                     type);
11685   ffetype_set_ams (type,
11686                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11687                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11688   ffetype_set_star (base_type,
11689                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11690                     type);
11691   ffetype_set_kind (base_type, 1, type);
11692   assert (ffetype_size (type) == sizeof (ffetargetLogical1));
11693
11694   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL2]
11695     = t = make_signed_type (CHAR_TYPE_SIZE);
11696   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical2"),
11697                         t));
11698   type = ffetype_new ();
11699   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL2,
11700                     type);
11701   ffetype_set_ams (type,
11702                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11703                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11704   ffetype_set_star (base_type,
11705                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11706                     type);
11707   ffetype_set_kind (base_type, 3, type);
11708   assert (ffetype_size (type) == sizeof (ffetargetLogical2));
11709
11710   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL3]
11711     = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11712   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical3"),
11713                         t));
11714   type = ffetype_new ();
11715   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL3,
11716                     type);
11717   ffetype_set_ams (type,
11718                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11719                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11720   ffetype_set_star (base_type,
11721                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11722                     type);
11723   ffetype_set_kind (base_type, 6, type);
11724   assert (ffetype_size (type) == sizeof (ffetargetLogical3));
11725
11726   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL4]
11727     = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11728   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical4"),
11729                         t));
11730   type = ffetype_new ();
11731   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL4,
11732                     type);
11733   ffetype_set_ams (type,
11734                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11735                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11736   ffetype_set_star (base_type,
11737                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11738                     type);
11739   ffetype_set_kind (base_type, 2, type);
11740   assert (ffetype_size (type) == sizeof (ffetargetLogical4));
11741
11742   ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11743     = t = make_node (REAL_TYPE);
11744   TYPE_PRECISION (t) = FLOAT_TYPE_SIZE;
11745   pushdecl (build_decl (TYPE_DECL, get_identifier ("real"),
11746                         t));
11747   layout_type (t);
11748   type = ffetype_new ();
11749   base_type = type;
11750   ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL1,
11751                     type);
11752   ffetype_set_ams (type,
11753                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11754                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11755   ffetype_set_star (base_type,
11756                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11757                     type);
11758   ffetype_set_kind (base_type, 1, type);
11759   ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11760     = FFETARGET_f2cTYREAL;
11761   assert (ffetype_size (type) == sizeof (ffetargetReal1));
11762
11763   ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREALDOUBLE]
11764     = t = make_node (REAL_TYPE);
11765   TYPE_PRECISION (t) = FLOAT_TYPE_SIZE * 2;     /* Always twice REAL. */
11766   pushdecl (build_decl (TYPE_DECL, get_identifier ("double precision"),
11767                         t));
11768   layout_type (t);
11769   type = ffetype_new ();
11770   ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE,
11771                     type);
11772   ffetype_set_ams (type,
11773                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11774                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11775   ffetype_set_star (base_type,
11776                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11777                     type);
11778   ffetype_set_kind (base_type, 2, type);
11779   ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]
11780     = FFETARGET_f2cTYDREAL;
11781   assert (ffetype_size (type) == sizeof (ffetargetReal2));
11782
11783   ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11784     = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]);
11785   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex"),
11786                         t));
11787   type = ffetype_new ();
11788   base_type = type;
11789   ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL1,
11790                     type);
11791   ffetype_set_ams (type,
11792                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11793                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11794   ffetype_set_star (base_type,
11795                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11796                     type);
11797   ffetype_set_kind (base_type, 1, type);
11798   ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11799     = FFETARGET_f2cTYCOMPLEX;
11800   assert (ffetype_size (type) == sizeof (ffetargetComplex1));
11801
11802   ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREALDOUBLE]
11803     = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]);
11804   pushdecl (build_decl (TYPE_DECL, get_identifier ("double complex"),
11805                         t));
11806   type = ffetype_new ();
11807   ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREALDOUBLE,
11808                     type);
11809   ffetype_set_ams (type,
11810                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11811                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11812   ffetype_set_star (base_type,
11813                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11814                     type);
11815   ffetype_set_kind (base_type, 2,
11816                     type);
11817   ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL2]
11818     = FFETARGET_f2cTYDCOMPLEX;
11819   assert (ffetype_size (type) == sizeof (ffetargetComplex2));
11820
11821   /* Make function and ptr-to-function types for non-CHARACTER types. */
11822
11823   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11824     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11825       {
11826         if ((t = ffecom_tree_type[i][j]) != NULL_TREE)
11827           {
11828             if (i == FFEINFO_basictypeINTEGER)
11829               {
11830                 /* Figure out the smallest INTEGER type that can hold
11831                    a pointer on this machine. */
11832                 if (GET_MODE_SIZE (TYPE_MODE (t))
11833                     >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
11834                   {
11835                     if ((ffecom_pointer_kind_ == FFEINFO_kindtypeNONE)
11836                         || (GET_MODE_SIZE (TYPE_MODE (ffecom_tree_type[i][ffecom_pointer_kind_]))
11837                             > GET_MODE_SIZE (TYPE_MODE (t))))
11838                       ffecom_pointer_kind_ = j;
11839                   }
11840               }
11841             else if (i == FFEINFO_basictypeCOMPLEX)
11842               t = void_type_node;
11843             /* For f2c compatibility, REAL functions are really
11844                implemented as DOUBLE PRECISION.  */
11845             else if ((i == FFEINFO_basictypeREAL)
11846                      && (j == FFEINFO_kindtypeREAL1))
11847               t = ffecom_tree_type
11848                 [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2];
11849
11850             t = ffecom_tree_fun_type[i][j] = build_function_type (t,
11851                                                                   NULL_TREE);
11852             ffecom_tree_ptr_to_fun_type[i][j] = build_pointer_type (t);
11853           }
11854       }
11855
11856   /* Set up pointer types.  */
11857
11858   if (ffecom_pointer_kind_ == FFEINFO_basictypeNONE)
11859     fatal ("no INTEGER type can hold a pointer on this configuration");
11860   else if (0 && ffe_is_do_internal_checks ())
11861     fprintf (stderr, "Pointer type kt=%d\n", ffecom_pointer_kind_);
11862   ffetype_set_kind (ffeinfo_type (FFEINFO_basictypeINTEGER,
11863                                   FFEINFO_kindtypeINTEGERDEFAULT),
11864                     7,
11865                     ffeinfo_type (FFEINFO_basictypeINTEGER,
11866                                   ffecom_pointer_kind_));
11867
11868   if (ffe_is_ugly_assign ())
11869     ffecom_label_kind_ = ffecom_pointer_kind_;  /* Require ASSIGN etc to this. */
11870   else
11871     ffecom_label_kind_ = FFEINFO_kindtypeINTEGERDEFAULT;
11872   if (0 && ffe_is_do_internal_checks ())
11873     fprintf (stderr, "Label type kt=%d\n", ffecom_label_kind_);
11874
11875   ffecom_integer_type_node
11876     = ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1];
11877   ffecom_integer_zero_node = convert (ffecom_integer_type_node,
11878                                       integer_zero_node);
11879   ffecom_integer_one_node = convert (ffecom_integer_type_node,
11880                                      integer_one_node);
11881
11882   /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional.
11883      Turns out that by TYLONG, runtime/libI77/lio.h really means
11884      "whatever size an ftnint is".  For consistency and sanity,
11885      com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen
11886      all are INTEGER, which we also make out of whatever back-end
11887      integer type is FLOAT_TYPE_SIZE bits wide.  This change, from
11888      LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to
11889      accommodate machines like the Alpha.  Note that this suggests
11890      f2c and libf2c are missing a distinction perhaps needed on
11891      some machines between "int" and "long int".  -- burley 0.5.5 950215 */
11892
11893   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, FLOAT_TYPE_SIZE,
11894                             FFETARGET_f2cTYLONG);
11895   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, SHORT_TYPE_SIZE,
11896                             FFETARGET_f2cTYSHORT);
11897   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, CHAR_TYPE_SIZE,
11898                             FFETARGET_f2cTYINT1);
11899   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, LONG_LONG_TYPE_SIZE,
11900                             FFETARGET_f2cTYQUAD);
11901   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, FLOAT_TYPE_SIZE,
11902                             FFETARGET_f2cTYLOGICAL);
11903   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, SHORT_TYPE_SIZE,
11904                             FFETARGET_f2cTYLOGICAL2);
11905   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, CHAR_TYPE_SIZE,
11906                             FFETARGET_f2cTYLOGICAL1);
11907   /* ~~~Not really such a type in libf2c, e.g. I/O support?  */
11908   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, LONG_LONG_TYPE_SIZE,
11909                             FFETARGET_f2cTYQUAD);
11910
11911   /* CHARACTER stuff is all special-cased, so it is not handled in the above
11912      loop.  CHARACTER items are built as arrays of unsigned char.  */
11913
11914   ffecom_tree_type[FFEINFO_basictypeCHARACTER]
11915     [FFEINFO_kindtypeCHARACTER1] = t = char_type_node;
11916   type = ffetype_new ();
11917   base_type = type;
11918   ffeinfo_set_type (FFEINFO_basictypeCHARACTER,
11919                     FFEINFO_kindtypeCHARACTER1,
11920                     type);
11921   ffetype_set_ams (type,
11922                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11923                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11924   ffetype_set_kind (base_type, 1, type);
11925   assert (ffetype_size (type)
11926           == sizeof (((ffetargetCharacter1) { 0, NULL }).text[0]));
11927
11928   ffecom_tree_fun_type[FFEINFO_basictypeCHARACTER]
11929     [FFEINFO_kindtypeCHARACTER1] = ffecom_tree_fun_type_void;
11930   ffecom_tree_ptr_to_fun_type[FFEINFO_basictypeCHARACTER]
11931     [FFEINFO_kindtypeCHARACTER1]
11932     = ffecom_tree_ptr_to_fun_type_void;
11933   ffecom_f2c_typecode_[FFEINFO_basictypeCHARACTER][FFEINFO_kindtypeCHARACTER1]
11934     = FFETARGET_f2cTYCHAR;
11935
11936   ffecom_f2c_typecode_[FFEINFO_basictypeANY][FFEINFO_kindtypeANY]
11937     = 0;
11938
11939   /* Make multi-return-value type and fields. */
11940
11941   ffecom_multi_type_node_ = make_node (UNION_TYPE);
11942
11943   field = NULL_TREE;
11944
11945   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11946     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11947       {
11948         char name[30];
11949
11950         if (ffecom_tree_type[i][j] == NULL_TREE)
11951           continue;             /* Not supported. */
11952         sprintf (&name[0], "bt_%s_kt_%s",
11953                  ffeinfo_basictype_string ((ffeinfoBasictype) i),
11954                  ffeinfo_kindtype_string ((ffeinfoKindtype) j));
11955         ffecom_multi_fields_[i][j] = build_decl (FIELD_DECL,
11956                                                  get_identifier (name),
11957                                                  ffecom_tree_type[i][j]);
11958         DECL_CONTEXT (ffecom_multi_fields_[i][j])
11959           = ffecom_multi_type_node_;
11960         DECL_ALIGN (ffecom_multi_fields_[i][j]) = 0;
11961         DECL_USER_ALIGN (ffecom_multi_fields_[i][j]) = 0;
11962         TREE_CHAIN (ffecom_multi_fields_[i][j]) = field;
11963         field = ffecom_multi_fields_[i][j];
11964       }
11965
11966   TYPE_FIELDS (ffecom_multi_type_node_) = field;
11967   layout_type (ffecom_multi_type_node_);
11968
11969   /* Subroutines usually return integer because they might have alternate
11970      returns. */
11971
11972   ffecom_tree_subr_type
11973     = build_function_type (integer_type_node, NULL_TREE);
11974   ffecom_tree_ptr_to_subr_type
11975     = build_pointer_type (ffecom_tree_subr_type);
11976   ffecom_tree_blockdata_type
11977     = build_function_type (void_type_node, NULL_TREE);
11978
11979   builtin_function ("__builtin_sqrtf", float_ftype_float,
11980                     BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrtf");
11981   builtin_function ("__builtin_fsqrt", double_ftype_double,
11982                     BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrt");
11983   builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble,
11984                     BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrtl");
11985   builtin_function ("__builtin_sinf", float_ftype_float,
11986                     BUILT_IN_SIN, BUILT_IN_NORMAL, "sinf");
11987   builtin_function ("__builtin_sin", double_ftype_double,
11988                     BUILT_IN_SIN, BUILT_IN_NORMAL, "sin");
11989   builtin_function ("__builtin_sinl", ldouble_ftype_ldouble,
11990                     BUILT_IN_SIN, BUILT_IN_NORMAL, "sinl");
11991   builtin_function ("__builtin_cosf", float_ftype_float,
11992                     BUILT_IN_COS, BUILT_IN_NORMAL, "cosf");
11993   builtin_function ("__builtin_cos", double_ftype_double,
11994                     BUILT_IN_COS, BUILT_IN_NORMAL, "cos");
11995   builtin_function ("__builtin_cosl", ldouble_ftype_ldouble,
11996                     BUILT_IN_COS, BUILT_IN_NORMAL, "cosl");
11997
11998 #if BUILT_FOR_270
11999   pedantic_lvalues = FALSE;
12000 #endif
12001
12002   ffecom_f2c_make_type_ (&ffecom_f2c_integer_type_node,
12003                          FFECOM_f2cINTEGER,
12004                          "integer");
12005   ffecom_f2c_make_type_ (&ffecom_f2c_address_type_node,
12006                          FFECOM_f2cADDRESS,
12007                          "address");
12008   ffecom_f2c_make_type_ (&ffecom_f2c_real_type_node,
12009                          FFECOM_f2cREAL,
12010                          "real");
12011   ffecom_f2c_make_type_ (&ffecom_f2c_doublereal_type_node,
12012                          FFECOM_f2cDOUBLEREAL,
12013                          "doublereal");
12014   ffecom_f2c_make_type_ (&ffecom_f2c_complex_type_node,
12015                          FFECOM_f2cCOMPLEX,
12016                          "complex");
12017   ffecom_f2c_make_type_ (&ffecom_f2c_doublecomplex_type_node,
12018                          FFECOM_f2cDOUBLECOMPLEX,
12019                          "doublecomplex");
12020   ffecom_f2c_make_type_ (&ffecom_f2c_longint_type_node,
12021                          FFECOM_f2cLONGINT,
12022                          "longint");
12023   ffecom_f2c_make_type_ (&ffecom_f2c_logical_type_node,
12024                          FFECOM_f2cLOGICAL,
12025                          "logical");
12026   ffecom_f2c_make_type_ (&ffecom_f2c_flag_type_node,
12027                          FFECOM_f2cFLAG,
12028                          "flag");
12029   ffecom_f2c_make_type_ (&ffecom_f2c_ftnlen_type_node,
12030                          FFECOM_f2cFTNLEN,
12031                          "ftnlen");
12032   ffecom_f2c_make_type_ (&ffecom_f2c_ftnint_type_node,
12033                          FFECOM_f2cFTNINT,
12034                          "ftnint");
12035
12036   ffecom_f2c_ftnlen_zero_node
12037     = convert (ffecom_f2c_ftnlen_type_node, integer_zero_node);
12038
12039   ffecom_f2c_ftnlen_one_node
12040     = convert (ffecom_f2c_ftnlen_type_node, integer_one_node);
12041
12042   ffecom_f2c_ftnlen_two_node = build_int_2 (2, 0);
12043   TREE_TYPE (ffecom_f2c_ftnlen_two_node) = ffecom_integer_type_node;
12044
12045   ffecom_f2c_ptr_to_ftnlen_type_node
12046     = build_pointer_type (ffecom_f2c_ftnlen_type_node);
12047
12048   ffecom_f2c_ptr_to_ftnint_type_node
12049     = build_pointer_type (ffecom_f2c_ftnint_type_node);
12050
12051   ffecom_f2c_ptr_to_integer_type_node
12052     = build_pointer_type (ffecom_f2c_integer_type_node);
12053
12054   ffecom_f2c_ptr_to_real_type_node
12055     = build_pointer_type (ffecom_f2c_real_type_node);
12056
12057   ffecom_float_zero_ = build_real (float_type_node, dconst0);
12058   ffecom_double_zero_ = build_real (double_type_node, dconst0);
12059   {
12060     REAL_VALUE_TYPE point_5;
12061
12062 #ifdef REAL_ARITHMETIC
12063     REAL_ARITHMETIC (point_5, RDIV_EXPR, dconst1, dconst2);
12064 #else
12065     point_5 = .5;
12066 #endif
12067     ffecom_float_half_ = build_real (float_type_node, point_5);
12068     ffecom_double_half_ = build_real (double_type_node, point_5);
12069   }
12070
12071   /* Do "extern int xargc;".  */
12072
12073   ffecom_tree_xargc_ = build_decl (VAR_DECL,
12074                                    get_identifier ("f__xargc"),
12075                                    integer_type_node);
12076   DECL_EXTERNAL (ffecom_tree_xargc_) = 1;
12077   TREE_STATIC (ffecom_tree_xargc_) = 1;
12078   TREE_PUBLIC (ffecom_tree_xargc_) = 1;
12079   ffecom_tree_xargc_ = start_decl (ffecom_tree_xargc_, FALSE);
12080   finish_decl (ffecom_tree_xargc_, NULL_TREE, FALSE);
12081
12082 #if 0   /* This is being fixed, and seems to be working now. */
12083   if ((FLOAT_TYPE_SIZE != 32)
12084       || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))) != 32))
12085     {
12086       warning ("configuration: REAL, INTEGER, and LOGICAL are %d bits wide,",
12087                (int) FLOAT_TYPE_SIZE);
12088       warning ("and pointers are %d bits wide, but g77 doesn't yet work",
12089           (int) TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))));
12090       warning ("properly unless they all are 32 bits wide.");
12091       warning ("Please keep this in mind before you report bugs.  g77 should");
12092       warning ("support non-32-bit machines better as of version 0.6.");
12093     }
12094 #endif
12095
12096 #if 0   /* Code in ste.c that would crash has been commented out. */
12097   if (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)
12098       < TYPE_PRECISION (string_type_node))
12099     /* I/O will probably crash.  */
12100     warning ("configuration: char * holds %d bits, but ftnlen only %d",
12101              TYPE_PRECISION (string_type_node),
12102              TYPE_PRECISION (ffecom_f2c_ftnlen_type_node));
12103 #endif
12104
12105 #if 0   /* ASSIGN-related stuff has been changed to accommodate this. */
12106   if (TYPE_PRECISION (ffecom_integer_type_node)
12107       < TYPE_PRECISION (string_type_node))
12108     /* ASSIGN 10 TO I will crash.  */
12109     warning ("configuration: char * holds %d bits, but INTEGER only %d --\n\
12110  ASSIGN statement might fail",
12111              TYPE_PRECISION (string_type_node),
12112              TYPE_PRECISION (ffecom_integer_type_node));
12113 #endif
12114 }
12115
12116 #endif
12117 /* ffecom_init_2 -- Initialize
12118
12119    ffecom_init_2();  */
12120
12121 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12122 void
12123 ffecom_init_2 ()
12124 {
12125   assert (ffecom_outer_function_decl_ == NULL_TREE);
12126   assert (current_function_decl == NULL_TREE);
12127   assert (ffecom_which_entrypoint_decl_ == NULL_TREE);
12128
12129   ffecom_master_arglist_ = NULL;
12130   ++ffecom_num_fns_;
12131   ffecom_primary_entry_ = NULL;
12132   ffecom_is_altreturning_ = FALSE;
12133   ffecom_func_result_ = NULL_TREE;
12134   ffecom_multi_retval_ = NULL_TREE;
12135 }
12136
12137 #endif
12138 /* ffecom_list_expr -- Transform list of exprs into gcc tree
12139
12140    tree t;
12141    ffebld expr;  // FFE opITEM list.
12142    tree = ffecom_list_expr(expr);
12143
12144    List of actual args is transformed into corresponding gcc backend list.  */
12145
12146 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12147 tree
12148 ffecom_list_expr (ffebld expr)
12149 {
12150   tree list;
12151   tree *plist = &list;
12152   tree trail = NULL_TREE;       /* Append char length args here. */
12153   tree *ptrail = &trail;
12154   tree length;
12155
12156   while (expr != NULL)
12157     {
12158       tree texpr = ffecom_arg_expr (ffebld_head (expr), &length);
12159
12160       if (texpr == error_mark_node)
12161         return error_mark_node;
12162
12163       *plist = build_tree_list (NULL_TREE, texpr);
12164       plist = &TREE_CHAIN (*plist);
12165       expr = ffebld_trail (expr);
12166       if (length != NULL_TREE)
12167         {
12168           *ptrail = build_tree_list (NULL_TREE, length);
12169           ptrail = &TREE_CHAIN (*ptrail);
12170         }
12171     }
12172
12173   *plist = trail;
12174
12175   return list;
12176 }
12177
12178 #endif
12179 /* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree
12180
12181    tree t;
12182    ffebld expr;  // FFE opITEM list.
12183    tree = ffecom_list_ptr_to_expr(expr);
12184
12185    List of actual args is transformed into corresponding gcc backend list for
12186    use in calling an external procedure (vs. a statement function).  */
12187
12188 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12189 tree
12190 ffecom_list_ptr_to_expr (ffebld expr)
12191 {
12192   tree list;
12193   tree *plist = &list;
12194   tree trail = NULL_TREE;       /* Append char length args here. */
12195   tree *ptrail = &trail;
12196   tree length;
12197
12198   while (expr != NULL)
12199     {
12200       tree texpr = ffecom_arg_ptr_to_expr (ffebld_head (expr), &length);
12201
12202       if (texpr == error_mark_node)
12203         return error_mark_node;
12204
12205       *plist = build_tree_list (NULL_TREE, texpr);
12206       plist = &TREE_CHAIN (*plist);
12207       expr = ffebld_trail (expr);
12208       if (length != NULL_TREE)
12209         {
12210           *ptrail = build_tree_list (NULL_TREE, length);
12211           ptrail = &TREE_CHAIN (*ptrail);
12212         }
12213     }
12214
12215   *plist = trail;
12216
12217   return list;
12218 }
12219
12220 #endif
12221 /* Obtain gcc's LABEL_DECL tree for label.  */
12222
12223 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12224 tree
12225 ffecom_lookup_label (ffelab label)
12226 {
12227   tree glabel;
12228
12229   if (ffelab_hook (label) == NULL_TREE)
12230     {
12231       char labelname[16];
12232
12233       switch (ffelab_type (label))
12234         {
12235         case FFELAB_typeLOOPEND:
12236         case FFELAB_typeNOTLOOP:
12237         case FFELAB_typeENDIF:
12238           sprintf (labelname, "%" ffelabValue_f "u", ffelab_value (label));
12239           glabel = build_decl (LABEL_DECL, get_identifier (labelname),
12240                                void_type_node);
12241           DECL_CONTEXT (glabel) = current_function_decl;
12242           DECL_MODE (glabel) = VOIDmode;
12243           break;
12244
12245         case FFELAB_typeFORMAT:
12246           glabel = build_decl (VAR_DECL,
12247                                ffecom_get_invented_identifier
12248                                ("__g77_format_%d", (int) ffelab_value (label)),
12249                                build_type_variant (build_array_type
12250                                                    (char_type_node,
12251                                                     NULL_TREE),
12252                                                    1, 0));
12253           TREE_CONSTANT (glabel) = 1;
12254           TREE_STATIC (glabel) = 1;
12255           DECL_CONTEXT (glabel) = current_function_decl;
12256           DECL_INITIAL (glabel) = NULL;
12257           make_decl_rtl (glabel, NULL);
12258           expand_decl (glabel);
12259
12260           ffecom_save_tree_forever (glabel);
12261
12262           break;
12263
12264         case FFELAB_typeANY:
12265           glabel = error_mark_node;
12266           break;
12267
12268         default:
12269           assert ("bad label type" == NULL);
12270           glabel = NULL;
12271           break;
12272         }
12273       ffelab_set_hook (label, glabel);
12274     }
12275   else
12276     {
12277       glabel = ffelab_hook (label);
12278     }
12279
12280   return glabel;
12281 }
12282
12283 #endif
12284 /* Stabilizes the arguments.  Don't use this if the lhs and rhs come from
12285    a single source specification (as in the fourth argument of MVBITS).
12286    If the type is NULL_TREE, the type of lhs is used to make the type of
12287    the MODIFY_EXPR.  */
12288
12289 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12290 tree
12291 ffecom_modify (tree newtype, tree lhs,
12292                tree rhs)
12293 {
12294   if (lhs == error_mark_node || rhs == error_mark_node)
12295     return error_mark_node;
12296
12297   if (newtype == NULL_TREE)
12298     newtype = TREE_TYPE (lhs);
12299
12300   if (TREE_SIDE_EFFECTS (lhs))
12301     lhs = stabilize_reference (lhs);
12302
12303   return ffecom_2s (MODIFY_EXPR, newtype, lhs, rhs);
12304 }
12305
12306 #endif
12307
12308 /* Register source file name.  */
12309
12310 void
12311 ffecom_file (const char *name)
12312 {
12313 #if FFECOM_GCC_INCLUDE
12314   ffecom_file_ (name);
12315 #endif
12316 }
12317
12318 /* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed
12319
12320    ffestorag st;
12321    ffecom_notify_init_storage(st);
12322
12323    Gets called when all possible units in an aggregate storage area (a LOCAL
12324    with equivalences or a COMMON) have been initialized.  The initialization
12325    info either is in ffestorag_init or, if that is NULL,
12326    ffestorag_accretion:
12327
12328    ffestorag_init may contain an opCONTER or opARRTER.  opCONTER may occur
12329    even for an array if the array is one element in length!
12330
12331    ffestorag_accretion will contain an opACCTER.  It is much like an
12332    opARRTER except it has an ffebit object in it instead of just a size.
12333    The back end can use the info in the ffebit object, if it wants, to
12334    reduce the amount of actual initialization, but in any case it should
12335    kill the ffebit object when done.  Also, set accretion to NULL but
12336    init to a non-NULL value.
12337
12338    After performing initialization, DO NOT set init to NULL, because that'll
12339    tell the front end it is ok for more initialization to happen.  Instead,
12340    set init to an opANY expression or some such thing that you can use to
12341    tell that you've already initialized the object.
12342
12343    27-Oct-91  JCB  1.1
12344       Support two-pass FFE.  */
12345
12346 void
12347 ffecom_notify_init_storage (ffestorag st)
12348 {
12349   ffebld init;                  /* The initialization expression. */
12350 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12351   ffetargetOffset size;         /* The size of the entity. */
12352   ffetargetAlign pad;           /* Its initial padding. */
12353 #endif
12354
12355   if (ffestorag_init (st) == NULL)
12356     {
12357       init = ffestorag_accretion (st);
12358       assert (init != NULL);
12359       ffestorag_set_accretion (st, NULL);
12360       ffestorag_set_accretes (st, 0);
12361
12362 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12363       /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
12364       size = ffebld_accter_size (init);
12365       pad = ffebld_accter_pad (init);
12366       ffebit_kill (ffebld_accter_bits (init));
12367       ffebld_set_op (init, FFEBLD_opARRTER);
12368       ffebld_set_arrter (init, ffebld_accter (init));
12369       ffebld_arrter_set_size (init, size);
12370       ffebld_arrter_set_pad (init, size);
12371 #endif
12372
12373 #if FFECOM_TWOPASS
12374       ffestorag_set_init (st, init);
12375 #endif
12376     }
12377 #if FFECOM_ONEPASS
12378   else
12379     init = ffestorag_init (st);
12380 #endif
12381
12382 #if FFECOM_ONEPASS              /* Process the inits, wipe 'em out. */
12383   ffestorag_set_init (st, ffebld_new_any ());
12384
12385   if (ffebld_op (init) == FFEBLD_opANY)
12386     return;                     /* Oh, we already did this! */
12387
12388 #if FFECOM_targetCURRENT == FFECOM_targetFFE
12389   {
12390     ffesymbol s;
12391
12392     if (ffestorag_symbol (st) != NULL)
12393       s = ffestorag_symbol (st);
12394     else
12395       s = ffestorag_typesymbol (st);
12396
12397     fprintf (dmpout, "= initialize_storage \"%s\" ",
12398              (s != NULL) ? ffesymbol_text (s) : "(unnamed)");
12399     ffebld_dump (init);
12400     fputc ('\n', dmpout);
12401   }
12402 #endif
12403
12404 #endif /* if FFECOM_ONEPASS */
12405 }
12406
12407 /* ffecom_notify_init_symbol -- A symbol is now fully init'ed
12408
12409    ffesymbol s;
12410    ffecom_notify_init_symbol(s);
12411
12412    Gets called when all possible units in a symbol (not placed in COMMON
12413    or involved in EQUIVALENCE, unless it as yet has no ffestorag object)
12414    have been initialized.  The initialization info either is in
12415    ffesymbol_init or, if that is NULL, ffesymbol_accretion:
12416
12417    ffesymbol_init may contain an opCONTER or opARRTER.  opCONTER may occur
12418    even for an array if the array is one element in length!
12419
12420    ffesymbol_accretion will contain an opACCTER.  It is much like an
12421    opARRTER except it has an ffebit object in it instead of just a size.
12422    The back end can use the info in the ffebit object, if it wants, to
12423    reduce the amount of actual initialization, but in any case it should
12424    kill the ffebit object when done.  Also, set accretion to NULL but
12425    init to a non-NULL value.
12426
12427    After performing initialization, DO NOT set init to NULL, because that'll
12428    tell the front end it is ok for more initialization to happen.  Instead,
12429    set init to an opANY expression or some such thing that you can use to
12430    tell that you've already initialized the object.
12431
12432    27-Oct-91  JCB  1.1
12433       Support two-pass FFE.  */
12434
12435 void
12436 ffecom_notify_init_symbol (ffesymbol s)
12437 {
12438   ffebld init;                  /* The initialization expression. */
12439 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12440   ffetargetOffset size;         /* The size of the entity. */
12441   ffetargetAlign pad;           /* Its initial padding. */
12442 #endif
12443
12444   if (ffesymbol_storage (s) == NULL)
12445     return;                     /* Do nothing until COMMON/EQUIVALENCE
12446                                    possibilities checked. */
12447
12448   if ((ffesymbol_init (s) == NULL)
12449       && ((init = ffesymbol_accretion (s)) != NULL))
12450     {
12451       ffesymbol_set_accretion (s, NULL);
12452       ffesymbol_set_accretes (s, 0);
12453
12454 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12455       /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
12456       size = ffebld_accter_size (init);
12457       pad = ffebld_accter_pad (init);
12458       ffebit_kill (ffebld_accter_bits (init));
12459       ffebld_set_op (init, FFEBLD_opARRTER);
12460       ffebld_set_arrter (init, ffebld_accter (init));
12461       ffebld_arrter_set_size (init, size);
12462       ffebld_arrter_set_pad (init, size);
12463 #endif
12464
12465 #if FFECOM_TWOPASS
12466       ffesymbol_set_init (s, init);
12467 #endif
12468     }
12469 #if FFECOM_ONEPASS
12470   else
12471     init = ffesymbol_init (s);
12472 #endif
12473
12474 #if FFECOM_ONEPASS
12475   ffesymbol_set_init (s, ffebld_new_any ());
12476
12477   if (ffebld_op (init) == FFEBLD_opANY)
12478     return;                     /* Oh, we already did this! */
12479
12480 #if FFECOM_targetCURRENT == FFECOM_targetFFE
12481   fprintf (dmpout, "= initialize_symbol \"%s\" ", ffesymbol_text (s));
12482   ffebld_dump (init);
12483   fputc ('\n', dmpout);
12484 #endif
12485
12486 #endif /* if FFECOM_ONEPASS */
12487 }
12488
12489 /* ffecom_notify_primary_entry -- Learn which is the primary entry point
12490
12491    ffesymbol s;
12492    ffecom_notify_primary_entry(s);
12493
12494    Gets called when implicit or explicit PROGRAM statement seen or when
12495    FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary
12496    global symbol that serves as the entry point.  */
12497
12498 void
12499 ffecom_notify_primary_entry (ffesymbol s)
12500 {
12501   ffecom_primary_entry_ = s;
12502   ffecom_primary_entry_kind_ = ffesymbol_kind (s);
12503
12504   if ((ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
12505       || (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE))
12506     ffecom_primary_entry_is_proc_ = TRUE;
12507   else
12508     ffecom_primary_entry_is_proc_ = FALSE;
12509
12510   if (!ffe_is_silent ())
12511     {
12512       if (ffecom_primary_entry_kind_ == FFEINFO_kindPROGRAM)
12513         fprintf (stderr, "%s:\n", ffesymbol_text (s));
12514       else
12515         fprintf (stderr, "  %s:\n", ffesymbol_text (s));
12516     }
12517
12518 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12519   if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
12520     {
12521       ffebld list;
12522       ffebld arg;
12523
12524       for (list = ffesymbol_dummyargs (s);
12525            list != NULL;
12526            list = ffebld_trail (list))
12527         {
12528           arg = ffebld_head (list);
12529           if (ffebld_op (arg) == FFEBLD_opSTAR)
12530             {
12531               ffecom_is_altreturning_ = TRUE;
12532               break;
12533             }
12534         }
12535     }
12536 #endif
12537 }
12538
12539 FILE *
12540 ffecom_open_include (char *name, ffewhereLine l, ffewhereColumn c)
12541 {
12542 #if FFECOM_GCC_INCLUDE
12543   return ffecom_open_include_ (name, l, c);
12544 #else
12545   return fopen (name, "r");
12546 #endif
12547 }
12548
12549 /* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front
12550
12551    tree t;
12552    ffebld expr;  // FFE expression.
12553    tree = ffecom_ptr_to_expr(expr);
12554
12555    Like ffecom_expr, but sticks address-of in front of most things.  */
12556
12557 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12558 tree
12559 ffecom_ptr_to_expr (ffebld expr)
12560 {
12561   tree item;
12562   ffeinfoBasictype bt;
12563   ffeinfoKindtype kt;
12564   ffesymbol s;
12565
12566   assert (expr != NULL);
12567
12568   switch (ffebld_op (expr))
12569     {
12570     case FFEBLD_opSYMTER:
12571       s = ffebld_symter (expr);
12572       if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
12573         {
12574           ffecomGfrt ix;
12575
12576           ix = ffeintrin_gfrt_indirect (ffebld_symter_implementation (expr));
12577           assert (ix != FFECOM_gfrt);
12578           if ((item = ffecom_gfrt_[ix]) == NULL_TREE)
12579             {
12580               ffecom_make_gfrt_ (ix);
12581               item = ffecom_gfrt_[ix];
12582             }
12583         }
12584       else
12585         {
12586           item = ffesymbol_hook (s).decl_tree;
12587           if (item == NULL_TREE)
12588             {
12589               s = ffecom_sym_transform_ (s);
12590               item = ffesymbol_hook (s).decl_tree;
12591             }
12592         }
12593       assert (item != NULL);
12594       if (item == error_mark_node)
12595         return item;
12596       if (!ffesymbol_hook (s).addr)
12597         item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12598                          item);
12599       return item;
12600
12601     case FFEBLD_opARRAYREF:
12602       return ffecom_arrayref_ (NULL_TREE, expr, 1);
12603
12604     case FFEBLD_opCONTER:
12605
12606       bt = ffeinfo_basictype (ffebld_info (expr));
12607       kt = ffeinfo_kindtype (ffebld_info (expr));
12608
12609       item = ffecom_constantunion (&ffebld_constant_union
12610                                    (ffebld_conter (expr)), bt, kt,
12611                                    ffecom_tree_type[bt][kt]);
12612       if (item == error_mark_node)
12613         return error_mark_node;
12614       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12615                        item);
12616       return item;
12617
12618     case FFEBLD_opANY:
12619       return error_mark_node;
12620
12621     default:
12622       bt = ffeinfo_basictype (ffebld_info (expr));
12623       kt = ffeinfo_kindtype (ffebld_info (expr));
12624
12625       item = ffecom_expr (expr);
12626       if (item == error_mark_node)
12627         return error_mark_node;
12628
12629       /* The back end currently optimizes a bit too zealously for us, in that
12630          we fail JCB001 if the following block of code is omitted.  It checks
12631          to see if the transformed expression is a symbol or array reference,
12632          and encloses it in a SAVE_EXPR if that is the case.  */
12633
12634       STRIP_NOPS (item);
12635       if ((TREE_CODE (item) == VAR_DECL)
12636           || (TREE_CODE (item) == PARM_DECL)
12637           || (TREE_CODE (item) == RESULT_DECL)
12638           || (TREE_CODE (item) == INDIRECT_REF)
12639           || (TREE_CODE (item) == ARRAY_REF)
12640           || (TREE_CODE (item) == COMPONENT_REF)
12641 #ifdef OFFSET_REF
12642           || (TREE_CODE (item) == OFFSET_REF)
12643 #endif
12644           || (TREE_CODE (item) == BUFFER_REF)
12645           || (TREE_CODE (item) == REALPART_EXPR)
12646           || (TREE_CODE (item) == IMAGPART_EXPR))
12647         {
12648           item = ffecom_save_tree (item);
12649         }
12650
12651       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12652                        item);
12653       return item;
12654     }
12655
12656   assert ("fall-through error" == NULL);
12657   return error_mark_node;
12658 }
12659
12660 #endif
12661 /* Obtain a temp var with given data type.
12662
12663    size is FFETARGET_charactersizeNONE for a non-CHARACTER type
12664    or >= 0 for a CHARACTER type.
12665
12666    elements is -1 for a scalar or > 0 for an array of type.  */
12667
12668 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12669 tree
12670 ffecom_make_tempvar (const char *commentary, tree type,
12671                      ffetargetCharacterSize size, int elements)
12672 {
12673   tree t;
12674   static int mynumber;
12675
12676   assert (current_binding_level->prep_state < 2);
12677
12678   if (type == error_mark_node)
12679     return error_mark_node;
12680
12681   if (size != FFETARGET_charactersizeNONE)
12682     type = build_array_type (type,
12683                              build_range_type (ffecom_f2c_ftnlen_type_node,
12684                                                ffecom_f2c_ftnlen_one_node,
12685                                                build_int_2 (size, 0)));
12686   if (elements != -1)
12687     type = build_array_type (type,
12688                              build_range_type (integer_type_node,
12689                                                integer_zero_node,
12690                                                build_int_2 (elements - 1,
12691                                                             0)));
12692   t = build_decl (VAR_DECL,
12693                   ffecom_get_invented_identifier ("__g77_%s_%d",
12694                                                   commentary,
12695                                                   mynumber++),
12696                   type);
12697
12698   t = start_decl (t, FALSE);
12699   finish_decl (t, NULL_TREE, FALSE);
12700
12701   return t;
12702 }
12703 #endif
12704
12705 /* Prepare argument pointer to expression.
12706
12707    Like ffecom_prepare_expr, except for expressions to be evaluated
12708    via ffecom_arg_ptr_to_expr.  */
12709
12710 void
12711 ffecom_prepare_arg_ptr_to_expr (ffebld expr)
12712 {
12713   /* ~~For now, it seems to be the same thing.  */
12714   ffecom_prepare_expr (expr);
12715   return;
12716 }
12717
12718 /* End of preparations.  */
12719
12720 bool
12721 ffecom_prepare_end (void)
12722 {
12723   int prep_state = current_binding_level->prep_state;
12724
12725   assert (prep_state < 2);
12726   current_binding_level->prep_state = 2;
12727
12728   return (prep_state == 1) ? TRUE : FALSE;
12729 }
12730
12731 /* Prepare expression.
12732
12733    This is called before any code is generated for the current block.
12734    It scans the expression, declares any temporaries that might be needed
12735    during evaluation of the expression, and stores those temporaries in
12736    the appropriate "hook" fields of the expression.  `dest', if not NULL,
12737    specifies the destination that ffecom_expr_ will see, in case that
12738    helps avoid generating unused temporaries.
12739
12740    ~~Improve to avoid allocating unused temporaries by taking `dest'
12741    into account vis-a-vis aliasing requirements of complex/character
12742    functions.  */
12743
12744 void
12745 ffecom_prepare_expr_ (ffebld expr, ffebld dest UNUSED)
12746 {
12747   ffeinfoBasictype bt;
12748   ffeinfoKindtype kt;
12749   ffetargetCharacterSize sz;
12750   tree tempvar = NULL_TREE;
12751
12752   assert (current_binding_level->prep_state < 2);
12753
12754   if (! expr)
12755     return;
12756
12757   bt = ffeinfo_basictype (ffebld_info (expr));
12758   kt = ffeinfo_kindtype (ffebld_info (expr));
12759   sz = ffeinfo_size (ffebld_info (expr));
12760
12761   /* Generate whatever temporaries are needed to represent the result
12762      of the expression.  */
12763
12764   if (bt == FFEINFO_basictypeCHARACTER)
12765     {
12766       while (ffebld_op (expr) == FFEBLD_opPAREN)
12767         expr = ffebld_left (expr);
12768     }
12769
12770   switch (ffebld_op (expr))
12771     {
12772     default:
12773       /* Don't make temps for SYMTER, CONTER, etc.  */
12774       if (ffebld_arity (expr) == 0)
12775         break;
12776
12777       switch (bt)
12778         {
12779         case FFEINFO_basictypeCOMPLEX:
12780           if (ffebld_op (expr) == FFEBLD_opFUNCREF)
12781             {
12782               ffesymbol s;
12783
12784               if (ffebld_op (ffebld_left (expr)) != FFEBLD_opSYMTER)
12785                 break;
12786
12787               s = ffebld_symter (ffebld_left (expr));
12788               if (ffesymbol_where (s) == FFEINFO_whereCONSTANT
12789                   || (ffesymbol_where (s) != FFEINFO_whereINTRINSIC
12790                       && ! ffesymbol_is_f2c (s))
12791                   || (ffesymbol_where (s) == FFEINFO_whereINTRINSIC
12792                       && ! ffe_is_f2c_library ()))
12793                 break;
12794             }
12795           else if (ffebld_op (expr) == FFEBLD_opPOWER)
12796             {
12797               /* Requires special treatment.  There's no POW_CC function
12798                  in libg2c, so POW_ZZ is used, which means we always
12799                  need a double-complex temp, not a single-complex.  */
12800               kt = FFEINFO_kindtypeREAL2;
12801             }
12802           else if (ffebld_op (expr) != FFEBLD_opDIVIDE)
12803             /* The other ops don't need temps for complex operands.  */
12804             break;
12805
12806           /* ~~~Avoid making temps for some intrinsics, such as AIMAG(C),
12807              REAL(C).  See 19990325-0.f, routine `check', for cases.  */
12808           tempvar = ffecom_make_tempvar ("complex",
12809                                          ffecom_tree_type
12810                                          [FFEINFO_basictypeCOMPLEX][kt],
12811                                          FFETARGET_charactersizeNONE,
12812                                          -1);
12813           break;
12814
12815         case FFEINFO_basictypeCHARACTER:
12816           if (ffebld_op (expr) != FFEBLD_opFUNCREF)
12817             break;
12818
12819           if (sz == FFETARGET_charactersizeNONE)
12820             /* ~~Kludge alert!  This should someday be fixed. */
12821             sz = 24;
12822
12823           tempvar = ffecom_make_tempvar ("char", char_type_node, sz, -1);
12824           break;
12825
12826         default:
12827           break;
12828         }
12829       break;
12830
12831 #ifdef HAHA
12832     case FFEBLD_opPOWER:
12833       {
12834         tree rtype, ltype;
12835         tree rtmp, ltmp, result;
12836
12837         ltype = ffecom_type_expr (ffebld_left (expr));
12838         rtype = ffecom_type_expr (ffebld_right (expr));
12839
12840         rtmp = ffecom_make_tempvar (rtype, FFETARGET_charactersizeNONE, -1);
12841         ltmp = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
12842         result = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
12843
12844         tempvar = make_tree_vec (3);
12845         TREE_VEC_ELT (tempvar, 0) = rtmp;
12846         TREE_VEC_ELT (tempvar, 1) = ltmp;
12847         TREE_VEC_ELT (tempvar, 2) = result;
12848       }
12849       break;
12850 #endif  /* HAHA */
12851
12852     case FFEBLD_opCONCATENATE:
12853       {
12854         /* This gets special handling, because only one set of temps
12855            is needed for a tree of these -- the tree is treated as
12856            a flattened list of concatenations when generating code.  */
12857
12858         ffecomConcatList_ catlist;
12859         tree ltmp, itmp, result;
12860         int count;
12861         int i;
12862
12863         catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
12864         count = ffecom_concat_list_count_ (catlist);
12865
12866         if (count >= 2)
12867           {
12868             ltmp
12869               = ffecom_make_tempvar ("concat_len",
12870                                      ffecom_f2c_ftnlen_type_node,
12871                                      FFETARGET_charactersizeNONE, count);
12872             itmp
12873               = ffecom_make_tempvar ("concat_item",
12874                                      ffecom_f2c_address_type_node,
12875                                      FFETARGET_charactersizeNONE, count);
12876             result
12877               = ffecom_make_tempvar ("concat_res",
12878                                      char_type_node,
12879                                      ffecom_concat_list_maxlen_ (catlist),
12880                                      -1);
12881
12882             tempvar = make_tree_vec (3);
12883             TREE_VEC_ELT (tempvar, 0) = ltmp;
12884             TREE_VEC_ELT (tempvar, 1) = itmp;
12885             TREE_VEC_ELT (tempvar, 2) = result;
12886           }
12887
12888         for (i = 0; i < count; ++i)
12889           ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist,
12890                                                                     i));
12891
12892         ffecom_concat_list_kill_ (catlist);
12893
12894         if (tempvar)
12895           {
12896             ffebld_nonter_set_hook (expr, tempvar);
12897             current_binding_level->prep_state = 1;
12898           }
12899       }
12900       return;
12901
12902     case FFEBLD_opCONVERT:
12903       if (bt == FFEINFO_basictypeCHARACTER
12904           && ((ffebld_size_known (ffebld_left (expr))
12905                == FFETARGET_charactersizeNONE)
12906               || (ffebld_size_known (ffebld_left (expr)) >= sz)))
12907         tempvar = ffecom_make_tempvar ("convert", char_type_node, sz, -1);
12908       break;
12909     }
12910
12911   if (tempvar)
12912     {
12913       ffebld_nonter_set_hook (expr, tempvar);
12914       current_binding_level->prep_state = 1;
12915     }
12916
12917   /* Prepare subexpressions for this expr.  */
12918
12919   switch (ffebld_op (expr))
12920     {
12921     case FFEBLD_opPERCENT_LOC:
12922       ffecom_prepare_ptr_to_expr (ffebld_left (expr));
12923       break;
12924
12925     case FFEBLD_opPERCENT_VAL:
12926     case FFEBLD_opPERCENT_REF:
12927       ffecom_prepare_expr (ffebld_left (expr));
12928       break;
12929
12930     case FFEBLD_opPERCENT_DESCR:
12931       ffecom_prepare_arg_ptr_to_expr (ffebld_left (expr));
12932       break;
12933
12934     case FFEBLD_opITEM:
12935       {
12936         ffebld item;
12937
12938         for (item = expr;
12939              item != NULL;
12940              item = ffebld_trail (item))
12941           if (ffebld_head (item) != NULL)
12942             ffecom_prepare_expr (ffebld_head (item));
12943       }
12944       break;
12945
12946     default:
12947       /* Need to handle character conversion specially.  */
12948       switch (ffebld_arity (expr))
12949         {
12950         case 2:
12951           ffecom_prepare_expr (ffebld_left (expr));
12952           ffecom_prepare_expr (ffebld_right (expr));
12953           break;
12954
12955         case 1:
12956           ffecom_prepare_expr (ffebld_left (expr));
12957           break;
12958
12959         default:
12960           break;
12961         }
12962     }
12963
12964   return;
12965 }
12966
12967 /* Prepare expression for reading and writing.
12968
12969    Like ffecom_prepare_expr, except for expressions to be evaluated
12970    via ffecom_expr_rw.  */
12971
12972 void
12973 ffecom_prepare_expr_rw (tree type, ffebld expr)
12974 {
12975   /* This is all we support for now.  */
12976   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
12977
12978   /* ~~For now, it seems to be the same thing.  */
12979   ffecom_prepare_expr (expr);
12980   return;
12981 }
12982
12983 /* Prepare expression for writing.
12984
12985    Like ffecom_prepare_expr, except for expressions to be evaluated
12986    via ffecom_expr_w.  */
12987
12988 void
12989 ffecom_prepare_expr_w (tree type, ffebld expr)
12990 {
12991   /* This is all we support for now.  */
12992   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
12993
12994   /* ~~For now, it seems to be the same thing.  */
12995   ffecom_prepare_expr (expr);
12996   return;
12997 }
12998
12999 /* Prepare expression for returning.
13000
13001    Like ffecom_prepare_expr, except for expressions to be evaluated
13002    via ffecom_return_expr.  */
13003
13004 void
13005 ffecom_prepare_return_expr (ffebld expr)
13006 {
13007   assert (current_binding_level->prep_state < 2);
13008
13009   if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE
13010       && ffecom_is_altreturning_
13011       && expr != NULL)
13012     ffecom_prepare_expr (expr);
13013 }
13014
13015 /* Prepare pointer to expression.
13016
13017    Like ffecom_prepare_expr, except for expressions to be evaluated
13018    via ffecom_ptr_to_expr.  */
13019
13020 void
13021 ffecom_prepare_ptr_to_expr (ffebld expr)
13022 {
13023   /* ~~For now, it seems to be the same thing.  */
13024   ffecom_prepare_expr (expr);
13025   return;
13026 }
13027
13028 /* Transform expression into constant pointer-to-expression tree.
13029
13030    If the expression can be transformed into a pointer-to-expression tree
13031    that is constant, that is done, and the tree returned.  Else NULL_TREE
13032    is returned.
13033
13034    That way, a caller can attempt to provide compile-time initialization
13035    of a variable and, if that fails, *then* choose to start a new block
13036    and resort to using temporaries, as appropriate.  */
13037
13038 tree
13039 ffecom_ptr_to_const_expr (ffebld expr)
13040 {
13041   if (! expr)
13042     return integer_zero_node;
13043
13044   if (ffebld_op (expr) == FFEBLD_opANY)
13045     return error_mark_node;
13046
13047   if (ffebld_arity (expr) == 0
13048       && (ffebld_op (expr) != FFEBLD_opSYMTER
13049           || ffebld_where (expr) == FFEINFO_whereCOMMON
13050           || ffebld_where (expr) == FFEINFO_whereGLOBAL
13051           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
13052     {
13053       tree t;
13054
13055       t = ffecom_ptr_to_expr (expr);
13056       assert (TREE_CONSTANT (t));
13057       return t;
13058     }
13059
13060   return NULL_TREE;
13061 }
13062
13063 /* ffecom_return_expr -- Returns return-value expr given alt return expr
13064
13065    tree rtn;  // NULL_TREE means use expand_null_return()
13066    ffebld expr;  // NULL if no alt return expr to RETURN stmt
13067    rtn = ffecom_return_expr(expr);
13068
13069    Based on the program unit type and other info (like return function
13070    type, return master function type when alternate ENTRY points,
13071    whether subroutine has any alternate RETURN points, etc), returns the
13072    appropriate expression to be returned to the caller, or NULL_TREE
13073    meaning no return value or the caller expects it to be returned somewhere
13074    else (which is handled by other parts of this module).  */
13075
13076 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13077 tree
13078 ffecom_return_expr (ffebld expr)
13079 {
13080   tree rtn;
13081
13082   switch (ffecom_primary_entry_kind_)
13083     {
13084     case FFEINFO_kindPROGRAM:
13085     case FFEINFO_kindBLOCKDATA:
13086       rtn = NULL_TREE;
13087       break;
13088
13089     case FFEINFO_kindSUBROUTINE:
13090       if (!ffecom_is_altreturning_)
13091         rtn = NULL_TREE;        /* No alt returns, never an expr. */
13092       else if (expr == NULL)
13093         rtn = integer_zero_node;
13094       else
13095         rtn = ffecom_expr (expr);
13096       break;
13097
13098     case FFEINFO_kindFUNCTION:
13099       if ((ffecom_multi_retval_ != NULL_TREE)
13100           || (ffesymbol_basictype (ffecom_primary_entry_)
13101               == FFEINFO_basictypeCHARACTER)
13102           || ((ffesymbol_basictype (ffecom_primary_entry_)
13103                == FFEINFO_basictypeCOMPLEX)
13104               && (ffecom_num_entrypoints_ == 0)
13105               && ffesymbol_is_f2c (ffecom_primary_entry_)))
13106         {                       /* Value is returned by direct assignment
13107                                    into (implicit) dummy. */
13108           rtn = NULL_TREE;
13109           break;
13110         }
13111       rtn = ffecom_func_result_;
13112 #if 0
13113       /* Spurious error if RETURN happens before first reference!  So elide
13114          this code.  In particular, for debugging registry, rtn should always
13115          be non-null after all, but TREE_USED won't be set until we encounter
13116          a reference in the code.  Perfectly okay (but weird) code that,
13117          e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in
13118          this diagnostic for no reason.  Have people use -O -Wuninitialized
13119          and leave it to the back end to find obviously weird cases.  */
13120
13121       /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid
13122          situation; if the return value has never been referenced, it won't
13123          have a tree under 2pass mode. */
13124       if ((rtn == NULL_TREE)
13125           || !TREE_USED (rtn))
13126         {
13127           ffebad_start (FFEBAD_RETURN_VALUE_UNSET);
13128           ffebad_here (0, ffesymbol_where_line (ffecom_primary_entry_),
13129                        ffesymbol_where_column (ffecom_primary_entry_));
13130           ffebad_string (ffesymbol_text (ffesymbol_funcresult
13131                                          (ffecom_primary_entry_)));
13132           ffebad_finish ();
13133         }
13134 #endif
13135       break;
13136
13137     default:
13138       assert ("bad unit kind" == NULL);
13139     case FFEINFO_kindANY:
13140       rtn = error_mark_node;
13141       break;
13142     }
13143
13144   return rtn;
13145 }
13146
13147 #endif
13148 /* Do save_expr only if tree is not error_mark_node.  */
13149
13150 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13151 tree
13152 ffecom_save_tree (tree t)
13153 {
13154   return save_expr (t);
13155 }
13156 #endif
13157
13158 /* Start a compound statement (block).  */
13159
13160 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13161 void
13162 ffecom_start_compstmt (void)
13163 {
13164   bison_rule_pushlevel_ ();
13165 }
13166 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
13167
13168 /* Public entry point for front end to access start_decl.  */
13169
13170 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13171 tree
13172 ffecom_start_decl (tree decl, bool is_initialized)
13173 {
13174   DECL_INITIAL (decl) = is_initialized ? error_mark_node : NULL_TREE;
13175   return start_decl (decl, FALSE);
13176 }
13177
13178 #endif
13179 /* ffecom_sym_commit -- Symbol's state being committed to reality
13180
13181    ffesymbol s;
13182    ffecom_sym_commit(s);
13183
13184    Does whatever the backend needs when a symbol is committed after having
13185    been backtrackable for a period of time.  */
13186
13187 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13188 void
13189 ffecom_sym_commit (ffesymbol s UNUSED)
13190 {
13191   assert (!ffesymbol_retractable ());
13192 }
13193
13194 #endif
13195 /* ffecom_sym_end_transition -- Perform end transition on all symbols
13196
13197    ffecom_sym_end_transition();
13198
13199    Does backend-specific stuff and also calls ffest_sym_end_transition
13200    to do the necessary FFE stuff.
13201
13202    Backtracking is never enabled when this fn is called, so don't worry
13203    about it.  */
13204
13205 ffesymbol
13206 ffecom_sym_end_transition (ffesymbol s)
13207 {
13208   ffestorag st;
13209
13210   assert (!ffesymbol_retractable ());
13211
13212   s = ffest_sym_end_transition (s);
13213
13214 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13215   if ((ffesymbol_kind (s) == FFEINFO_kindBLOCKDATA)
13216       && (ffesymbol_where (s) == FFEINFO_whereGLOBAL))
13217     {
13218       ffecom_list_blockdata_
13219         = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
13220                                               FFEINTRIN_specNONE,
13221                                               FFEINTRIN_impNONE),
13222                            ffecom_list_blockdata_);
13223     }
13224 #endif
13225
13226   /* This is where we finally notice that a symbol has partial initialization
13227      and finalize it. */
13228
13229   if (ffesymbol_accretion (s) != NULL)
13230     {
13231       assert (ffesymbol_init (s) == NULL);
13232       ffecom_notify_init_symbol (s);
13233     }
13234   else if (((st = ffesymbol_storage (s)) != NULL)
13235            && ((st = ffestorag_parent (st)) != NULL)
13236            && (ffestorag_accretion (st) != NULL))
13237     {
13238       assert (ffestorag_init (st) == NULL);
13239       ffecom_notify_init_storage (st);
13240     }
13241
13242 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13243   if ((ffesymbol_kind (s) == FFEINFO_kindCOMMON)
13244       && (ffesymbol_where (s) == FFEINFO_whereLOCAL)
13245       && (ffesymbol_storage (s) != NULL))
13246     {
13247       ffecom_list_common_
13248         = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
13249                                               FFEINTRIN_specNONE,
13250                                               FFEINTRIN_impNONE),
13251                            ffecom_list_common_);
13252     }
13253 #endif
13254
13255   return s;
13256 }
13257
13258 /* ffecom_sym_exec_transition -- Perform exec transition on all symbols
13259
13260    ffecom_sym_exec_transition();
13261
13262    Does backend-specific stuff and also calls ffest_sym_exec_transition
13263    to do the necessary FFE stuff.
13264
13265    See the long-winded description in ffecom_sym_learned for info
13266    on handling the situation where backtracking is inhibited.  */
13267
13268 ffesymbol
13269 ffecom_sym_exec_transition (ffesymbol s)
13270 {
13271   s = ffest_sym_exec_transition (s);
13272
13273   return s;
13274 }
13275
13276 /* ffecom_sym_learned -- Initial or more info gained on symbol after exec
13277
13278    ffesymbol s;
13279    s = ffecom_sym_learned(s);
13280
13281    Called when a new symbol is seen after the exec transition or when more
13282    info (perhaps) is gained for an UNCERTAIN symbol.  The symbol state when
13283    it arrives here is that all its latest info is updated already, so its
13284    state may be UNCERTAIN or UNDERSTOOD, it might already have the hook
13285    field filled in if its gone through here or exec_transition first, and
13286    so on.
13287
13288    The backend probably wants to check ffesymbol_retractable() to see if
13289    backtracking is in effect.  If so, the FFE's changes to the symbol may
13290    be retracted (undone) or committed (ratified), at which time the
13291    appropriate ffecom_sym_retract or _commit function will be called
13292    for that function.
13293
13294    If the backend has its own backtracking mechanism, great, use it so that
13295    committal is a simple operation.  Though it doesn't make much difference,
13296    I suppose: the reason for tentative symbol evolution in the FFE is to
13297    enable error detection in weird incorrect statements early and to disable
13298    incorrect error detection on a correct statement.  The backend is not
13299    likely to introduce any information that'll get involved in these
13300    considerations, so it is probably just fine that the implementation
13301    model for this fn and for _exec_transition is to not do anything
13302    (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE
13303    and instead wait until ffecom_sym_commit is called (which it never
13304    will be as long as we're using ambiguity-detecting statement analysis in
13305    the FFE, which we are initially to shake out the code, but don't depend
13306    on this), otherwise go ahead and do whatever is needed.
13307
13308    In essence, then, when this fn and _exec_transition get called while
13309    backtracking is enabled, a general mechanism would be to flag which (or
13310    both) of these were called (and in what order? neat question as to what
13311    might happen that I'm too lame to think through right now) and then when
13312    _commit is called reproduce the original calling sequence, if any, for
13313    the two fns (at which point backtracking will, of course, be disabled).  */
13314
13315 ffesymbol
13316 ffecom_sym_learned (ffesymbol s)
13317 {
13318   ffestorag_exec_layout (s);
13319
13320   return s;
13321 }
13322
13323 /* ffecom_sym_retract -- Symbol's state being retracted from reality
13324
13325    ffesymbol s;
13326    ffecom_sym_retract(s);
13327
13328    Does whatever the backend needs when a symbol is retracted after having
13329    been backtrackable for a period of time.  */
13330
13331 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13332 void
13333 ffecom_sym_retract (ffesymbol s UNUSED)
13334 {
13335   assert (!ffesymbol_retractable ());
13336
13337 #if 0                           /* GCC doesn't commit any backtrackable sins,
13338                                    so nothing needed here. */
13339   switch (ffesymbol_hook (s).state)
13340     {
13341     case 0:                     /* nothing happened yet. */
13342       break;
13343
13344     case 1:                     /* exec transition happened. */
13345       break;
13346
13347     case 2:                     /* learned happened. */
13348       break;
13349
13350     case 3:                     /* learned then exec. */
13351       break;
13352
13353     case 4:                     /* exec then learned. */
13354       break;
13355
13356     default:
13357       assert ("bad hook state" == NULL);
13358       break;
13359     }
13360 #endif
13361 }
13362
13363 #endif
13364 /* Create temporary gcc label.  */
13365
13366 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13367 tree
13368 ffecom_temp_label ()
13369 {
13370   tree glabel;
13371   static int mynumber = 0;
13372
13373   glabel = build_decl (LABEL_DECL,
13374                        ffecom_get_invented_identifier ("__g77_label_%d",
13375                                                        mynumber++),
13376                        void_type_node);
13377   DECL_CONTEXT (glabel) = current_function_decl;
13378   DECL_MODE (glabel) = VOIDmode;
13379
13380   return glabel;
13381 }
13382
13383 #endif
13384 /* Return an expression that is usable as an arg in a conditional context
13385    (IF, DO WHILE, .NOT., and so on).
13386
13387    Use the one provided for the back end as of >2.6.0.  */
13388
13389 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13390 tree
13391 ffecom_truth_value (tree expr)
13392 {
13393   return truthvalue_conversion (expr);
13394 }
13395
13396 #endif
13397 /* Return the inversion of a truth value (the inversion of what
13398    ffecom_truth_value builds).
13399
13400    Apparently invert_truthvalue, which is properly in the back end, is
13401    enough for now, so just use it.  */
13402
13403 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13404 tree
13405 ffecom_truth_value_invert (tree expr)
13406 {
13407   return invert_truthvalue (ffecom_truth_value (expr));
13408 }
13409
13410 #endif
13411
13412 /* Return the tree that is the type of the expression, as would be
13413    returned in TREE_TYPE(ffecom_expr(expr)), without otherwise
13414    transforming the expression, generating temporaries, etc.  */
13415
13416 tree
13417 ffecom_type_expr (ffebld expr)
13418 {
13419   ffeinfoBasictype bt;
13420   ffeinfoKindtype kt;
13421   tree tree_type;
13422
13423   assert (expr != NULL);
13424
13425   bt = ffeinfo_basictype (ffebld_info (expr));
13426   kt = ffeinfo_kindtype (ffebld_info (expr));
13427   tree_type = ffecom_tree_type[bt][kt];
13428
13429   switch (ffebld_op (expr))
13430     {
13431     case FFEBLD_opCONTER:
13432     case FFEBLD_opSYMTER:
13433     case FFEBLD_opARRAYREF:
13434     case FFEBLD_opUPLUS:
13435     case FFEBLD_opPAREN:
13436     case FFEBLD_opUMINUS:
13437     case FFEBLD_opADD:
13438     case FFEBLD_opSUBTRACT:
13439     case FFEBLD_opMULTIPLY:
13440     case FFEBLD_opDIVIDE:
13441     case FFEBLD_opPOWER:
13442     case FFEBLD_opNOT:
13443     case FFEBLD_opFUNCREF:
13444     case FFEBLD_opSUBRREF:
13445     case FFEBLD_opAND:
13446     case FFEBLD_opOR:
13447     case FFEBLD_opXOR:
13448     case FFEBLD_opNEQV:
13449     case FFEBLD_opEQV:
13450     case FFEBLD_opCONVERT:
13451     case FFEBLD_opLT:
13452     case FFEBLD_opLE:
13453     case FFEBLD_opEQ:
13454     case FFEBLD_opNE:
13455     case FFEBLD_opGT:
13456     case FFEBLD_opGE:
13457     case FFEBLD_opPERCENT_LOC:
13458       return tree_type;
13459
13460     case FFEBLD_opACCTER:
13461     case FFEBLD_opARRTER:
13462     case FFEBLD_opITEM:
13463     case FFEBLD_opSTAR:
13464     case FFEBLD_opBOUNDS:
13465     case FFEBLD_opREPEAT:
13466     case FFEBLD_opLABTER:
13467     case FFEBLD_opLABTOK:
13468     case FFEBLD_opIMPDO:
13469     case FFEBLD_opCONCATENATE:
13470     case FFEBLD_opSUBSTR:
13471     default:
13472       assert ("bad op for ffecom_type_expr" == NULL);
13473       /* Fall through. */
13474     case FFEBLD_opANY:
13475       return error_mark_node;
13476     }
13477 }
13478
13479 /* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points
13480
13481    If the PARM_DECL already exists, return it, else create it.  It's an
13482    integer_type_node argument for the master function that implements a
13483    subroutine or function with more than one entrypoint and is bound at
13484    run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for
13485    first ENTRY statement, and so on).  */
13486
13487 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13488 tree
13489 ffecom_which_entrypoint_decl ()
13490 {
13491   assert (ffecom_which_entrypoint_decl_ != NULL_TREE);
13492
13493   return ffecom_which_entrypoint_decl_;
13494 }
13495
13496 #endif
13497 \f
13498 /* The following sections consists of private and public functions
13499    that have the same names and perform roughly the same functions
13500    as counterparts in the C front end.  Changes in the C front end
13501    might affect how things should be done here.  Only functions
13502    needed by the back end should be public here; the rest should
13503    be private (static in the C sense).  Functions needed by other
13504    g77 front-end modules should be accessed by them via public
13505    ffecom_* names, which should themselves call private versions
13506    in this section so the private versions are easy to recognize
13507    when upgrading to a new gcc and finding interesting changes
13508    in the front end.
13509
13510    Functions named after rule "foo:" in c-parse.y are named
13511    "bison_rule_foo_" so they are easy to find.  */
13512
13513 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13514
13515 static void
13516 bison_rule_pushlevel_ ()
13517 {
13518   emit_line_note (input_filename, lineno);
13519   pushlevel (0);
13520   clear_last_expr ();
13521   expand_start_bindings (0);
13522 }
13523
13524 static tree
13525 bison_rule_compstmt_ ()
13526 {
13527   tree t;
13528   int keep = kept_level_p ();
13529
13530   /* Make the temps go away.  */
13531   if (! keep)
13532     current_binding_level->names = NULL_TREE;
13533
13534   emit_line_note (input_filename, lineno);
13535   expand_end_bindings (getdecls (), keep, 0);
13536   t = poplevel (keep, 1, 0);
13537
13538   return t;
13539 }
13540
13541 /* Return a definition for a builtin function named NAME and whose data type
13542    is TYPE.  TYPE should be a function type with argument types.
13543    FUNCTION_CODE tells later passes how to compile calls to this function.
13544    See tree.h for its possible values.
13545
13546    If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
13547    the name to be called if we can't opencode the function.  */
13548
13549 tree
13550 builtin_function (const char *name, tree type, int function_code,
13551                   enum built_in_class class,
13552                   const char *library_name)
13553 {
13554   tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type);
13555   DECL_EXTERNAL (decl) = 1;
13556   TREE_PUBLIC (decl) = 1;
13557   if (library_name)
13558     DECL_ASSEMBLER_NAME (decl) = get_identifier (library_name);
13559   make_decl_rtl (decl, NULL_PTR);
13560   pushdecl (decl);
13561   DECL_BUILT_IN_CLASS (decl) = class;
13562   DECL_FUNCTION_CODE (decl) = function_code;
13563
13564   return decl;
13565 }
13566
13567 /* Handle when a new declaration NEWDECL
13568    has the same name as an old one OLDDECL
13569    in the same binding contour.
13570    Prints an error message if appropriate.
13571
13572    If safely possible, alter OLDDECL to look like NEWDECL, and return 1.
13573    Otherwise, return 0.  */
13574
13575 static int
13576 duplicate_decls (tree newdecl, tree olddecl)
13577 {
13578   int types_match = 1;
13579   int new_is_definition = (TREE_CODE (newdecl) == FUNCTION_DECL
13580                            && DECL_INITIAL (newdecl) != 0);
13581   tree oldtype = TREE_TYPE (olddecl);
13582   tree newtype = TREE_TYPE (newdecl);
13583
13584   if (olddecl == newdecl)
13585     return 1;
13586
13587   if (TREE_CODE (newtype) == ERROR_MARK
13588       || TREE_CODE (oldtype) == ERROR_MARK)
13589     types_match = 0;
13590
13591   /* New decl is completely inconsistent with the old one =>
13592      tell caller to replace the old one.
13593      This is always an error except in the case of shadowing a builtin.  */
13594   if (TREE_CODE (olddecl) != TREE_CODE (newdecl))
13595     return 0;
13596
13597   /* For real parm decl following a forward decl,
13598      return 1 so old decl will be reused.  */
13599   if (types_match && TREE_CODE (newdecl) == PARM_DECL
13600       && TREE_ASM_WRITTEN (olddecl) && ! TREE_ASM_WRITTEN (newdecl))
13601     return 1;
13602
13603   /* The new declaration is the same kind of object as the old one.
13604      The declarations may partially match.  Print warnings if they don't
13605      match enough.  Ultimately, copy most of the information from the new
13606      decl to the old one, and keep using the old one.  */
13607
13608   if (TREE_CODE (olddecl) == FUNCTION_DECL
13609       && DECL_BUILT_IN (olddecl))
13610     {
13611       /* A function declaration for a built-in function.  */
13612       if (!TREE_PUBLIC (newdecl))
13613         return 0;
13614       else if (!types_match)
13615         {
13616           /* Accept the return type of the new declaration if same modes.  */
13617           tree oldreturntype = TREE_TYPE (TREE_TYPE (olddecl));
13618           tree newreturntype = TREE_TYPE (TREE_TYPE (newdecl));
13619
13620           if (TYPE_MODE (oldreturntype) == TYPE_MODE (newreturntype))
13621             {
13622               /* Function types may be shared, so we can't just modify
13623                  the return type of olddecl's function type.  */
13624               tree newtype
13625                 = build_function_type (newreturntype,
13626                                        TYPE_ARG_TYPES (TREE_TYPE (olddecl)));
13627
13628               types_match = 1;
13629               if (types_match)
13630                 TREE_TYPE (olddecl) = newtype;
13631             }
13632         }
13633       if (!types_match)
13634         return 0;
13635     }
13636   else if (TREE_CODE (olddecl) == FUNCTION_DECL
13637            && DECL_SOURCE_LINE (olddecl) == 0)
13638     {
13639       /* A function declaration for a predeclared function
13640          that isn't actually built in.  */
13641       if (!TREE_PUBLIC (newdecl))
13642         return 0;
13643       else if (!types_match)
13644         {
13645           /* If the types don't match, preserve volatility indication.
13646              Later on, we will discard everything else about the
13647              default declaration.  */
13648           TREE_THIS_VOLATILE (newdecl) |= TREE_THIS_VOLATILE (olddecl);
13649         }
13650     }
13651
13652   /* Copy all the DECL_... slots specified in the new decl
13653      except for any that we copy here from the old type.
13654
13655      Past this point, we don't change OLDTYPE and NEWTYPE
13656      even if we change the types of NEWDECL and OLDDECL.  */
13657
13658   if (types_match)
13659     {
13660       /* Merge the data types specified in the two decls.  */
13661       if (TREE_CODE (newdecl) != FUNCTION_DECL || !DECL_BUILT_IN (olddecl))
13662         TREE_TYPE (newdecl)
13663           = TREE_TYPE (olddecl)
13664             = TREE_TYPE (newdecl);
13665
13666       /* Lay the type out, unless already done.  */
13667       if (oldtype != TREE_TYPE (newdecl))
13668         {
13669           if (TREE_TYPE (newdecl) != error_mark_node)
13670             layout_type (TREE_TYPE (newdecl));
13671           if (TREE_CODE (newdecl) != FUNCTION_DECL
13672               && TREE_CODE (newdecl) != TYPE_DECL
13673               && TREE_CODE (newdecl) != CONST_DECL)
13674             layout_decl (newdecl, 0);
13675         }
13676       else
13677         {
13678           /* Since the type is OLDDECL's, make OLDDECL's size go with.  */
13679           DECL_SIZE (newdecl) = DECL_SIZE (olddecl);
13680           DECL_SIZE_UNIT (newdecl) = DECL_SIZE_UNIT (olddecl);
13681           if (TREE_CODE (olddecl) != FUNCTION_DECL)
13682             if (DECL_ALIGN (olddecl) > DECL_ALIGN (newdecl))
13683               {
13684                 DECL_ALIGN (newdecl) = DECL_ALIGN (olddecl);
13685                 DECL_USER_ALIGN (newdecl) |= DECL_USER_ALIGN (olddecl);
13686               }
13687         }
13688
13689       /* Keep the old rtl since we can safely use it.  */
13690       DECL_RTL (newdecl) = DECL_RTL (olddecl);
13691
13692       /* Merge the type qualifiers.  */
13693       if (DECL_BUILT_IN_NONANSI (olddecl) && TREE_THIS_VOLATILE (olddecl)
13694           && !TREE_THIS_VOLATILE (newdecl))
13695         TREE_THIS_VOLATILE (olddecl) = 0;
13696       if (TREE_READONLY (newdecl))
13697         TREE_READONLY (olddecl) = 1;
13698       if (TREE_THIS_VOLATILE (newdecl))
13699         {
13700           TREE_THIS_VOLATILE (olddecl) = 1;
13701           if (TREE_CODE (newdecl) == VAR_DECL)
13702             make_var_volatile (newdecl);
13703         }
13704
13705       /* Keep source location of definition rather than declaration.
13706          Likewise, keep decl at outer scope.  */
13707       if ((DECL_INITIAL (newdecl) == 0 && DECL_INITIAL (olddecl) != 0)
13708           || (DECL_CONTEXT (newdecl) != 0 && DECL_CONTEXT (olddecl) == 0))
13709         {
13710           DECL_SOURCE_LINE (newdecl) = DECL_SOURCE_LINE (olddecl);
13711           DECL_SOURCE_FILE (newdecl) = DECL_SOURCE_FILE (olddecl);
13712
13713           if (DECL_CONTEXT (olddecl) == 0
13714               && TREE_CODE (newdecl) != FUNCTION_DECL)
13715             DECL_CONTEXT (newdecl) = 0;
13716         }
13717
13718       /* Merge the unused-warning information.  */
13719       if (DECL_IN_SYSTEM_HEADER (olddecl))
13720         DECL_IN_SYSTEM_HEADER (newdecl) = 1;
13721       else if (DECL_IN_SYSTEM_HEADER (newdecl))
13722         DECL_IN_SYSTEM_HEADER (olddecl) = 1;
13723
13724       /* Merge the initialization information.  */
13725       if (DECL_INITIAL (newdecl) == 0)
13726         DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13727
13728       /* Merge the section attribute.
13729          We want to issue an error if the sections conflict but that must be
13730          done later in decl_attributes since we are called before attributes
13731          are assigned.  */
13732       if (DECL_SECTION_NAME (newdecl) == NULL_TREE)
13733         DECL_SECTION_NAME (newdecl) = DECL_SECTION_NAME (olddecl);
13734
13735 #if BUILT_FOR_270
13736       if (TREE_CODE (newdecl) == FUNCTION_DECL)
13737         {
13738           DECL_STATIC_CONSTRUCTOR(newdecl) |= DECL_STATIC_CONSTRUCTOR(olddecl);
13739           DECL_STATIC_DESTRUCTOR (newdecl) |= DECL_STATIC_DESTRUCTOR (olddecl);
13740         }
13741 #endif
13742     }
13743   /* If cannot merge, then use the new type and qualifiers,
13744      and don't preserve the old rtl.  */
13745   else
13746     {
13747       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13748       TREE_READONLY (olddecl) = TREE_READONLY (newdecl);
13749       TREE_THIS_VOLATILE (olddecl) = TREE_THIS_VOLATILE (newdecl);
13750       TREE_SIDE_EFFECTS (olddecl) = TREE_SIDE_EFFECTS (newdecl);
13751     }
13752
13753   /* Merge the storage class information.  */
13754   /* For functions, static overrides non-static.  */
13755   if (TREE_CODE (newdecl) == FUNCTION_DECL)
13756     {
13757       TREE_PUBLIC (newdecl) &= TREE_PUBLIC (olddecl);
13758       /* This is since we don't automatically
13759          copy the attributes of NEWDECL into OLDDECL.  */
13760       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13761       /* If this clears `static', clear it in the identifier too.  */
13762       if (! TREE_PUBLIC (olddecl))
13763         TREE_PUBLIC (DECL_NAME (olddecl)) = 0;
13764     }
13765   if (DECL_EXTERNAL (newdecl))
13766     {
13767       TREE_STATIC (newdecl) = TREE_STATIC (olddecl);
13768       DECL_EXTERNAL (newdecl) = DECL_EXTERNAL (olddecl);
13769       /* An extern decl does not override previous storage class.  */
13770       TREE_PUBLIC (newdecl) = TREE_PUBLIC (olddecl);
13771     }
13772   else
13773     {
13774       TREE_STATIC (olddecl) = TREE_STATIC (newdecl);
13775       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13776     }
13777
13778   /* If either decl says `inline', this fn is inline,
13779      unless its definition was passed already.  */
13780   if (DECL_INLINE (newdecl) && DECL_INITIAL (olddecl) == 0)
13781     DECL_INLINE (olddecl) = 1;
13782   DECL_INLINE (newdecl) = DECL_INLINE (olddecl);
13783
13784   /* Get rid of any built-in function if new arg types don't match it
13785      or if we have a function definition.  */
13786   if (TREE_CODE (newdecl) == FUNCTION_DECL
13787       && DECL_BUILT_IN (olddecl)
13788       && (!types_match || new_is_definition))
13789     {
13790       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13791       DECL_BUILT_IN_CLASS (olddecl) = NOT_BUILT_IN;
13792     }
13793
13794   /* If redeclaring a builtin function, and not a definition,
13795      it stays built in.
13796      Also preserve various other info from the definition.  */
13797   if (TREE_CODE (newdecl) == FUNCTION_DECL && !new_is_definition)
13798     {
13799       if (DECL_BUILT_IN (olddecl))
13800         {
13801           DECL_BUILT_IN_CLASS (newdecl) = DECL_BUILT_IN_CLASS (olddecl);
13802           DECL_FUNCTION_CODE (newdecl) = DECL_FUNCTION_CODE (olddecl);
13803         }
13804       else
13805         DECL_FRAME_SIZE (newdecl) = DECL_FRAME_SIZE (olddecl);
13806
13807       DECL_RESULT (newdecl) = DECL_RESULT (olddecl);
13808       DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13809       DECL_SAVED_INSNS (newdecl) = DECL_SAVED_INSNS (olddecl);
13810       DECL_ARGUMENTS (newdecl) = DECL_ARGUMENTS (olddecl);
13811     }
13812
13813   /* Copy most of the decl-specific fields of NEWDECL into OLDDECL.
13814      But preserve olddecl's DECL_UID.  */
13815   {
13816     register unsigned olddecl_uid = DECL_UID (olddecl);
13817
13818     memcpy ((char *) olddecl + sizeof (struct tree_common),
13819             (char *) newdecl + sizeof (struct tree_common),
13820             sizeof (struct tree_decl) - sizeof (struct tree_common));
13821     DECL_UID (olddecl) = olddecl_uid;
13822   }
13823
13824   return 1;
13825 }
13826
13827 /* Finish processing of a declaration;
13828    install its initial value.
13829    If the length of an array type is not known before,
13830    it must be determined now, from the initial value, or it is an error.  */
13831
13832 static void
13833 finish_decl (tree decl, tree init, bool is_top_level)
13834 {
13835   register tree type = TREE_TYPE (decl);
13836   int was_incomplete = (DECL_SIZE (decl) == 0);
13837   bool at_top_level = (current_binding_level == global_binding_level);
13838   bool top_level = is_top_level || at_top_level;
13839
13840   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13841      level anyway.  */
13842   assert (!is_top_level || !at_top_level);
13843
13844   if (TREE_CODE (decl) == PARM_DECL)
13845     assert (init == NULL_TREE);
13846   /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it
13847      overlaps DECL_ARG_TYPE.  */
13848   else if (init == NULL_TREE)
13849     assert (DECL_INITIAL (decl) == NULL_TREE);
13850   else
13851     assert (DECL_INITIAL (decl) == error_mark_node);
13852
13853   if (init != NULL_TREE)
13854     {
13855       if (TREE_CODE (decl) != TYPE_DECL)
13856         DECL_INITIAL (decl) = init;
13857       else
13858         {
13859           /* typedef foo = bar; store the type of bar as the type of foo.  */
13860           TREE_TYPE (decl) = TREE_TYPE (init);
13861           DECL_INITIAL (decl) = init = 0;
13862         }
13863     }
13864
13865   /* Deduce size of array from initialization, if not already known */
13866
13867   if (TREE_CODE (type) == ARRAY_TYPE
13868       && TYPE_DOMAIN (type) == 0
13869       && TREE_CODE (decl) != TYPE_DECL)
13870     {
13871       assert (top_level);
13872       assert (was_incomplete);
13873
13874       layout_decl (decl, 0);
13875     }
13876
13877   if (TREE_CODE (decl) == VAR_DECL)
13878     {
13879       if (DECL_SIZE (decl) == NULL_TREE
13880           && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
13881         layout_decl (decl, 0);
13882
13883       if (DECL_SIZE (decl) == NULL_TREE
13884           && (TREE_STATIC (decl)
13885               ?
13886       /* A static variable with an incomplete type is an error if it is
13887          initialized. Also if it is not file scope. Otherwise, let it
13888          through, but if it is not `extern' then it may cause an error
13889          message later.  */
13890               (DECL_INITIAL (decl) != 0 || DECL_CONTEXT (decl) != 0)
13891               :
13892       /* An automatic variable with an incomplete type is an error.  */
13893               !DECL_EXTERNAL (decl)))
13894         {
13895           assert ("storage size not known" == NULL);
13896           abort ();
13897         }
13898
13899       if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl))
13900           && (DECL_SIZE (decl) != 0)
13901           && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST))
13902         {
13903           assert ("storage size not constant" == NULL);
13904           abort ();
13905         }
13906     }
13907
13908   /* Output the assembler code and/or RTL code for variables and functions,
13909      unless the type is an undefined structure or union. If not, it will get
13910      done when the type is completed.  */
13911
13912   if (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == FUNCTION_DECL)
13913     {
13914       rest_of_decl_compilation (decl, NULL,
13915                                 DECL_CONTEXT (decl) == 0,
13916                                 0);
13917
13918       if (DECL_CONTEXT (decl) != 0)
13919         {
13920           /* Recompute the RTL of a local array now if it used to be an
13921              incomplete type.  */
13922           if (was_incomplete
13923               && !TREE_STATIC (decl) && !DECL_EXTERNAL (decl))
13924             {
13925               /* If we used it already as memory, it must stay in memory.  */
13926               TREE_ADDRESSABLE (decl) = TREE_USED (decl);
13927               /* If it's still incomplete now, no init will save it.  */
13928               if (DECL_SIZE (decl) == 0)
13929                 DECL_INITIAL (decl) = 0;
13930               expand_decl (decl);
13931             }
13932           /* Compute and store the initial value.  */
13933           if (TREE_CODE (decl) != FUNCTION_DECL)
13934             expand_decl_init (decl);
13935         }
13936     }
13937   else if (TREE_CODE (decl) == TYPE_DECL)
13938     {
13939       rest_of_decl_compilation (decl, NULL_PTR,
13940                                 DECL_CONTEXT (decl) == 0,
13941                                 0);
13942     }
13943
13944   /* At the end of a declaration, throw away any variable type sizes of types
13945      defined inside that declaration.  There is no use computing them in the
13946      following function definition.  */
13947   if (current_binding_level == global_binding_level)
13948     get_pending_sizes ();
13949 }
13950
13951 /* Finish up a function declaration and compile that function
13952    all the way to assembler language output.  The free the storage
13953    for the function definition.
13954
13955    This is called after parsing the body of the function definition.
13956
13957    NESTED is nonzero if the function being finished is nested in another.  */
13958
13959 static void
13960 finish_function (int nested)
13961 {
13962   register tree fndecl = current_function_decl;
13963
13964   assert (fndecl != NULL_TREE);
13965   if (TREE_CODE (fndecl) != ERROR_MARK)
13966     {
13967       if (nested)
13968         assert (DECL_CONTEXT (fndecl) != NULL_TREE);
13969       else
13970         assert (DECL_CONTEXT (fndecl) == NULL_TREE);
13971     }
13972
13973 /*  TREE_READONLY (fndecl) = 1;
13974     This caused &foo to be of type ptr-to-const-function
13975     which then got a warning when stored in a ptr-to-function variable.  */
13976
13977   poplevel (1, 0, 1);
13978
13979   if (TREE_CODE (fndecl) != ERROR_MARK)
13980     {
13981       BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
13982
13983       /* Must mark the RESULT_DECL as being in this function.  */
13984
13985       DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl;
13986
13987       /* Obey `register' declarations if `setjmp' is called in this fn.  */
13988       /* Generate rtl for function exit.  */
13989       expand_function_end (input_filename, lineno, 0);
13990
13991       /* If this is a nested function, protect the local variables in the stack
13992          above us from being collected while we're compiling this function.  */
13993       if (nested)
13994         ggc_push_context ();
13995
13996       /* Run the optimizers and output the assembler code for this function.  */
13997       rest_of_compilation (fndecl);
13998
13999       /* Undo the GC context switch.  */
14000       if (nested)
14001         ggc_pop_context ();
14002     }
14003
14004   if (TREE_CODE (fndecl) != ERROR_MARK
14005       && !nested
14006       && DECL_SAVED_INSNS (fndecl) == 0)
14007     {
14008       /* Stop pointing to the local nodes about to be freed.  */
14009       /* But DECL_INITIAL must remain nonzero so we know this was an actual
14010          function definition.  */
14011       /* For a nested function, this is done in pop_f_function_context.  */
14012       /* If rest_of_compilation set this to 0, leave it 0.  */
14013       if (DECL_INITIAL (fndecl) != 0)
14014         DECL_INITIAL (fndecl) = error_mark_node;
14015       DECL_ARGUMENTS (fndecl) = 0;
14016     }
14017
14018   if (!nested)
14019     {
14020       /* Let the error reporting routines know that we're outside a function.
14021          For a nested function, this value is used in pop_c_function_context
14022          and then reset via pop_function_context.  */
14023       ffecom_outer_function_decl_ = current_function_decl = NULL;
14024     }
14025 }
14026
14027 /* Plug-in replacement for identifying the name of a decl and, for a
14028    function, what we call it in diagnostics.  For now, "program unit"
14029    should suffice, since it's a bit of a hassle to figure out which
14030    of several kinds of things it is.  Note that it could conceivably
14031    be a statement function, which probably isn't really a program unit
14032    per se, but if that comes up, it should be easy to check (being a
14033    nested function and all).  */
14034
14035 static const char *
14036 lang_printable_name (tree decl, int v)
14037 {
14038   /* Just to keep GCC quiet about the unused variable.
14039      In theory, differing values of V should produce different
14040      output.  */
14041   switch (v)
14042     {
14043     default:
14044       if (TREE_CODE (decl) == ERROR_MARK)
14045         return "erroneous code";
14046       return IDENTIFIER_POINTER (DECL_NAME (decl));
14047     }
14048 }
14049
14050 /* g77's function to print out name of current function that caused
14051    an error.  */
14052
14053 #if BUILT_FOR_270
14054 static void
14055 lang_print_error_function (const char *file)
14056 {
14057   static ffeglobal last_g = NULL;
14058   static ffesymbol last_s = NULL;
14059   ffeglobal g;
14060   ffesymbol s;
14061   const char *kind;
14062
14063   if ((ffecom_primary_entry_ == NULL)
14064       || (ffesymbol_global (ffecom_primary_entry_) == NULL))
14065     {
14066       g = NULL;
14067       s = NULL;
14068       kind = NULL;
14069     }
14070   else
14071     {
14072       g = ffesymbol_global (ffecom_primary_entry_);
14073       if (ffecom_nested_entry_ == NULL)
14074         {
14075           s = ffecom_primary_entry_;
14076           switch (ffesymbol_kind (s))
14077             {
14078             case FFEINFO_kindFUNCTION:
14079               kind = "function";
14080               break;
14081
14082             case FFEINFO_kindSUBROUTINE:
14083               kind = "subroutine";
14084               break;
14085
14086             case FFEINFO_kindPROGRAM:
14087               kind = "program";
14088               break;
14089
14090             case FFEINFO_kindBLOCKDATA:
14091               kind = "block-data";
14092               break;
14093
14094             default:
14095               kind = ffeinfo_kind_message (ffesymbol_kind (s));
14096               break;
14097             }
14098         }
14099       else
14100         {
14101           s = ffecom_nested_entry_;
14102           kind = "statement function";
14103         }
14104     }
14105
14106   if ((last_g != g) || (last_s != s))
14107     {
14108       if (file)
14109         fprintf (stderr, "%s: ", file);
14110
14111       if (s == NULL)
14112         fprintf (stderr, "Outside of any program unit:\n");
14113       else
14114         {
14115           const char *name = ffesymbol_text (s);
14116
14117           fprintf (stderr, "In %s `%s':\n", kind, name);
14118         }
14119
14120       last_g = g;
14121       last_s = s;
14122     }
14123 }
14124 #endif
14125
14126 /* Similar to `lookup_name' but look only at current binding level.  */
14127
14128 static tree
14129 lookup_name_current_level (tree name)
14130 {
14131   register tree t;
14132
14133   if (current_binding_level == global_binding_level)
14134     return IDENTIFIER_GLOBAL_VALUE (name);
14135
14136   if (IDENTIFIER_LOCAL_VALUE (name) == 0)
14137     return 0;
14138
14139   for (t = current_binding_level->names; t; t = TREE_CHAIN (t))
14140     if (DECL_NAME (t) == name)
14141       break;
14142
14143   return t;
14144 }
14145
14146 /* Create a new `struct binding_level'.  */
14147
14148 static struct binding_level *
14149 make_binding_level ()
14150 {
14151   /* NOSTRICT */
14152   return (struct binding_level *) xmalloc (sizeof (struct binding_level));
14153 }
14154
14155 /* Save and restore the variables in this file and elsewhere
14156    that keep track of the progress of compilation of the current function.
14157    Used for nested functions.  */
14158
14159 struct f_function
14160 {
14161   struct f_function *next;
14162   tree named_labels;
14163   tree shadowed_labels;
14164   struct binding_level *binding_level;
14165 };
14166
14167 struct f_function *f_function_chain;
14168
14169 /* Restore the variables used during compilation of a C function.  */
14170
14171 static void
14172 pop_f_function_context ()
14173 {
14174   struct f_function *p = f_function_chain;
14175   tree link;
14176
14177   /* Bring back all the labels that were shadowed.  */
14178   for (link = shadowed_labels; link; link = TREE_CHAIN (link))
14179     if (DECL_NAME (TREE_VALUE (link)) != 0)
14180       IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link)))
14181         = TREE_VALUE (link);
14182
14183   if (current_function_decl != error_mark_node
14184       && DECL_SAVED_INSNS (current_function_decl) == 0)
14185     {
14186       /* Stop pointing to the local nodes about to be freed.  */
14187       /* But DECL_INITIAL must remain nonzero so we know this was an actual
14188          function definition.  */
14189       DECL_INITIAL (current_function_decl) = error_mark_node;
14190       DECL_ARGUMENTS (current_function_decl) = 0;
14191     }
14192
14193   pop_function_context ();
14194
14195   f_function_chain = p->next;
14196
14197   named_labels = p->named_labels;
14198   shadowed_labels = p->shadowed_labels;
14199   current_binding_level = p->binding_level;
14200
14201   free (p);
14202 }
14203
14204 /* Save and reinitialize the variables
14205    used during compilation of a C function.  */
14206
14207 static void
14208 push_f_function_context ()
14209 {
14210   struct f_function *p
14211   = (struct f_function *) xmalloc (sizeof (struct f_function));
14212
14213   push_function_context ();
14214
14215   p->next = f_function_chain;
14216   f_function_chain = p;
14217
14218   p->named_labels = named_labels;
14219   p->shadowed_labels = shadowed_labels;
14220   p->binding_level = current_binding_level;
14221 }
14222
14223 static void
14224 push_parm_decl (tree parm)
14225 {
14226   int old_immediate_size_expand = immediate_size_expand;
14227
14228   /* Don't try computing parm sizes now -- wait till fn is called.  */
14229
14230   immediate_size_expand = 0;
14231
14232   /* Fill in arg stuff.  */
14233
14234   DECL_ARG_TYPE (parm) = TREE_TYPE (parm);
14235   DECL_ARG_TYPE_AS_WRITTEN (parm) = TREE_TYPE (parm);
14236   TREE_READONLY (parm) = 1;     /* All implementation args are read-only. */
14237
14238   parm = pushdecl (parm);
14239
14240   immediate_size_expand = old_immediate_size_expand;
14241
14242   finish_decl (parm, NULL_TREE, FALSE);
14243 }
14244
14245 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate.  */
14246
14247 static tree
14248 pushdecl_top_level (x)
14249      tree x;
14250 {
14251   register tree t;
14252   register struct binding_level *b = current_binding_level;
14253   register tree f = current_function_decl;
14254
14255   current_binding_level = global_binding_level;
14256   current_function_decl = NULL_TREE;
14257   t = pushdecl (x);
14258   current_binding_level = b;
14259   current_function_decl = f;
14260   return t;
14261 }
14262
14263 /* Store the list of declarations of the current level.
14264    This is done for the parameter declarations of a function being defined,
14265    after they are modified in the light of any missing parameters.  */
14266
14267 static tree
14268 storedecls (decls)
14269      tree decls;
14270 {
14271   return current_binding_level->names = decls;
14272 }
14273
14274 /* Store the parameter declarations into the current function declaration.
14275    This is called after parsing the parameter declarations, before
14276    digesting the body of the function.
14277
14278    For an old-style definition, modify the function's type
14279    to specify at least the number of arguments.  */
14280
14281 static void
14282 store_parm_decls (int is_main_program UNUSED)
14283 {
14284   register tree fndecl = current_function_decl;
14285
14286   if (fndecl == error_mark_node)
14287     return;
14288
14289   /* This is a chain of PARM_DECLs from old-style parm declarations.  */
14290   DECL_ARGUMENTS (fndecl) = storedecls (nreverse (getdecls ()));
14291
14292   /* Initialize the RTL code for the function.  */
14293
14294   init_function_start (fndecl, input_filename, lineno);
14295
14296   /* Set up parameters and prepare for return, for the function.  */
14297
14298   expand_function_start (fndecl, 0);
14299 }
14300
14301 static tree
14302 start_decl (tree decl, bool is_top_level)
14303 {
14304   register tree tem;
14305   bool at_top_level = (current_binding_level == global_binding_level);
14306   bool top_level = is_top_level || at_top_level;
14307
14308   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
14309      level anyway.  */
14310   assert (!is_top_level || !at_top_level);
14311
14312   if (DECL_INITIAL (decl) != NULL_TREE)
14313     {
14314       assert (DECL_INITIAL (decl) == error_mark_node);
14315       assert (!DECL_EXTERNAL (decl));
14316     }
14317   else if (top_level)
14318     assert ((TREE_STATIC (decl) == 1) || DECL_EXTERNAL (decl) == 1);
14319
14320   /* For Fortran, we by default put things in .common when possible.  */
14321   DECL_COMMON (decl) = 1;
14322
14323   /* Add this decl to the current binding level. TEM may equal DECL or it may
14324      be a previous decl of the same name.  */
14325   if (is_top_level)
14326     tem = pushdecl_top_level (decl);
14327   else
14328     tem = pushdecl (decl);
14329
14330   /* For a local variable, define the RTL now.  */
14331   if (!top_level
14332   /* But not if this is a duplicate decl and we preserved the rtl from the
14333      previous one (which may or may not happen).  */
14334       && DECL_RTL (tem) == 0)
14335     {
14336       if (TYPE_SIZE (TREE_TYPE (tem)) != 0)
14337         expand_decl (tem);
14338       else if (TREE_CODE (TREE_TYPE (tem)) == ARRAY_TYPE
14339                && DECL_INITIAL (tem) != 0)
14340         expand_decl (tem);
14341     }
14342
14343   return tem;
14344 }
14345
14346 /* Create the FUNCTION_DECL for a function definition.
14347    DECLSPECS and DECLARATOR are the parts of the declaration;
14348    they describe the function's name and the type it returns,
14349    but twisted together in a fashion that parallels the syntax of C.
14350
14351    This function creates a binding context for the function body
14352    as well as setting up the FUNCTION_DECL in current_function_decl.
14353
14354    Returns 1 on success.  If the DECLARATOR is not suitable for a function
14355    (it defines a datum instead), we return 0, which tells
14356    yyparse to report a parse error.
14357
14358    NESTED is nonzero for a function nested within another function.  */
14359
14360 static void
14361 start_function (tree name, tree type, int nested, int public)
14362 {
14363   tree decl1;
14364   tree restype;
14365   int old_immediate_size_expand = immediate_size_expand;
14366
14367   named_labels = 0;
14368   shadowed_labels = 0;
14369
14370   /* Don't expand any sizes in the return type of the function.  */
14371   immediate_size_expand = 0;
14372
14373   if (nested)
14374     {
14375       assert (!public);
14376       assert (current_function_decl != NULL_TREE);
14377       assert (DECL_CONTEXT (current_function_decl) == NULL_TREE);
14378     }
14379   else
14380     {
14381       assert (current_function_decl == NULL_TREE);
14382     }
14383
14384   if (TREE_CODE (type) == ERROR_MARK)
14385     decl1 = current_function_decl = error_mark_node;
14386   else
14387     {
14388       decl1 = build_decl (FUNCTION_DECL,
14389                           name,
14390                           type);
14391       TREE_PUBLIC (decl1) = public ? 1 : 0;
14392       if (nested)
14393         DECL_INLINE (decl1) = 1;
14394       TREE_STATIC (decl1) = 1;
14395       DECL_EXTERNAL (decl1) = 0;
14396
14397       announce_function (decl1);
14398
14399       /* Make the init_value nonzero so pushdecl knows this is not tentative.
14400          error_mark_node is replaced below (in poplevel) with the BLOCK.  */
14401       DECL_INITIAL (decl1) = error_mark_node;
14402
14403       /* Record the decl so that the function name is defined. If we already have
14404          a decl for this name, and it is a FUNCTION_DECL, use the old decl.  */
14405
14406       current_function_decl = pushdecl (decl1);
14407     }
14408
14409   if (!nested)
14410     ffecom_outer_function_decl_ = current_function_decl;
14411
14412   pushlevel (0);
14413   current_binding_level->prep_state = 2;
14414
14415   if (TREE_CODE (current_function_decl) != ERROR_MARK)
14416     {
14417       make_decl_rtl (current_function_decl, NULL);
14418
14419       restype = TREE_TYPE (TREE_TYPE (current_function_decl));
14420       DECL_RESULT (current_function_decl)
14421         = build_decl (RESULT_DECL, NULL_TREE, restype);
14422     }
14423
14424   if (!nested && (TREE_CODE (current_function_decl) != ERROR_MARK))
14425     TREE_ADDRESSABLE (current_function_decl) = 1;
14426
14427   immediate_size_expand = old_immediate_size_expand;
14428 }
14429 \f
14430 /* Here are the public functions the GNU back end needs.  */
14431
14432 tree
14433 convert (type, expr)
14434      tree type, expr;
14435 {
14436   register tree e = expr;
14437   register enum tree_code code = TREE_CODE (type);
14438
14439   if (type == TREE_TYPE (e)
14440       || TREE_CODE (e) == ERROR_MARK)
14441     return e;
14442   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
14443     return fold (build1 (NOP_EXPR, type, e));
14444   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
14445       || code == ERROR_MARK)
14446     return error_mark_node;
14447   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
14448     {
14449       assert ("void value not ignored as it ought to be" == NULL);
14450       return error_mark_node;
14451     }
14452   if (code == VOID_TYPE)
14453     return build1 (CONVERT_EXPR, type, e);
14454   if ((code != RECORD_TYPE)
14455       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
14456     e = ffecom_1 (REALPART_EXPR, TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e))),
14457                   e);
14458   if (code == INTEGER_TYPE || code == ENUMERAL_TYPE)
14459     return fold (convert_to_integer (type, e));
14460   if (code == POINTER_TYPE)
14461     return fold (convert_to_pointer (type, e));
14462   if (code == REAL_TYPE)
14463     return fold (convert_to_real (type, e));
14464   if (code == COMPLEX_TYPE)
14465     return fold (convert_to_complex (type, e));
14466   if (code == RECORD_TYPE)
14467     return fold (ffecom_convert_to_complex_ (type, e));
14468
14469   assert ("conversion to non-scalar type requested" == NULL);
14470   return error_mark_node;
14471 }
14472
14473 /* integrate_decl_tree calls this function, but since we don't use the
14474    DECL_LANG_SPECIFIC field, this is a no-op.  */
14475
14476 void
14477 copy_lang_decl (node)
14478      tree node UNUSED;
14479 {
14480 }
14481
14482 /* Return the list of declarations of the current level.
14483    Note that this list is in reverse order unless/until
14484    you nreverse it; and when you do nreverse it, you must
14485    store the result back using `storedecls' or you will lose.  */
14486
14487 tree
14488 getdecls ()
14489 {
14490   return current_binding_level->names;
14491 }
14492
14493 /* Nonzero if we are currently in the global binding level.  */
14494
14495 int
14496 global_bindings_p ()
14497 {
14498   return current_binding_level == global_binding_level;
14499 }
14500
14501 /* Print an error message for invalid use of an incomplete type.
14502    VALUE is the expression that was used (or 0 if that isn't known)
14503    and TYPE is the type that was invalid.  */
14504
14505 void
14506 incomplete_type_error (value, type)
14507      tree value UNUSED;
14508      tree type;
14509 {
14510   if (TREE_CODE (type) == ERROR_MARK)
14511     return;
14512
14513   assert ("incomplete type?!?" == NULL);
14514 }
14515
14516 /* Mark ARG for GC.  */
14517 static void
14518 mark_binding_level (void *arg)
14519 {
14520   struct binding_level *level = *(struct binding_level **) arg;
14521
14522   while (level)
14523     {
14524       ggc_mark_tree (level->names);
14525       ggc_mark_tree (level->blocks);
14526       ggc_mark_tree (level->this_block);
14527       level = level->level_chain;
14528     }
14529 }
14530
14531 void
14532 init_decl_processing ()
14533 {
14534   static tree *const tree_roots[] = {
14535     &current_function_decl,
14536     &string_type_node,
14537     &ffecom_tree_fun_type_void,
14538     &ffecom_integer_zero_node,
14539     &ffecom_integer_one_node,
14540     &ffecom_tree_subr_type,
14541     &ffecom_tree_ptr_to_subr_type,
14542     &ffecom_tree_blockdata_type,
14543     &ffecom_tree_xargc_,
14544     &ffecom_f2c_integer_type_node,
14545     &ffecom_f2c_ptr_to_integer_type_node,
14546     &ffecom_f2c_address_type_node,
14547     &ffecom_f2c_real_type_node,
14548     &ffecom_f2c_ptr_to_real_type_node,
14549     &ffecom_f2c_doublereal_type_node,
14550     &ffecom_f2c_complex_type_node,
14551     &ffecom_f2c_doublecomplex_type_node,
14552     &ffecom_f2c_longint_type_node,
14553     &ffecom_f2c_logical_type_node,
14554     &ffecom_f2c_flag_type_node,
14555     &ffecom_f2c_ftnlen_type_node,
14556     &ffecom_f2c_ftnlen_zero_node,
14557     &ffecom_f2c_ftnlen_one_node,
14558     &ffecom_f2c_ftnlen_two_node,
14559     &ffecom_f2c_ptr_to_ftnlen_type_node,
14560     &ffecom_f2c_ftnint_type_node,
14561     &ffecom_f2c_ptr_to_ftnint_type_node,
14562     &ffecom_outer_function_decl_,
14563     &ffecom_previous_function_decl_,
14564     &ffecom_which_entrypoint_decl_,
14565     &ffecom_float_zero_,
14566     &ffecom_float_half_,
14567     &ffecom_double_zero_,
14568     &ffecom_double_half_,
14569     &ffecom_func_result_,
14570     &ffecom_func_length_,
14571     &ffecom_multi_type_node_,
14572     &ffecom_multi_retval_,
14573     &named_labels,
14574     &shadowed_labels
14575   };
14576   size_t i;
14577
14578   malloc_init ();
14579
14580   /* Record our roots.  */
14581   for (i = 0; i < ARRAY_SIZE (tree_roots); i++)
14582     ggc_add_tree_root (tree_roots[i], 1);
14583   ggc_add_tree_root (&ffecom_tree_type[0][0],
14584                      FFEINFO_basictype*FFEINFO_kindtype);
14585   ggc_add_tree_root (&ffecom_tree_fun_type[0][0],
14586                      FFEINFO_basictype*FFEINFO_kindtype);
14587   ggc_add_tree_root (&ffecom_tree_ptr_to_fun_type[0][0],
14588                      FFEINFO_basictype*FFEINFO_kindtype);
14589   ggc_add_tree_root (ffecom_gfrt_, FFECOM_gfrt);
14590   ggc_add_root (&current_binding_level, 1, sizeof current_binding_level,
14591                 mark_binding_level);
14592   ggc_add_root (&free_binding_level, 1, sizeof current_binding_level,
14593                 mark_binding_level);
14594   ggc_add_root (&tracker_head, 1, sizeof tracker_head, mark_tracker_head);
14595
14596   ffe_init_0 ();
14597 }
14598
14599 const char *
14600 init_parse (filename)
14601      const char *filename;
14602 {
14603   /* Open input file.  */
14604   if (filename == 0 || !strcmp (filename, "-"))
14605     {
14606       finput = stdin;
14607       filename = "stdin";
14608     }
14609   else
14610     finput = fopen (filename, "r");
14611   if (finput == 0)
14612     pfatal_with_name (filename);
14613
14614 #ifdef IO_BUFFER_SIZE
14615   setvbuf (finput, (char *) xmalloc (IO_BUFFER_SIZE), _IOFBF, IO_BUFFER_SIZE);
14616 #endif
14617
14618   /* Make identifier nodes long enough for the language-specific slots.  */
14619   set_identifier_size (sizeof (struct lang_identifier));
14620   decl_printable_name = lang_printable_name;
14621 #if BUILT_FOR_270
14622   print_error_function = lang_print_error_function;
14623 #endif
14624
14625   return filename;
14626 }
14627
14628 void
14629 finish_parse ()
14630 {
14631   fclose (finput);
14632 }
14633
14634 /* Delete the node BLOCK from the current binding level.
14635    This is used for the block inside a stmt expr ({...})
14636    so that the block can be reinserted where appropriate.  */
14637
14638 static void
14639 delete_block (block)
14640      tree block;
14641 {
14642   tree t;
14643   if (current_binding_level->blocks == block)
14644     current_binding_level->blocks = TREE_CHAIN (block);
14645   for (t = current_binding_level->blocks; t;)
14646     {
14647       if (TREE_CHAIN (t) == block)
14648         TREE_CHAIN (t) = TREE_CHAIN (block);
14649       else
14650         t = TREE_CHAIN (t);
14651     }
14652   TREE_CHAIN (block) = NULL;
14653   /* Clear TREE_USED which is always set by poplevel.
14654      The flag is set again if insert_block is called.  */
14655   TREE_USED (block) = 0;
14656 }
14657
14658 void
14659 insert_block (block)
14660      tree block;
14661 {
14662   TREE_USED (block) = 1;
14663   current_binding_level->blocks
14664     = chainon (current_binding_level->blocks, block);
14665 }
14666
14667 /* Each front end provides its own.  */
14668 static void ffe_init PARAMS ((void));
14669 static void ffe_finish PARAMS ((void));
14670 static void ffe_init_options PARAMS ((void));
14671
14672 struct lang_hooks lang_hooks = {ffe_init,
14673                                 ffe_finish,
14674                                 ffe_init_options,
14675                                 ffe_decode_option,
14676                                 NULL /* post_options */};
14677
14678 /* used by print-tree.c */
14679
14680 void
14681 lang_print_xnode (file, node, indent)
14682      FILE *file UNUSED;
14683      tree node UNUSED;
14684      int indent UNUSED;
14685 {
14686 }
14687
14688 static void
14689 ffe_finish ()
14690 {
14691   ffe_terminate_0 ();
14692
14693   if (ffe_is_ffedebug ())
14694     malloc_pool_display (malloc_pool_image ());
14695 }
14696
14697 const char *
14698 lang_identify ()
14699 {
14700   return "f77";
14701 }
14702
14703 /* Return the typed-based alias set for T, which may be an expression
14704    or a type.  Return -1 if we don't do anything special.  */
14705
14706 HOST_WIDE_INT
14707 lang_get_alias_set (t)
14708      tree t ATTRIBUTE_UNUSED;
14709 {
14710   /* We do not wish to use alias-set based aliasing at all.  Used in the
14711      extreme (every object with its own set, with equivalences recorded)
14712      it might be helpful, but there are problems when it comes to inlining.
14713      We get on ok with flag_argument_noalias, and alias-set aliasing does
14714      currently limit how stack slots can be reused, which is a lose.  */
14715   return 0;
14716 }
14717
14718 static void
14719 ffe_init_options ()
14720 {
14721   /* Set default options for Fortran.  */
14722   flag_move_all_movables = 1;
14723   flag_reduce_all_givs = 1;
14724   flag_argument_noalias = 2;
14725   flag_errno_math = 0;
14726   flag_complex_divide_method = 1;
14727 }
14728
14729 static void
14730 ffe_init ()
14731 {
14732   /* If the file is output from cpp, it should contain a first line
14733      `# 1 "real-filename"', and the current design of gcc (toplev.c
14734      in particular and the way it sets up information relied on by
14735      INCLUDE) requires that we read this now, and store the
14736      "real-filename" info in master_input_filename.  Ask the lexer
14737      to try doing this.  */
14738   ffelex_hash_kludge (finput);
14739 }
14740
14741 int
14742 mark_addressable (exp)
14743      tree exp;
14744 {
14745   register tree x = exp;
14746   while (1)
14747     switch (TREE_CODE (x))
14748       {
14749       case ADDR_EXPR:
14750       case COMPONENT_REF:
14751       case ARRAY_REF:
14752         x = TREE_OPERAND (x, 0);
14753         break;
14754
14755       case CONSTRUCTOR:
14756         TREE_ADDRESSABLE (x) = 1;
14757         return 1;
14758
14759       case VAR_DECL:
14760       case CONST_DECL:
14761       case PARM_DECL:
14762       case RESULT_DECL:
14763         if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x)
14764             && DECL_NONLOCAL (x))
14765           {
14766             if (TREE_PUBLIC (x))
14767               {
14768                 assert ("address of global register var requested" == NULL);
14769                 return 0;
14770               }
14771             assert ("address of register variable requested" == NULL);
14772           }
14773         else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x))
14774           {
14775             if (TREE_PUBLIC (x))
14776               {
14777                 assert ("address of global register var requested" == NULL);
14778                 return 0;
14779               }
14780             assert ("address of register var requested" == NULL);
14781           }
14782         put_var_into_stack (x);
14783
14784         /* drops in */
14785       case FUNCTION_DECL:
14786         TREE_ADDRESSABLE (x) = 1;
14787 #if 0                           /* poplevel deals with this now.  */
14788         if (DECL_CONTEXT (x) == 0)
14789           TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x)) = 1;
14790 #endif
14791
14792       default:
14793         return 1;
14794       }
14795 }
14796
14797 /* If DECL has a cleanup, build and return that cleanup here.
14798    This is a callback called by expand_expr.  */
14799
14800 tree
14801 maybe_build_cleanup (decl)
14802      tree decl UNUSED;
14803 {
14804   /* There are no cleanups in Fortran.  */
14805   return NULL_TREE;
14806 }
14807
14808 /* Exit a binding level.
14809    Pop the level off, and restore the state of the identifier-decl mappings
14810    that were in effect when this level was entered.
14811
14812    If KEEP is nonzero, this level had explicit declarations, so
14813    and create a "block" (a BLOCK node) for the level
14814    to record its declarations and subblocks for symbol table output.
14815
14816    If FUNCTIONBODY is nonzero, this level is the body of a function,
14817    so create a block as if KEEP were set and also clear out all
14818    label names.
14819
14820    If REVERSE is nonzero, reverse the order of decls before putting
14821    them into the BLOCK.  */
14822
14823 tree
14824 poplevel (keep, reverse, functionbody)
14825      int keep;
14826      int reverse;
14827      int functionbody;
14828 {
14829   register tree link;
14830   /* The chain of decls was accumulated in reverse order.
14831      Put it into forward order, just for cleanliness.  */
14832   tree decls;
14833   tree subblocks = current_binding_level->blocks;
14834   tree block = 0;
14835   tree decl;
14836   int block_previously_created;
14837
14838   /* Get the decls in the order they were written.
14839      Usually current_binding_level->names is in reverse order.
14840      But parameter decls were previously put in forward order.  */
14841
14842   if (reverse)
14843     current_binding_level->names
14844       = decls = nreverse (current_binding_level->names);
14845   else
14846     decls = current_binding_level->names;
14847
14848   /* Output any nested inline functions within this block
14849      if they weren't already output.  */
14850
14851   for (decl = decls; decl; decl = TREE_CHAIN (decl))
14852     if (TREE_CODE (decl) == FUNCTION_DECL
14853         && ! TREE_ASM_WRITTEN (decl)
14854         && DECL_INITIAL (decl) != 0
14855         && TREE_ADDRESSABLE (decl))
14856       {
14857         /* If this decl was copied from a file-scope decl
14858            on account of a block-scope extern decl,
14859            propagate TREE_ADDRESSABLE to the file-scope decl.
14860
14861            DECL_ABSTRACT_ORIGIN can be set to itself if warn_return_type is
14862            true, since then the decl goes through save_for_inline_copying.  */
14863         if (DECL_ABSTRACT_ORIGIN (decl) != 0
14864             && DECL_ABSTRACT_ORIGIN (decl) != decl)
14865           TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl)) = 1;
14866         else if (DECL_SAVED_INSNS (decl) != 0)
14867           {
14868             push_function_context ();
14869             output_inline_function (decl);
14870             pop_function_context ();
14871           }
14872       }
14873
14874   /* If there were any declarations or structure tags in that level,
14875      or if this level is a function body,
14876      create a BLOCK to record them for the life of this function.  */
14877
14878   block = 0;
14879   block_previously_created = (current_binding_level->this_block != 0);
14880   if (block_previously_created)
14881     block = current_binding_level->this_block;
14882   else if (keep || functionbody)
14883     block = make_node (BLOCK);
14884   if (block != 0)
14885     {
14886       BLOCK_VARS (block) = decls;
14887       BLOCK_SUBBLOCKS (block) = subblocks;
14888     }
14889
14890   /* In each subblock, record that this is its superior.  */
14891
14892   for (link = subblocks; link; link = TREE_CHAIN (link))
14893     BLOCK_SUPERCONTEXT (link) = block;
14894
14895   /* Clear out the meanings of the local variables of this level.  */
14896
14897   for (link = decls; link; link = TREE_CHAIN (link))
14898     {
14899       if (DECL_NAME (link) != 0)
14900         {
14901           /* If the ident. was used or addressed via a local extern decl,
14902              don't forget that fact.  */
14903           if (DECL_EXTERNAL (link))
14904             {
14905               if (TREE_USED (link))
14906                 TREE_USED (DECL_NAME (link)) = 1;
14907               if (TREE_ADDRESSABLE (link))
14908                 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (link)) = 1;
14909             }
14910           IDENTIFIER_LOCAL_VALUE (DECL_NAME (link)) = 0;
14911         }
14912     }
14913
14914   /* If the level being exited is the top level of a function,
14915      check over all the labels, and clear out the current
14916      (function local) meanings of their names.  */
14917
14918   if (functionbody)
14919     {
14920       /* If this is the top level block of a function,
14921          the vars are the function's parameters.
14922          Don't leave them in the BLOCK because they are
14923          found in the FUNCTION_DECL instead.  */
14924
14925       BLOCK_VARS (block) = 0;
14926     }
14927
14928   /* Pop the current level, and free the structure for reuse.  */
14929
14930   {
14931     register struct binding_level *level = current_binding_level;
14932     current_binding_level = current_binding_level->level_chain;
14933
14934     level->level_chain = free_binding_level;
14935     free_binding_level = level;
14936   }
14937
14938   /* Dispose of the block that we just made inside some higher level.  */
14939   if (functionbody
14940       && current_function_decl != error_mark_node)
14941     DECL_INITIAL (current_function_decl) = block;
14942   else if (block)
14943     {
14944       if (!block_previously_created)
14945         current_binding_level->blocks
14946           = chainon (current_binding_level->blocks, block);
14947     }
14948   /* If we did not make a block for the level just exited,
14949      any blocks made for inner levels
14950      (since they cannot be recorded as subblocks in that level)
14951      must be carried forward so they will later become subblocks
14952      of something else.  */
14953   else if (subblocks)
14954     current_binding_level->blocks
14955       = chainon (current_binding_level->blocks, subblocks);
14956
14957   if (block)
14958     TREE_USED (block) = 1;
14959   return block;
14960 }
14961
14962 void
14963 print_lang_decl (file, node, indent)
14964      FILE *file UNUSED;
14965      tree node UNUSED;
14966      int indent UNUSED;
14967 {
14968 }
14969
14970 void
14971 print_lang_identifier (file, node, indent)
14972      FILE *file;
14973      tree node;
14974      int indent;
14975 {
14976   print_node (file, "global", IDENTIFIER_GLOBAL_VALUE (node), indent + 4);
14977   print_node (file, "local", IDENTIFIER_LOCAL_VALUE (node), indent + 4);
14978 }
14979
14980 void
14981 print_lang_statistics ()
14982 {
14983 }
14984
14985 void
14986 print_lang_type (file, node, indent)
14987      FILE *file UNUSED;
14988      tree node UNUSED;
14989      int indent UNUSED;
14990 {
14991 }
14992
14993 /* Record a decl-node X as belonging to the current lexical scope.
14994    Check for errors (such as an incompatible declaration for the same
14995    name already seen in the same scope).
14996
14997    Returns either X or an old decl for the same name.
14998    If an old decl is returned, it may have been smashed
14999    to agree with what X says.  */
15000
15001 tree
15002 pushdecl (x)
15003      tree x;
15004 {
15005   register tree t;
15006   register tree name = DECL_NAME (x);
15007   register struct binding_level *b = current_binding_level;
15008
15009   if ((TREE_CODE (x) == FUNCTION_DECL)
15010       && (DECL_INITIAL (x) == 0)
15011       && DECL_EXTERNAL (x))
15012     DECL_CONTEXT (x) = NULL_TREE;
15013   else
15014     DECL_CONTEXT (x) = current_function_decl;
15015
15016   if (name)
15017     {
15018       if (IDENTIFIER_INVENTED (name))
15019         {
15020 #if BUILT_FOR_270
15021           DECL_ARTIFICIAL (x) = 1;
15022 #endif
15023           DECL_IN_SYSTEM_HEADER (x) = 1;
15024         }
15025
15026       t = lookup_name_current_level (name);
15027
15028       assert ((t == NULL_TREE) || (DECL_CONTEXT (x) == NULL_TREE));
15029
15030       /* Don't push non-parms onto list for parms until we understand
15031          why we're doing this and whether it works.  */
15032
15033       assert ((b == global_binding_level)
15034               || !ffecom_transform_only_dummies_
15035               || TREE_CODE (x) == PARM_DECL);
15036
15037       if ((t != NULL_TREE) && duplicate_decls (x, t))
15038         return t;
15039
15040       /* If we are processing a typedef statement, generate a whole new
15041          ..._TYPE node (which will be just an variant of the existing
15042          ..._TYPE node with identical properties) and then install the
15043          TYPE_DECL node generated to represent the typedef name as the
15044          TYPE_NAME of this brand new (duplicate) ..._TYPE node.
15045
15046          The whole point here is to end up with a situation where each and every
15047          ..._TYPE node the compiler creates will be uniquely associated with
15048          AT MOST one node representing a typedef name. This way, even though
15049          the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL
15050          (i.e. "typedef name") nodes very early on, later parts of the
15051          compiler can always do the reverse translation and get back the
15052          corresponding typedef name.  For example, given:
15053
15054          typedef struct S MY_TYPE; MY_TYPE object;
15055
15056          Later parts of the compiler might only know that `object' was of type
15057          `struct S' if it were not for code just below.  With this code
15058          however, later parts of the compiler see something like:
15059
15060          struct S' == struct S typedef struct S' MY_TYPE; struct S' object;
15061
15062          And they can then deduce (from the node for type struct S') that the
15063          original object declaration was:
15064
15065          MY_TYPE object;
15066
15067          Being able to do this is important for proper support of protoize, and
15068          also for generating precise symbolic debugging information which
15069          takes full account of the programmer's (typedef) vocabulary.
15070
15071          Obviously, we don't want to generate a duplicate ..._TYPE node if the
15072          TYPE_DECL node that we are now processing really represents a
15073          standard built-in type.
15074
15075          Since all standard types are effectively declared at line zero in the
15076          source file, we can easily check to see if we are working on a
15077          standard type by checking the current value of lineno.  */
15078
15079       if (TREE_CODE (x) == TYPE_DECL)
15080         {
15081           if (DECL_SOURCE_LINE (x) == 0)
15082             {
15083               if (TYPE_NAME (TREE_TYPE (x)) == 0)
15084                 TYPE_NAME (TREE_TYPE (x)) = x;
15085             }
15086           else if (TREE_TYPE (x) != error_mark_node)
15087             {
15088               tree tt = TREE_TYPE (x);
15089
15090               tt = build_type_copy (tt);
15091               TYPE_NAME (tt) = x;
15092               TREE_TYPE (x) = tt;
15093             }
15094         }
15095
15096       /* This name is new in its binding level. Install the new declaration
15097          and return it.  */
15098       if (b == global_binding_level)
15099         IDENTIFIER_GLOBAL_VALUE (name) = x;
15100       else
15101         IDENTIFIER_LOCAL_VALUE (name) = x;
15102     }
15103
15104   /* Put decls on list in reverse order. We will reverse them later if
15105      necessary.  */
15106   TREE_CHAIN (x) = b->names;
15107   b->names = x;
15108
15109   return x;
15110 }
15111
15112 /* Nonzero if the current level needs to have a BLOCK made.  */
15113
15114 static int
15115 kept_level_p ()
15116 {
15117   tree decl;
15118
15119   for (decl = current_binding_level->names;
15120        decl;
15121        decl = TREE_CHAIN (decl))
15122     {
15123       if (TREE_USED (decl) || TREE_CODE (decl) != VAR_DECL
15124           || (DECL_NAME (decl) && ! DECL_ARTIFICIAL (decl)))
15125         /* Currently, there aren't supposed to be non-artificial names
15126            at other than the top block for a function -- they're
15127            believed to always be temps.  But it's wise to check anyway.  */
15128         return 1;
15129     }
15130   return 0;
15131 }
15132
15133 /* Enter a new binding level.
15134    If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
15135    not for that of tags.  */
15136
15137 void
15138 pushlevel (tag_transparent)
15139      int tag_transparent;
15140 {
15141   register struct binding_level *newlevel = NULL_BINDING_LEVEL;
15142
15143   assert (! tag_transparent);
15144
15145   if (current_binding_level == global_binding_level)
15146     {
15147       named_labels = 0;
15148     }
15149
15150   /* Reuse or create a struct for this binding level.  */
15151
15152   if (free_binding_level)
15153     {
15154       newlevel = free_binding_level;
15155       free_binding_level = free_binding_level->level_chain;
15156     }
15157   else
15158     {
15159       newlevel = make_binding_level ();
15160     }
15161
15162   /* Add this level to the front of the chain (stack) of levels that
15163      are active.  */
15164
15165   *newlevel = clear_binding_level;
15166   newlevel->level_chain = current_binding_level;
15167   current_binding_level = newlevel;
15168 }
15169
15170 /* Set the BLOCK node for the innermost scope
15171    (the one we are currently in).  */
15172
15173 void
15174 set_block (block)
15175      register tree block;
15176 {
15177   current_binding_level->this_block = block;
15178 }
15179
15180 /* ~~gcc/tree.h *should* declare this, because toplev.c references it.  */
15181
15182 /* Can't 'yydebug' a front end not generated by yacc/bison!  */
15183
15184 void
15185 set_yydebug (value)
15186      int value;
15187 {
15188   if (value)
15189     fprintf (stderr, "warning: no yacc/bison-generated output to debug!\n");
15190 }
15191
15192 tree
15193 signed_or_unsigned_type (unsignedp, type)
15194      int unsignedp;
15195      tree type;
15196 {
15197   tree type2;
15198
15199   if (! INTEGRAL_TYPE_P (type))
15200     return type;
15201   if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node))
15202     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15203   if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node))
15204     return unsignedp ? unsigned_type_node : integer_type_node;
15205   if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node))
15206     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15207   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node))
15208     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15209   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node))
15210     return (unsignedp ? long_long_unsigned_type_node
15211             : long_long_integer_type_node);
15212
15213   type2 = type_for_size (TYPE_PRECISION (type), unsignedp);
15214   if (type2 == NULL_TREE)
15215     return type;
15216
15217   return type2;
15218 }
15219
15220 tree
15221 signed_type (type)
15222      tree type;
15223 {
15224   tree type1 = TYPE_MAIN_VARIANT (type);
15225   ffeinfoKindtype kt;
15226   tree type2;
15227
15228   if (type1 == unsigned_char_type_node || type1 == char_type_node)
15229     return signed_char_type_node;
15230   if (type1 == unsigned_type_node)
15231     return integer_type_node;
15232   if (type1 == short_unsigned_type_node)
15233     return short_integer_type_node;
15234   if (type1 == long_unsigned_type_node)
15235     return long_integer_type_node;
15236   if (type1 == long_long_unsigned_type_node)
15237     return long_long_integer_type_node;
15238 #if 0   /* gcc/c-* files only */
15239   if (type1 == unsigned_intDI_type_node)
15240     return intDI_type_node;
15241   if (type1 == unsigned_intSI_type_node)
15242     return intSI_type_node;
15243   if (type1 == unsigned_intHI_type_node)
15244     return intHI_type_node;
15245   if (type1 == unsigned_intQI_type_node)
15246     return intQI_type_node;
15247 #endif
15248
15249   type2 = type_for_size (TYPE_PRECISION (type1), 0);
15250   if (type2 != NULL_TREE)
15251     return type2;
15252
15253   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15254     {
15255       type2 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
15256
15257       if (type1 == type2)
15258         return ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15259     }
15260
15261   return type;
15262 }
15263
15264 /* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
15265    or validate its data type for an `if' or `while' statement or ?..: exp.
15266
15267    This preparation consists of taking the ordinary
15268    representation of an expression expr and producing a valid tree
15269    boolean expression describing whether expr is nonzero.  We could
15270    simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
15271    but we optimize comparisons, &&, ||, and !.
15272
15273    The resulting type should always be `integer_type_node'.  */
15274
15275 tree
15276 truthvalue_conversion (expr)
15277      tree expr;
15278 {
15279   if (TREE_CODE (expr) == ERROR_MARK)
15280     return expr;
15281
15282 #if 0 /* This appears to be wrong for C++.  */
15283   /* These really should return error_mark_node after 2.4 is stable.
15284      But not all callers handle ERROR_MARK properly.  */
15285   switch (TREE_CODE (TREE_TYPE (expr)))
15286     {
15287     case RECORD_TYPE:
15288       error ("struct type value used where scalar is required");
15289       return integer_zero_node;
15290
15291     case UNION_TYPE:
15292       error ("union type value used where scalar is required");
15293       return integer_zero_node;
15294
15295     case ARRAY_TYPE:
15296       error ("array type value used where scalar is required");
15297       return integer_zero_node;
15298
15299     default:
15300       break;
15301     }
15302 #endif /* 0 */
15303
15304   switch (TREE_CODE (expr))
15305     {
15306       /* It is simpler and generates better code to have only TRUTH_*_EXPR
15307          or comparison expressions as truth values at this level.  */
15308 #if 0
15309     case COMPONENT_REF:
15310       /* A one-bit unsigned bit-field is already acceptable.  */
15311       if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr, 1)))
15312           && TREE_UNSIGNED (TREE_OPERAND (expr, 1)))
15313         return expr;
15314       break;
15315 #endif
15316
15317     case EQ_EXPR:
15318       /* It is simpler and generates better code to have only TRUTH_*_EXPR
15319          or comparison expressions as truth values at this level.  */
15320 #if 0
15321       if (integer_zerop (TREE_OPERAND (expr, 1)))
15322         return build_unary_op (TRUTH_NOT_EXPR, TREE_OPERAND (expr, 0), 0);
15323 #endif
15324     case NE_EXPR: case LE_EXPR: case GE_EXPR: case LT_EXPR: case GT_EXPR:
15325     case TRUTH_ANDIF_EXPR:
15326     case TRUTH_ORIF_EXPR:
15327     case TRUTH_AND_EXPR:
15328     case TRUTH_OR_EXPR:
15329     case TRUTH_XOR_EXPR:
15330       TREE_TYPE (expr) = integer_type_node;
15331       return expr;
15332
15333     case ERROR_MARK:
15334       return expr;
15335
15336     case INTEGER_CST:
15337       return integer_zerop (expr) ? integer_zero_node : integer_one_node;
15338
15339     case REAL_CST:
15340       return real_zerop (expr) ? integer_zero_node : integer_one_node;
15341
15342     case ADDR_EXPR:
15343       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 0)))
15344         return build (COMPOUND_EXPR, integer_type_node,
15345                       TREE_OPERAND (expr, 0), integer_one_node);
15346       else
15347         return integer_one_node;
15348
15349     case COMPLEX_EXPR:
15350       return ffecom_2 ((TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1))
15351                         ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
15352                        integer_type_node,
15353                        truthvalue_conversion (TREE_OPERAND (expr, 0)),
15354                        truthvalue_conversion (TREE_OPERAND (expr, 1)));
15355
15356     case NEGATE_EXPR:
15357     case ABS_EXPR:
15358     case FLOAT_EXPR:
15359     case FFS_EXPR:
15360       /* These don't change whether an object is non-zero or zero.  */
15361       return truthvalue_conversion (TREE_OPERAND (expr, 0));
15362
15363     case LROTATE_EXPR:
15364     case RROTATE_EXPR:
15365       /* These don't change whether an object is zero or non-zero, but
15366          we can't ignore them if their second arg has side-effects.  */
15367       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1)))
15368         return build (COMPOUND_EXPR, integer_type_node, TREE_OPERAND (expr, 1),
15369                       truthvalue_conversion (TREE_OPERAND (expr, 0)));
15370       else
15371         return truthvalue_conversion (TREE_OPERAND (expr, 0));
15372
15373     case COND_EXPR:
15374       /* Distribute the conversion into the arms of a COND_EXPR.  */
15375       return fold (build (COND_EXPR, integer_type_node, TREE_OPERAND (expr, 0),
15376                           truthvalue_conversion (TREE_OPERAND (expr, 1)),
15377                           truthvalue_conversion (TREE_OPERAND (expr, 2))));
15378
15379     case CONVERT_EXPR:
15380       /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
15381          since that affects how `default_conversion' will behave.  */
15382       if (TREE_CODE (TREE_TYPE (expr)) == REFERENCE_TYPE
15383           || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) == REFERENCE_TYPE)
15384         break;
15385       /* fall through... */
15386     case NOP_EXPR:
15387       /* If this is widening the argument, we can ignore it.  */
15388       if (TYPE_PRECISION (TREE_TYPE (expr))
15389           >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr, 0))))
15390         return truthvalue_conversion (TREE_OPERAND (expr, 0));
15391       break;
15392
15393     case MINUS_EXPR:
15394       /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize
15395          this case.  */
15396       if (TARGET_FLOAT_FORMAT == IEEE_FLOAT_FORMAT
15397           && TREE_CODE (TREE_TYPE (expr)) == REAL_TYPE)
15398         break;
15399       /* fall through... */
15400     case BIT_XOR_EXPR:
15401       /* This and MINUS_EXPR can be changed into a comparison of the
15402          two objects.  */
15403       if (TREE_TYPE (TREE_OPERAND (expr, 0))
15404           == TREE_TYPE (TREE_OPERAND (expr, 1)))
15405         return ffecom_2 (NE_EXPR, integer_type_node,
15406                          TREE_OPERAND (expr, 0),
15407                          TREE_OPERAND (expr, 1));
15408       return ffecom_2 (NE_EXPR, integer_type_node,
15409                        TREE_OPERAND (expr, 0),
15410                        fold (build1 (NOP_EXPR,
15411                                      TREE_TYPE (TREE_OPERAND (expr, 0)),
15412                                      TREE_OPERAND (expr, 1))));
15413
15414     case BIT_AND_EXPR:
15415       if (integer_onep (TREE_OPERAND (expr, 1)))
15416         return expr;
15417       break;
15418
15419     case MODIFY_EXPR:
15420 #if 0                           /* No such thing in Fortran. */
15421       if (warn_parentheses && C_EXP_ORIGINAL_CODE (expr) == MODIFY_EXPR)
15422         warning ("suggest parentheses around assignment used as truth value");
15423 #endif
15424       break;
15425
15426     default:
15427       break;
15428     }
15429
15430   if (TREE_CODE (TREE_TYPE (expr)) == COMPLEX_TYPE)
15431     return (ffecom_2
15432             ((TREE_SIDE_EFFECTS (expr)
15433               ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
15434              integer_type_node,
15435              truthvalue_conversion (ffecom_1 (REALPART_EXPR,
15436                                               TREE_TYPE (TREE_TYPE (expr)),
15437                                               expr)),
15438              truthvalue_conversion (ffecom_1 (IMAGPART_EXPR,
15439                                               TREE_TYPE (TREE_TYPE (expr)),
15440                                               expr))));
15441
15442   return ffecom_2 (NE_EXPR, integer_type_node,
15443                    expr,
15444                    convert (TREE_TYPE (expr), integer_zero_node));
15445 }
15446
15447 tree
15448 type_for_mode (mode, unsignedp)
15449      enum machine_mode mode;
15450      int unsignedp;
15451 {
15452   int i;
15453   int j;
15454   tree t;
15455
15456   if (mode == TYPE_MODE (integer_type_node))
15457     return unsignedp ? unsigned_type_node : integer_type_node;
15458
15459   if (mode == TYPE_MODE (signed_char_type_node))
15460     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15461
15462   if (mode == TYPE_MODE (short_integer_type_node))
15463     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15464
15465   if (mode == TYPE_MODE (long_integer_type_node))
15466     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15467
15468   if (mode == TYPE_MODE (long_long_integer_type_node))
15469     return unsignedp ? long_long_unsigned_type_node : long_long_integer_type_node;
15470
15471 #if HOST_BITS_PER_WIDE_INT >= 64
15472   if (mode == TYPE_MODE (intTI_type_node))
15473     return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
15474 #endif
15475
15476   if (mode == TYPE_MODE (float_type_node))
15477     return float_type_node;
15478
15479   if (mode == TYPE_MODE (double_type_node))
15480     return double_type_node;
15481
15482   if (mode == TYPE_MODE (build_pointer_type (char_type_node)))
15483     return build_pointer_type (char_type_node);
15484
15485   if (mode == TYPE_MODE (build_pointer_type (integer_type_node)))
15486     return build_pointer_type (integer_type_node);
15487
15488   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
15489     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
15490       {
15491         if (((t = ffecom_tree_type[i][j]) != NULL_TREE)
15492             && (mode == TYPE_MODE (t)))
15493           {
15494             if ((i == FFEINFO_basictypeINTEGER) && unsignedp)
15495               return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][j];
15496             else
15497               return t;
15498           }
15499       }
15500
15501   return 0;
15502 }
15503
15504 tree
15505 type_for_size (bits, unsignedp)
15506      unsigned bits;
15507      int unsignedp;
15508 {
15509   ffeinfoKindtype kt;
15510   tree type_node;
15511
15512   if (bits == TYPE_PRECISION (integer_type_node))
15513     return unsignedp ? unsigned_type_node : integer_type_node;
15514
15515   if (bits == TYPE_PRECISION (signed_char_type_node))
15516     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15517
15518   if (bits == TYPE_PRECISION (short_integer_type_node))
15519     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15520
15521   if (bits == TYPE_PRECISION (long_integer_type_node))
15522     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15523
15524   if (bits == TYPE_PRECISION (long_long_integer_type_node))
15525     return (unsignedp ? long_long_unsigned_type_node
15526             : long_long_integer_type_node);
15527
15528   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15529     {
15530       type_node = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15531
15532       if ((type_node != NULL_TREE) && (bits == TYPE_PRECISION (type_node)))
15533         return unsignedp ? ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]
15534           : type_node;
15535     }
15536
15537   return 0;
15538 }
15539
15540 tree
15541 unsigned_type (type)
15542      tree type;
15543 {
15544   tree type1 = TYPE_MAIN_VARIANT (type);
15545   ffeinfoKindtype kt;
15546   tree type2;
15547
15548   if (type1 == signed_char_type_node || type1 == char_type_node)
15549     return unsigned_char_type_node;
15550   if (type1 == integer_type_node)
15551     return unsigned_type_node;
15552   if (type1 == short_integer_type_node)
15553     return short_unsigned_type_node;
15554   if (type1 == long_integer_type_node)
15555     return long_unsigned_type_node;
15556   if (type1 == long_long_integer_type_node)
15557     return long_long_unsigned_type_node;
15558 #if 0   /* gcc/c-* files only */
15559   if (type1 == intDI_type_node)
15560     return unsigned_intDI_type_node;
15561   if (type1 == intSI_type_node)
15562     return unsigned_intSI_type_node;
15563   if (type1 == intHI_type_node)
15564     return unsigned_intHI_type_node;
15565   if (type1 == intQI_type_node)
15566     return unsigned_intQI_type_node;
15567 #endif
15568
15569   type2 = type_for_size (TYPE_PRECISION (type1), 1);
15570   if (type2 != NULL_TREE)
15571     return type2;
15572
15573   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15574     {
15575       type2 = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15576
15577       if (type1 == type2)
15578         return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
15579     }
15580
15581   return type;
15582 }
15583
15584 void
15585 lang_mark_tree (t)
15586      union tree_node *t ATTRIBUTE_UNUSED;
15587 {
15588   if (TREE_CODE (t) == IDENTIFIER_NODE)
15589     {
15590       struct lang_identifier *i = (struct lang_identifier *) t;
15591       ggc_mark_tree (IDENTIFIER_GLOBAL_VALUE (i));
15592       ggc_mark_tree (IDENTIFIER_LOCAL_VALUE (i));
15593       ggc_mark_tree (IDENTIFIER_LABEL_VALUE (i));
15594     }
15595   else if (TYPE_P (t) && TYPE_LANG_SPECIFIC (t))
15596     ggc_mark (TYPE_LANG_SPECIFIC (t));
15597 }
15598
15599 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
15600 \f
15601 #if FFECOM_GCC_INCLUDE
15602
15603 /* From gcc/cccp.c, the code to handle -I.  */
15604
15605 /* Skip leading "./" from a directory name.
15606    This may yield the empty string, which represents the current directory.  */
15607
15608 static const char *
15609 skip_redundant_dir_prefix (const char *dir)
15610 {
15611   while (dir[0] == '.' && dir[1] == '/')
15612     for (dir += 2; *dir == '/'; dir++)
15613       continue;
15614   if (dir[0] == '.' && !dir[1])
15615     dir++;
15616   return dir;
15617 }
15618
15619 /* The file_name_map structure holds a mapping of file names for a
15620    particular directory.  This mapping is read from the file named
15621    FILE_NAME_MAP_FILE in that directory.  Such a file can be used to
15622    map filenames on a file system with severe filename restrictions,
15623    such as DOS.  The format of the file name map file is just a series
15624    of lines with two tokens on each line.  The first token is the name
15625    to map, and the second token is the actual name to use.  */
15626
15627 struct file_name_map
15628 {
15629   struct file_name_map *map_next;
15630   char *map_from;
15631   char *map_to;
15632 };
15633
15634 #define FILE_NAME_MAP_FILE "header.gcc"
15635
15636 /* Current maximum length of directory names in the search path
15637    for include files.  (Altered as we get more of them.)  */
15638
15639 static int max_include_len = 0;
15640
15641 struct file_name_list
15642   {
15643     struct file_name_list *next;
15644     char *fname;
15645     /* Mapping of file names for this directory.  */
15646     struct file_name_map *name_map;
15647     /* Non-zero if name_map is valid.  */
15648     int got_name_map;
15649   };
15650
15651 static struct file_name_list *include = NULL;   /* First dir to search */
15652 static struct file_name_list *last_include = NULL;      /* Last in chain */
15653
15654 /* I/O buffer structure.
15655    The `fname' field is nonzero for source files and #include files
15656    and for the dummy text used for -D and -U.
15657    It is zero for rescanning results of macro expansion
15658    and for expanding macro arguments.  */
15659 #define INPUT_STACK_MAX 400
15660 static struct file_buf {
15661   const char *fname;
15662   /* Filename specified with #line command.  */
15663   const char *nominal_fname;
15664   /* Record where in the search path this file was found.
15665      For #include_next.  */
15666   struct file_name_list *dir;
15667   ffewhereLine line;
15668   ffewhereColumn column;
15669 } instack[INPUT_STACK_MAX];
15670
15671 static int last_error_tick = 0;    /* Incremented each time we print it.  */
15672 static int input_file_stack_tick = 0;  /* Incremented when status changes.  */
15673
15674 /* Current nesting level of input sources.
15675    `instack[indepth]' is the level currently being read.  */
15676 static int indepth = -1;
15677
15678 typedef struct file_buf FILE_BUF;
15679
15680 typedef unsigned char U_CHAR;
15681
15682 /* table to tell if char can be part of a C identifier. */
15683 U_CHAR is_idchar[256];
15684 /* table to tell if char can be first char of a c identifier. */
15685 U_CHAR is_idstart[256];
15686 /* table to tell if c is horizontal space.  */
15687 U_CHAR is_hor_space[256];
15688 /* table to tell if c is horizontal or vertical space.  */
15689 static U_CHAR is_space[256];
15690
15691 #define SKIP_WHITE_SPACE(p) do { while (is_hor_space[*p]) p++; } while (0)
15692 #define SKIP_ALL_WHITE_SPACE(p) do { while (is_space[*p]) p++; } while (0)
15693
15694 /* Nonzero means -I- has been seen,
15695    so don't look for #include "foo" the source-file directory.  */
15696 static int ignore_srcdir;
15697
15698 #ifndef INCLUDE_LEN_FUDGE
15699 #define INCLUDE_LEN_FUDGE 0
15700 #endif
15701
15702 static void append_include_chain (struct file_name_list *first,
15703                                   struct file_name_list *last);
15704 static FILE *open_include_file (char *filename,
15705                                 struct file_name_list *searchptr);
15706 static void print_containing_files (ffebadSeverity sev);
15707 static const char *skip_redundant_dir_prefix (const char *);
15708 static char *read_filename_string (int ch, FILE *f);
15709 static struct file_name_map *read_name_map (const char *dirname);
15710
15711 /* Append a chain of `struct file_name_list's
15712    to the end of the main include chain.
15713    FIRST is the beginning of the chain to append, and LAST is the end.  */
15714
15715 static void
15716 append_include_chain (first, last)
15717      struct file_name_list *first, *last;
15718 {
15719   struct file_name_list *dir;
15720
15721   if (!first || !last)
15722     return;
15723
15724   if (include == 0)
15725     include = first;
15726   else
15727     last_include->next = first;
15728
15729   for (dir = first; ; dir = dir->next) {
15730     int len = strlen (dir->fname) + INCLUDE_LEN_FUDGE;
15731     if (len > max_include_len)
15732       max_include_len = len;
15733     if (dir == last)
15734       break;
15735   }
15736
15737   last->next = NULL;
15738   last_include = last;
15739 }
15740
15741 /* Try to open include file FILENAME.  SEARCHPTR is the directory
15742    being tried from the include file search path.  This function maps
15743    filenames on file systems based on information read by
15744    read_name_map.  */
15745
15746 static FILE *
15747 open_include_file (filename, searchptr)
15748      char *filename;
15749      struct file_name_list *searchptr;
15750 {
15751   register struct file_name_map *map;
15752   register char *from;
15753   char *p, *dir;
15754
15755   if (searchptr && ! searchptr->got_name_map)
15756     {
15757       searchptr->name_map = read_name_map (searchptr->fname
15758                                            ? searchptr->fname : ".");
15759       searchptr->got_name_map = 1;
15760     }
15761
15762   /* First check the mapping for the directory we are using.  */
15763   if (searchptr && searchptr->name_map)
15764     {
15765       from = filename;
15766       if (searchptr->fname)
15767         from += strlen (searchptr->fname) + 1;
15768       for (map = searchptr->name_map; map; map = map->map_next)
15769         {
15770           if (! strcmp (map->map_from, from))
15771             {
15772               /* Found a match.  */
15773               return fopen (map->map_to, "r");
15774             }
15775         }
15776     }
15777
15778   /* Try to find a mapping file for the particular directory we are
15779      looking in.  Thus #include <sys/types.h> will look up sys/types.h
15780      in /usr/include/header.gcc and look up types.h in
15781      /usr/include/sys/header.gcc.  */
15782   p = strrchr (filename, '/');
15783 #ifdef DIR_SEPARATOR
15784   if (! p) p = strrchr (filename, DIR_SEPARATOR);
15785   else {
15786     char *tmp = strrchr (filename, DIR_SEPARATOR);
15787     if (tmp != NULL && tmp > p) p = tmp;
15788   }
15789 #endif
15790   if (! p)
15791     p = filename;
15792   if (searchptr
15793       && searchptr->fname
15794       && strlen (searchptr->fname) == (size_t) (p - filename)
15795       && ! strncmp (searchptr->fname, filename, (int) (p - filename)))
15796     {
15797       /* FILENAME is in SEARCHPTR, which we've already checked.  */
15798       return fopen (filename, "r");
15799     }
15800
15801   if (p == filename)
15802     {
15803       from = filename;
15804       map = read_name_map (".");
15805     }
15806   else
15807     {
15808       dir = (char *) xmalloc (p - filename + 1);
15809       memcpy (dir, filename, p - filename);
15810       dir[p - filename] = '\0';
15811       from = p + 1;
15812       map = read_name_map (dir);
15813       free (dir);
15814     }
15815   for (; map; map = map->map_next)
15816     if (! strcmp (map->map_from, from))
15817       return fopen (map->map_to, "r");
15818
15819   return fopen (filename, "r");
15820 }
15821
15822 /* Print the file names and line numbers of the #include
15823    commands which led to the current file.  */
15824
15825 static void
15826 print_containing_files (ffebadSeverity sev)
15827 {
15828   FILE_BUF *ip = NULL;
15829   int i;
15830   int first = 1;
15831   const char *str1;
15832   const char *str2;
15833
15834   /* If stack of files hasn't changed since we last printed
15835      this info, don't repeat it.  */
15836   if (last_error_tick == input_file_stack_tick)
15837     return;
15838
15839   for (i = indepth; i >= 0; i--)
15840     if (instack[i].fname != NULL) {
15841       ip = &instack[i];
15842       break;
15843     }
15844
15845   /* Give up if we don't find a source file.  */
15846   if (ip == NULL)
15847     return;
15848
15849   /* Find the other, outer source files.  */
15850   for (i--; i >= 0; i--)
15851     if (instack[i].fname != NULL)
15852       {
15853         ip = &instack[i];
15854         if (first)
15855           {
15856             first = 0;
15857             str1 = "In file included";
15858           }
15859         else
15860           {
15861             str1 = "...          ...";
15862           }
15863
15864         if (i == 1)
15865           str2 = ":";
15866         else
15867           str2 = "";
15868
15869         ffebad_start_msg ("%A from %B at %0%C", sev);
15870         ffebad_here (0, ip->line, ip->column);
15871         ffebad_string (str1);
15872         ffebad_string (ip->nominal_fname);
15873         ffebad_string (str2);
15874         ffebad_finish ();
15875       }
15876
15877   /* Record we have printed the status as of this time.  */
15878   last_error_tick = input_file_stack_tick;
15879 }
15880
15881 /* Read a space delimited string of unlimited length from a stdio
15882    file.  */
15883
15884 static char *
15885 read_filename_string (ch, f)
15886      int ch;
15887      FILE *f;
15888 {
15889   char *alloc, *set;
15890   int len;
15891
15892   len = 20;
15893   set = alloc = xmalloc (len + 1);
15894   if (! is_space[ch])
15895     {
15896       *set++ = ch;
15897       while ((ch = getc (f)) != EOF && ! is_space[ch])
15898         {
15899           if (set - alloc == len)
15900             {
15901               len *= 2;
15902               alloc = xrealloc (alloc, len + 1);
15903               set = alloc + len / 2;
15904             }
15905           *set++ = ch;
15906         }
15907     }
15908   *set = '\0';
15909   ungetc (ch, f);
15910   return alloc;
15911 }
15912
15913 /* Read the file name map file for DIRNAME.  */
15914
15915 static struct file_name_map *
15916 read_name_map (dirname)
15917      const char *dirname;
15918 {
15919   /* This structure holds a linked list of file name maps, one per
15920      directory.  */
15921   struct file_name_map_list
15922     {
15923       struct file_name_map_list *map_list_next;
15924       char *map_list_name;
15925       struct file_name_map *map_list_map;
15926     };
15927   static struct file_name_map_list *map_list;
15928   register struct file_name_map_list *map_list_ptr;
15929   char *name;
15930   FILE *f;
15931   size_t dirlen;
15932   int separator_needed;
15933
15934   dirname = skip_redundant_dir_prefix (dirname);
15935
15936   for (map_list_ptr = map_list; map_list_ptr;
15937        map_list_ptr = map_list_ptr->map_list_next)
15938     if (! strcmp (map_list_ptr->map_list_name, dirname))
15939       return map_list_ptr->map_list_map;
15940
15941   map_list_ptr = ((struct file_name_map_list *)
15942                   xmalloc (sizeof (struct file_name_map_list)));
15943   map_list_ptr->map_list_name = xstrdup (dirname);
15944   map_list_ptr->map_list_map = NULL;
15945
15946   dirlen = strlen (dirname);
15947   separator_needed = dirlen != 0 && dirname[dirlen - 1] != '/';
15948   name = (char *) xmalloc (dirlen + strlen (FILE_NAME_MAP_FILE) + 2);
15949   strcpy (name, dirname);
15950   name[dirlen] = '/';
15951   strcpy (name + dirlen + separator_needed, FILE_NAME_MAP_FILE);
15952   f = fopen (name, "r");
15953   free (name);
15954   if (!f)
15955     map_list_ptr->map_list_map = NULL;
15956   else
15957     {
15958       int ch;
15959
15960       while ((ch = getc (f)) != EOF)
15961         {
15962           char *from, *to;
15963           struct file_name_map *ptr;
15964
15965           if (is_space[ch])
15966             continue;
15967           from = read_filename_string (ch, f);
15968           while ((ch = getc (f)) != EOF && is_hor_space[ch])
15969             ;
15970           to = read_filename_string (ch, f);
15971
15972           ptr = ((struct file_name_map *)
15973                  xmalloc (sizeof (struct file_name_map)));
15974           ptr->map_from = from;
15975
15976           /* Make the real filename absolute.  */
15977           if (*to == '/')
15978             ptr->map_to = to;
15979           else
15980             {
15981               ptr->map_to = xmalloc (dirlen + strlen (to) + 2);
15982               strcpy (ptr->map_to, dirname);
15983               ptr->map_to[dirlen] = '/';
15984               strcpy (ptr->map_to + dirlen + separator_needed, to);
15985               free (to);
15986             }
15987
15988           ptr->map_next = map_list_ptr->map_list_map;
15989           map_list_ptr->map_list_map = ptr;
15990
15991           while ((ch = getc (f)) != '\n')
15992             if (ch == EOF)
15993               break;
15994         }
15995       fclose (f);
15996     }
15997
15998   map_list_ptr->map_list_next = map_list;
15999   map_list = map_list_ptr;
16000
16001   return map_list_ptr->map_list_map;
16002 }
16003
16004 static void
16005 ffecom_file_ (const char *name)
16006 {
16007   FILE_BUF *fp;
16008
16009   /* Do partial setup of input buffer for the sake of generating
16010      early #line directives (when -g is in effect).  */
16011
16012   fp = &instack[++indepth];
16013   memset ((char *) fp, 0, sizeof (FILE_BUF));
16014   if (name == NULL)
16015     name = "";
16016   fp->nominal_fname = fp->fname = name;
16017 }
16018
16019 /* Initialize syntactic classifications of characters.  */
16020
16021 static void
16022 ffecom_initialize_char_syntax_ ()
16023 {
16024   register int i;
16025
16026   /*
16027    * Set up is_idchar and is_idstart tables.  These should be
16028    * faster than saying (is_alpha (c) || c == '_'), etc.
16029    * Set up these things before calling any routines tthat
16030    * refer to them.
16031    */
16032   for (i = 'a'; i <= 'z'; i++) {
16033     is_idchar[i - 'a' + 'A'] = 1;
16034     is_idchar[i] = 1;
16035     is_idstart[i - 'a' + 'A'] = 1;
16036     is_idstart[i] = 1;
16037   }
16038   for (i = '0'; i <= '9'; i++)
16039     is_idchar[i] = 1;
16040   is_idchar['_'] = 1;
16041   is_idstart['_'] = 1;
16042
16043   /* horizontal space table */
16044   is_hor_space[' '] = 1;
16045   is_hor_space['\t'] = 1;
16046   is_hor_space['\v'] = 1;
16047   is_hor_space['\f'] = 1;
16048   is_hor_space['\r'] = 1;
16049
16050   is_space[' '] = 1;
16051   is_space['\t'] = 1;
16052   is_space['\v'] = 1;
16053   is_space['\f'] = 1;
16054   is_space['\n'] = 1;
16055   is_space['\r'] = 1;
16056 }
16057
16058 static void
16059 ffecom_close_include_ (FILE *f)
16060 {
16061   fclose (f);
16062
16063   indepth--;
16064   input_file_stack_tick++;
16065
16066   ffewhere_line_kill (instack[indepth].line);
16067   ffewhere_column_kill (instack[indepth].column);
16068 }
16069
16070 static int
16071 ffecom_decode_include_option_ (char *spec)
16072 {
16073   struct file_name_list *dirtmp;
16074
16075   if (! ignore_srcdir && !strcmp (spec, "-"))
16076     ignore_srcdir = 1;
16077   else
16078     {
16079       dirtmp = (struct file_name_list *)
16080         xmalloc (sizeof (struct file_name_list));
16081       dirtmp->next = 0;         /* New one goes on the end */
16082       if (spec[0] != 0)
16083         dirtmp->fname = spec;
16084       else
16085         fatal ("Directory name must immediately follow -I option with no intervening spaces, as in `-Idir', not `-I dir'");
16086       dirtmp->got_name_map = 0;
16087       append_include_chain (dirtmp, dirtmp);
16088     }
16089   return 1;
16090 }
16091
16092 /* Open INCLUDEd file.  */
16093
16094 static FILE *
16095 ffecom_open_include_ (char *name, ffewhereLine l, ffewhereColumn c)
16096 {
16097   char *fbeg = name;
16098   size_t flen = strlen (fbeg);
16099   struct file_name_list *search_start = include; /* Chain of dirs to search */
16100   struct file_name_list dsp[1]; /* First in chain, if #include "..." */
16101   struct file_name_list *searchptr = 0;
16102   char *fname;          /* Dynamically allocated fname buffer */
16103   FILE *f;
16104   FILE_BUF *fp;
16105
16106   if (flen == 0)
16107     return NULL;
16108
16109   dsp[0].fname = NULL;
16110
16111   /* If -I- was specified, don't search current dir, only spec'd ones. */
16112   if (!ignore_srcdir)
16113     {
16114       for (fp = &instack[indepth]; fp >= instack; fp--)
16115         {
16116           int n;
16117           char *ep;
16118           const char *nam;
16119
16120           if ((nam = fp->nominal_fname) != NULL)
16121             {
16122               /* Found a named file.  Figure out dir of the file,
16123                  and put it in front of the search list.  */
16124               dsp[0].next = search_start;
16125               search_start = dsp;
16126 #ifndef VMS
16127               ep = strrchr (nam, '/');
16128 #ifdef DIR_SEPARATOR
16129             if (ep == NULL) ep = strrchr (nam, DIR_SEPARATOR);
16130             else {
16131               char *tmp = strrchr (nam, DIR_SEPARATOR);
16132               if (tmp != NULL && tmp > ep) ep = tmp;
16133             }
16134 #endif
16135 #else                           /* VMS */
16136               ep = strrchr (nam, ']');
16137               if (ep == NULL) ep = strrchr (nam, '>');
16138               if (ep == NULL) ep = strrchr (nam, ':');
16139               if (ep != NULL) ep++;
16140 #endif                          /* VMS */
16141               if (ep != NULL)
16142                 {
16143                   n = ep - nam;
16144                   dsp[0].fname = (char *) xmalloc (n + 1);
16145                   strncpy (dsp[0].fname, nam, n);
16146                   dsp[0].fname[n] = '\0';
16147                   if (n + INCLUDE_LEN_FUDGE > max_include_len)
16148                     max_include_len = n + INCLUDE_LEN_FUDGE;
16149                 }
16150               else
16151                 dsp[0].fname = NULL; /* Current directory */
16152               dsp[0].got_name_map = 0;
16153               break;
16154             }
16155         }
16156     }
16157
16158   /* Allocate this permanently, because it gets stored in the definitions
16159      of macros.  */
16160   fname = xmalloc (max_include_len + flen + 4);
16161   /* + 2 above for slash and terminating null.  */
16162   /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED
16163      for g77 yet).  */
16164
16165   /* If specified file name is absolute, just open it.  */
16166
16167   if (*fbeg == '/'
16168 #ifdef DIR_SEPARATOR
16169       || *fbeg == DIR_SEPARATOR
16170 #endif
16171       )
16172     {
16173       strncpy (fname, (char *) fbeg, flen);
16174       fname[flen] = 0;
16175       f = open_include_file (fname, NULL_PTR);
16176     }
16177   else
16178     {
16179       f = NULL;
16180
16181       /* Search directory path, trying to open the file.
16182          Copy each filename tried into FNAME.  */
16183
16184       for (searchptr = search_start; searchptr; searchptr = searchptr->next)
16185         {
16186           if (searchptr->fname)
16187             {
16188               /* The empty string in a search path is ignored.
16189                  This makes it possible to turn off entirely
16190                  a standard piece of the list.  */
16191               if (searchptr->fname[0] == 0)
16192                 continue;
16193               strcpy (fname, skip_redundant_dir_prefix (searchptr->fname));
16194               if (fname[0] && fname[strlen (fname) - 1] != '/')
16195                 strcat (fname, "/");
16196               fname[strlen (fname) + flen] = 0;
16197             }
16198           else
16199             fname[0] = 0;
16200
16201           strncat (fname, fbeg, flen);
16202 #ifdef VMS
16203           /* Change this 1/2 Unix 1/2 VMS file specification into a
16204              full VMS file specification */
16205           if (searchptr->fname && (searchptr->fname[0] != 0))
16206             {
16207               /* Fix up the filename */
16208               hack_vms_include_specification (fname);
16209             }
16210           else
16211             {
16212               /* This is a normal VMS filespec, so use it unchanged.  */
16213               strncpy (fname, (char *) fbeg, flen);
16214               fname[flen] = 0;
16215 #if 0   /* Not for g77.  */
16216               /* if it's '#include filename', add the missing .h */
16217               if (strchr (fname, '.') == NULL)
16218                 strcat (fname, ".h");
16219 #endif
16220             }
16221 #endif /* VMS */
16222           f = open_include_file (fname, searchptr);
16223 #ifdef EACCES
16224           if (f == NULL && errno == EACCES)
16225             {
16226               print_containing_files (FFEBAD_severityWARNING);
16227               ffebad_start_msg ("At %0, INCLUDE file %A exists, but is not readable",
16228                                 FFEBAD_severityWARNING);
16229               ffebad_string (fname);
16230               ffebad_here (0, l, c);
16231               ffebad_finish ();
16232             }
16233 #endif
16234           if (f != NULL)
16235             break;
16236         }
16237     }
16238
16239   if (f == NULL)
16240     {
16241       /* A file that was not found.  */
16242
16243       strncpy (fname, (char *) fbeg, flen);
16244       fname[flen] = 0;
16245       print_containing_files (ffebad_severity (FFEBAD_OPEN_INCLUDE));
16246       ffebad_start (FFEBAD_OPEN_INCLUDE);
16247       ffebad_here (0, l, c);
16248       ffebad_string (fname);
16249       ffebad_finish ();
16250     }
16251
16252   if (dsp[0].fname != NULL)
16253     free (dsp[0].fname);
16254
16255   if (f == NULL)
16256     return NULL;
16257
16258   if (indepth >= (INPUT_STACK_MAX - 1))
16259     {
16260       print_containing_files (FFEBAD_severityFATAL);
16261       ffebad_start_msg ("At %0, INCLUDE nesting too deep",
16262                         FFEBAD_severityFATAL);
16263       ffebad_string (fname);
16264       ffebad_here (0, l, c);
16265       ffebad_finish ();
16266       return NULL;
16267     }
16268
16269   instack[indepth].line = ffewhere_line_use (l);
16270   instack[indepth].column = ffewhere_column_use (c);
16271
16272   fp = &instack[indepth + 1];
16273   memset ((char *) fp, 0, sizeof (FILE_BUF));
16274   fp->nominal_fname = fp->fname = fname;
16275   fp->dir = searchptr;
16276
16277   indepth++;
16278   input_file_stack_tick++;
16279
16280   return f;
16281 }
16282 #endif  /* FFECOM_GCC_INCLUDE */
16283
16284 /**INDENT* (Do not reformat this comment even with -fca option.)
16285    Data-gathering files: Given the source file listed below, compiled with
16286    f2c I obtained the output file listed after that, and from the output
16287    file I derived the above code.
16288
16289 -------- (begin input file to f2c)
16290         implicit none
16291         character*10 A1,A2
16292         complex C1,C2
16293         integer I1,I2
16294         real R1,R2
16295         double precision D1,D2
16296 C
16297         call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2)
16298 c /
16299         call fooI(I1/I2)
16300         call fooR(R1/I1)
16301         call fooD(D1/I1)
16302         call fooC(C1/I1)
16303         call fooR(R1/R2)
16304         call fooD(R1/D1)
16305         call fooD(D1/D2)
16306         call fooD(D1/R1)
16307         call fooC(C1/C2)
16308         call fooC(C1/R1)
16309         call fooZ(C1/D1)
16310 c **
16311         call fooI(I1**I2)
16312         call fooR(R1**I1)
16313         call fooD(D1**I1)
16314         call fooC(C1**I1)
16315         call fooR(R1**R2)
16316         call fooD(R1**D1)
16317         call fooD(D1**D2)
16318         call fooD(D1**R1)
16319         call fooC(C1**C2)
16320         call fooC(C1**R1)
16321         call fooZ(C1**D1)
16322 c FFEINTRIN_impABS
16323         call fooR(ABS(R1))
16324 c FFEINTRIN_impACOS
16325         call fooR(ACOS(R1))
16326 c FFEINTRIN_impAIMAG
16327         call fooR(AIMAG(C1))
16328 c FFEINTRIN_impAINT
16329         call fooR(AINT(R1))
16330 c FFEINTRIN_impALOG
16331         call fooR(ALOG(R1))
16332 c FFEINTRIN_impALOG10
16333         call fooR(ALOG10(R1))
16334 c FFEINTRIN_impAMAX0
16335         call fooR(AMAX0(I1,I2))
16336 c FFEINTRIN_impAMAX1
16337         call fooR(AMAX1(R1,R2))
16338 c FFEINTRIN_impAMIN0
16339         call fooR(AMIN0(I1,I2))
16340 c FFEINTRIN_impAMIN1
16341         call fooR(AMIN1(R1,R2))
16342 c FFEINTRIN_impAMOD
16343         call fooR(AMOD(R1,R2))
16344 c FFEINTRIN_impANINT
16345         call fooR(ANINT(R1))
16346 c FFEINTRIN_impASIN
16347         call fooR(ASIN(R1))
16348 c FFEINTRIN_impATAN
16349         call fooR(ATAN(R1))
16350 c FFEINTRIN_impATAN2
16351         call fooR(ATAN2(R1,R2))
16352 c FFEINTRIN_impCABS
16353         call fooR(CABS(C1))
16354 c FFEINTRIN_impCCOS
16355         call fooC(CCOS(C1))
16356 c FFEINTRIN_impCEXP
16357         call fooC(CEXP(C1))
16358 c FFEINTRIN_impCHAR
16359         call fooA(CHAR(I1))
16360 c FFEINTRIN_impCLOG
16361         call fooC(CLOG(C1))
16362 c FFEINTRIN_impCONJG
16363         call fooC(CONJG(C1))
16364 c FFEINTRIN_impCOS
16365         call fooR(COS(R1))
16366 c FFEINTRIN_impCOSH
16367         call fooR(COSH(R1))
16368 c FFEINTRIN_impCSIN
16369         call fooC(CSIN(C1))
16370 c FFEINTRIN_impCSQRT
16371         call fooC(CSQRT(C1))
16372 c FFEINTRIN_impDABS
16373         call fooD(DABS(D1))
16374 c FFEINTRIN_impDACOS
16375         call fooD(DACOS(D1))
16376 c FFEINTRIN_impDASIN
16377         call fooD(DASIN(D1))
16378 c FFEINTRIN_impDATAN
16379         call fooD(DATAN(D1))
16380 c FFEINTRIN_impDATAN2
16381         call fooD(DATAN2(D1,D2))
16382 c FFEINTRIN_impDCOS
16383         call fooD(DCOS(D1))
16384 c FFEINTRIN_impDCOSH
16385         call fooD(DCOSH(D1))
16386 c FFEINTRIN_impDDIM
16387         call fooD(DDIM(D1,D2))
16388 c FFEINTRIN_impDEXP
16389         call fooD(DEXP(D1))
16390 c FFEINTRIN_impDIM
16391         call fooR(DIM(R1,R2))
16392 c FFEINTRIN_impDINT
16393         call fooD(DINT(D1))
16394 c FFEINTRIN_impDLOG
16395         call fooD(DLOG(D1))
16396 c FFEINTRIN_impDLOG10
16397         call fooD(DLOG10(D1))
16398 c FFEINTRIN_impDMAX1
16399         call fooD(DMAX1(D1,D2))
16400 c FFEINTRIN_impDMIN1
16401         call fooD(DMIN1(D1,D2))
16402 c FFEINTRIN_impDMOD
16403         call fooD(DMOD(D1,D2))
16404 c FFEINTRIN_impDNINT
16405         call fooD(DNINT(D1))
16406 c FFEINTRIN_impDPROD
16407         call fooD(DPROD(R1,R2))
16408 c FFEINTRIN_impDSIGN
16409         call fooD(DSIGN(D1,D2))
16410 c FFEINTRIN_impDSIN
16411         call fooD(DSIN(D1))
16412 c FFEINTRIN_impDSINH
16413         call fooD(DSINH(D1))
16414 c FFEINTRIN_impDSQRT
16415         call fooD(DSQRT(D1))
16416 c FFEINTRIN_impDTAN
16417         call fooD(DTAN(D1))
16418 c FFEINTRIN_impDTANH
16419         call fooD(DTANH(D1))
16420 c FFEINTRIN_impEXP
16421         call fooR(EXP(R1))
16422 c FFEINTRIN_impIABS
16423         call fooI(IABS(I1))
16424 c FFEINTRIN_impICHAR
16425         call fooI(ICHAR(A1))
16426 c FFEINTRIN_impIDIM
16427         call fooI(IDIM(I1,I2))
16428 c FFEINTRIN_impIDNINT
16429         call fooI(IDNINT(D1))
16430 c FFEINTRIN_impINDEX
16431         call fooI(INDEX(A1,A2))
16432 c FFEINTRIN_impISIGN
16433         call fooI(ISIGN(I1,I2))
16434 c FFEINTRIN_impLEN
16435         call fooI(LEN(A1))
16436 c FFEINTRIN_impLGE
16437         call fooL(LGE(A1,A2))
16438 c FFEINTRIN_impLGT
16439         call fooL(LGT(A1,A2))
16440 c FFEINTRIN_impLLE
16441         call fooL(LLE(A1,A2))
16442 c FFEINTRIN_impLLT
16443         call fooL(LLT(A1,A2))
16444 c FFEINTRIN_impMAX0
16445         call fooI(MAX0(I1,I2))
16446 c FFEINTRIN_impMAX1
16447         call fooI(MAX1(R1,R2))
16448 c FFEINTRIN_impMIN0
16449         call fooI(MIN0(I1,I2))
16450 c FFEINTRIN_impMIN1
16451         call fooI(MIN1(R1,R2))
16452 c FFEINTRIN_impMOD
16453         call fooI(MOD(I1,I2))
16454 c FFEINTRIN_impNINT
16455         call fooI(NINT(R1))
16456 c FFEINTRIN_impSIGN
16457         call fooR(SIGN(R1,R2))
16458 c FFEINTRIN_impSIN
16459         call fooR(SIN(R1))
16460 c FFEINTRIN_impSINH
16461         call fooR(SINH(R1))
16462 c FFEINTRIN_impSQRT
16463         call fooR(SQRT(R1))
16464 c FFEINTRIN_impTAN
16465         call fooR(TAN(R1))
16466 c FFEINTRIN_impTANH
16467         call fooR(TANH(R1))
16468 c FFEINTRIN_imp_CMPLX_C
16469         call fooC(cmplx(C1,C2))
16470 c FFEINTRIN_imp_CMPLX_D
16471         call fooZ(cmplx(D1,D2))
16472 c FFEINTRIN_imp_CMPLX_I
16473         call fooC(cmplx(I1,I2))
16474 c FFEINTRIN_imp_CMPLX_R
16475         call fooC(cmplx(R1,R2))
16476 c FFEINTRIN_imp_DBLE_C
16477         call fooD(dble(C1))
16478 c FFEINTRIN_imp_DBLE_D
16479         call fooD(dble(D1))
16480 c FFEINTRIN_imp_DBLE_I
16481         call fooD(dble(I1))
16482 c FFEINTRIN_imp_DBLE_R
16483         call fooD(dble(R1))
16484 c FFEINTRIN_imp_INT_C
16485         call fooI(int(C1))
16486 c FFEINTRIN_imp_INT_D
16487         call fooI(int(D1))
16488 c FFEINTRIN_imp_INT_I
16489         call fooI(int(I1))
16490 c FFEINTRIN_imp_INT_R
16491         call fooI(int(R1))
16492 c FFEINTRIN_imp_REAL_C
16493         call fooR(real(C1))
16494 c FFEINTRIN_imp_REAL_D
16495         call fooR(real(D1))
16496 c FFEINTRIN_imp_REAL_I
16497         call fooR(real(I1))
16498 c FFEINTRIN_imp_REAL_R
16499         call fooR(real(R1))
16500 c
16501 c FFEINTRIN_imp_INT_D:
16502 c
16503 c FFEINTRIN_specIDINT
16504         call fooI(IDINT(D1))
16505 c
16506 c FFEINTRIN_imp_INT_R:
16507 c
16508 c FFEINTRIN_specIFIX
16509         call fooI(IFIX(R1))
16510 c FFEINTRIN_specINT
16511         call fooI(INT(R1))
16512 c
16513 c FFEINTRIN_imp_REAL_D:
16514 c
16515 c FFEINTRIN_specSNGL
16516         call fooR(SNGL(D1))
16517 c
16518 c FFEINTRIN_imp_REAL_I:
16519 c
16520 c FFEINTRIN_specFLOAT
16521         call fooR(FLOAT(I1))
16522 c FFEINTRIN_specREAL
16523         call fooR(REAL(I1))
16524 c
16525         end
16526 -------- (end input file to f2c)
16527
16528 -------- (begin output from providing above input file as input to:
16529 --------  `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
16530 --------     -e "s:^#.*$::g"')
16531
16532 //  -- translated by f2c (version 19950223).
16533    You must link the resulting object file with the libraries:
16534         -lf2c -lm   (in that order)
16535 //
16536
16537
16538 // f2c.h  --  Standard Fortran to C header file //
16539
16540 ///  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
16541
16542         - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
16543
16544
16545
16546
16547 // F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems //
16548 // we assume short, float are OK //
16549 typedef long int // long int // integer;
16550 typedef char *address;
16551 typedef short int shortint;
16552 typedef float real;
16553 typedef double doublereal;
16554 typedef struct { real r, i; } complex;
16555 typedef struct { doublereal r, i; } doublecomplex;
16556 typedef long int // long int // logical;
16557 typedef short int shortlogical;
16558 typedef char logical1;
16559 typedef char integer1;
16560 // typedef long long longint; // // system-dependent //
16561
16562
16563
16564
16565 // Extern is for use with -E //
16566
16567
16568
16569
16570 // I/O stuff //
16571
16572
16573
16574
16575
16576
16577
16578
16579 typedef long int // int or long int // flag;
16580 typedef long int // int or long int // ftnlen;
16581 typedef long int // int or long int // ftnint;
16582
16583
16584 //external read, write//
16585 typedef struct
16586 {       flag cierr;
16587         ftnint ciunit;
16588         flag ciend;
16589         char *cifmt;
16590         ftnint cirec;
16591 } cilist;
16592
16593 //internal read, write//
16594 typedef struct
16595 {       flag icierr;
16596         char *iciunit;
16597         flag iciend;
16598         char *icifmt;
16599         ftnint icirlen;
16600         ftnint icirnum;
16601 } icilist;
16602
16603 //open//
16604 typedef struct
16605 {       flag oerr;
16606         ftnint ounit;
16607         char *ofnm;
16608         ftnlen ofnmlen;
16609         char *osta;
16610         char *oacc;
16611         char *ofm;
16612         ftnint orl;
16613         char *oblnk;
16614 } olist;
16615
16616 //close//
16617 typedef struct
16618 {       flag cerr;
16619         ftnint cunit;
16620         char *csta;
16621 } cllist;
16622
16623 //rewind, backspace, endfile//
16624 typedef struct
16625 {       flag aerr;
16626         ftnint aunit;
16627 } alist;
16628
16629 // inquire //
16630 typedef struct
16631 {       flag inerr;
16632         ftnint inunit;
16633         char *infile;
16634         ftnlen infilen;
16635         ftnint  *inex;  //parameters in standard's order//
16636         ftnint  *inopen;
16637         ftnint  *innum;
16638         ftnint  *innamed;
16639         char    *inname;
16640         ftnlen  innamlen;
16641         char    *inacc;
16642         ftnlen  inacclen;
16643         char    *inseq;
16644         ftnlen  inseqlen;
16645         char    *indir;
16646         ftnlen  indirlen;
16647         char    *infmt;
16648         ftnlen  infmtlen;
16649         char    *inform;
16650         ftnint  informlen;
16651         char    *inunf;
16652         ftnlen  inunflen;
16653         ftnint  *inrecl;
16654         ftnint  *innrec;
16655         char    *inblank;
16656         ftnlen  inblanklen;
16657 } inlist;
16658
16659
16660
16661 union Multitype {       // for multiple entry points //
16662         integer1 g;
16663         shortint h;
16664         integer i;
16665         // longint j; //
16666         real r;
16667         doublereal d;
16668         complex c;
16669         doublecomplex z;
16670         };
16671
16672 typedef union Multitype Multitype;
16673
16674 typedef long Long;      // No longer used; formerly in Namelist //
16675
16676 struct Vardesc {        // for Namelist //
16677         char *name;
16678         char *addr;
16679         ftnlen *dims;
16680         int  type;
16681         };
16682 typedef struct Vardesc Vardesc;
16683
16684 struct Namelist {
16685         char *name;
16686         Vardesc **vars;
16687         int nvars;
16688         };
16689 typedef struct Namelist Namelist;
16690
16691
16692
16693
16694
16695
16696
16697
16698 // procedure parameter types for -A and -C++ //
16699
16700
16701
16702
16703 typedef int // Unknown procedure type // (*U_fp)();
16704 typedef shortint (*J_fp)();
16705 typedef integer (*I_fp)();
16706 typedef real (*R_fp)();
16707 typedef doublereal (*D_fp)(), (*E_fp)();
16708 typedef // Complex // void  (*C_fp)();
16709 typedef // Double Complex // void  (*Z_fp)();
16710 typedef logical (*L_fp)();
16711 typedef shortlogical (*K_fp)();
16712 typedef // Character // void  (*H_fp)();
16713 typedef // Subroutine // int (*S_fp)();
16714
16715 // E_fp is for real functions when -R is not specified //
16716 typedef void  C_f;      // complex function //
16717 typedef void  H_f;      // character function //
16718 typedef void  Z_f;      // double complex function //
16719 typedef doublereal E_f; // real function with -R not specified //
16720
16721 // undef any lower-case symbols that your C compiler predefines, e.g.: //
16722
16723
16724 // (No such symbols should be defined in a strict ANSI C compiler.
16725    We can avoid trouble with f2c-translated code by using
16726    gcc -ansi [-traditional].) //
16727
16728
16729
16730
16731
16732
16733
16734
16735
16736
16737
16738
16739
16740
16741
16742
16743
16744
16745
16746
16747
16748
16749
16750 // Main program // MAIN__()
16751 {
16752     // System generated locals //
16753     integer i__1;
16754     real r__1, r__2;
16755     doublereal d__1, d__2;
16756     complex q__1;
16757     doublecomplex z__1, z__2, z__3;
16758     logical L__1;
16759     char ch__1[1];
16760
16761     // Builtin functions //
16762     void c_div();
16763     integer pow_ii();
16764     double pow_ri(), pow_di();
16765     void pow_ci();
16766     double pow_dd();
16767     void pow_zz();
16768     double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
16769             asin(), atan(), atan2(), c_abs();
16770     void c_cos(), c_exp(), c_log(), r_cnjg();
16771     double cos(), cosh();
16772     void c_sin(), c_sqrt();
16773     double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
16774             d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
16775     integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
16776     logical l_ge(), l_gt(), l_le(), l_lt();
16777     integer i_nint();
16778     double r_sign();
16779
16780     // Local variables //
16781     extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
16782             fool_(), fooz_(), getem_();
16783     static char a1[10], a2[10];
16784     static complex c1, c2;
16785     static doublereal d1, d2;
16786     static integer i1, i2;
16787     static real r1, r2;
16788
16789
16790     getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L);
16791 // / //
16792     i__1 = i1 / i2;
16793     fooi_(&i__1);
16794     r__1 = r1 / i1;
16795     foor_(&r__1);
16796     d__1 = d1 / i1;
16797     food_(&d__1);
16798     d__1 = (doublereal) i1;
16799     q__1.r = c1.r / d__1, q__1.i = c1.i / d__1;
16800     fooc_(&q__1);
16801     r__1 = r1 / r2;
16802     foor_(&r__1);
16803     d__1 = r1 / d1;
16804     food_(&d__1);
16805     d__1 = d1 / d2;
16806     food_(&d__1);
16807     d__1 = d1 / r1;
16808     food_(&d__1);
16809     c_div(&q__1, &c1, &c2);
16810     fooc_(&q__1);
16811     q__1.r = c1.r / r1, q__1.i = c1.i / r1;
16812     fooc_(&q__1);
16813     z__1.r = c1.r / d1, z__1.i = c1.i / d1;
16814     fooz_(&z__1);
16815 // ** //
16816     i__1 = pow_ii(&i1, &i2);
16817     fooi_(&i__1);
16818     r__1 = pow_ri(&r1, &i1);
16819     foor_(&r__1);
16820     d__1 = pow_di(&d1, &i1);
16821     food_(&d__1);
16822     pow_ci(&q__1, &c1, &i1);
16823     fooc_(&q__1);
16824     d__1 = (doublereal) r1;
16825     d__2 = (doublereal) r2;
16826     r__1 = pow_dd(&d__1, &d__2);
16827     foor_(&r__1);
16828     d__2 = (doublereal) r1;
16829     d__1 = pow_dd(&d__2, &d1);
16830     food_(&d__1);
16831     d__1 = pow_dd(&d1, &d2);
16832     food_(&d__1);
16833     d__2 = (doublereal) r1;
16834     d__1 = pow_dd(&d1, &d__2);
16835     food_(&d__1);
16836     z__2.r = c1.r, z__2.i = c1.i;
16837     z__3.r = c2.r, z__3.i = c2.i;
16838     pow_zz(&z__1, &z__2, &z__3);
16839     q__1.r = z__1.r, q__1.i = z__1.i;
16840     fooc_(&q__1);
16841     z__2.r = c1.r, z__2.i = c1.i;
16842     z__3.r = r1, z__3.i = 0.;
16843     pow_zz(&z__1, &z__2, &z__3);
16844     q__1.r = z__1.r, q__1.i = z__1.i;
16845     fooc_(&q__1);
16846     z__2.r = c1.r, z__2.i = c1.i;
16847     z__3.r = d1, z__3.i = 0.;
16848     pow_zz(&z__1, &z__2, &z__3);
16849     fooz_(&z__1);
16850 // FFEINTRIN_impABS //
16851     r__1 = (doublereal)((  r1  ) >= 0 ? (  r1  ) : -(  r1  ))  ;
16852     foor_(&r__1);
16853 // FFEINTRIN_impACOS //
16854     r__1 = acos(r1);
16855     foor_(&r__1);
16856 // FFEINTRIN_impAIMAG //
16857     r__1 = r_imag(&c1);
16858     foor_(&r__1);
16859 // FFEINTRIN_impAINT //
16860     r__1 = r_int(&r1);
16861     foor_(&r__1);
16862 // FFEINTRIN_impALOG //
16863     r__1 = log(r1);
16864     foor_(&r__1);
16865 // FFEINTRIN_impALOG10 //
16866     r__1 = r_lg10(&r1);
16867     foor_(&r__1);
16868 // FFEINTRIN_impAMAX0 //
16869     r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16870     foor_(&r__1);
16871 // FFEINTRIN_impAMAX1 //
16872     r__1 = (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16873     foor_(&r__1);
16874 // FFEINTRIN_impAMIN0 //
16875     r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16876     foor_(&r__1);
16877 // FFEINTRIN_impAMIN1 //
16878     r__1 = (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16879     foor_(&r__1);
16880 // FFEINTRIN_impAMOD //
16881     r__1 = r_mod(&r1, &r2);
16882     foor_(&r__1);
16883 // FFEINTRIN_impANINT //
16884     r__1 = r_nint(&r1);
16885     foor_(&r__1);
16886 // FFEINTRIN_impASIN //
16887     r__1 = asin(r1);
16888     foor_(&r__1);
16889 // FFEINTRIN_impATAN //
16890     r__1 = atan(r1);
16891     foor_(&r__1);
16892 // FFEINTRIN_impATAN2 //
16893     r__1 = atan2(r1, r2);
16894     foor_(&r__1);
16895 // FFEINTRIN_impCABS //
16896     r__1 = c_abs(&c1);
16897     foor_(&r__1);
16898 // FFEINTRIN_impCCOS //
16899     c_cos(&q__1, &c1);
16900     fooc_(&q__1);
16901 // FFEINTRIN_impCEXP //
16902     c_exp(&q__1, &c1);
16903     fooc_(&q__1);
16904 // FFEINTRIN_impCHAR //
16905     *(unsigned char *)&ch__1[0] = i1;
16906     fooa_(ch__1, 1L);
16907 // FFEINTRIN_impCLOG //
16908     c_log(&q__1, &c1);
16909     fooc_(&q__1);
16910 // FFEINTRIN_impCONJG //
16911     r_cnjg(&q__1, &c1);
16912     fooc_(&q__1);
16913 // FFEINTRIN_impCOS //
16914     r__1 = cos(r1);
16915     foor_(&r__1);
16916 // FFEINTRIN_impCOSH //
16917     r__1 = cosh(r1);
16918     foor_(&r__1);
16919 // FFEINTRIN_impCSIN //
16920     c_sin(&q__1, &c1);
16921     fooc_(&q__1);
16922 // FFEINTRIN_impCSQRT //
16923     c_sqrt(&q__1, &c1);
16924     fooc_(&q__1);
16925 // FFEINTRIN_impDABS //
16926     d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ;
16927     food_(&d__1);
16928 // FFEINTRIN_impDACOS //
16929     d__1 = acos(d1);
16930     food_(&d__1);
16931 // FFEINTRIN_impDASIN //
16932     d__1 = asin(d1);
16933     food_(&d__1);
16934 // FFEINTRIN_impDATAN //
16935     d__1 = atan(d1);
16936     food_(&d__1);
16937 // FFEINTRIN_impDATAN2 //
16938     d__1 = atan2(d1, d2);
16939     food_(&d__1);
16940 // FFEINTRIN_impDCOS //
16941     d__1 = cos(d1);
16942     food_(&d__1);
16943 // FFEINTRIN_impDCOSH //
16944     d__1 = cosh(d1);
16945     food_(&d__1);
16946 // FFEINTRIN_impDDIM //
16947     d__1 = d_dim(&d1, &d2);
16948     food_(&d__1);
16949 // FFEINTRIN_impDEXP //
16950     d__1 = exp(d1);
16951     food_(&d__1);
16952 // FFEINTRIN_impDIM //
16953     r__1 = r_dim(&r1, &r2);
16954     foor_(&r__1);
16955 // FFEINTRIN_impDINT //
16956     d__1 = d_int(&d1);
16957     food_(&d__1);
16958 // FFEINTRIN_impDLOG //
16959     d__1 = log(d1);
16960     food_(&d__1);
16961 // FFEINTRIN_impDLOG10 //
16962     d__1 = d_lg10(&d1);
16963     food_(&d__1);
16964 // FFEINTRIN_impDMAX1 //
16965     d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ;
16966     food_(&d__1);
16967 // FFEINTRIN_impDMIN1 //
16968     d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ;
16969     food_(&d__1);
16970 // FFEINTRIN_impDMOD //
16971     d__1 = d_mod(&d1, &d2);
16972     food_(&d__1);
16973 // FFEINTRIN_impDNINT //
16974     d__1 = d_nint(&d1);
16975     food_(&d__1);
16976 // FFEINTRIN_impDPROD //
16977     d__1 = (doublereal) r1 * r2;
16978     food_(&d__1);
16979 // FFEINTRIN_impDSIGN //
16980     d__1 = d_sign(&d1, &d2);
16981     food_(&d__1);
16982 // FFEINTRIN_impDSIN //
16983     d__1 = sin(d1);
16984     food_(&d__1);
16985 // FFEINTRIN_impDSINH //
16986     d__1 = sinh(d1);
16987     food_(&d__1);
16988 // FFEINTRIN_impDSQRT //
16989     d__1 = sqrt(d1);
16990     food_(&d__1);
16991 // FFEINTRIN_impDTAN //
16992     d__1 = tan(d1);
16993     food_(&d__1);
16994 // FFEINTRIN_impDTANH //
16995     d__1 = tanh(d1);
16996     food_(&d__1);
16997 // FFEINTRIN_impEXP //
16998     r__1 = exp(r1);
16999     foor_(&r__1);
17000 // FFEINTRIN_impIABS //
17001     i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ;
17002     fooi_(&i__1);
17003 // FFEINTRIN_impICHAR //
17004     i__1 = *(unsigned char *)a1;
17005     fooi_(&i__1);
17006 // FFEINTRIN_impIDIM //
17007     i__1 = i_dim(&i1, &i2);
17008     fooi_(&i__1);
17009 // FFEINTRIN_impIDNINT //
17010     i__1 = i_dnnt(&d1);
17011     fooi_(&i__1);
17012 // FFEINTRIN_impINDEX //
17013     i__1 = i_indx(a1, a2, 10L, 10L);
17014     fooi_(&i__1);
17015 // FFEINTRIN_impISIGN //
17016     i__1 = i_sign(&i1, &i2);
17017     fooi_(&i__1);
17018 // FFEINTRIN_impLEN //
17019     i__1 = i_len(a1, 10L);
17020     fooi_(&i__1);
17021 // FFEINTRIN_impLGE //
17022     L__1 = l_ge(a1, a2, 10L, 10L);
17023     fool_(&L__1);
17024 // FFEINTRIN_impLGT //
17025     L__1 = l_gt(a1, a2, 10L, 10L);
17026     fool_(&L__1);
17027 // FFEINTRIN_impLLE //
17028     L__1 = l_le(a1, a2, 10L, 10L);
17029     fool_(&L__1);
17030 // FFEINTRIN_impLLT //
17031     L__1 = l_lt(a1, a2, 10L, 10L);
17032     fool_(&L__1);
17033 // FFEINTRIN_impMAX0 //
17034     i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
17035     fooi_(&i__1);
17036 // FFEINTRIN_impMAX1 //
17037     i__1 = (integer) (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
17038     fooi_(&i__1);
17039 // FFEINTRIN_impMIN0 //
17040     i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
17041     fooi_(&i__1);
17042 // FFEINTRIN_impMIN1 //
17043     i__1 = (integer) (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
17044     fooi_(&i__1);
17045 // FFEINTRIN_impMOD //
17046     i__1 = i1 % i2;
17047     fooi_(&i__1);
17048 // FFEINTRIN_impNINT //
17049     i__1 = i_nint(&r1);
17050     fooi_(&i__1);
17051 // FFEINTRIN_impSIGN //
17052     r__1 = r_sign(&r1, &r2);
17053     foor_(&r__1);
17054 // FFEINTRIN_impSIN //
17055     r__1 = sin(r1);
17056     foor_(&r__1);
17057 // FFEINTRIN_impSINH //
17058     r__1 = sinh(r1);
17059     foor_(&r__1);
17060 // FFEINTRIN_impSQRT //
17061     r__1 = sqrt(r1);
17062     foor_(&r__1);
17063 // FFEINTRIN_impTAN //
17064     r__1 = tan(r1);
17065     foor_(&r__1);
17066 // FFEINTRIN_impTANH //
17067     r__1 = tanh(r1);
17068     foor_(&r__1);
17069 // FFEINTRIN_imp_CMPLX_C //
17070     r__1 = c1.r;
17071     r__2 = c2.r;
17072     q__1.r = r__1, q__1.i = r__2;
17073     fooc_(&q__1);
17074 // FFEINTRIN_imp_CMPLX_D //
17075     z__1.r = d1, z__1.i = d2;
17076     fooz_(&z__1);
17077 // FFEINTRIN_imp_CMPLX_I //
17078     r__1 = (real) i1;
17079     r__2 = (real) i2;
17080     q__1.r = r__1, q__1.i = r__2;
17081     fooc_(&q__1);
17082 // FFEINTRIN_imp_CMPLX_R //
17083     q__1.r = r1, q__1.i = r2;
17084     fooc_(&q__1);
17085 // FFEINTRIN_imp_DBLE_C //
17086     d__1 = (doublereal) c1.r;
17087     food_(&d__1);
17088 // FFEINTRIN_imp_DBLE_D //
17089     d__1 = d1;
17090     food_(&d__1);
17091 // FFEINTRIN_imp_DBLE_I //
17092     d__1 = (doublereal) i1;
17093     food_(&d__1);
17094 // FFEINTRIN_imp_DBLE_R //
17095     d__1 = (doublereal) r1;
17096     food_(&d__1);
17097 // FFEINTRIN_imp_INT_C //
17098     i__1 = (integer) c1.r;
17099     fooi_(&i__1);
17100 // FFEINTRIN_imp_INT_D //
17101     i__1 = (integer) d1;
17102     fooi_(&i__1);
17103 // FFEINTRIN_imp_INT_I //
17104     i__1 = i1;
17105     fooi_(&i__1);
17106 // FFEINTRIN_imp_INT_R //
17107     i__1 = (integer) r1;
17108     fooi_(&i__1);
17109 // FFEINTRIN_imp_REAL_C //
17110     r__1 = c1.r;
17111     foor_(&r__1);
17112 // FFEINTRIN_imp_REAL_D //
17113     r__1 = (real) d1;
17114     foor_(&r__1);
17115 // FFEINTRIN_imp_REAL_I //
17116     r__1 = (real) i1;
17117     foor_(&r__1);
17118 // FFEINTRIN_imp_REAL_R //
17119     r__1 = r1;
17120     foor_(&r__1);
17121
17122 // FFEINTRIN_imp_INT_D: //
17123
17124 // FFEINTRIN_specIDINT //
17125     i__1 = (integer) d1;
17126     fooi_(&i__1);
17127
17128 // FFEINTRIN_imp_INT_R: //
17129
17130 // FFEINTRIN_specIFIX //
17131     i__1 = (integer) r1;
17132     fooi_(&i__1);
17133 // FFEINTRIN_specINT //
17134     i__1 = (integer) r1;
17135     fooi_(&i__1);
17136
17137 // FFEINTRIN_imp_REAL_D: //
17138
17139 // FFEINTRIN_specSNGL //
17140     r__1 = (real) d1;
17141     foor_(&r__1);
17142
17143 // FFEINTRIN_imp_REAL_I: //
17144
17145 // FFEINTRIN_specFLOAT //
17146     r__1 = (real) i1;
17147     foor_(&r__1);
17148 // FFEINTRIN_specREAL //
17149     r__1 = (real) i1;
17150     foor_(&r__1);
17151
17152 } // MAIN__ //
17153
17154 -------- (end output file from f2c)
17155
17156 */