gcc/f/com.c

   1 /* com.c -- Implementation File (module.c template V1.0)
   2    Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001
   3    Free Software Foundation, Inc.
   4    Contributed by James Craig Burley.
   5
   6 This file is part of GNU Fortran.
   7
   8 GNU Fortran is free software; you can redistribute it and/or modify
   9 it under the terms of the GNU General Public License as published by
  10 the Free Software Foundation; either version 2, or (at your option)
  11 any later version.
  12
  13 GNU Fortran is distributed in the hope that it will be useful,
  14 but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 GNU General Public License for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with GNU Fortran; see the file COPYING.  If not, write to
  20 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
  21 02111-1307, USA.
  22
  23    Related Modules:
  24       None
  25
  26    Description:
  27       Contains compiler-specific functions.
  28
  29    Modifications:
  30 */
  31
  32 /* Understanding this module means understanding the interface between
  33    the g77 front end and the gcc back end (or, perhaps, some other
  34    back end).  In here are the functions called by the front end proper
  35    to notify whatever back end is in place about certain things, and
  36    also the back-end-specific functions.  It's a bear to deal with, so
  37    lately I've been trying to simplify things, especially with regard
  38    to the gcc-back-end-specific stuff.
  39
  40    Building expressions generally seems quite easy, but building decls
  41    has been challenging and is undergoing revision.  gcc has several
  42    kinds of decls:
  43
  44    TYPE_DECL -- a type (int, float, struct, function, etc.)
  45    CONST_DECL -- a constant of some type other than function
  46    LABEL_DECL -- a variable or a constant?
  47    PARM_DECL -- an argument to a function (a variable that is a dummy)
  48    RESULT_DECL -- the return value of a function (a variable)
  49    VAR_DECL -- other variable (can hold a ptr-to-function, struct, int, etc.)
  50    FUNCTION_DECL -- a function (either the actual function or an extern ref)
  51    FIELD_DECL -- a field in a struct or union (goes into types)
  52
  53    g77 has a set of functions that somewhat parallels the gcc front end
  54    when it comes to building decls:
  55
  56    Internal Function (one we define, not just declare as extern):
  57    if (is_nested) push_f_function_context ();
  58    start_function (get_identifier ("function_name"), function_type,
  59                    is_nested, is_public);
  60    // for each arg, build PARM_DECL and call push_parm_decl (decl) with it;
  61    store_parm_decls (is_main_program);
  62    ffecom_start_compstmt ();
  63    // for stmts and decls inside function, do appropriate things;
  64    ffecom_end_compstmt ();
  65    finish_function (is_nested);
  66    if (is_nested) pop_f_function_context ();
  67
  68    Everything Else:
  69    tree d;
  70    tree init;
  71    // fill in external, public, static, &c for decl, and
  72    // set DECL_INITIAL to error_mark_node if going to initialize
  73    // set is_top_level TRUE only if not at top level and decl
  74    // must go in top level (i.e. not within current function decl context)
  75    d = start_decl (decl, is_top_level);
  76    init = ...;  // if have initializer
  77    finish_decl (d, init, is_top_level);
  78
  79 */
  80
  81 /* Include files. */
  82
  83 #include "proj.h"
  84 #if FFECOM_targetCURRENT == FFECOM_targetGCC
  85 #include "flags.h"
  86 #include "rtl.h"
  87 #include "toplev.h"
  88 #include "tree.h"
  89 #include "output.h"  /* Must follow tree.h so TREE_CODE is defined! */
  90 #include "convert.h"
  91 #include "ggc.h"
  92 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
  93
  94 #define FFECOM_GCC_INCLUDE 1    /* Enable -I. */
  95
  96 /* BEGIN stuff from gcc/cccp.c.  */
  97
  98 /* The following symbols should be autoconfigured:
  99         HAVE_FCNTL_H
 100         HAVE_STDLIB_H
 101         HAVE_SYS_TIME_H
 102         HAVE_UNISTD_H
 103         TIME_WITH_SYS_TIME
 104    In the mean time, we'll get by with approximations based
 105    on existing GCC configuration symbols.  */
 106
 107 #ifdef POSIX
 108 # ifndef HAVE_STDLIB_H
 109 # define HAVE_STDLIB_H 1
 110 # endif
 111 # ifndef HAVE_UNISTD_H
 112 # define HAVE_UNISTD_H 1
 113 # endif
 114 #endif /* defined (POSIX) */
 115
 116 #if defined (POSIX) || (defined (USG) && !defined (VMS))
 117 # ifndef HAVE_FCNTL_H
 118 # define HAVE_FCNTL_H 1
 119 # endif
 120 #endif
 121
 122 #ifdef RLIMIT_STACK
 123 # include <sys/resource.h>
 124 #endif
 125
 126 #if HAVE_FCNTL_H
 127 # include <fcntl.h>
 128 #endif
 129
 130 /* This defines "errno" properly for VMS, and gives us EACCES. */
 131 #include <errno.h>
 132
 133 #if HAVE_STDLIB_H
 134 # include <stdlib.h>
 135 #else
 136 char *getenv ();
 137 #endif
 138
 139 #if HAVE_UNISTD_H
 140 # include <unistd.h>
 141 #endif
 142
 143 /* VMS-specific definitions */
 144 #ifdef VMS
 145 #include <descrip.h>
 146 #define O_RDONLY        0       /* Open arg for Read/Only  */
 147 #define O_WRONLY        1       /* Open arg for Write/Only */
 148 #define read(fd,buf,size)       VMS_read (fd,buf,size)
 149 #define write(fd,buf,size)      VMS_write (fd,buf,size)
 150 #define open(fname,mode,prot)   VMS_open (fname,mode,prot)
 151 #define fopen(fname,mode)       VMS_fopen (fname,mode)
 152 #define freopen(fname,mode,ofile) VMS_freopen (fname,mode,ofile)
 153 #define strncat(dst,src,cnt) VMS_strncat (dst,src,cnt)
 154 #define fstat(fd,stbuf)         VMS_fstat (fd,stbuf)
 155 static int VMS_fstat (), VMS_stat ();
 156 static char * VMS_strncat ();
 157 static int VMS_read ();
 158 static int VMS_write ();
 159 static int VMS_open ();
 160 static FILE * VMS_fopen ();
 161 static FILE * VMS_freopen ();
 162 static void hack_vms_include_specification ();
 163 typedef struct { unsigned :16, :16, :16; } vms_ino_t;
 164 #define ino_t vms_ino_t
 165 #define INCLUDE_LEN_FUDGE 10    /* leave room for VMS syntax conversion */
 166 #endif /* VMS */
 167
 168 #ifndef O_RDONLY
 169 #define O_RDONLY 0
 170 #endif
 171
 172 /* END stuff from gcc/cccp.c.  */
 173
 174 #define FFECOM_DETERMINE_TYPES 1 /* for com.h */
 175 #include "com.h"
 176 #include "bad.h"
 177 #include "bld.h"
 178 #include "equiv.h"
 179 #include "expr.h"
 180 #include "implic.h"
 181 #include "info.h"
 182 #include "malloc.h"
 183 #include "src.h"
 184 #include "st.h"
 185 #include "storag.h"
 186 #include "symbol.h"
 187 #include "target.h"
 188 #include "top.h"
 189 #include "type.h"
 190
 191 /* Externals defined here.  */
 192
 193 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 194
 195 /* ~~gcc/tree.h *should* declare this, because toplev.c and dwarfout.c
 196    reference it.  */
 197
 198 const char * const language_string = "GNU F77";
 199
 200 /* Stream for reading from the input file.  */
 201 FILE *finput;
 202
 203 /* These definitions parallel those in c-decl.c so that code from that
 204    module can be used pretty much as is.  Much of these defs aren't
 205    otherwise used, i.e. by g77 code per se, except some of them are used
 206    to build some of them that are.  The ones that are global (i.e. not
 207    "static") are those that ste.c and such might use (directly
 208    or by using com macros that reference them in their definitions).  */
 209
 210 tree string_type_node;
 211
 212 /* The rest of these are inventions for g77, though there might be
 213    similar things in the C front end.  As they are found, these
 214    inventions should be renamed to be canonical.  Note that only
 215    the ones currently required to be global are so.  */
 216
 217 static tree ffecom_tree_fun_type_void;
 218
 219 tree ffecom_integer_type_node;  /* Abbrev for _tree_type[blah][blah]. */
 220 tree ffecom_integer_zero_node;  /* Like *_*_* with g77's integer type. */
 221 tree ffecom_integer_one_node;   /* " */
 222 tree ffecom_tree_type[FFEINFO_basictype][FFEINFO_kindtype];
 223
 224 /* _fun_type things are the f2c-specific versions.  For -fno-f2c,
 225    just use build_function_type and build_pointer_type on the
 226    appropriate _tree_type array element.  */
 227
 228 static tree ffecom_tree_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
 229 static tree ffecom_tree_ptr_to_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
 230 static tree ffecom_tree_subr_type;
 231 static tree ffecom_tree_ptr_to_subr_type;
 232 static tree ffecom_tree_blockdata_type;
 233
 234 static tree ffecom_tree_xargc_;
 235
 236 ffecomSymbol ffecom_symbol_null_
 237 =
 238 {
 239   NULL_TREE,
 240   NULL_TREE,
 241   NULL_TREE,
 242   NULL_TREE,
 243   false
 244 };
 245 ffeinfoKindtype ffecom_pointer_kind_ = FFEINFO_basictypeNONE;
 246 ffeinfoKindtype ffecom_label_kind_ = FFEINFO_basictypeNONE;
 247
 248 int ffecom_f2c_typecode_[FFEINFO_basictype][FFEINFO_kindtype];
 249 tree ffecom_f2c_integer_type_node;
 250 tree ffecom_f2c_ptr_to_integer_type_node;
 251 tree ffecom_f2c_address_type_node;
 252 tree ffecom_f2c_real_type_node;
 253 tree ffecom_f2c_ptr_to_real_type_node;
 254 tree ffecom_f2c_doublereal_type_node;
 255 tree ffecom_f2c_complex_type_node;
 256 tree ffecom_f2c_doublecomplex_type_node;
 257 tree ffecom_f2c_longint_type_node;
 258 tree ffecom_f2c_logical_type_node;
 259 tree ffecom_f2c_flag_type_node;
 260 tree ffecom_f2c_ftnlen_type_node;
 261 tree ffecom_f2c_ftnlen_zero_node;
 262 tree ffecom_f2c_ftnlen_one_node;
 263 tree ffecom_f2c_ftnlen_two_node;
 264 tree ffecom_f2c_ptr_to_ftnlen_type_node;
 265 tree ffecom_f2c_ftnint_type_node;
 266 tree ffecom_f2c_ptr_to_ftnint_type_node;
 267 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 268
 269 /* Simple definitions and enumerations. */
 270
 271 #ifndef FFECOM_sizeMAXSTACKITEM
 272 #define FFECOM_sizeMAXSTACKITEM 32*1024 /* Keep user-declared things
 273                                            larger than this # bytes
 274                                            off stack if possible. */
 275 #endif
 276
 277 /* For systems that have large enough stacks, they should define
 278    this to 0, and here, for ease of use later on, we just undefine
 279    it if it is 0.  */
 280
 281 #if FFECOM_sizeMAXSTACKITEM == 0
 282 #undef FFECOM_sizeMAXSTACKITEM
 283 #endif
 284
 285 typedef enum
 286   {
 287     FFECOM_rttypeVOID_,
 288     FFECOM_rttypeVOIDSTAR_,     /* C's `void *' type. */
 289     FFECOM_rttypeFTNINT_,       /* f2c's `ftnint' type. */
 290     FFECOM_rttypeINTEGER_,      /* f2c's `integer' type. */
 291     FFECOM_rttypeLONGINT_,      /* f2c's `longint' type. */
 292     FFECOM_rttypeLOGICAL_,      /* f2c's `logical' type. */
 293     FFECOM_rttypeREAL_F2C_,     /* f2c's `real' returned as `double'. */
 294     FFECOM_rttypeREAL_GNU_,     /* `real' returned as such. */
 295     FFECOM_rttypeCOMPLEX_F2C_,  /* f2c's `complex' returned via 1st arg. */
 296     FFECOM_rttypeCOMPLEX_GNU_,  /* f2c's `complex' returned directly. */
 297     FFECOM_rttypeDOUBLE_,       /* C's `double' type. */
 298     FFECOM_rttypeDOUBLEREAL_,   /* f2c's `doublereal' type. */
 299     FFECOM_rttypeDBLCMPLX_F2C_, /* f2c's `doublecomplex' returned via 1st arg. */
 300     FFECOM_rttypeDBLCMPLX_GNU_, /* f2c's `doublecomplex' returned directly. */
 301     FFECOM_rttypeCHARACTER_,    /* f2c `char *'/`ftnlen' pair. */
 302     FFECOM_rttype_
 303   } ffecomRttype_;
 304
 305 /* Internal typedefs. */
 306
 307 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 308 typedef struct _ffecom_concat_list_ ffecomConcatList_;
 309 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 310
 311 /* Private include files. */
 312
 313
 314 /* Internal structure definitions. */
 315
 316 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 317 struct _ffecom_concat_list_
 318   {
 319     ffebld *exprs;
 320     int count;
 321     int max;
 322     ffetargetCharacterSize minlen;
 323     ffetargetCharacterSize maxlen;
 324   };
 325 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 326
 327 /* Static functions (internal). */
 328
 329 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 330 static tree ffecom_arglist_expr_ (const char *argstring, ffebld args);
 331 static tree ffecom_widest_expr_type_ (ffebld list);
 332 static bool ffecom_overlap_ (tree dest_decl, tree dest_offset,
 333                              tree dest_size, tree source_tree,
 334                              ffebld source, bool scalar_arg);
 335 static bool ffecom_args_overlapping_ (tree dest_tree, ffebld dest,
 336                                       tree args, tree callee_commons,
 337                                       bool scalar_args);
 338 static tree ffecom_build_f2c_string_ (int i, const char *s);
 339 static tree ffecom_call_ (tree fn, ffeinfoKindtype kt,
 340                           bool is_f2c_complex, tree type,
 341                           tree args, tree dest_tree,
 342                           ffebld dest, bool *dest_used,
 343                           tree callee_commons, bool scalar_args, tree hook);
 344 static tree ffecom_call_binop_ (tree fn, ffeinfoKindtype kt,
 345                                 bool is_f2c_complex, tree type,
 346                                 ffebld left, ffebld right,
 347                                 tree dest_tree, ffebld dest,
 348                                 bool *dest_used, tree callee_commons,
 349                                 bool scalar_args, bool ref, tree hook);
 350 static void ffecom_char_args_x_ (tree *xitem, tree *length,
 351                                  ffebld expr, bool with_null);
 352 static tree ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy);
 353 static tree ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s);
 354 static ffecomConcatList_
 355   ffecom_concat_list_gather_ (ffecomConcatList_ catlist,
 356                               ffebld expr,
 357                               ffetargetCharacterSize max);
 358 static void ffecom_concat_list_kill_ (ffecomConcatList_ catlist);
 359 static ffecomConcatList_ ffecom_concat_list_new_ (ffebld expr,
 360                                                 ffetargetCharacterSize max);
 361 static void ffecom_debug_kludge_ (tree aggr, const char *aggr_type,
 362                                   ffesymbol member, tree member_type,
 363                                   ffetargetOffset offset);
 364 static void ffecom_do_entry_ (ffesymbol fn, int entrynum);
 365 static tree ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
 366                           bool *dest_used, bool assignp, bool widenp);
 367 static tree ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
 368                                     ffebld dest, bool *dest_used);
 369 static tree ffecom_expr_power_integer_ (ffebld expr);
 370 static void ffecom_expr_transform_ (ffebld expr);
 371 static void ffecom_f2c_make_type_ (tree *type, int tcode, const char *name);
 372 static void ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
 373                                       int code);
 374 static ffeglobal ffecom_finish_global_ (ffeglobal global);
 375 static ffesymbol ffecom_finish_symbol_transform_ (ffesymbol s);
 376 static tree ffecom_get_appended_identifier_ (char us, const char *text);
 377 static tree ffecom_get_external_identifier_ (ffesymbol s);
 378 static tree ffecom_get_identifier_ (const char *text);
 379 static tree ffecom_gen_sfuncdef_ (ffesymbol s,
 380                                   ffeinfoBasictype bt,
 381                                   ffeinfoKindtype kt);
 382 static const char *ffecom_gfrt_args_ (ffecomGfrt ix);
 383 static tree ffecom_gfrt_tree_ (ffecomGfrt ix);
 384 static tree ffecom_init_zero_ (tree decl);
 385 static tree ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
 386                                      tree *maybe_tree);
 387 static tree ffecom_intrinsic_len_ (ffebld expr);
 388 static void ffecom_let_char_ (tree dest_tree,
 389                               tree dest_length,
 390                               ffetargetCharacterSize dest_size,
 391                               ffebld source);
 392 static void ffecom_make_gfrt_ (ffecomGfrt ix);
 393 static void ffecom_member_phase1_ (ffestorag mst, ffestorag st);
 394 static void ffecom_member_phase2_ (ffestorag mst, ffestorag st);
 395 static void ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size,
 396                                       ffebld source);
 397 static void ffecom_push_dummy_decls_ (ffebld dumlist,
 398                                       bool stmtfunc);
 399 static void ffecom_start_progunit_ (void);
 400 static ffesymbol ffecom_sym_transform_ (ffesymbol s);
 401 static ffesymbol ffecom_sym_transform_assign_ (ffesymbol s);
 402 static void ffecom_transform_common_ (ffesymbol s);
 403 static void ffecom_transform_equiv_ (ffestorag st);
 404 static tree ffecom_transform_namelist_ (ffesymbol s);
 405 static void ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
 406                                        tree t);
 407 static void ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
 408                                        tree *size, tree tree);
 409 static tree ffecom_tree_divide_ (tree tree_type, tree left, tree right,
 410                                  tree dest_tree, ffebld dest,
 411                                  bool *dest_used, tree hook);
 412 static tree ffecom_type_localvar_ (ffesymbol s,
 413                                    ffeinfoBasictype bt,
 414                                    ffeinfoKindtype kt);
 415 static tree ffecom_type_namelist_ (void);
 416 static tree ffecom_type_vardesc_ (void);
 417 static tree ffecom_vardesc_ (ffebld expr);
 418 static tree ffecom_vardesc_array_ (ffesymbol s);
 419 static tree ffecom_vardesc_dims_ (ffesymbol s);
 420 static tree ffecom_convert_narrow_ (tree type, tree expr);
 421 static tree ffecom_convert_widen_ (tree type, tree expr);
 422 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 423
 424 /* These are static functions that parallel those found in the C front
 425    end and thus have the same names.  */
 426
 427 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 428 static tree bison_rule_compstmt_ (void);
 429 static void bison_rule_pushlevel_ (void);
 430 static void delete_block (tree block);
 431 static int duplicate_decls (tree newdecl, tree olddecl);
 432 static void finish_decl (tree decl, tree init, bool is_top_level);
 433 static void finish_function (int nested);
 434 static const char *lang_printable_name (tree decl, int v);
 435 static tree lookup_name_current_level (tree name);
 436 static struct binding_level *make_binding_level (void);
 437 static void pop_f_function_context (void);
 438 static void push_f_function_context (void);
 439 static void push_parm_decl (tree parm);
 440 static tree pushdecl_top_level (tree decl);
 441 static int kept_level_p (void);
 442 static tree storedecls (tree decls);
 443 static void store_parm_decls (int is_main_program);
 444 static tree start_decl (tree decl, bool is_top_level);
 445 static void start_function (tree name, tree type, int nested, int public);
 446 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 447 #if FFECOM_GCC_INCLUDE
 448 static void ffecom_file_ (const char *name);
 449 static void ffecom_initialize_char_syntax_ (void);
 450 static void ffecom_close_include_ (FILE *f);
 451 static int ffecom_decode_include_option_ (char *spec);
 452 static FILE *ffecom_open_include_ (char *name, ffewhereLine l,
 453                                    ffewhereColumn c);
 454 #endif  /* FFECOM_GCC_INCLUDE */
 455
 456 /* Static objects accessed by functions in this module. */
 457
 458 static ffesymbol ffecom_primary_entry_ = NULL;
 459 static ffesymbol ffecom_nested_entry_ = NULL;
 460 static ffeinfoKind ffecom_primary_entry_kind_;
 461 static bool ffecom_primary_entry_is_proc_;
 462 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 463 static tree ffecom_outer_function_decl_;
 464 static tree ffecom_previous_function_decl_;
 465 static tree ffecom_which_entrypoint_decl_;
 466 static tree ffecom_float_zero_ = NULL_TREE;
 467 static tree ffecom_float_half_ = NULL_TREE;
 468 static tree ffecom_double_zero_ = NULL_TREE;
 469 static tree ffecom_double_half_ = NULL_TREE;
 470 static tree ffecom_func_result_;/* For functions. */
 471 static tree ffecom_func_length_;/* For CHARACTER fns. */
 472 static ffebld ffecom_list_blockdata_;
 473 static ffebld ffecom_list_common_;
 474 static ffebld ffecom_master_arglist_;
 475 static ffeinfoBasictype ffecom_master_bt_;
 476 static ffeinfoKindtype ffecom_master_kt_;
 477 static ffetargetCharacterSize ffecom_master_size_;
 478 static int ffecom_num_fns_ = 0;
 479 static int ffecom_num_entrypoints_ = 0;
 480 static bool ffecom_is_altreturning_ = FALSE;
 481 static tree ffecom_multi_type_node_;
 482 static tree ffecom_multi_retval_;
 483 static tree
 484   ffecom_multi_fields_[FFEINFO_basictype][FFEINFO_kindtype];
 485 static bool ffecom_member_namelisted_;  /* _member_phase1_ namelisted? */
 486 static bool ffecom_doing_entry_ = FALSE;
 487 static bool ffecom_transform_only_dummies_ = FALSE;
 488 static int ffecom_typesize_pointer_;
 489 static int ffecom_typesize_integer1_;
 490
 491 /* Holds pointer-to-function expressions.  */
 492
 493 static tree ffecom_gfrt_[FFECOM_gfrt]
 494 =
 495 {
 496 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NULL_TREE,
 497 #include "com-rt.def"
 498 #undef DEFGFRT
 499 };
 500
 501 /* Holds the external names of the functions.  */
 502
 503 static const char *ffecom_gfrt_name_[FFECOM_gfrt]
 504 =
 505 {
 506 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NAME,
 507 #include "com-rt.def"
 508 #undef DEFGFRT
 509 };
 510
 511 /* Whether the function returns.  */
 512
 513 static bool ffecom_gfrt_volatile_[FFECOM_gfrt]
 514 =
 515 {
 516 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) VOLATILE,
 517 #include "com-rt.def"
 518 #undef DEFGFRT
 519 };
 520
 521 /* Whether the function returns type complex.  */
 522
 523 static bool ffecom_gfrt_complex_[FFECOM_gfrt]
 524 =
 525 {
 526 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) COMPLEX,
 527 #include "com-rt.def"
 528 #undef DEFGFRT
 529 };
 530
 531 /* Whether the function is const
 532    (i.e., has no side effects and only depends on its arguments).  */
 533
 534 static bool ffecom_gfrt_const_[FFECOM_gfrt]
 535 =
 536 {
 537 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) CONST,
 538 #include "com-rt.def"
 539 #undef DEFGFRT
 540 };
 541
 542 /* Type code for the function return value.  */
 543
 544 static ffecomRttype_ ffecom_gfrt_type_[FFECOM_gfrt]
 545 =
 546 {
 547 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) TYPE,
 548 #include "com-rt.def"
 549 #undef DEFGFRT
 550 };
 551
 552 /* String of codes for the function's arguments.  */
 553
 554 static const char *ffecom_gfrt_argstring_[FFECOM_gfrt]
 555 =
 556 {
 557 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) ARGS,
 558 #include "com-rt.def"
 559 #undef DEFGFRT
 560 };
 561 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 562
 563 /* Internal macros. */
 564
 565 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 566
 567 /* We let tm.h override the types used here, to handle trivial differences
 568    such as the choice of unsigned int or long unsigned int for size_t.
 569    When machines start needing nontrivial differences in the size type,
 570    it would be best to do something here to figure out automatically
 571    from other information what type to use.  */
 572
 573 #ifndef SIZE_TYPE
 574 #define SIZE_TYPE "long unsigned int"
 575 #endif
 576
 577 #define ffecom_concat_list_count_(catlist) ((catlist).count)
 578 #define ffecom_concat_list_expr_(catlist,i) ((catlist).exprs[(i)])
 579 #define ffecom_concat_list_maxlen_(catlist) ((catlist).maxlen)
 580 #define ffecom_concat_list_minlen_(catlist) ((catlist).minlen)
 581
 582 #define ffecom_char_args_(i,l,e) ffecom_char_args_x_((i),(l),(e),FALSE)
 583 #define ffecom_char_args_with_null_(i,l,e) ffecom_char_args_x_((i),(l),(e),TRUE)
 584
 585 /* For each binding contour we allocate a binding_level structure
 586  * which records the names defined in that contour.
 587  * Contours include:
 588  *  0) the global one
 589  *  1) one for each function definition,
 590  *     where internal declarations of the parameters appear.
 591  *
 592  * The current meaning of a name can be found by searching the levels from
 593  * the current one out to the global one.
 594  */
 595
 596 /* Note that the information in the `names' component of the global contour
 597    is duplicated in the IDENTIFIER_GLOBAL_VALUEs of all identifiers.  */
 598
 599 struct binding_level
 600   {
 601     /* A chain of _DECL nodes for all variables, constants, functions,
 602        and typedef types.  These are in the reverse of the order supplied.
 603      */
 604     tree names;
 605
 606     /* For each level (except not the global one),
 607        a chain of BLOCK nodes for all the levels
 608        that were entered and exited one level down.  */
 609     tree blocks;
 610
 611     /* The BLOCK node for this level, if one has been preallocated.
 612        If 0, the BLOCK is allocated (if needed) when the level is popped.  */
 613     tree this_block;
 614
 615     /* The binding level which this one is contained in (inherits from).  */
 616     struct binding_level *level_chain;
 617
 618     /* 0: no ffecom_prepare_* functions called at this level yet;
 619        1: ffecom_prepare* functions called, except not ffecom_prepare_end;
 620        2: ffecom_prepare_end called.  */
 621     int prep_state;
 622   };
 623
 624 #define NULL_BINDING_LEVEL (struct binding_level *) NULL
 625
 626 /* The binding level currently in effect.  */
 627
 628 static struct binding_level *current_binding_level;
 629
 630 /* A chain of binding_level structures awaiting reuse.  */
 631
 632 static struct binding_level *free_binding_level;
 633
 634 /* The outermost binding level, for names of file scope.
 635    This is created when the compiler is started and exists
 636    through the entire run.  */
 637
 638 static struct binding_level *global_binding_level;
 639
 640 /* Binding level structures are initialized by copying this one.  */
 641
 642 static struct binding_level clear_binding_level
 643 =
 644 {NULL, NULL, NULL, NULL_BINDING_LEVEL, 0};
 645
 646 /* Language-dependent contents of an identifier.  */
 647
 648 struct lang_identifier
 649   {
 650     struct tree_identifier ignore;
 651     tree global_value, local_value, label_value;
 652     bool invented;
 653   };
 654
 655 /* Macros for access to language-specific slots in an identifier.  */
 656 /* Each of these slots contains a DECL node or null.  */
 657
 658 /* This represents the value which the identifier has in the
 659    file-scope namespace.  */
 660 #define IDENTIFIER_GLOBAL_VALUE(NODE)   \
 661   (((struct lang_identifier *)(NODE))->global_value)
 662 /* This represents the value which the identifier has in the current
 663    scope.  */
 664 #define IDENTIFIER_LOCAL_VALUE(NODE)    \
 665   (((struct lang_identifier *)(NODE))->local_value)
 666 /* This represents the value which the identifier has as a label in
 667    the current label scope.  */
 668 #define IDENTIFIER_LABEL_VALUE(NODE)    \
 669   (((struct lang_identifier *)(NODE))->label_value)
 670 /* This is nonzero if the identifier was "made up" by g77 code.  */
 671 #define IDENTIFIER_INVENTED(NODE)       \
 672   (((struct lang_identifier *)(NODE))->invented)
 673
 674 /* In identifiers, C uses the following fields in a special way:
 675    TREE_PUBLIC        to record that there was a previous local extern decl.
 676    TREE_USED          to record that such a decl was used.
 677    TREE_ADDRESSABLE   to record that the address of such a decl was used.  */
 678
 679 /* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function
 680    that have names.  Here so we can clear out their names' definitions
 681    at the end of the function.  */
 682
 683 static tree named_labels;
 684
 685 /* A list of LABEL_DECLs from outer contexts that are currently shadowed.  */
 686
 687 static tree shadowed_labels;
 688
 689 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 690 \f
 691 /* Return the subscript expression, modified to do range-checking.
 692
 693    `array' is the array to be checked against.
 694    `element' is the subscript expression to check.
 695    `dim' is the dimension number (starting at 0).
 696    `total_dims' is the total number of dimensions (0 for CHARACTER substring).
 697 */
 698
 699 static tree
 700 ffecom_subscript_check_ (tree array, tree element, int dim, int total_dims,
 701                          const char *array_name)
 702 {
 703   tree low = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
 704   tree high = TYPE_MAX_VALUE (TYPE_DOMAIN (array));
 705   tree cond;
 706   tree die;
 707   tree args;
 708
 709   if (element == error_mark_node)
 710     return element;
 711
 712   if (TREE_TYPE (low) != TREE_TYPE (element))
 713     {
 714       if (TYPE_PRECISION (TREE_TYPE (low))
 715           > TYPE_PRECISION (TREE_TYPE (element)))
 716         element = convert (TREE_TYPE (low), element);
 717       else
 718         {
 719           low = convert (TREE_TYPE (element), low);
 720           if (high)
 721             high = convert (TREE_TYPE (element), high);
 722         }
 723     }
 724
 725   element = ffecom_save_tree (element);
 726   cond = ffecom_2 (LE_EXPR, integer_type_node,
 727                    low,
 728                    element);
 729   if (high)
 730     {
 731       cond = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
 732                        cond,
 733                        ffecom_2 (LE_EXPR, integer_type_node,
 734                                  element,
 735                                  high));
 736     }
 737
 738   {
 739     int len;
 740     char *proc;
 741     char *var;
 742     tree arg3;
 743     tree arg2;
 744     tree arg1;
 745     tree arg4;
 746
 747     switch (total_dims)
 748       {
 749       case 0:
 750         var = xmalloc (strlen (array_name) + 20);
 751         sprintf (var, "%s[%s-substring]",
 752                  array_name,
 753                  dim ? "end" : "start");
 754         len = strlen (var) + 1;
 755         arg1 = build_string (len, var);
 756         free (var);
 757         break;
 758
 759       case 1:
 760         len = strlen (array_name) + 1;
 761         arg1 = build_string (len, array_name);
 762         break;
 763
 764       default:
 765         var = xmalloc (strlen (array_name) + 40);
 766         sprintf (var, "%s[subscript-%d-of-%d]",
 767                  array_name,
 768                  dim + 1, total_dims);
 769         len = strlen (var) + 1;
 770         arg1 = build_string (len, var);
 771         free (var);
 772         break;
 773       }
 774
 775     TREE_TYPE (arg1)
 776       = build_type_variant (build_array_type (char_type_node,
 777                                               build_range_type
 778                                               (integer_type_node,
 779                                                integer_one_node,
 780                                                build_int_2 (len, 0))),
 781                             1, 0);
 782     TREE_CONSTANT (arg1) = 1;
 783     TREE_STATIC (arg1) = 1;
 784     arg1 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg1)),
 785                      arg1);
 786
 787     /* s_rnge adds one to the element to print it, so bias against
 788        that -- want to print a faithful *subscript* value.  */
 789     arg2 = convert (ffecom_f2c_ftnint_type_node,
 790                     ffecom_2 (MINUS_EXPR,
 791                               TREE_TYPE (element),
 792                               element,
 793                               convert (TREE_TYPE (element),
 794                                        integer_one_node)));
 795
 796     proc = xmalloc ((len = strlen (input_filename)
 797                      + IDENTIFIER_LENGTH (DECL_NAME (current_function_decl))
 798                      + 2));
 799
 800     sprintf (&proc[0], "%s/%s",
 801              input_filename,
 802              IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
 803     arg3 = build_string (len, proc);
 804
 805     free (proc);
 806
 807     TREE_TYPE (arg3)
 808       = build_type_variant (build_array_type (char_type_node,
 809                                               build_range_type
 810                                               (integer_type_node,
 811                                                integer_one_node,
 812                                                build_int_2 (len, 0))),
 813                             1, 0);
 814     TREE_CONSTANT (arg3) = 1;
 815     TREE_STATIC (arg3) = 1;
 816     arg3 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg3)),
 817                      arg3);
 818
 819     arg4 = convert (ffecom_f2c_ftnint_type_node,
 820                     build_int_2 (lineno, 0));
 821
 822     arg1 = build_tree_list (NULL_TREE, arg1);
 823     arg2 = build_tree_list (NULL_TREE, arg2);
 824     arg3 = build_tree_list (NULL_TREE, arg3);
 825     arg4 = build_tree_list (NULL_TREE, arg4);
 826     TREE_CHAIN (arg3) = arg4;
 827     TREE_CHAIN (arg2) = arg3;
 828     TREE_CHAIN (arg1) = arg2;
 829
 830     args = arg1;
 831   }
 832   die = ffecom_call_gfrt (FFECOM_gfrtRANGE,
 833                           args, NULL_TREE);
 834   TREE_SIDE_EFFECTS (die) = 1;
 835
 836   element = ffecom_3 (COND_EXPR,
 837                       TREE_TYPE (element),
 838                       cond,
 839                       element,
 840                       die);
 841
 842   return element;
 843 }
 844
 845 /* Return the computed element of an array reference.
 846
 847    `item' is NULL_TREE, or the transformed pointer to the array.
 848    `expr' is the original opARRAYREF expression, which is transformed
 849      if `item' is NULL_TREE.
 850    `want_ptr' is non-zero if a pointer to the element, instead of
 851      the element itself, is to be returned.  */
 852
 853 static tree
 854 ffecom_arrayref_ (tree item, ffebld expr, int want_ptr)
 855 {
 856   ffebld dims[FFECOM_dimensionsMAX];
 857   int i;
 858   int total_dims;
 859   int flatten = ffe_is_flatten_arrays ();
 860   int need_ptr;
 861   tree array;
 862   tree element;
 863   tree tree_type;
 864   tree tree_type_x;
 865   const char *array_name;
 866   ffetype type;
 867   ffebld list;
 868
 869   if (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER)
 870     array_name = ffesymbol_text (ffebld_symter (ffebld_left (expr)));
 871   else
 872     array_name = "[expr?]";
 873
 874   /* Build up ARRAY_REFs in reverse order (since we're column major
 875      here in Fortran land). */
 876
 877   for (i = 0, list = ffebld_right (expr);
 878        list != NULL;
 879        ++i, list = ffebld_trail (list))
 880     {
 881       dims[i] = ffebld_head (list);
 882       type = ffeinfo_type (ffebld_basictype (dims[i]),
 883                            ffebld_kindtype (dims[i]));
 884       if (! flatten
 885           && ffecom_typesize_pointer_ > ffecom_typesize_integer1_
 886           && ffetype_size (type) > ffecom_typesize_integer1_)
 887         /* E.g. ARRAY(INDEX), given INTEGER*8 INDEX, on a system with 64-bit
 888            pointers and 32-bit integers.  Do the full 64-bit pointer
 889            arithmetic, for codes using arrays for nonstandard heap-like
 890            work.  */
 891         flatten = 1;
 892     }
 893
 894   total_dims = i;
 895
 896   need_ptr = want_ptr || flatten;
 897
 898   if (! item)
 899     {
 900       if (need_ptr)
 901         item = ffecom_ptr_to_expr (ffebld_left (expr));
 902       else
 903         item = ffecom_expr (ffebld_left (expr));
 904
 905       if (item == error_mark_node)
 906         return item;
 907
 908       if (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereFLEETING
 909           && ! mark_addressable (item))
 910         return error_mark_node;
 911     }
 912
 913   if (item == error_mark_node)
 914     return item;
 915
 916   if (need_ptr)
 917     {
 918       tree min;
 919
 920       for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
 921            i >= 0;
 922            --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array)))
 923         {
 924           min = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
 925           element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
 926           if (flag_bounds_check)
 927             element = ffecom_subscript_check_ (array, element, i, total_dims,
 928                                                array_name);
 929           if (element == error_mark_node)
 930             return element;
 931
 932           /* Widen integral arithmetic as desired while preserving
 933              signedness.  */
 934           tree_type = TREE_TYPE (element);
 935           tree_type_x = tree_type;
 936           if (tree_type
 937               && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
 938               && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
 939             tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
 940
 941           if (TREE_TYPE (min) != tree_type_x)
 942             min = convert (tree_type_x, min);
 943           if (TREE_TYPE (element) != tree_type_x)
 944             element = convert (tree_type_x, element);
 945
 946           item = ffecom_2 (PLUS_EXPR,
 947                            build_pointer_type (TREE_TYPE (array)),
 948                            item,
 949                            size_binop (MULT_EXPR,
 950                                        size_in_bytes (TREE_TYPE (array)),
 951                                        convert (sizetype,
 952                                                 fold (build (MINUS_EXPR,
 953                                                              tree_type_x,
 954                                                              element, min)))));
 955         }
 956       if (! want_ptr)
 957         {
 958           item = ffecom_1 (INDIRECT_REF,
 959                            TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
 960                            item);
 961         }
 962     }
 963   else
 964     {
 965       for (--i;
 966            i >= 0;
 967            --i)
 968         {
 969           array = TYPE_MAIN_VARIANT (TREE_TYPE (item));
 970
 971           element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
 972           if (flag_bounds_check)
 973             element = ffecom_subscript_check_ (array, element, i, total_dims,
 974                                                array_name);
 975           if (element == error_mark_node)
 976             return element;
 977
 978           /* Widen integral arithmetic as desired while preserving
 979              signedness.  */
 980           tree_type = TREE_TYPE (element);
 981           tree_type_x = tree_type;
 982           if (tree_type
 983               && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
 984               && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
 985             tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
 986
 987           element = convert (tree_type_x, element);
 988
 989           item = ffecom_2 (ARRAY_REF,
 990                            TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
 991                            item,
 992                            element);
 993         }
 994     }
 995
 996   return item;
 997 }
 998
 999 /* This is like gcc's stabilize_reference -- in fact, most of the code
1000    comes from that -- but it handles the situation where the reference
1001    is going to have its subparts picked at, and it shouldn't change
1002    (or trigger extra invocations of functions in the subtrees) due to
1003    this.  save_expr is a bit overzealous, because we don't need the
1004    entire thing calculated and saved like a temp.  So, for DECLs, no
1005    change is needed, because these are stable aggregates, and ARRAY_REF
1006    and such might well be stable too, but for things like calculations,
1007    we do need to calculate a snapshot of a value before picking at it.  */
1008
1009 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1010 static tree
1011 ffecom_stabilize_aggregate_ (tree ref)
1012 {
1013   tree result;
1014   enum tree_code code = TREE_CODE (ref);
1015
1016   switch (code)
1017     {
1018     case VAR_DECL:
1019     case PARM_DECL:
1020     case RESULT_DECL:
1021       /* No action is needed in this case.  */
1022       return ref;
1023
1024     case NOP_EXPR:
1025     case CONVERT_EXPR:
1026     case FLOAT_EXPR:
1027     case FIX_TRUNC_EXPR:
1028     case FIX_FLOOR_EXPR:
1029     case FIX_ROUND_EXPR:
1030     case FIX_CEIL_EXPR:
1031       result = build_nt (code, stabilize_reference (TREE_OPERAND (ref, 0)));
1032       break;
1033
1034     case INDIRECT_REF:
1035       result = build_nt (INDIRECT_REF,
1036                          stabilize_reference_1 (TREE_OPERAND (ref, 0)));
1037       break;
1038
1039     case COMPONENT_REF:
1040       result = build_nt (COMPONENT_REF,
1041                          stabilize_reference (TREE_OPERAND (ref, 0)),
1042                          TREE_OPERAND (ref, 1));
1043       break;
1044
1045     case BIT_FIELD_REF:
1046       result = build_nt (BIT_FIELD_REF,
1047                          stabilize_reference (TREE_OPERAND (ref, 0)),
1048                          stabilize_reference_1 (TREE_OPERAND (ref, 1)),
1049                          stabilize_reference_1 (TREE_OPERAND (ref, 2)));
1050       break;
1051
1052     case ARRAY_REF:
1053       result = build_nt (ARRAY_REF,
1054                          stabilize_reference (TREE_OPERAND (ref, 0)),
1055                          stabilize_reference_1 (TREE_OPERAND (ref, 1)));
1056       break;
1057
1058     case COMPOUND_EXPR:
1059       result = build_nt (COMPOUND_EXPR,
1060                          stabilize_reference_1 (TREE_OPERAND (ref, 0)),
1061                          stabilize_reference (TREE_OPERAND (ref, 1)));
1062       break;
1063
1064     case RTL_EXPR:
1065       abort ();
1066
1067
1068     default:
1069       return save_expr (ref);
1070
1071     case ERROR_MARK:
1072       return error_mark_node;
1073     }
1074
1075   TREE_TYPE (result) = TREE_TYPE (ref);
1076   TREE_READONLY (result) = TREE_READONLY (ref);
1077   TREE_SIDE_EFFECTS (result) = TREE_SIDE_EFFECTS (ref);
1078   TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref);
1079
1080   return result;
1081 }
1082 #endif
1083
1084 /* A rip-off of gcc's convert.c convert_to_complex function,
1085    reworked to handle complex implemented as C structures
1086    (RECORD_TYPE with two fields, real and imaginary `r' and `i').  */
1087
1088 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1089 static tree
1090 ffecom_convert_to_complex_ (tree type, tree expr)
1091 {
1092   register enum tree_code form = TREE_CODE (TREE_TYPE (expr));
1093   tree subtype;
1094
1095   assert (TREE_CODE (type) == RECORD_TYPE);
1096
1097   subtype = TREE_TYPE (TYPE_FIELDS (type));
1098
1099   if (form == REAL_TYPE || form == INTEGER_TYPE || form == ENUMERAL_TYPE)
1100     {
1101       expr = convert (subtype, expr);
1102       return ffecom_2 (COMPLEX_EXPR, type, expr,
1103                        convert (subtype, integer_zero_node));
1104     }
1105
1106   if (form == RECORD_TYPE)
1107     {
1108       tree elt_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr)));
1109       if (TYPE_MAIN_VARIANT (elt_type) == TYPE_MAIN_VARIANT (subtype))
1110         return expr;
1111       else
1112         {
1113           expr = save_expr (expr);
1114           return ffecom_2 (COMPLEX_EXPR,
1115                            type,
1116                            convert (subtype,
1117                                     ffecom_1 (REALPART_EXPR,
1118                                               TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1119                                               expr)),
1120                            convert (subtype,
1121                                     ffecom_1 (IMAGPART_EXPR,
1122                                               TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1123                                               expr)));
1124         }
1125     }
1126
1127   if (form == POINTER_TYPE || form == REFERENCE_TYPE)
1128     error ("pointer value used where a complex was expected");
1129   else
1130     error ("aggregate value used where a complex was expected");
1131
1132   return ffecom_2 (COMPLEX_EXPR, type,
1133                    convert (subtype, integer_zero_node),
1134                    convert (subtype, integer_zero_node));
1135 }
1136 #endif
1137
1138 /* Like gcc's convert(), but crashes if widening might happen.  */
1139
1140 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1141 static tree
1142 ffecom_convert_narrow_ (type, expr)
1143      tree type, expr;
1144 {
1145   register tree e = expr;
1146   register enum tree_code code = TREE_CODE (type);
1147
1148   if (type == TREE_TYPE (e)
1149       || TREE_CODE (e) == ERROR_MARK)
1150     return e;
1151   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1152     return fold (build1 (NOP_EXPR, type, e));
1153   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1154       || code == ERROR_MARK)
1155     return error_mark_node;
1156   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1157     {
1158       assert ("void value not ignored as it ought to be" == NULL);
1159       return error_mark_node;
1160     }
1161   assert (code != VOID_TYPE);
1162   if ((code != RECORD_TYPE)
1163       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1164     assert ("converting COMPLEX to REAL" == NULL);
1165   assert (code != ENUMERAL_TYPE);
1166   if (code == INTEGER_TYPE)
1167     {
1168       assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1169                && TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)))
1170               || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1171                   && (TYPE_PRECISION (type)
1172                       == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1173       return fold (convert_to_integer (type, e));
1174     }
1175   if (code == POINTER_TYPE)
1176     {
1177       assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1178       return fold (convert_to_pointer (type, e));
1179     }
1180   if (code == REAL_TYPE)
1181     {
1182       assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1183       assert (TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)));
1184       return fold (convert_to_real (type, e));
1185     }
1186   if (code == COMPLEX_TYPE)
1187     {
1188       assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1189       assert (TYPE_PRECISION (TREE_TYPE (type)) <= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1190       return fold (convert_to_complex (type, e));
1191     }
1192   if (code == RECORD_TYPE)
1193     {
1194       assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1195       /* Check that at least the first field name agrees.  */
1196       assert (DECL_NAME (TYPE_FIELDS (type))
1197               == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1198       assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1199               <= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1200       if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1201           == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1202         return e;
1203       return fold (ffecom_convert_to_complex_ (type, e));
1204     }
1205
1206   assert ("conversion to non-scalar type requested" == NULL);
1207   return error_mark_node;
1208 }
1209 #endif
1210
1211 /* Like gcc's convert(), but crashes if narrowing might happen.  */
1212
1213 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1214 static tree
1215 ffecom_convert_widen_ (type, expr)
1216      tree type, expr;
1217 {
1218   register tree e = expr;
1219   register enum tree_code code = TREE_CODE (type);
1220
1221   if (type == TREE_TYPE (e)
1222       || TREE_CODE (e) == ERROR_MARK)
1223     return e;
1224   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1225     return fold (build1 (NOP_EXPR, type, e));
1226   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1227       || code == ERROR_MARK)
1228     return error_mark_node;
1229   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1230     {
1231       assert ("void value not ignored as it ought to be" == NULL);
1232       return error_mark_node;
1233     }
1234   assert (code != VOID_TYPE);
1235   if ((code != RECORD_TYPE)
1236       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1237     assert ("narrowing COMPLEX to REAL" == NULL);
1238   assert (code != ENUMERAL_TYPE);
1239   if (code == INTEGER_TYPE)
1240     {
1241       assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1242                && TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)))
1243               || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1244                   && (TYPE_PRECISION (type)
1245                       == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1246       return fold (convert_to_integer (type, e));
1247     }
1248   if (code == POINTER_TYPE)
1249     {
1250       assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1251       return fold (convert_to_pointer (type, e));
1252     }
1253   if (code == REAL_TYPE)
1254     {
1255       assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1256       assert (TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)));
1257       return fold (convert_to_real (type, e));
1258     }
1259   if (code == COMPLEX_TYPE)
1260     {
1261       assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1262       assert (TYPE_PRECISION (TREE_TYPE (type)) >= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1263       return fold (convert_to_complex (type, e));
1264     }
1265   if (code == RECORD_TYPE)
1266     {
1267       assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1268       /* Check that at least the first field name agrees.  */
1269       assert (DECL_NAME (TYPE_FIELDS (type))
1270               == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1271       assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1272               >= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1273       if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1274           == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1275         return e;
1276       return fold (ffecom_convert_to_complex_ (type, e));
1277     }
1278
1279   assert ("conversion to non-scalar type requested" == NULL);
1280   return error_mark_node;
1281 }
1282 #endif
1283
1284 /* Handles making a COMPLEX type, either the standard
1285    (but buggy?) gbe way, or the safer (but less elegant?)
1286    f2c way.  */
1287
1288 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1289 static tree
1290 ffecom_make_complex_type_ (tree subtype)
1291 {
1292   tree type;
1293   tree realfield;
1294   tree imagfield;
1295
1296   if (ffe_is_emulate_complex ())
1297     {
1298       type = make_node (RECORD_TYPE);
1299       realfield = ffecom_decl_field (type, NULL_TREE, "r", subtype);
1300       imagfield = ffecom_decl_field (type, realfield, "i", subtype);
1301       TYPE_FIELDS (type) = realfield;
1302       layout_type (type);
1303     }
1304   else
1305     {
1306       type = make_node (COMPLEX_TYPE);
1307       TREE_TYPE (type) = subtype;
1308       layout_type (type);
1309     }
1310
1311   return type;
1312 }
1313 #endif
1314
1315 /* Chooses either the gbe or the f2c way to build a
1316    complex constant.  */
1317
1318 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1319 static tree
1320 ffecom_build_complex_constant_ (tree type, tree realpart, tree imagpart)
1321 {
1322   tree bothparts;
1323
1324   if (ffe_is_emulate_complex ())
1325     {
1326       bothparts = build_tree_list (TYPE_FIELDS (type), realpart);
1327       TREE_CHAIN (bothparts) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), imagpart);
1328       bothparts = build (CONSTRUCTOR, type, NULL_TREE, bothparts);
1329     }
1330   else
1331     {
1332       bothparts = build_complex (type, realpart, imagpart);
1333     }
1334
1335   return bothparts;
1336 }
1337 #endif
1338
1339 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1340 static tree
1341 ffecom_arglist_expr_ (const char *c, ffebld expr)
1342 {
1343   tree list;
1344   tree *plist = &list;
1345   tree trail = NULL_TREE;       /* Append char length args here. */
1346   tree *ptrail = &trail;
1347   tree length;
1348   ffebld exprh;
1349   tree item;
1350   bool ptr = FALSE;
1351   tree wanted = NULL_TREE;
1352   static char zed[] = "0";
1353
1354   if (c == NULL)
1355     c = &zed[0];
1356
1357   while (expr != NULL)
1358     {
1359       if (*c != '\0')
1360         {
1361           ptr = FALSE;
1362           if (*c == '&')
1363             {
1364               ptr = TRUE;
1365               ++c;
1366             }
1367           switch (*(c++))
1368             {
1369             case '\0':
1370               ptr = TRUE;
1371               wanted = NULL_TREE;
1372               break;
1373
1374             case 'a':
1375               assert (ptr);
1376               wanted = NULL_TREE;
1377               break;
1378
1379             case 'c':
1380               wanted = ffecom_f2c_complex_type_node;
1381               break;
1382
1383             case 'd':
1384               wanted = ffecom_f2c_doublereal_type_node;
1385               break;
1386
1387             case 'e':
1388               wanted = ffecom_f2c_doublecomplex_type_node;
1389               break;
1390
1391             case 'f':
1392               wanted = ffecom_f2c_real_type_node;
1393               break;
1394
1395             case 'i':
1396               wanted = ffecom_f2c_integer_type_node;
1397               break;
1398
1399             case 'j':
1400               wanted = ffecom_f2c_longint_type_node;
1401               break;
1402
1403             default:
1404               assert ("bad argstring code" == NULL);
1405               wanted = NULL_TREE;
1406               break;
1407             }
1408         }
1409
1410       exprh = ffebld_head (expr);
1411       if (exprh == NULL)
1412         wanted = NULL_TREE;
1413
1414       if ((wanted == NULL_TREE)
1415           || (ptr
1416               && (TYPE_MODE
1417                   (ffecom_tree_type[ffeinfo_basictype (ffebld_info (exprh))]
1418                    [ffeinfo_kindtype (ffebld_info (exprh))])
1419                    == TYPE_MODE (wanted))))
1420         *plist
1421           = build_tree_list (NULL_TREE,
1422                              ffecom_arg_ptr_to_expr (exprh,
1423                                                      &length));
1424       else
1425         {
1426           item = ffecom_arg_expr (exprh, &length);
1427           item = ffecom_convert_widen_ (wanted, item);
1428           if (ptr)
1429             {
1430               item = ffecom_1 (ADDR_EXPR,
1431                                build_pointer_type (TREE_TYPE (item)),
1432                                item);
1433             }
1434           *plist
1435             = build_tree_list (NULL_TREE,
1436                                item);
1437         }
1438
1439       plist = &TREE_CHAIN (*plist);
1440       expr = ffebld_trail (expr);
1441       if (length != NULL_TREE)
1442         {
1443           *ptrail = build_tree_list (NULL_TREE, length);
1444           ptrail = &TREE_CHAIN (*ptrail);
1445         }
1446     }
1447
1448   /* We've run out of args in the call; if the implementation expects
1449      more, supply null pointers for them, which the implementation can
1450      check to see if an arg was omitted. */
1451
1452   while (*c != '\0' && *c != '0')
1453     {
1454       if (*c == '&')
1455         ++c;
1456       else
1457         assert ("missing arg to run-time routine!" == NULL);
1458
1459       switch (*(c++))
1460         {
1461         case '\0':
1462         case 'a':
1463         case 'c':
1464         case 'd':
1465         case 'e':
1466         case 'f':
1467         case 'i':
1468         case 'j':
1469           break;
1470
1471         default:
1472           assert ("bad arg string code" == NULL);
1473           break;
1474         }
1475       *plist
1476         = build_tree_list (NULL_TREE,
1477                            null_pointer_node);
1478       plist = &TREE_CHAIN (*plist);
1479     }
1480
1481   *plist = trail;
1482
1483   return list;
1484 }
1485 #endif
1486
1487 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1488 static tree
1489 ffecom_widest_expr_type_ (ffebld list)
1490 {
1491   ffebld item;
1492   ffebld widest = NULL;
1493   ffetype type;
1494   ffetype widest_type = NULL;
1495   tree t;
1496
1497   for (; list != NULL; list = ffebld_trail (list))
1498     {
1499       item = ffebld_head (list);
1500       if (item == NULL)
1501         continue;
1502       if ((widest != NULL)
1503           && (ffeinfo_basictype (ffebld_info (item))
1504               != ffeinfo_basictype (ffebld_info (widest))))
1505         continue;
1506       type = ffeinfo_type (ffeinfo_basictype (ffebld_info (item)),
1507                            ffeinfo_kindtype (ffebld_info (item)));
1508       if ((widest == FFEINFO_kindtypeNONE)
1509           || (ffetype_size (type)
1510               > ffetype_size (widest_type)))
1511         {
1512           widest = item;
1513           widest_type = type;
1514         }
1515     }
1516
1517   assert (widest != NULL);
1518   t = ffecom_tree_type[ffeinfo_basictype (ffebld_info (widest))]
1519     [ffeinfo_kindtype (ffebld_info (widest))];
1520   assert (t != NULL_TREE);
1521   return t;
1522 }
1523 #endif
1524
1525 /* Check whether a partial overlap between two expressions is possible.
1526
1527    Can *starting* to write a portion of expr1 change the value
1528    computed (perhaps already, *partially*) by expr2?
1529
1530    Currently, this is a concern only for a COMPLEX expr1.  But if it
1531    isn't in COMMON or local EQUIVALENCE, since we don't support
1532    aliasing of arguments, it isn't a concern.  */
1533
1534 static bool
1535 ffecom_possible_partial_overlap_ (ffebld expr1, ffebld expr2 ATTRIBUTE_UNUSED)
1536 {
1537   ffesymbol sym;
1538   ffestorag st;
1539
1540   switch (ffebld_op (expr1))
1541     {
1542     case FFEBLD_opSYMTER:
1543       sym = ffebld_symter (expr1);
1544       break;
1545
1546     case FFEBLD_opARRAYREF:
1547       if (ffebld_op (ffebld_left (expr1)) != FFEBLD_opSYMTER)
1548         return FALSE;
1549       sym = ffebld_symter (ffebld_left (expr1));
1550       break;
1551
1552     default:
1553       return FALSE;
1554     }
1555
1556   if (ffesymbol_where (sym) != FFEINFO_whereCOMMON
1557       && (ffesymbol_where (sym) != FFEINFO_whereLOCAL
1558           || ! (st = ffesymbol_storage (sym))
1559           || ! ffestorag_parent (st)))
1560     return FALSE;
1561
1562   /* It's in COMMON or local EQUIVALENCE.  */
1563
1564   return TRUE;
1565 }
1566
1567 /* Check whether dest and source might overlap.  ffebld versions of these
1568    might or might not be passed, will be NULL if not.
1569
1570    The test is really whether source_tree is modifiable and, if modified,
1571    might overlap destination such that the value(s) in the destination might
1572    change before it is finally modified.  dest_* are the canonized
1573    destination itself.  */
1574
1575 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1576 static bool
1577 ffecom_overlap_ (tree dest_decl, tree dest_offset, tree dest_size,
1578                  tree source_tree, ffebld source UNUSED,
1579                  bool scalar_arg)
1580 {
1581   tree source_decl;
1582   tree source_offset;
1583   tree source_size;
1584   tree t;
1585
1586   if (source_tree == NULL_TREE)
1587     return FALSE;
1588
1589   switch (TREE_CODE (source_tree))
1590     {
1591     case ERROR_MARK:
1592     case IDENTIFIER_NODE:
1593     case INTEGER_CST:
1594     case REAL_CST:
1595     case COMPLEX_CST:
1596     case STRING_CST:
1597     case CONST_DECL:
1598     case VAR_DECL:
1599     case RESULT_DECL:
1600     case FIELD_DECL:
1601     case MINUS_EXPR:
1602     case MULT_EXPR:
1603     case TRUNC_DIV_EXPR:
1604     case CEIL_DIV_EXPR:
1605     case FLOOR_DIV_EXPR:
1606     case ROUND_DIV_EXPR:
1607     case TRUNC_MOD_EXPR:
1608     case CEIL_MOD_EXPR:
1609     case FLOOR_MOD_EXPR:
1610     case ROUND_MOD_EXPR:
1611     case RDIV_EXPR:
1612     case EXACT_DIV_EXPR:
1613     case FIX_TRUNC_EXPR:
1614     case FIX_CEIL_EXPR:
1615     case FIX_FLOOR_EXPR:
1616     case FIX_ROUND_EXPR:
1617     case FLOAT_EXPR:
1618     case EXPON_EXPR:
1619     case NEGATE_EXPR:
1620     case MIN_EXPR:
1621     case MAX_EXPR:
1622     case ABS_EXPR:
1623     case FFS_EXPR:
1624     case LSHIFT_EXPR:
1625     case RSHIFT_EXPR:
1626     case LROTATE_EXPR:
1627     case RROTATE_EXPR:
1628     case BIT_IOR_EXPR:
1629     case BIT_XOR_EXPR:
1630     case BIT_AND_EXPR:
1631     case BIT_ANDTC_EXPR:
1632     case BIT_NOT_EXPR:
1633     case TRUTH_ANDIF_EXPR:
1634     case TRUTH_ORIF_EXPR:
1635     case TRUTH_AND_EXPR:
1636     case TRUTH_OR_EXPR:
1637     case TRUTH_XOR_EXPR:
1638     case TRUTH_NOT_EXPR:
1639     case LT_EXPR:
1640     case LE_EXPR:
1641     case GT_EXPR:
1642     case GE_EXPR:
1643     case EQ_EXPR:
1644     case NE_EXPR:
1645     case COMPLEX_EXPR:
1646     case CONJ_EXPR:
1647     case REALPART_EXPR:
1648     case IMAGPART_EXPR:
1649     case LABEL_EXPR:
1650     case COMPONENT_REF:
1651       return FALSE;
1652
1653     case COMPOUND_EXPR:
1654       return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1655                               TREE_OPERAND (source_tree, 1), NULL,
1656                               scalar_arg);
1657
1658     case MODIFY_EXPR:
1659       return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1660                               TREE_OPERAND (source_tree, 0), NULL,
1661                               scalar_arg);
1662
1663     case CONVERT_EXPR:
1664     case NOP_EXPR:
1665     case NON_LVALUE_EXPR:
1666     case PLUS_EXPR:
1667       if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1668         return TRUE;
1669
1670       ffecom_tree_canonize_ptr_ (&source_decl, &source_offset,
1671                                  source_tree);
1672       source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1673       break;
1674
1675     case COND_EXPR:
1676       return
1677         ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1678                          TREE_OPERAND (source_tree, 1), NULL,
1679                          scalar_arg)
1680           || ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1681                               TREE_OPERAND (source_tree, 2), NULL,
1682                               scalar_arg);
1683
1684
1685     case ADDR_EXPR:
1686       ffecom_tree_canonize_ref_ (&source_decl, &source_offset,
1687                                  &source_size,
1688                                  TREE_OPERAND (source_tree, 0));
1689       break;
1690
1691     case PARM_DECL:
1692       if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1693         return TRUE;
1694
1695       source_decl = source_tree;
1696       source_offset = bitsize_zero_node;
1697       source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1698       break;
1699
1700     case SAVE_EXPR:
1701     case REFERENCE_EXPR:
1702     case PREDECREMENT_EXPR:
1703     case PREINCREMENT_EXPR:
1704     case POSTDECREMENT_EXPR:
1705     case POSTINCREMENT_EXPR:
1706     case INDIRECT_REF:
1707     case ARRAY_REF:
1708     case CALL_EXPR:
1709     default:
1710       return TRUE;
1711     }
1712
1713   /* Come here when source_decl, source_offset, and source_size filled
1714      in appropriately.  */
1715
1716   if (source_decl == NULL_TREE)
1717     return FALSE;               /* No decl involved, so no overlap. */
1718
1719   if (source_decl != dest_decl)
1720     return FALSE;               /* Different decl, no overlap. */
1721
1722   if (TREE_CODE (dest_size) == ERROR_MARK)
1723     return TRUE;                /* Assignment into entire assumed-size
1724                                    array?  Shouldn't happen.... */
1725
1726   t = ffecom_2 (LE_EXPR, integer_type_node,
1727                 ffecom_2 (PLUS_EXPR, TREE_TYPE (dest_offset),
1728                           dest_offset,
1729                           convert (TREE_TYPE (dest_offset),
1730                                    dest_size)),
1731                 convert (TREE_TYPE (dest_offset),
1732                          source_offset));
1733
1734   if (integer_onep (t))
1735     return FALSE;               /* Destination precedes source. */
1736
1737   if (!scalar_arg
1738       || (source_size == NULL_TREE)
1739       || (TREE_CODE (source_size) == ERROR_MARK)
1740       || integer_zerop (source_size))
1741     return TRUE;                /* No way to tell if dest follows source. */
1742
1743   t = ffecom_2 (LE_EXPR, integer_type_node,
1744                 ffecom_2 (PLUS_EXPR, TREE_TYPE (source_offset),
1745                           source_offset,
1746                           convert (TREE_TYPE (source_offset),
1747                                    source_size)),
1748                 convert (TREE_TYPE (source_offset),
1749                          dest_offset));
1750
1751   if (integer_onep (t))
1752     return FALSE;               /* Destination follows source. */
1753
1754   return TRUE;          /* Destination and source overlap. */
1755 }
1756 #endif
1757
1758 /* Check whether dest might overlap any of a list of arguments or is
1759    in a COMMON area the callee might know about (and thus modify).  */
1760
1761 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1762 static bool
1763 ffecom_args_overlapping_ (tree dest_tree, ffebld dest UNUSED,
1764                           tree args, tree callee_commons,
1765                           bool scalar_args)
1766 {
1767   tree arg;
1768   tree dest_decl;
1769   tree dest_offset;
1770   tree dest_size;
1771
1772   ffecom_tree_canonize_ref_ (&dest_decl, &dest_offset, &dest_size,
1773                              dest_tree);
1774
1775   if (dest_decl == NULL_TREE)
1776     return FALSE;               /* Seems unlikely! */
1777
1778   /* If the decl cannot be determined reliably, or if its in COMMON
1779      and the callee isn't known to not futz with COMMON via other
1780      means, overlap might happen.  */
1781
1782   if ((TREE_CODE (dest_decl) == ERROR_MARK)
1783       || ((callee_commons != NULL_TREE)
1784           && TREE_PUBLIC (dest_decl)))
1785     return TRUE;
1786
1787   for (; args != NULL_TREE; args = TREE_CHAIN (args))
1788     {
1789       if (((arg = TREE_VALUE (args)) != NULL_TREE)
1790           && ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1791                               arg, NULL, scalar_args))
1792         return TRUE;
1793     }
1794
1795   return FALSE;
1796 }
1797 #endif
1798
1799 /* Build a string for a variable name as used by NAMELIST.  This means that
1800    if we're using the f2c library, we build an uppercase string, since
1801    f2c does this.  */
1802
1803 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1804 static tree
1805 ffecom_build_f2c_string_ (int i, const char *s)
1806 {
1807   if (!ffe_is_f2c_library ())
1808     return build_string (i, s);
1809
1810   {
1811     char *tmp;
1812     const char *p;
1813     char *q;
1814     char space[34];
1815     tree t;
1816
1817     if (((size_t) i) > ARRAY_SIZE (space))
1818       tmp = malloc_new_ks (malloc_pool_image (), "f2c_string", i);
1819     else
1820       tmp = &space[0];
1821
1822     for (p = s, q = tmp; *p != '\0'; ++p, ++q)
1823       *q = TOUPPER (*p);
1824     *q = '\0';
1825
1826     t = build_string (i, tmp);
1827
1828     if (((size_t) i) > ARRAY_SIZE (space))
1829       malloc_kill_ks (malloc_pool_image (), tmp, i);
1830
1831     return t;
1832   }
1833 }
1834
1835 #endif
1836 /* Returns CALL_EXPR or equivalent with given type (pass NULL_TREE for
1837    type to just get whatever the function returns), handling the
1838    f2c value-returning convention, if required, by prepending
1839    to the arglist a pointer to a temporary to receive the return value.  */
1840
1841 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1842 static tree
1843 ffecom_call_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1844               tree type, tree args, tree dest_tree,
1845               ffebld dest, bool *dest_used, tree callee_commons,
1846               bool scalar_args, tree hook)
1847 {
1848   tree item;
1849   tree tempvar;
1850
1851   if (dest_used != NULL)
1852     *dest_used = FALSE;
1853
1854   if (is_f2c_complex)
1855     {
1856       if ((dest_used == NULL)
1857           || (dest == NULL)
1858           || (ffeinfo_basictype (ffebld_info (dest))
1859               != FFEINFO_basictypeCOMPLEX)
1860           || (ffeinfo_kindtype (ffebld_info (dest)) != kt)
1861           || ((type != NULL_TREE) && (TREE_TYPE (dest_tree) != type))
1862           || ffecom_args_overlapping_ (dest_tree, dest, args,
1863                                        callee_commons,
1864                                        scalar_args))
1865         {
1866 #ifdef HOHO
1867           tempvar = ffecom_make_tempvar (ffecom_tree_type
1868                                          [FFEINFO_basictypeCOMPLEX][kt],
1869                                          FFETARGET_charactersizeNONE,
1870                                          -1);
1871 #else
1872           tempvar = hook;
1873           assert (tempvar);
1874 #endif
1875         }
1876       else
1877         {
1878           *dest_used = TRUE;
1879           tempvar = dest_tree;
1880           type = NULL_TREE;
1881         }
1882
1883       item
1884         = build_tree_list (NULL_TREE,
1885                            ffecom_1 (ADDR_EXPR,
1886                                      build_pointer_type (TREE_TYPE (tempvar)),
1887                                      tempvar));
1888       TREE_CHAIN (item) = args;
1889
1890       item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1891                         item, NULL_TREE);
1892
1893       if (tempvar != dest_tree)
1894         item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item, tempvar);
1895     }
1896   else
1897     item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1898                       args, NULL_TREE);
1899
1900   if ((type != NULL_TREE) && (TREE_TYPE (item) != type))
1901     item = ffecom_convert_narrow_ (type, item);
1902
1903   return item;
1904 }
1905 #endif
1906
1907 /* Given two arguments, transform them and make a call to the given
1908    function via ffecom_call_.  */
1909
1910 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1911 static tree
1912 ffecom_call_binop_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1913                     tree type, ffebld left, ffebld right,
1914                     tree dest_tree, ffebld dest, bool *dest_used,
1915                     tree callee_commons, bool scalar_args, bool ref, tree hook)
1916 {
1917   tree left_tree;
1918   tree right_tree;
1919   tree left_length;
1920   tree right_length;
1921
1922   if (ref)
1923     {
1924       /* Pass arguments by reference.  */
1925       left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
1926       right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
1927     }
1928   else
1929     {
1930       /* Pass arguments by value.  */
1931       left_tree = ffecom_arg_expr (left, &left_length);
1932       right_tree = ffecom_arg_expr (right, &right_length);
1933     }
1934
1935
1936   left_tree = build_tree_list (NULL_TREE, left_tree);
1937   right_tree = build_tree_list (NULL_TREE, right_tree);
1938   TREE_CHAIN (left_tree) = right_tree;
1939
1940   if (left_length != NULL_TREE)
1941     {
1942       left_length = build_tree_list (NULL_TREE, left_length);
1943       TREE_CHAIN (right_tree) = left_length;
1944     }
1945
1946   if (right_length != NULL_TREE)
1947     {
1948       right_length = build_tree_list (NULL_TREE, right_length);
1949       if (left_length != NULL_TREE)
1950         TREE_CHAIN (left_length) = right_length;
1951       else
1952         TREE_CHAIN (right_tree) = right_length;
1953     }
1954
1955   return ffecom_call_ (fn, kt, is_f2c_complex, type, left_tree,
1956                        dest_tree, dest, dest_used, callee_commons,
1957                        scalar_args, hook);
1958 }
1959 #endif
1960
1961 /* Return ptr/length args for char subexpression
1962
1963    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
1964    subexpressions by constructing the appropriate trees for the ptr-to-
1965    character-text and length-of-character-text arguments in a calling
1966    sequence.
1967
1968    Note that if with_null is TRUE, and the expression is an opCONTER,
1969    a null byte is appended to the string.  */
1970
1971 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1972 static void
1973 ffecom_char_args_x_ (tree *xitem, tree *length, ffebld expr, bool with_null)
1974 {
1975   tree item;
1976   tree high;
1977   ffetargetCharacter1 val;
1978   ffetargetCharacterSize newlen;
1979
1980   switch (ffebld_op (expr))
1981     {
1982     case FFEBLD_opCONTER:
1983       val = ffebld_constant_character1 (ffebld_conter (expr));
1984       newlen = ffetarget_length_character1 (val);
1985       if (with_null)
1986         {
1987           /* Begin FFETARGET-NULL-KLUDGE.  */
1988           if (newlen != 0)
1989             ++newlen;
1990         }
1991       *length = build_int_2 (newlen, 0);
1992       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
1993       high = build_int_2 (newlen, 0);
1994       TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
1995       item = build_string (newlen,
1996                            ffetarget_text_character1 (val));
1997       /* End FFETARGET-NULL-KLUDGE.  */
1998       TREE_TYPE (item)
1999         = build_type_variant
2000           (build_array_type
2001            (char_type_node,
2002             build_range_type
2003             (ffecom_f2c_ftnlen_type_node,
2004              ffecom_f2c_ftnlen_one_node,
2005              high)),
2006            1, 0);
2007       TREE_CONSTANT (item) = 1;
2008       TREE_STATIC (item) = 1;
2009       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
2010                        item);
2011       break;
2012
2013     case FFEBLD_opSYMTER:
2014       {
2015         ffesymbol s = ffebld_symter (expr);
2016
2017         item = ffesymbol_hook (s).decl_tree;
2018         if (item == NULL_TREE)
2019           {
2020             s = ffecom_sym_transform_ (s);
2021             item = ffesymbol_hook (s).decl_tree;
2022           }
2023         if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
2024           {
2025             if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
2026               *length = ffesymbol_hook (s).length_tree;
2027             else
2028               {
2029                 *length = build_int_2 (ffesymbol_size (s), 0);
2030                 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2031               }
2032           }
2033         else if (item == error_mark_node)
2034           *length = error_mark_node;
2035         else
2036           /* FFEINFO_kindFUNCTION.  */
2037           *length = NULL_TREE;
2038         if (!ffesymbol_hook (s).addr
2039             && (item != error_mark_node))
2040           item = ffecom_1 (ADDR_EXPR,
2041                            build_pointer_type (TREE_TYPE (item)),
2042                            item);
2043       }
2044       break;
2045
2046     case FFEBLD_opARRAYREF:
2047       {
2048         ffecom_char_args_ (&item, length, ffebld_left (expr));
2049
2050         if (item == error_mark_node || *length == error_mark_node)
2051           {
2052             item = *length = error_mark_node;
2053             break;
2054           }
2055
2056         item = ffecom_arrayref_ (item, expr, 1);
2057       }
2058       break;
2059
2060     case FFEBLD_opSUBSTR:
2061       {
2062         ffebld start;
2063         ffebld end;
2064         ffebld thing = ffebld_right (expr);
2065         tree start_tree;
2066         tree end_tree;
2067         const char *char_name;
2068         ffebld left_symter;
2069         tree array;
2070
2071         assert (ffebld_op (thing) == FFEBLD_opITEM);
2072         start = ffebld_head (thing);
2073         thing = ffebld_trail (thing);
2074         assert (ffebld_trail (thing) == NULL);
2075         end = ffebld_head (thing);
2076
2077         /* Determine name for pretty-printing range-check errors.  */
2078         for (left_symter = ffebld_left (expr);
2079              left_symter && ffebld_op (left_symter) == FFEBLD_opARRAYREF;
2080              left_symter = ffebld_left (left_symter))
2081           ;
2082         if (ffebld_op (left_symter) == FFEBLD_opSYMTER)
2083           char_name = ffesymbol_text (ffebld_symter (left_symter));
2084         else
2085           char_name = "[expr?]";
2086
2087         ffecom_char_args_ (&item, length, ffebld_left (expr));
2088
2089         if (item == error_mark_node || *length == error_mark_node)
2090           {
2091             item = *length = error_mark_node;
2092             break;
2093           }
2094
2095         array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
2096
2097         /* ~~~~Handle INTEGER*8 start/end, a la FFEBLD_opARRAYREF.  */
2098
2099         if (start == NULL)
2100           {
2101             if (end == NULL)
2102               ;
2103             else
2104               {
2105                 end_tree = ffecom_expr (end);
2106                 if (flag_bounds_check)
2107                   end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2108                                                       char_name);
2109                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2110                                     end_tree);
2111
2112                 if (end_tree == error_mark_node)
2113                   {
2114                     item = *length = error_mark_node;
2115                     break;
2116                   }
2117
2118                 *length = end_tree;
2119               }
2120           }
2121         else
2122           {
2123             start_tree = ffecom_expr (start);
2124             if (flag_bounds_check)
2125               start_tree = ffecom_subscript_check_ (array, start_tree, 0, 0,
2126                                                     char_name);
2127             start_tree = convert (ffecom_f2c_ftnlen_type_node,
2128                                   start_tree);
2129
2130             if (start_tree == error_mark_node)
2131               {
2132                 item = *length = error_mark_node;
2133                 break;
2134               }
2135
2136             start_tree = ffecom_save_tree (start_tree);
2137
2138             item = ffecom_2 (PLUS_EXPR, TREE_TYPE (item),
2139                              item,
2140                              ffecom_2 (MINUS_EXPR,
2141                                        TREE_TYPE (start_tree),
2142                                        start_tree,
2143                                        ffecom_f2c_ftnlen_one_node));
2144
2145             if (end == NULL)
2146               {
2147                 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2148                                     ffecom_f2c_ftnlen_one_node,
2149                                     ffecom_2 (MINUS_EXPR,
2150                                               ffecom_f2c_ftnlen_type_node,
2151                                               *length,
2152                                               start_tree));
2153               }
2154             else
2155               {
2156                 end_tree = ffecom_expr (end);
2157                 if (flag_bounds_check)
2158                   end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2159                                                       char_name);
2160                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2161                                     end_tree);
2162
2163                 if (end_tree == error_mark_node)
2164                   {
2165                     item = *length = error_mark_node;
2166                     break;
2167                   }
2168
2169                 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2170                                     ffecom_f2c_ftnlen_one_node,
2171                                     ffecom_2 (MINUS_EXPR,
2172                                               ffecom_f2c_ftnlen_type_node,
2173                                               end_tree, start_tree));
2174               }
2175           }
2176       }
2177       break;
2178
2179     case FFEBLD_opFUNCREF:
2180       {
2181         ffesymbol s = ffebld_symter (ffebld_left (expr));
2182         tree tempvar;
2183         tree args;
2184         ffetargetCharacterSize size = ffeinfo_size (ffebld_info (expr));
2185         ffecomGfrt ix;
2186
2187         if (size == FFETARGET_charactersizeNONE)
2188           /* ~~Kludge alert!  This should someday be fixed. */
2189           size = 24;
2190
2191         *length = build_int_2 (size, 0);
2192         TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2193
2194         if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
2195             == FFEINFO_whereINTRINSIC)
2196           {
2197             if (size == 1)
2198               {
2199                 /* Invocation of an intrinsic returning CHARACTER*1.  */
2200                 item = ffecom_expr_intrinsic_ (expr, NULL_TREE,
2201                                                NULL, NULL);
2202                 break;
2203               }
2204             ix = ffeintrin_gfrt_direct (ffebld_symter_implementation (ffebld_left (expr)));
2205             assert (ix != FFECOM_gfrt);
2206             item = ffecom_gfrt_tree_ (ix);
2207           }
2208         else
2209           {
2210             ix = FFECOM_gfrt;
2211             item = ffesymbol_hook (s).decl_tree;
2212             if (item == NULL_TREE)
2213               {
2214                 s = ffecom_sym_transform_ (s);
2215                 item = ffesymbol_hook (s).decl_tree;
2216               }
2217             if (item == error_mark_node)
2218               {
2219                 item = *length = error_mark_node;
2220                 break;
2221               }
2222
2223             if (!ffesymbol_hook (s).addr)
2224               item = ffecom_1_fn (item);
2225           }
2226
2227 #ifdef HOHO
2228         tempvar = ffecom_push_tempvar (char_type_node, size, -1, TRUE);
2229 #else
2230         tempvar = ffebld_nonter_hook (expr);
2231         assert (tempvar);
2232 #endif
2233         tempvar = ffecom_1 (ADDR_EXPR,
2234                             build_pointer_type (TREE_TYPE (tempvar)),
2235                             tempvar);
2236
2237         args = build_tree_list (NULL_TREE, tempvar);
2238
2239         if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)       /* Sfunc args by value. */
2240           TREE_CHAIN (args) = ffecom_list_expr (ffebld_right (expr));
2241         else
2242           {
2243             TREE_CHAIN (args) = build_tree_list (NULL_TREE, *length);
2244             if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
2245               {
2246                 TREE_CHAIN (TREE_CHAIN (args))
2247                   = ffecom_arglist_expr_ (ffecom_gfrt_args_ (ix),
2248                                           ffebld_right (expr));
2249               }
2250             else
2251               {
2252                 TREE_CHAIN (TREE_CHAIN (args))
2253                   = ffecom_list_ptr_to_expr (ffebld_right (expr));
2254               }
2255           }
2256
2257         item = ffecom_3s (CALL_EXPR,
2258                           TREE_TYPE (TREE_TYPE (TREE_TYPE (item))),
2259                           item, args, NULL_TREE);
2260         item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item,
2261                          tempvar);
2262       }
2263       break;
2264
2265     case FFEBLD_opCONVERT:
2266
2267       ffecom_char_args_ (&item, length, ffebld_left (expr));
2268
2269       if (item == error_mark_node || *length == error_mark_node)
2270         {
2271           item = *length = error_mark_node;
2272           break;
2273         }
2274
2275       if ((ffebld_size_known (ffebld_left (expr))
2276            == FFETARGET_charactersizeNONE)
2277           || (ffebld_size_known (ffebld_left (expr)) < (ffebld_size (expr))))
2278         {                       /* Possible blank-padding needed, copy into
2279                                    temporary. */
2280           tree tempvar;
2281           tree args;
2282           tree newlen;
2283
2284 #ifdef HOHO
2285           tempvar = ffecom_make_tempvar (char_type_node,
2286                                          ffebld_size (expr), -1);
2287 #else
2288           tempvar = ffebld_nonter_hook (expr);
2289           assert (tempvar);
2290 #endif
2291           tempvar = ffecom_1 (ADDR_EXPR,
2292                               build_pointer_type (TREE_TYPE (tempvar)),
2293                               tempvar);
2294
2295           newlen = build_int_2 (ffebld_size (expr), 0);
2296           TREE_TYPE (newlen) = ffecom_f2c_ftnlen_type_node;
2297
2298           args = build_tree_list (NULL_TREE, tempvar);
2299           TREE_CHAIN (args) = build_tree_list (NULL_TREE, item);
2300           TREE_CHAIN (TREE_CHAIN (args)) = build_tree_list (NULL_TREE, newlen);
2301           TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (args)))
2302             = build_tree_list (NULL_TREE, *length);
2303
2304           item = ffecom_call_gfrt (FFECOM_gfrtCOPY, args, NULL_TREE);
2305           TREE_SIDE_EFFECTS (item) = 1;
2306           item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), fold (item),
2307                            tempvar);
2308           *length = newlen;
2309         }
2310       else
2311         {                       /* Just truncate the length. */
2312           *length = build_int_2 (ffebld_size (expr), 0);
2313           TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2314         }
2315       break;
2316
2317     default:
2318       assert ("bad op for single char arg expr" == NULL);
2319       item = NULL_TREE;
2320       break;
2321     }
2322
2323   *xitem = item;
2324 }
2325 #endif
2326
2327 /* Check the size of the type to be sure it doesn't overflow the
2328    "portable" capacities of the compiler back end.  `dummy' types
2329    can generally overflow the normal sizes as long as the computations
2330    themselves don't overflow.  A particular target of the back end
2331    must still enforce its size requirements, though, and the back
2332    end takes care of this in stor-layout.c.  */
2333
2334 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2335 static tree
2336 ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy)
2337 {
2338   if (TREE_CODE (type) == ERROR_MARK)
2339     return type;
2340
2341   if (TYPE_SIZE (type) == NULL_TREE)
2342     return type;
2343
2344   if (TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST)
2345     return type;
2346
2347   if ((tree_int_cst_sgn (TYPE_SIZE (type)) < 0)
2348       || (!dummy && (((TREE_INT_CST_HIGH (TYPE_SIZE (type)) != 0))
2349                      || TREE_OVERFLOW (TYPE_SIZE (type)))))
2350     {
2351       ffebad_start (FFEBAD_ARRAY_LARGE);
2352       ffebad_string (ffesymbol_text (s));
2353       ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s));
2354       ffebad_finish ();
2355
2356       return error_mark_node;
2357     }
2358
2359   return type;
2360 }
2361 #endif
2362
2363 /* Builds a length argument (PARM_DECL).  Also wraps type in an array type
2364    where the dimension info is (1:size) where <size> is ffesymbol_size(s) if
2365    known, length_arg if not known (FFETARGET_charactersizeNONE).  */
2366
2367 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2368 static tree
2369 ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s)
2370 {
2371   ffetargetCharacterSize sz = ffesymbol_size (s);
2372   tree highval;
2373   tree tlen;
2374   tree type = *xtype;
2375
2376   if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
2377     tlen = NULL_TREE;           /* A statement function, no length passed. */
2378   else
2379     {
2380       if (ffesymbol_where (s) == FFEINFO_whereDUMMY)
2381         tlen = ffecom_get_invented_identifier ("__g77_length_%s",
2382                                                ffesymbol_text (s));
2383       else
2384         tlen = ffecom_get_invented_identifier ("__g77_%s", "length");
2385       tlen = build_decl (PARM_DECL, tlen, ffecom_f2c_ftnlen_type_node);
2386 #if BUILT_FOR_270
2387       DECL_ARTIFICIAL (tlen) = 1;
2388 #endif
2389     }
2390
2391   if (sz == FFETARGET_charactersizeNONE)
2392     {
2393       assert (tlen != NULL_TREE);
2394       highval = variable_size (tlen);
2395     }
2396   else
2397     {
2398       highval = build_int_2 (sz, 0);
2399       TREE_TYPE (highval) = ffecom_f2c_ftnlen_type_node;
2400     }
2401
2402   type = build_array_type (type,
2403                            build_range_type (ffecom_f2c_ftnlen_type_node,
2404                                              ffecom_f2c_ftnlen_one_node,
2405                                              highval));
2406
2407   *xtype = type;
2408   return tlen;
2409 }
2410
2411 #endif
2412 /* ffecom_concat_list_gather_ -- Gather list of concatenated string exprs
2413
2414    ffecomConcatList_ catlist;
2415    ffebld expr;  // expr of CHARACTER basictype.
2416    ffetargetCharacterSize max;  // max chars to gather or _...NONE if no max
2417    catlist = ffecom_concat_list_gather_(catlist,expr,max);
2418
2419    Scans expr for character subexpressions, updates and returns catlist
2420    accordingly.  */
2421
2422 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2423 static ffecomConcatList_
2424 ffecom_concat_list_gather_ (ffecomConcatList_ catlist, ffebld expr,
2425                             ffetargetCharacterSize max)
2426 {
2427   ffetargetCharacterSize sz;
2428
2429 recurse:                        /* :::::::::::::::::::: */
2430
2431   if (expr == NULL)
2432     return catlist;
2433
2434   if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen >= max))
2435     return catlist;             /* Don't append any more items. */
2436
2437   switch (ffebld_op (expr))
2438     {
2439     case FFEBLD_opCONTER:
2440     case FFEBLD_opSYMTER:
2441     case FFEBLD_opARRAYREF:
2442     case FFEBLD_opFUNCREF:
2443     case FFEBLD_opSUBSTR:
2444     case FFEBLD_opCONVERT:      /* Callers should strip this off beforehand
2445                                    if they don't need to preserve it. */
2446       if (catlist.count == catlist.max)
2447         {                       /* Make a (larger) list. */
2448           ffebld *newx;
2449           int newmax;
2450
2451           newmax = (catlist.max == 0) ? 8 : catlist.max * 2;
2452           newx = malloc_new_ks (malloc_pool_image (), "catlist",
2453                                 newmax * sizeof (newx[0]));
2454           if (catlist.max != 0)
2455             {
2456               memcpy (newx, catlist.exprs, catlist.max * sizeof (newx[0]));
2457               malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2458                               catlist.max * sizeof (newx[0]));
2459             }
2460           catlist.max = newmax;
2461           catlist.exprs = newx;
2462         }
2463       if ((sz = ffebld_size_known (expr)) != FFETARGET_charactersizeNONE)
2464         catlist.minlen += sz;
2465       else
2466         ++catlist.minlen;       /* Not true for F90; can be 0 length. */
2467       if ((sz = ffebld_size_max (expr)) == FFETARGET_charactersizeNONE)
2468         catlist.maxlen = sz;
2469       else
2470         catlist.maxlen += sz;
2471       if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen > max))
2472         {                       /* This item overlaps (or is beyond) the end
2473                                    of the destination. */
2474           switch (ffebld_op (expr))
2475             {
2476             case FFEBLD_opCONTER:
2477             case FFEBLD_opSYMTER:
2478             case FFEBLD_opARRAYREF:
2479             case FFEBLD_opFUNCREF:
2480             case FFEBLD_opSUBSTR:
2481               /* ~~Do useful truncations here. */
2482               break;
2483
2484             default:
2485               assert ("op changed or inconsistent switches!" == NULL);
2486               break;
2487             }
2488         }
2489       catlist.exprs[catlist.count++] = expr;
2490       return catlist;
2491
2492     case FFEBLD_opPAREN:
2493       expr = ffebld_left (expr);
2494       goto recurse;             /* :::::::::::::::::::: */
2495
2496     case FFEBLD_opCONCATENATE:
2497       catlist = ffecom_concat_list_gather_ (catlist, ffebld_left (expr), max);
2498       expr = ffebld_right (expr);
2499       goto recurse;             /* :::::::::::::::::::: */
2500
2501 #if 0                           /* Breaks passing small actual arg to larger
2502                                    dummy arg of sfunc */
2503     case FFEBLD_opCONVERT:
2504       expr = ffebld_left (expr);
2505       {
2506         ffetargetCharacterSize cmax;
2507
2508         cmax = catlist.len + ffebld_size_known (expr);
2509
2510         if ((max == FFETARGET_charactersizeNONE) || (max > cmax))
2511           max = cmax;
2512       }
2513       goto recurse;             /* :::::::::::::::::::: */
2514 #endif
2515
2516     case FFEBLD_opANY:
2517       return catlist;
2518
2519     default:
2520       assert ("bad op in _gather_" == NULL);
2521       return catlist;
2522     }
2523 }
2524
2525 #endif
2526 /* ffecom_concat_list_kill_ -- Kill list of concatenated string exprs
2527
2528    ffecomConcatList_ catlist;
2529    ffecom_concat_list_kill_(catlist);
2530
2531    Anything allocated within the list info is deallocated.  */
2532
2533 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2534 static void
2535 ffecom_concat_list_kill_ (ffecomConcatList_ catlist)
2536 {
2537   if (catlist.max != 0)
2538     malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2539                     catlist.max * sizeof (catlist.exprs[0]));
2540 }
2541
2542 #endif
2543 /* Make list of concatenated string exprs.
2544
2545    Returns a flattened list of concatenated subexpressions given a
2546    tree of such expressions.  */
2547
2548 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2549 static ffecomConcatList_
2550 ffecom_concat_list_new_ (ffebld expr, ffetargetCharacterSize max)
2551 {
2552   ffecomConcatList_ catlist;
2553
2554   catlist.maxlen = catlist.minlen = catlist.max = catlist.count = 0;
2555   return ffecom_concat_list_gather_ (catlist, expr, max);
2556 }
2557
2558 #endif
2559
2560 /* Provide some kind of useful info on member of aggregate area,
2561    since current g77/gcc technology does not provide debug info
2562    on these members.  */
2563
2564 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2565 static void
2566 ffecom_debug_kludge_ (tree aggr, const char *aggr_type, ffesymbol member,
2567                       tree member_type UNUSED, ffetargetOffset offset)
2568 {
2569   tree value;
2570   tree decl;
2571   int len;
2572   char *buff;
2573   char space[120];
2574 #if 0
2575   tree type_id;
2576
2577   for (type_id = member_type;
2578        TREE_CODE (type_id) != IDENTIFIER_NODE;
2579        )
2580     {
2581       switch (TREE_CODE (type_id))
2582         {
2583         case INTEGER_TYPE:
2584         case REAL_TYPE:
2585           type_id = TYPE_NAME (type_id);
2586           break;
2587
2588         case ARRAY_TYPE:
2589         case COMPLEX_TYPE:
2590           type_id = TREE_TYPE (type_id);
2591           break;
2592
2593         default:
2594           assert ("no IDENTIFIER_NODE for type!" == NULL);
2595           type_id = error_mark_node;
2596           break;
2597         }
2598     }
2599 #endif
2600
2601   if (ffecom_transform_only_dummies_
2602       || !ffe_is_debug_kludge ())
2603     return;     /* Can't do this yet, maybe later. */
2604
2605   len = 60
2606     + strlen (aggr_type)
2607     + IDENTIFIER_LENGTH (DECL_NAME (aggr));
2608 #if 0
2609     + IDENTIFIER_LENGTH (type_id);
2610 #endif
2611
2612   if (((size_t) len) >= ARRAY_SIZE (space))
2613     buff = malloc_new_ks (malloc_pool_image (), "debug_kludge", len + 1);
2614   else
2615     buff = &space[0];
2616
2617   sprintf (&buff[0], "At (%s) `%s' plus %ld bytes",
2618            aggr_type,
2619            IDENTIFIER_POINTER (DECL_NAME (aggr)),
2620            (long int) offset);
2621
2622   value = build_string (len, buff);
2623   TREE_TYPE (value)
2624     = build_type_variant (build_array_type (char_type_node,
2625                                             build_range_type
2626                                             (integer_type_node,
2627                                              integer_one_node,
2628                                              build_int_2 (strlen (buff), 0))),
2629                           1, 0);
2630   decl = build_decl (VAR_DECL,
2631                      ffecom_get_identifier_ (ffesymbol_text (member)),
2632                      TREE_TYPE (value));
2633   TREE_CONSTANT (decl) = 1;
2634   TREE_STATIC (decl) = 1;
2635   DECL_INITIAL (decl) = error_mark_node;
2636   DECL_IN_SYSTEM_HEADER (decl) = 1;     /* Don't let -Wunused complain. */
2637   decl = start_decl (decl, FALSE);
2638   finish_decl (decl, value, FALSE);
2639
2640   if (buff != &space[0])
2641     malloc_kill_ks (malloc_pool_image (), buff, len + 1);
2642 }
2643 #endif
2644
2645 /* ffecom_do_entry_ -- Do compilation of a particular entrypoint
2646
2647    ffesymbol fn;  // the SUBROUTINE, FUNCTION, or ENTRY symbol itself
2648    int i;  // entry# for this entrypoint (used by master fn)
2649    ffecom_do_entrypoint_(s,i);
2650
2651    Makes a public entry point that calls our private master fn (already
2652    compiled).  */
2653
2654 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2655 static void
2656 ffecom_do_entry_ (ffesymbol fn, int entrynum)
2657 {
2658   ffebld item;
2659   tree type;                    /* Type of function. */
2660   tree multi_retval;            /* Var holding return value (union). */
2661   tree result;                  /* Var holding result. */
2662   ffeinfoBasictype bt;
2663   ffeinfoKindtype kt;
2664   ffeglobal g;
2665   ffeglobalType gt;
2666   bool charfunc;                /* All entry points return same type
2667                                    CHARACTER. */
2668   bool cmplxfunc;               /* Use f2c way of returning COMPLEX. */
2669   bool multi;                   /* Master fn has multiple return types. */
2670   bool altreturning = FALSE;    /* This entry point has alternate returns. */
2671   int old_lineno = lineno;
2672   const char *old_input_filename = input_filename;
2673
2674   input_filename = ffesymbol_where_filename (fn);
2675   lineno = ffesymbol_where_filelinenum (fn);
2676
2677   ffecom_doing_entry_ = TRUE;   /* Don't bother with array dimensions. */
2678
2679   switch (ffecom_primary_entry_kind_)
2680     {
2681     case FFEINFO_kindFUNCTION:
2682
2683       /* Determine actual return type for function. */
2684
2685       gt = FFEGLOBAL_typeFUNC;
2686       bt = ffesymbol_basictype (fn);
2687       kt = ffesymbol_kindtype (fn);
2688       if (bt == FFEINFO_basictypeNONE)
2689         {
2690           ffeimplic_establish_symbol (fn);
2691           if (ffesymbol_funcresult (fn) != NULL)
2692             ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
2693           bt = ffesymbol_basictype (fn);
2694           kt = ffesymbol_kindtype (fn);
2695         }
2696
2697       if (bt == FFEINFO_basictypeCHARACTER)
2698         charfunc = TRUE, cmplxfunc = FALSE;
2699       else if ((bt == FFEINFO_basictypeCOMPLEX)
2700                && ffesymbol_is_f2c (fn))
2701         charfunc = FALSE, cmplxfunc = TRUE;
2702       else
2703         charfunc = cmplxfunc = FALSE;
2704
2705       if (charfunc)
2706         type = ffecom_tree_fun_type_void;
2707       else if (ffesymbol_is_f2c (fn))
2708         type = ffecom_tree_fun_type[bt][kt];
2709       else
2710         type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
2711
2712       if ((type == NULL_TREE)
2713           || (TREE_TYPE (type) == NULL_TREE))
2714         type = ffecom_tree_fun_type_void;       /* _sym_exec_transition. */
2715
2716       multi = (ffecom_master_bt_ == FFEINFO_basictypeNONE);
2717       break;
2718
2719     case FFEINFO_kindSUBROUTINE:
2720       gt = FFEGLOBAL_typeSUBR;
2721       bt = FFEINFO_basictypeNONE;
2722       kt = FFEINFO_kindtypeNONE;
2723       if (ffecom_is_altreturning_)
2724         {                       /* Am _I_ altreturning? */
2725           for (item = ffesymbol_dummyargs (fn);
2726                item != NULL;
2727                item = ffebld_trail (item))
2728             {
2729               if (ffebld_op (ffebld_head (item)) == FFEBLD_opSTAR)
2730                 {
2731                   altreturning = TRUE;
2732                   break;
2733                 }
2734             }
2735           if (altreturning)
2736             type = ffecom_tree_subr_type;
2737           else
2738             type = ffecom_tree_fun_type_void;
2739         }
2740       else
2741         type = ffecom_tree_fun_type_void;
2742       charfunc = FALSE;
2743       cmplxfunc = FALSE;
2744       multi = FALSE;
2745       break;
2746
2747     default:
2748       assert ("say what??" == NULL);
2749       /* Fall through. */
2750     case FFEINFO_kindANY:
2751       gt = FFEGLOBAL_typeANY;
2752       bt = FFEINFO_basictypeNONE;
2753       kt = FFEINFO_kindtypeNONE;
2754       type = error_mark_node;
2755       charfunc = FALSE;
2756       cmplxfunc = FALSE;
2757       multi = FALSE;
2758       break;
2759     }
2760
2761   /* build_decl uses the current lineno and input_filename to set the decl
2762      source info.  So, I've putzed with ffestd and ffeste code to update that
2763      source info to point to the appropriate statement just before calling
2764      ffecom_do_entrypoint (which calls this fn).  */
2765
2766   start_function (ffecom_get_external_identifier_ (fn),
2767                   type,
2768                   0,            /* nested/inline */
2769                   1);           /* TREE_PUBLIC */
2770
2771   if (((g = ffesymbol_global (fn)) != NULL)
2772       && ((ffeglobal_type (g) == gt)
2773           || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
2774     {
2775       ffeglobal_set_hook (g, current_function_decl);
2776     }
2777
2778   /* Reset args in master arg list so they get retransitioned. */
2779
2780   for (item = ffecom_master_arglist_;
2781        item != NULL;
2782        item = ffebld_trail (item))
2783     {
2784       ffebld arg;
2785       ffesymbol s;
2786
2787       arg = ffebld_head (item);
2788       if (ffebld_op (arg) != FFEBLD_opSYMTER)
2789         continue;               /* Alternate return or some such thing. */
2790       s = ffebld_symter (arg);
2791       ffesymbol_hook (s).decl_tree = NULL_TREE;
2792       ffesymbol_hook (s).length_tree = NULL_TREE;
2793     }
2794
2795   /* Build dummy arg list for this entry point. */
2796
2797   if (charfunc || cmplxfunc)
2798     {                           /* Prepend arg for where result goes. */
2799       tree type;
2800       tree length;
2801
2802       if (charfunc)
2803         type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
2804       else
2805         type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
2806
2807       result = ffecom_get_invented_identifier ("__g77_%s", "result");
2808
2809       /* Make length arg _and_ enhance type info for CHAR arg itself.  */
2810
2811       if (charfunc)
2812         length = ffecom_char_enhance_arg_ (&type, fn);
2813       else
2814         length = NULL_TREE;     /* Not ref'd if !charfunc. */
2815
2816       type = build_pointer_type (type);
2817       result = build_decl (PARM_DECL, result, type);
2818
2819       push_parm_decl (result);
2820       ffecom_func_result_ = result;
2821
2822       if (charfunc)
2823         {
2824           push_parm_decl (length);
2825           ffecom_func_length_ = length;
2826         }
2827     }
2828   else
2829     result = DECL_RESULT (current_function_decl);
2830
2831   ffecom_push_dummy_decls_ (ffesymbol_dummyargs (fn), FALSE);
2832
2833   store_parm_decls (0);
2834
2835   ffecom_start_compstmt ();
2836   /* Disallow temp vars at this level.  */
2837   current_binding_level->prep_state = 2;
2838
2839   /* Make local var to hold return type for multi-type master fn. */
2840
2841   if (multi)
2842     {
2843       multi_retval = ffecom_get_invented_identifier ("__g77_%s",
2844                                                      "multi_retval");
2845       multi_retval = build_decl (VAR_DECL, multi_retval,
2846                                  ffecom_multi_type_node_);
2847       multi_retval = start_decl (multi_retval, FALSE);
2848       finish_decl (multi_retval, NULL_TREE, FALSE);
2849     }
2850   else
2851     multi_retval = NULL_TREE;   /* Not actually ref'd if !multi. */
2852
2853   /* Here we emit the actual code for the entry point. */
2854
2855   {
2856     ffebld list;
2857     ffebld arg;
2858     ffesymbol s;
2859     tree arglist = NULL_TREE;
2860     tree *plist = &arglist;
2861     tree prepend;
2862     tree call;
2863     tree actarg;
2864     tree master_fn;
2865
2866     /* Prepare actual arg list based on master arg list. */
2867
2868     for (list = ffecom_master_arglist_;
2869          list != NULL;
2870          list = ffebld_trail (list))
2871       {
2872         arg = ffebld_head (list);
2873         if (ffebld_op (arg) != FFEBLD_opSYMTER)
2874           continue;
2875         s = ffebld_symter (arg);
2876         if (ffesymbol_hook (s).decl_tree == NULL_TREE
2877             || ffesymbol_hook (s).decl_tree == error_mark_node)
2878           actarg = null_pointer_node;   /* We don't have this arg. */
2879         else
2880           actarg = ffesymbol_hook (s).decl_tree;
2881         *plist = build_tree_list (NULL_TREE, actarg);
2882         plist = &TREE_CHAIN (*plist);
2883       }
2884
2885     /* This code appends the length arguments for character
2886        variables/arrays.  */
2887
2888     for (list = ffecom_master_arglist_;
2889          list != NULL;
2890          list = ffebld_trail (list))
2891       {
2892         arg = ffebld_head (list);
2893         if (ffebld_op (arg) != FFEBLD_opSYMTER)
2894           continue;
2895         s = ffebld_symter (arg);
2896         if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
2897           continue;             /* Only looking for CHARACTER arguments. */
2898         if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
2899           continue;             /* Only looking for variables and arrays. */
2900         if (ffesymbol_hook (s).length_tree == NULL_TREE
2901             || ffesymbol_hook (s).length_tree == error_mark_node)
2902           actarg = ffecom_f2c_ftnlen_zero_node; /* We don't have this arg. */
2903         else
2904           actarg = ffesymbol_hook (s).length_tree;
2905         *plist = build_tree_list (NULL_TREE, actarg);
2906         plist = &TREE_CHAIN (*plist);
2907       }
2908
2909     /* Prepend character-value return info to actual arg list. */
2910
2911     if (charfunc)
2912       {
2913         prepend = build_tree_list (NULL_TREE, ffecom_func_result_);
2914         TREE_CHAIN (prepend)
2915           = build_tree_list (NULL_TREE, ffecom_func_length_);
2916         TREE_CHAIN (TREE_CHAIN (prepend)) = arglist;
2917         arglist = prepend;
2918       }
2919
2920     /* Prepend multi-type return value to actual arg list. */
2921
2922     if (multi)
2923       {
2924         prepend
2925           = build_tree_list (NULL_TREE,
2926                              ffecom_1 (ADDR_EXPR,
2927                               build_pointer_type (TREE_TYPE (multi_retval)),
2928                                        multi_retval));
2929         TREE_CHAIN (prepend) = arglist;
2930         arglist = prepend;
2931       }
2932
2933     /* Prepend my entry-point number to the actual arg list. */
2934
2935     prepend = build_tree_list (NULL_TREE, build_int_2 (entrynum, 0));
2936     TREE_CHAIN (prepend) = arglist;
2937     arglist = prepend;
2938
2939     /* Build the call to the master function. */
2940
2941     master_fn = ffecom_1_fn (ffecom_previous_function_decl_);
2942     call = ffecom_3s (CALL_EXPR,
2943                       TREE_TYPE (TREE_TYPE (TREE_TYPE (master_fn))),
2944                       master_fn, arglist, NULL_TREE);
2945
2946     /* Decide whether the master function is a function or subroutine, and
2947        handle the return value for my entry point. */
2948
2949     if (charfunc || ((ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
2950                      && !altreturning))
2951       {
2952         expand_expr_stmt (call);
2953         expand_null_return ();
2954       }
2955     else if (multi && cmplxfunc)
2956       {
2957         expand_expr_stmt (call);
2958         result
2959           = ffecom_1 (INDIRECT_REF,
2960                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
2961                       result);
2962         result = ffecom_modify (NULL_TREE, result,
2963                                 ffecom_2 (COMPONENT_REF, TREE_TYPE (result),
2964                                           multi_retval,
2965                                           ffecom_multi_fields_[bt][kt]));
2966         expand_expr_stmt (result);
2967         expand_null_return ();
2968       }
2969     else if (multi)
2970       {
2971         expand_expr_stmt (call);
2972         result
2973           = ffecom_modify (NULL_TREE, result,
2974                            convert (TREE_TYPE (result),
2975                                     ffecom_2 (COMPONENT_REF,
2976                                               ffecom_tree_type[bt][kt],
2977                                               multi_retval,
2978                                               ffecom_multi_fields_[bt][kt])));
2979         expand_return (result);
2980       }
2981     else if (cmplxfunc)
2982       {
2983         result
2984           = ffecom_1 (INDIRECT_REF,
2985                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
2986                       result);
2987         result = ffecom_modify (NULL_TREE, result, call);
2988         expand_expr_stmt (result);
2989         expand_null_return ();
2990       }
2991     else
2992       {
2993         result = ffecom_modify (NULL_TREE,
2994                                 result,
2995                                 convert (TREE_TYPE (result),
2996                                          call));
2997         expand_return (result);
2998       }
2999   }
3000
3001   ffecom_end_compstmt ();
3002
3003   finish_function (0);
3004
3005   lineno = old_lineno;
3006   input_filename = old_input_filename;
3007
3008   ffecom_doing_entry_ = FALSE;
3009 }
3010
3011 #endif
3012 /* Transform expr into gcc tree with possible destination
3013
3014    Recursive descent on expr while making corresponding tree nodes and
3015    attaching type info and such.  If destination supplied and compatible
3016    with temporary that would be made in certain cases, temporary isn't
3017    made, destination used instead, and dest_used flag set TRUE.  */
3018
3019 #if FFECOM_targetCURRENT == FFECOM_targetGCC
3020 static tree
3021 ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
3022               bool *dest_used, bool assignp, bool widenp)
3023 {
3024   tree item;
3025   tree list;
3026   tree args;
3027   ffeinfoBasictype bt;
3028   ffeinfoKindtype kt;
3029   tree t;
3030   tree dt;                      /* decl_tree for an ffesymbol. */
3031   tree tree_type, tree_type_x;
3032   tree left, right;
3033   ffesymbol s;
3034   enum tree_code code;
3035
3036   assert (expr != NULL);
3037
3038   if (dest_used != NULL)
3039     *dest_used = FALSE;
3040
3041   bt = ffeinfo_basictype (ffebld_info (expr));
3042   kt = ffeinfo_kindtype (ffebld_info (expr));
3043   tree_type = ffecom_tree_type[bt][kt];
3044
3045   /* Widen integral arithmetic as desired while preserving signedness.  */
3046   tree_type_x = NULL_TREE;
3047   if (widenp && tree_type
3048       && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
3049       && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
3050     tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
3051
3052   switch (ffebld_op (expr))
3053     {
3054     case FFEBLD_opACCTER:
3055       {
3056         ffebitCount i;
3057         ffebit bits = ffebld_accter_bits (expr);
3058         ffetargetOffset source_offset = 0;
3059         ffetargetOffset dest_offset = ffebld_accter_pad (expr);
3060         tree purpose;
3061
3062         assert (dest_offset == 0
3063                 || (bt == FFEINFO_basictypeCHARACTER
3064                     && kt == FFEINFO_kindtypeCHARACTER1));
3065
3066         list = item = NULL;
3067         for (;;)
3068           {
3069             ffebldConstantUnion cu;
3070             ffebitCount length;
3071             bool value;
3072             ffebldConstantArray ca = ffebld_accter (expr);
3073
3074             ffebit_test (bits, source_offset, &value, &length);
3075             if (length == 0)
3076               break;
3077
3078             if (value)
3079               {
3080                 for (i = 0; i < length; ++i)
3081                   {
3082                     cu = ffebld_constantarray_get (ca, bt, kt,
3083                                                    source_offset + i);
3084
3085                     t = ffecom_constantunion (&cu, bt, kt, tree_type);
3086
3087                     if (i == 0
3088                         && dest_offset != 0)
3089                       purpose = build_int_2 (dest_offset, 0);
3090                     else
3091                       purpose = NULL_TREE;
3092
3093                     if (list == NULL_TREE)
3094                       list = item = build_tree_list (purpose, t);
3095                     else
3096                       {
3097                         TREE_CHAIN (item) = build_tree_list (purpose, t);
3098                         item = TREE_CHAIN (item);
3099                       }
3100                   }
3101               }
3102             source_offset += length;
3103             dest_offset += length;
3104           }
3105       }
3106
3107       item = build_int_2 ((ffebld_accter_size (expr)
3108                            + ffebld_accter_pad (expr)) - 1, 0);
3109       ffebit_kill (ffebld_accter_bits (expr));
3110       TREE_TYPE (item) = ffecom_integer_type_node;
3111       item
3112         = build_array_type
3113           (tree_type,
3114            build_range_type (ffecom_integer_type_node,
3115                              ffecom_integer_zero_node,
3116                              item));
3117       list = build (CONSTRUCTOR, item, NULL_TREE, list);
3118       TREE_CONSTANT (list) = 1;
3119       TREE_STATIC (list) = 1;
3120       return list;
3121
3122     case FFEBLD_opARRTER:
3123       {
3124         ffetargetOffset i;
3125
3126         list = NULL_TREE;
3127         if (ffebld_arrter_pad (expr) == 0)
3128           item = NULL_TREE;
3129         else
3130           {
3131             assert (bt == FFEINFO_basictypeCHARACTER
3132                     && kt == FFEINFO_kindtypeCHARACTER1);
3133
3134             /* Becomes PURPOSE first time through loop.  */
3135             item = build_int_2 (ffebld_arrter_pad (expr), 0);
3136           }
3137
3138         for (i = 0; i < ffebld_arrter_size (expr); ++i)
3139           {
3140             ffebldConstantUnion cu
3141             = ffebld_constantarray_get (ffebld_arrter (expr), bt, kt, i);
3142
3143             t = ffecom_constantunion (&cu, bt, kt, tree_type);
3144
3145             if (list == NULL_TREE)
3146               /* Assume item is PURPOSE first time through loop.  */
3147               list = item = build_tree_list (item, t);
3148             else
3149               {
3150                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
3151                 item = TREE_CHAIN (item);
3152               }
3153           }
3154       }
3155
3156       item = build_int_2 ((ffebld_arrter_size (expr)
3157                           + ffebld_arrter_pad (expr)) - 1, 0);
3158       TREE_TYPE (item) = ffecom_integer_type_node;
3159       item
3160         = build_array_type
3161           (tree_type,
3162            build_range_type (ffecom_integer_type_node,
3163                              ffecom_integer_zero_node,
3164                              item));
3165       list = build (CONSTRUCTOR, item, NULL_TREE, list);
3166       TREE_CONSTANT (list) = 1;
3167       TREE_STATIC (list) = 1;
3168       return list;
3169
3170     case FFEBLD_opCONTER:
3171       assert (ffebld_conter_pad (expr) == 0);
3172       item
3173         = ffecom_constantunion (&ffebld_constant_union (ffebld_conter (expr)),
3174                                 bt, kt, tree_type);
3175       return item;
3176
3177     case FFEBLD_opSYMTER:
3178       if ((ffebld_symter_generic (expr) != FFEINTRIN_genNONE)
3179           || (ffebld_symter_specific (expr) != FFEINTRIN_specNONE))
3180         return ffecom_ptr_to_expr (expr);       /* Same as %REF(intrinsic). */
3181       s = ffebld_symter (expr);
3182       t = ffesymbol_hook (s).decl_tree;
3183
3184       if (assignp)
3185         {                       /* ASSIGN'ed-label expr. */
3186           if (ffe_is_ugly_assign ())
3187             {
3188               /* User explicitly wants ASSIGN'ed variables to be at the same
3189                  memory address as the variables when used in non-ASSIGN
3190                  contexts.  That can make old, arcane, non-standard code
3191                  work, but don't try to do it when a pointer wouldn't fit
3192                  in the normal variable (take other approach, and warn,
3193                  instead).  */
3194
3195               if (t == NULL_TREE)
3196                 {
3197                   s = ffecom_sym_transform_ (s);
3198                   t = ffesymbol_hook (s).decl_tree;
3199                   assert (t != NULL_TREE);
3200                 }
3201
3202               if (t == error_mark_node)
3203                 return t;
3204
3205               if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t)))
3206                   >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
3207                 {
3208                   if (ffesymbol_hook (s).addr)
3209                     t = ffecom_1 (INDIRECT_REF,
3210                                   TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3211                   return t;
3212                 }
3213
3214               if (ffesymbol_hook (s).assign_tree == NULL_TREE)
3215                 {
3216                   ffebad_start_msg ("ASSIGN'ed label cannot fit into `%A' at %0 -- using wider sibling",
3217                                     FFEBAD_severityWARNING);
3218                   ffebad_string (ffesymbol_text (s));
3219                   ffebad_here (0, ffesymbol_where_line (s),
3220                                ffesymbol_where_column (s));
3221                   ffebad_finish ();
3222                 }
3223             }
3224
3225           /* Don't use the normal variable's tree for ASSIGN, though mark
3226              it as in the system header (housekeeping).  Use an explicit,
3227              specially created sibling that is known to be wide enough
3228              to hold pointers to labels.  */
3229
3230           if (t != NULL_TREE
3231               && TREE_CODE (t) == VAR_DECL)
3232             DECL_IN_SYSTEM_HEADER (t) = 1;      /* Don't let -Wunused complain. */
3233
3234           t = ffesymbol_hook (s).assign_tree;
3235           if (t == NULL_TREE)
3236             {
3237               s = ffecom_sym_transform_assign_ (s);
3238               t = ffesymbol_hook (s).assign_tree;
3239               assert (t != NULL_TREE);
3240             }
3241         }
3242       else
3243         {
3244           if (t == NULL_TREE)
3245             {
3246               s = ffecom_sym_transform_ (s);
3247               t = ffesymbol_hook (s).decl_tree;
3248               assert (t != NULL_TREE);
3249             }
3250           if (ffesymbol_hook (s).addr)
3251             t = ffecom_1 (INDIRECT_REF,
3252                           TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3253         }
3254       return t;
3255
3256     case FFEBLD_opARRAYREF:
3257       return ffecom_arrayref_ (NULL_TREE, expr, 0);
3258
3259     case FFEBLD_opUPLUS:
3260       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3261       return ffecom_1 (NOP_EXPR, tree_type, left);
3262
3263     case FFEBLD_opPAREN:
3264       /* ~~~Make sure Fortran rules respected here */
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_opUMINUS:
3269       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3270       if (tree_type_x)
3271         {
3272           tree_type = tree_type_x;
3273           left = convert (tree_type, left);
3274         }
3275       return ffecom_1 (NEGATE_EXPR, tree_type, left);
3276
3277     case FFEBLD_opADD:
3278       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3279       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3280       if (tree_type_x)
3281         {
3282           tree_type = tree_type_x;
3283           left = convert (tree_type, left);
3284           right = convert (tree_type, right);
3285         }
3286       return ffecom_2 (PLUS_EXPR, tree_type, left, right);
3287
3288     case FFEBLD_opSUBTRACT:
3289       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3290       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3291       if (tree_type_x)
3292         {
3293           tree_type = tree_type_x;
3294           left = convert (tree_type, left);
3295           right = convert (tree_type, right);
3296         }
3297       return ffecom_2 (MINUS_EXPR, tree_type, left, right);
3298
3299     case FFEBLD_opMULTIPLY:
3300       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3301       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3302       if (tree_type_x)
3303         {
3304           tree_type = tree_type_x;
3305           left = convert (tree_type, left);
3306           right = convert (tree_type, right);
3307         }
3308       return ffecom_2 (MULT_EXPR, tree_type, left, right);
3309
3310     case FFEBLD_opDIVIDE:
3311       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3312       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3313       if (tree_type_x)
3314         {
3315           tree_type = tree_type_x;
3316           left = convert (tree_type, left);
3317           right = convert (tree_type, right);
3318         }
3319       return ffecom_tree_divide_ (tree_type, left, right,
3320                                   dest_tree, dest, dest_used,
3321                                   ffebld_nonter_hook (expr));
3322
3323     case FFEBLD_opPOWER:
3324       {
3325         ffebld left = ffebld_left (expr);
3326         ffebld right = ffebld_right (expr);
3327         ffecomGfrt code;
3328         ffeinfoKindtype rtkt;
3329         ffeinfoKindtype ltkt;
3330         bool ref = TRUE;
3331
3332         switch (ffeinfo_basictype (ffebld_info (right)))
3333           {
3334
3335           case FFEINFO_basictypeINTEGER:
3336             if (1 || optimize)
3337               {
3338                 item = ffecom_expr_power_integer_ (expr);
3339                 if (item != NULL_TREE)
3340                   return item;
3341               }
3342
3343             rtkt = FFEINFO_kindtypeINTEGER1;
3344             switch (ffeinfo_basictype (ffebld_info (left)))
3345               {
3346               case FFEINFO_basictypeINTEGER:
3347                 if ((ffeinfo_kindtype (ffebld_info (left))
3348                     == FFEINFO_kindtypeINTEGER4)
3349                     || (ffeinfo_kindtype (ffebld_info (right))
3350                         == FFEINFO_kindtypeINTEGER4))
3351                   {
3352                     code = FFECOM_gfrtPOW_QQ;
3353                     ltkt = FFEINFO_kindtypeINTEGER4;
3354                     rtkt = FFEINFO_kindtypeINTEGER4;
3355                   }
3356                 else
3357                   {
3358                     code = FFECOM_gfrtPOW_II;
3359                     ltkt = FFEINFO_kindtypeINTEGER1;
3360                   }
3361                 break;
3362
3363               case FFEINFO_basictypeREAL:
3364                 if (ffeinfo_kindtype (ffebld_info (left))
3365                     == FFEINFO_kindtypeREAL1)
3366                   {
3367                     code = FFECOM_gfrtPOW_RI;
3368                     ltkt = FFEINFO_kindtypeREAL1;
3369                   }
3370                 else
3371                   {
3372                     code = FFECOM_gfrtPOW_DI;
3373                     ltkt = FFEINFO_kindtypeREAL2;
3374                   }
3375                 break;
3376
3377               case FFEINFO_basictypeCOMPLEX:
3378                 if (ffeinfo_kindtype (ffebld_info (left))
3379                     == FFEINFO_kindtypeREAL1)
3380                   {
3381                     code = FFECOM_gfrtPOW_CI;   /* Overlapping result okay. */
3382                     ltkt = FFEINFO_kindtypeREAL1;
3383                   }
3384                 else
3385                   {
3386                     code = FFECOM_gfrtPOW_ZI;   /* Overlapping result okay. */
3387                     ltkt = FFEINFO_kindtypeREAL2;
3388                   }
3389                 break;
3390
3391               default:
3392                 assert ("bad pow_*i" == NULL);
3393                 code = FFECOM_gfrtPOW_CI;       /* Overlapping result okay. */
3394                 ltkt = FFEINFO_kindtypeREAL1;
3395                 break;
3396               }
3397             if (ffeinfo_kindtype (ffebld_info (left)) != ltkt)
3398               left = ffeexpr_convert (left, NULL, NULL,
3399                                       ffeinfo_basictype (ffebld_info (left)),
3400                                       ltkt, 0,
3401                                       FFETARGET_charactersizeNONE,
3402                                       FFEEXPR_contextLET);
3403             if (ffeinfo_kindtype (ffebld_info (right)) != rtkt)
3404               right = ffeexpr_convert (right, NULL, NULL,
3405                                        FFEINFO_basictypeINTEGER,
3406                                        rtkt, 0,
3407                                        FFETARGET_charactersizeNONE,
3408                                        FFEEXPR_contextLET);
3409             break;
3410
3411           case FFEINFO_basictypeREAL:
3412             if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3413               left = ffeexpr_convert (left, NULL, NULL, FFEINFO_basictypeREAL,
3414                                       FFEINFO_kindtypeREALDOUBLE, 0,
3415                                       FFETARGET_charactersizeNONE,
3416                                       FFEEXPR_contextLET);
3417             if (ffeinfo_kindtype (ffebld_info (right))
3418                 == FFEINFO_kindtypeREAL1)
3419               right = ffeexpr_convert (right, NULL, NULL,
3420                                        FFEINFO_basictypeREAL,
3421                                        FFEINFO_kindtypeREALDOUBLE, 0,
3422                                        FFETARGET_charactersizeNONE,
3423                                        FFEEXPR_contextLET);
3424             /* We used to call FFECOM_gfrtPOW_DD here,
3425                which passes arguments by reference.  */
3426             code = FFECOM_gfrtL_POW;
3427             /* Pass arguments by value. */
3428             ref  = FALSE;
3429             break;
3430
3431           case FFEINFO_basictypeCOMPLEX:
3432             if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3433               left = ffeexpr_convert (left, NULL, NULL,
3434                                       FFEINFO_basictypeCOMPLEX,
3435                                       FFEINFO_kindtypeREALDOUBLE, 0,
3436                                       FFETARGET_charactersizeNONE,
3437                                       FFEEXPR_contextLET);
3438             if (ffeinfo_kindtype (ffebld_info (right))
3439                 == FFEINFO_kindtypeREAL1)
3440               right = ffeexpr_convert (right, NULL, NULL,
3441                                        FFEINFO_basictypeCOMPLEX,
3442                                        FFEINFO_kindtypeREALDOUBLE, 0,
3443                                        FFETARGET_charactersizeNONE,
3444                                        FFEEXPR_contextLET);
3445             code = FFECOM_gfrtPOW_ZZ;   /* Overlapping result okay. */
3446             ref = TRUE;                 /* Pass arguments by reference. */
3447             break;
3448
3449           default:
3450             assert ("bad pow_x*" == NULL);
3451             code = FFECOM_gfrtPOW_II;
3452             break;
3453           }
3454         return ffecom_call_binop_ (ffecom_gfrt_tree_ (code),
3455                                    ffecom_gfrt_kindtype (code),
3456                                    (ffe_is_f2c_library ()
3457                                     && ffecom_gfrt_complex_[code]),
3458                                    tree_type, left, right,
3459                                    dest_tree, dest, dest_used,
3460                                    NULL_TREE, FALSE, ref,
3461                                    ffebld_nonter_hook (expr));
3462       }
3463
3464     case FFEBLD_opNOT:
3465       switch (bt)
3466         {
3467         case FFEINFO_basictypeLOGICAL:
3468           item = ffecom_truth_value_invert (ffecom_expr (ffebld_left (expr)));
3469           return convert (tree_type, item);
3470
3471         case FFEINFO_basictypeINTEGER:
3472           return ffecom_1 (BIT_NOT_EXPR, tree_type,
3473                            ffecom_expr (ffebld_left (expr)));
3474
3475         default:
3476           assert ("NOT bad basictype" == NULL);
3477           /* Fall through. */
3478         case FFEINFO_basictypeANY:
3479           return error_mark_node;
3480         }
3481       break;
3482
3483     case FFEBLD_opFUNCREF:
3484       assert (ffeinfo_basictype (ffebld_info (expr))
3485               != FFEINFO_basictypeCHARACTER);
3486       /* Fall through.   */
3487     case FFEBLD_opSUBRREF:
3488       if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
3489           == FFEINFO_whereINTRINSIC)
3490         {                       /* Invocation of an intrinsic. */
3491           item = ffecom_expr_intrinsic_ (expr, dest_tree, dest,
3492                                          dest_used);
3493           return item;
3494         }
3495       s = ffebld_symter (ffebld_left (expr));
3496       dt = ffesymbol_hook (s).decl_tree;
3497       if (dt == NULL_TREE)
3498         {
3499           s = ffecom_sym_transform_ (s);
3500           dt = ffesymbol_hook (s).decl_tree;
3501         }
3502       if (dt == error_mark_node)
3503         return dt;
3504
3505       if (ffesymbol_hook (s).addr)
3506         item = dt;
3507       else
3508         item = ffecom_1_fn (dt);
3509
3510       if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
3511         args = ffecom_list_expr (ffebld_right (expr));
3512       else
3513         args = ffecom_list_ptr_to_expr (ffebld_right (expr));
3514
3515       if (args == error_mark_node)
3516         return error_mark_node;
3517
3518       item = ffecom_call_ (item, kt,
3519                            ffesymbol_is_f2c (s)
3520                            && (bt == FFEINFO_basictypeCOMPLEX)
3521                            && (ffesymbol_where (s)
3522                                != FFEINFO_whereCONSTANT),
3523                            tree_type,
3524                            args,
3525                            dest_tree, dest, dest_used,
3526                            error_mark_node, FALSE,
3527                            ffebld_nonter_hook (expr));
3528       TREE_SIDE_EFFECTS (item) = 1;
3529       return item;
3530
3531     case FFEBLD_opAND:
3532       switch (bt)
3533         {
3534         case FFEINFO_basictypeLOGICAL:
3535           item
3536             = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3537                        ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3538                      ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3539           return convert (tree_type, item);
3540
3541         case FFEINFO_basictypeINTEGER:
3542           return ffecom_2 (BIT_AND_EXPR, tree_type,
3543                            ffecom_expr (ffebld_left (expr)),
3544                            ffecom_expr (ffebld_right (expr)));
3545
3546         default:
3547           assert ("AND bad basictype" == NULL);
3548           /* Fall through. */
3549         case FFEINFO_basictypeANY:
3550           return error_mark_node;
3551         }
3552       break;
3553
3554     case FFEBLD_opOR:
3555       switch (bt)
3556         {
3557         case FFEINFO_basictypeLOGICAL:
3558           item
3559             = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
3560                        ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3561                      ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3562           return convert (tree_type, item);
3563
3564         case FFEINFO_basictypeINTEGER:
3565           return ffecom_2 (BIT_IOR_EXPR, tree_type,
3566                            ffecom_expr (ffebld_left (expr)),
3567                            ffecom_expr (ffebld_right (expr)));
3568
3569         default:
3570           assert ("OR bad basictype" == NULL);
3571           /* Fall through. */
3572         case FFEINFO_basictypeANY:
3573           return error_mark_node;
3574         }
3575       break;
3576
3577     case FFEBLD_opXOR:
3578     case FFEBLD_opNEQV:
3579       switch (bt)
3580         {
3581         case FFEINFO_basictypeLOGICAL:
3582           item
3583             = ffecom_2 (NE_EXPR, integer_type_node,
3584                         ffecom_expr (ffebld_left (expr)),
3585                         ffecom_expr (ffebld_right (expr)));
3586           return convert (tree_type, ffecom_truth_value (item));
3587
3588         case FFEINFO_basictypeINTEGER:
3589           return ffecom_2 (BIT_XOR_EXPR, tree_type,
3590                            ffecom_expr (ffebld_left (expr)),
3591                            ffecom_expr (ffebld_right (expr)));
3592
3593         default:
3594           assert ("XOR/NEQV bad basictype" == NULL);
3595           /* Fall through. */
3596         case FFEINFO_basictypeANY:
3597           return error_mark_node;
3598         }
3599       break;
3600
3601     case FFEBLD_opEQV:
3602       switch (bt)
3603         {
3604         case FFEINFO_basictypeLOGICAL:
3605           item
3606             = ffecom_2 (EQ_EXPR, integer_type_node,
3607                         ffecom_expr (ffebld_left (expr)),
3608                         ffecom_expr (ffebld_right (expr)));
3609           return convert (tree_type, ffecom_truth_value (item));
3610
3611         case FFEINFO_basictypeINTEGER:
3612           return
3613             ffecom_1 (BIT_NOT_EXPR, tree_type,
3614                       ffecom_2 (BIT_XOR_EXPR, tree_type,
3615                                 ffecom_expr (ffebld_left (expr)),
3616                                 ffecom_expr (ffebld_right (expr))));
3617
3618         default:
3619           assert ("EQV bad basictype" == NULL);
3620           /* Fall through. */
3621         case FFEINFO_basictypeANY:
3622           return error_mark_node;
3623         }
3624       break;
3625
3626     case FFEBLD_opCONVERT:
3627       if (ffebld_op (ffebld_left (expr)) == FFEBLD_opANY)
3628         return error_mark_node;
3629
3630       switch (bt)
3631         {
3632         case FFEINFO_basictypeLOGICAL:
3633         case FFEINFO_basictypeINTEGER:
3634         case FFEINFO_basictypeREAL:
3635           return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3636
3637         case FFEINFO_basictypeCOMPLEX:
3638           switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3639             {
3640             case FFEINFO_basictypeINTEGER:
3641             case FFEINFO_basictypeLOGICAL:
3642             case FFEINFO_basictypeREAL:
3643               item = ffecom_expr (ffebld_left (expr));
3644               if (item == error_mark_node)
3645                 return error_mark_node;
3646               /* convert() takes care of converting to the subtype first,
3647                  at least in gcc-2.7.2. */
3648               item = convert (tree_type, item);
3649               return item;
3650
3651             case FFEINFO_basictypeCOMPLEX:
3652               return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3653
3654             default:
3655               assert ("CONVERT COMPLEX bad basictype" == NULL);
3656               /* Fall through. */
3657             case FFEINFO_basictypeANY:
3658               return error_mark_node;
3659             }
3660           break;
3661
3662         default:
3663           assert ("CONVERT bad basictype" == NULL);
3664           /* Fall through. */
3665         case FFEINFO_basictypeANY:
3666           return error_mark_node;
3667         }
3668       break;
3669
3670     case FFEBLD_opLT:
3671       code = LT_EXPR;
3672       goto relational;          /* :::::::::::::::::::: */
3673
3674     case FFEBLD_opLE:
3675       code = LE_EXPR;
3676       goto relational;          /* :::::::::::::::::::: */
3677
3678     case FFEBLD_opEQ:
3679       code = EQ_EXPR;
3680       goto relational;          /* :::::::::::::::::::: */
3681
3682     case FFEBLD_opNE:
3683       code = NE_EXPR;
3684       goto relational;          /* :::::::::::::::::::: */
3685
3686     case FFEBLD_opGT:
3687       code = GT_EXPR;
3688       goto relational;          /* :::::::::::::::::::: */
3689
3690     case FFEBLD_opGE:
3691       code = GE_EXPR;
3692
3693     relational:         /* :::::::::::::::::::: */
3694       switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3695         {
3696         case FFEINFO_basictypeLOGICAL:
3697         case FFEINFO_basictypeINTEGER:
3698         case FFEINFO_basictypeREAL:
3699           item = ffecom_2 (code, integer_type_node,
3700                            ffecom_expr (ffebld_left (expr)),
3701                            ffecom_expr (ffebld_right (expr)));
3702           return convert (tree_type, item);
3703
3704         case FFEINFO_basictypeCOMPLEX:
3705           assert (code == EQ_EXPR || code == NE_EXPR);
3706           {
3707             tree real_type;
3708             tree arg1 = ffecom_expr (ffebld_left (expr));
3709             tree arg2 = ffecom_expr (ffebld_right (expr));
3710
3711             if (arg1 == error_mark_node || arg2 == error_mark_node)
3712               return error_mark_node;
3713
3714             arg1 = ffecom_save_tree (arg1);
3715             arg2 = ffecom_save_tree (arg2);
3716
3717             if (TREE_CODE (TREE_TYPE (arg1)) == COMPLEX_TYPE)
3718               {
3719                 real_type = TREE_TYPE (TREE_TYPE (arg1));
3720                 assert (real_type == TREE_TYPE (TREE_TYPE (arg2)));
3721               }
3722             else
3723               {
3724                 real_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg1)));
3725                 assert (real_type == TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg2))));
3726               }
3727
3728             item
3729               = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3730                           ffecom_2 (EQ_EXPR, integer_type_node,
3731                                   ffecom_1 (REALPART_EXPR, real_type, arg1),
3732                                  ffecom_1 (REALPART_EXPR, real_type, arg2)),
3733                           ffecom_2 (EQ_EXPR, integer_type_node,
3734                                   ffecom_1 (IMAGPART_EXPR, real_type, arg1),
3735                                     ffecom_1 (IMAGPART_EXPR, real_type,
3736                                               arg2)));
3737             if (code == EQ_EXPR)
3738               item = ffecom_truth_value (item);
3739             else
3740               item = ffecom_truth_value_invert (item);
3741             return convert (tree_type, item);
3742           }
3743
3744         case FFEINFO_basictypeCHARACTER:
3745           {
3746             ffebld left = ffebld_left (expr);
3747             ffebld right = ffebld_right (expr);
3748             tree left_tree;
3749             tree right_tree;
3750             tree left_length;
3751             tree right_length;
3752
3753             /* f2c run-time functions do the implicit blank-padding for us,
3754                so we don't usually have to implement blank-padding ourselves.
3755                (The exception is when we pass an argument to a separately
3756                compiled statement function -- if we know the arg is not the
3757                same length as the dummy, we must truncate or extend it.  If
3758                we "inline" statement functions, that necessity goes away as
3759                well.)
3760
3761                Strip off the CONVERT operators that blank-pad.  (Truncation by
3762                CONVERT shouldn't happen here, but it can happen in
3763                assignments.) */
3764
3765             while (ffebld_op (left) == FFEBLD_opCONVERT)
3766               left = ffebld_left (left);
3767             while (ffebld_op (right) == FFEBLD_opCONVERT)
3768               right = ffebld_left (right);
3769
3770             left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
3771             right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
3772
3773             if (left_tree == error_mark_node || left_length == error_mark_node
3774                 || right_tree == error_mark_node
3775                 || right_length == error_mark_node)
3776               return error_mark_node;
3777
3778             if ((ffebld_size_known (left) == 1)
3779                 && (ffebld_size_known (right) == 1))
3780               {
3781                 left_tree
3782                   = ffecom_1 (INDIRECT_REF,
3783                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3784                               left_tree);
3785                 right_tree
3786                   = ffecom_1 (INDIRECT_REF,
3787                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3788                               right_tree);
3789
3790                 item
3791                   = ffecom_2 (code, integer_type_node,
3792                               ffecom_2 (ARRAY_REF,
3793                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3794                                         left_tree,
3795                                         integer_one_node),
3796                               ffecom_2 (ARRAY_REF,
3797                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3798                                         right_tree,
3799                                         integer_one_node));
3800               }
3801             else
3802               {
3803                 item = build_tree_list (NULL_TREE, left_tree);
3804                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, right_tree);
3805                 TREE_CHAIN (TREE_CHAIN (item)) = build_tree_list (NULL_TREE,
3806                                                                left_length);
3807                 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
3808                   = build_tree_list (NULL_TREE, right_length);
3809                 item = ffecom_call_gfrt (FFECOM_gfrtCMP, item, NULL_TREE);
3810                 item = ffecom_2 (code, integer_type_node,
3811                                  item,
3812                                  convert (TREE_TYPE (item),
3813                                           integer_zero_node));
3814               }
3815             item = convert (tree_type, item);
3816           }
3817
3818           return item;
3819
3820         default:
3821           assert ("relational bad basictype" == NULL);
3822           /* Fall through. */
3823         case FFEINFO_basictypeANY:
3824           return error_mark_node;
3825         }
3826       break;
3827
3828     case FFEBLD_opPERCENT_LOC:
3829       item = ffecom_arg_ptr_to_expr (ffebld_left (expr), &list);
3830       return convert (tree_type, item);
3831
3832     case FFEBLD_opITEM:
3833     case FFEBLD_opSTAR:
3834     case FFEBLD_opBOUNDS:
3835     case FFEBLD_opREPEAT:
3836     case FFEBLD_opLABTER:
3837     case FFEBLD_opLABTOK:
3838     case FFEBLD_opIMPDO:
3839     case FFEBLD_opCONCATENATE:
3840     case FFEBLD_opSUBSTR:
3841     default:
3842       assert ("bad op" == NULL);
3843       /* Fall through. */
3844     case FFEBLD_opANY:
3845       return error_mark_node;
3846     }
3847
3848 #if 1
3849   assert ("didn't think anything got here anymore!!" == NULL);
3850 #else
3851   switch (ffebld_arity (expr))
3852     {
3853     case 2:
3854       TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3855       TREE_OPERAND (item, 1) = ffecom_expr (ffebld_right (expr));
3856       if (TREE_OPERAND (item, 0) == error_mark_node
3857           || TREE_OPERAND (item, 1) == error_mark_node)
3858         return error_mark_node;
3859       break;
3860
3861     case 1:
3862       TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3863       if (TREE_OPERAND (item, 0) == error_mark_node)
3864         return error_mark_node;
3865       break;
3866
3867     default:
3868       break;
3869     }
3870
3871   return fold (item);
3872 #endif
3873 }
3874
3875 #endif
3876 /* Returns the tree that does the intrinsic invocation.
3877
3878    Note: this function applies only to intrinsics returning
3879    CHARACTER*1 or non-CHARACTER results, and to intrinsic
3880    subroutines.  */
3881
3882 #if FFECOM_targetCURRENT == FFECOM_targetGCC
3883 static tree
3884 ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
3885                         ffebld dest, bool *dest_used)
3886 {
3887   tree expr_tree;
3888   tree saved_expr1;             /* For those who need it. */
3889   tree saved_expr2;             /* For those who need it. */
3890   ffeinfoBasictype bt;
3891   ffeinfoKindtype kt;
3892   tree tree_type;
3893   tree arg1_type;
3894   tree real_type;               /* REAL type corresponding to COMPLEX. */
3895   tree tempvar;
3896   ffebld list = ffebld_right (expr);    /* List of (some) args. */
3897   ffebld arg1;                  /* For handy reference. */
3898   ffebld arg2;
3899   ffebld arg3;
3900   ffeintrinImp codegen_imp;
3901   ffecomGfrt gfrt;
3902
3903   assert (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER);
3904
3905   if (dest_used != NULL)
3906     *dest_used = FALSE;
3907
3908   bt = ffeinfo_basictype (ffebld_info (expr));
3909   kt = ffeinfo_kindtype (ffebld_info (expr));
3910   tree_type = ffecom_tree_type[bt][kt];
3911
3912   if (list != NULL)
3913     {
3914       arg1 = ffebld_head (list);
3915       if (arg1 != NULL && ffebld_op (arg1) == FFEBLD_opANY)
3916         return error_mark_node;
3917       if ((list = ffebld_trail (list)) != NULL)
3918         {
3919           arg2 = ffebld_head (list);
3920           if (arg2 != NULL && ffebld_op (arg2) == FFEBLD_opANY)
3921             return error_mark_node;
3922           if ((list = ffebld_trail (list)) != NULL)
3923             {
3924               arg3 = ffebld_head (list);
3925               if (arg3 != NULL && ffebld_op (arg3) == FFEBLD_opANY)
3926                 return error_mark_node;
3927             }
3928           else
3929             arg3 = NULL;
3930         }
3931       else
3932         arg2 = arg3 = NULL;
3933     }
3934   else
3935     arg1 = arg2 = arg3 = NULL;
3936
3937   /* <list> ends up at the opITEM of the 3rd arg, or NULL if there are < 3
3938      args.  This is used by the MAX/MIN expansions. */
3939
3940   if (arg1 != NULL)
3941     arg1_type = ffecom_tree_type
3942       [ffeinfo_basictype (ffebld_info (arg1))]
3943       [ffeinfo_kindtype (ffebld_info (arg1))];
3944   else
3945     arg1_type = NULL_TREE;      /* Really not needed, but might catch bugs
3946                                    here. */
3947
3948   /* There are several ways for each of the cases in the following switch
3949      statements to exit (from simplest to use to most complicated):
3950
3951      break;  (when expr_tree == NULL)
3952
3953      A standard call is made to the specific intrinsic just as if it had been
3954      passed in as a dummy procedure and called as any old procedure.  This
3955      method can produce slower code but in some cases it's the easiest way for
3956      now.  However, if a (presumably faster) direct call is available,
3957      that is used, so this is the easiest way in many more cases now.
3958
3959      gfrt = FFECOM_gfrtWHATEVER;
3960      break;
3961
3962      gfrt contains the gfrt index of a library function to call, passing the
3963      argument(s) by value rather than by reference.  Used when a more
3964      careful choice of library function is needed than that provided
3965      by the vanilla `break;'.
3966
3967      return expr_tree;
3968
3969      The expr_tree has been completely set up and is ready to be returned
3970      as is.  No further actions are taken.  Use this when the tree is not
3971      in the simple form for one of the arity_n labels.   */
3972
3973   /* For info on how the switch statement cases were written, see the files
3974      enclosed in comments below the switch statement. */
3975
3976   codegen_imp = ffebld_symter_implementation (ffebld_left (expr));
3977   gfrt = ffeintrin_gfrt_direct (codegen_imp);
3978   if (gfrt == FFECOM_gfrt)
3979     gfrt = ffeintrin_gfrt_indirect (codegen_imp);
3980
3981   switch (codegen_imp)
3982     {
3983     case FFEINTRIN_impABS:
3984     case FFEINTRIN_impCABS:
3985     case FFEINTRIN_impCDABS:
3986     case FFEINTRIN_impDABS:
3987     case FFEINTRIN_impIABS:
3988       if (ffeinfo_basictype (ffebld_info (arg1))
3989           == FFEINFO_basictypeCOMPLEX)
3990         {
3991           if (kt == FFEINFO_kindtypeREAL1)
3992             gfrt = FFECOM_gfrtCABS;
3993           else if (kt == FFEINFO_kindtypeREAL2)
3994             gfrt = FFECOM_gfrtCDABS;
3995           break;
3996         }
3997       return ffecom_1 (ABS_EXPR, tree_type,
3998                        convert (tree_type, ffecom_expr (arg1)));
3999
4000     case FFEINTRIN_impACOS:
4001     case FFEINTRIN_impDACOS:
4002       break;
4003
4004     case FFEINTRIN_impAIMAG:
4005     case FFEINTRIN_impDIMAG:
4006     case FFEINTRIN_impIMAGPART:
4007       if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
4008         arg1_type = TREE_TYPE (arg1_type);
4009       else
4010         arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
4011
4012       return
4013         convert (tree_type,
4014                  ffecom_1 (IMAGPART_EXPR, arg1_type,
4015                            ffecom_expr (arg1)));
4016
4017     case FFEINTRIN_impAINT:
4018     case FFEINTRIN_impDINT:
4019 #if 0
4020       /* ~~Someday implement FIX_TRUNC_EXPR yielding same type as arg.  */
4021       return ffecom_1 (FIX_TRUNC_EXPR, tree_type, ffecom_expr (arg1));
4022 #else /* in the meantime, must use floor to avoid range problems with ints */
4023       /* r__1 = r1 >= 0 ? floor(r1) : -floor(-r1); */
4024       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4025       return
4026         convert (tree_type,
4027                  ffecom_3 (COND_EXPR, double_type_node,
4028                            ffecom_truth_value
4029                            (ffecom_2 (GE_EXPR, integer_type_node,
4030                                       saved_expr1,
4031                                       convert (arg1_type,
4032                                                ffecom_float_zero_))),
4033                            ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4034                                              build_tree_list (NULL_TREE,
4035                                                   convert (double_type_node,
4036                                                            saved_expr1)),
4037                                              NULL_TREE),
4038                            ffecom_1 (NEGATE_EXPR, double_type_node,
4039                                      ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4040                                                  build_tree_list (NULL_TREE,
4041                                                   convert (double_type_node,
4042                                                       ffecom_1 (NEGATE_EXPR,
4043                                                                 arg1_type,
4044                                                                saved_expr1))),
4045                                                        NULL_TREE)
4046                                      ))
4047                  );
4048 #endif
4049
4050     case FFEINTRIN_impANINT:
4051     case FFEINTRIN_impDNINT:
4052 #if 0                           /* This way of doing it won't handle real
4053                                    numbers of large magnitudes. */
4054       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4055       expr_tree = convert (tree_type,
4056                            convert (integer_type_node,
4057                                     ffecom_3 (COND_EXPR, tree_type,
4058                                               ffecom_truth_value
4059                                               (ffecom_2 (GE_EXPR,
4060                                                          integer_type_node,
4061                                                          saved_expr1,
4062                                                        ffecom_float_zero_)),
4063                                               ffecom_2 (PLUS_EXPR,
4064                                                         tree_type,
4065                                                         saved_expr1,
4066                                                         ffecom_float_half_),
4067                                               ffecom_2 (MINUS_EXPR,
4068                                                         tree_type,
4069                                                         saved_expr1,
4070                                                      ffecom_float_half_))));
4071       return expr_tree;
4072 #else /* So we instead call floor. */
4073       /* r__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1) */
4074       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4075       return
4076         convert (tree_type,
4077                  ffecom_3 (COND_EXPR, double_type_node,
4078                            ffecom_truth_value
4079                            (ffecom_2 (GE_EXPR, integer_type_node,
4080                                       saved_expr1,
4081                                       convert (arg1_type,
4082                                                ffecom_float_zero_))),
4083                            ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4084                                              build_tree_list (NULL_TREE,
4085                                                   convert (double_type_node,
4086                                                            ffecom_2 (PLUS_EXPR,
4087                                                                      arg1_type,
4088                                                                      saved_expr1,
4089                                                                      convert (arg1_type,
4090                                                                               ffecom_float_half_)))),
4091                                              NULL_TREE),
4092                            ffecom_1 (NEGATE_EXPR, double_type_node,
4093                                      ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4094                                                        build_tree_list (NULL_TREE,
4095                                                                         convert (double_type_node,
4096                                                                                  ffecom_2 (MINUS_EXPR,
4097                                                                                            arg1_type,
4098                                                                                            convert (arg1_type,
4099                                                                                                     ffecom_float_half_),
4100                                                                                            saved_expr1))),
4101                                                        NULL_TREE))
4102                            )
4103                  );
4104 #endif
4105
4106     case FFEINTRIN_impASIN:
4107     case FFEINTRIN_impDASIN:
4108     case FFEINTRIN_impATAN:
4109     case FFEINTRIN_impDATAN:
4110     case FFEINTRIN_impATAN2:
4111     case FFEINTRIN_impDATAN2:
4112       break;
4113
4114     case FFEINTRIN_impCHAR:
4115     case FFEINTRIN_impACHAR:
4116 #ifdef HOHO
4117       tempvar = ffecom_make_tempvar (char_type_node, 1, -1);
4118 #else
4119       tempvar = ffebld_nonter_hook (expr);
4120       assert (tempvar);
4121 #endif
4122       {
4123         tree tmv = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (tempvar)));
4124
4125         expr_tree = ffecom_modify (tmv,
4126                                    ffecom_2 (ARRAY_REF, tmv, tempvar,
4127                                              integer_one_node),
4128                                    convert (tmv, ffecom_expr (arg1)));
4129       }
4130       expr_tree = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar),
4131                             expr_tree,
4132                             tempvar);
4133       expr_tree = ffecom_1 (ADDR_EXPR,
4134                             build_pointer_type (TREE_TYPE (expr_tree)),
4135                             expr_tree);
4136       return expr_tree;
4137
4138     case FFEINTRIN_impCMPLX:
4139     case FFEINTRIN_impDCMPLX:
4140       if (arg2 == NULL)
4141         return
4142           convert (tree_type, ffecom_expr (arg1));
4143
4144       real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4145       return
4146         ffecom_2 (COMPLEX_EXPR, tree_type,
4147                   convert (real_type, ffecom_expr (arg1)),
4148                   convert (real_type,
4149                            ffecom_expr (arg2)));
4150
4151     case FFEINTRIN_impCOMPLEX:
4152       return
4153         ffecom_2 (COMPLEX_EXPR, tree_type,
4154                   ffecom_expr (arg1),
4155                   ffecom_expr (arg2));
4156
4157     case FFEINTRIN_impCONJG:
4158     case FFEINTRIN_impDCONJG:
4159       {
4160         tree arg1_tree;
4161
4162         real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4163         arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4164         return
4165           ffecom_2 (COMPLEX_EXPR, tree_type,
4166                     ffecom_1 (REALPART_EXPR, real_type, arg1_tree),
4167                     ffecom_1 (NEGATE_EXPR, real_type,
4168                               ffecom_1 (IMAGPART_EXPR, real_type, arg1_tree)));
4169       }
4170
4171     case FFEINTRIN_impCOS:
4172     case FFEINTRIN_impCCOS:
4173     case FFEINTRIN_impCDCOS:
4174     case FFEINTRIN_impDCOS:
4175       if (bt == FFEINFO_basictypeCOMPLEX)
4176         {
4177           if (kt == FFEINFO_kindtypeREAL1)
4178             gfrt = FFECOM_gfrtCCOS;     /* Overlapping result okay. */
4179           else if (kt == FFEINFO_kindtypeREAL2)
4180             gfrt = FFECOM_gfrtCDCOS;    /* Overlapping result okay. */
4181         }
4182       break;
4183
4184     case FFEINTRIN_impCOSH:
4185     case FFEINTRIN_impDCOSH:
4186       break;
4187
4188     case FFEINTRIN_impDBLE:
4189     case FFEINTRIN_impDFLOAT:
4190     case FFEINTRIN_impDREAL:
4191     case FFEINTRIN_impFLOAT:
4192     case FFEINTRIN_impIDINT:
4193     case FFEINTRIN_impIFIX:
4194     case FFEINTRIN_impINT2:
4195     case FFEINTRIN_impINT8:
4196     case FFEINTRIN_impINT:
4197     case FFEINTRIN_impLONG:
4198     case FFEINTRIN_impREAL:
4199     case FFEINTRIN_impSHORT:
4200     case FFEINTRIN_impSNGL:
4201       return convert (tree_type, ffecom_expr (arg1));
4202
4203     case FFEINTRIN_impDIM:
4204     case FFEINTRIN_impDDIM:
4205     case FFEINTRIN_impIDIM:
4206       saved_expr1 = ffecom_save_tree (convert (tree_type,
4207                                                ffecom_expr (arg1)));
4208       saved_expr2 = ffecom_save_tree (convert (tree_type,
4209                                                ffecom_expr (arg2)));
4210       return
4211         ffecom_3 (COND_EXPR, tree_type,
4212                   ffecom_truth_value
4213                   (ffecom_2 (GT_EXPR, integer_type_node,
4214                              saved_expr1,
4215                              saved_expr2)),
4216                   ffecom_2 (MINUS_EXPR, tree_type,
4217                             saved_expr1,
4218                             saved_expr2),
4219                   convert (tree_type, ffecom_float_zero_));
4220
4221     case FFEINTRIN_impDPROD:
4222       return
4223         ffecom_2 (MULT_EXPR, tree_type,
4224                   convert (tree_type, ffecom_expr (arg1)),
4225                   convert (tree_type, ffecom_expr (arg2)));
4226
4227     case FFEINTRIN_impEXP:
4228     case FFEINTRIN_impCDEXP:
4229     case FFEINTRIN_impCEXP:
4230     case FFEINTRIN_impDEXP:
4231       if (bt == FFEINFO_basictypeCOMPLEX)
4232         {
4233           if (kt == FFEINFO_kindtypeREAL1)
4234             gfrt = FFECOM_gfrtCEXP;     /* Overlapping result okay. */
4235           else if (kt == FFEINFO_kindtypeREAL2)
4236             gfrt = FFECOM_gfrtCDEXP;    /* Overlapping result okay. */
4237         }
4238       break;
4239
4240     case FFEINTRIN_impICHAR:
4241     case FFEINTRIN_impIACHAR:
4242 #if 0                           /* The simple approach. */
4243       ffecom_char_args_ (&expr_tree, &saved_expr1 /* Ignored */ , arg1);
4244       expr_tree
4245         = ffecom_1 (INDIRECT_REF,
4246                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4247                     expr_tree);
4248       expr_tree
4249         = ffecom_2 (ARRAY_REF,
4250                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4251                     expr_tree,
4252                     integer_one_node);
4253       return convert (tree_type, expr_tree);
4254 #else /* The more interesting (and more optimal) approach. */
4255       expr_tree = ffecom_intrinsic_ichar_ (tree_type, arg1, &saved_expr1);
4256       expr_tree = ffecom_3 (COND_EXPR, tree_type,
4257                             saved_expr1,
4258                             expr_tree,
4259                             convert (tree_type, integer_zero_node));
4260       return expr_tree;
4261 #endif
4262
4263     case FFEINTRIN_impINDEX:
4264       break;
4265
4266     case FFEINTRIN_impLEN:
4267 #if 0
4268       break;                                    /* The simple approach. */
4269 #else
4270       return ffecom_intrinsic_len_ (arg1);      /* The more optimal approach. */
4271 #endif
4272
4273     case FFEINTRIN_impLGE:
4274     case FFEINTRIN_impLGT:
4275     case FFEINTRIN_impLLE:
4276     case FFEINTRIN_impLLT:
4277       break;
4278
4279     case FFEINTRIN_impLOG:
4280     case FFEINTRIN_impALOG:
4281     case FFEINTRIN_impCDLOG:
4282     case FFEINTRIN_impCLOG:
4283     case FFEINTRIN_impDLOG:
4284       if (bt == FFEINFO_basictypeCOMPLEX)
4285         {
4286           if (kt == FFEINFO_kindtypeREAL1)
4287             gfrt = FFECOM_gfrtCLOG;     /* Overlapping result okay. */
4288           else if (kt == FFEINFO_kindtypeREAL2)
4289             gfrt = FFECOM_gfrtCDLOG;    /* Overlapping result okay. */
4290         }
4291       break;
4292
4293     case FFEINTRIN_impLOG10:
4294     case FFEINTRIN_impALOG10:
4295     case FFEINTRIN_impDLOG10:
4296       if (gfrt != FFECOM_gfrt)
4297         break;  /* Already picked one, stick with it. */
4298
4299       if (kt == FFEINFO_kindtypeREAL1)
4300         /* We used to call FFECOM_gfrtALOG10 here.  */
4301         gfrt = FFECOM_gfrtL_LOG10;
4302       else if (kt == FFEINFO_kindtypeREAL2)
4303         /* We used to call FFECOM_gfrtDLOG10 here.  */
4304         gfrt = FFECOM_gfrtL_LOG10;
4305       break;
4306
4307     case FFEINTRIN_impMAX:
4308     case FFEINTRIN_impAMAX0:
4309     case FFEINTRIN_impAMAX1:
4310     case FFEINTRIN_impDMAX1:
4311     case FFEINTRIN_impMAX0:
4312     case FFEINTRIN_impMAX1:
4313       if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4314         arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4315       else
4316         arg1_type = tree_type;
4317       expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4318                             convert (arg1_type, ffecom_expr (arg1)),
4319                             convert (arg1_type, ffecom_expr (arg2)));
4320       for (; list != NULL; list = ffebld_trail (list))
4321         {
4322           if ((ffebld_head (list) == NULL)
4323               || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4324             continue;
4325           expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4326                                 expr_tree,
4327                                 convert (arg1_type,
4328                                          ffecom_expr (ffebld_head (list))));
4329         }
4330       return convert (tree_type, expr_tree);
4331
4332     case FFEINTRIN_impMIN:
4333     case FFEINTRIN_impAMIN0:
4334     case FFEINTRIN_impAMIN1:
4335     case FFEINTRIN_impDMIN1:
4336     case FFEINTRIN_impMIN0:
4337     case FFEINTRIN_impMIN1:
4338       if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4339         arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4340       else
4341         arg1_type = tree_type;
4342       expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4343                             convert (arg1_type, ffecom_expr (arg1)),
4344                             convert (arg1_type, ffecom_expr (arg2)));
4345       for (; list != NULL; list = ffebld_trail (list))
4346         {
4347           if ((ffebld_head (list) == NULL)
4348               || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4349             continue;
4350           expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4351                                 expr_tree,
4352                                 convert (arg1_type,
4353                                          ffecom_expr (ffebld_head (list))));
4354         }
4355       return convert (tree_type, expr_tree);
4356
4357     case FFEINTRIN_impMOD:
4358     case FFEINTRIN_impAMOD:
4359     case FFEINTRIN_impDMOD:
4360       if (bt != FFEINFO_basictypeREAL)
4361         return ffecom_2 (TRUNC_MOD_EXPR, tree_type,
4362                          convert (tree_type, ffecom_expr (arg1)),
4363                          convert (tree_type, ffecom_expr (arg2)));
4364
4365       if (kt == FFEINFO_kindtypeREAL1)
4366         /* We used to call FFECOM_gfrtAMOD here.  */
4367         gfrt = FFECOM_gfrtL_FMOD;
4368       else if (kt == FFEINFO_kindtypeREAL2)
4369         /* We used to call FFECOM_gfrtDMOD here.  */
4370         gfrt = FFECOM_gfrtL_FMOD;
4371       break;
4372
4373     case FFEINTRIN_impNINT:
4374     case FFEINTRIN_impIDNINT:
4375 #if 0
4376       /* ~~Ideally FIX_ROUND_EXPR would be implemented, but it ain't yet.  */
4377       return ffecom_1 (FIX_ROUND_EXPR, tree_type, ffecom_expr (arg1));
4378 #else
4379       /* i__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1); */
4380       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4381       return
4382         convert (ffecom_integer_type_node,
4383                  ffecom_3 (COND_EXPR, arg1_type,
4384                            ffecom_truth_value
4385                            (ffecom_2 (GE_EXPR, integer_type_node,
4386                                       saved_expr1,
4387                                       convert (arg1_type,
4388                                                ffecom_float_zero_))),
4389                            ffecom_2 (PLUS_EXPR, arg1_type,
4390                                      saved_expr1,
4391                                      convert (arg1_type,
4392                                               ffecom_float_half_)),
4393                            ffecom_2 (MINUS_EXPR, arg1_type,
4394                                      saved_expr1,
4395                                      convert (arg1_type,
4396                                               ffecom_float_half_))));
4397 #endif
4398
4399     case FFEINTRIN_impSIGN:
4400     case FFEINTRIN_impDSIGN:
4401     case FFEINTRIN_impISIGN:
4402       {
4403         tree arg2_tree = ffecom_expr (arg2);
4404
4405         saved_expr1
4406           = ffecom_save_tree
4407           (ffecom_1 (ABS_EXPR, tree_type,
4408                      convert (tree_type,
4409                               ffecom_expr (arg1))));
4410         expr_tree
4411           = ffecom_3 (COND_EXPR, tree_type,
4412                       ffecom_truth_value
4413                       (ffecom_2 (GE_EXPR, integer_type_node,
4414                                  arg2_tree,
4415                                  convert (TREE_TYPE (arg2_tree),
4416                                           integer_zero_node))),
4417                       saved_expr1,
4418                       ffecom_1 (NEGATE_EXPR, tree_type, saved_expr1));
4419         /* Make sure SAVE_EXPRs get referenced early enough. */
4420         expr_tree
4421           = ffecom_2 (COMPOUND_EXPR, tree_type,
4422                       convert (void_type_node, saved_expr1),
4423                       expr_tree);
4424       }
4425       return expr_tree;
4426
4427     case FFEINTRIN_impSIN:
4428     case FFEINTRIN_impCDSIN:
4429     case FFEINTRIN_impCSIN:
4430     case FFEINTRIN_impDSIN:
4431       if (bt == FFEINFO_basictypeCOMPLEX)
4432         {
4433           if (kt == FFEINFO_kindtypeREAL1)
4434             gfrt = FFECOM_gfrtCSIN;     /* Overlapping result okay. */
4435           else if (kt == FFEINFO_kindtypeREAL2)
4436             gfrt = FFECOM_gfrtCDSIN;    /* Overlapping result okay. */
4437         }
4438       break;
4439
4440     case FFEINTRIN_impSINH:
4441     case FFEINTRIN_impDSINH:
4442       break;
4443
4444     case FFEINTRIN_impSQRT:
4445     case FFEINTRIN_impCDSQRT:
4446     case FFEINTRIN_impCSQRT:
4447     case FFEINTRIN_impDSQRT:
4448       if (bt == FFEINFO_basictypeCOMPLEX)
4449         {
4450           if (kt == FFEINFO_kindtypeREAL1)
4451             gfrt = FFECOM_gfrtCSQRT;    /* Overlapping result okay. */
4452           else if (kt == FFEINFO_kindtypeREAL2)
4453             gfrt = FFECOM_gfrtCDSQRT;   /* Overlapping result okay. */
4454         }
4455       break;
4456
4457     case FFEINTRIN_impTAN:
4458     case FFEINTRIN_impDTAN:
4459     case FFEINTRIN_impTANH:
4460     case FFEINTRIN_impDTANH:
4461       break;
4462
4463     case FFEINTRIN_impREALPART:
4464       if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
4465         arg1_type = TREE_TYPE (arg1_type);
4466       else
4467         arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
4468
4469       return
4470         convert (tree_type,
4471                  ffecom_1 (REALPART_EXPR, arg1_type,
4472                            ffecom_expr (arg1)));
4473
4474     case FFEINTRIN_impIAND:
4475     case FFEINTRIN_impAND:
4476       return ffecom_2 (BIT_AND_EXPR, tree_type,
4477                        convert (tree_type,
4478                                 ffecom_expr (arg1)),
4479                        convert (tree_type,
4480                                 ffecom_expr (arg2)));
4481
4482     case FFEINTRIN_impIOR:
4483     case FFEINTRIN_impOR:
4484       return ffecom_2 (BIT_IOR_EXPR, tree_type,
4485                        convert (tree_type,
4486                                 ffecom_expr (arg1)),
4487                        convert (tree_type,
4488                                 ffecom_expr (arg2)));
4489
4490     case FFEINTRIN_impIEOR:
4491     case FFEINTRIN_impXOR:
4492       return ffecom_2 (BIT_XOR_EXPR, tree_type,
4493                        convert (tree_type,
4494                                 ffecom_expr (arg1)),
4495                        convert (tree_type,
4496                                 ffecom_expr (arg2)));
4497
4498     case FFEINTRIN_impLSHIFT:
4499       return ffecom_2 (LSHIFT_EXPR, tree_type,
4500                        ffecom_expr (arg1),
4501                        convert (integer_type_node,
4502                                 ffecom_expr (arg2)));
4503
4504     case FFEINTRIN_impRSHIFT:
4505       return ffecom_2 (RSHIFT_EXPR, tree_type,
4506                        ffecom_expr (arg1),
4507                        convert (integer_type_node,
4508                                 ffecom_expr (arg2)));
4509
4510     case FFEINTRIN_impNOT:
4511       return ffecom_1 (BIT_NOT_EXPR, tree_type, ffecom_expr (arg1));
4512
4513     case FFEINTRIN_impBIT_SIZE:
4514       return convert (tree_type, TYPE_SIZE (arg1_type));
4515
4516     case FFEINTRIN_impBTEST:
4517       {
4518         ffetargetLogical1 true;
4519         ffetargetLogical1 false;
4520         tree true_tree;
4521         tree false_tree;
4522
4523         ffetarget_logical1 (&true, TRUE);
4524         ffetarget_logical1 (&false, FALSE);
4525         if (true == 1)
4526           true_tree = convert (tree_type, integer_one_node);
4527         else
4528           true_tree = convert (tree_type, build_int_2 (true, 0));
4529         if (false == 0)
4530           false_tree = convert (tree_type, integer_zero_node);
4531         else
4532           false_tree = convert (tree_type, build_int_2 (false, 0));
4533
4534         return
4535           ffecom_3 (COND_EXPR, tree_type,
4536                     ffecom_truth_value
4537                     (ffecom_2 (EQ_EXPR, integer_type_node,
4538                                ffecom_2 (BIT_AND_EXPR, arg1_type,
4539                                          ffecom_expr (arg1),
4540                                          ffecom_2 (LSHIFT_EXPR, arg1_type,
4541                                                    convert (arg1_type,
4542                                                           integer_one_node),
4543                                                    convert (integer_type_node,
4544                                                             ffecom_expr (arg2)))),
4545                                convert (arg1_type,
4546                                         integer_zero_node))),
4547                     false_tree,
4548                     true_tree);
4549       }
4550
4551     case FFEINTRIN_impIBCLR:
4552       return
4553         ffecom_2 (BIT_AND_EXPR, tree_type,
4554                   ffecom_expr (arg1),
4555                   ffecom_1 (BIT_NOT_EXPR, tree_type,
4556                             ffecom_2 (LSHIFT_EXPR, tree_type,
4557                                       convert (tree_type,
4558                                                integer_one_node),
4559                                       convert (integer_type_node,
4560                                                ffecom_expr (arg2)))));
4561
4562     case FFEINTRIN_impIBITS:
4563       {
4564         tree arg3_tree = ffecom_save_tree (convert (integer_type_node,
4565                                                     ffecom_expr (arg3)));
4566         tree uns_type
4567         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4568
4569         expr_tree
4570           = ffecom_2 (BIT_AND_EXPR, tree_type,
4571                       ffecom_2 (RSHIFT_EXPR, tree_type,
4572                                 ffecom_expr (arg1),
4573                                 convert (integer_type_node,
4574                                          ffecom_expr (arg2))),
4575                       convert (tree_type,
4576                                ffecom_2 (RSHIFT_EXPR, uns_type,
4577                                          ffecom_1 (BIT_NOT_EXPR,
4578                                                    uns_type,
4579                                                    convert (uns_type,
4580                                                         integer_zero_node)),
4581                                          ffecom_2 (MINUS_EXPR,
4582                                                    integer_type_node,
4583                                                    TYPE_SIZE (uns_type),
4584                                                    arg3_tree))));
4585 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4586         expr_tree
4587           = ffecom_3 (COND_EXPR, tree_type,
4588                       ffecom_truth_value
4589                       (ffecom_2 (NE_EXPR, integer_type_node,
4590                                  arg3_tree,
4591                                  integer_zero_node)),
4592                       expr_tree,
4593                       convert (tree_type, integer_zero_node));
4594 #endif
4595       }
4596       return expr_tree;
4597
4598     case FFEINTRIN_impIBSET:
4599       return
4600         ffecom_2 (BIT_IOR_EXPR, tree_type,
4601                   ffecom_expr (arg1),
4602                   ffecom_2 (LSHIFT_EXPR, tree_type,
4603                             convert (tree_type, integer_one_node),
4604                             convert (integer_type_node,
4605                                      ffecom_expr (arg2))));
4606
4607     case FFEINTRIN_impISHFT:
4608       {
4609         tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4610         tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4611                                                     ffecom_expr (arg2)));
4612         tree uns_type
4613         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4614
4615         expr_tree
4616           = ffecom_3 (COND_EXPR, tree_type,
4617                       ffecom_truth_value
4618                       (ffecom_2 (GE_EXPR, integer_type_node,
4619                                  arg2_tree,
4620                                  integer_zero_node)),
4621                       ffecom_2 (LSHIFT_EXPR, tree_type,
4622                                 arg1_tree,
4623                                 arg2_tree),
4624                       convert (tree_type,
4625                                ffecom_2 (RSHIFT_EXPR, uns_type,
4626                                          convert (uns_type, arg1_tree),
4627                                          ffecom_1 (NEGATE_EXPR,
4628                                                    integer_type_node,
4629                                                    arg2_tree))));
4630 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4631         expr_tree
4632           = ffecom_3 (COND_EXPR, tree_type,
4633                       ffecom_truth_value
4634                       (ffecom_2 (NE_EXPR, integer_type_node,
4635                                  arg2_tree,
4636                                  TYPE_SIZE (uns_type))),
4637                       expr_tree,
4638                       convert (tree_type, integer_zero_node));
4639 #endif
4640         /* Make sure SAVE_EXPRs get referenced early enough. */
4641         expr_tree
4642           = ffecom_2 (COMPOUND_EXPR, tree_type,
4643                       convert (void_type_node, arg1_tree),
4644                       ffecom_2 (COMPOUND_EXPR, tree_type,
4645                                 convert (void_type_node, arg2_tree),
4646                                 expr_tree));
4647       }
4648       return expr_tree;
4649
4650     case FFEINTRIN_impISHFTC:
4651       {
4652         tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4653         tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4654                                                     ffecom_expr (arg2)));
4655         tree arg3_tree = (arg3 == NULL) ? TYPE_SIZE (tree_type)
4656         : ffecom_save_tree (convert (integer_type_node, ffecom_expr (arg3)));
4657         tree shift_neg;
4658         tree shift_pos;
4659         tree mask_arg1;
4660         tree masked_arg1;
4661         tree uns_type
4662         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4663
4664         mask_arg1
4665           = ffecom_2 (LSHIFT_EXPR, tree_type,
4666                       ffecom_1 (BIT_NOT_EXPR, tree_type,
4667                                 convert (tree_type, integer_zero_node)),
4668                       arg3_tree);
4669 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4670         mask_arg1
4671           = ffecom_3 (COND_EXPR, tree_type,
4672                       ffecom_truth_value
4673                       (ffecom_2 (NE_EXPR, integer_type_node,
4674                                  arg3_tree,
4675                                  TYPE_SIZE (uns_type))),
4676                       mask_arg1,
4677                       convert (tree_type, integer_zero_node));
4678 #endif
4679         mask_arg1 = ffecom_save_tree (mask_arg1);
4680         masked_arg1
4681           = ffecom_2 (BIT_AND_EXPR, tree_type,
4682                       arg1_tree,
4683                       ffecom_1 (BIT_NOT_EXPR, tree_type,
4684                                 mask_arg1));
4685         masked_arg1 = ffecom_save_tree (masked_arg1);
4686         shift_neg
4687           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4688                       convert (tree_type,
4689                                ffecom_2 (RSHIFT_EXPR, uns_type,
4690                                          convert (uns_type, masked_arg1),
4691                                          ffecom_1 (NEGATE_EXPR,
4692                                                    integer_type_node,
4693                                                    arg2_tree))),
4694                       ffecom_2 (LSHIFT_EXPR, tree_type,
4695                                 arg1_tree,
4696                                 ffecom_2 (PLUS_EXPR, integer_type_node,
4697                                           arg2_tree,
4698                                           arg3_tree)));
4699         shift_pos
4700           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4701                       ffecom_2 (LSHIFT_EXPR, tree_type,
4702                                 arg1_tree,
4703                                 arg2_tree),
4704                       convert (tree_type,
4705                                ffecom_2 (RSHIFT_EXPR, uns_type,
4706                                          convert (uns_type, masked_arg1),
4707                                          ffecom_2 (MINUS_EXPR,
4708                                                    integer_type_node,
4709                                                    arg3_tree,
4710                                                    arg2_tree))));
4711         expr_tree
4712           = ffecom_3 (COND_EXPR, tree_type,
4713                       ffecom_truth_value
4714                       (ffecom_2 (LT_EXPR, integer_type_node,
4715                                  arg2_tree,
4716                                  integer_zero_node)),
4717                       shift_neg,
4718                       shift_pos);
4719         expr_tree
4720           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4721                       ffecom_2 (BIT_AND_EXPR, tree_type,
4722                                 mask_arg1,
4723                                 arg1_tree),
4724                       ffecom_2 (BIT_AND_EXPR, tree_type,
4725                                 ffecom_1 (BIT_NOT_EXPR, tree_type,
4726                                           mask_arg1),
4727                                 expr_tree));
4728         expr_tree
4729           = ffecom_3 (COND_EXPR, tree_type,
4730                       ffecom_truth_value
4731                       (ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
4732                                  ffecom_2 (EQ_EXPR, integer_type_node,
4733                                            ffecom_1 (ABS_EXPR,
4734                                                      integer_type_node,
4735                                                      arg2_tree),
4736                                            arg3_tree),
4737                                  ffecom_2 (EQ_EXPR, integer_type_node,
4738                                            arg2_tree,
4739                                            integer_zero_node))),
4740                       arg1_tree,
4741                       expr_tree);
4742         /* Make sure SAVE_EXPRs get referenced early enough. */
4743         expr_tree
4744           = ffecom_2 (COMPOUND_EXPR, tree_type,
4745                       convert (void_type_node, arg1_tree),
4746                       ffecom_2 (COMPOUND_EXPR, tree_type,
4747                                 convert (void_type_node, arg2_tree),
4748                                 ffecom_2 (COMPOUND_EXPR, tree_type,
4749                                           convert (void_type_node,
4750                                                    mask_arg1),
4751                                           ffecom_2 (COMPOUND_EXPR, tree_type,
4752                                                     convert (void_type_node,
4753                                                              masked_arg1),
4754                                                     expr_tree))));
4755         expr_tree
4756           = ffecom_2 (COMPOUND_EXPR, tree_type,
4757                       convert (void_type_node,
4758                                arg3_tree),
4759                       expr_tree);
4760       }
4761       return expr_tree;
4762
4763     case FFEINTRIN_impLOC:
4764       {
4765         tree arg1_tree = ffecom_expr (arg1);
4766
4767         expr_tree
4768           = convert (tree_type,
4769                      ffecom_1 (ADDR_EXPR,
4770                                build_pointer_type (TREE_TYPE (arg1_tree)),
4771                                arg1_tree));
4772       }
4773       return expr_tree;
4774
4775     case FFEINTRIN_impMVBITS:
4776       {
4777         tree arg1_tree;
4778         tree arg2_tree;
4779         tree arg3_tree;
4780         ffebld arg4 = ffebld_head (ffebld_trail (list));
4781         tree arg4_tree;
4782         tree arg4_type;
4783         ffebld arg5 = ffebld_head (ffebld_trail (ffebld_trail (list)));
4784         tree arg5_tree;
4785         tree prep_arg1;
4786         tree prep_arg4;
4787         tree arg5_plus_arg3;
4788
4789         arg2_tree = convert (integer_type_node,
4790                              ffecom_expr (arg2));
4791         arg3_tree = ffecom_save_tree (convert (integer_type_node,
4792                                                ffecom_expr (arg3)));
4793         arg4_tree = ffecom_expr_rw (NULL_TREE, arg4);
4794         arg4_type = TREE_TYPE (arg4_tree);
4795
4796         arg1_tree = ffecom_save_tree (convert (arg4_type,
4797                                                ffecom_expr (arg1)));
4798
4799         arg5_tree = ffecom_save_tree (convert (integer_type_node,
4800                                                ffecom_expr (arg5)));
4801
4802         prep_arg1
4803           = ffecom_2 (LSHIFT_EXPR, arg4_type,
4804                       ffecom_2 (BIT_AND_EXPR, arg4_type,
4805                                 ffecom_2 (RSHIFT_EXPR, arg4_type,
4806                                           arg1_tree,
4807                                           arg2_tree),
4808                                 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4809                                           ffecom_2 (LSHIFT_EXPR, arg4_type,
4810                                                     ffecom_1 (BIT_NOT_EXPR,
4811                                                               arg4_type,
4812                                                               convert
4813                                                               (arg4_type,
4814                                                         integer_zero_node)),
4815                                                     arg3_tree))),
4816                       arg5_tree);
4817         arg5_plus_arg3
4818           = ffecom_save_tree (ffecom_2 (PLUS_EXPR, arg4_type,
4819                                         arg5_tree,
4820                                         arg3_tree));
4821         prep_arg4
4822           = ffecom_2 (LSHIFT_EXPR, arg4_type,
4823                       ffecom_1 (BIT_NOT_EXPR, arg4_type,
4824                                 convert (arg4_type,
4825                                          integer_zero_node)),
4826                       arg5_plus_arg3);
4827 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4828         prep_arg4
4829           = ffecom_3 (COND_EXPR, arg4_type,
4830                       ffecom_truth_value
4831                       (ffecom_2 (NE_EXPR, integer_type_node,
4832                                  arg5_plus_arg3,
4833                                  convert (TREE_TYPE (arg5_plus_arg3),
4834                                           TYPE_SIZE (arg4_type)))),
4835                       prep_arg4,
4836                       convert (arg4_type, integer_zero_node));
4837 #endif
4838         prep_arg4
4839           = ffecom_2 (BIT_AND_EXPR, arg4_type,
4840                       arg4_tree,
4841                       ffecom_2 (BIT_IOR_EXPR, arg4_type,
4842                                 prep_arg4,
4843                                 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4844                                           ffecom_2 (LSHIFT_EXPR, arg4_type,
4845                                                     ffecom_1 (BIT_NOT_EXPR,
4846                                                               arg4_type,
4847                                                               convert
4848                                                               (arg4_type,
4849                                                         integer_zero_node)),
4850                                                     arg5_tree))));
4851         prep_arg1
4852           = ffecom_2 (BIT_IOR_EXPR, arg4_type,
4853                       prep_arg1,
4854                       prep_arg4);
4855 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4856         prep_arg1
4857           = ffecom_3 (COND_EXPR, arg4_type,
4858                       ffecom_truth_value
4859                       (ffecom_2 (NE_EXPR, integer_type_node,
4860                                  arg3_tree,
4861                                  convert (TREE_TYPE (arg3_tree),
4862                                           integer_zero_node))),
4863                       prep_arg1,
4864                       arg4_tree);
4865         prep_arg1
4866           = ffecom_3 (COND_EXPR, arg4_type,
4867                       ffecom_truth_value
4868                       (ffecom_2 (NE_EXPR, integer_type_node,
4869                                  arg3_tree,
4870                                  convert (TREE_TYPE (arg3_tree),
4871                                           TYPE_SIZE (arg4_type)))),
4872                       prep_arg1,
4873                       arg1_tree);
4874 #endif
4875         expr_tree
4876           = ffecom_2s (MODIFY_EXPR, void_type_node,
4877                        arg4_tree,
4878                        prep_arg1);
4879         /* Make sure SAVE_EXPRs get referenced early enough. */
4880         expr_tree
4881           = ffecom_2 (COMPOUND_EXPR, void_type_node,
4882                       arg1_tree,
4883                       ffecom_2 (COMPOUND_EXPR, void_type_node,
4884                                 arg3_tree,
4885                                 ffecom_2 (COMPOUND_EXPR, void_type_node,
4886                                           arg5_tree,
4887                                           ffecom_2 (COMPOUND_EXPR, void_type_node,
4888                                                     arg5_plus_arg3,
4889                                                     expr_tree))));
4890         expr_tree
4891           = ffecom_2 (COMPOUND_EXPR, void_type_node,
4892                       arg4_tree,
4893                       expr_tree);
4894
4895       }
4896       return expr_tree;
4897
4898     case FFEINTRIN_impDERF:
4899     case FFEINTRIN_impERF:
4900     case FFEINTRIN_impDERFC:
4901     case FFEINTRIN_impERFC:
4902       break;
4903
4904     case FFEINTRIN_impIARGC:
4905       /* extern int xargc; i__1 = xargc - 1; */
4906       expr_tree = ffecom_2 (MINUS_EXPR, TREE_TYPE (ffecom_tree_xargc_),
4907                             ffecom_tree_xargc_,
4908                             convert (TREE_TYPE (ffecom_tree_xargc_),
4909                                      integer_one_node));
4910       return expr_tree;
4911
4912     case FFEINTRIN_impSIGNAL_func:
4913     case FFEINTRIN_impSIGNAL_subr:
4914       {
4915         tree arg1_tree;
4916         tree arg2_tree;
4917         tree arg3_tree;
4918
4919         arg1_tree = convert (ffecom_f2c_integer_type_node,
4920                              ffecom_expr (arg1));
4921         arg1_tree = ffecom_1 (ADDR_EXPR,
4922                               build_pointer_type (TREE_TYPE (arg1_tree)),
4923                               arg1_tree);
4924
4925         /* Pass procedure as a pointer to it, anything else by value.  */
4926         if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
4927           arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
4928         else
4929           arg2_tree = ffecom_ptr_to_expr (arg2);
4930         arg2_tree = convert (TREE_TYPE (null_pointer_node),
4931                              arg2_tree);
4932
4933         if (arg3 != NULL)
4934           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
4935         else
4936           arg3_tree = NULL_TREE;
4937
4938         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4939         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4940         TREE_CHAIN (arg1_tree) = arg2_tree;
4941
4942         expr_tree
4943           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4944                           ffecom_gfrt_kindtype (gfrt),
4945                           FALSE,
4946                           ((codegen_imp == FFEINTRIN_impSIGNAL_subr) ?
4947                            NULL_TREE :
4948                            tree_type),
4949                           arg1_tree,
4950                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4951                           ffebld_nonter_hook (expr));
4952
4953         if (arg3_tree != NULL_TREE)
4954           expr_tree
4955             = ffecom_modify (NULL_TREE, arg3_tree,
4956                              convert (TREE_TYPE (arg3_tree),
4957                                       expr_tree));
4958       }
4959       return expr_tree;
4960
4961     case FFEINTRIN_impALARM:
4962       {
4963         tree arg1_tree;
4964         tree arg2_tree;
4965         tree arg3_tree;
4966
4967         arg1_tree = convert (ffecom_f2c_integer_type_node,
4968                              ffecom_expr (arg1));
4969         arg1_tree = ffecom_1 (ADDR_EXPR,
4970                               build_pointer_type (TREE_TYPE (arg1_tree)),
4971                               arg1_tree);
4972
4973         /* Pass procedure as a pointer to it, anything else by value.  */
4974         if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
4975           arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
4976         else
4977           arg2_tree = ffecom_ptr_to_expr (arg2);
4978         arg2_tree = convert (TREE_TYPE (null_pointer_node),
4979                              arg2_tree);
4980
4981         if (arg3 != NULL)
4982           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
4983         else
4984           arg3_tree = NULL_TREE;
4985
4986         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4987         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4988         TREE_CHAIN (arg1_tree) = arg2_tree;
4989
4990         expr_tree
4991           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4992                           ffecom_gfrt_kindtype (gfrt),
4993                           FALSE,
4994                           NULL_TREE,
4995                           arg1_tree,
4996                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4997                           ffebld_nonter_hook (expr));
4998
4999         if (arg3_tree != NULL_TREE)
5000           expr_tree
5001             = ffecom_modify (NULL_TREE, arg3_tree,
5002                              convert (TREE_TYPE (arg3_tree),
5003                                       expr_tree));
5004       }
5005       return expr_tree;
5006
5007     case FFEINTRIN_impCHDIR_subr:
5008     case FFEINTRIN_impFDATE_subr:
5009     case FFEINTRIN_impFGET_subr:
5010     case FFEINTRIN_impFPUT_subr:
5011     case FFEINTRIN_impGETCWD_subr:
5012     case FFEINTRIN_impHOSTNM_subr:
5013     case FFEINTRIN_impSYSTEM_subr:
5014     case FFEINTRIN_impUNLINK_subr:
5015       {
5016         tree arg1_len = integer_zero_node;
5017         tree arg1_tree;
5018         tree arg2_tree;
5019
5020         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5021
5022         if (arg2 != NULL)
5023           arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
5024         else
5025           arg2_tree = NULL_TREE;
5026
5027         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5028         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5029         TREE_CHAIN (arg1_tree) = arg1_len;
5030
5031         expr_tree
5032           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5033                           ffecom_gfrt_kindtype (gfrt),
5034                           FALSE,
5035                           NULL_TREE,
5036                           arg1_tree,
5037                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5038                           ffebld_nonter_hook (expr));
5039
5040         if (arg2_tree != NULL_TREE)
5041           expr_tree
5042             = ffecom_modify (NULL_TREE, arg2_tree,
5043                              convert (TREE_TYPE (arg2_tree),
5044                                       expr_tree));
5045       }
5046       return expr_tree;
5047
5048     case FFEINTRIN_impEXIT:
5049       if (arg1 != NULL)
5050         break;
5051
5052       expr_tree = build_tree_list (NULL_TREE,
5053                                    ffecom_1 (ADDR_EXPR,
5054                                              build_pointer_type
5055                                              (ffecom_integer_type_node),
5056                                              integer_zero_node));
5057
5058       return
5059         ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5060                       ffecom_gfrt_kindtype (gfrt),
5061                       FALSE,
5062                       void_type_node,
5063                       expr_tree,
5064                       NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5065                       ffebld_nonter_hook (expr));
5066
5067     case FFEINTRIN_impFLUSH:
5068       if (arg1 == NULL)
5069         gfrt = FFECOM_gfrtFLUSH;
5070       else
5071         gfrt = FFECOM_gfrtFLUSH1;
5072       break;
5073
5074     case FFEINTRIN_impCHMOD_subr:
5075     case FFEINTRIN_impLINK_subr:
5076     case FFEINTRIN_impRENAME_subr:
5077     case FFEINTRIN_impSYMLNK_subr:
5078       {
5079         tree arg1_len = integer_zero_node;
5080         tree arg1_tree;
5081         tree arg2_len = integer_zero_node;
5082         tree arg2_tree;
5083         tree arg3_tree;
5084
5085         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5086         arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
5087         if (arg3 != NULL)
5088           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5089         else
5090           arg3_tree = NULL_TREE;
5091
5092         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5093         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5094         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5095         arg2_len = build_tree_list (NULL_TREE, arg2_len);
5096         TREE_CHAIN (arg1_tree) = arg2_tree;
5097         TREE_CHAIN (arg2_tree) = arg1_len;
5098         TREE_CHAIN (arg1_len) = arg2_len;
5099         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5100                                   ffecom_gfrt_kindtype (gfrt),
5101                                   FALSE,
5102                                   NULL_TREE,
5103                                   arg1_tree,
5104                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5105                                   ffebld_nonter_hook (expr));
5106         if (arg3_tree != NULL_TREE)
5107           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5108                                      convert (TREE_TYPE (arg3_tree),
5109                                               expr_tree));
5110       }
5111       return expr_tree;
5112
5113     case FFEINTRIN_impLSTAT_subr:
5114     case FFEINTRIN_impSTAT_subr:
5115       {
5116         tree arg1_len = integer_zero_node;
5117         tree arg1_tree;
5118         tree arg2_tree;
5119         tree arg3_tree;
5120
5121         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5122
5123         arg2_tree = ffecom_ptr_to_expr (arg2);
5124
5125         if (arg3 != NULL)
5126           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5127         else
5128           arg3_tree = NULL_TREE;
5129
5130         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5131         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5132         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5133         TREE_CHAIN (arg1_tree) = arg2_tree;
5134         TREE_CHAIN (arg2_tree) = arg1_len;
5135         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5136                                   ffecom_gfrt_kindtype (gfrt),
5137                                   FALSE,
5138                                   NULL_TREE,
5139                                   arg1_tree,
5140                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5141                                   ffebld_nonter_hook (expr));
5142         if (arg3_tree != NULL_TREE)
5143           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5144                                      convert (TREE_TYPE (arg3_tree),
5145                                               expr_tree));
5146       }
5147       return expr_tree;
5148
5149     case FFEINTRIN_impFGETC_subr:
5150     case FFEINTRIN_impFPUTC_subr:
5151       {
5152         tree arg1_tree;
5153         tree arg2_tree;
5154         tree arg2_len = integer_zero_node;
5155         tree arg3_tree;
5156
5157         arg1_tree = convert (ffecom_f2c_integer_type_node,
5158                              ffecom_expr (arg1));
5159         arg1_tree = ffecom_1 (ADDR_EXPR,
5160                               build_pointer_type (TREE_TYPE (arg1_tree)),
5161                               arg1_tree);
5162
5163         arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
5164         if (arg3 != NULL)
5165           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5166         else
5167           arg3_tree = NULL_TREE;
5168
5169         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5170         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5171         arg2_len = build_tree_list (NULL_TREE, arg2_len);
5172         TREE_CHAIN (arg1_tree) = arg2_tree;
5173         TREE_CHAIN (arg2_tree) = arg2_len;
5174
5175         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5176                                   ffecom_gfrt_kindtype (gfrt),
5177                                   FALSE,
5178                                   NULL_TREE,
5179                                   arg1_tree,
5180                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5181                                   ffebld_nonter_hook (expr));
5182         if (arg3_tree != NULL_TREE)
5183           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5184                                      convert (TREE_TYPE (arg3_tree),
5185                                               expr_tree));
5186       }
5187       return expr_tree;
5188
5189     case FFEINTRIN_impFSTAT_subr:
5190       {
5191         tree arg1_tree;
5192         tree arg2_tree;
5193         tree arg3_tree;
5194
5195         arg1_tree = convert (ffecom_f2c_integer_type_node,
5196                              ffecom_expr (arg1));
5197         arg1_tree = ffecom_1 (ADDR_EXPR,
5198                               build_pointer_type (TREE_TYPE (arg1_tree)),
5199                               arg1_tree);
5200
5201         arg2_tree = convert (ffecom_f2c_ptr_to_integer_type_node,
5202                              ffecom_ptr_to_expr (arg2));
5203
5204         if (arg3 == NULL)
5205           arg3_tree = NULL_TREE;
5206         else
5207           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5208
5209         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5210         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5211         TREE_CHAIN (arg1_tree) = arg2_tree;
5212         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5213                                   ffecom_gfrt_kindtype (gfrt),
5214                                   FALSE,
5215                                   NULL_TREE,
5216                                   arg1_tree,
5217                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5218                                   ffebld_nonter_hook (expr));
5219         if (arg3_tree != NULL_TREE) {
5220           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5221                                      convert (TREE_TYPE (arg3_tree),
5222                                               expr_tree));
5223         }
5224       }
5225       return expr_tree;
5226
5227     case FFEINTRIN_impKILL_subr:
5228       {
5229         tree arg1_tree;
5230         tree arg2_tree;
5231         tree arg3_tree;
5232
5233         arg1_tree = convert (ffecom_f2c_integer_type_node,
5234                              ffecom_expr (arg1));
5235         arg1_tree = ffecom_1 (ADDR_EXPR,
5236                               build_pointer_type (TREE_TYPE (arg1_tree)),
5237                               arg1_tree);
5238
5239         arg2_tree = convert (ffecom_f2c_integer_type_node,
5240                              ffecom_expr (arg2));
5241         arg2_tree = ffecom_1 (ADDR_EXPR,
5242                               build_pointer_type (TREE_TYPE (arg2_tree)),
5243                               arg2_tree);
5244
5245         if (arg3 == NULL)
5246           arg3_tree = NULL_TREE;
5247         else
5248           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5249
5250         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5251         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5252         TREE_CHAIN (arg1_tree) = arg2_tree;
5253         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5254                                   ffecom_gfrt_kindtype (gfrt),
5255                                   FALSE,
5256                                   NULL_TREE,
5257                                   arg1_tree,
5258                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5259                                   ffebld_nonter_hook (expr));
5260         if (arg3_tree != NULL_TREE) {
5261           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5262                                      convert (TREE_TYPE (arg3_tree),
5263                                               expr_tree));
5264         }
5265       }
5266       return expr_tree;
5267
5268     case FFEINTRIN_impCTIME_subr:
5269     case FFEINTRIN_impTTYNAM_subr:
5270       {
5271         tree arg1_len = integer_zero_node;
5272         tree arg1_tree;
5273         tree arg2_tree;
5274
5275         arg1_tree = ffecom_arg_ptr_to_expr (arg2, &arg1_len);
5276
5277         arg2_tree = convert (((codegen_imp == FFEINTRIN_impCTIME_subr) ?
5278                               ffecom_f2c_longint_type_node :
5279                               ffecom_f2c_integer_type_node),
5280                              ffecom_expr (arg1));
5281         arg2_tree = ffecom_1 (ADDR_EXPR,
5282                               build_pointer_type (TREE_TYPE (arg2_tree)),
5283                               arg2_tree);
5284
5285         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5286         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5287         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5288         TREE_CHAIN (arg1_len) = arg2_tree;
5289         TREE_CHAIN (arg1_tree) = arg1_len;
5290
5291         expr_tree
5292           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5293                           ffecom_gfrt_kindtype (gfrt),
5294                           FALSE,
5295                           NULL_TREE,
5296                           arg1_tree,
5297                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5298                           ffebld_nonter_hook (expr));
5299         TREE_SIDE_EFFECTS (expr_tree) = 1;
5300       }
5301       return expr_tree;
5302
5303     case FFEINTRIN_impIRAND:
5304     case FFEINTRIN_impRAND:
5305       /* Arg defaults to 0 (normal random case) */
5306       {
5307         tree arg1_tree;
5308
5309         if (arg1 == NULL)
5310           arg1_tree = ffecom_integer_zero_node;
5311         else
5312           arg1_tree = ffecom_expr (arg1);
5313         arg1_tree = convert (ffecom_f2c_integer_type_node,
5314                              arg1_tree);
5315         arg1_tree = ffecom_1 (ADDR_EXPR,
5316                               build_pointer_type (TREE_TYPE (arg1_tree)),
5317                               arg1_tree);
5318         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5319
5320         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5321                                   ffecom_gfrt_kindtype (gfrt),
5322                                   FALSE,
5323                                   ((codegen_imp == FFEINTRIN_impIRAND) ?
5324                                    ffecom_f2c_integer_type_node :
5325                                    ffecom_f2c_real_type_node),
5326                                   arg1_tree,
5327                                   dest_tree, dest, dest_used,
5328                                   NULL_TREE, TRUE,
5329                                   ffebld_nonter_hook (expr));
5330       }
5331       return expr_tree;
5332
5333     case FFEINTRIN_impFTELL_subr:
5334     case FFEINTRIN_impUMASK_subr:
5335       {
5336         tree arg1_tree;
5337         tree arg2_tree;
5338
5339         arg1_tree = convert (ffecom_f2c_integer_type_node,
5340                              ffecom_expr (arg1));
5341         arg1_tree = ffecom_1 (ADDR_EXPR,
5342                               build_pointer_type (TREE_TYPE (arg1_tree)),
5343                               arg1_tree);
5344
5345         if (arg2 == NULL)
5346           arg2_tree = NULL_TREE;
5347         else
5348           arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
5349
5350         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5351                                   ffecom_gfrt_kindtype (gfrt),
5352                                   FALSE,
5353                                   NULL_TREE,
5354                                   build_tree_list (NULL_TREE, arg1_tree),
5355                                   NULL_TREE, NULL, NULL, NULL_TREE,
5356                                   TRUE,
5357                                   ffebld_nonter_hook (expr));
5358         if (arg2_tree != NULL_TREE) {
5359           expr_tree = ffecom_modify (NULL_TREE, arg2_tree,
5360                                      convert (TREE_TYPE (arg2_tree),
5361                                               expr_tree));
5362         }
5363       }
5364       return expr_tree;
5365
5366     case FFEINTRIN_impCPU_TIME:
5367     case FFEINTRIN_impSECOND_subr:
5368       {
5369         tree arg1_tree;
5370
5371         arg1_tree = ffecom_expr_w (NULL_TREE, arg1);
5372
5373         expr_tree
5374           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5375                           ffecom_gfrt_kindtype (gfrt),
5376                           FALSE,
5377                           NULL_TREE,
5378                           NULL_TREE,
5379                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5380                           ffebld_nonter_hook (expr));
5381
5382         expr_tree
5383           = ffecom_modify (NULL_TREE, arg1_tree,
5384                            convert (TREE_TYPE (arg1_tree),
5385                                     expr_tree));
5386       }
5387       return expr_tree;
5388
5389     case FFEINTRIN_impDTIME_subr:
5390     case FFEINTRIN_impETIME_subr:
5391       {
5392         tree arg1_tree;
5393         tree result_tree;
5394
5395         result_tree = ffecom_expr_w (NULL_TREE, arg2);
5396
5397         arg1_tree = ffecom_ptr_to_expr (arg1);
5398
5399         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5400                                   ffecom_gfrt_kindtype (gfrt),
5401                                   FALSE,
5402                                   NULL_TREE,
5403                                   build_tree_list (NULL_TREE, arg1_tree),
5404                                   NULL_TREE, NULL, NULL, NULL_TREE,
5405                                   TRUE,
5406                                   ffebld_nonter_hook (expr));
5407         expr_tree = ffecom_modify (NULL_TREE, result_tree,
5408                                    convert (TREE_TYPE (result_tree),
5409                                             expr_tree));
5410       }
5411       return expr_tree;
5412
5413       /* Straightforward calls of libf2c routines: */
5414     case FFEINTRIN_impABORT:
5415     case FFEINTRIN_impACCESS:
5416     case FFEINTRIN_impBESJ0:
5417     case FFEINTRIN_impBESJ1:
5418     case FFEINTRIN_impBESJN:
5419     case FFEINTRIN_impBESY0:
5420     case FFEINTRIN_impBESY1:
5421     case FFEINTRIN_impBESYN:
5422     case FFEINTRIN_impCHDIR_func:
5423     case FFEINTRIN_impCHMOD_func:
5424     case FFEINTRIN_impDATE:
5425     case FFEINTRIN_impDATE_AND_TIME:
5426     case FFEINTRIN_impDBESJ0:
5427     case FFEINTRIN_impDBESJ1:
5428     case FFEINTRIN_impDBESJN:
5429     case FFEINTRIN_impDBESY0:
5430     case FFEINTRIN_impDBESY1:
5431     case FFEINTRIN_impDBESYN:
5432     case FFEINTRIN_impDTIME_func:
5433     case FFEINTRIN_impETIME_func:
5434     case FFEINTRIN_impFGETC_func:
5435     case FFEINTRIN_impFGET_func:
5436     case FFEINTRIN_impFNUM:
5437     case FFEINTRIN_impFPUTC_func:
5438     case FFEINTRIN_impFPUT_func:
5439     case FFEINTRIN_impFSEEK:
5440     case FFEINTRIN_impFSTAT_func:
5441     case FFEINTRIN_impFTELL_func:
5442     case FFEINTRIN_impGERROR:
5443     case FFEINTRIN_impGETARG:
5444     case FFEINTRIN_impGETCWD_func:
5445     case FFEINTRIN_impGETENV:
5446     case FFEINTRIN_impGETGID:
5447     case FFEINTRIN_impGETLOG:
5448     case FFEINTRIN_impGETPID:
5449     case FFEINTRIN_impGETUID:
5450     case FFEINTRIN_impGMTIME:
5451     case FFEINTRIN_impHOSTNM_func:
5452     case FFEINTRIN_impIDATE_unix:
5453     case FFEINTRIN_impIDATE_vxt:
5454     case FFEINTRIN_impIERRNO:
5455     case FFEINTRIN_impISATTY:
5456     case FFEINTRIN_impITIME:
5457     case FFEINTRIN_impKILL_func:
5458     case FFEINTRIN_impLINK_func:
5459     case FFEINTRIN_impLNBLNK:
5460     case FFEINTRIN_impLSTAT_func:
5461     case FFEINTRIN_impLTIME:
5462     case FFEINTRIN_impMCLOCK8:
5463     case FFEINTRIN_impMCLOCK:
5464     case FFEINTRIN_impPERROR:
5465     case FFEINTRIN_impRENAME_func:
5466     case FFEINTRIN_impSECNDS:
5467     case FFEINTRIN_impSECOND_func:
5468     case FFEINTRIN_impSLEEP:
5469     case FFEINTRIN_impSRAND:
5470     case FFEINTRIN_impSTAT_func:
5471     case FFEINTRIN_impSYMLNK_func:
5472     case FFEINTRIN_impSYSTEM_CLOCK:
5473     case FFEINTRIN_impSYSTEM_func:
5474     case FFEINTRIN_impTIME8:
5475     case FFEINTRIN_impTIME_unix:
5476     case FFEINTRIN_impTIME_vxt:
5477     case FFEINTRIN_impUMASK_func:
5478     case FFEINTRIN_impUNLINK_func:
5479       break;
5480
5481     case FFEINTRIN_impCTIME_func:       /* CHARACTER functions not handled here. */
5482     case FFEINTRIN_impFDATE_func:       /* CHARACTER functions not handled here. */
5483     case FFEINTRIN_impTTYNAM_func:      /* CHARACTER functions not handled here. */
5484     case FFEINTRIN_impNONE:
5485     case FFEINTRIN_imp:         /* Hush up gcc warning. */
5486       fprintf (stderr, "No %s implementation.\n",
5487                ffeintrin_name_implementation (ffebld_symter_implementation (ffebld_left (expr))));
5488       assert ("unimplemented intrinsic" == NULL);
5489       return error_mark_node;
5490     }
5491
5492   assert (gfrt != FFECOM_gfrt); /* Must have an implementation! */
5493
5494   expr_tree = ffecom_arglist_expr_ (ffecom_gfrt_args_ (gfrt),
5495                                     ffebld_right (expr));
5496
5497   return ffecom_call_ (ffecom_gfrt_tree_ (gfrt), ffecom_gfrt_kindtype (gfrt),
5498                        (ffe_is_f2c_library () && ffecom_gfrt_complex_[gfrt]),
5499                        tree_type,
5500                        expr_tree, dest_tree, dest, dest_used,
5501                        NULL_TREE, TRUE,
5502                        ffebld_nonter_hook (expr));
5503
5504   /* See bottom of this file for f2c transforms used to determine
5505      many of the above implementations.  The info seems to confuse
5506      Emacs's C mode indentation, which is why it's been moved to
5507      the bottom of this source file.  */
5508 }
5509
5510 #endif
5511 /* For power (exponentiation) where right-hand operand is type INTEGER,
5512    generate in-line code to do it the fast way (which, if the operand
5513    is a constant, might just mean a series of multiplies).  */
5514
5515 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5516 static tree
5517 ffecom_expr_power_integer_ (ffebld expr)
5518 {
5519   tree l = ffecom_expr (ffebld_left (expr));
5520   tree r = ffecom_expr (ffebld_right (expr));
5521   tree ltype = TREE_TYPE (l);
5522   tree rtype = TREE_TYPE (r);
5523   tree result = NULL_TREE;
5524
5525   if (l == error_mark_node
5526       || r == error_mark_node)
5527     return error_mark_node;
5528
5529   if (TREE_CODE (r) == INTEGER_CST)
5530     {
5531       int sgn = tree_int_cst_sgn (r);
5532
5533       if (sgn == 0)
5534         return convert (ltype, integer_one_node);
5535
5536       if ((TREE_CODE (ltype) == INTEGER_TYPE)
5537           && (sgn < 0))
5538         {
5539           /* Reciprocal of integer is either 0, -1, or 1, so after
5540              calculating that (which we leave to the back end to do
5541              or not do optimally), don't bother with any multiplying.  */
5542
5543           result = ffecom_tree_divide_ (ltype,
5544                                         convert (ltype, integer_one_node),
5545                                         l,
5546                                         NULL_TREE, NULL, NULL, NULL_TREE);
5547           r = ffecom_1 (NEGATE_EXPR,
5548                         rtype,
5549                         r);
5550           if ((TREE_INT_CST_LOW (r) & 1) == 0)
5551             result = ffecom_1 (ABS_EXPR, rtype,
5552                                result);
5553         }
5554
5555       /* Generate appropriate series of multiplies, preceded
5556          by divide if the exponent is negative.  */
5557
5558       l = save_expr (l);
5559
5560       if (sgn < 0)
5561         {
5562           l = ffecom_tree_divide_ (ltype,
5563                                    convert (ltype, integer_one_node),
5564                                    l,
5565                                    NULL_TREE, NULL, NULL,
5566                                    ffebld_nonter_hook (expr));
5567           r = ffecom_1 (NEGATE_EXPR, rtype, r);
5568           assert (TREE_CODE (r) == INTEGER_CST);
5569
5570           if (tree_int_cst_sgn (r) < 0)
5571             {                   /* The "most negative" number.  */
5572               r = ffecom_1 (NEGATE_EXPR, rtype,
5573                             ffecom_2 (RSHIFT_EXPR, rtype,
5574                                       r,
5575                                       integer_one_node));
5576               l = save_expr (l);
5577               l = ffecom_2 (MULT_EXPR, ltype,
5578                             l,
5579                             l);
5580             }
5581         }
5582
5583       for (;;)
5584         {
5585           if (TREE_INT_CST_LOW (r) & 1)
5586             {
5587               if (result == NULL_TREE)
5588                 result = l;
5589               else
5590                 result = ffecom_2 (MULT_EXPR, ltype,
5591                                    result,
5592                                    l);
5593             }
5594
5595           r = ffecom_2 (RSHIFT_EXPR, rtype,
5596                         r,
5597                         integer_one_node);
5598           if (integer_zerop (r))
5599             break;
5600           assert (TREE_CODE (r) == INTEGER_CST);
5601
5602           l = save_expr (l);
5603           l = ffecom_2 (MULT_EXPR, ltype,
5604                         l,
5605                         l);
5606         }
5607       return result;
5608     }
5609
5610   /* Though rhs isn't a constant, in-line code cannot be expanded
5611      while transforming dummies
5612      because the back end cannot be easily convinced to generate
5613      stores (MODIFY_EXPR), handle temporaries, and so on before
5614      all the appropriate rtx's have been generated for things like
5615      dummy args referenced in rhs -- which doesn't happen until
5616      store_parm_decls() is called (expand_function_start, I believe,
5617      does the actual rtx-stuffing of PARM_DECLs).
5618
5619      So, in this case, let the caller generate the call to the
5620      run-time-library function to evaluate the power for us.  */
5621
5622   if (ffecom_transform_only_dummies_)
5623     return NULL_TREE;
5624
5625   /* Right-hand operand not a constant, expand in-line code to figure
5626      out how to do the multiplies, &c.
5627
5628      The returned expression is expressed this way in GNU C, where l and
5629      r are the "inputs":
5630
5631      ({ typeof (r) rtmp = r;
5632         typeof (l) ltmp = l;
5633         typeof (l) result;
5634
5635         if (rtmp == 0)
5636           result = 1;
5637         else
5638           {
5639             if ((basetypeof (l) == basetypeof (int))
5640                 && (rtmp < 0))
5641               {
5642                 result = ((typeof (l)) 1) / ltmp;
5643                 if ((ltmp < 0) && (((-rtmp) & 1) == 0))
5644                   result = -result;
5645               }
5646             else
5647               {
5648                 result = 1;
5649                 if ((basetypeof (l) != basetypeof (int))
5650                     && (rtmp < 0))
5651                   {
5652                     ltmp = ((typeof (l)) 1) / ltmp;
5653                     rtmp = -rtmp;
5654                     if (rtmp < 0)
5655                       {
5656                         rtmp = -(rtmp >> 1);
5657                         ltmp *= ltmp;
5658                       }
5659                   }
5660                 for (;;)
5661                   {
5662                     if (rtmp & 1)
5663                       result *= ltmp;
5664                     if ((rtmp >>= 1) == 0)
5665                       break;
5666                     ltmp *= ltmp;
5667                   }
5668               }
5669           }
5670         result;
5671      })
5672
5673      Note that some of the above is compile-time collapsable, such as
5674      the first part of the if statements that checks the base type of
5675      l against int.  The if statements are phrased that way to suggest
5676      an easy way to generate the if/else constructs here, knowing that
5677      the back end should (and probably does) eliminate the resulting
5678      dead code (either the int case or the non-int case), something
5679      it couldn't do without the redundant phrasing, requiring explicit
5680      dead-code elimination here, which would be kind of difficult to
5681      read.  */
5682
5683   {
5684     tree rtmp;
5685     tree ltmp;
5686     tree divide;
5687     tree basetypeof_l_is_int;
5688     tree se;
5689     tree t;
5690
5691     basetypeof_l_is_int
5692       = build_int_2 ((TREE_CODE (ltype) == INTEGER_TYPE), 0);
5693
5694     se = expand_start_stmt_expr ();
5695
5696     ffecom_start_compstmt ();
5697
5698 #ifndef HAHA
5699     rtmp = ffecom_make_tempvar ("power_r", rtype,
5700                                 FFETARGET_charactersizeNONE, -1);
5701     ltmp = ffecom_make_tempvar ("power_l", ltype,
5702                                 FFETARGET_charactersizeNONE, -1);
5703     result = ffecom_make_tempvar ("power_res", ltype,
5704                                   FFETARGET_charactersizeNONE, -1);
5705     if (TREE_CODE (ltype) == COMPLEX_TYPE
5706         || TREE_CODE (ltype) == RECORD_TYPE)
5707       divide = ffecom_make_tempvar ("power_div", ltype,
5708                                     FFETARGET_charactersizeNONE, -1);
5709     else
5710       divide = NULL_TREE;
5711 #else  /* HAHA */
5712     {
5713       tree hook;
5714
5715       hook = ffebld_nonter_hook (expr);
5716       assert (hook);
5717       assert (TREE_CODE (hook) == TREE_VEC);
5718       assert (TREE_VEC_LENGTH (hook) == 4);
5719       rtmp = TREE_VEC_ELT (hook, 0);
5720       ltmp = TREE_VEC_ELT (hook, 1);
5721       result = TREE_VEC_ELT (hook, 2);
5722       divide = TREE_VEC_ELT (hook, 3);
5723       if (TREE_CODE (ltype) == COMPLEX_TYPE
5724           || TREE_CODE (ltype) == RECORD_TYPE)
5725         assert (divide);
5726       else
5727         assert (! divide);
5728     }
5729 #endif  /* HAHA */
5730
5731     expand_expr_stmt (ffecom_modify (void_type_node,
5732                                      rtmp,
5733                                      r));
5734     expand_expr_stmt (ffecom_modify (void_type_node,
5735                                      ltmp,
5736                                      l));
5737     expand_start_cond (ffecom_truth_value
5738                        (ffecom_2 (EQ_EXPR, integer_type_node,
5739                                   rtmp,
5740                                   convert (rtype, integer_zero_node))),
5741                        0);
5742     expand_expr_stmt (ffecom_modify (void_type_node,
5743                                      result,
5744                                      convert (ltype, integer_one_node)));
5745     expand_start_else ();
5746     if (! integer_zerop (basetypeof_l_is_int))
5747       {
5748         expand_start_cond (ffecom_2 (LT_EXPR, integer_type_node,
5749                                      rtmp,
5750                                      convert (rtype,
5751                                               integer_zero_node)),
5752                            0);
5753         expand_expr_stmt (ffecom_modify (void_type_node,
5754                                          result,
5755                                          ffecom_tree_divide_
5756                                          (ltype,
5757                                           convert (ltype, integer_one_node),
5758                                           ltmp,
5759                                           NULL_TREE, NULL, NULL,
5760                                           divide)));
5761         expand_start_cond (ffecom_truth_value
5762                            (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5763                                       ffecom_2 (LT_EXPR, integer_type_node,
5764                                                 ltmp,
5765                                                 convert (ltype,
5766                                                          integer_zero_node)),
5767                                       ffecom_2 (EQ_EXPR, integer_type_node,
5768                                                 ffecom_2 (BIT_AND_EXPR,
5769                                                           rtype,
5770                                                           ffecom_1 (NEGATE_EXPR,
5771                                                                     rtype,
5772                                                                     rtmp),
5773                                                           convert (rtype,
5774                                                                    integer_one_node)),
5775                                                 convert (rtype,
5776                                                          integer_zero_node)))),
5777                            0);
5778         expand_expr_stmt (ffecom_modify (void_type_node,
5779                                          result,
5780                                          ffecom_1 (NEGATE_EXPR,
5781                                                    ltype,
5782                                                    result)));
5783         expand_end_cond ();
5784         expand_start_else ();
5785       }
5786     expand_expr_stmt (ffecom_modify (void_type_node,
5787                                      result,
5788                                      convert (ltype, integer_one_node)));
5789     expand_start_cond (ffecom_truth_value
5790                        (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5791                                   ffecom_truth_value_invert
5792                                   (basetypeof_l_is_int),
5793                                   ffecom_2 (LT_EXPR, integer_type_node,
5794                                             rtmp,
5795                                             convert (rtype,
5796                                                      integer_zero_node)))),
5797                        0);
5798     expand_expr_stmt (ffecom_modify (void_type_node,
5799                                      ltmp,
5800                                      ffecom_tree_divide_
5801                                      (ltype,
5802                                       convert (ltype, integer_one_node),
5803                                       ltmp,
5804                                       NULL_TREE, NULL, NULL,
5805                                       divide)));
5806     expand_expr_stmt (ffecom_modify (void_type_node,
5807                                      rtmp,
5808                                      ffecom_1 (NEGATE_EXPR, rtype,
5809                                                rtmp)));
5810     expand_start_cond (ffecom_truth_value
5811                        (ffecom_2 (LT_EXPR, integer_type_node,
5812                                   rtmp,
5813                                   convert (rtype, integer_zero_node))),
5814                        0);
5815     expand_expr_stmt (ffecom_modify (void_type_node,
5816                                      rtmp,
5817                                      ffecom_1 (NEGATE_EXPR, rtype,
5818                                                ffecom_2 (RSHIFT_EXPR,
5819                                                          rtype,
5820                                                          rtmp,
5821                                                          integer_one_node))));
5822     expand_expr_stmt (ffecom_modify (void_type_node,
5823                                      ltmp,
5824                                      ffecom_2 (MULT_EXPR, ltype,
5825                                                ltmp,
5826                                                ltmp)));
5827     expand_end_cond ();
5828     expand_end_cond ();
5829     expand_start_loop (1);
5830     expand_start_cond (ffecom_truth_value
5831                        (ffecom_2 (BIT_AND_EXPR, rtype,
5832                                   rtmp,
5833                                   convert (rtype, integer_one_node))),
5834                        0);
5835     expand_expr_stmt (ffecom_modify (void_type_node,
5836                                      result,
5837                                      ffecom_2 (MULT_EXPR, ltype,
5838                                                result,
5839                                                ltmp)));
5840     expand_end_cond ();
5841     expand_exit_loop_if_false (NULL,
5842                                ffecom_truth_value
5843                                (ffecom_modify (rtype,
5844                                                rtmp,
5845                                                ffecom_2 (RSHIFT_EXPR,
5846                                                          rtype,
5847                                                          rtmp,
5848                                                          integer_one_node))));
5849     expand_expr_stmt (ffecom_modify (void_type_node,
5850                                      ltmp,
5851                                      ffecom_2 (MULT_EXPR, ltype,
5852                                                ltmp,
5853                                                ltmp)));
5854     expand_end_loop ();
5855     expand_end_cond ();
5856     if (!integer_zerop (basetypeof_l_is_int))
5857       expand_end_cond ();
5858     expand_expr_stmt (result);
5859
5860     t = ffecom_end_compstmt ();
5861
5862     result = expand_end_stmt_expr (se);
5863
5864     /* This code comes from c-parse.in, after its expand_end_stmt_expr.  */
5865
5866     if (TREE_CODE (t) == BLOCK)
5867       {
5868         /* Make a BIND_EXPR for the BLOCK already made.  */
5869         result = build (BIND_EXPR, TREE_TYPE (result),
5870                         NULL_TREE, result, t);
5871         /* Remove the block from the tree at this point.
5872            It gets put back at the proper place
5873            when the BIND_EXPR is expanded.  */
5874         delete_block (t);
5875       }
5876     else
5877       result = t;
5878   }
5879
5880   return result;
5881 }
5882
5883 #endif
5884 /* ffecom_expr_transform_ -- Transform symbols in expr
5885
5886    ffebld expr;  // FFE expression.
5887    ffecom_expr_transform_ (expr);
5888
5889    Recursive descent on expr while transforming any untransformed SYMTERs.  */
5890
5891 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5892 static void
5893 ffecom_expr_transform_ (ffebld expr)
5894 {
5895   tree t;
5896   ffesymbol s;
5897
5898 tail_recurse:                   /* :::::::::::::::::::: */
5899
5900   if (expr == NULL)
5901     return;
5902
5903   switch (ffebld_op (expr))
5904     {
5905     case FFEBLD_opSYMTER:
5906       s = ffebld_symter (expr);
5907       t = ffesymbol_hook (s).decl_tree;
5908       if ((t == NULL_TREE)
5909           && ((ffesymbol_kind (s) != FFEINFO_kindNONE)
5910               || ((ffesymbol_where (s) != FFEINFO_whereNONE)
5911                   && (ffesymbol_where (s) != FFEINFO_whereINTRINSIC))))
5912         {
5913           s = ffecom_sym_transform_ (s);
5914           t = ffesymbol_hook (s).decl_tree;     /* Sfunc expr non-dummy,
5915                                                    DIMENSION expr? */
5916         }
5917       break;                    /* Ok if (t == NULL) here. */
5918
5919     case FFEBLD_opITEM:
5920       ffecom_expr_transform_ (ffebld_head (expr));
5921       expr = ffebld_trail (expr);
5922       goto tail_recurse;        /* :::::::::::::::::::: */
5923
5924     default:
5925       break;
5926     }
5927
5928   switch (ffebld_arity (expr))
5929     {
5930     case 2:
5931       ffecom_expr_transform_ (ffebld_left (expr));
5932       expr = ffebld_right (expr);
5933       goto tail_recurse;        /* :::::::::::::::::::: */
5934
5935     case 1:
5936       expr = ffebld_left (expr);
5937       goto tail_recurse;        /* :::::::::::::::::::: */
5938
5939     default:
5940       break;
5941     }
5942
5943   return;
5944 }
5945
5946 #endif
5947 /* Make a type based on info in live f2c.h file.  */
5948
5949 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5950 static void
5951 ffecom_f2c_make_type_ (tree *type, int tcode, const char *name)
5952 {
5953   switch (tcode)
5954     {
5955     case FFECOM_f2ccodeCHAR:
5956       *type = make_signed_type (CHAR_TYPE_SIZE);
5957       break;
5958
5959     case FFECOM_f2ccodeSHORT:
5960       *type = make_signed_type (SHORT_TYPE_SIZE);
5961       break;
5962
5963     case FFECOM_f2ccodeINT:
5964       *type = make_signed_type (INT_TYPE_SIZE);
5965       break;
5966
5967     case FFECOM_f2ccodeLONG:
5968       *type = make_signed_type (LONG_TYPE_SIZE);
5969       break;
5970
5971     case FFECOM_f2ccodeLONGLONG:
5972       *type = make_signed_type (LONG_LONG_TYPE_SIZE);
5973       break;
5974
5975     case FFECOM_f2ccodeCHARPTR:
5976       *type = build_pointer_type (DEFAULT_SIGNED_CHAR
5977                                   ? signed_char_type_node
5978                                   : unsigned_char_type_node);
5979       break;
5980
5981     case FFECOM_f2ccodeFLOAT:
5982       *type = make_node (REAL_TYPE);
5983       TYPE_PRECISION (*type) = FLOAT_TYPE_SIZE;
5984       layout_type (*type);
5985       break;
5986
5987     case FFECOM_f2ccodeDOUBLE:
5988       *type = make_node (REAL_TYPE);
5989       TYPE_PRECISION (*type) = DOUBLE_TYPE_SIZE;
5990       layout_type (*type);
5991       break;
5992
5993     case FFECOM_f2ccodeLONGDOUBLE:
5994       *type = make_node (REAL_TYPE);
5995       TYPE_PRECISION (*type) = LONG_DOUBLE_TYPE_SIZE;
5996       layout_type (*type);
5997       break;
5998
5999     case FFECOM_f2ccodeTWOREALS:
6000       *type = ffecom_make_complex_type_ (ffecom_f2c_real_type_node);
6001       break;
6002
6003     case FFECOM_f2ccodeTWODOUBLEREALS:
6004       *type = ffecom_make_complex_type_ (ffecom_f2c_doublereal_type_node);
6005       break;
6006
6007     default:
6008       assert ("unexpected FFECOM_f2ccodeXYZZY!" == NULL);
6009       *type = error_mark_node;
6010       return;
6011     }
6012
6013   pushdecl (build_decl (TYPE_DECL,
6014                         ffecom_get_invented_identifier ("__g77_f2c_%s", name),
6015                         *type));
6016 }
6017
6018 #endif
6019 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6020 /* Set the f2c list-directed-I/O code for whatever (integral) type has the
6021    given size.  */
6022
6023 static void
6024 ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
6025                           int code)
6026 {
6027   int j;
6028   tree t;
6029
6030   for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
6031     if ((t = ffecom_tree_type[bt][j]) != NULL_TREE
6032         && compare_tree_int (TYPE_SIZE (t), size) == 0)
6033       {
6034         assert (code != -1);
6035         ffecom_f2c_typecode_[bt][j] = code;
6036         code = -1;
6037       }
6038 }
6039
6040 #endif
6041 /* Finish up globals after doing all program units in file
6042
6043    Need to handle only uninitialized COMMON areas.  */
6044
6045 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6046 static ffeglobal
6047 ffecom_finish_global_ (ffeglobal global)
6048 {
6049   tree cbtype;
6050   tree cbt;
6051   tree size;
6052
6053   if (ffeglobal_type (global) != FFEGLOBAL_typeCOMMON)
6054       return global;
6055
6056   if (ffeglobal_common_init (global))
6057       return global;
6058
6059   cbt = ffeglobal_hook (global);
6060   if ((cbt == NULL_TREE)
6061       || !ffeglobal_common_have_size (global))
6062     return global;              /* No need to make common, never ref'd. */
6063
6064   DECL_EXTERNAL (cbt) = 0;
6065
6066   /* Give the array a size now.  */
6067
6068   size = build_int_2 ((ffeglobal_common_size (global)
6069                       + ffeglobal_common_pad (global)) - 1,
6070                       0);
6071
6072   cbtype = TREE_TYPE (cbt);
6073   TYPE_DOMAIN (cbtype) = build_range_type (integer_type_node,
6074                                            integer_zero_node,
6075                                            size);
6076   if (!TREE_TYPE (size))
6077     TREE_TYPE (size) = TYPE_DOMAIN (cbtype);
6078   layout_type (cbtype);
6079
6080   cbt = start_decl (cbt, FALSE);
6081   assert (cbt == ffeglobal_hook (global));
6082
6083   finish_decl (cbt, NULL_TREE, FALSE);
6084
6085   return global;
6086 }
6087
6088 #endif
6089 /* Finish up any untransformed symbols.  */
6090
6091 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6092 static ffesymbol
6093 ffecom_finish_symbol_transform_ (ffesymbol s)
6094 {
6095   if ((s == NULL) || (TREE_CODE (current_function_decl) == ERROR_MARK))
6096     return s;
6097
6098   /* It's easy to know to transform an untransformed symbol, to make sure
6099      we put out debugging info for it.  But COMMON variables, unlike
6100      EQUIVALENCE ones, aren't given declarations in addition to the
6101      tree expressions that specify offsets, because COMMON variables
6102      can be referenced in the outer scope where only dummy arguments
6103      (PARM_DECLs) should really be seen.  To be safe, just don't do any
6104      VAR_DECLs for COMMON variables when we transform them for real
6105      use, and therefore we do all the VAR_DECL creating here.  */
6106
6107   if (ffesymbol_hook (s).decl_tree == NULL_TREE)
6108     {
6109       if (ffesymbol_kind (s) != FFEINFO_kindNONE
6110           || (ffesymbol_where (s) != FFEINFO_whereNONE
6111               && ffesymbol_where (s) != FFEINFO_whereINTRINSIC
6112               && ffesymbol_where (s) != FFEINFO_whereDUMMY))
6113         /* Not transformed, and not CHARACTER*(*), and not a dummy
6114            argument, which can happen only if the entry point names
6115            it "rides in on" are all invalidated for other reasons.  */
6116         s = ffecom_sym_transform_ (s);
6117     }
6118
6119   if ((ffesymbol_where (s) == FFEINFO_whereCOMMON)
6120       && (ffesymbol_hook (s).decl_tree != error_mark_node))
6121     {
6122       /* This isn't working, at least for dbxout.  The .s file looks
6123          okay to me (burley), but in gdb 4.9 at least, the variables
6124          appear to reside somewhere outside of the common area, so
6125          it doesn't make sense to mislead anyone by generating the info
6126          on those variables until this is fixed.  NOTE: Same problem
6127          with EQUIVALENCE, sadly...see similar #if later.  */
6128       ffecom_member_phase2_ (ffesymbol_storage (ffesymbol_common (s)),
6129                              ffesymbol_storage (s));
6130     }
6131
6132   return s;
6133 }
6134
6135 #endif
6136 /* Append underscore(s) to name before calling get_identifier.  "us"
6137    is nonzero if the name already contains an underscore and thus
6138    needs two underscores appended.  */
6139
6140 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6141 static tree
6142 ffecom_get_appended_identifier_ (char us, const char *name)
6143 {
6144   int i;
6145   char *newname;
6146   tree id;
6147
6148   newname = xmalloc ((i = strlen (name)) + 1
6149                      + ffe_is_underscoring ()
6150                      + us);
6151   memcpy (newname, name, i);
6152   newname[i] = '_';
6153   newname[i + us] = '_';
6154   newname[i + 1 + us] = '\0';
6155   id = get_identifier (newname);
6156
6157   free (newname);
6158
6159   return id;
6160 }
6161
6162 #endif
6163 /* Decide whether to append underscore to name before calling
6164    get_identifier.  */
6165
6166 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6167 static tree
6168 ffecom_get_external_identifier_ (ffesymbol s)
6169 {
6170   char us;
6171   const char *name = ffesymbol_text (s);
6172
6173   /* If name is a built-in name, just return it as is.  */
6174
6175   if (!ffe_is_underscoring ()
6176       || (strcmp (name, FFETARGET_nameBLANK_COMMON) == 0)
6177 #if FFETARGET_isENFORCED_MAIN_NAME
6178       || (strcmp (name, FFETARGET_nameENFORCED_NAME) == 0)
6179 #else
6180       || (strcmp (name, FFETARGET_nameUNNAMED_MAIN) == 0)
6181 #endif
6182       || (strcmp (name, FFETARGET_nameUNNAMED_BLOCK_DATA) == 0))
6183     return get_identifier (name);
6184
6185   us = ffe_is_second_underscore ()
6186     ? (strchr (name, '_') != NULL)
6187       : 0;
6188
6189   return ffecom_get_appended_identifier_ (us, name);
6190 }
6191
6192 #endif
6193 /* Decide whether to append underscore to internal name before calling
6194    get_identifier.
6195
6196    This is for non-external, top-function-context names only.  Transform
6197    identifier so it doesn't conflict with the transformed result
6198    of using a _different_ external name.  E.g. if "CALL FOO" is
6199    transformed into "FOO_();", then the variable in "FOO_ = 3"
6200    must be transformed into something that does not conflict, since
6201    these two things should be independent.
6202
6203    The transformation is as follows.  If the name does not contain
6204    an underscore, there is no possible conflict, so just return.
6205    If the name does contain an underscore, then transform it just
6206    like we transform an external identifier.  */
6207
6208 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6209 static tree
6210 ffecom_get_identifier_ (const char *name)
6211 {
6212   /* If name does not contain an underscore, just return it as is.  */
6213
6214   if (!ffe_is_underscoring ()
6215       || (strchr (name, '_') == NULL))
6216     return get_identifier (name);
6217
6218   return ffecom_get_appended_identifier_ (ffe_is_second_underscore (),
6219                                           name);
6220 }
6221
6222 #endif
6223 /* ffecom_gen_sfuncdef_ -- Generate definition of statement function
6224
6225    tree t;
6226    ffesymbol s;  // kindFUNCTION, whereIMMEDIATE.
6227    t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s),
6228          ffesymbol_kindtype(s));
6229
6230    Call after setting up containing function and getting trees for all
6231    other symbols.  */
6232
6233 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6234 static tree
6235 ffecom_gen_sfuncdef_ (ffesymbol s, ffeinfoBasictype bt, ffeinfoKindtype kt)
6236 {
6237   ffebld expr = ffesymbol_sfexpr (s);
6238   tree type;
6239   tree func;
6240   tree result;
6241   bool charfunc = (bt == FFEINFO_basictypeCHARACTER);
6242   static bool recurse = FALSE;
6243   int old_lineno = lineno;
6244   const char *old_input_filename = input_filename;
6245
6246   ffecom_nested_entry_ = s;
6247
6248   /* For now, we don't have a handy pointer to where the sfunc is actually
6249      defined, though that should be easy to add to an ffesymbol. (The
6250      token/where info available might well point to the place where the type
6251      of the sfunc is declared, especially if that precedes the place where
6252      the sfunc itself is defined, which is typically the case.)  We should
6253      put out a null pointer rather than point somewhere wrong, but I want to
6254      see how it works at this point.  */
6255
6256   input_filename = ffesymbol_where_filename (s);
6257   lineno = ffesymbol_where_filelinenum (s);
6258
6259   /* Pretransform the expression so any newly discovered things belong to the
6260      outer program unit, not to the statement function. */
6261
6262   ffecom_expr_transform_ (expr);
6263
6264   /* Make sure no recursive invocation of this fn (a specific case of failing
6265      to pretransform an sfunc's expression, i.e. where its expression
6266      references another untransformed sfunc) happens. */
6267
6268   assert (!recurse);
6269   recurse = TRUE;
6270
6271   push_f_function_context ();
6272
6273   if (charfunc)
6274     type = void_type_node;
6275   else
6276     {
6277       type = ffecom_tree_type[bt][kt];
6278       if (type == NULL_TREE)
6279         type = integer_type_node;       /* _sym_exec_transition reports
6280                                            error. */
6281     }
6282
6283   start_function (ffecom_get_identifier_ (ffesymbol_text (s)),
6284                   build_function_type (type, NULL_TREE),
6285                   1,            /* nested/inline */
6286                   0);           /* TREE_PUBLIC */
6287
6288   /* We don't worry about COMPLEX return values here, because this is
6289      entirely internal to our code, and gcc has the ability to return COMPLEX
6290      directly as a value.  */
6291
6292   if (charfunc)
6293     {                           /* Prepend arg for where result goes. */
6294       tree type;
6295
6296       type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
6297
6298       result = ffecom_get_invented_identifier ("__g77_%s", "result");
6299
6300       ffecom_char_enhance_arg_ (&type, s);      /* Ignore returned length. */
6301
6302       type = build_pointer_type (type);
6303       result = build_decl (PARM_DECL, result, type);
6304
6305       push_parm_decl (result);
6306     }
6307   else
6308     result = NULL_TREE;         /* Not ref'd if !charfunc. */
6309
6310   ffecom_push_dummy_decls_ (ffesymbol_dummyargs (s), TRUE);
6311
6312   store_parm_decls (0);
6313
6314   ffecom_start_compstmt ();
6315
6316   if (expr != NULL)
6317     {
6318       if (charfunc)
6319         {
6320           ffetargetCharacterSize sz = ffesymbol_size (s);
6321           tree result_length;
6322
6323           result_length = build_int_2 (sz, 0);
6324           TREE_TYPE (result_length) = ffecom_f2c_ftnlen_type_node;
6325
6326           ffecom_prepare_let_char_ (sz, expr);
6327
6328           ffecom_prepare_end ();
6329
6330           ffecom_let_char_ (result, result_length, sz, expr);
6331           expand_null_return ();
6332         }
6333       else
6334         {
6335           ffecom_prepare_expr (expr);
6336
6337           ffecom_prepare_end ();
6338
6339           expand_return (ffecom_modify (NULL_TREE,
6340                                         DECL_RESULT (current_function_decl),
6341                                         ffecom_expr (expr)));
6342         }
6343     }
6344
6345   ffecom_end_compstmt ();
6346
6347   func = current_function_decl;
6348   finish_function (1);
6349
6350   pop_f_function_context ();
6351
6352   recurse = FALSE;
6353
6354   lineno = old_lineno;
6355   input_filename = old_input_filename;
6356
6357   ffecom_nested_entry_ = NULL;
6358
6359   return func;
6360 }
6361
6362 #endif
6363
6364 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6365 static const char *
6366 ffecom_gfrt_args_ (ffecomGfrt ix)
6367 {
6368   return ffecom_gfrt_argstring_[ix];
6369 }
6370
6371 #endif
6372 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6373 static tree
6374 ffecom_gfrt_tree_ (ffecomGfrt ix)
6375 {
6376   if (ffecom_gfrt_[ix] == NULL_TREE)
6377     ffecom_make_gfrt_ (ix);
6378
6379   return ffecom_1 (ADDR_EXPR,
6380                    build_pointer_type (TREE_TYPE (ffecom_gfrt_[ix])),
6381                    ffecom_gfrt_[ix]);
6382 }
6383
6384 #endif
6385 /* Return initialize-to-zero expression for this VAR_DECL.  */
6386
6387 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6388 /* A somewhat evil way to prevent the garbage collector
6389    from collecting 'tree' structures.  */
6390 #define NUM_TRACKED_CHUNK 63
6391 static struct tree_ggc_tracker
6392 {
6393   struct tree_ggc_tracker *next;
6394   tree trees[NUM_TRACKED_CHUNK];
6395 } *tracker_head = NULL;
6396
6397 static void
6398 mark_tracker_head (void *arg)
6399 {
6400   struct tree_ggc_tracker *head;
6401   int i;
6402
6403   for (head = * (struct tree_ggc_tracker **) arg;
6404        head != NULL;
6405        head = head->next)
6406   {
6407     ggc_mark (head);
6408     for (i = 0; i < NUM_TRACKED_CHUNK; i++)
6409       ggc_mark_tree (head->trees[i]);
6410   }
6411 }
6412
6413 void
6414 ffecom_save_tree_forever (tree t)
6415 {
6416   int i;
6417   if (tracker_head != NULL)
6418     for (i = 0; i < NUM_TRACKED_CHUNK; i++)
6419       if (tracker_head->trees[i] == NULL)
6420         {
6421           tracker_head->trees[i] = t;
6422           return;
6423         }
6424
6425   {
6426     /* Need to allocate a new block.  */
6427     struct tree_ggc_tracker *old_head = tracker_head;
6428
6429     tracker_head = ggc_alloc (sizeof (*tracker_head));
6430     tracker_head->next = old_head;
6431     tracker_head->trees[0] = t;
6432     for (i = 1; i < NUM_TRACKED_CHUNK; i++)
6433       tracker_head->trees[i] = NULL;
6434   }
6435 }
6436
6437 static tree
6438 ffecom_init_zero_ (tree decl)
6439 {
6440   tree init;
6441   int incremental = TREE_STATIC (decl);
6442   tree type = TREE_TYPE (decl);
6443
6444   if (incremental)
6445     {
6446       make_decl_rtl (decl, NULL);
6447       assemble_variable (decl, TREE_PUBLIC (decl) ? 1 : 0, 0, 1);
6448     }
6449
6450   if ((TREE_CODE (type) != ARRAY_TYPE)
6451       && (TREE_CODE (type) != RECORD_TYPE)
6452       && (TREE_CODE (type) != UNION_TYPE)
6453       && !incremental)
6454     init = convert (type, integer_zero_node);
6455   else if (!incremental)
6456     {
6457       init = build (CONSTRUCTOR, type, NULL_TREE, NULL_TREE);
6458       TREE_CONSTANT (init) = 1;
6459       TREE_STATIC (init) = 1;
6460     }
6461   else
6462     {
6463       assemble_zeros (int_size_in_bytes (type));
6464       init = error_mark_node;
6465     }
6466
6467   return init;
6468 }
6469
6470 #endif
6471 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6472 static tree
6473 ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
6474                          tree *maybe_tree)
6475 {
6476   tree expr_tree;
6477   tree length_tree;
6478
6479   switch (ffebld_op (arg))
6480     {
6481     case FFEBLD_opCONTER:       /* For F90, check 0-length. */
6482       if (ffetarget_length_character1
6483           (ffebld_constant_character1
6484            (ffebld_conter (arg))) == 0)
6485         {
6486           *maybe_tree = integer_zero_node;
6487           return convert (tree_type, integer_zero_node);
6488         }
6489
6490       *maybe_tree = integer_one_node;
6491       expr_tree = build_int_2 (*ffetarget_text_character1
6492                                (ffebld_constant_character1
6493                                 (ffebld_conter (arg))),
6494                                0);
6495       TREE_TYPE (expr_tree) = tree_type;
6496       return expr_tree;
6497
6498     case FFEBLD_opSYMTER:
6499     case FFEBLD_opARRAYREF:
6500     case FFEBLD_opFUNCREF:
6501     case FFEBLD_opSUBSTR:
6502       ffecom_char_args_ (&expr_tree, &length_tree, arg);
6503
6504       if ((expr_tree == error_mark_node)
6505           || (length_tree == error_mark_node))
6506         {
6507           *maybe_tree = error_mark_node;
6508           return error_mark_node;
6509         }
6510
6511       if (integer_zerop (length_tree))
6512         {
6513           *maybe_tree = integer_zero_node;
6514           return convert (tree_type, integer_zero_node);
6515         }
6516
6517       expr_tree
6518         = ffecom_1 (INDIRECT_REF,
6519                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6520                     expr_tree);
6521       expr_tree
6522         = ffecom_2 (ARRAY_REF,
6523                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6524                     expr_tree,
6525                     integer_one_node);
6526       expr_tree = convert (tree_type, expr_tree);
6527
6528       if (TREE_CODE (length_tree) == INTEGER_CST)
6529         *maybe_tree = integer_one_node;
6530       else                      /* Must check length at run time.  */
6531         *maybe_tree
6532           = ffecom_truth_value
6533             (ffecom_2 (GT_EXPR, integer_type_node,
6534                        length_tree,
6535                        ffecom_f2c_ftnlen_zero_node));
6536       return expr_tree;
6537
6538     case FFEBLD_opPAREN:
6539     case FFEBLD_opCONVERT:
6540       if (ffeinfo_size (ffebld_info (arg)) == 0)
6541         {
6542           *maybe_tree = integer_zero_node;
6543           return convert (tree_type, integer_zero_node);
6544         }
6545       return ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6546                                       maybe_tree);
6547
6548     case FFEBLD_opCONCATENATE:
6549       {
6550         tree maybe_left;
6551         tree maybe_right;
6552         tree expr_left;
6553         tree expr_right;
6554
6555         expr_left = ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6556                                              &maybe_left);
6557         expr_right = ffecom_intrinsic_ichar_ (tree_type, ffebld_right (arg),
6558                                               &maybe_right);
6559         *maybe_tree = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
6560                                 maybe_left,
6561                                 maybe_right);
6562         expr_tree = ffecom_3 (COND_EXPR, tree_type,
6563                               maybe_left,
6564                               expr_left,
6565                               expr_right);
6566         return expr_tree;
6567       }
6568
6569     default:
6570       assert ("bad op in ICHAR" == NULL);
6571       return error_mark_node;
6572     }
6573 }
6574
6575 #endif
6576 /* ffecom_intrinsic_len_ -- Return length info for char arg (LEN())
6577
6578    tree length_arg;
6579    ffebld expr;
6580    length_arg = ffecom_intrinsic_len_ (expr);
6581
6582    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
6583    subexpressions by constructing the appropriate tree for the
6584    length-of-character-text argument in a calling sequence.  */
6585
6586 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6587 static tree
6588 ffecom_intrinsic_len_ (ffebld expr)
6589 {
6590   ffetargetCharacter1 val;
6591   tree length;
6592
6593   switch (ffebld_op (expr))
6594     {
6595     case FFEBLD_opCONTER:
6596       val = ffebld_constant_character1 (ffebld_conter (expr));
6597       length = build_int_2 (ffetarget_length_character1 (val), 0);
6598       TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6599       break;
6600
6601     case FFEBLD_opSYMTER:
6602       {
6603         ffesymbol s = ffebld_symter (expr);
6604         tree item;
6605
6606         item = ffesymbol_hook (s).decl_tree;
6607         if (item == NULL_TREE)
6608           {
6609             s = ffecom_sym_transform_ (s);
6610             item = ffesymbol_hook (s).decl_tree;
6611           }
6612         if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
6613           {
6614             if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
6615               length = ffesymbol_hook (s).length_tree;
6616             else
6617               {
6618                 length = build_int_2 (ffesymbol_size (s), 0);
6619                 TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6620               }
6621           }
6622         else if (item == error_mark_node)
6623           length = error_mark_node;
6624         else                    /* FFEINFO_kindFUNCTION: */
6625           length = NULL_TREE;
6626       }
6627       break;
6628
6629     case FFEBLD_opARRAYREF:
6630       length = ffecom_intrinsic_len_ (ffebld_left (expr));
6631       break;
6632
6633     case FFEBLD_opSUBSTR:
6634       {
6635         ffebld start;
6636         ffebld end;
6637         ffebld thing = ffebld_right (expr);
6638         tree start_tree;
6639         tree end_tree;
6640
6641         assert (ffebld_op (thing) == FFEBLD_opITEM);
6642         start = ffebld_head (thing);
6643         thing = ffebld_trail (thing);
6644         assert (ffebld_trail (thing) == NULL);
6645         end = ffebld_head (thing);
6646
6647         length = ffecom_intrinsic_len_ (ffebld_left (expr));
6648
6649         if (length == error_mark_node)
6650           break;
6651
6652         if (start == NULL)
6653           {
6654             if (end == NULL)
6655               ;
6656             else
6657               {
6658                 length = convert (ffecom_f2c_ftnlen_type_node,
6659                                   ffecom_expr (end));
6660               }
6661           }
6662         else
6663           {
6664             start_tree = convert (ffecom_f2c_ftnlen_type_node,
6665                                   ffecom_expr (start));
6666
6667             if (start_tree == error_mark_node)
6668               {
6669                 length = error_mark_node;
6670                 break;
6671               }
6672
6673             if (end == NULL)
6674               {
6675                 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6676                                    ffecom_f2c_ftnlen_one_node,
6677                                    ffecom_2 (MINUS_EXPR,
6678                                              ffecom_f2c_ftnlen_type_node,
6679                                              length,
6680                                              start_tree));
6681               }
6682             else
6683               {
6684                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
6685                                     ffecom_expr (end));
6686
6687                 if (end_tree == error_mark_node)
6688                   {
6689                     length = error_mark_node;
6690                     break;
6691                   }
6692
6693                 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6694                                    ffecom_f2c_ftnlen_one_node,
6695                                    ffecom_2 (MINUS_EXPR,
6696                                              ffecom_f2c_ftnlen_type_node,
6697                                              end_tree, start_tree));
6698               }
6699           }
6700       }
6701       break;
6702
6703     case FFEBLD_opCONCATENATE:
6704       length
6705         = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6706                     ffecom_intrinsic_len_ (ffebld_left (expr)),
6707                     ffecom_intrinsic_len_ (ffebld_right (expr)));
6708       break;
6709
6710     case FFEBLD_opFUNCREF:
6711     case FFEBLD_opCONVERT:
6712       length = build_int_2 (ffebld_size (expr), 0);
6713       TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6714       break;
6715
6716     default:
6717       assert ("bad op for single char arg expr" == NULL);
6718       length = ffecom_f2c_ftnlen_zero_node;
6719       break;
6720     }
6721
6722   assert (length != NULL_TREE);
6723
6724   return length;
6725 }
6726
6727 #endif
6728 /* Handle CHARACTER assignments.
6729
6730    Generates code to do the assignment.  Used by ordinary assignment
6731    statement handler ffecom_let_stmt and by statement-function
6732    handler to generate code for a statement function.  */
6733
6734 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6735 static void
6736 ffecom_let_char_ (tree dest_tree, tree dest_length,
6737                   ffetargetCharacterSize dest_size, ffebld source)
6738 {
6739   ffecomConcatList_ catlist;
6740   tree source_length;
6741   tree source_tree;
6742   tree expr_tree;
6743
6744   if ((dest_tree == error_mark_node)
6745       || (dest_length == error_mark_node))
6746     return;
6747
6748   assert (dest_tree != NULL_TREE);
6749   assert (dest_length != NULL_TREE);
6750
6751   /* Source might be an opCONVERT, which just means it is a different size
6752      than the destination.  Since the underlying implementation here handles
6753      that (directly or via the s_copy or s_cat run-time-library functions),
6754      we don't need the "convenience" of an opCONVERT that tells us to
6755      truncate or blank-pad, particularly since the resulting implementation
6756      would probably be slower than otherwise. */
6757
6758   while (ffebld_op (source) == FFEBLD_opCONVERT)
6759     source = ffebld_left (source);
6760
6761   catlist = ffecom_concat_list_new_ (source, dest_size);
6762   switch (ffecom_concat_list_count_ (catlist))
6763     {
6764     case 0:                     /* Shouldn't happen, but in case it does... */
6765       ffecom_concat_list_kill_ (catlist);
6766       source_tree = null_pointer_node;
6767       source_length = ffecom_f2c_ftnlen_zero_node;
6768       expr_tree = build_tree_list (NULL_TREE, dest_tree);
6769       TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6770       TREE_CHAIN (TREE_CHAIN (expr_tree))
6771         = build_tree_list (NULL_TREE, dest_length);
6772       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6773         = build_tree_list (NULL_TREE, source_length);
6774
6775       expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6776       TREE_SIDE_EFFECTS (expr_tree) = 1;
6777
6778       expand_expr_stmt (expr_tree);
6779
6780       return;
6781
6782     case 1:                     /* The (fairly) easy case. */
6783       ffecom_char_args_ (&source_tree, &source_length,
6784                          ffecom_concat_list_expr_ (catlist, 0));
6785       ffecom_concat_list_kill_ (catlist);
6786       assert (source_tree != NULL_TREE);
6787       assert (source_length != NULL_TREE);
6788
6789       if ((source_tree == error_mark_node)
6790           || (source_length == error_mark_node))
6791         return;
6792
6793       if (dest_size == 1)
6794         {
6795           dest_tree
6796             = ffecom_1 (INDIRECT_REF,
6797                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6798                                                       (dest_tree))),
6799                         dest_tree);
6800           dest_tree
6801             = ffecom_2 (ARRAY_REF,
6802                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6803                                                       (dest_tree))),
6804                         dest_tree,
6805                         integer_one_node);
6806           source_tree
6807             = ffecom_1 (INDIRECT_REF,
6808                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6809                                                       (source_tree))),
6810                         source_tree);
6811           source_tree
6812             = ffecom_2 (ARRAY_REF,
6813                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6814                                                       (source_tree))),
6815                         source_tree,
6816                         integer_one_node);
6817
6818           expr_tree = ffecom_modify (void_type_node, dest_tree, source_tree);
6819
6820           expand_expr_stmt (expr_tree);
6821
6822           return;
6823         }
6824
6825       expr_tree = build_tree_list (NULL_TREE, dest_tree);
6826       TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6827       TREE_CHAIN (TREE_CHAIN (expr_tree))
6828         = build_tree_list (NULL_TREE, dest_length);
6829       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6830         = build_tree_list (NULL_TREE, source_length);
6831
6832       expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6833       TREE_SIDE_EFFECTS (expr_tree) = 1;
6834
6835       expand_expr_stmt (expr_tree);
6836
6837       return;
6838
6839     default:                    /* Must actually concatenate things. */
6840       break;
6841     }
6842
6843   /* Heavy-duty concatenation. */
6844
6845   {
6846     int count = ffecom_concat_list_count_ (catlist);
6847     int i;
6848     tree lengths;
6849     tree items;
6850     tree length_array;
6851     tree item_array;
6852     tree citem;
6853     tree clength;
6854
6855 #ifdef HOHO
6856     length_array
6857       = lengths
6858       = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
6859                              FFETARGET_charactersizeNONE, count, TRUE);
6860     item_array = items = ffecom_push_tempvar (ffecom_f2c_address_type_node,
6861                                               FFETARGET_charactersizeNONE,
6862                                               count, TRUE);
6863 #else
6864     {
6865       tree hook;
6866
6867       hook = ffebld_nonter_hook (source);
6868       assert (hook);
6869       assert (TREE_CODE (hook) == TREE_VEC);
6870       assert (TREE_VEC_LENGTH (hook) == 2);
6871       length_array = lengths = TREE_VEC_ELT (hook, 0);
6872       item_array = items = TREE_VEC_ELT (hook, 1);
6873     }
6874 #endif
6875
6876     for (i = 0; i < count; ++i)
6877       {
6878         ffecom_char_args_ (&citem, &clength,
6879                            ffecom_concat_list_expr_ (catlist, i));
6880         if ((citem == error_mark_node)
6881             || (clength == error_mark_node))
6882           {
6883             ffecom_concat_list_kill_ (catlist);
6884             return;
6885           }
6886
6887         items
6888           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
6889                       ffecom_modify (void_type_node,
6890                                      ffecom_2 (ARRAY_REF,
6891                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
6892                                                item_array,
6893                                                build_int_2 (i, 0)),
6894                                      citem),
6895                       items);
6896         lengths
6897           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
6898                       ffecom_modify (void_type_node,
6899                                      ffecom_2 (ARRAY_REF,
6900                    TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
6901                                                length_array,
6902                                                build_int_2 (i, 0)),
6903                                      clength),
6904                       lengths);
6905       }
6906
6907     expr_tree = build_tree_list (NULL_TREE, dest_tree);
6908     TREE_CHAIN (expr_tree)
6909       = build_tree_list (NULL_TREE,
6910                          ffecom_1 (ADDR_EXPR,
6911                                    build_pointer_type (TREE_TYPE (items)),
6912                                    items));
6913     TREE_CHAIN (TREE_CHAIN (expr_tree))
6914       = build_tree_list (NULL_TREE,
6915                          ffecom_1 (ADDR_EXPR,
6916                                    build_pointer_type (TREE_TYPE (lengths)),
6917                                    lengths));
6918     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6919       = build_tree_list
6920         (NULL_TREE,
6921          ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
6922                    convert (ffecom_f2c_ftnlen_type_node,
6923                             build_int_2 (count, 0))));
6924     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree))))
6925       = build_tree_list (NULL_TREE, dest_length);
6926
6927     expr_tree = ffecom_call_gfrt (FFECOM_gfrtCAT, expr_tree, NULL_TREE);
6928     TREE_SIDE_EFFECTS (expr_tree) = 1;
6929
6930     expand_expr_stmt (expr_tree);
6931   }
6932
6933   ffecom_concat_list_kill_ (catlist);
6934 }
6935
6936 #endif
6937 /* ffecom_make_gfrt_ -- Make initial info for run-time routine
6938
6939    ffecomGfrt ix;
6940    ffecom_make_gfrt_(ix);
6941
6942    Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL
6943    for the indicated run-time routine (ix).  */
6944
6945 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6946 static void
6947 ffecom_make_gfrt_ (ffecomGfrt ix)
6948 {
6949   tree t;
6950   tree ttype;
6951
6952   switch (ffecom_gfrt_type_[ix])
6953     {
6954     case FFECOM_rttypeVOID_:
6955       ttype = void_type_node;
6956       break;
6957
6958     case FFECOM_rttypeVOIDSTAR_:
6959       ttype = TREE_TYPE (null_pointer_node);    /* `void *'. */
6960       break;
6961
6962     case FFECOM_rttypeFTNINT_:
6963       ttype = ffecom_f2c_ftnint_type_node;
6964       break;
6965
6966     case FFECOM_rttypeINTEGER_:
6967       ttype = ffecom_f2c_integer_type_node;
6968       break;
6969
6970     case FFECOM_rttypeLONGINT_:
6971       ttype = ffecom_f2c_longint_type_node;
6972       break;
6973
6974     case FFECOM_rttypeLOGICAL_:
6975       ttype = ffecom_f2c_logical_type_node;
6976       break;
6977
6978     case FFECOM_rttypeREAL_F2C_:
6979       ttype = double_type_node;
6980       break;
6981
6982     case FFECOM_rttypeREAL_GNU_:
6983       ttype = float_type_node;
6984       break;
6985
6986     case FFECOM_rttypeCOMPLEX_F2C_:
6987       ttype = void_type_node;
6988       break;
6989
6990     case FFECOM_rttypeCOMPLEX_GNU_:
6991       ttype = ffecom_f2c_complex_type_node;
6992       break;
6993
6994     case FFECOM_rttypeDOUBLE_:
6995       ttype = double_type_node;
6996       break;
6997
6998     case FFECOM_rttypeDOUBLEREAL_:
6999       ttype = ffecom_f2c_doublereal_type_node;
7000       break;
7001
7002     case FFECOM_rttypeDBLCMPLX_F2C_:
7003       ttype = void_type_node;
7004       break;
7005
7006     case FFECOM_rttypeDBLCMPLX_GNU_:
7007       ttype = ffecom_f2c_doublecomplex_type_node;
7008       break;
7009
7010     case FFECOM_rttypeCHARACTER_:
7011       ttype = void_type_node;
7012       break;
7013
7014     default:
7015       ttype = NULL;
7016       assert ("bad rttype" == NULL);
7017       break;
7018     }
7019
7020   ttype = build_function_type (ttype, NULL_TREE);
7021   t = build_decl (FUNCTION_DECL,
7022                   get_identifier (ffecom_gfrt_name_[ix]),
7023                   ttype);
7024   DECL_EXTERNAL (t) = 1;
7025   TREE_READONLY (t) = ffecom_gfrt_const_[ix] ? 1 : 0;
7026   TREE_PUBLIC (t) = 1;
7027   TREE_THIS_VOLATILE (t) = ffecom_gfrt_volatile_[ix] ? 1 : 0;
7028
7029   /* Sanity check:  A function that's const cannot be volatile.  */
7030
7031   assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_volatile_[ix] : 1);
7032
7033   /* Sanity check: A function that's const cannot return complex.  */
7034
7035   assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_complex_[ix] : 1);
7036
7037   t = start_decl (t, TRUE);
7038
7039   finish_decl (t, NULL_TREE, TRUE);
7040
7041   ffecom_gfrt_[ix] = t;
7042 }
7043
7044 #endif
7045 /* Phase 1 pass over each member of a COMMON/EQUIVALENCE group.  */
7046
7047 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7048 static void
7049 ffecom_member_phase1_ (ffestorag mst UNUSED, ffestorag st)
7050 {
7051   ffesymbol s = ffestorag_symbol (st);
7052
7053   if (ffesymbol_namelisted (s))
7054     ffecom_member_namelisted_ = TRUE;
7055 }
7056
7057 #endif
7058 /* Phase 2 pass over each member of a COMMON/EQUIVALENCE group.  Declare
7059    the member so debugger will see it.  Otherwise nobody should be
7060    referencing the member.  */
7061
7062 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7063 static void
7064 ffecom_member_phase2_ (ffestorag mst, ffestorag st)
7065 {
7066   ffesymbol s;
7067   tree t;
7068   tree mt;
7069   tree type;
7070
7071   if ((mst == NULL)
7072       || ((mt = ffestorag_hook (mst)) == NULL)
7073       || (mt == error_mark_node))
7074     return;
7075
7076   if ((st == NULL)
7077       || ((s = ffestorag_symbol (st)) == NULL))
7078     return;
7079
7080   type = ffecom_type_localvar_ (s,
7081                                 ffesymbol_basictype (s),
7082                                 ffesymbol_kindtype (s));
7083   if (type == error_mark_node)
7084     return;
7085
7086   t = build_decl (VAR_DECL,
7087                   ffecom_get_identifier_ (ffesymbol_text (s)),
7088                   type);
7089
7090   TREE_STATIC (t) = TREE_STATIC (mt);
7091   DECL_INITIAL (t) = NULL_TREE;
7092   TREE_ASM_WRITTEN (t) = 1;
7093   TREE_USED (t) = 1;
7094
7095   DECL_RTL (t)
7096     = gen_rtx (MEM, TYPE_MODE (type),
7097                plus_constant (XEXP (DECL_RTL (mt), 0),
7098                               ffestorag_modulo (mst)
7099                               + ffestorag_offset (st)
7100                               - ffestorag_offset (mst)));
7101
7102   t = start_decl (t, FALSE);
7103
7104   finish_decl (t, NULL_TREE, FALSE);
7105 }
7106
7107 #endif
7108 /* Prepare source expression for assignment into a destination perhaps known
7109    to be of a specific size.  */
7110
7111 static void
7112 ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size, ffebld source)
7113 {
7114   ffecomConcatList_ catlist;
7115   int count;
7116   int i;
7117   tree ltmp;
7118   tree itmp;
7119   tree tempvar = NULL_TREE;
7120
7121   while (ffebld_op (source) == FFEBLD_opCONVERT)
7122     source = ffebld_left (source);
7123
7124   catlist = ffecom_concat_list_new_ (source, dest_size);
7125   count = ffecom_concat_list_count_ (catlist);
7126
7127   if (count >= 2)
7128     {
7129       ltmp
7130         = ffecom_make_tempvar ("let_char_len", ffecom_f2c_ftnlen_type_node,
7131                                FFETARGET_charactersizeNONE, count);
7132       itmp
7133         = ffecom_make_tempvar ("let_char_item", ffecom_f2c_address_type_node,
7134                                FFETARGET_charactersizeNONE, count);
7135
7136       tempvar = make_tree_vec (2);
7137       TREE_VEC_ELT (tempvar, 0) = ltmp;
7138       TREE_VEC_ELT (tempvar, 1) = itmp;
7139     }
7140
7141   for (i = 0; i < count; ++i)
7142     ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist, i));
7143
7144   ffecom_concat_list_kill_ (catlist);
7145
7146   if (tempvar)
7147     {
7148       ffebld_nonter_set_hook (source, tempvar);
7149       current_binding_level->prep_state = 1;
7150     }
7151 }
7152
7153 /* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order
7154
7155    Ignores STAR (alternate-return) dummies.  All other get exec-transitioned
7156    (which generates their trees) and then their trees get push_parm_decl'd.
7157
7158    The second arg is TRUE if the dummies are for a statement function, in
7159    which case lengths are not pushed for character arguments (since they are
7160    always known by both the caller and the callee, though the code allows
7161    for someday permitting CHAR*(*) stmtfunc dummies).  */
7162
7163 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7164 static void
7165 ffecom_push_dummy_decls_ (ffebld dummy_list, bool stmtfunc)
7166 {
7167   ffebld dummy;
7168   ffebld dumlist;
7169   ffesymbol s;
7170   tree parm;
7171
7172   ffecom_transform_only_dummies_ = TRUE;
7173
7174   /* First push the parms corresponding to actual dummy "contents".  */
7175
7176   for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7177     {
7178       dummy = ffebld_head (dumlist);
7179       switch (ffebld_op (dummy))
7180         {
7181         case FFEBLD_opSTAR:
7182         case FFEBLD_opANY:
7183           continue;             /* Forget alternate returns. */
7184
7185         default:
7186           break;
7187         }
7188       assert (ffebld_op (dummy) == FFEBLD_opSYMTER);
7189       s = ffebld_symter (dummy);
7190       parm = ffesymbol_hook (s).decl_tree;
7191       if (parm == NULL_TREE)
7192         {
7193           s = ffecom_sym_transform_ (s);
7194           parm = ffesymbol_hook (s).decl_tree;
7195           assert (parm != NULL_TREE);
7196         }
7197       if (parm != error_mark_node)
7198         push_parm_decl (parm);
7199     }
7200
7201   /* Then, for CHARACTER dummies, push the parms giving their lengths.  */
7202
7203   for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7204     {
7205       dummy = ffebld_head (dumlist);
7206       switch (ffebld_op (dummy))
7207         {
7208         case FFEBLD_opSTAR:
7209         case FFEBLD_opANY:
7210           continue;             /* Forget alternate returns, they mean
7211                                    NOTHING! */
7212
7213         default:
7214           break;
7215         }
7216       s = ffebld_symter (dummy);
7217       if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
7218         continue;               /* Only looking for CHARACTER arguments. */
7219       if (stmtfunc && (ffesymbol_size (s) != FFETARGET_charactersizeNONE))
7220         continue;               /* Stmtfunc arg with known size needs no
7221                                    length param. */
7222       if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
7223         continue;               /* Only looking for variables and arrays. */
7224       parm = ffesymbol_hook (s).length_tree;
7225       assert (parm != NULL_TREE);
7226       if (parm != error_mark_node)
7227         push_parm_decl (parm);
7228     }
7229
7230   ffecom_transform_only_dummies_ = FALSE;
7231 }
7232
7233 #endif
7234 /* ffecom_start_progunit_ -- Beginning of program unit
7235
7236    Does GNU back end stuff necessary to teach it about the start of its
7237    equivalent of a Fortran program unit.  */
7238
7239 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7240 static void
7241 ffecom_start_progunit_ ()
7242 {
7243   ffesymbol fn = ffecom_primary_entry_;
7244   ffebld arglist;
7245   tree id;                      /* Identifier (name) of function. */
7246   tree type;                    /* Type of function. */
7247   tree result;                  /* Result of function. */
7248   ffeinfoBasictype bt;
7249   ffeinfoKindtype kt;
7250   ffeglobal g;
7251   ffeglobalType gt;
7252   ffeglobalType egt = FFEGLOBAL_type;
7253   bool charfunc;
7254   bool cmplxfunc;
7255   bool altentries = (ffecom_num_entrypoints_ != 0);
7256   bool multi
7257   = altentries
7258   && (ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
7259   && (ffecom_master_bt_ == FFEINFO_basictypeNONE);
7260   bool main_program = FALSE;
7261   int old_lineno = lineno;
7262   const char *old_input_filename = input_filename;
7263
7264   assert (fn != NULL);
7265   assert (ffesymbol_hook (fn).decl_tree == NULL_TREE);
7266
7267   input_filename = ffesymbol_where_filename (fn);
7268   lineno = ffesymbol_where_filelinenum (fn);
7269
7270   switch (ffecom_primary_entry_kind_)
7271     {
7272     case FFEINFO_kindPROGRAM:
7273       main_program = TRUE;
7274       gt = FFEGLOBAL_typeMAIN;
7275       bt = FFEINFO_basictypeNONE;
7276       kt = FFEINFO_kindtypeNONE;
7277       type = ffecom_tree_fun_type_void;
7278       charfunc = FALSE;
7279       cmplxfunc = FALSE;
7280       break;
7281
7282     case FFEINFO_kindBLOCKDATA:
7283       gt = FFEGLOBAL_typeBDATA;
7284       bt = FFEINFO_basictypeNONE;
7285       kt = FFEINFO_kindtypeNONE;
7286       type = ffecom_tree_fun_type_void;
7287       charfunc = FALSE;
7288       cmplxfunc = FALSE;
7289       break;
7290
7291     case FFEINFO_kindFUNCTION:
7292       gt = FFEGLOBAL_typeFUNC;
7293       egt = FFEGLOBAL_typeEXT;
7294       bt = ffesymbol_basictype (fn);
7295       kt = ffesymbol_kindtype (fn);
7296       if (bt == FFEINFO_basictypeNONE)
7297         {
7298           ffeimplic_establish_symbol (fn);
7299           if (ffesymbol_funcresult (fn) != NULL)
7300             ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
7301           bt = ffesymbol_basictype (fn);
7302           kt = ffesymbol_kindtype (fn);
7303         }
7304
7305       if (multi)
7306         charfunc = cmplxfunc = FALSE;
7307       else if (bt == FFEINFO_basictypeCHARACTER)
7308         charfunc = TRUE, cmplxfunc = FALSE;
7309       else if ((bt == FFEINFO_basictypeCOMPLEX)
7310                && ffesymbol_is_f2c (fn)
7311                && !altentries)
7312         charfunc = FALSE, cmplxfunc = TRUE;
7313       else
7314         charfunc = cmplxfunc = FALSE;
7315
7316       if (multi || charfunc)
7317         type = ffecom_tree_fun_type_void;
7318       else if (ffesymbol_is_f2c (fn) && !altentries)
7319         type = ffecom_tree_fun_type[bt][kt];
7320       else
7321         type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
7322
7323       if ((type == NULL_TREE)
7324           || (TREE_TYPE (type) == NULL_TREE))
7325         type = ffecom_tree_fun_type_void;       /* _sym_exec_transition. */
7326       break;
7327
7328     case FFEINFO_kindSUBROUTINE:
7329       gt = FFEGLOBAL_typeSUBR;
7330       egt = FFEGLOBAL_typeEXT;
7331       bt = FFEINFO_basictypeNONE;
7332       kt = FFEINFO_kindtypeNONE;
7333       if (ffecom_is_altreturning_)
7334         type = ffecom_tree_subr_type;
7335       else
7336         type = ffecom_tree_fun_type_void;
7337       charfunc = FALSE;
7338       cmplxfunc = FALSE;
7339       break;
7340
7341     default:
7342       assert ("say what??" == NULL);
7343       /* Fall through. */
7344     case FFEINFO_kindANY:
7345       gt = FFEGLOBAL_typeANY;
7346       bt = FFEINFO_basictypeNONE;
7347       kt = FFEINFO_kindtypeNONE;
7348       type = error_mark_node;
7349       charfunc = FALSE;
7350       cmplxfunc = FALSE;
7351       break;
7352     }
7353
7354   if (altentries)
7355     {
7356       id = ffecom_get_invented_identifier ("__g77_masterfun_%s",
7357                                            ffesymbol_text (fn));
7358     }
7359 #if FFETARGET_isENFORCED_MAIN
7360   else if (main_program)
7361     id = get_identifier (FFETARGET_nameENFORCED_MAIN_NAME);
7362 #endif
7363   else
7364     id = ffecom_get_external_identifier_ (fn);
7365
7366   start_function (id,
7367                   type,
7368                   0,            /* nested/inline */
7369                   !altentries); /* TREE_PUBLIC */
7370
7371   TREE_USED (current_function_decl) = 1;        /* Avoid spurious warning if altentries. */
7372
7373   if (!altentries
7374       && ((g = ffesymbol_global (fn)) != NULL)
7375       && ((ffeglobal_type (g) == gt)
7376           || (ffeglobal_type (g) == egt)))
7377     {
7378       ffeglobal_set_hook (g, current_function_decl);
7379     }
7380
7381   /* Arg handling needs exec-transitioned ffesymbols to work with.  But
7382      exec-transitioning needs current_function_decl to be filled in.  So we
7383      do these things in two phases. */
7384
7385   if (altentries)
7386     {                           /* 1st arg identifies which entrypoint. */
7387       ffecom_which_entrypoint_decl_
7388         = build_decl (PARM_DECL,
7389                       ffecom_get_invented_identifier ("__g77_%s",
7390                                                       "which_entrypoint"),
7391                       integer_type_node);
7392       push_parm_decl (ffecom_which_entrypoint_decl_);
7393     }
7394
7395   if (charfunc
7396       || cmplxfunc
7397       || multi)
7398     {                           /* Arg for result (return value). */
7399       tree type;
7400       tree length;
7401
7402       if (charfunc)
7403         type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
7404       else if (cmplxfunc)
7405         type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
7406       else
7407         type = ffecom_multi_type_node_;
7408
7409       result = ffecom_get_invented_identifier ("__g77_%s", "result");
7410
7411       /* Make length arg _and_ enhance type info for CHAR arg itself.  */
7412
7413       if (charfunc)
7414         length = ffecom_char_enhance_arg_ (&type, fn);
7415       else
7416         length = NULL_TREE;     /* Not ref'd if !charfunc. */
7417
7418       type = build_pointer_type (type);
7419       result = build_decl (PARM_DECL, result, type);
7420
7421       push_parm_decl (result);
7422       if (multi)
7423         ffecom_multi_retval_ = result;
7424       else
7425         ffecom_func_result_ = result;
7426
7427       if (charfunc)
7428         {
7429           push_parm_decl (length);
7430           ffecom_func_length_ = length;
7431         }
7432     }
7433
7434   if (ffecom_primary_entry_is_proc_)
7435     {
7436       if (altentries)
7437         arglist = ffecom_master_arglist_;
7438       else
7439         arglist = ffesymbol_dummyargs (fn);
7440       ffecom_push_dummy_decls_ (arglist, FALSE);
7441     }
7442
7443   if (TREE_CODE (current_function_decl) != ERROR_MARK)
7444     store_parm_decls (main_program ? 1 : 0);
7445
7446   ffecom_start_compstmt ();
7447   /* Disallow temp vars at this level.  */
7448   current_binding_level->prep_state = 2;
7449
7450   lineno = old_lineno;
7451   input_filename = old_input_filename;
7452
7453   /* This handles any symbols still untransformed, in case -g specified.
7454      This used to be done in ffecom_finish_progunit, but it turns out to
7455      be necessary to do it here so that statement functions are
7456      expanded before code.  But don't bother for BLOCK DATA.  */
7457
7458   if (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
7459     ffesymbol_drive (ffecom_finish_symbol_transform_);
7460 }
7461
7462 #endif
7463 /* ffecom_sym_transform_ -- Transform FFE sym into backend sym
7464
7465    ffesymbol s;
7466    ffecom_sym_transform_(s);
7467
7468    The ffesymbol_hook info for s is updated with appropriate backend info
7469    on the symbol.  */
7470
7471 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7472 static ffesymbol
7473 ffecom_sym_transform_ (ffesymbol s)
7474 {
7475   tree t;                       /* Transformed thingy. */
7476   tree tlen;                    /* Length if CHAR*(*). */
7477   bool addr;                    /* Is t the address of the thingy? */
7478   ffeinfoBasictype bt;
7479   ffeinfoKindtype kt;
7480   ffeglobal g;
7481   int old_lineno = lineno;
7482   const char *old_input_filename = input_filename;
7483
7484   /* Must ensure special ASSIGN variables are declared at top of outermost
7485      block, else they'll end up in the innermost block when their first
7486      ASSIGN is seen, which leaves them out of scope when they're the
7487      subject of a GOTO or I/O statement.
7488
7489      We make this variable even if -fugly-assign.  Just let it go unused,
7490      in case it turns out there are cases where we really want to use this
7491      variable anyway (e.g. ASSIGN to INTEGER*2 variable).  */
7492
7493   if (! ffecom_transform_only_dummies_
7494       && ffesymbol_assigned (s)
7495       && ! ffesymbol_hook (s).assign_tree)
7496     s = ffecom_sym_transform_assign_ (s);
7497
7498   if (ffesymbol_sfdummyparent (s) == NULL)
7499     {
7500       input_filename = ffesymbol_where_filename (s);
7501       lineno = ffesymbol_where_filelinenum (s);
7502     }
7503   else
7504     {
7505       ffesymbol sf = ffesymbol_sfdummyparent (s);
7506
7507       input_filename = ffesymbol_where_filename (sf);
7508       lineno = ffesymbol_where_filelinenum (sf);
7509     }
7510
7511   bt = ffeinfo_basictype (ffebld_info (s));
7512   kt = ffeinfo_kindtype (ffebld_info (s));
7513
7514   t = NULL_TREE;
7515   tlen = NULL_TREE;
7516   addr = FALSE;
7517
7518   switch (ffesymbol_kind (s))
7519     {
7520     case FFEINFO_kindNONE:
7521       switch (ffesymbol_where (s))
7522         {
7523         case FFEINFO_whereDUMMY:        /* Subroutine or function. */
7524           assert (ffecom_transform_only_dummies_);
7525
7526           /* Before 0.4, this could be ENTITY/DUMMY, but see
7527              ffestu_sym_end_transition -- no longer true (in particular, if
7528              it could be an ENTITY, it _will_ be made one, so that
7529              possibility won't come through here).  So we never make length
7530              arg for CHARACTER type.  */
7531
7532           t = build_decl (PARM_DECL,
7533                           ffecom_get_identifier_ (ffesymbol_text (s)),
7534                           ffecom_tree_ptr_to_subr_type);
7535 #if BUILT_FOR_270
7536           DECL_ARTIFICIAL (t) = 1;
7537 #endif
7538           addr = TRUE;
7539           break;
7540
7541         case FFEINFO_whereGLOBAL:       /* Subroutine or function. */
7542           assert (!ffecom_transform_only_dummies_);
7543
7544           if (((g = ffesymbol_global (s)) != NULL)
7545               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7546                   || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7547                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
7548               && (ffeglobal_hook (g) != NULL_TREE)
7549               && ffe_is_globals ())
7550             {
7551               t = ffeglobal_hook (g);
7552               break;
7553             }
7554
7555           t = build_decl (FUNCTION_DECL,
7556                           ffecom_get_external_identifier_ (s),
7557                           ffecom_tree_subr_type);       /* Assume subr. */
7558           DECL_EXTERNAL (t) = 1;
7559           TREE_PUBLIC (t) = 1;
7560
7561           t = start_decl (t, FALSE);
7562           finish_decl (t, NULL_TREE, FALSE);
7563
7564           if ((g != NULL)
7565               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7566                   || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7567                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
7568             ffeglobal_set_hook (g, t);
7569
7570           ffecom_save_tree_forever (t);
7571
7572           break;
7573
7574         default:
7575           assert ("NONE where unexpected" == NULL);
7576           /* Fall through. */
7577         case FFEINFO_whereANY:
7578           break;
7579         }
7580       break;
7581
7582     case FFEINFO_kindENTITY:
7583       switch (ffeinfo_where (ffesymbol_info (s)))
7584         {
7585
7586         case FFEINFO_whereCONSTANT:
7587           /* ~~Debugging info needed? */
7588           assert (!ffecom_transform_only_dummies_);
7589           t = error_mark_node;  /* Shouldn't ever see this in expr. */
7590           break;
7591
7592         case FFEINFO_whereLOCAL:
7593           assert (!ffecom_transform_only_dummies_);
7594
7595           {
7596             ffestorag st = ffesymbol_storage (s);
7597             tree type;
7598
7599             if ((st != NULL)
7600                 && (ffestorag_size (st) == 0))
7601               {
7602                 t = error_mark_node;
7603                 break;
7604               }
7605
7606             type = ffecom_type_localvar_ (s, bt, kt);
7607
7608             if (type == error_mark_node)
7609               {
7610                 t = error_mark_node;
7611                 break;
7612               }
7613
7614             if ((st != NULL)
7615                 && (ffestorag_parent (st) != NULL))
7616               {                 /* Child of EQUIVALENCE parent. */
7617                 ffestorag est;
7618                 tree et;
7619                 ffetargetOffset offset;
7620
7621                 est = ffestorag_parent (st);
7622                 ffecom_transform_equiv_ (est);
7623
7624                 et = ffestorag_hook (est);
7625                 assert (et != NULL_TREE);
7626
7627                 if (! TREE_STATIC (et))
7628                   put_var_into_stack (et);
7629
7630                 offset = ffestorag_modulo (est)
7631                   + ffestorag_offset (ffesymbol_storage (s))
7632                   - ffestorag_offset (est);
7633
7634                 ffecom_debug_kludge_ (et, "EQUIVALENCE", s, type, offset);
7635
7636                 /* (t_type *) (((char *) &et) + offset) */
7637
7638                 t = convert (string_type_node,  /* (char *) */
7639                              ffecom_1 (ADDR_EXPR,
7640                                        build_pointer_type (TREE_TYPE (et)),
7641                                        et));
7642                 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
7643                               t,
7644                               build_int_2 (offset, 0));
7645                 t = convert (build_pointer_type (type),
7646                              t);
7647                 TREE_CONSTANT (t) = staticp (et);
7648
7649                 addr = TRUE;
7650               }
7651             else
7652               {
7653                 tree initexpr;
7654                 bool init = ffesymbol_is_init (s);
7655
7656                 t = build_decl (VAR_DECL,
7657                                 ffecom_get_identifier_ (ffesymbol_text (s)),
7658                                 type);
7659
7660                 if (init
7661                     || ffesymbol_namelisted (s)
7662 #ifdef FFECOM_sizeMAXSTACKITEM
7663                     || ((st != NULL)
7664                         && (ffestorag_size (st) > FFECOM_sizeMAXSTACKITEM))
7665 #endif
7666                     || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
7667                         && (ffecom_primary_entry_kind_
7668                             != FFEINFO_kindBLOCKDATA)
7669                         && (ffesymbol_is_save (s) || ffe_is_saveall ())))
7670                   TREE_STATIC (t) = !ffesymbol_attr (s, FFESYMBOL_attrADJUSTABLE);
7671                 else
7672                   TREE_STATIC (t) = 0;  /* No need to make static. */
7673
7674                 if (init || ffe_is_init_local_zero ())
7675                   DECL_INITIAL (t) = error_mark_node;
7676
7677                 /* Keep -Wunused from complaining about var if it
7678                    is used as sfunc arg or DATA implied-DO.  */
7679                 if (ffesymbol_attrs (s) & FFESYMBOL_attrsSFARG)
7680                   DECL_IN_SYSTEM_HEADER (t) = 1;
7681
7682                 t = start_decl (t, FALSE);
7683
7684                 if (init)
7685                   {
7686                     if (ffesymbol_init (s) != NULL)
7687                       initexpr = ffecom_expr (ffesymbol_init (s));
7688                     else
7689                       initexpr = ffecom_init_zero_ (t);
7690                   }
7691                 else if (ffe_is_init_local_zero ())
7692                   initexpr = ffecom_init_zero_ (t);
7693                 else
7694                   initexpr = NULL_TREE; /* Not ref'd if !init. */
7695
7696                 finish_decl (t, initexpr, FALSE);
7697
7698                 if (st != NULL && DECL_SIZE (t) != error_mark_node)
7699                   {
7700                     assert (TREE_CODE (DECL_SIZE_UNIT (t)) == INTEGER_CST);
7701                     assert (0 == compare_tree_int (DECL_SIZE_UNIT (t),
7702                                                    ffestorag_size (st)));
7703                   }
7704               }
7705           }
7706           break;
7707
7708         case FFEINFO_whereRESULT:
7709           assert (!ffecom_transform_only_dummies_);
7710
7711           if (bt == FFEINFO_basictypeCHARACTER)
7712             {                   /* Result is already in list of dummies, use
7713                                    it (& length). */
7714               t = ffecom_func_result_;
7715               tlen = ffecom_func_length_;
7716               addr = TRUE;
7717               break;
7718             }
7719           if ((ffecom_num_entrypoints_ == 0)
7720               && (bt == FFEINFO_basictypeCOMPLEX)
7721               && (ffesymbol_is_f2c (ffecom_primary_entry_)))
7722             {                   /* Result is already in list of dummies, use
7723                                    it. */
7724               t = ffecom_func_result_;
7725               addr = TRUE;
7726               break;
7727             }
7728           if (ffecom_func_result_ != NULL_TREE)
7729             {
7730               t = ffecom_func_result_;
7731               break;
7732             }
7733           if ((ffecom_num_entrypoints_ != 0)
7734               && (ffecom_master_bt_ == FFEINFO_basictypeNONE))
7735             {
7736               assert (ffecom_multi_retval_ != NULL_TREE);
7737               t = ffecom_1 (INDIRECT_REF, ffecom_multi_type_node_,
7738                             ffecom_multi_retval_);
7739               t = ffecom_2 (COMPONENT_REF, ffecom_tree_type[bt][kt],
7740                             t, ffecom_multi_fields_[bt][kt]);
7741
7742               break;
7743             }
7744
7745           t = build_decl (VAR_DECL,
7746                           ffecom_get_identifier_ (ffesymbol_text (s)),
7747                           ffecom_tree_type[bt][kt]);
7748           TREE_STATIC (t) = 0;  /* Put result on stack. */
7749           t = start_decl (t, FALSE);
7750           finish_decl (t, NULL_TREE, FALSE);
7751
7752           ffecom_func_result_ = t;
7753
7754           break;
7755
7756         case FFEINFO_whereDUMMY:
7757           {
7758             tree type;
7759             ffebld dl;
7760             ffebld dim;
7761             tree low;
7762             tree high;
7763             tree old_sizes;
7764             bool adjustable = FALSE;    /* Conditionally adjustable? */
7765
7766             type = ffecom_tree_type[bt][kt];
7767             if (ffesymbol_sfdummyparent (s) != NULL)
7768               {
7769                 if (current_function_decl == ffecom_outer_function_decl_)
7770                   {                     /* Exec transition before sfunc
7771                                            context; get it later. */
7772                     break;
7773                   }
7774                 t = ffecom_get_identifier_ (ffesymbol_text
7775                                             (ffesymbol_sfdummyparent (s)));
7776               }
7777             else
7778               t = ffecom_get_identifier_ (ffesymbol_text (s));
7779
7780             assert (ffecom_transform_only_dummies_);
7781
7782             old_sizes = get_pending_sizes ();
7783             put_pending_sizes (old_sizes);
7784
7785             if (bt == FFEINFO_basictypeCHARACTER)
7786               tlen = ffecom_char_enhance_arg_ (&type, s);
7787             type = ffecom_check_size_overflow_ (s, type, TRUE);
7788
7789             for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
7790               {
7791                 if (type == error_mark_node)
7792                   break;
7793
7794                 dim = ffebld_head (dl);
7795                 assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
7796                 if ((ffebld_left (dim) == NULL) || ffecom_doing_entry_)
7797                   low = ffecom_integer_one_node;
7798                 else
7799                   low = ffecom_expr (ffebld_left (dim));
7800                 assert (ffebld_right (dim) != NULL);
7801                 if ((ffebld_op (ffebld_right (dim)) == FFEBLD_opSTAR)
7802                     || ffecom_doing_entry_)
7803                   {
7804                     /* Used to just do high=low.  But for ffecom_tree_
7805                        canonize_ref_, it probably is important to correctly
7806                        assess the size.  E.g. given COMPLEX C(*),CFUNC and
7807                        C(2)=CFUNC(C), overlap can happen, while it can't
7808                        for, say, C(1)=CFUNC(C(2)).  */
7809                     /* Even more recently used to set to INT_MAX, but that
7810                        broke when some overflow checking went into the back
7811                        end.  Now we just leave the upper bound unspecified.  */
7812                     high = NULL;
7813                   }
7814                 else
7815                   high = ffecom_expr (ffebld_right (dim));
7816
7817                 /* Determine whether array is conditionally adjustable,
7818                    to decide whether back-end magic is needed.
7819
7820                    Normally the front end uses the back-end function
7821                    variable_size to wrap SAVE_EXPR's around expressions
7822                    affecting the size/shape of an array so that the
7823                    size/shape info doesn't change during execution
7824                    of the compiled code even though variables and
7825                    functions referenced in those expressions might.
7826
7827                    variable_size also makes sure those saved expressions
7828                    get evaluated immediately upon entry to the
7829                    compiled procedure -- the front end normally doesn't
7830                    have to worry about that.
7831
7832                    However, there is a problem with this that affects
7833                    g77's implementation of entry points, and that is
7834                    that it is _not_ true that each invocation of the
7835                    compiled procedure is permitted to evaluate
7836                    array size/shape info -- because it is possible
7837                    that, for some invocations, that info is invalid (in
7838                    which case it is "promised" -- i.e. a violation of
7839                    the Fortran standard -- that the compiled code
7840                    won't reference the array or its size/shape
7841                    during that particular invocation).
7842
7843                    To phrase this in C terms, consider this gcc function:
7844
7845                      void foo (int *n, float (*a)[*n])
7846                      {
7847                        // a is "pointer to array ...", fyi.
7848                      }
7849
7850                    Suppose that, for some invocations, it is permitted
7851                    for a caller of foo to do this:
7852
7853                        foo (NULL, NULL);
7854
7855                    Now the _written_ code for foo can take such a call
7856                    into account by either testing explicitly for whether
7857                    (a == NULL) || (n == NULL) -- presumably it is
7858                    not permitted to reference *a in various fashions
7859                    if (n == NULL) I suppose -- or it can avoid it by
7860                    looking at other info (other arguments, static/global
7861                    data, etc.).
7862
7863                    However, this won't work in gcc 2.5.8 because it'll
7864                    automatically emit the code to save the "*n"
7865                    expression, which'll yield a NULL dereference for
7866                    the "foo (NULL, NULL)" call, something the code
7867                    for foo cannot prevent.
7868
7869                    g77 definitely needs to avoid executing such
7870                    code anytime the pointer to the adjustable array
7871                    is NULL, because even if its bounds expressions
7872                    don't have any references to possible "absent"
7873                    variables like "*n" -- say all variable references
7874                    are to COMMON variables, i.e. global (though in C,
7875                    local static could actually make sense) -- the
7876                    expressions could yield other run-time problems
7877                    for allowably "dead" values in those variables.
7878
7879                    For example, let's consider a more complicated
7880                    version of foo:
7881
7882                      extern int i;
7883                      extern int j;
7884
7885                      void foo (float (*a)[i/j])
7886                      {
7887                        ...
7888                      }
7889
7890                    The above is (essentially) quite valid for Fortran
7891                    but, again, for a call like "foo (NULL);", it is
7892                    permitted for i and j to be undefined when the
7893                    call is made.  If j happened to be zero, for
7894                    example, emitting the code to evaluate "i/j"
7895                    could result in a run-time error.
7896
7897                    Offhand, though I don't have my F77 or F90
7898                    standards handy, it might even be valid for a
7899                    bounds expression to contain a function reference,
7900                    in which case I doubt it is permitted for an
7901                    implementation to invoke that function in the
7902                    Fortran case involved here (invocation of an
7903                    alternate ENTRY point that doesn't have the adjustable
7904                    array as one of its arguments).
7905
7906                    So, the code that the compiler would normally emit
7907                    to preevaluate the size/shape info for an
7908                    adjustable array _must not_ be executed at run time
7909                    in certain cases.  Specifically, for Fortran,
7910                    the case is when the pointer to the adjustable
7911                    array == NULL.  (For gnu-ish C, it might be nice
7912                    for the source code itself to specify an expression
7913                    that, if TRUE, inhibits execution of the code.  Or
7914                    reverse the sense for elegance.)
7915
7916                    (Note that g77 could use a different test than NULL,
7917                    actually, since it happens to always pass an
7918                    integer to the called function that specifies which
7919                    entry point is being invoked.  Hmm, this might
7920                    solve the next problem.)
7921
7922                    One way a user could, I suppose, write "foo" so
7923                    it works is to insert COND_EXPR's for the
7924                    size/shape info so the dangerous stuff isn't
7925                    actually done, as in:
7926
7927                      void foo (int *n, float (*a)[(a == NULL) ? 0 : *n])
7928                      {
7929                        ...
7930                      }
7931
7932                    The next problem is that the front end needs to
7933                    be able to tell the back end about the array's
7934                    decl _before_ it tells it about the conditional
7935                    expression to inhibit evaluation of size/shape info,
7936                    as shown above.
7937
7938                    To solve this, the front end needs to be able
7939                    to give the back end the expression to inhibit
7940                    generation of the preevaluation code _after_
7941                    it makes the decl for the adjustable array.
7942
7943                    Until then, the above example using the COND_EXPR
7944                    doesn't pass muster with gcc because the "(a == NULL)"
7945                    part has a reference to "a", which is still
7946                    undefined at that point.
7947
7948                    g77 will therefore use a different mechanism in the
7949                    meantime.  */
7950
7951                 if (!adjustable
7952                     && ((TREE_CODE (low) != INTEGER_CST)
7953                         || (high && TREE_CODE (high) != INTEGER_CST)))
7954                   adjustable = TRUE;
7955
7956 #if 0                           /* Old approach -- see below. */
7957                 if (TREE_CODE (low) != INTEGER_CST)
7958                   low = ffecom_3 (COND_EXPR, integer_type_node,
7959                                   ffecom_adjarray_passed_ (s),
7960                                   low,
7961                                   ffecom_integer_zero_node);
7962
7963                 if (high && TREE_CODE (high) != INTEGER_CST)
7964                   high = ffecom_3 (COND_EXPR, integer_type_node,
7965                                    ffecom_adjarray_passed_ (s),
7966                                    high,
7967                                    ffecom_integer_zero_node);
7968 #endif
7969
7970                 /* ~~~gcc/stor-layout.c (layout_type) should do this,
7971                    probably.  Fixes 950302-1.f.  */
7972
7973                 if (TREE_CODE (low) != INTEGER_CST)
7974                   low = variable_size (low);
7975
7976                 /* ~~~Similarly, this fixes dumb0.f.  The C front end
7977                    does this, which is why dumb0.c would work.  */
7978
7979                 if (high && TREE_CODE (high) != INTEGER_CST)
7980                   high = variable_size (high);
7981
7982                 type
7983                   = build_array_type
7984                     (type,
7985                      build_range_type (ffecom_integer_type_node,
7986                                        low, high));
7987                 type = ffecom_check_size_overflow_ (s, type, TRUE);
7988               }
7989
7990             if (type == error_mark_node)
7991               {
7992                 t = error_mark_node;
7993                 break;
7994               }
7995
7996             if ((ffesymbol_sfdummyparent (s) == NULL)
7997                  || (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER))
7998               {
7999                 type = build_pointer_type (type);
8000                 addr = TRUE;
8001               }
8002
8003             t = build_decl (PARM_DECL, t, type);
8004 #if BUILT_FOR_270
8005             DECL_ARTIFICIAL (t) = 1;
8006 #endif
8007
8008             /* If this arg is present in every entry point's list of
8009                dummy args, then we're done.  */
8010
8011             if (ffesymbol_numentries (s)
8012                 == (ffecom_num_entrypoints_ + 1))
8013               break;
8014
8015 #if 1
8016
8017             /* If variable_size in stor-layout has been called during
8018                the above, then get_pending_sizes should have the
8019                yet-to-be-evaluated saved expressions pending.
8020                Make the whole lot of them get emitted, conditionally
8021                on whether the array decl ("t" above) is not NULL.  */
8022
8023             {
8024               tree sizes = get_pending_sizes ();
8025               tree tem;
8026
8027               for (tem = sizes;
8028                    tem != old_sizes;
8029                    tem = TREE_CHAIN (tem))
8030                 {
8031                   tree temv = TREE_VALUE (tem);
8032
8033                   if (sizes == tem)
8034                     sizes = temv;
8035                   else
8036                     sizes
8037                       = ffecom_2 (COMPOUND_EXPR,
8038                                   TREE_TYPE (sizes),
8039                                   temv,
8040                                   sizes);
8041                 }
8042
8043               if (sizes != tem)
8044                 {
8045                   sizes
8046                     = ffecom_3 (COND_EXPR,
8047                                 TREE_TYPE (sizes),
8048                                 ffecom_2 (NE_EXPR,
8049                                           integer_type_node,
8050                                           t,
8051                                           null_pointer_node),
8052                                 sizes,
8053                                 convert (TREE_TYPE (sizes),
8054                                          integer_zero_node));
8055                   sizes = ffecom_save_tree (sizes);
8056
8057                   sizes
8058                     = tree_cons (NULL_TREE, sizes, tem);
8059                 }
8060
8061               if (sizes)
8062                 put_pending_sizes (sizes);
8063             }
8064
8065 #else
8066 #if 0
8067             if (adjustable
8068                 && (ffesymbol_numentries (s)
8069                     != ffecom_num_entrypoints_ + 1))
8070               DECL_SOMETHING (t)
8071                 = ffecom_2 (NE_EXPR, integer_type_node,
8072                             t,
8073                             null_pointer_node);
8074 #else
8075 #if 0
8076             if (adjustable
8077                 && (ffesymbol_numentries (s)
8078                     != ffecom_num_entrypoints_ + 1))
8079               {
8080                 ffebad_start (FFEBAD_MISSING_ADJARRAY_UNSUPPORTED);
8081                 ffebad_here (0, ffesymbol_where_line (s),
8082                              ffesymbol_where_column (s));
8083                 ffebad_string (ffesymbol_text (s));
8084                 ffebad_finish ();
8085               }
8086 #endif
8087 #endif
8088 #endif
8089           }
8090           break;
8091
8092         case FFEINFO_whereCOMMON:
8093           {
8094             ffesymbol cs;
8095             ffeglobal cg;
8096             tree ct;
8097             ffestorag st = ffesymbol_storage (s);
8098             tree type;
8099
8100             cs = ffesymbol_common (s);  /* The COMMON area itself.  */
8101             if (st != NULL)     /* Else not laid out. */
8102               {
8103                 ffecom_transform_common_ (cs);
8104                 st = ffesymbol_storage (s);
8105               }
8106
8107             type = ffecom_type_localvar_ (s, bt, kt);
8108
8109             cg = ffesymbol_global (cs); /* The global COMMON info.  */
8110             if ((cg == NULL)
8111                 || (ffeglobal_type (cg) != FFEGLOBAL_typeCOMMON))
8112               ct = NULL_TREE;
8113             else
8114               ct = ffeglobal_hook (cg); /* The common area's tree.  */
8115
8116             if ((ct == NULL_TREE)
8117                 || (st == NULL)
8118                 || (type == error_mark_node))
8119               t = error_mark_node;
8120             else
8121               {
8122                 ffetargetOffset offset;
8123                 ffestorag cst;
8124
8125                 cst = ffestorag_parent (st);
8126                 assert (cst == ffesymbol_storage (cs));
8127
8128                 offset = ffestorag_modulo (cst)
8129                   + ffestorag_offset (st)
8130                   - ffestorag_offset (cst);
8131
8132                 ffecom_debug_kludge_ (ct, "COMMON", s, type, offset);
8133
8134                 /* (t_type *) (((char *) &ct) + offset) */
8135
8136                 t = convert (string_type_node,  /* (char *) */
8137                              ffecom_1 (ADDR_EXPR,
8138                                        build_pointer_type (TREE_TYPE (ct)),
8139                                        ct));
8140                 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
8141                               t,
8142                               build_int_2 (offset, 0));
8143                 t = convert (build_pointer_type (type),
8144                              t);
8145                 TREE_CONSTANT (t) = 1;
8146
8147                 addr = TRUE;
8148               }
8149           }
8150           break;
8151
8152         case FFEINFO_whereIMMEDIATE:
8153         case FFEINFO_whereGLOBAL:
8154         case FFEINFO_whereFLEETING:
8155         case FFEINFO_whereFLEETING_CADDR:
8156         case FFEINFO_whereFLEETING_IADDR:
8157         case FFEINFO_whereINTRINSIC:
8158         case FFEINFO_whereCONSTANT_SUBOBJECT:
8159         default:
8160           assert ("ENTITY where unheard of" == NULL);
8161           /* Fall through. */
8162         case FFEINFO_whereANY:
8163           t = error_mark_node;
8164           break;
8165         }
8166       break;
8167
8168     case FFEINFO_kindFUNCTION:
8169       switch (ffeinfo_where (ffesymbol_info (s)))
8170         {
8171         case FFEINFO_whereLOCAL:        /* Me. */
8172           assert (!ffecom_transform_only_dummies_);
8173           t = current_function_decl;
8174           break;
8175
8176         case FFEINFO_whereGLOBAL:
8177           assert (!ffecom_transform_only_dummies_);
8178
8179           if (((g = ffesymbol_global (s)) != NULL)
8180               && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8181                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8182               && (ffeglobal_hook (g) != NULL_TREE)
8183               && ffe_is_globals ())
8184             {
8185               t = ffeglobal_hook (g);
8186               break;
8187             }
8188
8189           if (ffesymbol_is_f2c (s)
8190               && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8191             t = ffecom_tree_fun_type[bt][kt];
8192           else
8193             t = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
8194
8195           t = build_decl (FUNCTION_DECL,
8196                           ffecom_get_external_identifier_ (s),
8197                           t);
8198           DECL_EXTERNAL (t) = 1;
8199           TREE_PUBLIC (t) = 1;
8200
8201           t = start_decl (t, FALSE);
8202           finish_decl (t, NULL_TREE, FALSE);
8203
8204           if ((g != NULL)
8205               && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8206                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8207             ffeglobal_set_hook (g, t);
8208
8209           ffecom_save_tree_forever (t);
8210
8211           break;
8212
8213         case FFEINFO_whereDUMMY:
8214           assert (ffecom_transform_only_dummies_);
8215
8216           if (ffesymbol_is_f2c (s)
8217               && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8218             t = ffecom_tree_ptr_to_fun_type[bt][kt];
8219           else
8220             t = build_pointer_type
8221               (build_function_type (ffecom_tree_type[bt][kt], NULL_TREE));
8222
8223           t = build_decl (PARM_DECL,
8224                           ffecom_get_identifier_ (ffesymbol_text (s)),
8225                           t);
8226 #if BUILT_FOR_270
8227           DECL_ARTIFICIAL (t) = 1;
8228 #endif
8229           addr = TRUE;
8230           break;
8231
8232         case FFEINFO_whereCONSTANT:     /* Statement function. */
8233           assert (!ffecom_transform_only_dummies_);
8234           t = ffecom_gen_sfuncdef_ (s, bt, kt);
8235           break;
8236
8237         case FFEINFO_whereINTRINSIC:
8238           assert (!ffecom_transform_only_dummies_);
8239           break;                /* Let actual references generate their
8240                                    decls. */
8241
8242         default:
8243           assert ("FUNCTION where unheard of" == NULL);
8244           /* Fall through. */
8245         case FFEINFO_whereANY:
8246           t = error_mark_node;
8247           break;
8248         }
8249       break;
8250
8251     case FFEINFO_kindSUBROUTINE:
8252       switch (ffeinfo_where (ffesymbol_info (s)))
8253         {
8254         case FFEINFO_whereLOCAL:        /* Me. */
8255           assert (!ffecom_transform_only_dummies_);
8256           t = current_function_decl;
8257           break;
8258
8259         case FFEINFO_whereGLOBAL:
8260           assert (!ffecom_transform_only_dummies_);
8261
8262           if (((g = ffesymbol_global (s)) != NULL)
8263               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8264                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8265               && (ffeglobal_hook (g) != NULL_TREE)
8266               && ffe_is_globals ())
8267             {
8268               t = ffeglobal_hook (g);
8269               break;
8270             }
8271
8272           t = build_decl (FUNCTION_DECL,
8273                           ffecom_get_external_identifier_ (s),
8274                           ffecom_tree_subr_type);
8275           DECL_EXTERNAL (t) = 1;
8276           TREE_PUBLIC (t) = 1;
8277
8278           t = start_decl (t, FALSE);
8279           finish_decl (t, NULL_TREE, FALSE);
8280
8281           if ((g != NULL)
8282               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8283                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8284             ffeglobal_set_hook (g, t);
8285
8286           ffecom_save_tree_forever (t);
8287
8288           break;
8289
8290         case FFEINFO_whereDUMMY:
8291           assert (ffecom_transform_only_dummies_);
8292
8293           t = build_decl (PARM_DECL,
8294                           ffecom_get_identifier_ (ffesymbol_text (s)),
8295                           ffecom_tree_ptr_to_subr_type);
8296 #if BUILT_FOR_270
8297           DECL_ARTIFICIAL (t) = 1;
8298 #endif
8299           addr = TRUE;
8300           break;
8301
8302         case FFEINFO_whereINTRINSIC:
8303           assert (!ffecom_transform_only_dummies_);
8304           break;                /* Let actual references generate their
8305                                    decls. */
8306
8307         default:
8308           assert ("SUBROUTINE where unheard of" == NULL);
8309           /* Fall through. */
8310         case FFEINFO_whereANY:
8311           t = error_mark_node;
8312           break;
8313         }
8314       break;
8315
8316     case FFEINFO_kindPROGRAM:
8317       switch (ffeinfo_where (ffesymbol_info (s)))
8318         {
8319         case FFEINFO_whereLOCAL:        /* Me. */
8320           assert (!ffecom_transform_only_dummies_);
8321           t = current_function_decl;
8322           break;
8323
8324         case FFEINFO_whereCOMMON:
8325         case FFEINFO_whereDUMMY:
8326         case FFEINFO_whereGLOBAL:
8327         case FFEINFO_whereRESULT:
8328         case FFEINFO_whereFLEETING:
8329         case FFEINFO_whereFLEETING_CADDR:
8330         case FFEINFO_whereFLEETING_IADDR:
8331         case FFEINFO_whereIMMEDIATE:
8332         case FFEINFO_whereINTRINSIC:
8333         case FFEINFO_whereCONSTANT:
8334         case FFEINFO_whereCONSTANT_SUBOBJECT:
8335         default:
8336           assert ("PROGRAM where unheard of" == NULL);
8337           /* Fall through. */
8338         case FFEINFO_whereANY:
8339           t = error_mark_node;
8340           break;
8341         }
8342       break;
8343
8344     case FFEINFO_kindBLOCKDATA:
8345       switch (ffeinfo_where (ffesymbol_info (s)))
8346         {
8347         case FFEINFO_whereLOCAL:        /* Me. */
8348           assert (!ffecom_transform_only_dummies_);
8349           t = current_function_decl;
8350           break;
8351
8352         case FFEINFO_whereGLOBAL:
8353           assert (!ffecom_transform_only_dummies_);
8354
8355           t = build_decl (FUNCTION_DECL,
8356                           ffecom_get_external_identifier_ (s),
8357                           ffecom_tree_blockdata_type);
8358           DECL_EXTERNAL (t) = 1;
8359           TREE_PUBLIC (t) = 1;
8360
8361           t = start_decl (t, FALSE);
8362           finish_decl (t, NULL_TREE, FALSE);
8363
8364           ffecom_save_tree_forever (t);
8365
8366           break;
8367
8368         case FFEINFO_whereCOMMON:
8369         case FFEINFO_whereDUMMY:
8370         case FFEINFO_whereRESULT:
8371         case FFEINFO_whereFLEETING:
8372         case FFEINFO_whereFLEETING_CADDR:
8373         case FFEINFO_whereFLEETING_IADDR:
8374         case FFEINFO_whereIMMEDIATE:
8375         case FFEINFO_whereINTRINSIC:
8376         case FFEINFO_whereCONSTANT:
8377         case FFEINFO_whereCONSTANT_SUBOBJECT:
8378         default:
8379           assert ("BLOCKDATA where unheard of" == NULL);
8380           /* Fall through. */
8381         case FFEINFO_whereANY:
8382           t = error_mark_node;
8383           break;
8384         }
8385       break;
8386
8387     case FFEINFO_kindCOMMON:
8388       switch (ffeinfo_where (ffesymbol_info (s)))
8389         {
8390         case FFEINFO_whereLOCAL:
8391           assert (!ffecom_transform_only_dummies_);
8392           ffecom_transform_common_ (s);
8393           break;
8394
8395         case FFEINFO_whereNONE:
8396         case FFEINFO_whereCOMMON:
8397         case FFEINFO_whereDUMMY:
8398         case FFEINFO_whereGLOBAL:
8399         case FFEINFO_whereRESULT:
8400         case FFEINFO_whereFLEETING:
8401         case FFEINFO_whereFLEETING_CADDR:
8402         case FFEINFO_whereFLEETING_IADDR:
8403         case FFEINFO_whereIMMEDIATE:
8404         case FFEINFO_whereINTRINSIC:
8405         case FFEINFO_whereCONSTANT:
8406         case FFEINFO_whereCONSTANT_SUBOBJECT:
8407         default:
8408           assert ("COMMON where unheard of" == NULL);
8409           /* Fall through. */
8410         case FFEINFO_whereANY:
8411           t = error_mark_node;
8412           break;
8413         }
8414       break;
8415
8416     case FFEINFO_kindCONSTRUCT:
8417       switch (ffeinfo_where (ffesymbol_info (s)))
8418         {
8419         case FFEINFO_whereLOCAL:
8420           assert (!ffecom_transform_only_dummies_);
8421           break;
8422
8423         case FFEINFO_whereNONE:
8424         case FFEINFO_whereCOMMON:
8425         case FFEINFO_whereDUMMY:
8426         case FFEINFO_whereGLOBAL:
8427         case FFEINFO_whereRESULT:
8428         case FFEINFO_whereFLEETING:
8429         case FFEINFO_whereFLEETING_CADDR:
8430         case FFEINFO_whereFLEETING_IADDR:
8431         case FFEINFO_whereIMMEDIATE:
8432         case FFEINFO_whereINTRINSIC:
8433         case FFEINFO_whereCONSTANT:
8434         case FFEINFO_whereCONSTANT_SUBOBJECT:
8435         default:
8436           assert ("CONSTRUCT where unheard of" == NULL);
8437           /* Fall through. */
8438         case FFEINFO_whereANY:
8439           t = error_mark_node;
8440           break;
8441         }
8442       break;
8443
8444     case FFEINFO_kindNAMELIST:
8445       switch (ffeinfo_where (ffesymbol_info (s)))
8446         {
8447         case FFEINFO_whereLOCAL:
8448           assert (!ffecom_transform_only_dummies_);
8449           t = ffecom_transform_namelist_ (s);
8450           break;
8451
8452         case FFEINFO_whereNONE:
8453         case FFEINFO_whereCOMMON:
8454         case FFEINFO_whereDUMMY:
8455         case FFEINFO_whereGLOBAL:
8456         case FFEINFO_whereRESULT:
8457         case FFEINFO_whereFLEETING:
8458         case FFEINFO_whereFLEETING_CADDR:
8459         case FFEINFO_whereFLEETING_IADDR:
8460         case FFEINFO_whereIMMEDIATE:
8461         case FFEINFO_whereINTRINSIC:
8462         case FFEINFO_whereCONSTANT:
8463         case FFEINFO_whereCONSTANT_SUBOBJECT:
8464         default:
8465           assert ("NAMELIST where unheard of" == NULL);
8466           /* Fall through. */
8467         case FFEINFO_whereANY:
8468           t = error_mark_node;
8469           break;
8470         }
8471       break;
8472
8473     default:
8474       assert ("kind unheard of" == NULL);
8475       /* Fall through. */
8476     case FFEINFO_kindANY:
8477       t = error_mark_node;
8478       break;
8479     }
8480
8481   ffesymbol_hook (s).decl_tree = t;
8482   ffesymbol_hook (s).length_tree = tlen;
8483   ffesymbol_hook (s).addr = addr;
8484
8485   lineno = old_lineno;
8486   input_filename = old_input_filename;
8487
8488   return s;
8489 }
8490
8491 #endif
8492 /* Transform into ASSIGNable symbol.
8493
8494    Symbol has already been transformed, but for whatever reason, the
8495    resulting decl_tree has been deemed not usable for an ASSIGN target.
8496    (E.g. it isn't wide enough to hold a pointer.)  So, here we invent
8497    another local symbol of type void * and stuff that in the assign_tree
8498    argument.  The F77/F90 standards allow this implementation.  */
8499
8500 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8501 static ffesymbol
8502 ffecom_sym_transform_assign_ (ffesymbol s)
8503 {
8504   tree t;                       /* Transformed thingy. */
8505   int old_lineno = lineno;
8506   const char *old_input_filename = input_filename;
8507
8508   if (ffesymbol_sfdummyparent (s) == NULL)
8509     {
8510       input_filename = ffesymbol_where_filename (s);
8511       lineno = ffesymbol_where_filelinenum (s);
8512     }
8513   else
8514     {
8515       ffesymbol sf = ffesymbol_sfdummyparent (s);
8516
8517       input_filename = ffesymbol_where_filename (sf);
8518       lineno = ffesymbol_where_filelinenum (sf);
8519     }
8520
8521   assert (!ffecom_transform_only_dummies_);
8522
8523   t = build_decl (VAR_DECL,
8524                   ffecom_get_invented_identifier ("__g77_ASSIGN_%s",
8525                                                    ffesymbol_text (s)),
8526                   TREE_TYPE (null_pointer_node));
8527
8528   switch (ffesymbol_where (s))
8529     {
8530     case FFEINFO_whereLOCAL:
8531       /* Unlike for regular vars, SAVE status is easy to determine for
8532          ASSIGNed vars, since there's no initialization, there's no
8533          effective storage association (so "SAVE J" does not apply to
8534          K even given "EQUIVALENCE (J,K)"), there's no size issue
8535          to worry about, etc.  */
8536       if ((ffesymbol_is_save (s) || ffe_is_saveall ())
8537           && (ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8538           && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA))
8539         TREE_STATIC (t) = 1;    /* SAVEd in proc, make static. */
8540       else
8541         TREE_STATIC (t) = 0;    /* No need to make static. */
8542       break;
8543
8544     case FFEINFO_whereCOMMON:
8545       TREE_STATIC (t) = 1;      /* Assume COMMONs always SAVEd. */
8546       break;
8547
8548     case FFEINFO_whereDUMMY:
8549       /* Note that twinning a DUMMY means the caller won't see
8550          the ASSIGNed value.  But both F77 and F90 allow implementations
8551          to do this, i.e. disallow Fortran code that would try and
8552          take advantage of actually putting a label into a variable
8553          via a dummy argument (or any other storage association, for
8554          that matter).  */
8555       TREE_STATIC (t) = 0;
8556       break;
8557
8558     default:
8559       TREE_STATIC (t) = 0;
8560       break;
8561     }
8562
8563   t = start_decl (t, FALSE);
8564   finish_decl (t, NULL_TREE, FALSE);
8565
8566   ffesymbol_hook (s).assign_tree = t;
8567
8568   lineno = old_lineno;
8569   input_filename = old_input_filename;
8570
8571   return s;
8572 }
8573
8574 #endif
8575 /* Implement COMMON area in back end.
8576
8577    Because COMMON-based variables can be referenced in the dimension
8578    expressions of dummy (adjustable) arrays, and because dummies
8579    (in the gcc back end) need to be put in the outer binding level
8580    of a function (which has two binding levels, the outer holding
8581    the dummies and the inner holding the other vars), special care
8582    must be taken to handle COMMON areas.
8583
8584    The current strategy is basically to always tell the back end about
8585    the COMMON area as a top-level external reference to just a block
8586    of storage of the master type of that area (e.g. integer, real,
8587    character, whatever -- not a structure).  As a distinct action,
8588    if initial values are provided, tell the back end about the area
8589    as a top-level non-external (initialized) area and remember not to
8590    allow further initialization or expansion of the area.  Meanwhile,
8591    if no initialization happens at all, tell the back end about
8592    the largest size we've seen declared so the space does get reserved.
8593    (This function doesn't handle all that stuff, but it does some
8594    of the important things.)
8595
8596    Meanwhile, for COMMON variables themselves, just keep creating
8597    references like *((float *) (&common_area + offset)) each time
8598    we reference the variable.  In other words, don't make a VAR_DECL
8599    or any kind of component reference (like we used to do before 0.4),
8600    though we might do that as well just for debugging purposes (and
8601    stuff the rtl with the appropriate offset expression).  */
8602
8603 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8604 static void
8605 ffecom_transform_common_ (ffesymbol s)
8606 {
8607   ffestorag st = ffesymbol_storage (s);
8608   ffeglobal g = ffesymbol_global (s);
8609   tree cbt;
8610   tree cbtype;
8611   tree init;
8612   tree high;
8613   bool is_init = ffestorag_is_init (st);
8614
8615   assert (st != NULL);
8616
8617   if ((g == NULL)
8618       || (ffeglobal_type (g) != FFEGLOBAL_typeCOMMON))
8619     return;
8620
8621   /* First update the size of the area in global terms.  */
8622
8623   ffeglobal_size_common (s, ffestorag_size (st));
8624
8625   if (!ffeglobal_common_init (g))
8626     is_init = FALSE;    /* No explicit init, don't let erroneous joins init. */
8627
8628   cbt = ffeglobal_hook (g);
8629
8630   /* If we already have declared this common block for a previous program
8631      unit, and either we already initialized it or we don't have new
8632      initialization for it, just return what we have without changing it.  */
8633
8634   if ((cbt != NULL_TREE)
8635       && (!is_init
8636           || !DECL_EXTERNAL (cbt)))
8637     {
8638       if (st->hook == NULL) ffestorag_set_hook (st, cbt);
8639       return;
8640     }
8641
8642   /* Process inits.  */
8643
8644   if (is_init)
8645     {
8646       if (ffestorag_init (st) != NULL)
8647         {
8648           ffebld sexp;
8649
8650           /* Set the padding for the expression, so ffecom_expr
8651              knows to insert that many zeros.  */
8652           switch (ffebld_op (sexp = ffestorag_init (st)))
8653             {
8654             case FFEBLD_opCONTER:
8655               ffebld_conter_set_pad (sexp, ffestorag_modulo (st));
8656               break;
8657
8658             case FFEBLD_opARRTER:
8659               ffebld_arrter_set_pad (sexp, ffestorag_modulo (st));
8660               break;
8661
8662             case FFEBLD_opACCTER:
8663               ffebld_accter_set_pad (sexp, ffestorag_modulo (st));
8664               break;
8665
8666             default:
8667               assert ("bad op for cmn init (pad)" == NULL);
8668               break;
8669             }
8670
8671           init = ffecom_expr (sexp);
8672           if (init == error_mark_node)
8673             {                   /* Hopefully the back end complained! */
8674               init = NULL_TREE;
8675               if (cbt != NULL_TREE)
8676                 return;
8677             }
8678         }
8679       else
8680         init = error_mark_node;
8681     }
8682   else
8683     init = NULL_TREE;
8684
8685   /* cbtype must be permanently allocated!  */
8686
8687   /* Allocate the MAX of the areas so far, seen filewide.  */
8688   high = build_int_2 ((ffeglobal_common_size (g)
8689                        + ffeglobal_common_pad (g)) - 1, 0);
8690   TREE_TYPE (high) = ffecom_integer_type_node;
8691
8692   if (init)
8693     cbtype = build_array_type (char_type_node,
8694                                build_range_type (integer_type_node,
8695                                                  integer_zero_node,
8696                                                  high));
8697   else
8698     cbtype = build_array_type (char_type_node, NULL_TREE);
8699
8700   if (cbt == NULL_TREE)
8701     {
8702       cbt
8703         = build_decl (VAR_DECL,
8704                       ffecom_get_external_identifier_ (s),
8705                       cbtype);
8706       TREE_STATIC (cbt) = 1;
8707       TREE_PUBLIC (cbt) = 1;
8708     }
8709   else
8710     {
8711       assert (is_init);
8712       TREE_TYPE (cbt) = cbtype;
8713     }
8714   DECL_EXTERNAL (cbt) = init ? 0 : 1;
8715   DECL_INITIAL (cbt) = init ? error_mark_node : NULL_TREE;
8716
8717   cbt = start_decl (cbt, TRUE);
8718   if (ffeglobal_hook (g) != NULL)
8719     assert (cbt == ffeglobal_hook (g));
8720
8721   assert (!init || !DECL_EXTERNAL (cbt));
8722
8723   /* Make sure that any type can live in COMMON and be referenced
8724      without getting a bus error.  We could pick the most restrictive
8725      alignment of all entities actually placed in the COMMON, but
8726      this seems easy enough.  */
8727
8728   DECL_ALIGN (cbt) = BIGGEST_ALIGNMENT;
8729   DECL_USER_ALIGN (cbt) = 0;
8730
8731   if (is_init && (ffestorag_init (st) == NULL))
8732     init = ffecom_init_zero_ (cbt);
8733
8734   finish_decl (cbt, init, TRUE);
8735
8736   if (is_init)
8737     ffestorag_set_init (st, ffebld_new_any ());
8738
8739   if (init)
8740     {
8741       assert (DECL_SIZE_UNIT (cbt) != NULL_TREE);
8742       assert (TREE_CODE (DECL_SIZE_UNIT (cbt)) == INTEGER_CST);
8743       assert (0 == compare_tree_int (DECL_SIZE_UNIT (cbt),
8744                                      (ffeglobal_common_size (g)
8745                                       + ffeglobal_common_pad (g))));
8746     }
8747
8748   ffeglobal_set_hook (g, cbt);
8749
8750   ffestorag_set_hook (st, cbt);
8751
8752   ffecom_save_tree_forever (cbt);
8753 }
8754
8755 #endif
8756 /* Make master area for local EQUIVALENCE.  */
8757
8758 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8759 static void
8760 ffecom_transform_equiv_ (ffestorag eqst)
8761 {
8762   tree eqt;
8763   tree eqtype;
8764   tree init;
8765   tree high;
8766   bool is_init = ffestorag_is_init (eqst);
8767
8768   assert (eqst != NULL);
8769
8770   eqt = ffestorag_hook (eqst);
8771
8772   if (eqt != NULL_TREE)
8773     return;
8774
8775   /* Process inits.  */
8776
8777   if (is_init)
8778     {
8779       if (ffestorag_init (eqst) != NULL)
8780         {
8781           ffebld sexp;
8782
8783           /* Set the padding for the expression, so ffecom_expr
8784              knows to insert that many zeros.  */
8785           switch (ffebld_op (sexp = ffestorag_init (eqst)))
8786             {
8787             case FFEBLD_opCONTER:
8788               ffebld_conter_set_pad (sexp, ffestorag_modulo (eqst));
8789               break;
8790
8791             case FFEBLD_opARRTER:
8792               ffebld_arrter_set_pad (sexp, ffestorag_modulo (eqst));
8793               break;
8794
8795             case FFEBLD_opACCTER:
8796               ffebld_accter_set_pad (sexp, ffestorag_modulo (eqst));
8797               break;
8798
8799             default:
8800               assert ("bad op for eqv init (pad)" == NULL);
8801               break;
8802             }
8803
8804           init = ffecom_expr (sexp);
8805           if (init == error_mark_node)
8806             init = NULL_TREE;   /* Hopefully the back end complained! */
8807         }
8808       else
8809         init = error_mark_node;
8810     }
8811   else if (ffe_is_init_local_zero ())
8812     init = error_mark_node;
8813   else
8814     init = NULL_TREE;
8815
8816   ffecom_member_namelisted_ = FALSE;
8817   ffestorag_drive (ffestorag_list_equivs (eqst),
8818                    &ffecom_member_phase1_,
8819                    eqst);
8820
8821   high = build_int_2 ((ffestorag_size (eqst)
8822                        + ffestorag_modulo (eqst)) - 1, 0);
8823   TREE_TYPE (high) = ffecom_integer_type_node;
8824
8825   eqtype = build_array_type (char_type_node,
8826                              build_range_type (ffecom_integer_type_node,
8827                                                ffecom_integer_zero_node,
8828                                                high));
8829
8830   eqt = build_decl (VAR_DECL,
8831                     ffecom_get_invented_identifier ("__g77_equiv_%s",
8832                                                     ffesymbol_text
8833                                                     (ffestorag_symbol (eqst))),
8834                     eqtype);
8835   DECL_EXTERNAL (eqt) = 0;
8836   if (is_init
8837       || ffecom_member_namelisted_
8838 #ifdef FFECOM_sizeMAXSTACKITEM
8839       || (ffestorag_size (eqst) > FFECOM_sizeMAXSTACKITEM)
8840 #endif
8841       || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8842           && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
8843           && (ffestorag_is_save (eqst) || ffe_is_saveall ())))
8844     TREE_STATIC (eqt) = 1;
8845   else
8846     TREE_STATIC (eqt) = 0;
8847   TREE_PUBLIC (eqt) = 0;
8848   TREE_ADDRESSABLE (eqt) = 1;  /* Ensure non-register allocation */
8849   DECL_CONTEXT (eqt) = current_function_decl;
8850   if (init)
8851     DECL_INITIAL (eqt) = error_mark_node;
8852   else
8853     DECL_INITIAL (eqt) = NULL_TREE;
8854
8855   eqt = start_decl (eqt, FALSE);
8856
8857   /* Make sure that any type can live in EQUIVALENCE and be referenced
8858      without getting a bus error.  We could pick the most restrictive
8859      alignment of all entities actually placed in the EQUIVALENCE, but
8860      this seems easy enough.  */
8861
8862   DECL_ALIGN (eqt) = BIGGEST_ALIGNMENT;
8863   DECL_USER_ALIGN (eqt) = 0;
8864
8865   if ((!is_init && ffe_is_init_local_zero ())
8866       || (is_init && (ffestorag_init (eqst) == NULL)))
8867     init = ffecom_init_zero_ (eqt);
8868
8869   finish_decl (eqt, init, FALSE);
8870
8871   if (is_init)
8872     ffestorag_set_init (eqst, ffebld_new_any ());
8873
8874   {
8875     assert (TREE_CODE (DECL_SIZE_UNIT (eqt)) == INTEGER_CST);
8876     assert (0 == compare_tree_int (DECL_SIZE_UNIT (eqt),
8877                                    (ffestorag_size (eqst)
8878                                     + ffestorag_modulo (eqst))));
8879   }
8880
8881   ffestorag_set_hook (eqst, eqt);
8882
8883   ffestorag_drive (ffestorag_list_equivs (eqst),
8884                    &ffecom_member_phase2_,
8885                    eqst);
8886 }
8887
8888 #endif
8889 /* Implement NAMELIST in back end.  See f2c/format.c for more info.  */
8890
8891 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8892 static tree
8893 ffecom_transform_namelist_ (ffesymbol s)
8894 {
8895   tree nmlt;
8896   tree nmltype = ffecom_type_namelist_ ();
8897   tree nmlinits;
8898   tree nameinit;
8899   tree varsinit;
8900   tree nvarsinit;
8901   tree field;
8902   tree high;
8903   int i;
8904   static int mynumber = 0;
8905
8906   nmlt = build_decl (VAR_DECL,
8907                      ffecom_get_invented_identifier ("__g77_namelist_%d",
8908                                                      mynumber++),
8909                      nmltype);
8910   TREE_STATIC (nmlt) = 1;
8911   DECL_INITIAL (nmlt) = error_mark_node;
8912
8913   nmlt = start_decl (nmlt, FALSE);
8914
8915   /* Process inits.  */
8916
8917   i = strlen (ffesymbol_text (s));
8918
8919   high = build_int_2 (i, 0);
8920   TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
8921
8922   nameinit = ffecom_build_f2c_string_ (i + 1,
8923                                        ffesymbol_text (s));
8924   TREE_TYPE (nameinit)
8925     = build_type_variant
8926     (build_array_type
8927      (char_type_node,
8928       build_range_type (ffecom_f2c_ftnlen_type_node,
8929                         ffecom_f2c_ftnlen_one_node,
8930                         high)),
8931      1, 0);
8932   TREE_CONSTANT (nameinit) = 1;
8933   TREE_STATIC (nameinit) = 1;
8934   nameinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (nameinit)),
8935                        nameinit);
8936
8937   varsinit = ffecom_vardesc_array_ (s);
8938   varsinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (varsinit)),
8939                        varsinit);
8940   TREE_CONSTANT (varsinit) = 1;
8941   TREE_STATIC (varsinit) = 1;
8942
8943   {
8944     ffebld b;
8945
8946     for (i = 0, b = ffesymbol_namelist (s); b != NULL; b = ffebld_trail (b))
8947       ++i;
8948   }
8949   nvarsinit = build_int_2 (i, 0);
8950   TREE_TYPE (nvarsinit) = integer_type_node;
8951   TREE_CONSTANT (nvarsinit) = 1;
8952   TREE_STATIC (nvarsinit) = 1;
8953
8954   nmlinits = build_tree_list ((field = TYPE_FIELDS (nmltype)), nameinit);
8955   TREE_CHAIN (nmlinits) = build_tree_list ((field = TREE_CHAIN (field)),
8956                                            varsinit);
8957   TREE_CHAIN (TREE_CHAIN (nmlinits))
8958     = build_tree_list ((field = TREE_CHAIN (field)), nvarsinit);
8959
8960   nmlinits = build (CONSTRUCTOR, nmltype, NULL_TREE, nmlinits);
8961   TREE_CONSTANT (nmlinits) = 1;
8962   TREE_STATIC (nmlinits) = 1;
8963
8964   finish_decl (nmlt, nmlinits, FALSE);
8965
8966   nmlt = ffecom_1 (ADDR_EXPR, build_pointer_type (nmltype), nmlt);
8967
8968   return nmlt;
8969 }
8970
8971 #endif
8972
8973 /* A subroutine of ffecom_tree_canonize_ref_.  The incoming tree is
8974    analyzed on the assumption it is calculating a pointer to be
8975    indirected through.  It must return the proper decl and offset,
8976    taking into account different units of measurements for offsets.  */
8977
8978 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8979 static void
8980 ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
8981                            tree t)
8982 {
8983   switch (TREE_CODE (t))
8984     {
8985     case NOP_EXPR:
8986     case CONVERT_EXPR:
8987     case NON_LVALUE_EXPR:
8988       ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
8989       break;
8990
8991     case PLUS_EXPR:
8992       ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
8993       if ((*decl == NULL_TREE)
8994           || (*decl == error_mark_node))
8995         break;
8996
8997       if (TREE_CODE (TREE_OPERAND (t, 1)) == INTEGER_CST)
8998         {
8999           /* An offset into COMMON.  */
9000           *offset = fold (build (PLUS_EXPR, TREE_TYPE (*offset),
9001                                  *offset, TREE_OPERAND (t, 1)));
9002           /* Convert offset (presumably in bytes) into canonical units
9003              (presumably bits).  */
9004           *offset = size_binop (MULT_EXPR,
9005                                 convert (bitsizetype, *offset),
9006                                 TYPE_SIZE (TREE_TYPE (TREE_TYPE (t))));
9007           break;
9008         }
9009       /* Not a COMMON reference, so an unrecognized pattern.  */
9010       *decl = error_mark_node;
9011       break;
9012
9013     case PARM_DECL:
9014       *decl = t;
9015       *offset = bitsize_zero_node;
9016       break;
9017
9018     case ADDR_EXPR:
9019       if (TREE_CODE (TREE_OPERAND (t, 0)) == VAR_DECL)
9020         {
9021           /* A reference to COMMON.  */
9022           *decl = TREE_OPERAND (t, 0);
9023           *offset = bitsize_zero_node;
9024           break;
9025         }
9026       /* Fall through.  */
9027     default:
9028       /* Not a COMMON reference, so an unrecognized pattern.  */
9029       *decl = error_mark_node;
9030       break;
9031     }
9032 }
9033 #endif
9034
9035 /* Given a tree that is possibly intended for use as an lvalue, return
9036    information representing a canonical view of that tree as a decl, an
9037    offset into that decl, and a size for the lvalue.
9038
9039    If there's no applicable decl, NULL_TREE is returned for the decl,
9040    and the other fields are left undefined.
9041
9042    If the tree doesn't fit the recognizable forms, an ERROR_MARK node
9043    is returned for the decl, and the other fields are left undefined.
9044
9045    Otherwise, the decl returned currently is either a VAR_DECL or a
9046    PARM_DECL.
9047
9048    The offset returned is always valid, but of course not necessarily
9049    a constant, and not necessarily converted into the appropriate
9050    type, leaving that up to the caller (so as to avoid that overhead
9051    if the decls being looked at are different anyway).
9052
9053    If the size cannot be determined (e.g. an adjustable array),
9054    an ERROR_MARK node is returned for the size.  Otherwise, the
9055    size returned is valid, not necessarily a constant, and not
9056    necessarily converted into the appropriate type as with the
9057    offset.
9058
9059    Note that the offset and size expressions are expressed in the
9060    base storage units (usually bits) rather than in the units of
9061    the type of the decl, because two decls with different types
9062    might overlap but with apparently non-overlapping array offsets,
9063    whereas converting the array offsets to consistant offsets will
9064    reveal the overlap.  */
9065
9066 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9067 static void
9068 ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
9069                            tree *size, tree t)
9070 {
9071   /* The default path is to report a nonexistant decl.  */
9072   *decl = NULL_TREE;
9073
9074   if (t == NULL_TREE)
9075     return;
9076
9077   switch (TREE_CODE (t))
9078     {
9079     case ERROR_MARK:
9080     case IDENTIFIER_NODE:
9081     case INTEGER_CST:
9082     case REAL_CST:
9083     case COMPLEX_CST:
9084     case STRING_CST:
9085     case CONST_DECL:
9086     case PLUS_EXPR:
9087     case MINUS_EXPR:
9088     case MULT_EXPR:
9089     case TRUNC_DIV_EXPR:
9090     case CEIL_DIV_EXPR:
9091     case FLOOR_DIV_EXPR:
9092     case ROUND_DIV_EXPR:
9093     case TRUNC_MOD_EXPR:
9094     case CEIL_MOD_EXPR:
9095     case FLOOR_MOD_EXPR:
9096     case ROUND_MOD_EXPR:
9097     case RDIV_EXPR:
9098     case EXACT_DIV_EXPR:
9099     case FIX_TRUNC_EXPR:
9100     case FIX_CEIL_EXPR:
9101     case FIX_FLOOR_EXPR:
9102     case FIX_ROUND_EXPR:
9103     case FLOAT_EXPR:
9104     case EXPON_EXPR:
9105     case NEGATE_EXPR:
9106     case MIN_EXPR:
9107     case MAX_EXPR:
9108     case ABS_EXPR:
9109     case FFS_EXPR:
9110     case LSHIFT_EXPR:
9111     case RSHIFT_EXPR:
9112     case LROTATE_EXPR:
9113     case RROTATE_EXPR:
9114     case BIT_IOR_EXPR:
9115     case BIT_XOR_EXPR:
9116     case BIT_AND_EXPR:
9117     case BIT_ANDTC_EXPR:
9118     case BIT_NOT_EXPR:
9119     case TRUTH_ANDIF_EXPR:
9120     case TRUTH_ORIF_EXPR:
9121     case TRUTH_AND_EXPR:
9122     case TRUTH_OR_EXPR:
9123     case TRUTH_XOR_EXPR:
9124     case TRUTH_NOT_EXPR:
9125     case LT_EXPR:
9126     case LE_EXPR:
9127     case GT_EXPR:
9128     case GE_EXPR:
9129     case EQ_EXPR:
9130     case NE_EXPR:
9131     case COMPLEX_EXPR:
9132     case CONJ_EXPR:
9133     case REALPART_EXPR:
9134     case IMAGPART_EXPR:
9135     case LABEL_EXPR:
9136     case COMPONENT_REF:
9137     case COMPOUND_EXPR:
9138     case ADDR_EXPR:
9139       return;
9140
9141     case VAR_DECL:
9142     case PARM_DECL:
9143       *decl = t;
9144       *offset = bitsize_zero_node;
9145       *size = TYPE_SIZE (TREE_TYPE (t));
9146       return;
9147
9148     case ARRAY_REF:
9149       {
9150         tree array = TREE_OPERAND (t, 0);
9151         tree element = TREE_OPERAND (t, 1);
9152         tree init_offset;
9153
9154         if ((array == NULL_TREE)
9155             || (element == NULL_TREE))
9156           {
9157             *decl = error_mark_node;
9158             return;
9159           }
9160
9161         ffecom_tree_canonize_ref_ (decl, &init_offset, size,
9162                                    array);
9163         if ((*decl == NULL_TREE)
9164             || (*decl == error_mark_node))
9165           return;
9166
9167         /* Calculate ((element - base) * NBBY) + init_offset.  */
9168         *offset = fold (build (MINUS_EXPR, TREE_TYPE (element),
9169                                element,
9170                                TYPE_MIN_VALUE (TYPE_DOMAIN
9171                                                (TREE_TYPE (array)))));
9172
9173         *offset = size_binop (MULT_EXPR,
9174                               convert (bitsizetype, *offset),
9175                               TYPE_SIZE (TREE_TYPE (TREE_TYPE (array))));
9176
9177         *offset = size_binop (PLUS_EXPR, init_offset, *offset);
9178
9179         *size = TYPE_SIZE (TREE_TYPE (t));
9180         return;
9181       }
9182
9183     case INDIRECT_REF:
9184
9185       /* Most of this code is to handle references to COMMON.  And so
9186          far that is useful only for calling library functions, since
9187          external (user) functions might reference common areas.  But
9188          even calling an external function, it's worthwhile to decode
9189          COMMON references because if not storing into COMMON, we don't
9190          want COMMON-based arguments to gratuitously force use of a
9191          temporary.  */
9192
9193       *size = TYPE_SIZE (TREE_TYPE (t));
9194
9195       ffecom_tree_canonize_ptr_ (decl, offset,
9196                                  TREE_OPERAND (t, 0));
9197
9198       return;
9199
9200     case CONVERT_EXPR:
9201     case NOP_EXPR:
9202     case MODIFY_EXPR:
9203     case NON_LVALUE_EXPR:
9204     case RESULT_DECL:
9205     case FIELD_DECL:
9206     case COND_EXPR:             /* More cases than we can handle. */
9207     case SAVE_EXPR:
9208     case REFERENCE_EXPR:
9209     case PREDECREMENT_EXPR:
9210     case PREINCREMENT_EXPR:
9211     case POSTDECREMENT_EXPR:
9212     case POSTINCREMENT_EXPR:
9213     case CALL_EXPR:
9214     default:
9215       *decl = error_mark_node;
9216       return;
9217     }
9218 }
9219 #endif
9220
9221 /* Do divide operation appropriate to type of operands.  */
9222
9223 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9224 static tree
9225 ffecom_tree_divide_ (tree tree_type, tree left, tree right,
9226                      tree dest_tree, ffebld dest, bool *dest_used,
9227                      tree hook)
9228 {
9229   if ((left == error_mark_node)
9230       || (right == error_mark_node))
9231     return error_mark_node;
9232
9233   switch (TREE_CODE (tree_type))
9234     {
9235     case INTEGER_TYPE:
9236       return ffecom_2 (TRUNC_DIV_EXPR, tree_type,
9237                        left,
9238                        right);
9239
9240     case COMPLEX_TYPE:
9241       if (! optimize_size)
9242         return ffecom_2 (RDIV_EXPR, tree_type,
9243                          left,
9244                          right);
9245       {
9246         ffecomGfrt ix;
9247
9248         if (TREE_TYPE (tree_type)
9249             == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9250           ix = FFECOM_gfrtDIV_CC;       /* Overlapping result okay. */
9251         else
9252           ix = FFECOM_gfrtDIV_ZZ;       /* Overlapping result okay. */
9253
9254         left = ffecom_1 (ADDR_EXPR,
9255                          build_pointer_type (TREE_TYPE (left)),
9256                          left);
9257         left = build_tree_list (NULL_TREE, left);
9258         right = ffecom_1 (ADDR_EXPR,
9259                           build_pointer_type (TREE_TYPE (right)),
9260                           right);
9261         right = build_tree_list (NULL_TREE, right);
9262         TREE_CHAIN (left) = right;
9263
9264         return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9265                              ffecom_gfrt_kindtype (ix),
9266                              ffe_is_f2c_library (),
9267                              tree_type,
9268                              left,
9269                              dest_tree, dest, dest_used,
9270                              NULL_TREE, TRUE, hook);
9271       }
9272       break;
9273
9274     case RECORD_TYPE:
9275       {
9276         ffecomGfrt ix;
9277
9278         if (TREE_TYPE (TYPE_FIELDS (tree_type))
9279             == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9280           ix = FFECOM_gfrtDIV_CC;       /* Overlapping result okay. */
9281         else
9282           ix = FFECOM_gfrtDIV_ZZ;       /* Overlapping result okay. */
9283
9284         left = ffecom_1 (ADDR_EXPR,
9285                          build_pointer_type (TREE_TYPE (left)),
9286                          left);
9287         left = build_tree_list (NULL_TREE, left);
9288         right = ffecom_1 (ADDR_EXPR,
9289                           build_pointer_type (TREE_TYPE (right)),
9290                           right);
9291         right = build_tree_list (NULL_TREE, right);
9292         TREE_CHAIN (left) = right;
9293
9294         return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9295                              ffecom_gfrt_kindtype (ix),
9296                              ffe_is_f2c_library (),
9297                              tree_type,
9298                              left,
9299                              dest_tree, dest, dest_used,
9300                              NULL_TREE, TRUE, hook);
9301       }
9302       break;
9303
9304     default:
9305       return ffecom_2 (RDIV_EXPR, tree_type,
9306                        left,
9307                        right);
9308     }
9309 }
9310
9311 #endif
9312 /* Build type info for non-dummy variable.  */
9313
9314 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9315 static tree
9316 ffecom_type_localvar_ (ffesymbol s, ffeinfoBasictype bt,
9317                        ffeinfoKindtype kt)
9318 {
9319   tree type;
9320   ffebld dl;
9321   ffebld dim;
9322   tree lowt;
9323   tree hight;
9324
9325   type = ffecom_tree_type[bt][kt];
9326   if (bt == FFEINFO_basictypeCHARACTER)
9327     {
9328       hight = build_int_2 (ffesymbol_size (s), 0);
9329       TREE_TYPE (hight) = ffecom_f2c_ftnlen_type_node;
9330
9331       type
9332         = build_array_type
9333           (type,
9334            build_range_type (ffecom_f2c_ftnlen_type_node,
9335                              ffecom_f2c_ftnlen_one_node,
9336                              hight));
9337       type = ffecom_check_size_overflow_ (s, type, FALSE);
9338     }
9339
9340   for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
9341     {
9342       if (type == error_mark_node)
9343         break;
9344
9345       dim = ffebld_head (dl);
9346       assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
9347
9348       if (ffebld_left (dim) == NULL)
9349         lowt = integer_one_node;
9350       else
9351         lowt = ffecom_expr (ffebld_left (dim));
9352
9353       if (TREE_CODE (lowt) != INTEGER_CST)
9354         lowt = variable_size (lowt);
9355
9356       assert (ffebld_right (dim) != NULL);
9357       hight = ffecom_expr (ffebld_right (dim));
9358
9359       if (TREE_CODE (hight) != INTEGER_CST)
9360         hight = variable_size (hight);
9361
9362       type = build_array_type (type,
9363                                build_range_type (ffecom_integer_type_node,
9364                                                  lowt, hight));
9365       type = ffecom_check_size_overflow_ (s, type, FALSE);
9366     }
9367
9368   return type;
9369 }
9370
9371 #endif
9372 /* Build Namelist type.  */
9373
9374 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9375 static tree
9376 ffecom_type_namelist_ ()
9377 {
9378   static tree type = NULL_TREE;
9379
9380   if (type == NULL_TREE)
9381     {
9382       static tree namefield, varsfield, nvarsfield;
9383       tree vardesctype;
9384
9385       vardesctype = ffecom_type_vardesc_ ();
9386
9387       type = make_node (RECORD_TYPE);
9388
9389       vardesctype = build_pointer_type (build_pointer_type (vardesctype));
9390
9391       namefield = ffecom_decl_field (type, NULL_TREE, "name",
9392                                      string_type_node);
9393       varsfield = ffecom_decl_field (type, namefield, "vars", vardesctype);
9394       nvarsfield = ffecom_decl_field (type, varsfield, "nvars",
9395                                       integer_type_node);
9396
9397       TYPE_FIELDS (type) = namefield;
9398       layout_type (type);
9399
9400       ggc_add_tree_root (&type, 1);
9401     }
9402
9403   return type;
9404 }
9405
9406 #endif
9407
9408 /* Build Vardesc type.  */
9409
9410 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9411 static tree
9412 ffecom_type_vardesc_ ()
9413 {
9414   static tree type = NULL_TREE;
9415   static tree namefield, addrfield, dimsfield, typefield;
9416
9417   if (type == NULL_TREE)
9418     {
9419       type = make_node (RECORD_TYPE);
9420
9421       namefield = ffecom_decl_field (type, NULL_TREE, "name",
9422                                      string_type_node);
9423       addrfield = ffecom_decl_field (type, namefield, "addr",
9424                                      string_type_node);
9425       dimsfield = ffecom_decl_field (type, addrfield, "dims",
9426                                      ffecom_f2c_ptr_to_ftnlen_type_node);
9427       typefield = ffecom_decl_field (type, dimsfield, "type",
9428                                      integer_type_node);
9429
9430       TYPE_FIELDS (type) = namefield;
9431       layout_type (type);
9432
9433       ggc_add_tree_root (&type, 1);
9434     }
9435
9436   return type;
9437 }
9438
9439 #endif
9440
9441 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9442 static tree
9443 ffecom_vardesc_ (ffebld expr)
9444 {
9445   ffesymbol s;
9446
9447   assert (ffebld_op (expr) == FFEBLD_opSYMTER);
9448   s = ffebld_symter (expr);
9449
9450   if (ffesymbol_hook (s).vardesc_tree == NULL_TREE)
9451     {
9452       int i;
9453       tree vardesctype = ffecom_type_vardesc_ ();
9454       tree var;
9455       tree nameinit;
9456       tree dimsinit;
9457       tree addrinit;
9458       tree typeinit;
9459       tree field;
9460       tree varinits;
9461       static int mynumber = 0;
9462
9463       var = build_decl (VAR_DECL,
9464                         ffecom_get_invented_identifier ("__g77_vardesc_%d",
9465                                                         mynumber++),
9466                         vardesctype);
9467       TREE_STATIC (var) = 1;
9468       DECL_INITIAL (var) = error_mark_node;
9469
9470       var = start_decl (var, FALSE);
9471
9472       /* Process inits.  */
9473
9474       nameinit = ffecom_build_f2c_string_ ((i = strlen (ffesymbol_text (s)))
9475                                            + 1,
9476                                            ffesymbol_text (s));
9477       TREE_TYPE (nameinit)
9478         = build_type_variant
9479         (build_array_type
9480          (char_type_node,
9481           build_range_type (integer_type_node,
9482                             integer_one_node,
9483                             build_int_2 (i, 0))),
9484          1, 0);
9485       TREE_CONSTANT (nameinit) = 1;
9486       TREE_STATIC (nameinit) = 1;
9487       nameinit = ffecom_1 (ADDR_EXPR,
9488                            build_pointer_type (TREE_TYPE (nameinit)),
9489                            nameinit);
9490
9491       addrinit = ffecom_arg_ptr_to_expr (expr, &typeinit);
9492
9493       dimsinit = ffecom_vardesc_dims_ (s);
9494
9495       if (typeinit == NULL_TREE)
9496         {
9497           ffeinfoBasictype bt = ffesymbol_basictype (s);
9498           ffeinfoKindtype kt = ffesymbol_kindtype (s);
9499           int tc = ffecom_f2c_typecode (bt, kt);
9500
9501           assert (tc != -1);
9502           typeinit = build_int_2 (tc, (tc < 0) ? -1 : 0);
9503         }
9504       else
9505         typeinit = ffecom_1 (NEGATE_EXPR, TREE_TYPE (typeinit), typeinit);
9506
9507       varinits = build_tree_list ((field = TYPE_FIELDS (vardesctype)),
9508                                   nameinit);
9509       TREE_CHAIN (varinits) = build_tree_list ((field = TREE_CHAIN (field)),
9510                                                addrinit);
9511       TREE_CHAIN (TREE_CHAIN (varinits))
9512         = build_tree_list ((field = TREE_CHAIN (field)), dimsinit);
9513       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (varinits)))
9514         = build_tree_list ((field = TREE_CHAIN (field)), typeinit);
9515
9516       varinits = build (CONSTRUCTOR, vardesctype, NULL_TREE, varinits);
9517       TREE_CONSTANT (varinits) = 1;
9518       TREE_STATIC (varinits) = 1;
9519
9520       finish_decl (var, varinits, FALSE);
9521
9522       var = ffecom_1 (ADDR_EXPR, build_pointer_type (vardesctype), var);
9523
9524       ffesymbol_hook (s).vardesc_tree = var;
9525     }
9526
9527   return ffesymbol_hook (s).vardesc_tree;
9528 }
9529
9530 #endif
9531 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9532 static tree
9533 ffecom_vardesc_array_ (ffesymbol s)
9534 {
9535   ffebld b;
9536   tree list;
9537   tree item = NULL_TREE;
9538   tree var;
9539   int i;
9540   static int mynumber = 0;
9541
9542   for (i = 0, list = NULL_TREE, b = ffesymbol_namelist (s);
9543        b != NULL;
9544        b = ffebld_trail (b), ++i)
9545     {
9546       tree t;
9547
9548       t = ffecom_vardesc_ (ffebld_head (b));
9549
9550       if (list == NULL_TREE)
9551         list = item = build_tree_list (NULL_TREE, t);
9552       else
9553         {
9554           TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9555           item = TREE_CHAIN (item);
9556         }
9557     }
9558
9559   item = build_array_type (build_pointer_type (ffecom_type_vardesc_ ()),
9560                            build_range_type (integer_type_node,
9561                                              integer_one_node,
9562                                              build_int_2 (i, 0)));
9563   list = build (CONSTRUCTOR, item, NULL_TREE, list);
9564   TREE_CONSTANT (list) = 1;
9565   TREE_STATIC (list) = 1;
9566
9567   var = ffecom_get_invented_identifier ("__g77_vardesc_array_%d", mynumber++);
9568   var = build_decl (VAR_DECL, var, item);
9569   TREE_STATIC (var) = 1;
9570   DECL_INITIAL (var) = error_mark_node;
9571   var = start_decl (var, FALSE);
9572   finish_decl (var, list, FALSE);
9573
9574   return var;
9575 }
9576
9577 #endif
9578 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9579 static tree
9580 ffecom_vardesc_dims_ (ffesymbol s)
9581 {
9582   if (ffesymbol_dims (s) == NULL)
9583     return convert (ffecom_f2c_ptr_to_ftnlen_type_node,
9584                     integer_zero_node);
9585
9586   {
9587     ffebld b;
9588     ffebld e;
9589     tree list;
9590     tree backlist;
9591     tree item = NULL_TREE;
9592     tree var;
9593     tree numdim;
9594     tree numelem;
9595     tree baseoff = NULL_TREE;
9596     static int mynumber = 0;
9597
9598     numdim = build_int_2 ((int) ffesymbol_rank (s), 0);
9599     TREE_TYPE (numdim) = ffecom_f2c_ftnlen_type_node;
9600
9601     numelem = ffecom_expr (ffesymbol_arraysize (s));
9602     TREE_TYPE (numelem) = ffecom_f2c_ftnlen_type_node;
9603
9604     list = NULL_TREE;
9605     backlist = NULL_TREE;
9606     for (b = ffesymbol_dims (s), e = ffesymbol_extents (s);
9607          b != NULL;
9608          b = ffebld_trail (b), e = ffebld_trail (e))
9609       {
9610         tree t;
9611         tree low;
9612         tree back;
9613
9614         if (ffebld_trail (b) == NULL)
9615           t = NULL_TREE;
9616         else
9617           {
9618             t = convert (ffecom_f2c_ftnlen_type_node,
9619                          ffecom_expr (ffebld_head (e)));
9620
9621             if (list == NULL_TREE)
9622               list = item = build_tree_list (NULL_TREE, t);
9623             else
9624               {
9625                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9626                 item = TREE_CHAIN (item);
9627               }
9628           }
9629
9630         if (ffebld_left (ffebld_head (b)) == NULL)
9631           low = ffecom_integer_one_node;
9632         else
9633           low = ffecom_expr (ffebld_left (ffebld_head (b)));
9634         low = convert (ffecom_f2c_ftnlen_type_node, low);
9635
9636         back = build_tree_list (low, t);
9637         TREE_CHAIN (back) = backlist;
9638         backlist = back;
9639       }
9640
9641     for (item = backlist; item != NULL_TREE; item = TREE_CHAIN (item))
9642       {
9643         if (TREE_VALUE (item) == NULL_TREE)
9644           baseoff = TREE_PURPOSE (item);
9645         else
9646           baseoff = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
9647                               TREE_PURPOSE (item),
9648                               ffecom_2 (MULT_EXPR,
9649                                         ffecom_f2c_ftnlen_type_node,
9650                                         TREE_VALUE (item),
9651                                         baseoff));
9652       }
9653
9654     /* backlist now dead, along with all TREE_PURPOSEs on it.  */
9655
9656     baseoff = build_tree_list (NULL_TREE, baseoff);
9657     TREE_CHAIN (baseoff) = list;
9658
9659     numelem = build_tree_list (NULL_TREE, numelem);
9660     TREE_CHAIN (numelem) = baseoff;
9661
9662     numdim = build_tree_list (NULL_TREE, numdim);
9663     TREE_CHAIN (numdim) = numelem;
9664
9665     item = build_array_type (ffecom_f2c_ftnlen_type_node,
9666                              build_range_type (integer_type_node,
9667                                                integer_zero_node,
9668                                                build_int_2
9669                                                ((int) ffesymbol_rank (s)
9670                                                 + 2, 0)));
9671     list = build (CONSTRUCTOR, item, NULL_TREE, numdim);
9672     TREE_CONSTANT (list) = 1;
9673     TREE_STATIC (list) = 1;
9674
9675     var = ffecom_get_invented_identifier ("__g77_dims_%d", mynumber++);
9676     var = build_decl (VAR_DECL, var, item);
9677     TREE_STATIC (var) = 1;
9678     DECL_INITIAL (var) = error_mark_node;
9679     var = start_decl (var, FALSE);
9680     finish_decl (var, list, FALSE);
9681
9682     var = ffecom_1 (ADDR_EXPR, build_pointer_type (item), var);
9683
9684     return var;
9685   }
9686 }
9687
9688 #endif
9689 /* Essentially does a "fold (build1 (code, type, node))" while checking
9690    for certain housekeeping things.
9691
9692    NOTE: for building an ADDR_EXPR around a FUNCTION_DECL, use
9693    ffecom_1_fn instead.  */
9694
9695 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9696 tree
9697 ffecom_1 (enum tree_code code, tree type, tree node)
9698 {
9699   tree item;
9700
9701   if ((node == error_mark_node)
9702       || (type == error_mark_node))
9703     return error_mark_node;
9704
9705   if (code == ADDR_EXPR)
9706     {
9707       if (!mark_addressable (node))
9708         assert ("can't mark_addressable this node!" == NULL);
9709     }
9710
9711   switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9712     {
9713       tree realtype;
9714
9715     case REALPART_EXPR:
9716       item = build (COMPONENT_REF, type, node, TYPE_FIELDS (TREE_TYPE (node)));
9717       break;
9718
9719     case IMAGPART_EXPR:
9720       item = build (COMPONENT_REF, type, node, TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (node))));
9721       break;
9722
9723
9724     case NEGATE_EXPR:
9725       if (TREE_CODE (type) != RECORD_TYPE)
9726         {
9727           item = build1 (code, type, node);
9728           break;
9729         }
9730       node = ffecom_stabilize_aggregate_ (node);
9731       realtype = TREE_TYPE (TYPE_FIELDS (type));
9732       item =
9733         ffecom_2 (COMPLEX_EXPR, type,
9734                   ffecom_1 (NEGATE_EXPR, realtype,
9735                             ffecom_1 (REALPART_EXPR, realtype,
9736                                       node)),
9737                   ffecom_1 (NEGATE_EXPR, realtype,
9738                             ffecom_1 (IMAGPART_EXPR, realtype,
9739                                       node)));
9740       break;
9741
9742     default:
9743       item = build1 (code, type, node);
9744       break;
9745     }
9746
9747   if (TREE_SIDE_EFFECTS (node))
9748     TREE_SIDE_EFFECTS (item) = 1;
9749   if ((code == ADDR_EXPR) && staticp (node))
9750     TREE_CONSTANT (item) = 1;
9751   return fold (item);
9752 }
9753 #endif
9754
9755 /* Like ffecom_1 (ADDR_EXPR, TREE_TYPE (node), node), except
9756    handles TREE_CODE (node) == FUNCTION_DECL.  In particular,
9757    does not set TREE_ADDRESSABLE (because calling an inline
9758    function does not mean the function needs to be separately
9759    compiled).  */
9760
9761 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9762 tree
9763 ffecom_1_fn (tree node)
9764 {
9765   tree item;
9766   tree type;
9767
9768   if (node == error_mark_node)
9769     return error_mark_node;
9770
9771   type = build_type_variant (TREE_TYPE (node),
9772                              TREE_READONLY (node),
9773                              TREE_THIS_VOLATILE (node));
9774   item = build1 (ADDR_EXPR,
9775                  build_pointer_type (type), node);
9776   if (TREE_SIDE_EFFECTS (node))
9777     TREE_SIDE_EFFECTS (item) = 1;
9778   if (staticp (node))
9779     TREE_CONSTANT (item) = 1;
9780   return fold (item);
9781 }
9782 #endif
9783
9784 /* Essentially does a "fold (build (code, type, node1, node2))" while
9785    checking for certain housekeeping things.  */
9786
9787 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9788 tree
9789 ffecom_2 (enum tree_code code, tree type, tree node1,
9790           tree node2)
9791 {
9792   tree item;
9793
9794   if ((node1 == error_mark_node)
9795       || (node2 == error_mark_node)
9796       || (type == error_mark_node))
9797     return error_mark_node;
9798
9799   switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9800     {
9801       tree a, b, c, d, realtype;
9802
9803     case CONJ_EXPR:
9804       assert ("no CONJ_EXPR support yet" == NULL);
9805       return error_mark_node;
9806
9807     case COMPLEX_EXPR:
9808       item = build_tree_list (TYPE_FIELDS (type), node1);
9809       TREE_CHAIN (item) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), node2);
9810       item = build (CONSTRUCTOR, type, NULL_TREE, item);
9811       break;
9812
9813     case PLUS_EXPR:
9814       if (TREE_CODE (type) != RECORD_TYPE)
9815         {
9816           item = build (code, type, node1, node2);
9817           break;
9818         }
9819       node1 = ffecom_stabilize_aggregate_ (node1);
9820       node2 = ffecom_stabilize_aggregate_ (node2);
9821       realtype = TREE_TYPE (TYPE_FIELDS (type));
9822       item =
9823         ffecom_2 (COMPLEX_EXPR, type,
9824                   ffecom_2 (PLUS_EXPR, realtype,
9825                             ffecom_1 (REALPART_EXPR, realtype,
9826                                       node1),
9827                             ffecom_1 (REALPART_EXPR, realtype,
9828                                       node2)),
9829                   ffecom_2 (PLUS_EXPR, realtype,
9830                             ffecom_1 (IMAGPART_EXPR, realtype,
9831                                       node1),
9832                             ffecom_1 (IMAGPART_EXPR, realtype,
9833                                       node2)));
9834       break;
9835
9836     case MINUS_EXPR:
9837       if (TREE_CODE (type) != RECORD_TYPE)
9838         {
9839           item = build (code, type, node1, node2);
9840           break;
9841         }
9842       node1 = ffecom_stabilize_aggregate_ (node1);
9843       node2 = ffecom_stabilize_aggregate_ (node2);
9844       realtype = TREE_TYPE (TYPE_FIELDS (type));
9845       item =
9846         ffecom_2 (COMPLEX_EXPR, type,
9847                   ffecom_2 (MINUS_EXPR, realtype,
9848                             ffecom_1 (REALPART_EXPR, realtype,
9849                                       node1),
9850                             ffecom_1 (REALPART_EXPR, realtype,
9851                                       node2)),
9852                   ffecom_2 (MINUS_EXPR, realtype,
9853                             ffecom_1 (IMAGPART_EXPR, realtype,
9854                                       node1),
9855                             ffecom_1 (IMAGPART_EXPR, realtype,
9856                                       node2)));
9857       break;
9858
9859     case MULT_EXPR:
9860       if (TREE_CODE (type) != RECORD_TYPE)
9861         {
9862           item = build (code, type, node1, node2);
9863           break;
9864         }
9865       node1 = ffecom_stabilize_aggregate_ (node1);
9866       node2 = ffecom_stabilize_aggregate_ (node2);
9867       realtype = TREE_TYPE (TYPE_FIELDS (type));
9868       a = save_expr (ffecom_1 (REALPART_EXPR, realtype,
9869                                node1));
9870       b = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
9871                                node1));
9872       c = save_expr (ffecom_1 (REALPART_EXPR, realtype,
9873                                node2));
9874       d = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
9875                                node2));
9876       item =
9877         ffecom_2 (COMPLEX_EXPR, type,
9878                   ffecom_2 (MINUS_EXPR, realtype,
9879                             ffecom_2 (MULT_EXPR, realtype,
9880                                       a,
9881                                       c),
9882                             ffecom_2 (MULT_EXPR, realtype,
9883                                       b,
9884                                       d)),
9885                   ffecom_2 (PLUS_EXPR, realtype,
9886                             ffecom_2 (MULT_EXPR, realtype,
9887                                       a,
9888                                       d),
9889                             ffecom_2 (MULT_EXPR, realtype,
9890                                       c,
9891                                       b)));
9892       break;
9893
9894     case EQ_EXPR:
9895       if ((TREE_CODE (node1) != RECORD_TYPE)
9896           && (TREE_CODE (node2) != RECORD_TYPE))
9897         {
9898           item = build (code, type, node1, node2);
9899           break;
9900         }
9901       assert (TREE_CODE (node1) == RECORD_TYPE);
9902       assert (TREE_CODE (node2) == RECORD_TYPE);
9903       node1 = ffecom_stabilize_aggregate_ (node1);
9904       node2 = ffecom_stabilize_aggregate_ (node2);
9905       realtype = TREE_TYPE (TYPE_FIELDS (type));
9906       item =
9907         ffecom_2 (TRUTH_ANDIF_EXPR, type,
9908                   ffecom_2 (code, type,
9909                             ffecom_1 (REALPART_EXPR, realtype,
9910                                       node1),
9911                             ffecom_1 (REALPART_EXPR, realtype,
9912                                       node2)),
9913                   ffecom_2 (code, type,
9914                             ffecom_1 (IMAGPART_EXPR, realtype,
9915                                       node1),
9916                             ffecom_1 (IMAGPART_EXPR, realtype,
9917                                       node2)));
9918       break;
9919
9920     case NE_EXPR:
9921       if ((TREE_CODE (node1) != RECORD_TYPE)
9922           && (TREE_CODE (node2) != RECORD_TYPE))
9923         {
9924           item = build (code, type, node1, node2);
9925           break;
9926         }
9927       assert (TREE_CODE (node1) == RECORD_TYPE);
9928       assert (TREE_CODE (node2) == RECORD_TYPE);
9929       node1 = ffecom_stabilize_aggregate_ (node1);
9930       node2 = ffecom_stabilize_aggregate_ (node2);
9931       realtype = TREE_TYPE (TYPE_FIELDS (type));
9932       item =
9933         ffecom_2 (TRUTH_ORIF_EXPR, type,
9934                   ffecom_2 (code, type,
9935                             ffecom_1 (REALPART_EXPR, realtype,
9936                                       node1),
9937                             ffecom_1 (REALPART_EXPR, realtype,
9938                                       node2)),
9939                   ffecom_2 (code, type,
9940                             ffecom_1 (IMAGPART_EXPR, realtype,
9941                                       node1),
9942                             ffecom_1 (IMAGPART_EXPR, realtype,
9943                                       node2)));
9944       break;
9945
9946     default:
9947       item = build (code, type, node1, node2);
9948       break;
9949     }
9950
9951   if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2))
9952     TREE_SIDE_EFFECTS (item) = 1;
9953   return fold (item);
9954 }
9955
9956 #endif
9957 /* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint
9958
9959    ffesymbol s;  // the ENTRY point itself
9960    if (ffecom_2pass_advise_entrypoint(s))
9961        // the ENTRY point has been accepted
9962
9963    Does whatever compiler needs to do when it learns about the entrypoint,
9964    like determine the return type of the master function, count the
9965    number of entrypoints, etc.  Returns FALSE if the return type is
9966    not compatible with the return type(s) of other entrypoint(s).
9967
9968    NOTE: for every call to this fn that returns TRUE, _do_entrypoint must
9969    later (after _finish_progunit) be called with the same entrypoint(s)
9970    as passed to this fn for which TRUE was returned.
9971
9972    03-Jan-92  JCB  2.0
9973       Return FALSE if the return type conflicts with previous entrypoints.  */
9974
9975 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9976 bool
9977 ffecom_2pass_advise_entrypoint (ffesymbol entry)
9978 {
9979   ffebld list;                  /* opITEM. */
9980   ffebld mlist;                 /* opITEM. */
9981   ffebld plist;                 /* opITEM. */
9982   ffebld arg;                   /* ffebld_head(opITEM). */
9983   ffebld item;                  /* opITEM. */
9984   ffesymbol s;                  /* ffebld_symter(arg). */
9985   ffeinfoBasictype bt = ffesymbol_basictype (entry);
9986   ffeinfoKindtype kt = ffesymbol_kindtype (entry);
9987   ffetargetCharacterSize size = ffesymbol_size (entry);
9988   bool ok;
9989
9990   if (ffecom_num_entrypoints_ == 0)
9991     {                           /* First entrypoint, make list of main
9992                                    arglist's dummies. */
9993       assert (ffecom_primary_entry_ != NULL);
9994
9995       ffecom_master_bt_ = ffesymbol_basictype (ffecom_primary_entry_);
9996       ffecom_master_kt_ = ffesymbol_kindtype (ffecom_primary_entry_);
9997       ffecom_master_size_ = ffesymbol_size (ffecom_primary_entry_);
9998
9999       for (plist = NULL, list = ffesymbol_dummyargs (ffecom_primary_entry_);
10000            list != NULL;
10001            list = ffebld_trail (list))
10002         {
10003           arg = ffebld_head (list);
10004           if (ffebld_op (arg) != FFEBLD_opSYMTER)
10005             continue;           /* Alternate return or some such thing. */
10006           item = ffebld_new_item (arg, NULL);
10007           if (plist == NULL)
10008             ffecom_master_arglist_ = item;
10009           else
10010             ffebld_set_trail (plist, item);
10011           plist = item;
10012         }
10013     }
10014
10015   /* If necessary, scan entry arglist for alternate returns.  Do this scan
10016      apparently redundantly (it's done below to UNIONize the arglists) so
10017      that we don't complain about RETURN 1 if an offending ENTRY is the only
10018      one with an alternate return.  */
10019
10020   if (!ffecom_is_altreturning_)
10021     {
10022       for (list = ffesymbol_dummyargs (entry);
10023            list != NULL;
10024            list = ffebld_trail (list))
10025         {
10026           arg = ffebld_head (list);
10027           if (ffebld_op (arg) == FFEBLD_opSTAR)
10028             {
10029               ffecom_is_altreturning_ = TRUE;
10030               break;
10031             }
10032         }
10033     }
10034
10035   /* Now check type compatibility. */
10036
10037   switch (ffecom_master_bt_)
10038     {
10039     case FFEINFO_basictypeNONE:
10040       ok = (bt != FFEINFO_basictypeCHARACTER);
10041       break;
10042
10043     case FFEINFO_basictypeCHARACTER:
10044       ok
10045         = (bt == FFEINFO_basictypeCHARACTER)
10046         && (kt == ffecom_master_kt_)
10047         && (size == ffecom_master_size_);
10048       break;
10049
10050     case FFEINFO_basictypeANY:
10051       return FALSE;             /* Just don't bother. */
10052
10053     default:
10054       if (bt == FFEINFO_basictypeCHARACTER)
10055         {
10056           ok = FALSE;
10057           break;
10058         }
10059       ok = TRUE;
10060       if ((bt != ffecom_master_bt_) || (kt != ffecom_master_kt_))
10061         {
10062           ffecom_master_bt_ = FFEINFO_basictypeNONE;
10063           ffecom_master_kt_ = FFEINFO_kindtypeNONE;
10064         }
10065       break;
10066     }
10067
10068   if (!ok)
10069     {
10070       ffebad_start (FFEBAD_ENTRY_CONFLICTS);
10071       ffest_ffebad_here_current_stmt (0);
10072       ffebad_finish ();
10073       return FALSE;             /* Can't handle entrypoint. */
10074     }
10075
10076   /* Entrypoint type compatible with previous types. */
10077
10078   ++ffecom_num_entrypoints_;
10079
10080   /* Master-arg-list = UNION(Master-arg-list,entry-arg-list). */
10081
10082   for (list = ffesymbol_dummyargs (entry);
10083        list != NULL;
10084        list = ffebld_trail (list))
10085     {
10086       arg = ffebld_head (list);
10087       if (ffebld_op (arg) != FFEBLD_opSYMTER)
10088         continue;               /* Alternate return or some such thing. */
10089       s = ffebld_symter (arg);
10090       for (plist = NULL, mlist = ffecom_master_arglist_;
10091            mlist != NULL;
10092            plist = mlist, mlist = ffebld_trail (mlist))
10093         {                       /* plist points to previous item for easy
10094                                    appending of arg. */
10095           if (ffebld_symter (ffebld_head (mlist)) == s)
10096             break;              /* Already have this arg in the master list. */
10097         }
10098       if (mlist != NULL)
10099         continue;               /* Already have this arg in the master list. */
10100
10101       /* Append this arg to the master list. */
10102
10103       item = ffebld_new_item (arg, NULL);
10104       if (plist == NULL)
10105         ffecom_master_arglist_ = item;
10106       else
10107         ffebld_set_trail (plist, item);
10108     }
10109
10110   return TRUE;
10111 }
10112
10113 #endif
10114 /* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint
10115
10116    ffesymbol s;  // the ENTRY point itself
10117    ffecom_2pass_do_entrypoint(s);
10118
10119    Does whatever compiler needs to do to make the entrypoint actually
10120    happen.  Must be called for each entrypoint after
10121    ffecom_finish_progunit is called.  */
10122
10123 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10124 void
10125 ffecom_2pass_do_entrypoint (ffesymbol entry)
10126 {
10127   static int mfn_num = 0;
10128   static int ent_num;
10129
10130   if (mfn_num != ffecom_num_fns_)
10131     {                           /* First entrypoint for this program unit. */
10132       ent_num = 1;
10133       mfn_num = ffecom_num_fns_;
10134       ffecom_do_entry_ (ffecom_primary_entry_, 0);
10135     }
10136   else
10137     ++ent_num;
10138
10139   --ffecom_num_entrypoints_;
10140
10141   ffecom_do_entry_ (entry, ent_num);
10142 }
10143
10144 #endif
10145
10146 /* Essentially does a "fold (build (code, type, node1, node2))" while
10147    checking for certain housekeeping things.  Always sets
10148    TREE_SIDE_EFFECTS.  */
10149
10150 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10151 tree
10152 ffecom_2s (enum tree_code code, tree type, tree node1,
10153            tree node2)
10154 {
10155   tree item;
10156
10157   if ((node1 == error_mark_node)
10158       || (node2 == error_mark_node)
10159       || (type == error_mark_node))
10160     return error_mark_node;
10161
10162   item = build (code, type, node1, node2);
10163   TREE_SIDE_EFFECTS (item) = 1;
10164   return fold (item);
10165 }
10166
10167 #endif
10168 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10169    checking for certain housekeeping things.  */
10170
10171 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10172 tree
10173 ffecom_3 (enum tree_code code, tree type, tree node1,
10174           tree node2, tree node3)
10175 {
10176   tree item;
10177
10178   if ((node1 == error_mark_node)
10179       || (node2 == error_mark_node)
10180       || (node3 == error_mark_node)
10181       || (type == error_mark_node))
10182     return error_mark_node;
10183
10184   item = build (code, type, node1, node2, node3);
10185   if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2)
10186       || (node3 != NULL_TREE && TREE_SIDE_EFFECTS (node3)))
10187     TREE_SIDE_EFFECTS (item) = 1;
10188   return fold (item);
10189 }
10190
10191 #endif
10192 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10193    checking for certain housekeeping things.  Always sets
10194    TREE_SIDE_EFFECTS.  */
10195
10196 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10197 tree
10198 ffecom_3s (enum tree_code code, tree type, tree node1,
10199            tree node2, tree node3)
10200 {
10201   tree item;
10202
10203   if ((node1 == error_mark_node)
10204       || (node2 == error_mark_node)
10205       || (node3 == error_mark_node)
10206       || (type == error_mark_node))
10207     return error_mark_node;
10208
10209   item = build (code, type, node1, node2, node3);
10210   TREE_SIDE_EFFECTS (item) = 1;
10211   return fold (item);
10212 }
10213
10214 #endif
10215
10216 /* ffecom_arg_expr -- Transform argument expr into gcc tree
10217
10218    See use by ffecom_list_expr.
10219
10220    If expression is NULL, returns an integer zero tree.  If it is not
10221    a CHARACTER expression, returns whatever ffecom_expr
10222    returns and sets the length return value to NULL_TREE.  Otherwise
10223    generates code to evaluate the character expression, returns the proper
10224    pointer to the result, but does NOT set the length return value to a tree
10225    that specifies the length of the result.  (In other words, the length
10226    variable is always set to NULL_TREE, because a length is never passed.)
10227
10228    21-Dec-91  JCB  1.1
10229       Don't set returned length, since nobody needs it (yet; someday if
10230       we allow CHARACTER*(*) dummies to statement functions, we'll need
10231       it).  */
10232
10233 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10234 tree
10235 ffecom_arg_expr (ffebld expr, tree *length)
10236 {
10237   tree ign;
10238
10239   *length = NULL_TREE;
10240
10241   if (expr == NULL)
10242     return integer_zero_node;
10243
10244   if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10245     return ffecom_expr (expr);
10246
10247   return ffecom_arg_ptr_to_expr (expr, &ign);
10248 }
10249
10250 #endif
10251 /* Transform expression into constant argument-pointer-to-expression tree.
10252
10253    If the expression can be transformed into a argument-pointer-to-expression
10254    tree that is constant, that is done, and the tree returned.  Else
10255    NULL_TREE is returned.
10256
10257    That way, a caller can attempt to provide compile-time initialization
10258    of a variable and, if that fails, *then* choose to start a new block
10259    and resort to using temporaries, as appropriate.  */
10260
10261 tree
10262 ffecom_arg_ptr_to_const_expr (ffebld expr, tree *length)
10263 {
10264   if (! expr)
10265     return integer_zero_node;
10266
10267   if (ffebld_op (expr) == FFEBLD_opANY)
10268     {
10269       if (length)
10270         *length = error_mark_node;
10271       return error_mark_node;
10272     }
10273
10274   if (ffebld_arity (expr) == 0
10275       && (ffebld_op (expr) != FFEBLD_opSYMTER
10276           || ffebld_where (expr) == FFEINFO_whereCOMMON
10277           || ffebld_where (expr) == FFEINFO_whereGLOBAL
10278           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10279     {
10280       tree t;
10281
10282       t = ffecom_arg_ptr_to_expr (expr, length);
10283       assert (TREE_CONSTANT (t));
10284       assert (! length || TREE_CONSTANT (*length));
10285       return t;
10286     }
10287
10288   if (length
10289       && ffebld_size (expr) != FFETARGET_charactersizeNONE)
10290     *length = build_int_2 (ffebld_size (expr), 0);
10291   else if (length)
10292     *length = NULL_TREE;
10293   return NULL_TREE;
10294 }
10295
10296 /* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree
10297
10298    See use by ffecom_list_ptr_to_expr.
10299
10300    If expression is NULL, returns an integer zero tree.  If it is not
10301    a CHARACTER expression, returns whatever ffecom_ptr_to_expr
10302    returns and sets the length return value to NULL_TREE.  Otherwise
10303    generates code to evaluate the character expression, returns the proper
10304    pointer to the result, AND sets the length return value to a tree that
10305    specifies the length of the result.
10306
10307    If the length argument is NULL, this is a slightly special
10308    case of building a FORMAT expression, that is, an expression that
10309    will be used at run time without regard to length.  For the current
10310    implementation, which uses the libf2c library, this means it is nice
10311    to append a null byte to the end of the expression, where feasible,
10312    to make sure any diagnostic about the FORMAT string terminates at
10313    some useful point.
10314
10315    For now, treat %REF(char-expr) as the same as char-expr with a NULL
10316    length argument.  This might even be seen as a feature, if a null
10317    byte can always be appended.  */
10318
10319 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10320 tree
10321 ffecom_arg_ptr_to_expr (ffebld expr, tree *length)
10322 {
10323   tree item;
10324   tree ign_length;
10325   ffecomConcatList_ catlist;
10326
10327   if (length != NULL)
10328     *length = NULL_TREE;
10329
10330   if (expr == NULL)
10331     return integer_zero_node;
10332
10333   switch (ffebld_op (expr))
10334     {
10335     case FFEBLD_opPERCENT_VAL:
10336       if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10337         return ffecom_expr (ffebld_left (expr));
10338       {
10339         tree temp_exp;
10340         tree temp_length;
10341
10342         temp_exp = ffecom_arg_ptr_to_expr (ffebld_left (expr), &temp_length);
10343         if (temp_exp == error_mark_node)
10344           return error_mark_node;
10345
10346         return ffecom_1 (INDIRECT_REF, TREE_TYPE (TREE_TYPE (temp_exp)),
10347                          temp_exp);
10348       }
10349
10350     case FFEBLD_opPERCENT_REF:
10351       if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10352         return ffecom_ptr_to_expr (ffebld_left (expr));
10353       if (length != NULL)
10354         {
10355           ign_length = NULL_TREE;
10356           length = &ign_length;
10357         }
10358       expr = ffebld_left (expr);
10359       break;
10360
10361     case FFEBLD_opPERCENT_DESCR:
10362       switch (ffeinfo_basictype (ffebld_info (expr)))
10363         {
10364 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10365         case FFEINFO_basictypeHOLLERITH:
10366 #endif
10367         case FFEINFO_basictypeCHARACTER:
10368           break;                /* Passed by descriptor anyway. */
10369
10370         default:
10371           item = ffecom_ptr_to_expr (expr);
10372           if (item != error_mark_node)
10373             *length = TYPE_SIZE (TREE_TYPE (TREE_TYPE (item)));
10374           break;
10375         }
10376       break;
10377
10378     default:
10379       break;
10380     }
10381
10382 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10383   if ((ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeHOLLERITH)
10384       && (length != NULL))
10385     {                           /* Pass Hollerith by descriptor. */
10386       ffetargetHollerith h;
10387
10388       assert (ffebld_op (expr) == FFEBLD_opCONTER);
10389       h = ffebld_cu_val_hollerith (ffebld_constant_union
10390                                    (ffebld_conter (expr)));
10391       *length
10392         = build_int_2 (h.length, 0);
10393       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10394     }
10395 #endif
10396
10397   if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10398     return ffecom_ptr_to_expr (expr);
10399
10400   assert (ffeinfo_kindtype (ffebld_info (expr))
10401           == FFEINFO_kindtypeCHARACTER1);
10402
10403   while (ffebld_op (expr) == FFEBLD_opPAREN)
10404     expr = ffebld_left (expr);
10405
10406   catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
10407   switch (ffecom_concat_list_count_ (catlist))
10408     {
10409     case 0:                     /* Shouldn't happen, but in case it does... */
10410       if (length != NULL)
10411         {
10412           *length = ffecom_f2c_ftnlen_zero_node;
10413           TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10414         }
10415       ffecom_concat_list_kill_ (catlist);
10416       return null_pointer_node;
10417
10418     case 1:                     /* The (fairly) easy case. */
10419       if (length == NULL)
10420         ffecom_char_args_with_null_ (&item, &ign_length,
10421                                      ffecom_concat_list_expr_ (catlist, 0));
10422       else
10423         ffecom_char_args_ (&item, length,
10424                            ffecom_concat_list_expr_ (catlist, 0));
10425       ffecom_concat_list_kill_ (catlist);
10426       assert (item != NULL_TREE);
10427       return item;
10428
10429     default:                    /* Must actually concatenate things. */
10430       break;
10431     }
10432
10433   {
10434     int count = ffecom_concat_list_count_ (catlist);
10435     int i;
10436     tree lengths;
10437     tree items;
10438     tree length_array;
10439     tree item_array;
10440     tree citem;
10441     tree clength;
10442     tree temporary;
10443     tree num;
10444     tree known_length;
10445     ffetargetCharacterSize sz;
10446
10447     sz = ffecom_concat_list_maxlen_ (catlist);
10448     /* ~~Kludge! */
10449     assert (sz != FFETARGET_charactersizeNONE);
10450
10451 #ifdef HOHO
10452     length_array
10453       = lengths
10454       = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
10455                              FFETARGET_charactersizeNONE, count, TRUE);
10456     item_array
10457       = items
10458       = ffecom_push_tempvar (ffecom_f2c_address_type_node,
10459                              FFETARGET_charactersizeNONE, count, TRUE);
10460     temporary = ffecom_push_tempvar (char_type_node,
10461                                      sz, -1, TRUE);
10462 #else
10463     {
10464       tree hook;
10465
10466       hook = ffebld_nonter_hook (expr);
10467       assert (hook);
10468       assert (TREE_CODE (hook) == TREE_VEC);
10469       assert (TREE_VEC_LENGTH (hook) == 3);
10470       length_array = lengths = TREE_VEC_ELT (hook, 0);
10471       item_array = items = TREE_VEC_ELT (hook, 1);
10472       temporary = TREE_VEC_ELT (hook, 2);
10473     }
10474 #endif
10475
10476     known_length = ffecom_f2c_ftnlen_zero_node;
10477
10478     for (i = 0; i < count; ++i)
10479       {
10480         if ((i == count)
10481             && (length == NULL))
10482           ffecom_char_args_with_null_ (&citem, &clength,
10483                                        ffecom_concat_list_expr_ (catlist, i));
10484         else
10485           ffecom_char_args_ (&citem, &clength,
10486                              ffecom_concat_list_expr_ (catlist, i));
10487         if ((citem == error_mark_node)
10488             || (clength == error_mark_node))
10489           {
10490             ffecom_concat_list_kill_ (catlist);
10491             *length = error_mark_node;
10492             return error_mark_node;
10493           }
10494
10495         items
10496           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
10497                       ffecom_modify (void_type_node,
10498                                      ffecom_2 (ARRAY_REF,
10499                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
10500                                                item_array,
10501                                                build_int_2 (i, 0)),
10502                                      citem),
10503                       items);
10504         clength = ffecom_save_tree (clength);
10505         if (length != NULL)
10506           known_length
10507             = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
10508                         known_length,
10509                         clength);
10510         lengths
10511           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
10512                       ffecom_modify (void_type_node,
10513                                      ffecom_2 (ARRAY_REF,
10514                    TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
10515                                                length_array,
10516                                                build_int_2 (i, 0)),
10517                                      clength),
10518                       lengths);
10519       }
10520
10521     temporary = ffecom_1 (ADDR_EXPR,
10522                           build_pointer_type (TREE_TYPE (temporary)),
10523                           temporary);
10524
10525     item = build_tree_list (NULL_TREE, temporary);
10526     TREE_CHAIN (item)
10527       = build_tree_list (NULL_TREE,
10528                          ffecom_1 (ADDR_EXPR,
10529                                    build_pointer_type (TREE_TYPE (items)),
10530                                    items));
10531     TREE_CHAIN (TREE_CHAIN (item))
10532       = build_tree_list (NULL_TREE,
10533                          ffecom_1 (ADDR_EXPR,
10534                                    build_pointer_type (TREE_TYPE (lengths)),
10535                                    lengths));
10536     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
10537       = build_tree_list
10538         (NULL_TREE,
10539          ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
10540                    convert (ffecom_f2c_ftnlen_type_node,
10541                             build_int_2 (count, 0))));
10542     num = build_int_2 (sz, 0);
10543     TREE_TYPE (num) = ffecom_f2c_ftnlen_type_node;
10544     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item))))
10545       = build_tree_list (NULL_TREE, num);
10546
10547     item = ffecom_call_gfrt (FFECOM_gfrtCAT, item, NULL_TREE);
10548     TREE_SIDE_EFFECTS (item) = 1;
10549     item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (temporary),
10550                      item,
10551                      temporary);
10552
10553     if (length != NULL)
10554       *length = known_length;
10555   }
10556
10557   ffecom_concat_list_kill_ (catlist);
10558   assert (item != NULL_TREE);
10559   return item;
10560 }
10561
10562 #endif
10563 /* Generate call to run-time function.
10564
10565    The first arg is the GNU Fortran Run-Time function index, the second
10566    arg is the list of arguments to pass to it.  Returned is the expression
10567    (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the
10568    result (which may be void).  */
10569
10570 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10571 tree
10572 ffecom_call_gfrt (ffecomGfrt ix, tree args, tree hook)
10573 {
10574   return ffecom_call_ (ffecom_gfrt_tree_ (ix),
10575                        ffecom_gfrt_kindtype (ix),
10576                        ffe_is_f2c_library () && ffecom_gfrt_complex_[ix],
10577                        NULL_TREE, args, NULL_TREE, NULL,
10578                        NULL, NULL_TREE, TRUE, hook);
10579 }
10580 #endif
10581
10582 /* Transform constant-union to tree.  */
10583
10584 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10585 tree
10586 ffecom_constantunion (ffebldConstantUnion *cu, ffeinfoBasictype bt,
10587                       ffeinfoKindtype kt, tree tree_type)
10588 {
10589   tree item;
10590
10591   switch (bt)
10592     {
10593     case FFEINFO_basictypeINTEGER:
10594       {
10595         int val;
10596
10597         switch (kt)
10598           {
10599 #if FFETARGET_okINTEGER1
10600           case FFEINFO_kindtypeINTEGER1:
10601             val = ffebld_cu_val_integer1 (*cu);
10602             break;
10603 #endif
10604
10605 #if FFETARGET_okINTEGER2
10606           case FFEINFO_kindtypeINTEGER2:
10607             val = ffebld_cu_val_integer2 (*cu);
10608             break;
10609 #endif
10610
10611 #if FFETARGET_okINTEGER3
10612           case FFEINFO_kindtypeINTEGER3:
10613             val = ffebld_cu_val_integer3 (*cu);
10614             break;
10615 #endif
10616
10617 #if FFETARGET_okINTEGER4
10618           case FFEINFO_kindtypeINTEGER4:
10619             val = ffebld_cu_val_integer4 (*cu);
10620             break;
10621 #endif
10622
10623           default:
10624             assert ("bad INTEGER constant kind type" == NULL);
10625             /* Fall through. */
10626           case FFEINFO_kindtypeANY:
10627             return error_mark_node;
10628           }
10629         item = build_int_2 (val, (val < 0) ? -1 : 0);
10630         TREE_TYPE (item) = tree_type;
10631       }
10632       break;
10633
10634     case FFEINFO_basictypeLOGICAL:
10635       {
10636         int val;
10637
10638         switch (kt)
10639           {
10640 #if FFETARGET_okLOGICAL1
10641           case FFEINFO_kindtypeLOGICAL1:
10642             val = ffebld_cu_val_logical1 (*cu);
10643             break;
10644 #endif
10645
10646 #if FFETARGET_okLOGICAL2
10647           case FFEINFO_kindtypeLOGICAL2:
10648             val = ffebld_cu_val_logical2 (*cu);
10649             break;
10650 #endif
10651
10652 #if FFETARGET_okLOGICAL3
10653           case FFEINFO_kindtypeLOGICAL3:
10654             val = ffebld_cu_val_logical3 (*cu);
10655             break;
10656 #endif
10657
10658 #if FFETARGET_okLOGICAL4
10659           case FFEINFO_kindtypeLOGICAL4:
10660             val = ffebld_cu_val_logical4 (*cu);
10661             break;
10662 #endif
10663
10664           default:
10665             assert ("bad LOGICAL constant kind type" == NULL);
10666             /* Fall through. */
10667           case FFEINFO_kindtypeANY:
10668             return error_mark_node;
10669           }
10670         item = build_int_2 (val, (val < 0) ? -1 : 0);
10671         TREE_TYPE (item) = tree_type;
10672       }
10673       break;
10674
10675     case FFEINFO_basictypeREAL:
10676       {
10677         REAL_VALUE_TYPE val;
10678
10679         switch (kt)
10680           {
10681 #if FFETARGET_okREAL1
10682           case FFEINFO_kindtypeREAL1:
10683             val = ffetarget_value_real1 (ffebld_cu_val_real1 (*cu));
10684             break;
10685 #endif
10686
10687 #if FFETARGET_okREAL2
10688           case FFEINFO_kindtypeREAL2:
10689             val = ffetarget_value_real2 (ffebld_cu_val_real2 (*cu));
10690             break;
10691 #endif
10692
10693 #if FFETARGET_okREAL3
10694           case FFEINFO_kindtypeREAL3:
10695             val = ffetarget_value_real3 (ffebld_cu_val_real3 (*cu));
10696             break;
10697 #endif
10698
10699 #if FFETARGET_okREAL4
10700           case FFEINFO_kindtypeREAL4:
10701             val = ffetarget_value_real4 (ffebld_cu_val_real4 (*cu));
10702             break;
10703 #endif
10704
10705           default:
10706             assert ("bad REAL constant kind type" == NULL);
10707             /* Fall through. */
10708           case FFEINFO_kindtypeANY:
10709             return error_mark_node;
10710           }
10711         item = build_real (tree_type, val);
10712       }
10713       break;
10714
10715     case FFEINFO_basictypeCOMPLEX:
10716       {
10717         REAL_VALUE_TYPE real;
10718         REAL_VALUE_TYPE imag;
10719         tree el_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
10720
10721         switch (kt)
10722           {
10723 #if FFETARGET_okCOMPLEX1
10724           case FFEINFO_kindtypeREAL1:
10725             real = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).real);
10726             imag = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).imaginary);
10727             break;
10728 #endif
10729
10730 #if FFETARGET_okCOMPLEX2
10731           case FFEINFO_kindtypeREAL2:
10732             real = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).real);
10733             imag = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).imaginary);
10734             break;
10735 #endif
10736
10737 #if FFETARGET_okCOMPLEX3
10738           case FFEINFO_kindtypeREAL3:
10739             real = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).real);
10740             imag = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).imaginary);
10741             break;
10742 #endif
10743
10744 #if FFETARGET_okCOMPLEX4
10745           case FFEINFO_kindtypeREAL4:
10746             real = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).real);
10747             imag = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).imaginary);
10748             break;
10749 #endif
10750
10751           default:
10752             assert ("bad REAL constant kind type" == NULL);
10753             /* Fall through. */
10754           case FFEINFO_kindtypeANY:
10755             return error_mark_node;
10756           }
10757         item = ffecom_build_complex_constant_ (tree_type,
10758                                                build_real (el_type, real),
10759                                                build_real (el_type, imag));
10760       }
10761       break;
10762
10763     case FFEINFO_basictypeCHARACTER:
10764       {                         /* Happens only in DATA and similar contexts. */
10765         ffetargetCharacter1 val;
10766
10767         switch (kt)
10768           {
10769 #if FFETARGET_okCHARACTER1
10770           case FFEINFO_kindtypeLOGICAL1:
10771             val = ffebld_cu_val_character1 (*cu);
10772             break;
10773 #endif
10774
10775           default:
10776             assert ("bad CHARACTER constant kind type" == NULL);
10777             /* Fall through. */
10778           case FFEINFO_kindtypeANY:
10779             return error_mark_node;
10780           }
10781         item = build_string (ffetarget_length_character1 (val),
10782                              ffetarget_text_character1 (val));
10783         TREE_TYPE (item)
10784           = build_type_variant (build_array_type (char_type_node,
10785                                                   build_range_type
10786                                                   (integer_type_node,
10787                                                    integer_one_node,
10788                                                    build_int_2
10789                                                 (ffetarget_length_character1
10790                                                  (val), 0))),
10791                                 1, 0);
10792       }
10793       break;
10794
10795     case FFEINFO_basictypeHOLLERITH:
10796       {
10797         ffetargetHollerith h;
10798
10799         h = ffebld_cu_val_hollerith (*cu);
10800
10801         /* If not at least as wide as default INTEGER, widen it.  */
10802         if (h.length >= FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE)
10803           item = build_string (h.length, h.text);
10804         else
10805           {
10806             char str[FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE];
10807
10808             memcpy (str, h.text, h.length);
10809             memset (&str[h.length], ' ',
10810                     FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE
10811                     - h.length);
10812             item = build_string (FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE,
10813                                  str);
10814           }
10815         TREE_TYPE (item)
10816           = build_type_variant (build_array_type (char_type_node,
10817                                                   build_range_type
10818                                                   (integer_type_node,
10819                                                    integer_one_node,
10820                                                    build_int_2
10821                                                    (h.length, 0))),
10822                                 1, 0);
10823       }
10824       break;
10825
10826     case FFEINFO_basictypeTYPELESS:
10827       {
10828         ffetargetInteger1 ival;
10829         ffetargetTypeless tless;
10830         ffebad error;
10831
10832         tless = ffebld_cu_val_typeless (*cu);
10833         error = ffetarget_convert_integer1_typeless (&ival, tless);
10834         assert (error == FFEBAD);
10835
10836         item = build_int_2 ((int) ival, 0);
10837       }
10838       break;
10839
10840     default:
10841       assert ("not yet on constant type" == NULL);
10842       /* Fall through. */
10843     case FFEINFO_basictypeANY:
10844       return error_mark_node;
10845     }
10846
10847   TREE_CONSTANT (item) = 1;
10848
10849   return item;
10850 }
10851
10852 #endif
10853
10854 /* Transform expression into constant tree.
10855
10856    If the expression can be transformed into a tree that is constant,
10857    that is done, and the tree returned.  Else NULL_TREE is returned.
10858
10859    That way, a caller can attempt to provide compile-time initialization
10860    of a variable and, if that fails, *then* choose to start a new block
10861    and resort to using temporaries, as appropriate.  */
10862
10863 tree
10864 ffecom_const_expr (ffebld expr)
10865 {
10866   if (! expr)
10867     return integer_zero_node;
10868
10869   if (ffebld_op (expr) == FFEBLD_opANY)
10870     return error_mark_node;
10871
10872   if (ffebld_arity (expr) == 0
10873       && (ffebld_op (expr) != FFEBLD_opSYMTER
10874 #if NEWCOMMON
10875           /* ~~Enable once common/equivalence is handled properly?  */
10876           || ffebld_where (expr) == FFEINFO_whereCOMMON
10877 #endif
10878           || ffebld_where (expr) == FFEINFO_whereGLOBAL
10879           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10880     {
10881       tree t;
10882
10883       t = ffecom_expr (expr);
10884       assert (TREE_CONSTANT (t));
10885       return t;
10886     }
10887
10888   return NULL_TREE;
10889 }
10890
10891 /* Handy way to make a field in a struct/union.  */
10892
10893 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10894 tree
10895 ffecom_decl_field (tree context, tree prevfield,
10896                    const char *name, tree type)
10897 {
10898   tree field;
10899
10900   field = build_decl (FIELD_DECL, get_identifier (name), type);
10901   DECL_CONTEXT (field) = context;
10902   DECL_ALIGN (field) = 0;
10903   DECL_USER_ALIGN (field) = 0;
10904   if (prevfield != NULL_TREE)
10905     TREE_CHAIN (prevfield) = field;
10906
10907   return field;
10908 }
10909
10910 #endif
10911
10912 void
10913 ffecom_close_include (FILE *f)
10914 {
10915 #if FFECOM_GCC_INCLUDE
10916   ffecom_close_include_ (f);
10917 #endif
10918 }
10919
10920 int
10921 ffecom_decode_include_option (char *spec)
10922 {
10923 #if FFECOM_GCC_INCLUDE
10924   return ffecom_decode_include_option_ (spec);
10925 #else
10926   return 1;
10927 #endif
10928 }
10929
10930 /* End a compound statement (block).  */
10931
10932 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10933 tree
10934 ffecom_end_compstmt (void)
10935 {
10936   return bison_rule_compstmt_ ();
10937 }
10938 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
10939
10940 /* ffecom_end_transition -- Perform end transition on all symbols
10941
10942    ffecom_end_transition();
10943
10944    Calls ffecom_sym_end_transition for each global and local symbol.  */
10945
10946 void
10947 ffecom_end_transition ()
10948 {
10949 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10950   ffebld item;
10951 #endif
10952
10953   if (ffe_is_ffedebug ())
10954     fprintf (dmpout, "; end_stmt_transition\n");
10955
10956 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10957   ffecom_list_blockdata_ = NULL;
10958   ffecom_list_common_ = NULL;
10959 #endif
10960
10961   ffesymbol_drive (ffecom_sym_end_transition);
10962   if (ffe_is_ffedebug ())
10963     {
10964       ffestorag_report ();
10965 #if FFECOM_targetCURRENT == FFECOM_targetFFE
10966       ffesymbol_report_all ();
10967 #endif
10968     }
10969
10970 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10971   ffecom_start_progunit_ ();
10972
10973   for (item = ffecom_list_blockdata_;
10974        item != NULL;
10975        item = ffebld_trail (item))
10976     {
10977       ffebld callee;
10978       ffesymbol s;
10979       tree dt;
10980       tree t;
10981       tree var;
10982       static int number = 0;
10983
10984       callee = ffebld_head (item);
10985       s = ffebld_symter (callee);
10986       t = ffesymbol_hook (s).decl_tree;
10987       if (t == NULL_TREE)
10988         {
10989           s = ffecom_sym_transform_ (s);
10990           t = ffesymbol_hook (s).decl_tree;
10991         }
10992
10993       dt = build_pointer_type (TREE_TYPE (t));
10994
10995       var = build_decl (VAR_DECL,
10996                         ffecom_get_invented_identifier ("__g77_forceload_%d",
10997                                                         number++),
10998                         dt);
10999       DECL_EXTERNAL (var) = 0;
11000       TREE_STATIC (var) = 1;
11001       TREE_PUBLIC (var) = 0;
11002       DECL_INITIAL (var) = error_mark_node;
11003       TREE_USED (var) = 1;
11004
11005       var = start_decl (var, FALSE);
11006
11007       t = ffecom_1 (ADDR_EXPR, dt, t);
11008
11009       finish_decl (var, t, FALSE);
11010     }
11011
11012   /* This handles any COMMON areas that weren't referenced but have, for
11013      example, important initial data.  */
11014
11015   for (item = ffecom_list_common_;
11016        item != NULL;
11017        item = ffebld_trail (item))
11018     ffecom_transform_common_ (ffebld_symter (ffebld_head (item)));
11019
11020   ffecom_list_common_ = NULL;
11021 #endif
11022 }
11023
11024 /* ffecom_exec_transition -- Perform exec transition on all symbols
11025
11026    ffecom_exec_transition();
11027
11028    Calls ffecom_sym_exec_transition for each global and local symbol.
11029    Make sure error updating not inhibited.  */
11030
11031 void
11032 ffecom_exec_transition ()
11033 {
11034   bool inhibited;
11035
11036   if (ffe_is_ffedebug ())
11037     fprintf (dmpout, "; exec_stmt_transition\n");
11038
11039   inhibited = ffebad_inhibit ();
11040   ffebad_set_inhibit (FALSE);
11041
11042   ffesymbol_drive (ffecom_sym_exec_transition); /* Don't retract! */
11043   ffeequiv_exec_transition ();  /* Handle all pending EQUIVALENCEs. */
11044   if (ffe_is_ffedebug ())
11045     {
11046       ffestorag_report ();
11047 #if FFECOM_targetCURRENT == FFECOM_targetFFE
11048       ffesymbol_report_all ();
11049 #endif
11050     }
11051
11052   if (inhibited)
11053     ffebad_set_inhibit (TRUE);
11054 }
11055
11056 /* Handle assignment statement.
11057
11058    Convert dest and source using ffecom_expr, then join them
11059    with an ASSIGN op and pass the whole thing to expand_expr_stmt.  */
11060
11061 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11062 void
11063 ffecom_expand_let_stmt (ffebld dest, ffebld source)
11064 {
11065   tree dest_tree;
11066   tree dest_length;
11067   tree source_tree;
11068   tree expr_tree;
11069
11070   if (ffeinfo_basictype (ffebld_info (dest)) != FFEINFO_basictypeCHARACTER)
11071     {
11072       bool dest_used;
11073       tree assign_temp;
11074
11075       /* This attempts to replicate the test below, but must not be
11076          true when the test below is false.  (Always err on the side
11077          of creating unused temporaries, to avoid ICEs.)  */
11078       if (ffebld_op (dest) != FFEBLD_opSYMTER
11079           || ((dest_tree = ffesymbol_hook (ffebld_symter (dest)).decl_tree)
11080               && (TREE_CODE (dest_tree) != VAR_DECL
11081                   || TREE_ADDRESSABLE (dest_tree))))
11082         {
11083           ffecom_prepare_expr_ (source, dest);
11084           dest_used = TRUE;
11085         }
11086       else
11087         {
11088           ffecom_prepare_expr_ (source, NULL);
11089           dest_used = FALSE;
11090         }
11091
11092       ffecom_prepare_expr_w (NULL_TREE, dest);
11093
11094       /* For COMPLEX assignment like C1=C2, if partial overlap is possible,
11095          create a temporary through which the assignment is to take place,
11096          since MODIFY_EXPR doesn't handle partial overlap properly.  */
11097       if (ffebld_basictype (dest) == FFEINFO_basictypeCOMPLEX
11098           && ffecom_possible_partial_overlap_ (dest, source))
11099         {
11100           assign_temp = ffecom_make_tempvar ("complex_let",
11101                                              ffecom_tree_type
11102                                              [ffebld_basictype (dest)]
11103                                              [ffebld_kindtype (dest)],
11104                                              FFETARGET_charactersizeNONE,
11105                                              -1);
11106         }
11107       else
11108         assign_temp = NULL_TREE;
11109
11110       ffecom_prepare_end ();
11111
11112       dest_tree = ffecom_expr_w (NULL_TREE, dest);
11113       if (dest_tree == error_mark_node)
11114         return;
11115
11116       if ((TREE_CODE (dest_tree) != VAR_DECL)
11117           || TREE_ADDRESSABLE (dest_tree))
11118         source_tree = ffecom_expr_ (source, dest_tree, dest, &dest_used,
11119                                     FALSE, FALSE);
11120       else
11121         {
11122           assert (! dest_used);
11123           dest_used = FALSE;
11124           source_tree = ffecom_expr (source);
11125         }
11126       if (source_tree == error_mark_node)
11127         return;
11128
11129       if (dest_used)
11130         expr_tree = source_tree;
11131       else if (assign_temp)
11132         {
11133 #ifdef MOVE_EXPR
11134           /* The back end understands a conceptual move (evaluate source;
11135              store into dest), so use that, in case it can determine
11136              that it is going to use, say, two registers as temporaries
11137              anyway.  So don't use the temp (and someday avoid generating
11138              it, once this code starts triggering regularly).  */
11139           expr_tree = ffecom_2s (MOVE_EXPR, void_type_node,
11140                                  dest_tree,
11141                                  source_tree);
11142 #else
11143           expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
11144                                  assign_temp,
11145                                  source_tree);
11146           expand_expr_stmt (expr_tree);
11147           expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
11148                                  dest_tree,
11149                                  assign_temp);
11150 #endif
11151         }
11152       else
11153         expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
11154                                dest_tree,
11155                                source_tree);
11156
11157       expand_expr_stmt (expr_tree);
11158       return;
11159     }
11160
11161   ffecom_prepare_let_char_ (ffebld_size_known (dest), source);
11162   ffecom_prepare_expr_w (NULL_TREE, dest);
11163
11164   ffecom_prepare_end ();
11165
11166   ffecom_char_args_ (&dest_tree, &dest_length, dest);
11167   ffecom_let_char_ (dest_tree, dest_length, ffebld_size_known (dest),
11168                     source);
11169 }
11170
11171 #endif
11172 /* ffecom_expr -- Transform expr into gcc tree
11173
11174    tree t;
11175    ffebld expr;  // FFE expression.
11176    tree = ffecom_expr(expr);
11177
11178    Recursive descent on expr while making corresponding tree nodes and
11179    attaching type info and such.  */
11180
11181 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11182 tree
11183 ffecom_expr (ffebld expr)
11184 {
11185   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, FALSE, FALSE);
11186 }
11187
11188 #endif
11189 /* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT.  */
11190
11191 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11192 tree
11193 ffecom_expr_assign (ffebld expr)
11194 {
11195   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
11196 }
11197
11198 #endif
11199 /* Like ffecom_expr_rw, but return tree usable for ASSIGN.  */
11200
11201 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11202 tree
11203 ffecom_expr_assign_w (ffebld expr)
11204 {
11205   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
11206 }
11207
11208 #endif
11209 /* Transform expr for use as into read/write tree and stabilize the
11210    reference.  Not for use on CHARACTER expressions.
11211
11212    Recursive descent on expr while making corresponding tree nodes and
11213    attaching type info and such.  */
11214
11215 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11216 tree
11217 ffecom_expr_rw (tree type, ffebld expr)
11218 {
11219   assert (expr != NULL);
11220   /* Different target types not yet supported.  */
11221   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
11222
11223   return stabilize_reference (ffecom_expr (expr));
11224 }
11225
11226 #endif
11227 /* Transform expr for use as into write tree and stabilize the
11228    reference.  Not for use on CHARACTER expressions.
11229
11230    Recursive descent on expr while making corresponding tree nodes and
11231    attaching type info and such.  */
11232
11233 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11234 tree
11235 ffecom_expr_w (tree type, ffebld expr)
11236 {
11237   assert (expr != NULL);
11238   /* Different target types not yet supported.  */
11239   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
11240
11241   return stabilize_reference (ffecom_expr (expr));
11242 }
11243
11244 #endif
11245 /* Do global stuff.  */
11246
11247 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11248 void
11249 ffecom_finish_compile ()
11250 {
11251   assert (ffecom_outer_function_decl_ == NULL_TREE);
11252   assert (current_function_decl == NULL_TREE);
11253
11254   ffeglobal_drive (ffecom_finish_global_);
11255 }
11256
11257 #endif
11258 /* Public entry point for front end to access finish_decl.  */
11259
11260 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11261 void
11262 ffecom_finish_decl (tree decl, tree init, bool is_top_level)
11263 {
11264   assert (!is_top_level);
11265   finish_decl (decl, init, FALSE);
11266 }
11267
11268 #endif
11269 /* Finish a program unit.  */
11270
11271 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11272 void
11273 ffecom_finish_progunit ()
11274 {
11275   ffecom_end_compstmt ();
11276
11277   ffecom_previous_function_decl_ = current_function_decl;
11278   ffecom_which_entrypoint_decl_ = NULL_TREE;
11279
11280   finish_function (0);
11281 }
11282
11283 #endif
11284
11285 /* Wrapper for get_identifier.  pattern is sprintf-like.  */
11286
11287 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11288 tree
11289 ffecom_get_invented_identifier (const char *pattern, ...)
11290 {
11291   tree decl;
11292   char *nam;
11293   va_list ap;
11294
11295   va_start (ap, pattern);
11296   if (vasprintf (&nam, pattern, ap) == 0)
11297     abort ();
11298   va_end (ap);
11299   decl = get_identifier (nam);
11300   free (nam);
11301   IDENTIFIER_INVENTED (decl) = 1;
11302   return decl;
11303 }
11304
11305 ffeinfoBasictype
11306 ffecom_gfrt_basictype (ffecomGfrt gfrt)
11307 {
11308   assert (gfrt < FFECOM_gfrt);
11309
11310   switch (ffecom_gfrt_type_[gfrt])
11311     {
11312     case FFECOM_rttypeVOID_:
11313     case FFECOM_rttypeVOIDSTAR_:
11314       return FFEINFO_basictypeNONE;
11315
11316     case FFECOM_rttypeFTNINT_:
11317       return FFEINFO_basictypeINTEGER;
11318
11319     case FFECOM_rttypeINTEGER_:
11320       return FFEINFO_basictypeINTEGER;
11321
11322     case FFECOM_rttypeLONGINT_:
11323       return FFEINFO_basictypeINTEGER;
11324
11325     case FFECOM_rttypeLOGICAL_:
11326       return FFEINFO_basictypeLOGICAL;
11327
11328     case FFECOM_rttypeREAL_F2C_:
11329     case FFECOM_rttypeREAL_GNU_:
11330       return FFEINFO_basictypeREAL;
11331
11332     case FFECOM_rttypeCOMPLEX_F2C_:
11333     case FFECOM_rttypeCOMPLEX_GNU_:
11334       return FFEINFO_basictypeCOMPLEX;
11335
11336     case FFECOM_rttypeDOUBLE_:
11337     case FFECOM_rttypeDOUBLEREAL_:
11338       return FFEINFO_basictypeREAL;
11339
11340     case FFECOM_rttypeDBLCMPLX_F2C_:
11341     case FFECOM_rttypeDBLCMPLX_GNU_:
11342       return FFEINFO_basictypeCOMPLEX;
11343
11344     case FFECOM_rttypeCHARACTER_:
11345       return FFEINFO_basictypeCHARACTER;
11346
11347     default:
11348       return FFEINFO_basictypeANY;
11349     }
11350 }
11351
11352 ffeinfoKindtype
11353 ffecom_gfrt_kindtype (ffecomGfrt gfrt)
11354 {
11355   assert (gfrt < FFECOM_gfrt);
11356
11357   switch (ffecom_gfrt_type_[gfrt])
11358     {
11359     case FFECOM_rttypeVOID_:
11360     case FFECOM_rttypeVOIDSTAR_:
11361       return FFEINFO_kindtypeNONE;
11362
11363     case FFECOM_rttypeFTNINT_:
11364       return FFEINFO_kindtypeINTEGER1;
11365
11366     case FFECOM_rttypeINTEGER_:
11367       return FFEINFO_kindtypeINTEGER1;
11368
11369     case FFECOM_rttypeLONGINT_:
11370       return FFEINFO_kindtypeINTEGER4;
11371
11372     case FFECOM_rttypeLOGICAL_:
11373       return FFEINFO_kindtypeLOGICAL1;
11374
11375     case FFECOM_rttypeREAL_F2C_:
11376     case FFECOM_rttypeREAL_GNU_:
11377       return FFEINFO_kindtypeREAL1;
11378
11379     case FFECOM_rttypeCOMPLEX_F2C_:
11380     case FFECOM_rttypeCOMPLEX_GNU_:
11381       return FFEINFO_kindtypeREAL1;
11382
11383     case FFECOM_rttypeDOUBLE_:
11384     case FFECOM_rttypeDOUBLEREAL_:
11385       return FFEINFO_kindtypeREAL2;
11386
11387     case FFECOM_rttypeDBLCMPLX_F2C_:
11388     case FFECOM_rttypeDBLCMPLX_GNU_:
11389       return FFEINFO_kindtypeREAL2;
11390
11391     case FFECOM_rttypeCHARACTER_:
11392       return FFEINFO_kindtypeCHARACTER1;
11393
11394     default:
11395       return FFEINFO_kindtypeANY;
11396     }
11397 }
11398
11399 void
11400 ffecom_init_0 ()
11401 {
11402   tree endlink;
11403   int i;
11404   int j;
11405   tree t;
11406   tree field;
11407   ffetype type;
11408   ffetype base_type;
11409   tree double_ftype_double;
11410   tree float_ftype_float;
11411   tree ldouble_ftype_ldouble;
11412   tree ffecom_tree_ptr_to_fun_type_void;
11413
11414   /* This block of code comes from the now-obsolete cktyps.c.  It checks
11415      whether the compiler environment is buggy in known ways, some of which
11416      would, if not explicitly checked here, result in subtle bugs in g77.  */
11417
11418   if (ffe_is_do_internal_checks ())
11419     {
11420       static char names[][12]
11421         =
11422       {"bar", "bletch", "foo", "foobar"};
11423       char *name;
11424       unsigned long ul;
11425       double fl;
11426
11427       name = bsearch ("foo", &names[0], ARRAY_SIZE (names), sizeof (names[0]),
11428                       (int (*)(const void *, const void *)) strcmp);
11429       if (name != (char *) &names[2])
11430         {
11431           assert ("bsearch doesn't work, #define FFEPROJ_BSEARCH 0 in proj.h"
11432                   == NULL);
11433           abort ();
11434         }
11435
11436       ul = strtoul ("123456789", NULL, 10);
11437       if (ul != 123456789L)
11438         {
11439           assert ("strtoul doesn't have enough range, #define FFEPROJ_STRTOUL 0\
11440  in proj.h" == NULL);
11441           abort ();
11442         }
11443
11444       fl = atof ("56.789");
11445       if ((fl < 56.788) || (fl > 56.79))
11446         {
11447           assert ("atof not type double, fix your #include <stdio.h>"
11448                   == NULL);
11449           abort ();
11450         }
11451     }
11452
11453 #if FFECOM_GCC_INCLUDE
11454   ffecom_initialize_char_syntax_ ();
11455 #endif
11456
11457   ffecom_outer_function_decl_ = NULL_TREE;
11458   current_function_decl = NULL_TREE;
11459   named_labels = NULL_TREE;
11460   current_binding_level = NULL_BINDING_LEVEL;
11461   free_binding_level = NULL_BINDING_LEVEL;
11462   /* Make the binding_level structure for global names.  */
11463   pushlevel (0);
11464   global_binding_level = current_binding_level;
11465   current_binding_level->prep_state = 2;
11466
11467   build_common_tree_nodes (1);
11468
11469   /* Define `int' and `char' first so that dbx will output them first.  */
11470   pushdecl (build_decl (TYPE_DECL, get_identifier ("int"),
11471                         integer_type_node));
11472   pushdecl (build_decl (TYPE_DECL, get_identifier ("char"),
11473                         char_type_node));
11474   pushdecl (build_decl (TYPE_DECL, get_identifier ("long int"),
11475                         long_integer_type_node));
11476   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned int"),
11477                         unsigned_type_node));
11478   pushdecl (build_decl (TYPE_DECL, get_identifier ("long unsigned int"),
11479                         long_unsigned_type_node));
11480   pushdecl (build_decl (TYPE_DECL, get_identifier ("long long int"),
11481                         long_long_integer_type_node));
11482   pushdecl (build_decl (TYPE_DECL, get_identifier ("long long unsigned int"),
11483                         long_long_unsigned_type_node));
11484   pushdecl (build_decl (TYPE_DECL, get_identifier ("short int"),
11485                         short_integer_type_node));
11486   pushdecl (build_decl (TYPE_DECL, get_identifier ("short unsigned int"),
11487                         short_unsigned_type_node));
11488
11489   /* Set the sizetype before we make other types.  This *should* be the
11490      first type we create.  */
11491
11492   set_sizetype
11493     (TREE_TYPE (IDENTIFIER_GLOBAL_VALUE (get_identifier (SIZE_TYPE))));
11494   ffecom_typesize_pointer_
11495     = TREE_INT_CST_LOW (TYPE_SIZE (sizetype)) / BITS_PER_UNIT;
11496
11497   build_common_tree_nodes_2 (0);
11498
11499   /* Define both `signed char' and `unsigned char'.  */
11500   pushdecl (build_decl (TYPE_DECL, get_identifier ("signed char"),
11501                         signed_char_type_node));
11502
11503   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned char"),
11504                         unsigned_char_type_node));
11505
11506   pushdecl (build_decl (TYPE_DECL, get_identifier ("float"),
11507                         float_type_node));
11508   pushdecl (build_decl (TYPE_DECL, get_identifier ("double"),
11509                         double_type_node));
11510   pushdecl (build_decl (TYPE_DECL, get_identifier ("long double"),
11511                         long_double_type_node));
11512
11513   /* For now, override what build_common_tree_nodes has done.  */
11514   complex_integer_type_node = ffecom_make_complex_type_ (integer_type_node);
11515   complex_float_type_node = ffecom_make_complex_type_ (float_type_node);
11516   complex_double_type_node = ffecom_make_complex_type_ (double_type_node);
11517   complex_long_double_type_node
11518     = ffecom_make_complex_type_ (long_double_type_node);
11519
11520   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex int"),
11521                         complex_integer_type_node));
11522   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex float"),
11523                         complex_float_type_node));
11524   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex double"),
11525                         complex_double_type_node));
11526   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex long double"),
11527                         complex_long_double_type_node));
11528
11529   pushdecl (build_decl (TYPE_DECL, get_identifier ("void"),
11530                         void_type_node));
11531   /* We are not going to have real types in C with less than byte alignment,
11532      so we might as well not have any types that claim to have it.  */
11533   TYPE_ALIGN (void_type_node) = BITS_PER_UNIT;
11534   TYPE_USER_ALIGN (void_type_node) = 0;
11535
11536   string_type_node = build_pointer_type (char_type_node);
11537
11538   ffecom_tree_fun_type_void
11539     = build_function_type (void_type_node, NULL_TREE);
11540
11541   ffecom_tree_ptr_to_fun_type_void
11542     = build_pointer_type (ffecom_tree_fun_type_void);
11543
11544   endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE);
11545
11546   float_ftype_float
11547     = build_function_type (float_type_node,
11548                            tree_cons (NULL_TREE, float_type_node, endlink));
11549
11550   double_ftype_double
11551     = build_function_type (double_type_node,
11552                            tree_cons (NULL_TREE, double_type_node, endlink));
11553
11554   ldouble_ftype_ldouble
11555     = build_function_type (long_double_type_node,
11556                            tree_cons (NULL_TREE, long_double_type_node,
11557                                       endlink));
11558
11559   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11560     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11561       {
11562         ffecom_tree_type[i][j] = NULL_TREE;
11563         ffecom_tree_fun_type[i][j] = NULL_TREE;
11564         ffecom_tree_ptr_to_fun_type[i][j] = NULL_TREE;
11565         ffecom_f2c_typecode_[i][j] = -1;
11566       }
11567
11568   /* Set up standard g77 types.  Note that INTEGER and LOGICAL are set
11569      to size FLOAT_TYPE_SIZE because they have to be the same size as
11570      REAL, which also is FLOAT_TYPE_SIZE, according to the standard.
11571      Compiler options and other such stuff that change the ways these
11572      types are set should not affect this particular setup.  */
11573
11574   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1]
11575     = t = make_signed_type (FLOAT_TYPE_SIZE);
11576   pushdecl (build_decl (TYPE_DECL, get_identifier ("integer"),
11577                         t));
11578   type = ffetype_new ();
11579   base_type = type;
11580   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER1,
11581                     type);
11582   ffetype_set_ams (type,
11583                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11584                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11585   ffetype_set_star (base_type,
11586                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11587                     type);
11588   ffetype_set_kind (base_type, 1, type);
11589   ffecom_typesize_integer1_ = ffetype_size (type);
11590   assert (ffetype_size (type) == sizeof (ffetargetInteger1));
11591
11592   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER1]
11593     = t = make_unsigned_type (FLOAT_TYPE_SIZE); /* HOLLERITH means unsigned. */
11594   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned"),
11595                         t));
11596
11597   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER2]
11598     = t = make_signed_type (CHAR_TYPE_SIZE);
11599   pushdecl (build_decl (TYPE_DECL, get_identifier ("byte"),
11600                         t));
11601   type = ffetype_new ();
11602   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER2,
11603                     type);
11604   ffetype_set_ams (type,
11605                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11606                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11607   ffetype_set_star (base_type,
11608                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11609                     type);
11610   ffetype_set_kind (base_type, 3, type);
11611   assert (ffetype_size (type) == sizeof (ffetargetInteger2));
11612
11613   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER2]
11614     = t = make_unsigned_type (CHAR_TYPE_SIZE);
11615   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned byte"),
11616                         t));
11617
11618   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER3]
11619     = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11620   pushdecl (build_decl (TYPE_DECL, get_identifier ("word"),
11621                         t));
11622   type = ffetype_new ();
11623   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER3,
11624                     type);
11625   ffetype_set_ams (type,
11626                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11627                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11628   ffetype_set_star (base_type,
11629                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11630                     type);
11631   ffetype_set_kind (base_type, 6, type);
11632   assert (ffetype_size (type) == sizeof (ffetargetInteger3));
11633
11634   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER3]
11635     = t = make_unsigned_type (CHAR_TYPE_SIZE * 2);
11636   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned word"),
11637                         t));
11638
11639   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER4]
11640     = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11641   pushdecl (build_decl (TYPE_DECL, get_identifier ("integer4"),
11642                         t));
11643   type = ffetype_new ();
11644   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER4,
11645                     type);
11646   ffetype_set_ams (type,
11647                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11648                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11649   ffetype_set_star (base_type,
11650                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11651                     type);
11652   ffetype_set_kind (base_type, 2, type);
11653   assert (ffetype_size (type) == sizeof (ffetargetInteger4));
11654
11655   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER4]
11656     = t = make_unsigned_type (FLOAT_TYPE_SIZE * 2);
11657   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned4"),
11658                         t));
11659
11660 #if 0
11661   if (ffe_is_do_internal_checks ()
11662       && LONG_TYPE_SIZE != FLOAT_TYPE_SIZE
11663       && LONG_TYPE_SIZE != CHAR_TYPE_SIZE
11664       && LONG_TYPE_SIZE != SHORT_TYPE_SIZE
11665       && LONG_TYPE_SIZE != LONG_LONG_TYPE_SIZE)
11666     {
11667       fprintf (stderr, "Sorry, no g77 support for LONG_TYPE_SIZE (%d bits) yet.\n",
11668                LONG_TYPE_SIZE);
11669     }
11670 #endif
11671
11672   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL1]
11673     = t = make_signed_type (FLOAT_TYPE_SIZE);
11674   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical"),
11675                         t));
11676   type = ffetype_new ();
11677   base_type = type;
11678   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL1,
11679                     type);
11680   ffetype_set_ams (type,
11681                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11682                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11683   ffetype_set_star (base_type,
11684                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11685                     type);
11686   ffetype_set_kind (base_type, 1, type);
11687   assert (ffetype_size (type) == sizeof (ffetargetLogical1));
11688
11689   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL2]
11690     = t = make_signed_type (CHAR_TYPE_SIZE);
11691   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical2"),
11692                         t));
11693   type = ffetype_new ();
11694   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL2,
11695                     type);
11696   ffetype_set_ams (type,
11697                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11698                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11699   ffetype_set_star (base_type,
11700                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11701                     type);
11702   ffetype_set_kind (base_type, 3, type);
11703   assert (ffetype_size (type) == sizeof (ffetargetLogical2));
11704
11705   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL3]
11706     = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11707   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical3"),
11708                         t));
11709   type = ffetype_new ();
11710   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL3,
11711                     type);
11712   ffetype_set_ams (type,
11713                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11714                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11715   ffetype_set_star (base_type,
11716                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11717                     type);
11718   ffetype_set_kind (base_type, 6, type);
11719   assert (ffetype_size (type) == sizeof (ffetargetLogical3));
11720
11721   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL4]
11722     = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11723   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical4"),
11724                         t));
11725   type = ffetype_new ();
11726   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL4,
11727                     type);
11728   ffetype_set_ams (type,
11729                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11730                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11731   ffetype_set_star (base_type,
11732                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11733                     type);
11734   ffetype_set_kind (base_type, 2, type);
11735   assert (ffetype_size (type) == sizeof (ffetargetLogical4));
11736
11737   ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11738     = t = make_node (REAL_TYPE);
11739   TYPE_PRECISION (t) = FLOAT_TYPE_SIZE;
11740   pushdecl (build_decl (TYPE_DECL, get_identifier ("real"),
11741                         t));
11742   layout_type (t);
11743   type = ffetype_new ();
11744   base_type = type;
11745   ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL1,
11746                     type);
11747   ffetype_set_ams (type,
11748                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11749                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11750   ffetype_set_star (base_type,
11751                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11752                     type);
11753   ffetype_set_kind (base_type, 1, type);
11754   ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11755     = FFETARGET_f2cTYREAL;
11756   assert (ffetype_size (type) == sizeof (ffetargetReal1));
11757
11758   ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREALDOUBLE]
11759     = t = make_node (REAL_TYPE);
11760   TYPE_PRECISION (t) = FLOAT_TYPE_SIZE * 2;     /* Always twice REAL. */
11761   pushdecl (build_decl (TYPE_DECL, get_identifier ("double precision"),
11762                         t));
11763   layout_type (t);
11764   type = ffetype_new ();
11765   ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE,
11766                     type);
11767   ffetype_set_ams (type,
11768                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11769                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11770   ffetype_set_star (base_type,
11771                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11772                     type);
11773   ffetype_set_kind (base_type, 2, type);
11774   ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]
11775     = FFETARGET_f2cTYDREAL;
11776   assert (ffetype_size (type) == sizeof (ffetargetReal2));
11777
11778   ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11779     = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]);
11780   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex"),
11781                         t));
11782   type = ffetype_new ();
11783   base_type = type;
11784   ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL1,
11785                     type);
11786   ffetype_set_ams (type,
11787                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11788                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11789   ffetype_set_star (base_type,
11790                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11791                     type);
11792   ffetype_set_kind (base_type, 1, type);
11793   ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11794     = FFETARGET_f2cTYCOMPLEX;
11795   assert (ffetype_size (type) == sizeof (ffetargetComplex1));
11796
11797   ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREALDOUBLE]
11798     = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]);
11799   pushdecl (build_decl (TYPE_DECL, get_identifier ("double complex"),
11800                         t));
11801   type = ffetype_new ();
11802   ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREALDOUBLE,
11803                     type);
11804   ffetype_set_ams (type,
11805                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11806                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11807   ffetype_set_star (base_type,
11808                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11809                     type);
11810   ffetype_set_kind (base_type, 2,
11811                     type);
11812   ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL2]
11813     = FFETARGET_f2cTYDCOMPLEX;
11814   assert (ffetype_size (type) == sizeof (ffetargetComplex2));
11815
11816   /* Make function and ptr-to-function types for non-CHARACTER types. */
11817
11818   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11819     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11820       {
11821         if ((t = ffecom_tree_type[i][j]) != NULL_TREE)
11822           {
11823             if (i == FFEINFO_basictypeINTEGER)
11824               {
11825                 /* Figure out the smallest INTEGER type that can hold
11826                    a pointer on this machine. */
11827                 if (GET_MODE_SIZE (TYPE_MODE (t))
11828                     >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
11829                   {
11830                     if ((ffecom_pointer_kind_ == FFEINFO_kindtypeNONE)
11831                         || (GET_MODE_SIZE (TYPE_MODE (ffecom_tree_type[i][ffecom_pointer_kind_]))
11832                             > GET_MODE_SIZE (TYPE_MODE (t))))
11833                       ffecom_pointer_kind_ = j;
11834                   }
11835               }
11836             else if (i == FFEINFO_basictypeCOMPLEX)
11837               t = void_type_node;
11838             /* For f2c compatibility, REAL functions are really
11839                implemented as DOUBLE PRECISION.  */
11840             else if ((i == FFEINFO_basictypeREAL)
11841                      && (j == FFEINFO_kindtypeREAL1))
11842               t = ffecom_tree_type
11843                 [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2];
11844
11845             t = ffecom_tree_fun_type[i][j] = build_function_type (t,
11846                                                                   NULL_TREE);
11847             ffecom_tree_ptr_to_fun_type[i][j] = build_pointer_type (t);
11848           }
11849       }
11850
11851   /* Set up pointer types.  */
11852
11853   if (ffecom_pointer_kind_ == FFEINFO_basictypeNONE)
11854     fatal_error ("no INTEGER type can hold a pointer on this configuration");
11855   else if (0 && ffe_is_do_internal_checks ())
11856     fprintf (stderr, "Pointer type kt=%d\n", ffecom_pointer_kind_);
11857   ffetype_set_kind (ffeinfo_type (FFEINFO_basictypeINTEGER,
11858                                   FFEINFO_kindtypeINTEGERDEFAULT),
11859                     7,
11860                     ffeinfo_type (FFEINFO_basictypeINTEGER,
11861                                   ffecom_pointer_kind_));
11862
11863   if (ffe_is_ugly_assign ())
11864     ffecom_label_kind_ = ffecom_pointer_kind_;  /* Require ASSIGN etc to this. */
11865   else
11866     ffecom_label_kind_ = FFEINFO_kindtypeINTEGERDEFAULT;
11867   if (0 && ffe_is_do_internal_checks ())
11868     fprintf (stderr, "Label type kt=%d\n", ffecom_label_kind_);
11869
11870   ffecom_integer_type_node
11871     = ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1];
11872   ffecom_integer_zero_node = convert (ffecom_integer_type_node,
11873                                       integer_zero_node);
11874   ffecom_integer_one_node = convert (ffecom_integer_type_node,
11875                                      integer_one_node);
11876
11877   /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional.
11878      Turns out that by TYLONG, runtime/libI77/lio.h really means
11879      "whatever size an ftnint is".  For consistency and sanity,
11880      com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen
11881      all are INTEGER, which we also make out of whatever back-end
11882      integer type is FLOAT_TYPE_SIZE bits wide.  This change, from
11883      LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to
11884      accommodate machines like the Alpha.  Note that this suggests
11885      f2c and libf2c are missing a distinction perhaps needed on
11886      some machines between "int" and "long int".  -- burley 0.5.5 950215 */
11887
11888   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, FLOAT_TYPE_SIZE,
11889                             FFETARGET_f2cTYLONG);
11890   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, SHORT_TYPE_SIZE,
11891                             FFETARGET_f2cTYSHORT);
11892   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, CHAR_TYPE_SIZE,
11893                             FFETARGET_f2cTYINT1);
11894   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, LONG_LONG_TYPE_SIZE,
11895                             FFETARGET_f2cTYQUAD);
11896   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, FLOAT_TYPE_SIZE,
11897                             FFETARGET_f2cTYLOGICAL);
11898   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, SHORT_TYPE_SIZE,
11899                             FFETARGET_f2cTYLOGICAL2);
11900   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, CHAR_TYPE_SIZE,
11901                             FFETARGET_f2cTYLOGICAL1);
11902   /* ~~~Not really such a type in libf2c, e.g. I/O support?  */
11903   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, LONG_LONG_TYPE_SIZE,
11904                             FFETARGET_f2cTYQUAD);
11905
11906   /* CHARACTER stuff is all special-cased, so it is not handled in the above
11907      loop.  CHARACTER items are built as arrays of unsigned char.  */
11908
11909   ffecom_tree_type[FFEINFO_basictypeCHARACTER]
11910     [FFEINFO_kindtypeCHARACTER1] = t = char_type_node;
11911   type = ffetype_new ();
11912   base_type = type;
11913   ffeinfo_set_type (FFEINFO_basictypeCHARACTER,
11914                     FFEINFO_kindtypeCHARACTER1,
11915                     type);
11916   ffetype_set_ams (type,
11917                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11918                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11919   ffetype_set_kind (base_type, 1, type);
11920   assert (ffetype_size (type)
11921           == sizeof (((ffetargetCharacter1) { 0, NULL }).text[0]));
11922
11923   ffecom_tree_fun_type[FFEINFO_basictypeCHARACTER]
11924     [FFEINFO_kindtypeCHARACTER1] = ffecom_tree_fun_type_void;
11925   ffecom_tree_ptr_to_fun_type[FFEINFO_basictypeCHARACTER]
11926     [FFEINFO_kindtypeCHARACTER1]
11927     = ffecom_tree_ptr_to_fun_type_void;
11928   ffecom_f2c_typecode_[FFEINFO_basictypeCHARACTER][FFEINFO_kindtypeCHARACTER1]
11929     = FFETARGET_f2cTYCHAR;
11930
11931   ffecom_f2c_typecode_[FFEINFO_basictypeANY][FFEINFO_kindtypeANY]
11932     = 0;
11933
11934   /* Make multi-return-value type and fields. */
11935
11936   ffecom_multi_type_node_ = make_node (UNION_TYPE);
11937
11938   field = NULL_TREE;
11939
11940   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11941     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11942       {
11943         char name[30];
11944
11945         if (ffecom_tree_type[i][j] == NULL_TREE)
11946           continue;             /* Not supported. */
11947         sprintf (&name[0], "bt_%s_kt_%s",
11948                  ffeinfo_basictype_string ((ffeinfoBasictype) i),
11949                  ffeinfo_kindtype_string ((ffeinfoKindtype) j));
11950         ffecom_multi_fields_[i][j] = build_decl (FIELD_DECL,
11951                                                  get_identifier (name),
11952                                                  ffecom_tree_type[i][j]);
11953         DECL_CONTEXT (ffecom_multi_fields_[i][j])
11954           = ffecom_multi_type_node_;
11955         DECL_ALIGN (ffecom_multi_fields_[i][j]) = 0;
11956         DECL_USER_ALIGN (ffecom_multi_fields_[i][j]) = 0;
11957         TREE_CHAIN (ffecom_multi_fields_[i][j]) = field;
11958         field = ffecom_multi_fields_[i][j];
11959       }
11960
11961   TYPE_FIELDS (ffecom_multi_type_node_) = field;
11962   layout_type (ffecom_multi_type_node_);
11963
11964   /* Subroutines usually return integer because they might have alternate
11965      returns. */
11966
11967   ffecom_tree_subr_type
11968     = build_function_type (integer_type_node, NULL_TREE);
11969   ffecom_tree_ptr_to_subr_type
11970     = build_pointer_type (ffecom_tree_subr_type);
11971   ffecom_tree_blockdata_type
11972     = build_function_type (void_type_node, NULL_TREE);
11973
11974   builtin_function ("__builtin_sqrtf", float_ftype_float,
11975                     BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrtf");
11976   builtin_function ("__builtin_fsqrt", double_ftype_double,
11977                     BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrt");
11978   builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble,
11979                     BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrtl");
11980   builtin_function ("__builtin_sinf", float_ftype_float,
11981                     BUILT_IN_SIN, BUILT_IN_NORMAL, "sinf");
11982   builtin_function ("__builtin_sin", double_ftype_double,
11983                     BUILT_IN_SIN, BUILT_IN_NORMAL, "sin");
11984   builtin_function ("__builtin_sinl", ldouble_ftype_ldouble,
11985                     BUILT_IN_SIN, BUILT_IN_NORMAL, "sinl");
11986   builtin_function ("__builtin_cosf", float_ftype_float,
11987                     BUILT_IN_COS, BUILT_IN_NORMAL, "cosf");
11988   builtin_function ("__builtin_cos", double_ftype_double,
11989                     BUILT_IN_COS, BUILT_IN_NORMAL, "cos");
11990   builtin_function ("__builtin_cosl", ldouble_ftype_ldouble,
11991                     BUILT_IN_COS, BUILT_IN_NORMAL, "cosl");
11992
11993 #if BUILT_FOR_270
11994   pedantic_lvalues = FALSE;
11995 #endif
11996
11997   ffecom_f2c_make_type_ (&ffecom_f2c_integer_type_node,
11998                          FFECOM_f2cINTEGER,
11999                          "integer");
12000   ffecom_f2c_make_type_ (&ffecom_f2c_address_type_node,
12001                          FFECOM_f2cADDRESS,
12002                          "address");
12003   ffecom_f2c_make_type_ (&ffecom_f2c_real_type_node,
12004                          FFECOM_f2cREAL,
12005                          "real");
12006   ffecom_f2c_make_type_ (&ffecom_f2c_doublereal_type_node,
12007                          FFECOM_f2cDOUBLEREAL,
12008                          "doublereal");
12009   ffecom_f2c_make_type_ (&ffecom_f2c_complex_type_node,
12010                          FFECOM_f2cCOMPLEX,
12011                          "complex");
12012   ffecom_f2c_make_type_ (&ffecom_f2c_doublecomplex_type_node,
12013                          FFECOM_f2cDOUBLECOMPLEX,
12014                          "doublecomplex");
12015   ffecom_f2c_make_type_ (&ffecom_f2c_longint_type_node,
12016                          FFECOM_f2cLONGINT,
12017                          "longint");
12018   ffecom_f2c_make_type_ (&ffecom_f2c_logical_type_node,
12019                          FFECOM_f2cLOGICAL,
12020                          "logical");
12021   ffecom_f2c_make_type_ (&ffecom_f2c_flag_type_node,
12022                          FFECOM_f2cFLAG,
12023                          "flag");
12024   ffecom_f2c_make_type_ (&ffecom_f2c_ftnlen_type_node,
12025                          FFECOM_f2cFTNLEN,
12026                          "ftnlen");
12027   ffecom_f2c_make_type_ (&ffecom_f2c_ftnint_type_node,
12028                          FFECOM_f2cFTNINT,
12029                          "ftnint");
12030
12031   ffecom_f2c_ftnlen_zero_node
12032     = convert (ffecom_f2c_ftnlen_type_node, integer_zero_node);
12033
12034   ffecom_f2c_ftnlen_one_node
12035     = convert (ffecom_f2c_ftnlen_type_node, integer_one_node);
12036
12037   ffecom_f2c_ftnlen_two_node = build_int_2 (2, 0);
12038   TREE_TYPE (ffecom_f2c_ftnlen_two_node) = ffecom_integer_type_node;
12039
12040   ffecom_f2c_ptr_to_ftnlen_type_node
12041     = build_pointer_type (ffecom_f2c_ftnlen_type_node);
12042
12043   ffecom_f2c_ptr_to_ftnint_type_node
12044     = build_pointer_type (ffecom_f2c_ftnint_type_node);
12045
12046   ffecom_f2c_ptr_to_integer_type_node
12047     = build_pointer_type (ffecom_f2c_integer_type_node);
12048
12049   ffecom_f2c_ptr_to_real_type_node
12050     = build_pointer_type (ffecom_f2c_real_type_node);
12051
12052   ffecom_float_zero_ = build_real (float_type_node, dconst0);
12053   ffecom_double_zero_ = build_real (double_type_node, dconst0);
12054   {
12055     REAL_VALUE_TYPE point_5;
12056
12057 #ifdef REAL_ARITHMETIC
12058     REAL_ARITHMETIC (point_5, RDIV_EXPR, dconst1, dconst2);
12059 #else
12060     point_5 = .5;
12061 #endif
12062     ffecom_float_half_ = build_real (float_type_node, point_5);
12063     ffecom_double_half_ = build_real (double_type_node, point_5);
12064   }
12065
12066   /* Do "extern int xargc;".  */
12067
12068   ffecom_tree_xargc_ = build_decl (VAR_DECL,
12069                                    get_identifier ("f__xargc"),
12070                                    integer_type_node);
12071   DECL_EXTERNAL (ffecom_tree_xargc_) = 1;
12072   TREE_STATIC (ffecom_tree_xargc_) = 1;
12073   TREE_PUBLIC (ffecom_tree_xargc_) = 1;
12074   ffecom_tree_xargc_ = start_decl (ffecom_tree_xargc_, FALSE);
12075   finish_decl (ffecom_tree_xargc_, NULL_TREE, FALSE);
12076
12077 #if 0   /* This is being fixed, and seems to be working now. */
12078   if ((FLOAT_TYPE_SIZE != 32)
12079       || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))) != 32))
12080     {
12081       warning ("configuration: REAL, INTEGER, and LOGICAL are %d bits wide,",
12082                (int) FLOAT_TYPE_SIZE);
12083       warning ("and pointers are %d bits wide, but g77 doesn't yet work",
12084           (int) TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))));
12085       warning ("properly unless they all are 32 bits wide.");
12086       warning ("Please keep this in mind before you report bugs.  g77 should");
12087       warning ("support non-32-bit machines better as of version 0.6.");
12088     }
12089 #endif
12090
12091 #if 0   /* Code in ste.c that would crash has been commented out. */
12092   if (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)
12093       < TYPE_PRECISION (string_type_node))
12094     /* I/O will probably crash.  */
12095     warning ("configuration: char * holds %d bits, but ftnlen only %d",
12096              TYPE_PRECISION (string_type_node),
12097              TYPE_PRECISION (ffecom_f2c_ftnlen_type_node));
12098 #endif
12099
12100 #if 0   /* ASSIGN-related stuff has been changed to accommodate this. */
12101   if (TYPE_PRECISION (ffecom_integer_type_node)
12102       < TYPE_PRECISION (string_type_node))
12103     /* ASSIGN 10 TO I will crash.  */
12104     warning ("configuration: char * holds %d bits, but INTEGER only %d --\n\
12105  ASSIGN statement might fail",
12106              TYPE_PRECISION (string_type_node),
12107              TYPE_PRECISION (ffecom_integer_type_node));
12108 #endif
12109 }
12110
12111 #endif
12112 /* ffecom_init_2 -- Initialize
12113
12114    ffecom_init_2();  */
12115
12116 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12117 void
12118 ffecom_init_2 ()
12119 {
12120   assert (ffecom_outer_function_decl_ == NULL_TREE);
12121   assert (current_function_decl == NULL_TREE);
12122   assert (ffecom_which_entrypoint_decl_ == NULL_TREE);
12123
12124   ffecom_master_arglist_ = NULL;
12125   ++ffecom_num_fns_;
12126   ffecom_primary_entry_ = NULL;
12127   ffecom_is_altreturning_ = FALSE;
12128   ffecom_func_result_ = NULL_TREE;
12129   ffecom_multi_retval_ = NULL_TREE;
12130 }
12131
12132 #endif
12133 /* ffecom_list_expr -- Transform list of exprs into gcc tree
12134
12135    tree t;
12136    ffebld expr;  // FFE opITEM list.
12137    tree = ffecom_list_expr(expr);
12138
12139    List of actual args is transformed into corresponding gcc backend list.  */
12140
12141 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12142 tree
12143 ffecom_list_expr (ffebld expr)
12144 {
12145   tree list;
12146   tree *plist = &list;
12147   tree trail = NULL_TREE;       /* Append char length args here. */
12148   tree *ptrail = &trail;
12149   tree length;
12150
12151   while (expr != NULL)
12152     {
12153       tree texpr = ffecom_arg_expr (ffebld_head (expr), &length);
12154
12155       if (texpr == error_mark_node)
12156         return error_mark_node;
12157
12158       *plist = build_tree_list (NULL_TREE, texpr);
12159       plist = &TREE_CHAIN (*plist);
12160       expr = ffebld_trail (expr);
12161       if (length != NULL_TREE)
12162         {
12163           *ptrail = build_tree_list (NULL_TREE, length);
12164           ptrail = &TREE_CHAIN (*ptrail);
12165         }
12166     }
12167
12168   *plist = trail;
12169
12170   return list;
12171 }
12172
12173 #endif
12174 /* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree
12175
12176    tree t;
12177    ffebld expr;  // FFE opITEM list.
12178    tree = ffecom_list_ptr_to_expr(expr);
12179
12180    List of actual args is transformed into corresponding gcc backend list for
12181    use in calling an external procedure (vs. a statement function).  */
12182
12183 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12184 tree
12185 ffecom_list_ptr_to_expr (ffebld expr)
12186 {
12187   tree list;
12188   tree *plist = &list;
12189   tree trail = NULL_TREE;       /* Append char length args here. */
12190   tree *ptrail = &trail;
12191   tree length;
12192
12193   while (expr != NULL)
12194     {
12195       tree texpr = ffecom_arg_ptr_to_expr (ffebld_head (expr), &length);
12196
12197       if (texpr == error_mark_node)
12198         return error_mark_node;
12199
12200       *plist = build_tree_list (NULL_TREE, texpr);
12201       plist = &TREE_CHAIN (*plist);
12202       expr = ffebld_trail (expr);
12203       if (length != NULL_TREE)
12204         {
12205           *ptrail = build_tree_list (NULL_TREE, length);
12206           ptrail = &TREE_CHAIN (*ptrail);
12207         }
12208     }
12209
12210   *plist = trail;
12211
12212   return list;
12213 }
12214
12215 #endif
12216 /* Obtain gcc's LABEL_DECL tree for label.  */
12217
12218 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12219 tree
12220 ffecom_lookup_label (ffelab label)
12221 {
12222   tree glabel;
12223
12224   if (ffelab_hook (label) == NULL_TREE)
12225     {
12226       char labelname[16];
12227
12228       switch (ffelab_type (label))
12229         {
12230         case FFELAB_typeLOOPEND:
12231         case FFELAB_typeNOTLOOP:
12232         case FFELAB_typeENDIF:
12233           sprintf (labelname, "%" ffelabValue_f "u", ffelab_value (label));
12234           glabel = build_decl (LABEL_DECL, get_identifier (labelname),
12235                                void_type_node);
12236           DECL_CONTEXT (glabel) = current_function_decl;
12237           DECL_MODE (glabel) = VOIDmode;
12238           break;
12239
12240         case FFELAB_typeFORMAT:
12241           glabel = build_decl (VAR_DECL,
12242                                ffecom_get_invented_identifier
12243                                ("__g77_format_%d", (int) ffelab_value (label)),
12244                                build_type_variant (build_array_type
12245                                                    (char_type_node,
12246                                                     NULL_TREE),
12247                                                    1, 0));
12248           TREE_CONSTANT (glabel) = 1;
12249           TREE_STATIC (glabel) = 1;
12250           DECL_CONTEXT (glabel) = current_function_decl;
12251           DECL_INITIAL (glabel) = NULL;
12252           make_decl_rtl (glabel, NULL);
12253           expand_decl (glabel);
12254
12255           ffecom_save_tree_forever (glabel);
12256
12257           break;
12258
12259         case FFELAB_typeANY:
12260           glabel = error_mark_node;
12261           break;
12262
12263         default:
12264           assert ("bad label type" == NULL);
12265           glabel = NULL;
12266           break;
12267         }
12268       ffelab_set_hook (label, glabel);
12269     }
12270   else
12271     {
12272       glabel = ffelab_hook (label);
12273     }
12274
12275   return glabel;
12276 }
12277
12278 #endif
12279 /* Stabilizes the arguments.  Don't use this if the lhs and rhs come from
12280    a single source specification (as in the fourth argument of MVBITS).
12281    If the type is NULL_TREE, the type of lhs is used to make the type of
12282    the MODIFY_EXPR.  */
12283
12284 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12285 tree
12286 ffecom_modify (tree newtype, tree lhs,
12287                tree rhs)
12288 {
12289   if (lhs == error_mark_node || rhs == error_mark_node)
12290     return error_mark_node;
12291
12292   if (newtype == NULL_TREE)
12293     newtype = TREE_TYPE (lhs);
12294
12295   if (TREE_SIDE_EFFECTS (lhs))
12296     lhs = stabilize_reference (lhs);
12297
12298   return ffecom_2s (MODIFY_EXPR, newtype, lhs, rhs);
12299 }
12300
12301 #endif
12302
12303 /* Register source file name.  */
12304
12305 void
12306 ffecom_file (const char *name)
12307 {
12308 #if FFECOM_GCC_INCLUDE
12309   ffecom_file_ (name);
12310 #endif
12311 }
12312
12313 /* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed
12314
12315    ffestorag st;
12316    ffecom_notify_init_storage(st);
12317
12318    Gets called when all possible units in an aggregate storage area (a LOCAL
12319    with equivalences or a COMMON) have been initialized.  The initialization
12320    info either is in ffestorag_init or, if that is NULL,
12321    ffestorag_accretion:
12322
12323    ffestorag_init may contain an opCONTER or opARRTER.  opCONTER may occur
12324    even for an array if the array is one element in length!
12325
12326    ffestorag_accretion will contain an opACCTER.  It is much like an
12327    opARRTER except it has an ffebit object in it instead of just a size.
12328    The back end can use the info in the ffebit object, if it wants, to
12329    reduce the amount of actual initialization, but in any case it should
12330    kill the ffebit object when done.  Also, set accretion to NULL but
12331    init to a non-NULL value.
12332
12333    After performing initialization, DO NOT set init to NULL, because that'll
12334    tell the front end it is ok for more initialization to happen.  Instead,
12335    set init to an opANY expression or some such thing that you can use to
12336    tell that you've already initialized the object.
12337
12338    27-Oct-91  JCB  1.1
12339       Support two-pass FFE.  */
12340
12341 void
12342 ffecom_notify_init_storage (ffestorag st)
12343 {
12344   ffebld init;                  /* The initialization expression. */
12345 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12346   ffetargetOffset size;         /* The size of the entity. */
12347   ffetargetAlign pad;           /* Its initial padding. */
12348 #endif
12349
12350   if (ffestorag_init (st) == NULL)
12351     {
12352       init = ffestorag_accretion (st);
12353       assert (init != NULL);
12354       ffestorag_set_accretion (st, NULL);
12355       ffestorag_set_accretes (st, 0);
12356
12357 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12358       /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
12359       size = ffebld_accter_size (init);
12360       pad = ffebld_accter_pad (init);
12361       ffebit_kill (ffebld_accter_bits (init));
12362       ffebld_set_op (init, FFEBLD_opARRTER);
12363       ffebld_set_arrter (init, ffebld_accter (init));
12364       ffebld_arrter_set_size (init, size);
12365       ffebld_arrter_set_pad (init, size);
12366 #endif
12367
12368 #if FFECOM_TWOPASS
12369       ffestorag_set_init (st, init);
12370 #endif
12371     }
12372 #if FFECOM_ONEPASS
12373   else
12374     init = ffestorag_init (st);
12375 #endif
12376
12377 #if FFECOM_ONEPASS              /* Process the inits, wipe 'em out. */
12378   ffestorag_set_init (st, ffebld_new_any ());
12379
12380   if (ffebld_op (init) == FFEBLD_opANY)
12381     return;                     /* Oh, we already did this! */
12382
12383 #if FFECOM_targetCURRENT == FFECOM_targetFFE
12384   {
12385     ffesymbol s;
12386
12387     if (ffestorag_symbol (st) != NULL)
12388       s = ffestorag_symbol (st);
12389     else
12390       s = ffestorag_typesymbol (st);
12391
12392     fprintf (dmpout, "= initialize_storage \"%s\" ",
12393              (s != NULL) ? ffesymbol_text (s) : "(unnamed)");
12394     ffebld_dump (init);
12395     fputc ('\n', dmpout);
12396   }
12397 #endif
12398
12399 #endif /* if FFECOM_ONEPASS */
12400 }
12401
12402 /* ffecom_notify_init_symbol -- A symbol is now fully init'ed
12403
12404    ffesymbol s;
12405    ffecom_notify_init_symbol(s);
12406
12407    Gets called when all possible units in a symbol (not placed in COMMON
12408    or involved in EQUIVALENCE, unless it as yet has no ffestorag object)
12409    have been initialized.  The initialization info either is in
12410    ffesymbol_init or, if that is NULL, ffesymbol_accretion:
12411
12412    ffesymbol_init may contain an opCONTER or opARRTER.  opCONTER may occur
12413    even for an array if the array is one element in length!
12414
12415    ffesymbol_accretion will contain an opACCTER.  It is much like an
12416    opARRTER except it has an ffebit object in it instead of just a size.
12417    The back end can use the info in the ffebit object, if it wants, to
12418    reduce the amount of actual initialization, but in any case it should
12419    kill the ffebit object when done.  Also, set accretion to NULL but
12420    init to a non-NULL value.
12421
12422    After performing initialization, DO NOT set init to NULL, because that'll
12423    tell the front end it is ok for more initialization to happen.  Instead,
12424    set init to an opANY expression or some such thing that you can use to
12425    tell that you've already initialized the object.
12426
12427    27-Oct-91  JCB  1.1
12428       Support two-pass FFE.  */
12429
12430 void
12431 ffecom_notify_init_symbol (ffesymbol s)
12432 {
12433   ffebld init;                  /* The initialization expression. */
12434 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12435   ffetargetOffset size;         /* The size of the entity. */
12436   ffetargetAlign pad;           /* Its initial padding. */
12437 #endif
12438
12439   if (ffesymbol_storage (s) == NULL)
12440     return;                     /* Do nothing until COMMON/EQUIVALENCE
12441                                    possibilities checked. */
12442
12443   if ((ffesymbol_init (s) == NULL)
12444       && ((init = ffesymbol_accretion (s)) != NULL))
12445     {
12446       ffesymbol_set_accretion (s, NULL);
12447       ffesymbol_set_accretes (s, 0);
12448
12449 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12450       /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
12451       size = ffebld_accter_size (init);
12452       pad = ffebld_accter_pad (init);
12453       ffebit_kill (ffebld_accter_bits (init));
12454       ffebld_set_op (init, FFEBLD_opARRTER);
12455       ffebld_set_arrter (init, ffebld_accter (init));
12456       ffebld_arrter_set_size (init, size);
12457       ffebld_arrter_set_pad (init, size);
12458 #endif
12459
12460 #if FFECOM_TWOPASS
12461       ffesymbol_set_init (s, init);
12462 #endif
12463     }
12464 #if FFECOM_ONEPASS
12465   else
12466     init = ffesymbol_init (s);
12467 #endif
12468
12469 #if FFECOM_ONEPASS
12470   ffesymbol_set_init (s, ffebld_new_any ());
12471
12472   if (ffebld_op (init) == FFEBLD_opANY)
12473     return;                     /* Oh, we already did this! */
12474
12475 #if FFECOM_targetCURRENT == FFECOM_targetFFE
12476   fprintf (dmpout, "= initialize_symbol \"%s\" ", ffesymbol_text (s));
12477   ffebld_dump (init);
12478   fputc ('\n', dmpout);
12479 #endif
12480
12481 #endif /* if FFECOM_ONEPASS */
12482 }
12483
12484 /* ffecom_notify_primary_entry -- Learn which is the primary entry point
12485
12486    ffesymbol s;
12487    ffecom_notify_primary_entry(s);
12488
12489    Gets called when implicit or explicit PROGRAM statement seen or when
12490    FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary
12491    global symbol that serves as the entry point.  */
12492
12493 void
12494 ffecom_notify_primary_entry (ffesymbol s)
12495 {
12496   ffecom_primary_entry_ = s;
12497   ffecom_primary_entry_kind_ = ffesymbol_kind (s);
12498
12499   if ((ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
12500       || (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE))
12501     ffecom_primary_entry_is_proc_ = TRUE;
12502   else
12503     ffecom_primary_entry_is_proc_ = FALSE;
12504
12505   if (!ffe_is_silent ())
12506     {
12507       if (ffecom_primary_entry_kind_ == FFEINFO_kindPROGRAM)
12508         fprintf (stderr, "%s:\n", ffesymbol_text (s));
12509       else
12510         fprintf (stderr, "  %s:\n", ffesymbol_text (s));
12511     }
12512
12513 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12514   if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
12515     {
12516       ffebld list;
12517       ffebld arg;
12518
12519       for (list = ffesymbol_dummyargs (s);
12520            list != NULL;
12521            list = ffebld_trail (list))
12522         {
12523           arg = ffebld_head (list);
12524           if (ffebld_op (arg) == FFEBLD_opSTAR)
12525             {
12526               ffecom_is_altreturning_ = TRUE;
12527               break;
12528             }
12529         }
12530     }
12531 #endif
12532 }
12533
12534 FILE *
12535 ffecom_open_include (char *name, ffewhereLine l, ffewhereColumn c)
12536 {
12537 #if FFECOM_GCC_INCLUDE
12538   return ffecom_open_include_ (name, l, c);
12539 #else
12540   return fopen (name, "r");
12541 #endif
12542 }
12543
12544 /* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front
12545
12546    tree t;
12547    ffebld expr;  // FFE expression.
12548    tree = ffecom_ptr_to_expr(expr);
12549
12550    Like ffecom_expr, but sticks address-of in front of most things.  */
12551
12552 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12553 tree
12554 ffecom_ptr_to_expr (ffebld expr)
12555 {
12556   tree item;
12557   ffeinfoBasictype bt;
12558   ffeinfoKindtype kt;
12559   ffesymbol s;
12560
12561   assert (expr != NULL);
12562
12563   switch (ffebld_op (expr))
12564     {
12565     case FFEBLD_opSYMTER:
12566       s = ffebld_symter (expr);
12567       if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
12568         {
12569           ffecomGfrt ix;
12570
12571           ix = ffeintrin_gfrt_indirect (ffebld_symter_implementation (expr));
12572           assert (ix != FFECOM_gfrt);
12573           if ((item = ffecom_gfrt_[ix]) == NULL_TREE)
12574             {
12575               ffecom_make_gfrt_ (ix);
12576               item = ffecom_gfrt_[ix];
12577             }
12578         }
12579       else
12580         {
12581           item = ffesymbol_hook (s).decl_tree;
12582           if (item == NULL_TREE)
12583             {
12584               s = ffecom_sym_transform_ (s);
12585               item = ffesymbol_hook (s).decl_tree;
12586             }
12587         }
12588       assert (item != NULL);
12589       if (item == error_mark_node)
12590         return item;
12591       if (!ffesymbol_hook (s).addr)
12592         item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12593                          item);
12594       return item;
12595
12596     case FFEBLD_opARRAYREF:
12597       return ffecom_arrayref_ (NULL_TREE, expr, 1);
12598
12599     case FFEBLD_opCONTER:
12600
12601       bt = ffeinfo_basictype (ffebld_info (expr));
12602       kt = ffeinfo_kindtype (ffebld_info (expr));
12603
12604       item = ffecom_constantunion (&ffebld_constant_union
12605                                    (ffebld_conter (expr)), bt, kt,
12606                                    ffecom_tree_type[bt][kt]);
12607       if (item == error_mark_node)
12608         return error_mark_node;
12609       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12610                        item);
12611       return item;
12612
12613     case FFEBLD_opANY:
12614       return error_mark_node;
12615
12616     default:
12617       bt = ffeinfo_basictype (ffebld_info (expr));
12618       kt = ffeinfo_kindtype (ffebld_info (expr));
12619
12620       item = ffecom_expr (expr);
12621       if (item == error_mark_node)
12622         return error_mark_node;
12623
12624       /* The back end currently optimizes a bit too zealously for us, in that
12625          we fail JCB001 if the following block of code is omitted.  It checks
12626          to see if the transformed expression is a symbol or array reference,
12627          and encloses it in a SAVE_EXPR if that is the case.  */
12628
12629       STRIP_NOPS (item);
12630       if ((TREE_CODE (item) == VAR_DECL)
12631           || (TREE_CODE (item) == PARM_DECL)
12632           || (TREE_CODE (item) == RESULT_DECL)
12633           || (TREE_CODE (item) == INDIRECT_REF)
12634           || (TREE_CODE (item) == ARRAY_REF)
12635           || (TREE_CODE (item) == COMPONENT_REF)
12636 #ifdef OFFSET_REF
12637           || (TREE_CODE (item) == OFFSET_REF)
12638 #endif
12639           || (TREE_CODE (item) == BUFFER_REF)
12640           || (TREE_CODE (item) == REALPART_EXPR)
12641           || (TREE_CODE (item) == IMAGPART_EXPR))
12642         {
12643           item = ffecom_save_tree (item);
12644         }
12645
12646       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12647                        item);
12648       return item;
12649     }
12650
12651   assert ("fall-through error" == NULL);
12652   return error_mark_node;
12653 }
12654
12655 #endif
12656 /* Obtain a temp var with given data type.
12657
12658    size is FFETARGET_charactersizeNONE for a non-CHARACTER type
12659    or >= 0 for a CHARACTER type.
12660
12661    elements is -1 for a scalar or > 0 for an array of type.  */
12662
12663 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12664 tree
12665 ffecom_make_tempvar (const char *commentary, tree type,
12666                      ffetargetCharacterSize size, int elements)
12667 {
12668   tree t;
12669   static int mynumber;
12670
12671   assert (current_binding_level->prep_state < 2);
12672
12673   if (type == error_mark_node)
12674     return error_mark_node;
12675
12676   if (size != FFETARGET_charactersizeNONE)
12677     type = build_array_type (type,
12678                              build_range_type (ffecom_f2c_ftnlen_type_node,
12679                                                ffecom_f2c_ftnlen_one_node,
12680                                                build_int_2 (size, 0)));
12681   if (elements != -1)
12682     type = build_array_type (type,
12683                              build_range_type (integer_type_node,
12684                                                integer_zero_node,
12685                                                build_int_2 (elements - 1,
12686                                                             0)));
12687   t = build_decl (VAR_DECL,
12688                   ffecom_get_invented_identifier ("__g77_%s_%d",
12689                                                   commentary,
12690                                                   mynumber++),
12691                   type);
12692
12693   t = start_decl (t, FALSE);
12694   finish_decl (t, NULL_TREE, FALSE);
12695
12696   return t;
12697 }
12698 #endif
12699
12700 /* Prepare argument pointer to expression.
12701
12702    Like ffecom_prepare_expr, except for expressions to be evaluated
12703    via ffecom_arg_ptr_to_expr.  */
12704
12705 void
12706 ffecom_prepare_arg_ptr_to_expr (ffebld expr)
12707 {
12708   /* ~~For now, it seems to be the same thing.  */
12709   ffecom_prepare_expr (expr);
12710   return;
12711 }
12712
12713 /* End of preparations.  */
12714
12715 bool
12716 ffecom_prepare_end (void)
12717 {
12718   int prep_state = current_binding_level->prep_state;
12719
12720   assert (prep_state < 2);
12721   current_binding_level->prep_state = 2;
12722
12723   return (prep_state == 1) ? TRUE : FALSE;
12724 }
12725
12726 /* Prepare expression.
12727
12728    This is called before any code is generated for the current block.
12729    It scans the expression, declares any temporaries that might be needed
12730    during evaluation of the expression, and stores those temporaries in
12731    the appropriate "hook" fields of the expression.  `dest', if not NULL,
12732    specifies the destination that ffecom_expr_ will see, in case that
12733    helps avoid generating unused temporaries.
12734
12735    ~~Improve to avoid allocating unused temporaries by taking `dest'
12736    into account vis-a-vis aliasing requirements of complex/character
12737    functions.  */
12738
12739 void
12740 ffecom_prepare_expr_ (ffebld expr, ffebld dest UNUSED)
12741 {
12742   ffeinfoBasictype bt;
12743   ffeinfoKindtype kt;
12744   ffetargetCharacterSize sz;
12745   tree tempvar = NULL_TREE;
12746
12747   assert (current_binding_level->prep_state < 2);
12748
12749   if (! expr)
12750     return;
12751
12752   bt = ffeinfo_basictype (ffebld_info (expr));
12753   kt = ffeinfo_kindtype (ffebld_info (expr));
12754   sz = ffeinfo_size (ffebld_info (expr));
12755
12756   /* Generate whatever temporaries are needed to represent the result
12757      of the expression.  */
12758
12759   if (bt == FFEINFO_basictypeCHARACTER)
12760     {
12761       while (ffebld_op (expr) == FFEBLD_opPAREN)
12762         expr = ffebld_left (expr);
12763     }
12764
12765   switch (ffebld_op (expr))
12766     {
12767     default:
12768       /* Don't make temps for SYMTER, CONTER, etc.  */
12769       if (ffebld_arity (expr) == 0)
12770         break;
12771
12772       switch (bt)
12773         {
12774         case FFEINFO_basictypeCOMPLEX:
12775           if (ffebld_op (expr) == FFEBLD_opFUNCREF)
12776             {
12777               ffesymbol s;
12778
12779               if (ffebld_op (ffebld_left (expr)) != FFEBLD_opSYMTER)
12780                 break;
12781
12782               s = ffebld_symter (ffebld_left (expr));
12783               if (ffesymbol_where (s) == FFEINFO_whereCONSTANT
12784                   || (ffesymbol_where (s) != FFEINFO_whereINTRINSIC
12785                       && ! ffesymbol_is_f2c (s))
12786                   || (ffesymbol_where (s) == FFEINFO_whereINTRINSIC
12787                       && ! ffe_is_f2c_library ()))
12788                 break;
12789             }
12790           else if (ffebld_op (expr) == FFEBLD_opPOWER)
12791             {
12792               /* Requires special treatment.  There's no POW_CC function
12793                  in libg2c, so POW_ZZ is used, which means we always
12794                  need a double-complex temp, not a single-complex.  */
12795               kt = FFEINFO_kindtypeREAL2;
12796             }
12797           else if (ffebld_op (expr) != FFEBLD_opDIVIDE)
12798             /* The other ops don't need temps for complex operands.  */
12799             break;
12800
12801           /* ~~~Avoid making temps for some intrinsics, such as AIMAG(C),
12802              REAL(C).  See 19990325-0.f, routine `check', for cases.  */
12803           tempvar = ffecom_make_tempvar ("complex",
12804                                          ffecom_tree_type
12805                                          [FFEINFO_basictypeCOMPLEX][kt],
12806                                          FFETARGET_charactersizeNONE,
12807                                          -1);
12808           break;
12809
12810         case FFEINFO_basictypeCHARACTER:
12811           if (ffebld_op (expr) != FFEBLD_opFUNCREF)
12812             break;
12813
12814           if (sz == FFETARGET_charactersizeNONE)
12815             /* ~~Kludge alert!  This should someday be fixed. */
12816             sz = 24;
12817
12818           tempvar = ffecom_make_tempvar ("char", char_type_node, sz, -1);
12819           break;
12820
12821         default:
12822           break;
12823         }
12824       break;
12825
12826 #ifdef HAHA
12827     case FFEBLD_opPOWER:
12828       {
12829         tree rtype, ltype;
12830         tree rtmp, ltmp, result;
12831
12832         ltype = ffecom_type_expr (ffebld_left (expr));
12833         rtype = ffecom_type_expr (ffebld_right (expr));
12834
12835         rtmp = ffecom_make_tempvar (rtype, FFETARGET_charactersizeNONE, -1);
12836         ltmp = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
12837         result = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
12838
12839         tempvar = make_tree_vec (3);
12840         TREE_VEC_ELT (tempvar, 0) = rtmp;
12841         TREE_VEC_ELT (tempvar, 1) = ltmp;
12842         TREE_VEC_ELT (tempvar, 2) = result;
12843       }
12844       break;
12845 #endif  /* HAHA */
12846
12847     case FFEBLD_opCONCATENATE:
12848       {
12849         /* This gets special handling, because only one set of temps
12850            is needed for a tree of these -- the tree is treated as
12851            a flattened list of concatenations when generating code.  */
12852
12853         ffecomConcatList_ catlist;
12854         tree ltmp, itmp, result;
12855         int count;
12856         int i;
12857
12858         catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
12859         count = ffecom_concat_list_count_ (catlist);
12860
12861         if (count >= 2)
12862           {
12863             ltmp
12864               = ffecom_make_tempvar ("concat_len",
12865                                      ffecom_f2c_ftnlen_type_node,
12866                                      FFETARGET_charactersizeNONE, count);
12867             itmp
12868               = ffecom_make_tempvar ("concat_item",
12869                                      ffecom_f2c_address_type_node,
12870                                      FFETARGET_charactersizeNONE, count);
12871             result
12872               = ffecom_make_tempvar ("concat_res",
12873                                      char_type_node,
12874                                      ffecom_concat_list_maxlen_ (catlist),
12875                                      -1);
12876
12877             tempvar = make_tree_vec (3);
12878             TREE_VEC_ELT (tempvar, 0) = ltmp;
12879             TREE_VEC_ELT (tempvar, 1) = itmp;
12880             TREE_VEC_ELT (tempvar, 2) = result;
12881           }
12882
12883         for (i = 0; i < count; ++i)
12884           ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist,
12885                                                                     i));
12886
12887         ffecom_concat_list_kill_ (catlist);
12888
12889         if (tempvar)
12890           {
12891             ffebld_nonter_set_hook (expr, tempvar);
12892             current_binding_level->prep_state = 1;
12893           }
12894       }
12895       return;
12896
12897     case FFEBLD_opCONVERT:
12898       if (bt == FFEINFO_basictypeCHARACTER
12899           && ((ffebld_size_known (ffebld_left (expr))
12900                == FFETARGET_charactersizeNONE)
12901               || (ffebld_size_known (ffebld_left (expr)) >= sz)))
12902         tempvar = ffecom_make_tempvar ("convert", char_type_node, sz, -1);
12903       break;
12904     }
12905
12906   if (tempvar)
12907     {
12908       ffebld_nonter_set_hook (expr, tempvar);
12909       current_binding_level->prep_state = 1;
12910     }
12911
12912   /* Prepare subexpressions for this expr.  */
12913
12914   switch (ffebld_op (expr))
12915     {
12916     case FFEBLD_opPERCENT_LOC:
12917       ffecom_prepare_ptr_to_expr (ffebld_left (expr));
12918       break;
12919
12920     case FFEBLD_opPERCENT_VAL:
12921     case FFEBLD_opPERCENT_REF:
12922       ffecom_prepare_expr (ffebld_left (expr));
12923       break;
12924
12925     case FFEBLD_opPERCENT_DESCR:
12926       ffecom_prepare_arg_ptr_to_expr (ffebld_left (expr));
12927       break;
12928
12929     case FFEBLD_opITEM:
12930       {
12931         ffebld item;
12932
12933         for (item = expr;
12934              item != NULL;
12935              item = ffebld_trail (item))
12936           if (ffebld_head (item) != NULL)
12937             ffecom_prepare_expr (ffebld_head (item));
12938       }
12939       break;
12940
12941     default:
12942       /* Need to handle character conversion specially.  */
12943       switch (ffebld_arity (expr))
12944         {
12945         case 2:
12946           ffecom_prepare_expr (ffebld_left (expr));
12947           ffecom_prepare_expr (ffebld_right (expr));
12948           break;
12949
12950         case 1:
12951           ffecom_prepare_expr (ffebld_left (expr));
12952           break;
12953
12954         default:
12955           break;
12956         }
12957     }
12958
12959   return;
12960 }
12961
12962 /* Prepare expression for reading and writing.
12963
12964    Like ffecom_prepare_expr, except for expressions to be evaluated
12965    via ffecom_expr_rw.  */
12966
12967 void
12968 ffecom_prepare_expr_rw (tree type, ffebld expr)
12969 {
12970   /* This is all we support for now.  */
12971   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
12972
12973   /* ~~For now, it seems to be the same thing.  */
12974   ffecom_prepare_expr (expr);
12975   return;
12976 }
12977
12978 /* Prepare expression for writing.
12979
12980    Like ffecom_prepare_expr, except for expressions to be evaluated
12981    via ffecom_expr_w.  */
12982
12983 void
12984 ffecom_prepare_expr_w (tree type, ffebld expr)
12985 {
12986   /* This is all we support for now.  */
12987   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
12988
12989   /* ~~For now, it seems to be the same thing.  */
12990   ffecom_prepare_expr (expr);
12991   return;
12992 }
12993
12994 /* Prepare expression for returning.
12995
12996    Like ffecom_prepare_expr, except for expressions to be evaluated
12997    via ffecom_return_expr.  */
12998
12999 void
13000 ffecom_prepare_return_expr (ffebld expr)
13001 {
13002   assert (current_binding_level->prep_state < 2);
13003
13004   if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE
13005       && ffecom_is_altreturning_
13006       && expr != NULL)
13007     ffecom_prepare_expr (expr);
13008 }
13009
13010 /* Prepare pointer to expression.
13011
13012    Like ffecom_prepare_expr, except for expressions to be evaluated
13013    via ffecom_ptr_to_expr.  */
13014
13015 void
13016 ffecom_prepare_ptr_to_expr (ffebld expr)
13017 {
13018   /* ~~For now, it seems to be the same thing.  */
13019   ffecom_prepare_expr (expr);
13020   return;
13021 }
13022
13023 /* Transform expression into constant pointer-to-expression tree.
13024
13025    If the expression can be transformed into a pointer-to-expression tree
13026    that is constant, that is done, and the tree returned.  Else NULL_TREE
13027    is returned.
13028
13029    That way, a caller can attempt to provide compile-time initialization
13030    of a variable and, if that fails, *then* choose to start a new block
13031    and resort to using temporaries, as appropriate.  */
13032
13033 tree
13034 ffecom_ptr_to_const_expr (ffebld expr)
13035 {
13036   if (! expr)
13037     return integer_zero_node;
13038
13039   if (ffebld_op (expr) == FFEBLD_opANY)
13040     return error_mark_node;
13041
13042   if (ffebld_arity (expr) == 0
13043       && (ffebld_op (expr) != FFEBLD_opSYMTER
13044           || ffebld_where (expr) == FFEINFO_whereCOMMON
13045           || ffebld_where (expr) == FFEINFO_whereGLOBAL
13046           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
13047     {
13048       tree t;
13049
13050       t = ffecom_ptr_to_expr (expr);
13051       assert (TREE_CONSTANT (t));
13052       return t;
13053     }
13054
13055   return NULL_TREE;
13056 }
13057
13058 /* ffecom_return_expr -- Returns return-value expr given alt return expr
13059
13060    tree rtn;  // NULL_TREE means use expand_null_return()
13061    ffebld expr;  // NULL if no alt return expr to RETURN stmt
13062    rtn = ffecom_return_expr(expr);
13063
13064    Based on the program unit type and other info (like return function
13065    type, return master function type when alternate ENTRY points,
13066    whether subroutine has any alternate RETURN points, etc), returns the
13067    appropriate expression to be returned to the caller, or NULL_TREE
13068    meaning no return value or the caller expects it to be returned somewhere
13069    else (which is handled by other parts of this module).  */
13070
13071 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13072 tree
13073 ffecom_return_expr (ffebld expr)
13074 {
13075   tree rtn;
13076
13077   switch (ffecom_primary_entry_kind_)
13078     {
13079     case FFEINFO_kindPROGRAM:
13080     case FFEINFO_kindBLOCKDATA:
13081       rtn = NULL_TREE;
13082       break;
13083
13084     case FFEINFO_kindSUBROUTINE:
13085       if (!ffecom_is_altreturning_)
13086         rtn = NULL_TREE;        /* No alt returns, never an expr. */
13087       else if (expr == NULL)
13088         rtn = integer_zero_node;
13089       else
13090         rtn = ffecom_expr (expr);
13091       break;
13092
13093     case FFEINFO_kindFUNCTION:
13094       if ((ffecom_multi_retval_ != NULL_TREE)
13095           || (ffesymbol_basictype (ffecom_primary_entry_)
13096               == FFEINFO_basictypeCHARACTER)
13097           || ((ffesymbol_basictype (ffecom_primary_entry_)
13098                == FFEINFO_basictypeCOMPLEX)
13099               && (ffecom_num_entrypoints_ == 0)
13100               && ffesymbol_is_f2c (ffecom_primary_entry_)))
13101         {                       /* Value is returned by direct assignment
13102                                    into (implicit) dummy. */
13103           rtn = NULL_TREE;
13104           break;
13105         }
13106       rtn = ffecom_func_result_;
13107 #if 0
13108       /* Spurious error if RETURN happens before first reference!  So elide
13109          this code.  In particular, for debugging registry, rtn should always
13110          be non-null after all, but TREE_USED won't be set until we encounter
13111          a reference in the code.  Perfectly okay (but weird) code that,
13112          e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in
13113          this diagnostic for no reason.  Have people use -O -Wuninitialized
13114          and leave it to the back end to find obviously weird cases.  */
13115
13116       /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid
13117          situation; if the return value has never been referenced, it won't
13118          have a tree under 2pass mode. */
13119       if ((rtn == NULL_TREE)
13120           || !TREE_USED (rtn))
13121         {
13122           ffebad_start (FFEBAD_RETURN_VALUE_UNSET);
13123           ffebad_here (0, ffesymbol_where_line (ffecom_primary_entry_),
13124                        ffesymbol_where_column (ffecom_primary_entry_));
13125           ffebad_string (ffesymbol_text (ffesymbol_funcresult
13126                                          (ffecom_primary_entry_)));
13127           ffebad_finish ();
13128         }
13129 #endif
13130       break;
13131
13132     default:
13133       assert ("bad unit kind" == NULL);
13134     case FFEINFO_kindANY:
13135       rtn = error_mark_node;
13136       break;
13137     }
13138
13139   return rtn;
13140 }
13141
13142 #endif
13143 /* Do save_expr only if tree is not error_mark_node.  */
13144
13145 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13146 tree
13147 ffecom_save_tree (tree t)
13148 {
13149   return save_expr (t);
13150 }
13151 #endif
13152
13153 /* Start a compound statement (block).  */
13154
13155 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13156 void
13157 ffecom_start_compstmt (void)
13158 {
13159   bison_rule_pushlevel_ ();
13160 }
13161 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
13162
13163 /* Public entry point for front end to access start_decl.  */
13164
13165 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13166 tree
13167 ffecom_start_decl (tree decl, bool is_initialized)
13168 {
13169   DECL_INITIAL (decl) = is_initialized ? error_mark_node : NULL_TREE;
13170   return start_decl (decl, FALSE);
13171 }
13172
13173 #endif
13174 /* ffecom_sym_commit -- Symbol's state being committed to reality
13175
13176    ffesymbol s;
13177    ffecom_sym_commit(s);
13178
13179    Does whatever the backend needs when a symbol is committed after having
13180    been backtrackable for a period of time.  */
13181
13182 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13183 void
13184 ffecom_sym_commit (ffesymbol s UNUSED)
13185 {
13186   assert (!ffesymbol_retractable ());
13187 }
13188
13189 #endif
13190 /* ffecom_sym_end_transition -- Perform end transition on all symbols
13191
13192    ffecom_sym_end_transition();
13193
13194    Does backend-specific stuff and also calls ffest_sym_end_transition
13195    to do the necessary FFE stuff.
13196
13197    Backtracking is never enabled when this fn is called, so don't worry
13198    about it.  */
13199
13200 ffesymbol
13201 ffecom_sym_end_transition (ffesymbol s)
13202 {
13203   ffestorag st;
13204
13205   assert (!ffesymbol_retractable ());
13206
13207   s = ffest_sym_end_transition (s);
13208
13209 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13210   if ((ffesymbol_kind (s) == FFEINFO_kindBLOCKDATA)
13211       && (ffesymbol_where (s) == FFEINFO_whereGLOBAL))
13212     {
13213       ffecom_list_blockdata_
13214         = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
13215                                               FFEINTRIN_specNONE,
13216                                               FFEINTRIN_impNONE),
13217                            ffecom_list_blockdata_);
13218     }
13219 #endif
13220
13221   /* This is where we finally notice that a symbol has partial initialization
13222      and finalize it. */
13223
13224   if (ffesymbol_accretion (s) != NULL)
13225     {
13226       assert (ffesymbol_init (s) == NULL);
13227       ffecom_notify_init_symbol (s);
13228     }
13229   else if (((st = ffesymbol_storage (s)) != NULL)
13230            && ((st = ffestorag_parent (st)) != NULL)
13231            && (ffestorag_accretion (st) != NULL))
13232     {
13233       assert (ffestorag_init (st) == NULL);
13234       ffecom_notify_init_storage (st);
13235     }
13236
13237 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13238   if ((ffesymbol_kind (s) == FFEINFO_kindCOMMON)
13239       && (ffesymbol_where (s) == FFEINFO_whereLOCAL)
13240       && (ffesymbol_storage (s) != NULL))
13241     {
13242       ffecom_list_common_
13243         = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
13244                                               FFEINTRIN_specNONE,
13245                                               FFEINTRIN_impNONE),
13246                            ffecom_list_common_);
13247     }
13248 #endif
13249
13250   return s;
13251 }
13252
13253 /* ffecom_sym_exec_transition -- Perform exec transition on all symbols
13254
13255    ffecom_sym_exec_transition();
13256
13257    Does backend-specific stuff and also calls ffest_sym_exec_transition
13258    to do the necessary FFE stuff.
13259
13260    See the long-winded description in ffecom_sym_learned for info
13261    on handling the situation where backtracking is inhibited.  */
13262
13263 ffesymbol
13264 ffecom_sym_exec_transition (ffesymbol s)
13265 {
13266   s = ffest_sym_exec_transition (s);
13267
13268   return s;
13269 }
13270
13271 /* ffecom_sym_learned -- Initial or more info gained on symbol after exec
13272
13273    ffesymbol s;
13274    s = ffecom_sym_learned(s);
13275
13276    Called when a new symbol is seen after the exec transition or when more
13277    info (perhaps) is gained for an UNCERTAIN symbol.  The symbol state when
13278    it arrives here is that all its latest info is updated already, so its
13279    state may be UNCERTAIN or UNDERSTOOD, it might already have the hook
13280    field filled in if its gone through here or exec_transition first, and
13281    so on.
13282
13283    The backend probably wants to check ffesymbol_retractable() to see if
13284    backtracking is in effect.  If so, the FFE's changes to the symbol may
13285    be retracted (undone) or committed (ratified), at which time the
13286    appropriate ffecom_sym_retract or _commit function will be called
13287    for that function.
13288
13289    If the backend has its own backtracking mechanism, great, use it so that
13290    committal is a simple operation.  Though it doesn't make much difference,
13291    I suppose: the reason for tentative symbol evolution in the FFE is to
13292    enable error detection in weird incorrect statements early and to disable
13293    incorrect error detection on a correct statement.  The backend is not
13294    likely to introduce any information that'll get involved in these
13295    considerations, so it is probably just fine that the implementation
13296    model for this fn and for _exec_transition is to not do anything
13297    (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE
13298    and instead wait until ffecom_sym_commit is called (which it never
13299    will be as long as we're using ambiguity-detecting statement analysis in
13300    the FFE, which we are initially to shake out the code, but don't depend
13301    on this), otherwise go ahead and do whatever is needed.
13302
13303    In essence, then, when this fn and _exec_transition get called while
13304    backtracking is enabled, a general mechanism would be to flag which (or
13305    both) of these were called (and in what order? neat question as to what
13306    might happen that I'm too lame to think through right now) and then when
13307    _commit is called reproduce the original calling sequence, if any, for
13308    the two fns (at which point backtracking will, of course, be disabled).  */
13309
13310 ffesymbol
13311 ffecom_sym_learned (ffesymbol s)
13312 {
13313   ffestorag_exec_layout (s);
13314
13315   return s;
13316 }
13317
13318 /* ffecom_sym_retract -- Symbol's state being retracted from reality
13319
13320    ffesymbol s;
13321    ffecom_sym_retract(s);
13322
13323    Does whatever the backend needs when a symbol is retracted after having
13324    been backtrackable for a period of time.  */
13325
13326 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13327 void
13328 ffecom_sym_retract (ffesymbol s UNUSED)
13329 {
13330   assert (!ffesymbol_retractable ());
13331
13332 #if 0                           /* GCC doesn't commit any backtrackable sins,
13333                                    so nothing needed here. */
13334   switch (ffesymbol_hook (s).state)
13335     {
13336     case 0:                     /* nothing happened yet. */
13337       break;
13338
13339     case 1:                     /* exec transition happened. */
13340       break;
13341
13342     case 2:                     /* learned happened. */
13343       break;
13344
13345     case 3:                     /* learned then exec. */
13346       break;
13347
13348     case 4:                     /* exec then learned. */
13349       break;
13350
13351     default:
13352       assert ("bad hook state" == NULL);
13353       break;
13354     }
13355 #endif
13356 }
13357
13358 #endif
13359 /* Create temporary gcc label.  */
13360
13361 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13362 tree
13363 ffecom_temp_label ()
13364 {
13365   tree glabel;
13366   static int mynumber = 0;
13367
13368   glabel = build_decl (LABEL_DECL,
13369                        ffecom_get_invented_identifier ("__g77_label_%d",
13370                                                        mynumber++),
13371                        void_type_node);
13372   DECL_CONTEXT (glabel) = current_function_decl;
13373   DECL_MODE (glabel) = VOIDmode;
13374
13375   return glabel;
13376 }
13377
13378 #endif
13379 /* Return an expression that is usable as an arg in a conditional context
13380    (IF, DO WHILE, .NOT., and so on).
13381
13382    Use the one provided for the back end as of >2.6.0.  */
13383
13384 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13385 tree
13386 ffecom_truth_value (tree expr)
13387 {
13388   return truthvalue_conversion (expr);
13389 }
13390
13391 #endif
13392 /* Return the inversion of a truth value (the inversion of what
13393    ffecom_truth_value builds).
13394
13395    Apparently invert_truthvalue, which is properly in the back end, is
13396    enough for now, so just use it.  */
13397
13398 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13399 tree
13400 ffecom_truth_value_invert (tree expr)
13401 {
13402   return invert_truthvalue (ffecom_truth_value (expr));
13403 }
13404
13405 #endif
13406
13407 /* Return the tree that is the type of the expression, as would be
13408    returned in TREE_TYPE(ffecom_expr(expr)), without otherwise
13409    transforming the expression, generating temporaries, etc.  */
13410
13411 tree
13412 ffecom_type_expr (ffebld expr)
13413 {
13414   ffeinfoBasictype bt;
13415   ffeinfoKindtype kt;
13416   tree tree_type;
13417
13418   assert (expr != NULL);
13419
13420   bt = ffeinfo_basictype (ffebld_info (expr));
13421   kt = ffeinfo_kindtype (ffebld_info (expr));
13422   tree_type = ffecom_tree_type[bt][kt];
13423
13424   switch (ffebld_op (expr))
13425     {
13426     case FFEBLD_opCONTER:
13427     case FFEBLD_opSYMTER:
13428     case FFEBLD_opARRAYREF:
13429     case FFEBLD_opUPLUS:
13430     case FFEBLD_opPAREN:
13431     case FFEBLD_opUMINUS:
13432     case FFEBLD_opADD:
13433     case FFEBLD_opSUBTRACT:
13434     case FFEBLD_opMULTIPLY:
13435     case FFEBLD_opDIVIDE:
13436     case FFEBLD_opPOWER:
13437     case FFEBLD_opNOT:
13438     case FFEBLD_opFUNCREF:
13439     case FFEBLD_opSUBRREF:
13440     case FFEBLD_opAND:
13441     case FFEBLD_opOR:
13442     case FFEBLD_opXOR:
13443     case FFEBLD_opNEQV:
13444     case FFEBLD_opEQV:
13445     case FFEBLD_opCONVERT:
13446     case FFEBLD_opLT:
13447     case FFEBLD_opLE:
13448     case FFEBLD_opEQ:
13449     case FFEBLD_opNE:
13450     case FFEBLD_opGT:
13451     case FFEBLD_opGE:
13452     case FFEBLD_opPERCENT_LOC:
13453       return tree_type;
13454
13455     case FFEBLD_opACCTER:
13456     case FFEBLD_opARRTER:
13457     case FFEBLD_opITEM:
13458     case FFEBLD_opSTAR:
13459     case FFEBLD_opBOUNDS:
13460     case FFEBLD_opREPEAT:
13461     case FFEBLD_opLABTER:
13462     case FFEBLD_opLABTOK:
13463     case FFEBLD_opIMPDO:
13464     case FFEBLD_opCONCATENATE:
13465     case FFEBLD_opSUBSTR:
13466     default:
13467       assert ("bad op for ffecom_type_expr" == NULL);
13468       /* Fall through. */
13469     case FFEBLD_opANY:
13470       return error_mark_node;
13471     }
13472 }
13473
13474 /* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points
13475
13476    If the PARM_DECL already exists, return it, else create it.  It's an
13477    integer_type_node argument for the master function that implements a
13478    subroutine or function with more than one entrypoint and is bound at
13479    run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for
13480    first ENTRY statement, and so on).  */
13481
13482 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13483 tree
13484 ffecom_which_entrypoint_decl ()
13485 {
13486   assert (ffecom_which_entrypoint_decl_ != NULL_TREE);
13487
13488   return ffecom_which_entrypoint_decl_;
13489 }
13490
13491 #endif
13492 \f
13493 /* The following sections consists of private and public functions
13494    that have the same names and perform roughly the same functions
13495    as counterparts in the C front end.  Changes in the C front end
13496    might affect how things should be done here.  Only functions
13497    needed by the back end should be public here; the rest should
13498    be private (static in the C sense).  Functions needed by other
13499    g77 front-end modules should be accessed by them via public
13500    ffecom_* names, which should themselves call private versions
13501    in this section so the private versions are easy to recognize
13502    when upgrading to a new gcc and finding interesting changes
13503    in the front end.
13504
13505    Functions named after rule "foo:" in c-parse.y are named
13506    "bison_rule_foo_" so they are easy to find.  */
13507
13508 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13509
13510 static void
13511 bison_rule_pushlevel_ ()
13512 {
13513   emit_line_note (input_filename, lineno);
13514   pushlevel (0);
13515   clear_last_expr ();
13516   expand_start_bindings (0);
13517 }
13518
13519 static tree
13520 bison_rule_compstmt_ ()
13521 {
13522   tree t;
13523   int keep = kept_level_p ();
13524
13525   /* Make the temps go away.  */
13526   if (! keep)
13527     current_binding_level->names = NULL_TREE;
13528
13529   emit_line_note (input_filename, lineno);
13530   expand_end_bindings (getdecls (), keep, 0);
13531   t = poplevel (keep, 1, 0);
13532
13533   return t;
13534 }
13535
13536 /* Return a definition for a builtin function named NAME and whose data type
13537    is TYPE.  TYPE should be a function type with argument types.
13538    FUNCTION_CODE tells later passes how to compile calls to this function.
13539    See tree.h for its possible values.
13540
13541    If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
13542    the name to be called if we can't opencode the function.  */
13543
13544 tree
13545 builtin_function (const char *name, tree type, int function_code,
13546                   enum built_in_class class,
13547                   const char *library_name)
13548 {
13549   tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type);
13550   DECL_EXTERNAL (decl) = 1;
13551   TREE_PUBLIC (decl) = 1;
13552   if (library_name)
13553     DECL_ASSEMBLER_NAME (decl) = get_identifier (library_name);
13554   make_decl_rtl (decl, NULL_PTR);
13555   pushdecl (decl);
13556   DECL_BUILT_IN_CLASS (decl) = class;
13557   DECL_FUNCTION_CODE (decl) = function_code;
13558
13559   return decl;
13560 }
13561
13562 /* Handle when a new declaration NEWDECL
13563    has the same name as an old one OLDDECL
13564    in the same binding contour.
13565    Prints an error message if appropriate.
13566
13567    If safely possible, alter OLDDECL to look like NEWDECL, and return 1.
13568    Otherwise, return 0.  */
13569
13570 static int
13571 duplicate_decls (tree newdecl, tree olddecl)
13572 {
13573   int types_match = 1;
13574   int new_is_definition = (TREE_CODE (newdecl) == FUNCTION_DECL
13575                            && DECL_INITIAL (newdecl) != 0);
13576   tree oldtype = TREE_TYPE (olddecl);
13577   tree newtype = TREE_TYPE (newdecl);
13578
13579   if (olddecl == newdecl)
13580     return 1;
13581
13582   if (TREE_CODE (newtype) == ERROR_MARK
13583       || TREE_CODE (oldtype) == ERROR_MARK)
13584     types_match = 0;
13585
13586   /* New decl is completely inconsistent with the old one =>
13587      tell caller to replace the old one.
13588      This is always an error except in the case of shadowing a builtin.  */
13589   if (TREE_CODE (olddecl) != TREE_CODE (newdecl))
13590     return 0;
13591
13592   /* For real parm decl following a forward decl,
13593      return 1 so old decl will be reused.  */
13594   if (types_match && TREE_CODE (newdecl) == PARM_DECL
13595       && TREE_ASM_WRITTEN (olddecl) && ! TREE_ASM_WRITTEN (newdecl))
13596     return 1;
13597
13598   /* The new declaration is the same kind of object as the old one.
13599      The declarations may partially match.  Print warnings if they don't
13600      match enough.  Ultimately, copy most of the information from the new
13601      decl to the old one, and keep using the old one.  */
13602
13603   if (TREE_CODE (olddecl) == FUNCTION_DECL
13604       && DECL_BUILT_IN (olddecl))
13605     {
13606       /* A function declaration for a built-in function.  */
13607       if (!TREE_PUBLIC (newdecl))
13608         return 0;
13609       else if (!types_match)
13610         {
13611           /* Accept the return type of the new declaration if same modes.  */
13612           tree oldreturntype = TREE_TYPE (TREE_TYPE (olddecl));
13613           tree newreturntype = TREE_TYPE (TREE_TYPE (newdecl));
13614
13615           if (TYPE_MODE (oldreturntype) == TYPE_MODE (newreturntype))
13616             {
13617               /* Function types may be shared, so we can't just modify
13618                  the return type of olddecl's function type.  */
13619               tree newtype
13620                 = build_function_type (newreturntype,
13621                                        TYPE_ARG_TYPES (TREE_TYPE (olddecl)));
13622
13623               types_match = 1;
13624               if (types_match)
13625                 TREE_TYPE (olddecl) = newtype;
13626             }
13627         }
13628       if (!types_match)
13629         return 0;
13630     }
13631   else if (TREE_CODE (olddecl) == FUNCTION_DECL
13632            && DECL_SOURCE_LINE (olddecl) == 0)
13633     {
13634       /* A function declaration for a predeclared function
13635          that isn't actually built in.  */
13636       if (!TREE_PUBLIC (newdecl))
13637         return 0;
13638       else if (!types_match)
13639         {
13640           /* If the types don't match, preserve volatility indication.
13641              Later on, we will discard everything else about the
13642              default declaration.  */
13643           TREE_THIS_VOLATILE (newdecl) |= TREE_THIS_VOLATILE (olddecl);
13644         }
13645     }
13646
13647   /* Copy all the DECL_... slots specified in the new decl
13648      except for any that we copy here from the old type.
13649
13650      Past this point, we don't change OLDTYPE and NEWTYPE
13651      even if we change the types of NEWDECL and OLDDECL.  */
13652
13653   if (types_match)
13654     {
13655       /* Merge the data types specified in the two decls.  */
13656       if (TREE_CODE (newdecl) != FUNCTION_DECL || !DECL_BUILT_IN (olddecl))
13657         TREE_TYPE (newdecl)
13658           = TREE_TYPE (olddecl)
13659             = TREE_TYPE (newdecl);
13660
13661       /* Lay the type out, unless already done.  */
13662       if (oldtype != TREE_TYPE (newdecl))
13663         {
13664           if (TREE_TYPE (newdecl) != error_mark_node)
13665             layout_type (TREE_TYPE (newdecl));
13666           if (TREE_CODE (newdecl) != FUNCTION_DECL
13667               && TREE_CODE (newdecl) != TYPE_DECL
13668               && TREE_CODE (newdecl) != CONST_DECL)
13669             layout_decl (newdecl, 0);
13670         }
13671       else
13672         {
13673           /* Since the type is OLDDECL's, make OLDDECL's size go with.  */
13674           DECL_SIZE (newdecl) = DECL_SIZE (olddecl);
13675           DECL_SIZE_UNIT (newdecl) = DECL_SIZE_UNIT (olddecl);
13676           if (TREE_CODE (olddecl) != FUNCTION_DECL)
13677             if (DECL_ALIGN (olddecl) > DECL_ALIGN (newdecl))
13678               {
13679                 DECL_ALIGN (newdecl) = DECL_ALIGN (olddecl);
13680                 DECL_USER_ALIGN (newdecl) |= DECL_USER_ALIGN (olddecl);
13681               }
13682         }
13683
13684       /* Keep the old rtl since we can safely use it.  */
13685       DECL_RTL (newdecl) = DECL_RTL (olddecl);
13686
13687       /* Merge the type qualifiers.  */
13688       if (DECL_BUILT_IN_NONANSI (olddecl) && TREE_THIS_VOLATILE (olddecl)
13689           && !TREE_THIS_VOLATILE (newdecl))
13690         TREE_THIS_VOLATILE (olddecl) = 0;
13691       if (TREE_READONLY (newdecl))
13692         TREE_READONLY (olddecl) = 1;
13693       if (TREE_THIS_VOLATILE (newdecl))
13694         {
13695           TREE_THIS_VOLATILE (olddecl) = 1;
13696           if (TREE_CODE (newdecl) == VAR_DECL)
13697             make_var_volatile (newdecl);
13698         }
13699
13700       /* Keep source location of definition rather than declaration.
13701          Likewise, keep decl at outer scope.  */
13702       if ((DECL_INITIAL (newdecl) == 0 && DECL_INITIAL (olddecl) != 0)
13703           || (DECL_CONTEXT (newdecl) != 0 && DECL_CONTEXT (olddecl) == 0))
13704         {
13705           DECL_SOURCE_LINE (newdecl) = DECL_SOURCE_LINE (olddecl);
13706           DECL_SOURCE_FILE (newdecl) = DECL_SOURCE_FILE (olddecl);
13707
13708           if (DECL_CONTEXT (olddecl) == 0
13709               && TREE_CODE (newdecl) != FUNCTION_DECL)
13710             DECL_CONTEXT (newdecl) = 0;
13711         }
13712
13713       /* Merge the unused-warning information.  */
13714       if (DECL_IN_SYSTEM_HEADER (olddecl))
13715         DECL_IN_SYSTEM_HEADER (newdecl) = 1;
13716       else if (DECL_IN_SYSTEM_HEADER (newdecl))
13717         DECL_IN_SYSTEM_HEADER (olddecl) = 1;
13718
13719       /* Merge the initialization information.  */
13720       if (DECL_INITIAL (newdecl) == 0)
13721         DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13722
13723       /* Merge the section attribute.
13724          We want to issue an error if the sections conflict but that must be
13725          done later in decl_attributes since we are called before attributes
13726          are assigned.  */
13727       if (DECL_SECTION_NAME (newdecl) == NULL_TREE)
13728         DECL_SECTION_NAME (newdecl) = DECL_SECTION_NAME (olddecl);
13729
13730 #if BUILT_FOR_270
13731       if (TREE_CODE (newdecl) == FUNCTION_DECL)
13732         {
13733           DECL_STATIC_CONSTRUCTOR(newdecl) |= DECL_STATIC_CONSTRUCTOR(olddecl);
13734           DECL_STATIC_DESTRUCTOR (newdecl) |= DECL_STATIC_DESTRUCTOR (olddecl);
13735         }
13736 #endif
13737     }
13738   /* If cannot merge, then use the new type and qualifiers,
13739      and don't preserve the old rtl.  */
13740   else
13741     {
13742       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13743       TREE_READONLY (olddecl) = TREE_READONLY (newdecl);
13744       TREE_THIS_VOLATILE (olddecl) = TREE_THIS_VOLATILE (newdecl);
13745       TREE_SIDE_EFFECTS (olddecl) = TREE_SIDE_EFFECTS (newdecl);
13746     }
13747
13748   /* Merge the storage class information.  */
13749   /* For functions, static overrides non-static.  */
13750   if (TREE_CODE (newdecl) == FUNCTION_DECL)
13751     {
13752       TREE_PUBLIC (newdecl) &= TREE_PUBLIC (olddecl);
13753       /* This is since we don't automatically
13754          copy the attributes of NEWDECL into OLDDECL.  */
13755       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13756       /* If this clears `static', clear it in the identifier too.  */
13757       if (! TREE_PUBLIC (olddecl))
13758         TREE_PUBLIC (DECL_NAME (olddecl)) = 0;
13759     }
13760   if (DECL_EXTERNAL (newdecl))
13761     {
13762       TREE_STATIC (newdecl) = TREE_STATIC (olddecl);
13763       DECL_EXTERNAL (newdecl) = DECL_EXTERNAL (olddecl);
13764       /* An extern decl does not override previous storage class.  */
13765       TREE_PUBLIC (newdecl) = TREE_PUBLIC (olddecl);
13766     }
13767   else
13768     {
13769       TREE_STATIC (olddecl) = TREE_STATIC (newdecl);
13770       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13771     }
13772
13773   /* If either decl says `inline', this fn is inline,
13774      unless its definition was passed already.  */
13775   if (DECL_INLINE (newdecl) && DECL_INITIAL (olddecl) == 0)
13776     DECL_INLINE (olddecl) = 1;
13777   DECL_INLINE (newdecl) = DECL_INLINE (olddecl);
13778
13779   /* Get rid of any built-in function if new arg types don't match it
13780      or if we have a function definition.  */
13781   if (TREE_CODE (newdecl) == FUNCTION_DECL
13782       && DECL_BUILT_IN (olddecl)
13783       && (!types_match || new_is_definition))
13784     {
13785       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13786       DECL_BUILT_IN_CLASS (olddecl) = NOT_BUILT_IN;
13787     }
13788
13789   /* If redeclaring a builtin function, and not a definition,
13790      it stays built in.
13791      Also preserve various other info from the definition.  */
13792   if (TREE_CODE (newdecl) == FUNCTION_DECL && !new_is_definition)
13793     {
13794       if (DECL_BUILT_IN (olddecl))
13795         {
13796           DECL_BUILT_IN_CLASS (newdecl) = DECL_BUILT_IN_CLASS (olddecl);
13797           DECL_FUNCTION_CODE (newdecl) = DECL_FUNCTION_CODE (olddecl);
13798         }
13799       else
13800         DECL_FRAME_SIZE (newdecl) = DECL_FRAME_SIZE (olddecl);
13801
13802       DECL_RESULT (newdecl) = DECL_RESULT (olddecl);
13803       DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13804       DECL_SAVED_INSNS (newdecl) = DECL_SAVED_INSNS (olddecl);
13805       DECL_ARGUMENTS (newdecl) = DECL_ARGUMENTS (olddecl);
13806     }
13807
13808   /* Copy most of the decl-specific fields of NEWDECL into OLDDECL.
13809      But preserve olddecl's DECL_UID.  */
13810   {
13811     register unsigned olddecl_uid = DECL_UID (olddecl);
13812
13813     memcpy ((char *) olddecl + sizeof (struct tree_common),
13814             (char *) newdecl + sizeof (struct tree_common),
13815             sizeof (struct tree_decl) - sizeof (struct tree_common));
13816     DECL_UID (olddecl) = olddecl_uid;
13817   }
13818
13819   return 1;
13820 }
13821
13822 /* Finish processing of a declaration;
13823    install its initial value.
13824    If the length of an array type is not known before,
13825    it must be determined now, from the initial value, or it is an error.  */
13826
13827 static void
13828 finish_decl (tree decl, tree init, bool is_top_level)
13829 {
13830   register tree type = TREE_TYPE (decl);
13831   int was_incomplete = (DECL_SIZE (decl) == 0);
13832   bool at_top_level = (current_binding_level == global_binding_level);
13833   bool top_level = is_top_level || at_top_level;
13834
13835   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13836      level anyway.  */
13837   assert (!is_top_level || !at_top_level);
13838
13839   if (TREE_CODE (decl) == PARM_DECL)
13840     assert (init == NULL_TREE);
13841   /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it
13842      overlaps DECL_ARG_TYPE.  */
13843   else if (init == NULL_TREE)
13844     assert (DECL_INITIAL (decl) == NULL_TREE);
13845   else
13846     assert (DECL_INITIAL (decl) == error_mark_node);
13847
13848   if (init != NULL_TREE)
13849     {
13850       if (TREE_CODE (decl) != TYPE_DECL)
13851         DECL_INITIAL (decl) = init;
13852       else
13853         {
13854           /* typedef foo = bar; store the type of bar as the type of foo.  */
13855           TREE_TYPE (decl) = TREE_TYPE (init);
13856           DECL_INITIAL (decl) = init = 0;
13857         }
13858     }
13859
13860   /* Deduce size of array from initialization, if not already known */
13861
13862   if (TREE_CODE (type) == ARRAY_TYPE
13863       && TYPE_DOMAIN (type) == 0
13864       && TREE_CODE (decl) != TYPE_DECL)
13865     {
13866       assert (top_level);
13867       assert (was_incomplete);
13868
13869       layout_decl (decl, 0);
13870     }
13871
13872   if (TREE_CODE (decl) == VAR_DECL)
13873     {
13874       if (DECL_SIZE (decl) == NULL_TREE
13875           && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
13876         layout_decl (decl, 0);
13877
13878       if (DECL_SIZE (decl) == NULL_TREE
13879           && (TREE_STATIC (decl)
13880               ?
13881       /* A static variable with an incomplete type is an error if it is
13882          initialized. Also if it is not file scope. Otherwise, let it
13883          through, but if it is not `extern' then it may cause an error
13884          message later.  */
13885               (DECL_INITIAL (decl) != 0 || DECL_CONTEXT (decl) != 0)
13886               :
13887       /* An automatic variable with an incomplete type is an error.  */
13888               !DECL_EXTERNAL (decl)))
13889         {
13890           assert ("storage size not known" == NULL);
13891           abort ();
13892         }
13893
13894       if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl))
13895           && (DECL_SIZE (decl) != 0)
13896           && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST))
13897         {
13898           assert ("storage size not constant" == NULL);
13899           abort ();
13900         }
13901     }
13902
13903   /* Output the assembler code and/or RTL code for variables and functions,
13904      unless the type is an undefined structure or union. If not, it will get
13905      done when the type is completed.  */
13906
13907   if (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == FUNCTION_DECL)
13908     {
13909       rest_of_decl_compilation (decl, NULL,
13910                                 DECL_CONTEXT (decl) == 0,
13911                                 0);
13912
13913       if (DECL_CONTEXT (decl) != 0)
13914         {
13915           /* Recompute the RTL of a local array now if it used to be an
13916              incomplete type.  */
13917           if (was_incomplete
13918               && !TREE_STATIC (decl) && !DECL_EXTERNAL (decl))
13919             {
13920               /* If we used it already as memory, it must stay in memory.  */
13921               TREE_ADDRESSABLE (decl) = TREE_USED (decl);
13922               /* If it's still incomplete now, no init will save it.  */
13923               if (DECL_SIZE (decl) == 0)
13924                 DECL_INITIAL (decl) = 0;
13925               expand_decl (decl);
13926             }
13927           /* Compute and store the initial value.  */
13928           if (TREE_CODE (decl) != FUNCTION_DECL)
13929             expand_decl_init (decl);
13930         }
13931     }
13932   else if (TREE_CODE (decl) == TYPE_DECL)
13933     {
13934       rest_of_decl_compilation (decl, NULL_PTR,
13935                                 DECL_CONTEXT (decl) == 0,
13936                                 0);
13937     }
13938
13939   /* At the end of a declaration, throw away any variable type sizes of types
13940      defined inside that declaration.  There is no use computing them in the
13941      following function definition.  */
13942   if (current_binding_level == global_binding_level)
13943     get_pending_sizes ();
13944 }
13945
13946 /* Finish up a function declaration and compile that function
13947    all the way to assembler language output.  The free the storage
13948    for the function definition.
13949
13950    This is called after parsing the body of the function definition.
13951
13952    NESTED is nonzero if the function being finished is nested in another.  */
13953
13954 static void
13955 finish_function (int nested)
13956 {
13957   register tree fndecl = current_function_decl;
13958
13959   assert (fndecl != NULL_TREE);
13960   if (TREE_CODE (fndecl) != ERROR_MARK)
13961     {
13962       if (nested)
13963         assert (DECL_CONTEXT (fndecl) != NULL_TREE);
13964       else
13965         assert (DECL_CONTEXT (fndecl) == NULL_TREE);
13966     }
13967
13968 /*  TREE_READONLY (fndecl) = 1;
13969     This caused &foo to be of type ptr-to-const-function
13970     which then got a warning when stored in a ptr-to-function variable.  */
13971
13972   poplevel (1, 0, 1);
13973
13974   if (TREE_CODE (fndecl) != ERROR_MARK)
13975     {
13976       BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
13977
13978       /* Must mark the RESULT_DECL as being in this function.  */
13979
13980       DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl;
13981
13982       /* Obey `register' declarations if `setjmp' is called in this fn.  */
13983       /* Generate rtl for function exit.  */
13984       expand_function_end (input_filename, lineno, 0);
13985
13986       /* If this is a nested function, protect the local variables in the stack
13987          above us from being collected while we're compiling this function.  */
13988       if (nested)
13989         ggc_push_context ();
13990
13991       /* Run the optimizers and output the assembler code for this function.  */
13992       rest_of_compilation (fndecl);
13993
13994       /* Undo the GC context switch.  */
13995       if (nested)
13996         ggc_pop_context ();
13997     }
13998
13999   if (TREE_CODE (fndecl) != ERROR_MARK
14000       && !nested
14001       && DECL_SAVED_INSNS (fndecl) == 0)
14002     {
14003       /* Stop pointing to the local nodes about to be freed.  */
14004       /* But DECL_INITIAL must remain nonzero so we know this was an actual
14005          function definition.  */
14006       /* For a nested function, this is done in pop_f_function_context.  */
14007       /* If rest_of_compilation set this to 0, leave it 0.  */
14008       if (DECL_INITIAL (fndecl) != 0)
14009         DECL_INITIAL (fndecl) = error_mark_node;
14010       DECL_ARGUMENTS (fndecl) = 0;
14011     }
14012
14013   if (!nested)
14014     {
14015       /* Let the error reporting routines know that we're outside a function.
14016          For a nested function, this value is used in pop_c_function_context
14017          and then reset via pop_function_context.  */
14018       ffecom_outer_function_decl_ = current_function_decl = NULL;
14019     }
14020 }
14021
14022 /* Plug-in replacement for identifying the name of a decl and, for a
14023    function, what we call it in diagnostics.  For now, "program unit"
14024    should suffice, since it's a bit of a hassle to figure out which
14025    of several kinds of things it is.  Note that it could conceivably
14026    be a statement function, which probably isn't really a program unit
14027    per se, but if that comes up, it should be easy to check (being a
14028    nested function and all).  */
14029
14030 static const char *
14031 lang_printable_name (tree decl, int v)
14032 {
14033   /* Just to keep GCC quiet about the unused variable.
14034      In theory, differing values of V should produce different
14035      output.  */
14036   switch (v)
14037     {
14038     default:
14039       if (TREE_CODE (decl) == ERROR_MARK)
14040         return "erroneous code";
14041       return IDENTIFIER_POINTER (DECL_NAME (decl));
14042     }
14043 }
14044
14045 /* g77's function to print out name of current function that caused
14046    an error.  */
14047
14048 #if BUILT_FOR_270
14049 static void
14050 lang_print_error_function (const char *file)
14051 {
14052   static ffeglobal last_g = NULL;
14053   static ffesymbol last_s = NULL;
14054   ffeglobal g;
14055   ffesymbol s;
14056   const char *kind;
14057
14058   if ((ffecom_primary_entry_ == NULL)
14059       || (ffesymbol_global (ffecom_primary_entry_) == NULL))
14060     {
14061       g = NULL;
14062       s = NULL;
14063       kind = NULL;
14064     }
14065   else
14066     {
14067       g = ffesymbol_global (ffecom_primary_entry_);
14068       if (ffecom_nested_entry_ == NULL)
14069         {
14070           s = ffecom_primary_entry_;
14071           switch (ffesymbol_kind (s))
14072             {
14073             case FFEINFO_kindFUNCTION:
14074               kind = "function";
14075               break;
14076
14077             case FFEINFO_kindSUBROUTINE:
14078               kind = "subroutine";
14079               break;
14080
14081             case FFEINFO_kindPROGRAM:
14082               kind = "program";
14083               break;
14084
14085             case FFEINFO_kindBLOCKDATA:
14086               kind = "block-data";
14087               break;
14088
14089             default:
14090               kind = ffeinfo_kind_message (ffesymbol_kind (s));
14091               break;
14092             }
14093         }
14094       else
14095         {
14096           s = ffecom_nested_entry_;
14097           kind = "statement function";
14098         }
14099     }
14100
14101   if ((last_g != g) || (last_s != s))
14102     {
14103       if (file)
14104         fprintf (stderr, "%s: ", file);
14105
14106       if (s == NULL)
14107         fprintf (stderr, "Outside of any program unit:\n");
14108       else
14109         {
14110           const char *name = ffesymbol_text (s);
14111
14112           fprintf (stderr, "In %s `%s':\n", kind, name);
14113         }
14114
14115       last_g = g;
14116       last_s = s;
14117     }
14118 }
14119 #endif
14120
14121 /* Similar to `lookup_name' but look only at current binding level.  */
14122
14123 static tree
14124 lookup_name_current_level (tree name)
14125 {
14126   register tree t;
14127
14128   if (current_binding_level == global_binding_level)
14129     return IDENTIFIER_GLOBAL_VALUE (name);
14130
14131   if (IDENTIFIER_LOCAL_VALUE (name) == 0)
14132     return 0;
14133
14134   for (t = current_binding_level->names; t; t = TREE_CHAIN (t))
14135     if (DECL_NAME (t) == name)
14136       break;
14137
14138   return t;
14139 }
14140
14141 /* Create a new `struct binding_level'.  */
14142
14143 static struct binding_level *
14144 make_binding_level ()
14145 {
14146   /* NOSTRICT */
14147   return (struct binding_level *) xmalloc (sizeof (struct binding_level));
14148 }
14149
14150 /* Save and restore the variables in this file and elsewhere
14151    that keep track of the progress of compilation of the current function.
14152    Used for nested functions.  */
14153
14154 struct f_function
14155 {
14156   struct f_function *next;
14157   tree named_labels;
14158   tree shadowed_labels;
14159   struct binding_level *binding_level;
14160 };
14161
14162 struct f_function *f_function_chain;
14163
14164 /* Restore the variables used during compilation of a C function.  */
14165
14166 static void
14167 pop_f_function_context ()
14168 {
14169   struct f_function *p = f_function_chain;
14170   tree link;
14171
14172   /* Bring back all the labels that were shadowed.  */
14173   for (link = shadowed_labels; link; link = TREE_CHAIN (link))
14174     if (DECL_NAME (TREE_VALUE (link)) != 0)
14175       IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link)))
14176         = TREE_VALUE (link);
14177
14178   if (current_function_decl != error_mark_node
14179       && DECL_SAVED_INSNS (current_function_decl) == 0)
14180     {
14181       /* Stop pointing to the local nodes about to be freed.  */
14182       /* But DECL_INITIAL must remain nonzero so we know this was an actual
14183          function definition.  */
14184       DECL_INITIAL (current_function_decl) = error_mark_node;
14185       DECL_ARGUMENTS (current_function_decl) = 0;
14186     }
14187
14188   pop_function_context ();
14189
14190   f_function_chain = p->next;
14191
14192   named_labels = p->named_labels;
14193   shadowed_labels = p->shadowed_labels;
14194   current_binding_level = p->binding_level;
14195
14196   free (p);
14197 }
14198
14199 /* Save and reinitialize the variables
14200    used during compilation of a C function.  */
14201
14202 static void
14203 push_f_function_context ()
14204 {
14205   struct f_function *p
14206   = (struct f_function *) xmalloc (sizeof (struct f_function));
14207
14208   push_function_context ();
14209
14210   p->next = f_function_chain;
14211   f_function_chain = p;
14212
14213   p->named_labels = named_labels;
14214   p->shadowed_labels = shadowed_labels;
14215   p->binding_level = current_binding_level;
14216 }
14217
14218 static void
14219 push_parm_decl (tree parm)
14220 {
14221   int old_immediate_size_expand = immediate_size_expand;
14222
14223   /* Don't try computing parm sizes now -- wait till fn is called.  */
14224
14225   immediate_size_expand = 0;
14226
14227   /* Fill in arg stuff.  */
14228
14229   DECL_ARG_TYPE (parm) = TREE_TYPE (parm);
14230   DECL_ARG_TYPE_AS_WRITTEN (parm) = TREE_TYPE (parm);
14231   TREE_READONLY (parm) = 1;     /* All implementation args are read-only. */
14232
14233   parm = pushdecl (parm);
14234
14235   immediate_size_expand = old_immediate_size_expand;
14236
14237   finish_decl (parm, NULL_TREE, FALSE);
14238 }
14239
14240 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate.  */
14241
14242 static tree
14243 pushdecl_top_level (x)
14244      tree x;
14245 {
14246   register tree t;
14247   register struct binding_level *b = current_binding_level;
14248   register tree f = current_function_decl;
14249
14250   current_binding_level = global_binding_level;
14251   current_function_decl = NULL_TREE;
14252   t = pushdecl (x);
14253   current_binding_level = b;
14254   current_function_decl = f;
14255   return t;
14256 }
14257
14258 /* Store the list of declarations of the current level.
14259    This is done for the parameter declarations of a function being defined,
14260    after they are modified in the light of any missing parameters.  */
14261
14262 static tree
14263 storedecls (decls)
14264      tree decls;
14265 {
14266   return current_binding_level->names = decls;
14267 }
14268
14269 /* Store the parameter declarations into the current function declaration.
14270    This is called after parsing the parameter declarations, before
14271    digesting the body of the function.
14272
14273    For an old-style definition, modify the function's type
14274    to specify at least the number of arguments.  */
14275
14276 static void
14277 store_parm_decls (int is_main_program UNUSED)
14278 {
14279   register tree fndecl = current_function_decl;
14280
14281   if (fndecl == error_mark_node)
14282     return;
14283
14284   /* This is a chain of PARM_DECLs from old-style parm declarations.  */
14285   DECL_ARGUMENTS (fndecl) = storedecls (nreverse (getdecls ()));
14286
14287   /* Initialize the RTL code for the function.  */
14288
14289   init_function_start (fndecl, input_filename, lineno);
14290
14291   /* Set up parameters and prepare for return, for the function.  */
14292
14293   expand_function_start (fndecl, 0);
14294 }
14295
14296 static tree
14297 start_decl (tree decl, bool is_top_level)
14298 {
14299   register tree tem;
14300   bool at_top_level = (current_binding_level == global_binding_level);
14301   bool top_level = is_top_level || at_top_level;
14302
14303   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
14304      level anyway.  */
14305   assert (!is_top_level || !at_top_level);
14306
14307   if (DECL_INITIAL (decl) != NULL_TREE)
14308     {
14309       assert (DECL_INITIAL (decl) == error_mark_node);
14310       assert (!DECL_EXTERNAL (decl));
14311     }
14312   else if (top_level)
14313     assert ((TREE_STATIC (decl) == 1) || DECL_EXTERNAL (decl) == 1);
14314
14315   /* For Fortran, we by default put things in .common when possible.  */
14316   DECL_COMMON (decl) = 1;
14317
14318   /* Add this decl to the current binding level. TEM may equal DECL or it may
14319      be a previous decl of the same name.  */
14320   if (is_top_level)
14321     tem = pushdecl_top_level (decl);
14322   else
14323     tem = pushdecl (decl);
14324
14325   /* For a local variable, define the RTL now.  */
14326   if (!top_level
14327   /* But not if this is a duplicate decl and we preserved the rtl from the
14328      previous one (which may or may not happen).  */
14329       && DECL_RTL (tem) == 0)
14330     {
14331       if (TYPE_SIZE (TREE_TYPE (tem)) != 0)
14332         expand_decl (tem);
14333       else if (TREE_CODE (TREE_TYPE (tem)) == ARRAY_TYPE
14334                && DECL_INITIAL (tem) != 0)
14335         expand_decl (tem);
14336     }
14337
14338   return tem;
14339 }
14340
14341 /* Create the FUNCTION_DECL for a function definition.
14342    DECLSPECS and DECLARATOR are the parts of the declaration;
14343    they describe the function's name and the type it returns,
14344    but twisted together in a fashion that parallels the syntax of C.
14345
14346    This function creates a binding context for the function body
14347    as well as setting up the FUNCTION_DECL in current_function_decl.
14348
14349    Returns 1 on success.  If the DECLARATOR is not suitable for a function
14350    (it defines a datum instead), we return 0, which tells
14351    yyparse to report a parse error.
14352
14353    NESTED is nonzero for a function nested within another function.  */
14354
14355 static void
14356 start_function (tree name, tree type, int nested, int public)
14357 {
14358   tree decl1;
14359   tree restype;
14360   int old_immediate_size_expand = immediate_size_expand;
14361
14362   named_labels = 0;
14363   shadowed_labels = 0;
14364
14365   /* Don't expand any sizes in the return type of the function.  */
14366   immediate_size_expand = 0;
14367
14368   if (nested)
14369     {
14370       assert (!public);
14371       assert (current_function_decl != NULL_TREE);
14372       assert (DECL_CONTEXT (current_function_decl) == NULL_TREE);
14373     }
14374   else
14375     {
14376       assert (current_function_decl == NULL_TREE);
14377     }
14378
14379   if (TREE_CODE (type) == ERROR_MARK)
14380     decl1 = current_function_decl = error_mark_node;
14381   else
14382     {
14383       decl1 = build_decl (FUNCTION_DECL,
14384                           name,
14385                           type);
14386       TREE_PUBLIC (decl1) = public ? 1 : 0;
14387       if (nested)
14388         DECL_INLINE (decl1) = 1;
14389       TREE_STATIC (decl1) = 1;
14390       DECL_EXTERNAL (decl1) = 0;
14391
14392       announce_function (decl1);
14393
14394       /* Make the init_value nonzero so pushdecl knows this is not tentative.
14395          error_mark_node is replaced below (in poplevel) with the BLOCK.  */
14396       DECL_INITIAL (decl1) = error_mark_node;
14397
14398       /* Record the decl so that the function name is defined. If we already have
14399          a decl for this name, and it is a FUNCTION_DECL, use the old decl.  */
14400
14401       current_function_decl = pushdecl (decl1);
14402     }
14403
14404   if (!nested)
14405     ffecom_outer_function_decl_ = current_function_decl;
14406
14407   pushlevel (0);
14408   current_binding_level->prep_state = 2;
14409
14410   if (TREE_CODE (current_function_decl) != ERROR_MARK)
14411     {
14412       make_decl_rtl (current_function_decl, NULL);
14413
14414       restype = TREE_TYPE (TREE_TYPE (current_function_decl));
14415       DECL_RESULT (current_function_decl)
14416         = build_decl (RESULT_DECL, NULL_TREE, restype);
14417     }
14418
14419   if (!nested && (TREE_CODE (current_function_decl) != ERROR_MARK))
14420     TREE_ADDRESSABLE (current_function_decl) = 1;
14421
14422   immediate_size_expand = old_immediate_size_expand;
14423 }
14424 \f
14425 /* Here are the public functions the GNU back end needs.  */
14426
14427 tree
14428 convert (type, expr)
14429      tree type, expr;
14430 {
14431   register tree e = expr;
14432   register enum tree_code code = TREE_CODE (type);
14433
14434   if (type == TREE_TYPE (e)
14435       || TREE_CODE (e) == ERROR_MARK)
14436     return e;
14437   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
14438     return fold (build1 (NOP_EXPR, type, e));
14439   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
14440       || code == ERROR_MARK)
14441     return error_mark_node;
14442   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
14443     {
14444       assert ("void value not ignored as it ought to be" == NULL);
14445       return error_mark_node;
14446     }
14447   if (code == VOID_TYPE)
14448     return build1 (CONVERT_EXPR, type, e);
14449   if ((code != RECORD_TYPE)
14450       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
14451     e = ffecom_1 (REALPART_EXPR, TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e))),
14452                   e);
14453   if (code == INTEGER_TYPE || code == ENUMERAL_TYPE)
14454     return fold (convert_to_integer (type, e));
14455   if (code == POINTER_TYPE)
14456     return fold (convert_to_pointer (type, e));
14457   if (code == REAL_TYPE)
14458     return fold (convert_to_real (type, e));
14459   if (code == COMPLEX_TYPE)
14460     return fold (convert_to_complex (type, e));
14461   if (code == RECORD_TYPE)
14462     return fold (ffecom_convert_to_complex_ (type, e));
14463
14464   assert ("conversion to non-scalar type requested" == NULL);
14465   return error_mark_node;
14466 }
14467
14468 /* integrate_decl_tree calls this function, but since we don't use the
14469    DECL_LANG_SPECIFIC field, this is a no-op.  */
14470
14471 void
14472 copy_lang_decl (node)
14473      tree node UNUSED;
14474 {
14475 }
14476
14477 /* Return the list of declarations of the current level.
14478    Note that this list is in reverse order unless/until
14479    you nreverse it; and when you do nreverse it, you must
14480    store the result back using `storedecls' or you will lose.  */
14481
14482 tree
14483 getdecls ()
14484 {
14485   return current_binding_level->names;
14486 }
14487
14488 /* Nonzero if we are currently in the global binding level.  */
14489
14490 int
14491 global_bindings_p ()
14492 {
14493   return current_binding_level == global_binding_level;
14494 }
14495
14496 /* Print an error message for invalid use of an incomplete type.
14497    VALUE is the expression that was used (or 0 if that isn't known)
14498    and TYPE is the type that was invalid.  */
14499
14500 void
14501 incomplete_type_error (value, type)
14502      tree value UNUSED;
14503      tree type;
14504 {
14505   if (TREE_CODE (type) == ERROR_MARK)
14506     return;
14507
14508   assert ("incomplete type?!?" == NULL);
14509 }
14510
14511 /* Mark ARG for GC.  */
14512 static void
14513 mark_binding_level (void *arg)
14514 {
14515   struct binding_level *level = *(struct binding_level **) arg;
14516
14517   while (level)
14518     {
14519       ggc_mark_tree (level->names);
14520       ggc_mark_tree (level->blocks);
14521       ggc_mark_tree (level->this_block);
14522       level = level->level_chain;
14523     }
14524 }
14525
14526 void
14527 init_decl_processing ()
14528 {
14529   static tree *const tree_roots[] = {
14530     &current_function_decl,
14531     &string_type_node,
14532     &ffecom_tree_fun_type_void,
14533     &ffecom_integer_zero_node,
14534     &ffecom_integer_one_node,
14535     &ffecom_tree_subr_type,
14536     &ffecom_tree_ptr_to_subr_type,
14537     &ffecom_tree_blockdata_type,
14538     &ffecom_tree_xargc_,
14539     &ffecom_f2c_integer_type_node,
14540     &ffecom_f2c_ptr_to_integer_type_node,
14541     &ffecom_f2c_address_type_node,
14542     &ffecom_f2c_real_type_node,
14543     &ffecom_f2c_ptr_to_real_type_node,
14544     &ffecom_f2c_doublereal_type_node,
14545     &ffecom_f2c_complex_type_node,
14546     &ffecom_f2c_doublecomplex_type_node,
14547     &ffecom_f2c_longint_type_node,
14548     &ffecom_f2c_logical_type_node,
14549     &ffecom_f2c_flag_type_node,
14550     &ffecom_f2c_ftnlen_type_node,
14551     &ffecom_f2c_ftnlen_zero_node,
14552     &ffecom_f2c_ftnlen_one_node,
14553     &ffecom_f2c_ftnlen_two_node,
14554     &ffecom_f2c_ptr_to_ftnlen_type_node,
14555     &ffecom_f2c_ftnint_type_node,
14556     &ffecom_f2c_ptr_to_ftnint_type_node,
14557     &ffecom_outer_function_decl_,
14558     &ffecom_previous_function_decl_,
14559     &ffecom_which_entrypoint_decl_,
14560     &ffecom_float_zero_,
14561     &ffecom_float_half_,
14562     &ffecom_double_zero_,
14563     &ffecom_double_half_,
14564     &ffecom_func_result_,
14565     &ffecom_func_length_,
14566     &ffecom_multi_type_node_,
14567     &ffecom_multi_retval_,
14568     &named_labels,
14569     &shadowed_labels
14570   };
14571   size_t i;
14572
14573   malloc_init ();
14574
14575   /* Record our roots.  */
14576   for (i = 0; i < ARRAY_SIZE (tree_roots); i++)
14577     ggc_add_tree_root (tree_roots[i], 1);
14578   ggc_add_tree_root (&ffecom_tree_type[0][0],
14579                      FFEINFO_basictype*FFEINFO_kindtype);
14580   ggc_add_tree_root (&ffecom_tree_fun_type[0][0],
14581                      FFEINFO_basictype*FFEINFO_kindtype);
14582   ggc_add_tree_root (&ffecom_tree_ptr_to_fun_type[0][0],
14583                      FFEINFO_basictype*FFEINFO_kindtype);
14584   ggc_add_tree_root (ffecom_gfrt_, FFECOM_gfrt);
14585   ggc_add_root (&current_binding_level, 1, sizeof current_binding_level,
14586                 mark_binding_level);
14587   ggc_add_root (&free_binding_level, 1, sizeof current_binding_level,
14588                 mark_binding_level);
14589   ggc_add_root (&tracker_head, 1, sizeof tracker_head, mark_tracker_head);
14590
14591   ffe_init_0 ();
14592 }
14593
14594 const char *
14595 init_parse (filename)
14596      const char *filename;
14597 {
14598   /* Open input file.  */
14599   if (filename == 0 || !strcmp (filename, "-"))
14600     {
14601       finput = stdin;
14602       filename = "stdin";
14603     }
14604   else
14605     finput = fopen (filename, "r");
14606   if (finput == 0)
14607     fatal_io_error ("can't open %s", filename);
14608
14609 #ifdef IO_BUFFER_SIZE
14610   setvbuf (finput, (char *) xmalloc (IO_BUFFER_SIZE), _IOFBF, IO_BUFFER_SIZE);
14611 #endif
14612
14613   /* Make identifier nodes long enough for the language-specific slots.  */
14614   set_identifier_size (sizeof (struct lang_identifier));
14615   decl_printable_name = lang_printable_name;
14616 #if BUILT_FOR_270
14617   print_error_function = lang_print_error_function;
14618 #endif
14619
14620   return filename;
14621 }
14622
14623 void
14624 finish_parse ()
14625 {
14626   fclose (finput);
14627 }
14628
14629 /* Delete the node BLOCK from the current binding level.
14630    This is used for the block inside a stmt expr ({...})
14631    so that the block can be reinserted where appropriate.  */
14632
14633 static void
14634 delete_block (block)
14635      tree block;
14636 {
14637   tree t;
14638   if (current_binding_level->blocks == block)
14639     current_binding_level->blocks = TREE_CHAIN (block);
14640   for (t = current_binding_level->blocks; t;)
14641     {
14642       if (TREE_CHAIN (t) == block)
14643         TREE_CHAIN (t) = TREE_CHAIN (block);
14644       else
14645         t = TREE_CHAIN (t);
14646     }
14647   TREE_CHAIN (block) = NULL;
14648   /* Clear TREE_USED which is always set by poplevel.
14649      The flag is set again if insert_block is called.  */
14650   TREE_USED (block) = 0;
14651 }
14652
14653 void
14654 insert_block (block)
14655      tree block;
14656 {
14657   TREE_USED (block) = 1;
14658   current_binding_level->blocks
14659     = chainon (current_binding_level->blocks, block);
14660 }
14661
14662 /* Each front end provides its own.  */
14663 static void ffe_init PARAMS ((void));
14664 static void ffe_finish PARAMS ((void));
14665 static void ffe_init_options PARAMS ((void));
14666
14667 struct lang_hooks lang_hooks = {ffe_init,
14668                                 ffe_finish,
14669                                 ffe_init_options,
14670                                 ffe_decode_option,
14671                                 NULL /* post_options */};
14672
14673 /* used by print-tree.c */
14674
14675 void
14676 lang_print_xnode (file, node, indent)
14677      FILE *file UNUSED;
14678      tree node UNUSED;
14679      int indent UNUSED;
14680 {
14681 }
14682
14683 static void
14684 ffe_finish ()
14685 {
14686   ffe_terminate_0 ();
14687
14688   if (ffe_is_ffedebug ())
14689     malloc_pool_display (malloc_pool_image ());
14690 }
14691
14692 const char *
14693 lang_identify ()
14694 {
14695   return "f77";
14696 }
14697
14698 /* Return the typed-based alias set for T, which may be an expression
14699    or a type.  Return -1 if we don't do anything special.  */
14700
14701 HOST_WIDE_INT
14702 lang_get_alias_set (t)
14703      tree t ATTRIBUTE_UNUSED;
14704 {
14705   /* We do not wish to use alias-set based aliasing at all.  Used in the
14706      extreme (every object with its own set, with equivalences recorded)
14707      it might be helpful, but there are problems when it comes to inlining.
14708      We get on ok with flag_argument_noalias, and alias-set aliasing does
14709      currently limit how stack slots can be reused, which is a lose.  */
14710   return 0;
14711 }
14712
14713 static void
14714 ffe_init_options ()
14715 {
14716   /* Set default options for Fortran.  */
14717   flag_move_all_movables = 1;
14718   flag_reduce_all_givs = 1;
14719   flag_argument_noalias = 2;
14720   flag_errno_math = 0;
14721   flag_complex_divide_method = 1;
14722 }
14723
14724 static void
14725 ffe_init ()
14726 {
14727   /* If the file is output from cpp, it should contain a first line
14728      `# 1 "real-filename"', and the current design of gcc (toplev.c
14729      in particular and the way it sets up information relied on by
14730      INCLUDE) requires that we read this now, and store the
14731      "real-filename" info in master_input_filename.  Ask the lexer
14732      to try doing this.  */
14733   ffelex_hash_kludge (finput);
14734 }
14735
14736 int
14737 mark_addressable (exp)
14738      tree exp;
14739 {
14740   register tree x = exp;
14741   while (1)
14742     switch (TREE_CODE (x))
14743       {
14744       case ADDR_EXPR:
14745       case COMPONENT_REF:
14746       case ARRAY_REF:
14747         x = TREE_OPERAND (x, 0);
14748         break;
14749
14750       case CONSTRUCTOR:
14751         TREE_ADDRESSABLE (x) = 1;
14752         return 1;
14753
14754       case VAR_DECL:
14755       case CONST_DECL:
14756       case PARM_DECL:
14757       case RESULT_DECL:
14758         if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x)
14759             && DECL_NONLOCAL (x))
14760           {
14761             if (TREE_PUBLIC (x))
14762               {
14763                 assert ("address of global register var requested" == NULL);
14764                 return 0;
14765               }
14766             assert ("address of register variable requested" == NULL);
14767           }
14768         else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x))
14769           {
14770             if (TREE_PUBLIC (x))
14771               {
14772                 assert ("address of global register var requested" == NULL);
14773                 return 0;
14774               }
14775             assert ("address of register var requested" == NULL);
14776           }
14777         put_var_into_stack (x);
14778
14779         /* drops in */
14780       case FUNCTION_DECL:
14781         TREE_ADDRESSABLE (x) = 1;
14782 #if 0                           /* poplevel deals with this now.  */
14783         if (DECL_CONTEXT (x) == 0)
14784           TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x)) = 1;
14785 #endif
14786
14787       default:
14788         return 1;
14789       }
14790 }
14791
14792 /* If DECL has a cleanup, build and return that cleanup here.
14793    This is a callback called by expand_expr.  */
14794
14795 tree
14796 maybe_build_cleanup (decl)
14797      tree decl UNUSED;
14798 {
14799   /* There are no cleanups in Fortran.  */
14800   return NULL_TREE;
14801 }
14802
14803 /* Exit a binding level.
14804    Pop the level off, and restore the state of the identifier-decl mappings
14805    that were in effect when this level was entered.
14806
14807    If KEEP is nonzero, this level had explicit declarations, so
14808    and create a "block" (a BLOCK node) for the level
14809    to record its declarations and subblocks for symbol table output.
14810
14811    If FUNCTIONBODY is nonzero, this level is the body of a function,
14812    so create a block as if KEEP were set and also clear out all
14813    label names.
14814
14815    If REVERSE is nonzero, reverse the order of decls before putting
14816    them into the BLOCK.  */
14817
14818 tree
14819 poplevel (keep, reverse, functionbody)
14820      int keep;
14821      int reverse;
14822      int functionbody;
14823 {
14824   register tree link;
14825   /* The chain of decls was accumulated in reverse order.
14826      Put it into forward order, just for cleanliness.  */
14827   tree decls;
14828   tree subblocks = current_binding_level->blocks;
14829   tree block = 0;
14830   tree decl;
14831   int block_previously_created;
14832
14833   /* Get the decls in the order they were written.
14834      Usually current_binding_level->names is in reverse order.
14835      But parameter decls were previously put in forward order.  */
14836
14837   if (reverse)
14838     current_binding_level->names
14839       = decls = nreverse (current_binding_level->names);
14840   else
14841     decls = current_binding_level->names;
14842
14843   /* Output any nested inline functions within this block
14844      if they weren't already output.  */
14845
14846   for (decl = decls; decl; decl = TREE_CHAIN (decl))
14847     if (TREE_CODE (decl) == FUNCTION_DECL
14848         && ! TREE_ASM_WRITTEN (decl)
14849         && DECL_INITIAL (decl) != 0
14850         && TREE_ADDRESSABLE (decl))
14851       {
14852         /* If this decl was copied from a file-scope decl
14853            on account of a block-scope extern decl,
14854            propagate TREE_ADDRESSABLE to the file-scope decl.
14855
14856            DECL_ABSTRACT_ORIGIN can be set to itself if warn_return_type is
14857            true, since then the decl goes through save_for_inline_copying.  */
14858         if (DECL_ABSTRACT_ORIGIN (decl) != 0
14859             && DECL_ABSTRACT_ORIGIN (decl) != decl)
14860           TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl)) = 1;
14861         else if (DECL_SAVED_INSNS (decl) != 0)
14862           {
14863             push_function_context ();
14864             output_inline_function (decl);
14865             pop_function_context ();
14866           }
14867       }
14868
14869   /* If there were any declarations or structure tags in that level,
14870      or if this level is a function body,
14871      create a BLOCK to record them for the life of this function.  */
14872
14873   block = 0;
14874   block_previously_created = (current_binding_level->this_block != 0);
14875   if (block_previously_created)
14876     block = current_binding_level->this_block;
14877   else if (keep || functionbody)
14878     block = make_node (BLOCK);
14879   if (block != 0)
14880     {
14881       BLOCK_VARS (block) = decls;
14882       BLOCK_SUBBLOCKS (block) = subblocks;
14883     }
14884
14885   /* In each subblock, record that this is its superior.  */
14886
14887   for (link = subblocks; link; link = TREE_CHAIN (link))
14888     BLOCK_SUPERCONTEXT (link) = block;
14889
14890   /* Clear out the meanings of the local variables of this level.  */
14891
14892   for (link = decls; link; link = TREE_CHAIN (link))
14893     {
14894       if (DECL_NAME (link) != 0)
14895         {
14896           /* If the ident. was used or addressed via a local extern decl,
14897              don't forget that fact.  */
14898           if (DECL_EXTERNAL (link))
14899             {
14900               if (TREE_USED (link))
14901                 TREE_USED (DECL_NAME (link)) = 1;
14902               if (TREE_ADDRESSABLE (link))
14903                 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (link)) = 1;
14904             }
14905           IDENTIFIER_LOCAL_VALUE (DECL_NAME (link)) = 0;
14906         }
14907     }
14908
14909   /* If the level being exited is the top level of a function,
14910      check over all the labels, and clear out the current
14911      (function local) meanings of their names.  */
14912
14913   if (functionbody)
14914     {
14915       /* If this is the top level block of a function,
14916          the vars are the function's parameters.
14917          Don't leave them in the BLOCK because they are
14918          found in the FUNCTION_DECL instead.  */
14919
14920       BLOCK_VARS (block) = 0;
14921     }
14922
14923   /* Pop the current level, and free the structure for reuse.  */
14924
14925   {
14926     register struct binding_level *level = current_binding_level;
14927     current_binding_level = current_binding_level->level_chain;
14928
14929     level->level_chain = free_binding_level;
14930     free_binding_level = level;
14931   }
14932
14933   /* Dispose of the block that we just made inside some higher level.  */
14934   if (functionbody
14935       && current_function_decl != error_mark_node)
14936     DECL_INITIAL (current_function_decl) = block;
14937   else if (block)
14938     {
14939       if (!block_previously_created)
14940         current_binding_level->blocks
14941           = chainon (current_binding_level->blocks, block);
14942     }
14943   /* If we did not make a block for the level just exited,
14944      any blocks made for inner levels
14945      (since they cannot be recorded as subblocks in that level)
14946      must be carried forward so they will later become subblocks
14947      of something else.  */
14948   else if (subblocks)
14949     current_binding_level->blocks
14950       = chainon (current_binding_level->blocks, subblocks);
14951
14952   if (block)
14953     TREE_USED (block) = 1;
14954   return block;
14955 }
14956
14957 void
14958 print_lang_decl (file, node, indent)
14959      FILE *file UNUSED;
14960      tree node UNUSED;
14961      int indent UNUSED;
14962 {
14963 }
14964
14965 void
14966 print_lang_identifier (file, node, indent)
14967      FILE *file;
14968      tree node;
14969      int indent;
14970 {
14971   print_node (file, "global", IDENTIFIER_GLOBAL_VALUE (node), indent + 4);
14972   print_node (file, "local", IDENTIFIER_LOCAL_VALUE (node), indent + 4);
14973 }
14974
14975 void
14976 print_lang_statistics ()
14977 {
14978 }
14979
14980 void
14981 print_lang_type (file, node, indent)
14982      FILE *file UNUSED;
14983      tree node UNUSED;
14984      int indent UNUSED;
14985 {
14986 }
14987
14988 /* Record a decl-node X as belonging to the current lexical scope.
14989    Check for errors (such as an incompatible declaration for the same
14990    name already seen in the same scope).
14991
14992    Returns either X or an old decl for the same name.
14993    If an old decl is returned, it may have been smashed
14994    to agree with what X says.  */
14995
14996 tree
14997 pushdecl (x)
14998      tree x;
14999 {
15000   register tree t;
15001   register tree name = DECL_NAME (x);
15002   register struct binding_level *b = current_binding_level;
15003
15004   if ((TREE_CODE (x) == FUNCTION_DECL)
15005       && (DECL_INITIAL (x) == 0)
15006       && DECL_EXTERNAL (x))
15007     DECL_CONTEXT (x) = NULL_TREE;
15008   else
15009     DECL_CONTEXT (x) = current_function_decl;
15010
15011   if (name)
15012     {
15013       if (IDENTIFIER_INVENTED (name))
15014         {
15015 #if BUILT_FOR_270
15016           DECL_ARTIFICIAL (x) = 1;
15017 #endif
15018           DECL_IN_SYSTEM_HEADER (x) = 1;
15019         }
15020
15021       t = lookup_name_current_level (name);
15022
15023       assert ((t == NULL_TREE) || (DECL_CONTEXT (x) == NULL_TREE));
15024
15025       /* Don't push non-parms onto list for parms until we understand
15026          why we're doing this and whether it works.  */
15027
15028       assert ((b == global_binding_level)
15029               || !ffecom_transform_only_dummies_
15030               || TREE_CODE (x) == PARM_DECL);
15031
15032       if ((t != NULL_TREE) && duplicate_decls (x, t))
15033         return t;
15034
15035       /* If we are processing a typedef statement, generate a whole new
15036          ..._TYPE node (which will be just an variant of the existing
15037          ..._TYPE node with identical properties) and then install the
15038          TYPE_DECL node generated to represent the typedef name as the
15039          TYPE_NAME of this brand new (duplicate) ..._TYPE node.
15040
15041          The whole point here is to end up with a situation where each and every
15042          ..._TYPE node the compiler creates will be uniquely associated with
15043          AT MOST one node representing a typedef name. This way, even though
15044          the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL
15045          (i.e. "typedef name") nodes very early on, later parts of the
15046          compiler can always do the reverse translation and get back the
15047          corresponding typedef name.  For example, given:
15048
15049          typedef struct S MY_TYPE; MY_TYPE object;
15050
15051          Later parts of the compiler might only know that `object' was of type
15052          `struct S' if it were not for code just below.  With this code
15053          however, later parts of the compiler see something like:
15054
15055          struct S' == struct S typedef struct S' MY_TYPE; struct S' object;
15056
15057          And they can then deduce (from the node for type struct S') that the
15058          original object declaration was:
15059
15060          MY_TYPE object;
15061
15062          Being able to do this is important for proper support of protoize, and
15063          also for generating precise symbolic debugging information which
15064          takes full account of the programmer's (typedef) vocabulary.
15065
15066          Obviously, we don't want to generate a duplicate ..._TYPE node if the
15067          TYPE_DECL node that we are now processing really represents a
15068          standard built-in type.
15069
15070          Since all standard types are effectively declared at line zero in the
15071          source file, we can easily check to see if we are working on a
15072          standard type by checking the current value of lineno.  */
15073
15074       if (TREE_CODE (x) == TYPE_DECL)
15075         {
15076           if (DECL_SOURCE_LINE (x) == 0)
15077             {
15078               if (TYPE_NAME (TREE_TYPE (x)) == 0)
15079                 TYPE_NAME (TREE_TYPE (x)) = x;
15080             }
15081           else if (TREE_TYPE (x) != error_mark_node)
15082             {
15083               tree tt = TREE_TYPE (x);
15084
15085               tt = build_type_copy (tt);
15086               TYPE_NAME (tt) = x;
15087               TREE_TYPE (x) = tt;
15088             }
15089         }
15090
15091       /* This name is new in its binding level. Install the new declaration
15092          and return it.  */
15093       if (b == global_binding_level)
15094         IDENTIFIER_GLOBAL_VALUE (name) = x;
15095       else
15096         IDENTIFIER_LOCAL_VALUE (name) = x;
15097     }
15098
15099   /* Put decls on list in reverse order. We will reverse them later if
15100      necessary.  */
15101   TREE_CHAIN (x) = b->names;
15102   b->names = x;
15103
15104   return x;
15105 }
15106
15107 /* Nonzero if the current level needs to have a BLOCK made.  */
15108
15109 static int
15110 kept_level_p ()
15111 {
15112   tree decl;
15113
15114   for (decl = current_binding_level->names;
15115        decl;
15116        decl = TREE_CHAIN (decl))
15117     {
15118       if (TREE_USED (decl) || TREE_CODE (decl) != VAR_DECL
15119           || (DECL_NAME (decl) && ! DECL_ARTIFICIAL (decl)))
15120         /* Currently, there aren't supposed to be non-artificial names
15121            at other than the top block for a function -- they're
15122            believed to always be temps.  But it's wise to check anyway.  */
15123         return 1;
15124     }
15125   return 0;
15126 }
15127
15128 /* Enter a new binding level.
15129    If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
15130    not for that of tags.  */
15131
15132 void
15133 pushlevel (tag_transparent)
15134      int tag_transparent;
15135 {
15136   register struct binding_level *newlevel = NULL_BINDING_LEVEL;
15137
15138   assert (! tag_transparent);
15139
15140   if (current_binding_level == global_binding_level)
15141     {
15142       named_labels = 0;
15143     }
15144
15145   /* Reuse or create a struct for this binding level.  */
15146
15147   if (free_binding_level)
15148     {
15149       newlevel = free_binding_level;
15150       free_binding_level = free_binding_level->level_chain;
15151     }
15152   else
15153     {
15154       newlevel = make_binding_level ();
15155     }
15156
15157   /* Add this level to the front of the chain (stack) of levels that
15158      are active.  */
15159
15160   *newlevel = clear_binding_level;
15161   newlevel->level_chain = current_binding_level;
15162   current_binding_level = newlevel;
15163 }
15164
15165 /* Set the BLOCK node for the innermost scope
15166    (the one we are currently in).  */
15167
15168 void
15169 set_block (block)
15170      register tree block;
15171 {
15172   current_binding_level->this_block = block;
15173   current_binding_level->names = chainon (current_binding_level->names,
15174                                           BLOCK_VARS (block));
15175   current_binding_level->blocks = chainon (current_binding_level->blocks,
15176                                            BLOCK_SUBBLOCKS (block));
15177 }
15178
15179 /* ~~gcc/tree.h *should* declare this, because toplev.c references it.  */
15180
15181 /* Can't 'yydebug' a front end not generated by yacc/bison!  */
15182
15183 void
15184 set_yydebug (value)
15185      int value;
15186 {
15187   if (value)
15188     fprintf (stderr, "warning: no yacc/bison-generated output to debug!\n");
15189 }
15190
15191 tree
15192 signed_or_unsigned_type (unsignedp, type)
15193      int unsignedp;
15194      tree type;
15195 {
15196   tree type2;
15197
15198   if (! INTEGRAL_TYPE_P (type))
15199     return type;
15200   if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node))
15201     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15202   if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node))
15203     return unsignedp ? unsigned_type_node : integer_type_node;
15204   if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node))
15205     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15206   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node))
15207     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15208   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node))
15209     return (unsignedp ? long_long_unsigned_type_node
15210             : long_long_integer_type_node);
15211
15212   type2 = type_for_size (TYPE_PRECISION (type), unsignedp);
15213   if (type2 == NULL_TREE)
15214     return type;
15215
15216   return type2;
15217 }
15218
15219 tree
15220 signed_type (type)
15221      tree type;
15222 {
15223   tree type1 = TYPE_MAIN_VARIANT (type);
15224   ffeinfoKindtype kt;
15225   tree type2;
15226
15227   if (type1 == unsigned_char_type_node || type1 == char_type_node)
15228     return signed_char_type_node;
15229   if (type1 == unsigned_type_node)
15230     return integer_type_node;
15231   if (type1 == short_unsigned_type_node)
15232     return short_integer_type_node;
15233   if (type1 == long_unsigned_type_node)
15234     return long_integer_type_node;
15235   if (type1 == long_long_unsigned_type_node)
15236     return long_long_integer_type_node;
15237 #if 0   /* gcc/c-* files only */
15238   if (type1 == unsigned_intDI_type_node)
15239     return intDI_type_node;
15240   if (type1 == unsigned_intSI_type_node)
15241     return intSI_type_node;
15242   if (type1 == unsigned_intHI_type_node)
15243     return intHI_type_node;
15244   if (type1 == unsigned_intQI_type_node)
15245     return intQI_type_node;
15246 #endif
15247
15248   type2 = type_for_size (TYPE_PRECISION (type1), 0);
15249   if (type2 != NULL_TREE)
15250     return type2;
15251
15252   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15253     {
15254       type2 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
15255
15256       if (type1 == type2)
15257         return ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15258     }
15259
15260   return type;
15261 }
15262
15263 /* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
15264    or validate its data type for an `if' or `while' statement or ?..: exp.
15265
15266    This preparation consists of taking the ordinary
15267    representation of an expression expr and producing a valid tree
15268    boolean expression describing whether expr is nonzero.  We could
15269    simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
15270    but we optimize comparisons, &&, ||, and !.
15271
15272    The resulting type should always be `integer_type_node'.  */
15273
15274 tree
15275 truthvalue_conversion (expr)
15276      tree expr;
15277 {
15278   if (TREE_CODE (expr) == ERROR_MARK)
15279     return expr;
15280
15281 #if 0 /* This appears to be wrong for C++.  */
15282   /* These really should return error_mark_node after 2.4 is stable.
15283      But not all callers handle ERROR_MARK properly.  */
15284   switch (TREE_CODE (TREE_TYPE (expr)))
15285     {
15286     case RECORD_TYPE:
15287       error ("struct type value used where scalar is required");
15288       return integer_zero_node;
15289
15290     case UNION_TYPE:
15291       error ("union type value used where scalar is required");
15292       return integer_zero_node;
15293
15294     case ARRAY_TYPE:
15295       error ("array type value used where scalar is required");
15296       return integer_zero_node;
15297
15298     default:
15299       break;
15300     }
15301 #endif /* 0 */
15302
15303   switch (TREE_CODE (expr))
15304     {
15305       /* It is simpler and generates better code to have only TRUTH_*_EXPR
15306          or comparison expressions as truth values at this level.  */
15307 #if 0
15308     case COMPONENT_REF:
15309       /* A one-bit unsigned bit-field is already acceptable.  */
15310       if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr, 1)))
15311           && TREE_UNSIGNED (TREE_OPERAND (expr, 1)))
15312         return expr;
15313       break;
15314 #endif
15315
15316     case EQ_EXPR:
15317       /* It is simpler and generates better code to have only TRUTH_*_EXPR
15318          or comparison expressions as truth values at this level.  */
15319 #if 0
15320       if (integer_zerop (TREE_OPERAND (expr, 1)))
15321         return build_unary_op (TRUTH_NOT_EXPR, TREE_OPERAND (expr, 0), 0);
15322 #endif
15323     case NE_EXPR: case LE_EXPR: case GE_EXPR: case LT_EXPR: case GT_EXPR:
15324     case TRUTH_ANDIF_EXPR:
15325     case TRUTH_ORIF_EXPR:
15326     case TRUTH_AND_EXPR:
15327     case TRUTH_OR_EXPR:
15328     case TRUTH_XOR_EXPR:
15329       TREE_TYPE (expr) = integer_type_node;
15330       return expr;
15331
15332     case ERROR_MARK:
15333       return expr;
15334
15335     case INTEGER_CST:
15336       return integer_zerop (expr) ? integer_zero_node : integer_one_node;
15337
15338     case REAL_CST:
15339       return real_zerop (expr) ? integer_zero_node : integer_one_node;
15340
15341     case ADDR_EXPR:
15342       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 0)))
15343         return build (COMPOUND_EXPR, integer_type_node,
15344                       TREE_OPERAND (expr, 0), integer_one_node);
15345       else
15346         return integer_one_node;
15347
15348     case COMPLEX_EXPR:
15349       return ffecom_2 ((TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1))
15350                         ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
15351                        integer_type_node,
15352                        truthvalue_conversion (TREE_OPERAND (expr, 0)),
15353                        truthvalue_conversion (TREE_OPERAND (expr, 1)));
15354
15355     case NEGATE_EXPR:
15356     case ABS_EXPR:
15357     case FLOAT_EXPR:
15358     case FFS_EXPR:
15359       /* These don't change whether an object is non-zero or zero.  */
15360       return truthvalue_conversion (TREE_OPERAND (expr, 0));
15361
15362     case LROTATE_EXPR:
15363     case RROTATE_EXPR:
15364       /* These don't change whether an object is zero or non-zero, but
15365          we can't ignore them if their second arg has side-effects.  */
15366       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1)))
15367         return build (COMPOUND_EXPR, integer_type_node, TREE_OPERAND (expr, 1),
15368                       truthvalue_conversion (TREE_OPERAND (expr, 0)));
15369       else
15370         return truthvalue_conversion (TREE_OPERAND (expr, 0));
15371
15372     case COND_EXPR:
15373       /* Distribute the conversion into the arms of a COND_EXPR.  */
15374       return fold (build (COND_EXPR, integer_type_node, TREE_OPERAND (expr, 0),
15375                           truthvalue_conversion (TREE_OPERAND (expr, 1)),
15376                           truthvalue_conversion (TREE_OPERAND (expr, 2))));
15377
15378     case CONVERT_EXPR:
15379       /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
15380          since that affects how `default_conversion' will behave.  */
15381       if (TREE_CODE (TREE_TYPE (expr)) == REFERENCE_TYPE
15382           || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) == REFERENCE_TYPE)
15383         break;
15384       /* fall through... */
15385     case NOP_EXPR:
15386       /* If this is widening the argument, we can ignore it.  */
15387       if (TYPE_PRECISION (TREE_TYPE (expr))
15388           >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr, 0))))
15389         return truthvalue_conversion (TREE_OPERAND (expr, 0));
15390       break;
15391
15392     case MINUS_EXPR:
15393       /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize
15394          this case.  */
15395       if (TARGET_FLOAT_FORMAT == IEEE_FLOAT_FORMAT
15396           && TREE_CODE (TREE_TYPE (expr)) == REAL_TYPE)
15397         break;
15398       /* fall through... */
15399     case BIT_XOR_EXPR:
15400       /* This and MINUS_EXPR can be changed into a comparison of the
15401          two objects.  */
15402       if (TREE_TYPE (TREE_OPERAND (expr, 0))
15403           == TREE_TYPE (TREE_OPERAND (expr, 1)))
15404         return ffecom_2 (NE_EXPR, integer_type_node,
15405                          TREE_OPERAND (expr, 0),
15406                          TREE_OPERAND (expr, 1));
15407       return ffecom_2 (NE_EXPR, integer_type_node,
15408                        TREE_OPERAND (expr, 0),
15409                        fold (build1 (NOP_EXPR,
15410                                      TREE_TYPE (TREE_OPERAND (expr, 0)),
15411                                      TREE_OPERAND (expr, 1))));
15412
15413     case BIT_AND_EXPR:
15414       if (integer_onep (TREE_OPERAND (expr, 1)))
15415         return expr;
15416       break;
15417
15418     case MODIFY_EXPR:
15419 #if 0                           /* No such thing in Fortran. */
15420       if (warn_parentheses && C_EXP_ORIGINAL_CODE (expr) == MODIFY_EXPR)
15421         warning ("suggest parentheses around assignment used as truth value");
15422 #endif
15423       break;
15424
15425     default:
15426       break;
15427     }
15428
15429   if (TREE_CODE (TREE_TYPE (expr)) == COMPLEX_TYPE)
15430     return (ffecom_2
15431             ((TREE_SIDE_EFFECTS (expr)
15432               ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
15433              integer_type_node,
15434              truthvalue_conversion (ffecom_1 (REALPART_EXPR,
15435                                               TREE_TYPE (TREE_TYPE (expr)),
15436                                               expr)),
15437              truthvalue_conversion (ffecom_1 (IMAGPART_EXPR,
15438                                               TREE_TYPE (TREE_TYPE (expr)),
15439                                               expr))));
15440
15441   return ffecom_2 (NE_EXPR, integer_type_node,
15442                    expr,
15443                    convert (TREE_TYPE (expr), integer_zero_node));
15444 }
15445
15446 tree
15447 type_for_mode (mode, unsignedp)
15448      enum machine_mode mode;
15449      int unsignedp;
15450 {
15451   int i;
15452   int j;
15453   tree t;
15454
15455   if (mode == TYPE_MODE (integer_type_node))
15456     return unsignedp ? unsigned_type_node : integer_type_node;
15457
15458   if (mode == TYPE_MODE (signed_char_type_node))
15459     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15460
15461   if (mode == TYPE_MODE (short_integer_type_node))
15462     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15463
15464   if (mode == TYPE_MODE (long_integer_type_node))
15465     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15466
15467   if (mode == TYPE_MODE (long_long_integer_type_node))
15468     return unsignedp ? long_long_unsigned_type_node : long_long_integer_type_node;
15469
15470 #if HOST_BITS_PER_WIDE_INT >= 64
15471   if (mode == TYPE_MODE (intTI_type_node))
15472     return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
15473 #endif
15474
15475   if (mode == TYPE_MODE (float_type_node))
15476     return float_type_node;
15477
15478   if (mode == TYPE_MODE (double_type_node))
15479     return double_type_node;
15480
15481   if (mode == TYPE_MODE (build_pointer_type (char_type_node)))
15482     return build_pointer_type (char_type_node);
15483
15484   if (mode == TYPE_MODE (build_pointer_type (integer_type_node)))
15485     return build_pointer_type (integer_type_node);
15486
15487   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
15488     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
15489       {
15490         if (((t = ffecom_tree_type[i][j]) != NULL_TREE)
15491             && (mode == TYPE_MODE (t)))
15492           {
15493             if ((i == FFEINFO_basictypeINTEGER) && unsignedp)
15494               return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][j];
15495             else
15496               return t;
15497           }
15498       }
15499
15500   return 0;
15501 }
15502
15503 tree
15504 type_for_size (bits, unsignedp)
15505      unsigned bits;
15506      int unsignedp;
15507 {
15508   ffeinfoKindtype kt;
15509   tree type_node;
15510
15511   if (bits == TYPE_PRECISION (integer_type_node))
15512     return unsignedp ? unsigned_type_node : integer_type_node;
15513
15514   if (bits == TYPE_PRECISION (signed_char_type_node))
15515     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15516
15517   if (bits == TYPE_PRECISION (short_integer_type_node))
15518     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15519
15520   if (bits == TYPE_PRECISION (long_integer_type_node))
15521     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15522
15523   if (bits == TYPE_PRECISION (long_long_integer_type_node))
15524     return (unsignedp ? long_long_unsigned_type_node
15525             : long_long_integer_type_node);
15526
15527   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15528     {
15529       type_node = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15530
15531       if ((type_node != NULL_TREE) && (bits == TYPE_PRECISION (type_node)))
15532         return unsignedp ? ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]
15533           : type_node;
15534     }
15535
15536   return 0;
15537 }
15538
15539 tree
15540 unsigned_type (type)
15541      tree type;
15542 {
15543   tree type1 = TYPE_MAIN_VARIANT (type);
15544   ffeinfoKindtype kt;
15545   tree type2;
15546
15547   if (type1 == signed_char_type_node || type1 == char_type_node)
15548     return unsigned_char_type_node;
15549   if (type1 == integer_type_node)
15550     return unsigned_type_node;
15551   if (type1 == short_integer_type_node)
15552     return short_unsigned_type_node;
15553   if (type1 == long_integer_type_node)
15554     return long_unsigned_type_node;
15555   if (type1 == long_long_integer_type_node)
15556     return long_long_unsigned_type_node;
15557 #if 0   /* gcc/c-* files only */
15558   if (type1 == intDI_type_node)
15559     return unsigned_intDI_type_node;
15560   if (type1 == intSI_type_node)
15561     return unsigned_intSI_type_node;
15562   if (type1 == intHI_type_node)
15563     return unsigned_intHI_type_node;
15564   if (type1 == intQI_type_node)
15565     return unsigned_intQI_type_node;
15566 #endif
15567
15568   type2 = type_for_size (TYPE_PRECISION (type1), 1);
15569   if (type2 != NULL_TREE)
15570     return type2;
15571
15572   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15573     {
15574       type2 = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15575
15576       if (type1 == type2)
15577         return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
15578     }
15579
15580   return type;
15581 }
15582
15583 void
15584 lang_mark_tree (t)
15585      union tree_node *t ATTRIBUTE_UNUSED;
15586 {
15587   if (TREE_CODE (t) == IDENTIFIER_NODE)
15588     {
15589       struct lang_identifier *i = (struct lang_identifier *) t;
15590       ggc_mark_tree (IDENTIFIER_GLOBAL_VALUE (i));
15591       ggc_mark_tree (IDENTIFIER_LOCAL_VALUE (i));
15592       ggc_mark_tree (IDENTIFIER_LABEL_VALUE (i));
15593     }
15594   else if (TYPE_P (t) && TYPE_LANG_SPECIFIC (t))
15595     ggc_mark (TYPE_LANG_SPECIFIC (t));
15596 }
15597
15598 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
15599 \f
15600 #if FFECOM_GCC_INCLUDE
15601
15602 /* From gcc/cccp.c, the code to handle -I.  */
15603
15604 /* Skip leading "./" from a directory name.
15605    This may yield the empty string, which represents the current directory.  */
15606
15607 static const char *
15608 skip_redundant_dir_prefix (const char *dir)
15609 {
15610   while (dir[0] == '.' && dir[1] == '/')
15611     for (dir += 2; *dir == '/'; dir++)
15612       continue;
15613   if (dir[0] == '.' && !dir[1])
15614     dir++;
15615   return dir;
15616 }
15617
15618 /* The file_name_map structure holds a mapping of file names for a
15619    particular directory.  This mapping is read from the file named
15620    FILE_NAME_MAP_FILE in that directory.  Such a file can be used to
15621    map filenames on a file system with severe filename restrictions,
15622    such as DOS.  The format of the file name map file is just a series
15623    of lines with two tokens on each line.  The first token is the name
15624    to map, and the second token is the actual name to use.  */
15625
15626 struct file_name_map
15627 {
15628   struct file_name_map *map_next;
15629   char *map_from;
15630   char *map_to;
15631 };
15632
15633 #define FILE_NAME_MAP_FILE "header.gcc"
15634
15635 /* Current maximum length of directory names in the search path
15636    for include files.  (Altered as we get more of them.)  */
15637
15638 static int max_include_len = 0;
15639
15640 struct file_name_list
15641   {
15642     struct file_name_list *next;
15643     char *fname;
15644     /* Mapping of file names for this directory.  */
15645     struct file_name_map *name_map;
15646     /* Non-zero if name_map is valid.  */
15647     int got_name_map;
15648   };
15649
15650 static struct file_name_list *include = NULL;   /* First dir to search */
15651 static struct file_name_list *last_include = NULL;      /* Last in chain */
15652
15653 /* I/O buffer structure.
15654    The `fname' field is nonzero for source files and #include files
15655    and for the dummy text used for -D and -U.
15656    It is zero for rescanning results of macro expansion
15657    and for expanding macro arguments.  */
15658 #define INPUT_STACK_MAX 400
15659 static struct file_buf {
15660   const char *fname;
15661   /* Filename specified with #line command.  */
15662   const char *nominal_fname;
15663   /* Record where in the search path this file was found.
15664      For #include_next.  */
15665   struct file_name_list *dir;
15666   ffewhereLine line;
15667   ffewhereColumn column;
15668 } instack[INPUT_STACK_MAX];
15669
15670 static int last_error_tick = 0;    /* Incremented each time we print it.  */
15671 static int input_file_stack_tick = 0;  /* Incremented when status changes.  */
15672
15673 /* Current nesting level of input sources.
15674    `instack[indepth]' is the level currently being read.  */
15675 static int indepth = -1;
15676
15677 typedef struct file_buf FILE_BUF;
15678
15679 typedef unsigned char U_CHAR;
15680
15681 /* table to tell if char can be part of a C identifier. */
15682 U_CHAR is_idchar[256];
15683 /* table to tell if char can be first char of a c identifier. */
15684 U_CHAR is_idstart[256];
15685 /* table to tell if c is horizontal space.  */
15686 U_CHAR is_hor_space[256];
15687 /* table to tell if c is horizontal or vertical space.  */
15688 static U_CHAR is_space[256];
15689
15690 #define SKIP_WHITE_SPACE(p) do { while (is_hor_space[*p]) p++; } while (0)
15691 #define SKIP_ALL_WHITE_SPACE(p) do { while (is_space[*p]) p++; } while (0)
15692
15693 /* Nonzero means -I- has been seen,
15694    so don't look for #include "foo" the source-file directory.  */
15695 static int ignore_srcdir;
15696
15697 #ifndef INCLUDE_LEN_FUDGE
15698 #define INCLUDE_LEN_FUDGE 0
15699 #endif
15700
15701 static void append_include_chain (struct file_name_list *first,
15702                                   struct file_name_list *last);
15703 static FILE *open_include_file (char *filename,
15704                                 struct file_name_list *searchptr);
15705 static void print_containing_files (ffebadSeverity sev);
15706 static const char *skip_redundant_dir_prefix (const char *);
15707 static char *read_filename_string (int ch, FILE *f);
15708 static struct file_name_map *read_name_map (const char *dirname);
15709
15710 /* Append a chain of `struct file_name_list's
15711    to the end of the main include chain.
15712    FIRST is the beginning of the chain to append, and LAST is the end.  */
15713
15714 static void
15715 append_include_chain (first, last)
15716      struct file_name_list *first, *last;
15717 {
15718   struct file_name_list *dir;
15719
15720   if (!first || !last)
15721     return;
15722
15723   if (include == 0)
15724     include = first;
15725   else
15726     last_include->next = first;
15727
15728   for (dir = first; ; dir = dir->next) {
15729     int len = strlen (dir->fname) + INCLUDE_LEN_FUDGE;
15730     if (len > max_include_len)
15731       max_include_len = len;
15732     if (dir == last)
15733       break;
15734   }
15735
15736   last->next = NULL;
15737   last_include = last;
15738 }
15739
15740 /* Try to open include file FILENAME.  SEARCHPTR is the directory
15741    being tried from the include file search path.  This function maps
15742    filenames on file systems based on information read by
15743    read_name_map.  */
15744
15745 static FILE *
15746 open_include_file (filename, searchptr)
15747      char *filename;
15748      struct file_name_list *searchptr;
15749 {
15750   register struct file_name_map *map;
15751   register char *from;
15752   char *p, *dir;
15753
15754   if (searchptr && ! searchptr->got_name_map)
15755     {
15756       searchptr->name_map = read_name_map (searchptr->fname
15757                                            ? searchptr->fname : ".");
15758       searchptr->got_name_map = 1;
15759     }
15760
15761   /* First check the mapping for the directory we are using.  */
15762   if (searchptr && searchptr->name_map)
15763     {
15764       from = filename;
15765       if (searchptr->fname)
15766         from += strlen (searchptr->fname) + 1;
15767       for (map = searchptr->name_map; map; map = map->map_next)
15768         {
15769           if (! strcmp (map->map_from, from))
15770             {
15771               /* Found a match.  */
15772               return fopen (map->map_to, "r");
15773             }
15774         }
15775     }
15776
15777   /* Try to find a mapping file for the particular directory we are
15778      looking in.  Thus #include <sys/types.h> will look up sys/types.h
15779      in /usr/include/header.gcc and look up types.h in
15780      /usr/include/sys/header.gcc.  */
15781   p = strrchr (filename, '/');
15782 #ifdef DIR_SEPARATOR
15783   if (! p) p = strrchr (filename, DIR_SEPARATOR);
15784   else {
15785     char *tmp = strrchr (filename, DIR_SEPARATOR);
15786     if (tmp != NULL && tmp > p) p = tmp;
15787   }
15788 #endif
15789   if (! p)
15790     p = filename;
15791   if (searchptr
15792       && searchptr->fname
15793       && strlen (searchptr->fname) == (size_t) (p - filename)
15794       && ! strncmp (searchptr->fname, filename, (int) (p - filename)))
15795     {
15796       /* FILENAME is in SEARCHPTR, which we've already checked.  */
15797       return fopen (filename, "r");
15798     }
15799
15800   if (p == filename)
15801     {
15802       from = filename;
15803       map = read_name_map (".");
15804     }
15805   else
15806     {
15807       dir = (char *) xmalloc (p - filename + 1);
15808       memcpy (dir, filename, p - filename);
15809       dir[p - filename] = '\0';
15810       from = p + 1;
15811       map = read_name_map (dir);
15812       free (dir);
15813     }
15814   for (; map; map = map->map_next)
15815     if (! strcmp (map->map_from, from))
15816       return fopen (map->map_to, "r");
15817
15818   return fopen (filename, "r");
15819 }
15820
15821 /* Print the file names and line numbers of the #include
15822    commands which led to the current file.  */
15823
15824 static void
15825 print_containing_files (ffebadSeverity sev)
15826 {
15827   FILE_BUF *ip = NULL;
15828   int i;
15829   int first = 1;
15830   const char *str1;
15831   const char *str2;
15832
15833   /* If stack of files hasn't changed since we last printed
15834      this info, don't repeat it.  */
15835   if (last_error_tick == input_file_stack_tick)
15836     return;
15837
15838   for (i = indepth; i >= 0; i--)
15839     if (instack[i].fname != NULL) {
15840       ip = &instack[i];
15841       break;
15842     }
15843
15844   /* Give up if we don't find a source file.  */
15845   if (ip == NULL)
15846     return;
15847
15848   /* Find the other, outer source files.  */
15849   for (i--; i >= 0; i--)
15850     if (instack[i].fname != NULL)
15851       {
15852         ip = &instack[i];
15853         if (first)
15854           {
15855             first = 0;
15856             str1 = "In file included";
15857           }
15858         else
15859           {
15860             str1 = "...          ...";
15861           }
15862
15863         if (i == 1)
15864           str2 = ":";
15865         else
15866           str2 = "";
15867
15868         ffebad_start_msg ("%A from %B at %0%C", sev);
15869         ffebad_here (0, ip->line, ip->column);
15870         ffebad_string (str1);
15871         ffebad_string (ip->nominal_fname);
15872         ffebad_string (str2);
15873         ffebad_finish ();
15874       }
15875
15876   /* Record we have printed the status as of this time.  */
15877   last_error_tick = input_file_stack_tick;
15878 }
15879
15880 /* Read a space delimited string of unlimited length from a stdio
15881    file.  */
15882
15883 static char *
15884 read_filename_string (ch, f)
15885      int ch;
15886      FILE *f;
15887 {
15888   char *alloc, *set;
15889   int len;
15890
15891   len = 20;
15892   set = alloc = xmalloc (len + 1);
15893   if (! is_space[ch])
15894     {
15895       *set++ = ch;
15896       while ((ch = getc (f)) != EOF && ! is_space[ch])
15897         {
15898           if (set - alloc == len)
15899             {
15900               len *= 2;
15901               alloc = xrealloc (alloc, len + 1);
15902               set = alloc + len / 2;
15903             }
15904           *set++ = ch;
15905         }
15906     }
15907   *set = '\0';
15908   ungetc (ch, f);
15909   return alloc;
15910 }
15911
15912 /* Read the file name map file for DIRNAME.  */
15913
15914 static struct file_name_map *
15915 read_name_map (dirname)
15916      const char *dirname;
15917 {
15918   /* This structure holds a linked list of file name maps, one per
15919      directory.  */
15920   struct file_name_map_list
15921     {
15922       struct file_name_map_list *map_list_next;
15923       char *map_list_name;
15924       struct file_name_map *map_list_map;
15925     };
15926   static struct file_name_map_list *map_list;
15927   register struct file_name_map_list *map_list_ptr;
15928   char *name;
15929   FILE *f;
15930   size_t dirlen;
15931   int separator_needed;
15932
15933   dirname = skip_redundant_dir_prefix (dirname);
15934
15935   for (map_list_ptr = map_list; map_list_ptr;
15936        map_list_ptr = map_list_ptr->map_list_next)
15937     if (! strcmp (map_list_ptr->map_list_name, dirname))
15938       return map_list_ptr->map_list_map;
15939
15940   map_list_ptr = ((struct file_name_map_list *)
15941                   xmalloc (sizeof (struct file_name_map_list)));
15942   map_list_ptr->map_list_name = xstrdup (dirname);
15943   map_list_ptr->map_list_map = NULL;
15944
15945   dirlen = strlen (dirname);
15946   separator_needed = dirlen != 0 && dirname[dirlen - 1] != '/';
15947   name = (char *) xmalloc (dirlen + strlen (FILE_NAME_MAP_FILE) + 2);
15948   strcpy (name, dirname);
15949   name[dirlen] = '/';
15950   strcpy (name + dirlen + separator_needed, FILE_NAME_MAP_FILE);
15951   f = fopen (name, "r");
15952   free (name);
15953   if (!f)
15954     map_list_ptr->map_list_map = NULL;
15955   else
15956     {
15957       int ch;
15958
15959       while ((ch = getc (f)) != EOF)
15960         {
15961           char *from, *to;
15962           struct file_name_map *ptr;
15963
15964           if (is_space[ch])
15965             continue;
15966           from = read_filename_string (ch, f);
15967           while ((ch = getc (f)) != EOF && is_hor_space[ch])
15968             ;
15969           to = read_filename_string (ch, f);
15970
15971           ptr = ((struct file_name_map *)
15972                  xmalloc (sizeof (struct file_name_map)));
15973           ptr->map_from = from;
15974
15975           /* Make the real filename absolute.  */
15976           if (*to == '/')
15977             ptr->map_to = to;
15978           else
15979             {
15980               ptr->map_to = xmalloc (dirlen + strlen (to) + 2);
15981               strcpy (ptr->map_to, dirname);
15982               ptr->map_to[dirlen] = '/';
15983               strcpy (ptr->map_to + dirlen + separator_needed, to);
15984               free (to);
15985             }
15986
15987           ptr->map_next = map_list_ptr->map_list_map;
15988           map_list_ptr->map_list_map = ptr;
15989
15990           while ((ch = getc (f)) != '\n')
15991             if (ch == EOF)
15992               break;
15993         }
15994       fclose (f);
15995     }
15996
15997   map_list_ptr->map_list_next = map_list;
15998   map_list = map_list_ptr;
15999
16000   return map_list_ptr->map_list_map;
16001 }
16002
16003 static void
16004 ffecom_file_ (const char *name)
16005 {
16006   FILE_BUF *fp;
16007
16008   /* Do partial setup of input buffer for the sake of generating
16009      early #line directives (when -g is in effect).  */
16010
16011   fp = &instack[++indepth];
16012   memset ((char *) fp, 0, sizeof (FILE_BUF));
16013   if (name == NULL)
16014     name = "";
16015   fp->nominal_fname = fp->fname = name;
16016 }
16017
16018 /* Initialize syntactic classifications of characters.  */
16019
16020 static void
16021 ffecom_initialize_char_syntax_ ()
16022 {
16023   register int i;
16024
16025   /*
16026    * Set up is_idchar and is_idstart tables.  These should be
16027    * faster than saying (is_alpha (c) || c == '_'), etc.
16028    * Set up these things before calling any routines tthat
16029    * refer to them.
16030    */
16031   for (i = 'a'; i <= 'z'; i++) {
16032     is_idchar[i - 'a' + 'A'] = 1;
16033     is_idchar[i] = 1;
16034     is_idstart[i - 'a' + 'A'] = 1;
16035     is_idstart[i] = 1;
16036   }
16037   for (i = '0'; i <= '9'; i++)
16038     is_idchar[i] = 1;
16039   is_idchar['_'] = 1;
16040   is_idstart['_'] = 1;
16041
16042   /* horizontal space table */
16043   is_hor_space[' '] = 1;
16044   is_hor_space['\t'] = 1;
16045   is_hor_space['\v'] = 1;
16046   is_hor_space['\f'] = 1;
16047   is_hor_space['\r'] = 1;
16048
16049   is_space[' '] = 1;
16050   is_space['\t'] = 1;
16051   is_space['\v'] = 1;
16052   is_space['\f'] = 1;
16053   is_space['\n'] = 1;
16054   is_space['\r'] = 1;
16055 }
16056
16057 static void
16058 ffecom_close_include_ (FILE *f)
16059 {
16060   fclose (f);
16061
16062   indepth--;
16063   input_file_stack_tick++;
16064
16065   ffewhere_line_kill (instack[indepth].line);
16066   ffewhere_column_kill (instack[indepth].column);
16067 }
16068
16069 static int
16070 ffecom_decode_include_option_ (char *spec)
16071 {
16072   struct file_name_list *dirtmp;
16073
16074   if (! ignore_srcdir && !strcmp (spec, "-"))
16075     ignore_srcdir = 1;
16076   else
16077     {
16078       dirtmp = (struct file_name_list *)
16079         xmalloc (sizeof (struct file_name_list));
16080       dirtmp->next = 0;         /* New one goes on the end */
16081       dirtmp->fname = spec;
16082       dirtmp->got_name_map = 0;
16083       if (spec[0] == 0)
16084         error ("Directory name must immediately follow -I");
16085       else
16086         append_include_chain (dirtmp, dirtmp);
16087     }
16088   return 1;
16089 }
16090
16091 /* Open INCLUDEd file.  */
16092
16093 static FILE *
16094 ffecom_open_include_ (char *name, ffewhereLine l, ffewhereColumn c)
16095 {
16096   char *fbeg = name;
16097   size_t flen = strlen (fbeg);
16098   struct file_name_list *search_start = include; /* Chain of dirs to search */
16099   struct file_name_list dsp[1]; /* First in chain, if #include "..." */
16100   struct file_name_list *searchptr = 0;
16101   char *fname;          /* Dynamically allocated fname buffer */
16102   FILE *f;
16103   FILE_BUF *fp;
16104
16105   if (flen == 0)
16106     return NULL;
16107
16108   dsp[0].fname = NULL;
16109
16110   /* If -I- was specified, don't search current dir, only spec'd ones. */
16111   if (!ignore_srcdir)
16112     {
16113       for (fp = &instack[indepth]; fp >= instack; fp--)
16114         {
16115           int n;
16116           char *ep;
16117           const char *nam;
16118
16119           if ((nam = fp->nominal_fname) != NULL)
16120             {
16121               /* Found a named file.  Figure out dir of the file,
16122                  and put it in front of the search list.  */
16123               dsp[0].next = search_start;
16124               search_start = dsp;
16125 #ifndef VMS
16126               ep = strrchr (nam, '/');
16127 #ifdef DIR_SEPARATOR
16128             if (ep == NULL) ep = strrchr (nam, DIR_SEPARATOR);
16129             else {
16130               char *tmp = strrchr (nam, DIR_SEPARATOR);
16131               if (tmp != NULL && tmp > ep) ep = tmp;
16132             }
16133 #endif
16134 #else                           /* VMS */
16135               ep = strrchr (nam, ']');
16136               if (ep == NULL) ep = strrchr (nam, '>');
16137               if (ep == NULL) ep = strrchr (nam, ':');
16138               if (ep != NULL) ep++;
16139 #endif                          /* VMS */
16140               if (ep != NULL)
16141                 {
16142                   n = ep - nam;
16143                   dsp[0].fname = (char *) xmalloc (n + 1);
16144                   strncpy (dsp[0].fname, nam, n);
16145                   dsp[0].fname[n] = '\0';
16146                   if (n + INCLUDE_LEN_FUDGE > max_include_len)
16147                     max_include_len = n + INCLUDE_LEN_FUDGE;
16148                 }
16149               else
16150                 dsp[0].fname = NULL; /* Current directory */
16151               dsp[0].got_name_map = 0;
16152               break;
16153             }
16154         }
16155     }
16156
16157   /* Allocate this permanently, because it gets stored in the definitions
16158      of macros.  */
16159   fname = xmalloc (max_include_len + flen + 4);
16160   /* + 2 above for slash and terminating null.  */
16161   /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED
16162      for g77 yet).  */
16163
16164   /* If specified file name is absolute, just open it.  */
16165
16166   if (*fbeg == '/'
16167 #ifdef DIR_SEPARATOR
16168       || *fbeg == DIR_SEPARATOR
16169 #endif
16170       )
16171     {
16172       strncpy (fname, (char *) fbeg, flen);
16173       fname[flen] = 0;
16174       f = open_include_file (fname, NULL_PTR);
16175     }
16176   else
16177     {
16178       f = NULL;
16179
16180       /* Search directory path, trying to open the file.
16181          Copy each filename tried into FNAME.  */
16182
16183       for (searchptr = search_start; searchptr; searchptr = searchptr->next)
16184         {
16185           if (searchptr->fname)
16186             {
16187               /* The empty string in a search path is ignored.
16188                  This makes it possible to turn off entirely
16189                  a standard piece of the list.  */
16190               if (searchptr->fname[0] == 0)
16191                 continue;
16192               strcpy (fname, skip_redundant_dir_prefix (searchptr->fname));
16193               if (fname[0] && fname[strlen (fname) - 1] != '/')
16194                 strcat (fname, "/");
16195               fname[strlen (fname) + flen] = 0;
16196             }
16197           else
16198             fname[0] = 0;
16199
16200           strncat (fname, fbeg, flen);
16201 #ifdef VMS
16202           /* Change this 1/2 Unix 1/2 VMS file specification into a
16203              full VMS file specification */
16204           if (searchptr->fname && (searchptr->fname[0] != 0))
16205             {
16206               /* Fix up the filename */
16207               hack_vms_include_specification (fname);
16208             }
16209           else
16210             {
16211               /* This is a normal VMS filespec, so use it unchanged.  */
16212               strncpy (fname, (char *) fbeg, flen);
16213               fname[flen] = 0;
16214 #if 0   /* Not for g77.  */
16215               /* if it's '#include filename', add the missing .h */
16216               if (strchr (fname, '.') == NULL)
16217                 strcat (fname, ".h");
16218 #endif
16219             }
16220 #endif /* VMS */
16221           f = open_include_file (fname, searchptr);
16222 #ifdef EACCES
16223           if (f == NULL && errno == EACCES)
16224             {
16225               print_containing_files (FFEBAD_severityWARNING);
16226               ffebad_start_msg ("At %0, INCLUDE file %A exists, but is not readable",
16227                                 FFEBAD_severityWARNING);
16228               ffebad_string (fname);
16229               ffebad_here (0, l, c);
16230               ffebad_finish ();
16231             }
16232 #endif
16233           if (f != NULL)
16234             break;
16235         }
16236     }
16237
16238   if (f == NULL)
16239     {
16240       /* A file that was not found.  */
16241
16242       strncpy (fname, (char *) fbeg, flen);
16243       fname[flen] = 0;
16244       print_containing_files (ffebad_severity (FFEBAD_OPEN_INCLUDE));
16245       ffebad_start (FFEBAD_OPEN_INCLUDE);
16246       ffebad_here (0, l, c);
16247       ffebad_string (fname);
16248       ffebad_finish ();
16249     }
16250
16251   if (dsp[0].fname != NULL)
16252     free (dsp[0].fname);
16253
16254   if (f == NULL)
16255     return NULL;
16256
16257   if (indepth >= (INPUT_STACK_MAX - 1))
16258     {
16259       print_containing_files (FFEBAD_severityFATAL);
16260       ffebad_start_msg ("At %0, INCLUDE nesting too deep",
16261                         FFEBAD_severityFATAL);
16262       ffebad_string (fname);
16263       ffebad_here (0, l, c);
16264       ffebad_finish ();
16265       return NULL;
16266     }
16267
16268   instack[indepth].line = ffewhere_line_use (l);
16269   instack[indepth].column = ffewhere_column_use (c);
16270
16271   fp = &instack[indepth + 1];
16272   memset ((char *) fp, 0, sizeof (FILE_BUF));
16273   fp->nominal_fname = fp->fname = fname;
16274   fp->dir = searchptr;
16275
16276   indepth++;
16277   input_file_stack_tick++;
16278
16279   return f;
16280 }
16281 #endif  /* FFECOM_GCC_INCLUDE */
16282
16283 /**INDENT* (Do not reformat this comment even with -fca option.)
16284    Data-gathering files: Given the source file listed below, compiled with
16285    f2c I obtained the output file listed after that, and from the output
16286    file I derived the above code.
16287
16288 -------- (begin input file to f2c)
16289         implicit none
16290         character*10 A1,A2
16291         complex C1,C2
16292         integer I1,I2
16293         real R1,R2
16294         double precision D1,D2
16295 C
16296         call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2)
16297 c /
16298         call fooI(I1/I2)
16299         call fooR(R1/I1)
16300         call fooD(D1/I1)
16301         call fooC(C1/I1)
16302         call fooR(R1/R2)
16303         call fooD(R1/D1)
16304         call fooD(D1/D2)
16305         call fooD(D1/R1)
16306         call fooC(C1/C2)
16307         call fooC(C1/R1)
16308         call fooZ(C1/D1)
16309 c **
16310         call fooI(I1**I2)
16311         call fooR(R1**I1)
16312         call fooD(D1**I1)
16313         call fooC(C1**I1)
16314         call fooR(R1**R2)
16315         call fooD(R1**D1)
16316         call fooD(D1**D2)
16317         call fooD(D1**R1)
16318         call fooC(C1**C2)
16319         call fooC(C1**R1)
16320         call fooZ(C1**D1)
16321 c FFEINTRIN_impABS
16322         call fooR(ABS(R1))
16323 c FFEINTRIN_impACOS
16324         call fooR(ACOS(R1))
16325 c FFEINTRIN_impAIMAG
16326         call fooR(AIMAG(C1))
16327 c FFEINTRIN_impAINT
16328         call fooR(AINT(R1))
16329 c FFEINTRIN_impALOG
16330         call fooR(ALOG(R1))
16331 c FFEINTRIN_impALOG10
16332         call fooR(ALOG10(R1))
16333 c FFEINTRIN_impAMAX0
16334         call fooR(AMAX0(I1,I2))
16335 c FFEINTRIN_impAMAX1
16336         call fooR(AMAX1(R1,R2))
16337 c FFEINTRIN_impAMIN0
16338         call fooR(AMIN0(I1,I2))
16339 c FFEINTRIN_impAMIN1
16340         call fooR(AMIN1(R1,R2))
16341 c FFEINTRIN_impAMOD
16342         call fooR(AMOD(R1,R2))
16343 c FFEINTRIN_impANINT
16344         call fooR(ANINT(R1))
16345 c FFEINTRIN_impASIN
16346         call fooR(ASIN(R1))
16347 c FFEINTRIN_impATAN
16348         call fooR(ATAN(R1))
16349 c FFEINTRIN_impATAN2
16350         call fooR(ATAN2(R1,R2))
16351 c FFEINTRIN_impCABS
16352         call fooR(CABS(C1))
16353 c FFEINTRIN_impCCOS
16354         call fooC(CCOS(C1))
16355 c FFEINTRIN_impCEXP
16356         call fooC(CEXP(C1))
16357 c FFEINTRIN_impCHAR
16358         call fooA(CHAR(I1))
16359 c FFEINTRIN_impCLOG
16360         call fooC(CLOG(C1))
16361 c FFEINTRIN_impCONJG
16362         call fooC(CONJG(C1))
16363 c FFEINTRIN_impCOS
16364         call fooR(COS(R1))
16365 c FFEINTRIN_impCOSH
16366         call fooR(COSH(R1))
16367 c FFEINTRIN_impCSIN
16368         call fooC(CSIN(C1))
16369 c FFEINTRIN_impCSQRT
16370         call fooC(CSQRT(C1))
16371 c FFEINTRIN_impDABS
16372         call fooD(DABS(D1))
16373 c FFEINTRIN_impDACOS
16374         call fooD(DACOS(D1))
16375 c FFEINTRIN_impDASIN
16376         call fooD(DASIN(D1))
16377 c FFEINTRIN_impDATAN
16378         call fooD(DATAN(D1))
16379 c FFEINTRIN_impDATAN2
16380         call fooD(DATAN2(D1,D2))
16381 c FFEINTRIN_impDCOS
16382         call fooD(DCOS(D1))
16383 c FFEINTRIN_impDCOSH
16384         call fooD(DCOSH(D1))
16385 c FFEINTRIN_impDDIM
16386         call fooD(DDIM(D1,D2))
16387 c FFEINTRIN_impDEXP
16388         call fooD(DEXP(D1))
16389 c FFEINTRIN_impDIM
16390         call fooR(DIM(R1,R2))
16391 c FFEINTRIN_impDINT
16392         call fooD(DINT(D1))
16393 c FFEINTRIN_impDLOG
16394         call fooD(DLOG(D1))
16395 c FFEINTRIN_impDLOG10
16396         call fooD(DLOG10(D1))
16397 c FFEINTRIN_impDMAX1
16398         call fooD(DMAX1(D1,D2))
16399 c FFEINTRIN_impDMIN1
16400         call fooD(DMIN1(D1,D2))
16401 c FFEINTRIN_impDMOD
16402         call fooD(DMOD(D1,D2))
16403 c FFEINTRIN_impDNINT
16404         call fooD(DNINT(D1))
16405 c FFEINTRIN_impDPROD
16406         call fooD(DPROD(R1,R2))
16407 c FFEINTRIN_impDSIGN
16408         call fooD(DSIGN(D1,D2))
16409 c FFEINTRIN_impDSIN
16410         call fooD(DSIN(D1))
16411 c FFEINTRIN_impDSINH
16412         call fooD(DSINH(D1))
16413 c FFEINTRIN_impDSQRT
16414         call fooD(DSQRT(D1))
16415 c FFEINTRIN_impDTAN
16416         call fooD(DTAN(D1))
16417 c FFEINTRIN_impDTANH
16418         call fooD(DTANH(D1))
16419 c FFEINTRIN_impEXP
16420         call fooR(EXP(R1))
16421 c FFEINTRIN_impIABS
16422         call fooI(IABS(I1))
16423 c FFEINTRIN_impICHAR
16424         call fooI(ICHAR(A1))
16425 c FFEINTRIN_impIDIM
16426         call fooI(IDIM(I1,I2))
16427 c FFEINTRIN_impIDNINT
16428         call fooI(IDNINT(D1))
16429 c FFEINTRIN_impINDEX
16430         call fooI(INDEX(A1,A2))
16431 c FFEINTRIN_impISIGN
16432         call fooI(ISIGN(I1,I2))
16433 c FFEINTRIN_impLEN
16434         call fooI(LEN(A1))
16435 c FFEINTRIN_impLGE
16436         call fooL(LGE(A1,A2))
16437 c FFEINTRIN_impLGT
16438         call fooL(LGT(A1,A2))
16439 c FFEINTRIN_impLLE
16440         call fooL(LLE(A1,A2))
16441 c FFEINTRIN_impLLT
16442         call fooL(LLT(A1,A2))
16443 c FFEINTRIN_impMAX0
16444         call fooI(MAX0(I1,I2))
16445 c FFEINTRIN_impMAX1
16446         call fooI(MAX1(R1,R2))
16447 c FFEINTRIN_impMIN0
16448         call fooI(MIN0(I1,I2))
16449 c FFEINTRIN_impMIN1
16450         call fooI(MIN1(R1,R2))
16451 c FFEINTRIN_impMOD
16452         call fooI(MOD(I1,I2))
16453 c FFEINTRIN_impNINT
16454         call fooI(NINT(R1))
16455 c FFEINTRIN_impSIGN
16456         call fooR(SIGN(R1,R2))
16457 c FFEINTRIN_impSIN
16458         call fooR(SIN(R1))
16459 c FFEINTRIN_impSINH
16460         call fooR(SINH(R1))
16461 c FFEINTRIN_impSQRT
16462         call fooR(SQRT(R1))
16463 c FFEINTRIN_impTAN
16464         call fooR(TAN(R1))
16465 c FFEINTRIN_impTANH
16466         call fooR(TANH(R1))
16467 c FFEINTRIN_imp_CMPLX_C
16468         call fooC(cmplx(C1,C2))
16469 c FFEINTRIN_imp_CMPLX_D
16470         call fooZ(cmplx(D1,D2))
16471 c FFEINTRIN_imp_CMPLX_I
16472         call fooC(cmplx(I1,I2))
16473 c FFEINTRIN_imp_CMPLX_R
16474         call fooC(cmplx(R1,R2))
16475 c FFEINTRIN_imp_DBLE_C
16476         call fooD(dble(C1))
16477 c FFEINTRIN_imp_DBLE_D
16478         call fooD(dble(D1))
16479 c FFEINTRIN_imp_DBLE_I
16480         call fooD(dble(I1))
16481 c FFEINTRIN_imp_DBLE_R
16482         call fooD(dble(R1))
16483 c FFEINTRIN_imp_INT_C
16484         call fooI(int(C1))
16485 c FFEINTRIN_imp_INT_D
16486         call fooI(int(D1))
16487 c FFEINTRIN_imp_INT_I
16488         call fooI(int(I1))
16489 c FFEINTRIN_imp_INT_R
16490         call fooI(int(R1))
16491 c FFEINTRIN_imp_REAL_C
16492         call fooR(real(C1))
16493 c FFEINTRIN_imp_REAL_D
16494         call fooR(real(D1))
16495 c FFEINTRIN_imp_REAL_I
16496         call fooR(real(I1))
16497 c FFEINTRIN_imp_REAL_R
16498         call fooR(real(R1))
16499 c
16500 c FFEINTRIN_imp_INT_D:
16501 c
16502 c FFEINTRIN_specIDINT
16503         call fooI(IDINT(D1))
16504 c
16505 c FFEINTRIN_imp_INT_R:
16506 c
16507 c FFEINTRIN_specIFIX
16508         call fooI(IFIX(R1))
16509 c FFEINTRIN_specINT
16510         call fooI(INT(R1))
16511 c
16512 c FFEINTRIN_imp_REAL_D:
16513 c
16514 c FFEINTRIN_specSNGL
16515         call fooR(SNGL(D1))
16516 c
16517 c FFEINTRIN_imp_REAL_I:
16518 c
16519 c FFEINTRIN_specFLOAT
16520         call fooR(FLOAT(I1))
16521 c FFEINTRIN_specREAL
16522         call fooR(REAL(I1))
16523 c
16524         end
16525 -------- (end input file to f2c)
16526
16527 -------- (begin output from providing above input file as input to:
16528 --------  `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
16529 --------     -e "s:^#.*$::g"')
16530
16531 //  -- translated by f2c (version 19950223).
16532    You must link the resulting object file with the libraries:
16533         -lf2c -lm   (in that order)
16534 //
16535
16536
16537 // f2c.h  --  Standard Fortran to C header file //
16538
16539 ///  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
16540
16541         - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
16542
16543
16544
16545
16546 // F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems //
16547 // we assume short, float are OK //
16548 typedef long int // long int // integer;
16549 typedef char *address;
16550 typedef short int shortint;
16551 typedef float real;
16552 typedef double doublereal;
16553 typedef struct { real r, i; } complex;
16554 typedef struct { doublereal r, i; } doublecomplex;
16555 typedef long int // long int // logical;
16556 typedef short int shortlogical;
16557 typedef char logical1;
16558 typedef char integer1;
16559 // typedef long long longint; // // system-dependent //
16560
16561
16562
16563
16564 // Extern is for use with -E //
16565
16566
16567
16568
16569 // I/O stuff //
16570
16571
16572
16573
16574
16575
16576
16577
16578 typedef long int // int or long int // flag;
16579 typedef long int // int or long int // ftnlen;
16580 typedef long int // int or long int // ftnint;
16581
16582
16583 //external read, write//
16584 typedef struct
16585 {       flag cierr;
16586         ftnint ciunit;
16587         flag ciend;
16588         char *cifmt;
16589         ftnint cirec;
16590 } cilist;
16591
16592 //internal read, write//
16593 typedef struct
16594 {       flag icierr;
16595         char *iciunit;
16596         flag iciend;
16597         char *icifmt;
16598         ftnint icirlen;
16599         ftnint icirnum;
16600 } icilist;
16601
16602 //open//
16603 typedef struct
16604 {       flag oerr;
16605         ftnint ounit;
16606         char *ofnm;
16607         ftnlen ofnmlen;
16608         char *osta;
16609         char *oacc;
16610         char *ofm;
16611         ftnint orl;
16612         char *oblnk;
16613 } olist;
16614
16615 //close//
16616 typedef struct
16617 {       flag cerr;
16618         ftnint cunit;
16619         char *csta;
16620 } cllist;
16621
16622 //rewind, backspace, endfile//
16623 typedef struct
16624 {       flag aerr;
16625         ftnint aunit;
16626 } alist;
16627
16628 // inquire //
16629 typedef struct
16630 {       flag inerr;
16631         ftnint inunit;
16632         char *infile;
16633         ftnlen infilen;
16634         ftnint  *inex;  //parameters in standard's order//
16635         ftnint  *inopen;
16636         ftnint  *innum;
16637         ftnint  *innamed;
16638         char    *inname;
16639         ftnlen  innamlen;
16640         char    *inacc;
16641         ftnlen  inacclen;
16642         char    *inseq;
16643         ftnlen  inseqlen;
16644         char    *indir;
16645         ftnlen  indirlen;
16646         char    *infmt;
16647         ftnlen  infmtlen;
16648         char    *inform;
16649         ftnint  informlen;
16650         char    *inunf;
16651         ftnlen  inunflen;
16652         ftnint  *inrecl;
16653         ftnint  *innrec;
16654         char    *inblank;
16655         ftnlen  inblanklen;
16656 } inlist;
16657
16658
16659
16660 union Multitype {       // for multiple entry points //
16661         integer1 g;
16662         shortint h;
16663         integer i;
16664         // longint j; //
16665         real r;
16666         doublereal d;
16667         complex c;
16668         doublecomplex z;
16669         };
16670
16671 typedef union Multitype Multitype;
16672
16673 typedef long Long;      // No longer used; formerly in Namelist //
16674
16675 struct Vardesc {        // for Namelist //
16676         char *name;
16677         char *addr;
16678         ftnlen *dims;
16679         int  type;
16680         };
16681 typedef struct Vardesc Vardesc;
16682
16683 struct Namelist {
16684         char *name;
16685         Vardesc **vars;
16686         int nvars;
16687         };
16688 typedef struct Namelist Namelist;
16689
16690
16691
16692
16693
16694
16695
16696
16697 // procedure parameter types for -A and -C++ //
16698
16699
16700
16701
16702 typedef int // Unknown procedure type // (*U_fp)();
16703 typedef shortint (*J_fp)();
16704 typedef integer (*I_fp)();
16705 typedef real (*R_fp)();
16706 typedef doublereal (*D_fp)(), (*E_fp)();
16707 typedef // Complex // void  (*C_fp)();
16708 typedef // Double Complex // void  (*Z_fp)();
16709 typedef logical (*L_fp)();
16710 typedef shortlogical (*K_fp)();
16711 typedef // Character // void  (*H_fp)();
16712 typedef // Subroutine // int (*S_fp)();
16713
16714 // E_fp is for real functions when -R is not specified //
16715 typedef void  C_f;      // complex function //
16716 typedef void  H_f;      // character function //
16717 typedef void  Z_f;      // double complex function //
16718 typedef doublereal E_f; // real function with -R not specified //
16719
16720 // undef any lower-case symbols that your C compiler predefines, e.g.: //
16721
16722
16723 // (No such symbols should be defined in a strict ANSI C compiler.
16724    We can avoid trouble with f2c-translated code by using
16725    gcc -ansi [-traditional].) //
16726
16727
16728
16729
16730
16731
16732
16733
16734
16735
16736
16737
16738
16739
16740
16741
16742
16743
16744
16745
16746
16747
16748
16749 // Main program // MAIN__()
16750 {
16751     // System generated locals //
16752     integer i__1;
16753     real r__1, r__2;
16754     doublereal d__1, d__2;
16755     complex q__1;
16756     doublecomplex z__1, z__2, z__3;
16757     logical L__1;
16758     char ch__1[1];
16759
16760     // Builtin functions //
16761     void c_div();
16762     integer pow_ii();
16763     double pow_ri(), pow_di();
16764     void pow_ci();
16765     double pow_dd();
16766     void pow_zz();
16767     double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
16768             asin(), atan(), atan2(), c_abs();
16769     void c_cos(), c_exp(), c_log(), r_cnjg();
16770     double cos(), cosh();
16771     void c_sin(), c_sqrt();
16772     double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
16773             d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
16774     integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
16775     logical l_ge(), l_gt(), l_le(), l_lt();
16776     integer i_nint();
16777     double r_sign();
16778
16779     // Local variables //
16780     extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
16781             fool_(), fooz_(), getem_();
16782     static char a1[10], a2[10];
16783     static complex c1, c2;
16784     static doublereal d1, d2;
16785     static integer i1, i2;
16786     static real r1, r2;
16787
16788
16789     getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L);
16790 // / //
16791     i__1 = i1 / i2;
16792     fooi_(&i__1);
16793     r__1 = r1 / i1;
16794     foor_(&r__1);
16795     d__1 = d1 / i1;
16796     food_(&d__1);
16797     d__1 = (doublereal) i1;
16798     q__1.r = c1.r / d__1, q__1.i = c1.i / d__1;
16799     fooc_(&q__1);
16800     r__1 = r1 / r2;
16801     foor_(&r__1);
16802     d__1 = r1 / d1;
16803     food_(&d__1);
16804     d__1 = d1 / d2;
16805     food_(&d__1);
16806     d__1 = d1 / r1;
16807     food_(&d__1);
16808     c_div(&q__1, &c1, &c2);
16809     fooc_(&q__1);
16810     q__1.r = c1.r / r1, q__1.i = c1.i / r1;
16811     fooc_(&q__1);
16812     z__1.r = c1.r / d1, z__1.i = c1.i / d1;
16813     fooz_(&z__1);
16814 // ** //
16815     i__1 = pow_ii(&i1, &i2);
16816     fooi_(&i__1);
16817     r__1 = pow_ri(&r1, &i1);
16818     foor_(&r__1);
16819     d__1 = pow_di(&d1, &i1);
16820     food_(&d__1);
16821     pow_ci(&q__1, &c1, &i1);
16822     fooc_(&q__1);
16823     d__1 = (doublereal) r1;
16824     d__2 = (doublereal) r2;
16825     r__1 = pow_dd(&d__1, &d__2);
16826     foor_(&r__1);
16827     d__2 = (doublereal) r1;
16828     d__1 = pow_dd(&d__2, &d1);
16829     food_(&d__1);
16830     d__1 = pow_dd(&d1, &d2);
16831     food_(&d__1);
16832     d__2 = (doublereal) r1;
16833     d__1 = pow_dd(&d1, &d__2);
16834     food_(&d__1);
16835     z__2.r = c1.r, z__2.i = c1.i;
16836     z__3.r = c2.r, z__3.i = c2.i;
16837     pow_zz(&z__1, &z__2, &z__3);
16838     q__1.r = z__1.r, q__1.i = z__1.i;
16839     fooc_(&q__1);
16840     z__2.r = c1.r, z__2.i = c1.i;
16841     z__3.r = r1, z__3.i = 0.;
16842     pow_zz(&z__1, &z__2, &z__3);
16843     q__1.r = z__1.r, q__1.i = z__1.i;
16844     fooc_(&q__1);
16845     z__2.r = c1.r, z__2.i = c1.i;
16846     z__3.r = d1, z__3.i = 0.;
16847     pow_zz(&z__1, &z__2, &z__3);
16848     fooz_(&z__1);
16849 // FFEINTRIN_impABS //
16850     r__1 = (doublereal)((  r1  ) >= 0 ? (  r1  ) : -(  r1  ))  ;
16851     foor_(&r__1);
16852 // FFEINTRIN_impACOS //
16853     r__1 = acos(r1);
16854     foor_(&r__1);
16855 // FFEINTRIN_impAIMAG //
16856     r__1 = r_imag(&c1);
16857     foor_(&r__1);
16858 // FFEINTRIN_impAINT //
16859     r__1 = r_int(&r1);
16860     foor_(&r__1);
16861 // FFEINTRIN_impALOG //
16862     r__1 = log(r1);
16863     foor_(&r__1);
16864 // FFEINTRIN_impALOG10 //
16865     r__1 = r_lg10(&r1);
16866     foor_(&r__1);
16867 // FFEINTRIN_impAMAX0 //
16868     r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16869     foor_(&r__1);
16870 // FFEINTRIN_impAMAX1 //
16871     r__1 = (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16872     foor_(&r__1);
16873 // FFEINTRIN_impAMIN0 //
16874     r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16875     foor_(&r__1);
16876 // FFEINTRIN_impAMIN1 //
16877     r__1 = (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16878     foor_(&r__1);
16879 // FFEINTRIN_impAMOD //
16880     r__1 = r_mod(&r1, &r2);
16881     foor_(&r__1);
16882 // FFEINTRIN_impANINT //
16883     r__1 = r_nint(&r1);
16884     foor_(&r__1);
16885 // FFEINTRIN_impASIN //
16886     r__1 = asin(r1);
16887     foor_(&r__1);
16888 // FFEINTRIN_impATAN //
16889     r__1 = atan(r1);
16890     foor_(&r__1);
16891 // FFEINTRIN_impATAN2 //
16892     r__1 = atan2(r1, r2);
16893     foor_(&r__1);
16894 // FFEINTRIN_impCABS //
16895     r__1 = c_abs(&c1);
16896     foor_(&r__1);
16897 // FFEINTRIN_impCCOS //
16898     c_cos(&q__1, &c1);
16899     fooc_(&q__1);
16900 // FFEINTRIN_impCEXP //
16901     c_exp(&q__1, &c1);
16902     fooc_(&q__1);
16903 // FFEINTRIN_impCHAR //
16904     *(unsigned char *)&ch__1[0] = i1;
16905     fooa_(ch__1, 1L);
16906 // FFEINTRIN_impCLOG //
16907     c_log(&q__1, &c1);
16908     fooc_(&q__1);
16909 // FFEINTRIN_impCONJG //
16910     r_cnjg(&q__1, &c1);
16911     fooc_(&q__1);
16912 // FFEINTRIN_impCOS //
16913     r__1 = cos(r1);
16914     foor_(&r__1);
16915 // FFEINTRIN_impCOSH //
16916     r__1 = cosh(r1);
16917     foor_(&r__1);
16918 // FFEINTRIN_impCSIN //
16919     c_sin(&q__1, &c1);
16920     fooc_(&q__1);
16921 // FFEINTRIN_impCSQRT //
16922     c_sqrt(&q__1, &c1);
16923     fooc_(&q__1);
16924 // FFEINTRIN_impDABS //
16925     d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ;
16926     food_(&d__1);
16927 // FFEINTRIN_impDACOS //
16928     d__1 = acos(d1);
16929     food_(&d__1);
16930 // FFEINTRIN_impDASIN //
16931     d__1 = asin(d1);
16932     food_(&d__1);
16933 // FFEINTRIN_impDATAN //
16934     d__1 = atan(d1);
16935     food_(&d__1);
16936 // FFEINTRIN_impDATAN2 //
16937     d__1 = atan2(d1, d2);
16938     food_(&d__1);
16939 // FFEINTRIN_impDCOS //
16940     d__1 = cos(d1);
16941     food_(&d__1);
16942 // FFEINTRIN_impDCOSH //
16943     d__1 = cosh(d1);
16944     food_(&d__1);
16945 // FFEINTRIN_impDDIM //
16946     d__1 = d_dim(&d1, &d2);
16947     food_(&d__1);
16948 // FFEINTRIN_impDEXP //
16949     d__1 = exp(d1);
16950     food_(&d__1);
16951 // FFEINTRIN_impDIM //
16952     r__1 = r_dim(&r1, &r2);
16953     foor_(&r__1);
16954 // FFEINTRIN_impDINT //
16955     d__1 = d_int(&d1);
16956     food_(&d__1);
16957 // FFEINTRIN_impDLOG //
16958     d__1 = log(d1);
16959     food_(&d__1);
16960 // FFEINTRIN_impDLOG10 //
16961     d__1 = d_lg10(&d1);
16962     food_(&d__1);
16963 // FFEINTRIN_impDMAX1 //
16964     d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ;
16965     food_(&d__1);
16966 // FFEINTRIN_impDMIN1 //
16967     d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ;
16968     food_(&d__1);
16969 // FFEINTRIN_impDMOD //
16970     d__1 = d_mod(&d1, &d2);
16971     food_(&d__1);
16972 // FFEINTRIN_impDNINT //
16973     d__1 = d_nint(&d1);
16974     food_(&d__1);
16975 // FFEINTRIN_impDPROD //
16976     d__1 = (doublereal) r1 * r2;
16977     food_(&d__1);
16978 // FFEINTRIN_impDSIGN //
16979     d__1 = d_sign(&d1, &d2);
16980     food_(&d__1);
16981 // FFEINTRIN_impDSIN //
16982     d__1 = sin(d1);
16983     food_(&d__1);
16984 // FFEINTRIN_impDSINH //
16985     d__1 = sinh(d1);
16986     food_(&d__1);
16987 // FFEINTRIN_impDSQRT //
16988     d__1 = sqrt(d1);
16989     food_(&d__1);
16990 // FFEINTRIN_impDTAN //
16991     d__1 = tan(d1);
16992     food_(&d__1);
16993 // FFEINTRIN_impDTANH //
16994     d__1 = tanh(d1);
16995     food_(&d__1);
16996 // FFEINTRIN_impEXP //
16997     r__1 = exp(r1);
16998     foor_(&r__1);
16999 // FFEINTRIN_impIABS //
17000     i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ;
17001     fooi_(&i__1);
17002 // FFEINTRIN_impICHAR //
17003     i__1 = *(unsigned char *)a1;
17004     fooi_(&i__1);
17005 // FFEINTRIN_impIDIM //
17006     i__1 = i_dim(&i1, &i2);
17007     fooi_(&i__1);
17008 // FFEINTRIN_impIDNINT //
17009     i__1 = i_dnnt(&d1);
17010     fooi_(&i__1);
17011 // FFEINTRIN_impINDEX //
17012     i__1 = i_indx(a1, a2, 10L, 10L);
17013     fooi_(&i__1);
17014 // FFEINTRIN_impISIGN //
17015     i__1 = i_sign(&i1, &i2);
17016     fooi_(&i__1);
17017 // FFEINTRIN_impLEN //
17018     i__1 = i_len(a1, 10L);
17019     fooi_(&i__1);
17020 // FFEINTRIN_impLGE //
17021     L__1 = l_ge(a1, a2, 10L, 10L);
17022     fool_(&L__1);
17023 // FFEINTRIN_impLGT //
17024     L__1 = l_gt(a1, a2, 10L, 10L);
17025     fool_(&L__1);
17026 // FFEINTRIN_impLLE //
17027     L__1 = l_le(a1, a2, 10L, 10L);
17028     fool_(&L__1);
17029 // FFEINTRIN_impLLT //
17030     L__1 = l_lt(a1, a2, 10L, 10L);
17031     fool_(&L__1);
17032 // FFEINTRIN_impMAX0 //
17033     i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
17034     fooi_(&i__1);
17035 // FFEINTRIN_impMAX1 //
17036     i__1 = (integer) (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
17037     fooi_(&i__1);
17038 // FFEINTRIN_impMIN0 //
17039     i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
17040     fooi_(&i__1);
17041 // FFEINTRIN_impMIN1 //
17042     i__1 = (integer) (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
17043     fooi_(&i__1);
17044 // FFEINTRIN_impMOD //
17045     i__1 = i1 % i2;
17046     fooi_(&i__1);
17047 // FFEINTRIN_impNINT //
17048     i__1 = i_nint(&r1);
17049     fooi_(&i__1);
17050 // FFEINTRIN_impSIGN //
17051     r__1 = r_sign(&r1, &r2);
17052     foor_(&r__1);
17053 // FFEINTRIN_impSIN //
17054     r__1 = sin(r1);
17055     foor_(&r__1);
17056 // FFEINTRIN_impSINH //
17057     r__1 = sinh(r1);
17058     foor_(&r__1);
17059 // FFEINTRIN_impSQRT //
17060     r__1 = sqrt(r1);
17061     foor_(&r__1);
17062 // FFEINTRIN_impTAN //
17063     r__1 = tan(r1);
17064     foor_(&r__1);
17065 // FFEINTRIN_impTANH //
17066     r__1 = tanh(r1);
17067     foor_(&r__1);
17068 // FFEINTRIN_imp_CMPLX_C //
17069     r__1 = c1.r;
17070     r__2 = c2.r;
17071     q__1.r = r__1, q__1.i = r__2;
17072     fooc_(&q__1);
17073 // FFEINTRIN_imp_CMPLX_D //
17074     z__1.r = d1, z__1.i = d2;
17075     fooz_(&z__1);
17076 // FFEINTRIN_imp_CMPLX_I //
17077     r__1 = (real) i1;
17078     r__2 = (real) i2;
17079     q__1.r = r__1, q__1.i = r__2;
17080     fooc_(&q__1);
17081 // FFEINTRIN_imp_CMPLX_R //
17082     q__1.r = r1, q__1.i = r2;
17083     fooc_(&q__1);
17084 // FFEINTRIN_imp_DBLE_C //
17085     d__1 = (doublereal) c1.r;
17086     food_(&d__1);
17087 // FFEINTRIN_imp_DBLE_D //
17088     d__1 = d1;
17089     food_(&d__1);
17090 // FFEINTRIN_imp_DBLE_I //
17091     d__1 = (doublereal) i1;
17092     food_(&d__1);
17093 // FFEINTRIN_imp_DBLE_R //
17094     d__1 = (doublereal) r1;
17095     food_(&d__1);
17096 // FFEINTRIN_imp_INT_C //
17097     i__1 = (integer) c1.r;
17098     fooi_(&i__1);
17099 // FFEINTRIN_imp_INT_D //
17100     i__1 = (integer) d1;
17101     fooi_(&i__1);
17102 // FFEINTRIN_imp_INT_I //
17103     i__1 = i1;
17104     fooi_(&i__1);
17105 // FFEINTRIN_imp_INT_R //
17106     i__1 = (integer) r1;
17107     fooi_(&i__1);
17108 // FFEINTRIN_imp_REAL_C //
17109     r__1 = c1.r;
17110     foor_(&r__1);
17111 // FFEINTRIN_imp_REAL_D //
17112     r__1 = (real) d1;
17113     foor_(&r__1);
17114 // FFEINTRIN_imp_REAL_I //
17115     r__1 = (real) i1;
17116     foor_(&r__1);
17117 // FFEINTRIN_imp_REAL_R //
17118     r__1 = r1;
17119     foor_(&r__1);
17120
17121 // FFEINTRIN_imp_INT_D: //
17122
17123 // FFEINTRIN_specIDINT //
17124     i__1 = (integer) d1;
17125     fooi_(&i__1);
17126
17127 // FFEINTRIN_imp_INT_R: //
17128
17129 // FFEINTRIN_specIFIX //
17130     i__1 = (integer) r1;
17131     fooi_(&i__1);
17132 // FFEINTRIN_specINT //
17133     i__1 = (integer) r1;
17134     fooi_(&i__1);
17135
17136 // FFEINTRIN_imp_REAL_D: //
17137
17138 // FFEINTRIN_specSNGL //
17139     r__1 = (real) d1;
17140     foor_(&r__1);
17141
17142 // FFEINTRIN_imp_REAL_I: //
17143
17144 // FFEINTRIN_specFLOAT //
17145     r__1 = (real) i1;
17146     foor_(&r__1);
17147 // FFEINTRIN_specREAL //
17148     r__1 = (real) i1;
17149     foor_(&r__1);
17150
17151 } // MAIN__ //
17152
17153 -------- (end output file from f2c)
17154
17155 */