gcc/f/com.c

   1 /* com.c -- Implementation File (module.c template V1.0)
   2    Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001
   3    Free Software Foundation, Inc.
   4    Contributed by James Craig Burley.
   5
   6 This file is part of GNU Fortran.
   7
   8 GNU Fortran is free software; you can redistribute it and/or modify
   9 it under the terms of the GNU General Public License as published by
  10 the Free Software Foundation; either version 2, or (at your option)
  11 any later version.
  12
  13 GNU Fortran is distributed in the hope that it will be useful,
  14 but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 GNU General Public License for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with GNU Fortran; see the file COPYING.  If not, write to
  20 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
  21 02111-1307, USA.
  22
  23    Related Modules:
  24       None
  25
  26    Description:
  27       Contains compiler-specific functions.
  28
  29    Modifications:
  30 */
  31
  32 /* Understanding this module means understanding the interface between
  33    the g77 front end and the gcc back end (or, perhaps, some other
  34    back end).  In here are the functions called by the front end proper
  35    to notify whatever back end is in place about certain things, and
  36    also the back-end-specific functions.  It's a bear to deal with, so
  37    lately I've been trying to simplify things, especially with regard
  38    to the gcc-back-end-specific stuff.
  39
  40    Building expressions generally seems quite easy, but building decls
  41    has been challenging and is undergoing revision.  gcc has several
  42    kinds of decls:
  43
  44    TYPE_DECL -- a type (int, float, struct, function, etc.)
  45    CONST_DECL -- a constant of some type other than function
  46    LABEL_DECL -- a variable or a constant?
  47    PARM_DECL -- an argument to a function (a variable that is a dummy)
  48    RESULT_DECL -- the return value of a function (a variable)
  49    VAR_DECL -- other variable (can hold a ptr-to-function, struct, int, etc.)
  50    FUNCTION_DECL -- a function (either the actual function or an extern ref)
  51    FIELD_DECL -- a field in a struct or union (goes into types)
  52
  53    g77 has a set of functions that somewhat parallels the gcc front end
  54    when it comes to building decls:
  55
  56    Internal Function (one we define, not just declare as extern):
  57    if (is_nested) push_f_function_context ();
  58    start_function (get_identifier ("function_name"), function_type,
  59                    is_nested, is_public);
  60    // for each arg, build PARM_DECL and call push_parm_decl (decl) with it;
  61    store_parm_decls (is_main_program);
  62    ffecom_start_compstmt ();
  63    // for stmts and decls inside function, do appropriate things;
  64    ffecom_end_compstmt ();
  65    finish_function (is_nested);
  66    if (is_nested) pop_f_function_context ();
  67
  68    Everything Else:
  69    tree d;
  70    tree init;
  71    // fill in external, public, static, &c for decl, and
  72    // set DECL_INITIAL to error_mark_node if going to initialize
  73    // set is_top_level TRUE only if not at top level and decl
  74    // must go in top level (i.e. not within current function decl context)
  75    d = start_decl (decl, is_top_level);
  76    init = ...;  // if have initializer
  77    finish_decl (d, init, is_top_level);
  78
  79 */
  80
  81 /* Include files. */
  82
  83 #include "proj.h"
  84 #if FFECOM_targetCURRENT == FFECOM_targetGCC
  85 #include "flags.h"
  86 #include "rtl.h"
  87 #include "toplev.h"
  88 #include "tree.h"
  89 #include "output.h"  /* Must follow tree.h so TREE_CODE is defined! */
  90 #include "convert.h"
  91 #include "ggc.h"
  92 #include "diagnostic.h"
  93 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
  94
  95 #define FFECOM_GCC_INCLUDE 1    /* Enable -I. */
  96
  97 /* VMS-specific definitions */
  98 #ifdef VMS
  99 #include <descrip.h>
 100 #define O_RDONLY        0       /* Open arg for Read/Only  */
 101 #define O_WRONLY        1       /* Open arg for Write/Only */
 102 #define read(fd,buf,size)       VMS_read (fd,buf,size)
 103 #define write(fd,buf,size)      VMS_write (fd,buf,size)
 104 #define open(fname,mode,prot)   VMS_open (fname,mode,prot)
 105 #define fopen(fname,mode)       VMS_fopen (fname,mode)
 106 #define freopen(fname,mode,ofile) VMS_freopen (fname,mode,ofile)
 107 #define strncat(dst,src,cnt) VMS_strncat (dst,src,cnt)
 108 #define fstat(fd,stbuf)         VMS_fstat (fd,stbuf)
 109 static int VMS_fstat (), VMS_stat ();
 110 static char * VMS_strncat ();
 111 static int VMS_read ();
 112 static int VMS_write ();
 113 static int VMS_open ();
 114 static FILE * VMS_fopen ();
 115 static FILE * VMS_freopen ();
 116 static void hack_vms_include_specification ();
 117 typedef struct { unsigned :16, :16, :16; } vms_ino_t;
 118 #define ino_t vms_ino_t
 119 #define INCLUDE_LEN_FUDGE 10    /* leave room for VMS syntax conversion */
 120 #endif /* VMS */
 121
 122 #define FFECOM_DETERMINE_TYPES 1 /* for com.h */
 123 #include "com.h"
 124 #include "bad.h"
 125 #include "bld.h"
 126 #include "equiv.h"
 127 #include "expr.h"
 128 #include "implic.h"
 129 #include "info.h"
 130 #include "malloc.h"
 131 #include "src.h"
 132 #include "st.h"
 133 #include "storag.h"
 134 #include "symbol.h"
 135 #include "target.h"
 136 #include "top.h"
 137 #include "type.h"
 138
 139 /* Externals defined here.  */
 140
 141 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 142
 143 /* ~~gcc/tree.h *should* declare this, because toplev.c and dwarfout.c
 144    reference it.  */
 145
 146 const char * const language_string = "GNU F77";
 147
 148 /* Stream for reading from the input file.  */
 149 FILE *finput;
 150
 151 /* These definitions parallel those in c-decl.c so that code from that
 152    module can be used pretty much as is.  Much of these defs aren't
 153    otherwise used, i.e. by g77 code per se, except some of them are used
 154    to build some of them that are.  The ones that are global (i.e. not
 155    "static") are those that ste.c and such might use (directly
 156    or by using com macros that reference them in their definitions).  */
 157
 158 tree string_type_node;
 159
 160 /* The rest of these are inventions for g77, though there might be
 161    similar things in the C front end.  As they are found, these
 162    inventions should be renamed to be canonical.  Note that only
 163    the ones currently required to be global are so.  */
 164
 165 static tree ffecom_tree_fun_type_void;
 166
 167 tree ffecom_integer_type_node;  /* Abbrev for _tree_type[blah][blah]. */
 168 tree ffecom_integer_zero_node;  /* Like *_*_* with g77's integer type. */
 169 tree ffecom_integer_one_node;   /* " */
 170 tree ffecom_tree_type[FFEINFO_basictype][FFEINFO_kindtype];
 171
 172 /* _fun_type things are the f2c-specific versions.  For -fno-f2c,
 173    just use build_function_type and build_pointer_type on the
 174    appropriate _tree_type array element.  */
 175
 176 static tree ffecom_tree_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
 177 static tree ffecom_tree_ptr_to_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
 178 static tree ffecom_tree_subr_type;
 179 static tree ffecom_tree_ptr_to_subr_type;
 180 static tree ffecom_tree_blockdata_type;
 181
 182 static tree ffecom_tree_xargc_;
 183
 184 ffecomSymbol ffecom_symbol_null_
 185 =
 186 {
 187   NULL_TREE,
 188   NULL_TREE,
 189   NULL_TREE,
 190   NULL_TREE,
 191   false
 192 };
 193 ffeinfoKindtype ffecom_pointer_kind_ = FFEINFO_basictypeNONE;
 194 ffeinfoKindtype ffecom_label_kind_ = FFEINFO_basictypeNONE;
 195
 196 int ffecom_f2c_typecode_[FFEINFO_basictype][FFEINFO_kindtype];
 197 tree ffecom_f2c_integer_type_node;
 198 tree ffecom_f2c_ptr_to_integer_type_node;
 199 tree ffecom_f2c_address_type_node;
 200 tree ffecom_f2c_real_type_node;
 201 tree ffecom_f2c_ptr_to_real_type_node;
 202 tree ffecom_f2c_doublereal_type_node;
 203 tree ffecom_f2c_complex_type_node;
 204 tree ffecom_f2c_doublecomplex_type_node;
 205 tree ffecom_f2c_longint_type_node;
 206 tree ffecom_f2c_logical_type_node;
 207 tree ffecom_f2c_flag_type_node;
 208 tree ffecom_f2c_ftnlen_type_node;
 209 tree ffecom_f2c_ftnlen_zero_node;
 210 tree ffecom_f2c_ftnlen_one_node;
 211 tree ffecom_f2c_ftnlen_two_node;
 212 tree ffecom_f2c_ptr_to_ftnlen_type_node;
 213 tree ffecom_f2c_ftnint_type_node;
 214 tree ffecom_f2c_ptr_to_ftnint_type_node;
 215 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 216
 217 /* Simple definitions and enumerations. */
 218
 219 #ifndef FFECOM_sizeMAXSTACKITEM
 220 #define FFECOM_sizeMAXSTACKITEM 32*1024 /* Keep user-declared things
 221                                            larger than this # bytes
 222                                            off stack if possible. */
 223 #endif
 224
 225 /* For systems that have large enough stacks, they should define
 226    this to 0, and here, for ease of use later on, we just undefine
 227    it if it is 0.  */
 228
 229 #if FFECOM_sizeMAXSTACKITEM == 0
 230 #undef FFECOM_sizeMAXSTACKITEM
 231 #endif
 232
 233 typedef enum
 234   {
 235     FFECOM_rttypeVOID_,
 236     FFECOM_rttypeVOIDSTAR_,     /* C's `void *' type. */
 237     FFECOM_rttypeFTNINT_,       /* f2c's `ftnint' type. */
 238     FFECOM_rttypeINTEGER_,      /* f2c's `integer' type. */
 239     FFECOM_rttypeLONGINT_,      /* f2c's `longint' type. */
 240     FFECOM_rttypeLOGICAL_,      /* f2c's `logical' type. */
 241     FFECOM_rttypeREAL_F2C_,     /* f2c's `real' returned as `double'. */
 242     FFECOM_rttypeREAL_GNU_,     /* `real' returned as such. */
 243     FFECOM_rttypeCOMPLEX_F2C_,  /* f2c's `complex' returned via 1st arg. */
 244     FFECOM_rttypeCOMPLEX_GNU_,  /* f2c's `complex' returned directly. */
 245     FFECOM_rttypeDOUBLE_,       /* C's `double' type. */
 246     FFECOM_rttypeDOUBLEREAL_,   /* f2c's `doublereal' type. */
 247     FFECOM_rttypeDBLCMPLX_F2C_, /* f2c's `doublecomplex' returned via 1st arg. */
 248     FFECOM_rttypeDBLCMPLX_GNU_, /* f2c's `doublecomplex' returned directly. */
 249     FFECOM_rttypeCHARACTER_,    /* f2c `char *'/`ftnlen' pair. */
 250     FFECOM_rttype_
 251   } ffecomRttype_;
 252
 253 /* Internal typedefs. */
 254
 255 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 256 typedef struct _ffecom_concat_list_ ffecomConcatList_;
 257 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 258
 259 /* Private include files. */
 260
 261
 262 /* Internal structure definitions. */
 263
 264 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 265 struct _ffecom_concat_list_
 266   {
 267     ffebld *exprs;
 268     int count;
 269     int max;
 270     ffetargetCharacterSize minlen;
 271     ffetargetCharacterSize maxlen;
 272   };
 273 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 274
 275 /* Static functions (internal). */
 276
 277 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 278 static tree ffecom_arglist_expr_ (const char *argstring, ffebld args);
 279 static tree ffecom_widest_expr_type_ (ffebld list);
 280 static bool ffecom_overlap_ (tree dest_decl, tree dest_offset,
 281                              tree dest_size, tree source_tree,
 282                              ffebld source, bool scalar_arg);
 283 static bool ffecom_args_overlapping_ (tree dest_tree, ffebld dest,
 284                                       tree args, tree callee_commons,
 285                                       bool scalar_args);
 286 static tree ffecom_build_f2c_string_ (int i, const char *s);
 287 static tree ffecom_call_ (tree fn, ffeinfoKindtype kt,
 288                           bool is_f2c_complex, tree type,
 289                           tree args, tree dest_tree,
 290                           ffebld dest, bool *dest_used,
 291                           tree callee_commons, bool scalar_args, tree hook);
 292 static tree ffecom_call_binop_ (tree fn, ffeinfoKindtype kt,
 293                                 bool is_f2c_complex, tree type,
 294                                 ffebld left, ffebld right,
 295                                 tree dest_tree, ffebld dest,
 296                                 bool *dest_used, tree callee_commons,
 297                                 bool scalar_args, bool ref, tree hook);
 298 static void ffecom_char_args_x_ (tree *xitem, tree *length,
 299                                  ffebld expr, bool with_null);
 300 static tree ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy);
 301 static tree ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s);
 302 static ffecomConcatList_
 303   ffecom_concat_list_gather_ (ffecomConcatList_ catlist,
 304                               ffebld expr,
 305                               ffetargetCharacterSize max);
 306 static void ffecom_concat_list_kill_ (ffecomConcatList_ catlist);
 307 static ffecomConcatList_ ffecom_concat_list_new_ (ffebld expr,
 308                                                 ffetargetCharacterSize max);
 309 static void ffecom_debug_kludge_ (tree aggr, const char *aggr_type,
 310                                   ffesymbol member, tree member_type,
 311                                   ffetargetOffset offset);
 312 static void ffecom_do_entry_ (ffesymbol fn, int entrynum);
 313 static tree ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
 314                           bool *dest_used, bool assignp, bool widenp);
 315 static tree ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
 316                                     ffebld dest, bool *dest_used);
 317 static tree ffecom_expr_power_integer_ (ffebld expr);
 318 static void ffecom_expr_transform_ (ffebld expr);
 319 static void ffecom_f2c_make_type_ (tree *type, int tcode, const char *name);
 320 static void ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
 321                                       int code);
 322 static ffeglobal ffecom_finish_global_ (ffeglobal global);
 323 static ffesymbol ffecom_finish_symbol_transform_ (ffesymbol s);
 324 static tree ffecom_get_appended_identifier_ (char us, const char *text);
 325 static tree ffecom_get_external_identifier_ (ffesymbol s);
 326 static tree ffecom_get_identifier_ (const char *text);
 327 static tree ffecom_gen_sfuncdef_ (ffesymbol s,
 328                                   ffeinfoBasictype bt,
 329                                   ffeinfoKindtype kt);
 330 static const char *ffecom_gfrt_args_ (ffecomGfrt ix);
 331 static tree ffecom_gfrt_tree_ (ffecomGfrt ix);
 332 static tree ffecom_init_zero_ (tree decl);
 333 static tree ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
 334                                      tree *maybe_tree);
 335 static tree ffecom_intrinsic_len_ (ffebld expr);
 336 static void ffecom_let_char_ (tree dest_tree,
 337                               tree dest_length,
 338                               ffetargetCharacterSize dest_size,
 339                               ffebld source);
 340 static void ffecom_make_gfrt_ (ffecomGfrt ix);
 341 static void ffecom_member_phase1_ (ffestorag mst, ffestorag st);
 342 static void ffecom_member_phase2_ (ffestorag mst, ffestorag st);
 343 static void ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size,
 344                                       ffebld source);
 345 static void ffecom_push_dummy_decls_ (ffebld dumlist,
 346                                       bool stmtfunc);
 347 static void ffecom_start_progunit_ (void);
 348 static ffesymbol ffecom_sym_transform_ (ffesymbol s);
 349 static ffesymbol ffecom_sym_transform_assign_ (ffesymbol s);
 350 static void ffecom_transform_common_ (ffesymbol s);
 351 static void ffecom_transform_equiv_ (ffestorag st);
 352 static tree ffecom_transform_namelist_ (ffesymbol s);
 353 static void ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
 354                                        tree t);
 355 static void ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
 356                                        tree *size, tree tree);
 357 static tree ffecom_tree_divide_ (tree tree_type, tree left, tree right,
 358                                  tree dest_tree, ffebld dest,
 359                                  bool *dest_used, tree hook);
 360 static tree ffecom_type_localvar_ (ffesymbol s,
 361                                    ffeinfoBasictype bt,
 362                                    ffeinfoKindtype kt);
 363 static tree ffecom_type_namelist_ (void);
 364 static tree ffecom_type_vardesc_ (void);
 365 static tree ffecom_vardesc_ (ffebld expr);
 366 static tree ffecom_vardesc_array_ (ffesymbol s);
 367 static tree ffecom_vardesc_dims_ (ffesymbol s);
 368 static tree ffecom_convert_narrow_ (tree type, tree expr);
 369 static tree ffecom_convert_widen_ (tree type, tree expr);
 370 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 371
 372 /* These are static functions that parallel those found in the C front
 373    end and thus have the same names.  */
 374
 375 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 376 static tree bison_rule_compstmt_ (void);
 377 static void bison_rule_pushlevel_ (void);
 378 static void delete_block (tree block);
 379 static int duplicate_decls (tree newdecl, tree olddecl);
 380 static void finish_decl (tree decl, tree init, bool is_top_level);
 381 static void finish_function (int nested);
 382 static const char *lang_printable_name (tree decl, int v);
 383 static tree lookup_name_current_level (tree name);
 384 static struct binding_level *make_binding_level (void);
 385 static void pop_f_function_context (void);
 386 static void push_f_function_context (void);
 387 static void push_parm_decl (tree parm);
 388 static tree pushdecl_top_level (tree decl);
 389 static int kept_level_p (void);
 390 static tree storedecls (tree decls);
 391 static void store_parm_decls (int is_main_program);
 392 static tree start_decl (tree decl, bool is_top_level);
 393 static void start_function (tree name, tree type, int nested, int public);
 394 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 395 #if FFECOM_GCC_INCLUDE
 396 static void ffecom_file_ (const char *name);
 397 static void ffecom_initialize_char_syntax_ (void);
 398 static void ffecom_close_include_ (FILE *f);
 399 static int ffecom_decode_include_option_ (char *spec);
 400 static FILE *ffecom_open_include_ (char *name, ffewhereLine l,
 401                                    ffewhereColumn c);
 402 #endif  /* FFECOM_GCC_INCLUDE */
 403
 404 /* Static objects accessed by functions in this module. */
 405
 406 static ffesymbol ffecom_primary_entry_ = NULL;
 407 static ffesymbol ffecom_nested_entry_ = NULL;
 408 static ffeinfoKind ffecom_primary_entry_kind_;
 409 static bool ffecom_primary_entry_is_proc_;
 410 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 411 static tree ffecom_outer_function_decl_;
 412 static tree ffecom_previous_function_decl_;
 413 static tree ffecom_which_entrypoint_decl_;
 414 static tree ffecom_float_zero_ = NULL_TREE;
 415 static tree ffecom_float_half_ = NULL_TREE;
 416 static tree ffecom_double_zero_ = NULL_TREE;
 417 static tree ffecom_double_half_ = NULL_TREE;
 418 static tree ffecom_func_result_;/* For functions. */
 419 static tree ffecom_func_length_;/* For CHARACTER fns. */
 420 static ffebld ffecom_list_blockdata_;
 421 static ffebld ffecom_list_common_;
 422 static ffebld ffecom_master_arglist_;
 423 static ffeinfoBasictype ffecom_master_bt_;
 424 static ffeinfoKindtype ffecom_master_kt_;
 425 static ffetargetCharacterSize ffecom_master_size_;
 426 static int ffecom_num_fns_ = 0;
 427 static int ffecom_num_entrypoints_ = 0;
 428 static bool ffecom_is_altreturning_ = FALSE;
 429 static tree ffecom_multi_type_node_;
 430 static tree ffecom_multi_retval_;
 431 static tree
 432   ffecom_multi_fields_[FFEINFO_basictype][FFEINFO_kindtype];
 433 static bool ffecom_member_namelisted_;  /* _member_phase1_ namelisted? */
 434 static bool ffecom_doing_entry_ = FALSE;
 435 static bool ffecom_transform_only_dummies_ = FALSE;
 436 static int ffecom_typesize_pointer_;
 437 static int ffecom_typesize_integer1_;
 438
 439 /* Holds pointer-to-function expressions.  */
 440
 441 static tree ffecom_gfrt_[FFECOM_gfrt]
 442 =
 443 {
 444 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NULL_TREE,
 445 #include "com-rt.def"
 446 #undef DEFGFRT
 447 };
 448
 449 /* Holds the external names of the functions.  */
 450
 451 static const char *ffecom_gfrt_name_[FFECOM_gfrt]
 452 =
 453 {
 454 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NAME,
 455 #include "com-rt.def"
 456 #undef DEFGFRT
 457 };
 458
 459 /* Whether the function returns.  */
 460
 461 static bool ffecom_gfrt_volatile_[FFECOM_gfrt]
 462 =
 463 {
 464 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) VOLATILE,
 465 #include "com-rt.def"
 466 #undef DEFGFRT
 467 };
 468
 469 /* Whether the function returns type complex.  */
 470
 471 static bool ffecom_gfrt_complex_[FFECOM_gfrt]
 472 =
 473 {
 474 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) COMPLEX,
 475 #include "com-rt.def"
 476 #undef DEFGFRT
 477 };
 478
 479 /* Whether the function is const
 480    (i.e., has no side effects and only depends on its arguments).  */
 481
 482 static bool ffecom_gfrt_const_[FFECOM_gfrt]
 483 =
 484 {
 485 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) CONST,
 486 #include "com-rt.def"
 487 #undef DEFGFRT
 488 };
 489
 490 /* Type code for the function return value.  */
 491
 492 static ffecomRttype_ ffecom_gfrt_type_[FFECOM_gfrt]
 493 =
 494 {
 495 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) TYPE,
 496 #include "com-rt.def"
 497 #undef DEFGFRT
 498 };
 499
 500 /* String of codes for the function's arguments.  */
 501
 502 static const char *ffecom_gfrt_argstring_[FFECOM_gfrt]
 503 =
 504 {
 505 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) ARGS,
 506 #include "com-rt.def"
 507 #undef DEFGFRT
 508 };
 509 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 510
 511 /* Internal macros. */
 512
 513 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 514
 515 /* We let tm.h override the types used here, to handle trivial differences
 516    such as the choice of unsigned int or long unsigned int for size_t.
 517    When machines start needing nontrivial differences in the size type,
 518    it would be best to do something here to figure out automatically
 519    from other information what type to use.  */
 520
 521 #ifndef SIZE_TYPE
 522 #define SIZE_TYPE "long unsigned int"
 523 #endif
 524
 525 #define ffecom_concat_list_count_(catlist) ((catlist).count)
 526 #define ffecom_concat_list_expr_(catlist,i) ((catlist).exprs[(i)])
 527 #define ffecom_concat_list_maxlen_(catlist) ((catlist).maxlen)
 528 #define ffecom_concat_list_minlen_(catlist) ((catlist).minlen)
 529
 530 #define ffecom_char_args_(i,l,e) ffecom_char_args_x_((i),(l),(e),FALSE)
 531 #define ffecom_char_args_with_null_(i,l,e) ffecom_char_args_x_((i),(l),(e),TRUE)
 532
 533 /* For each binding contour we allocate a binding_level structure
 534  * which records the names defined in that contour.
 535  * Contours include:
 536  *  0) the global one
 537  *  1) one for each function definition,
 538  *     where internal declarations of the parameters appear.
 539  *
 540  * The current meaning of a name can be found by searching the levels from
 541  * the current one out to the global one.
 542  */
 543
 544 /* Note that the information in the `names' component of the global contour
 545    is duplicated in the IDENTIFIER_GLOBAL_VALUEs of all identifiers.  */
 546
 547 struct binding_level
 548   {
 549     /* A chain of _DECL nodes for all variables, constants, functions,
 550        and typedef types.  These are in the reverse of the order supplied.
 551      */
 552     tree names;
 553
 554     /* For each level (except not the global one),
 555        a chain of BLOCK nodes for all the levels
 556        that were entered and exited one level down.  */
 557     tree blocks;
 558
 559     /* The BLOCK node for this level, if one has been preallocated.
 560        If 0, the BLOCK is allocated (if needed) when the level is popped.  */
 561     tree this_block;
 562
 563     /* The binding level which this one is contained in (inherits from).  */
 564     struct binding_level *level_chain;
 565
 566     /* 0: no ffecom_prepare_* functions called at this level yet;
 567        1: ffecom_prepare* functions called, except not ffecom_prepare_end;
 568        2: ffecom_prepare_end called.  */
 569     int prep_state;
 570   };
 571
 572 #define NULL_BINDING_LEVEL (struct binding_level *) NULL
 573
 574 /* The binding level currently in effect.  */
 575
 576 static struct binding_level *current_binding_level;
 577
 578 /* A chain of binding_level structures awaiting reuse.  */
 579
 580 static struct binding_level *free_binding_level;
 581
 582 /* The outermost binding level, for names of file scope.
 583    This is created when the compiler is started and exists
 584    through the entire run.  */
 585
 586 static struct binding_level *global_binding_level;
 587
 588 /* Binding level structures are initialized by copying this one.  */
 589
 590 static struct binding_level clear_binding_level
 591 =
 592 {NULL, NULL, NULL, NULL_BINDING_LEVEL, 0};
 593
 594 /* Language-dependent contents of an identifier.  */
 595
 596 struct lang_identifier
 597   {
 598     struct tree_identifier ignore;
 599     tree global_value, local_value, label_value;
 600     bool invented;
 601   };
 602
 603 /* Macros for access to language-specific slots in an identifier.  */
 604 /* Each of these slots contains a DECL node or null.  */
 605
 606 /* This represents the value which the identifier has in the
 607    file-scope namespace.  */
 608 #define IDENTIFIER_GLOBAL_VALUE(NODE)   \
 609   (((struct lang_identifier *)(NODE))->global_value)
 610 /* This represents the value which the identifier has in the current
 611    scope.  */
 612 #define IDENTIFIER_LOCAL_VALUE(NODE)    \
 613   (((struct lang_identifier *)(NODE))->local_value)
 614 /* This represents the value which the identifier has as a label in
 615    the current label scope.  */
 616 #define IDENTIFIER_LABEL_VALUE(NODE)    \
 617   (((struct lang_identifier *)(NODE))->label_value)
 618 /* This is nonzero if the identifier was "made up" by g77 code.  */
 619 #define IDENTIFIER_INVENTED(NODE)       \
 620   (((struct lang_identifier *)(NODE))->invented)
 621
 622 /* In identifiers, C uses the following fields in a special way:
 623    TREE_PUBLIC        to record that there was a previous local extern decl.
 624    TREE_USED          to record that such a decl was used.
 625    TREE_ADDRESSABLE   to record that the address of such a decl was used.  */
 626
 627 /* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function
 628    that have names.  Here so we can clear out their names' definitions
 629    at the end of the function.  */
 630
 631 static tree named_labels;
 632
 633 /* A list of LABEL_DECLs from outer contexts that are currently shadowed.  */
 634
 635 static tree shadowed_labels;
 636
 637 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 638 \f
 639 /* Return the subscript expression, modified to do range-checking.
 640
 641    `array' is the array to be checked against.
 642    `element' is the subscript expression to check.
 643    `dim' is the dimension number (starting at 0).
 644    `total_dims' is the total number of dimensions (0 for CHARACTER substring).
 645 */
 646
 647 static tree
 648 ffecom_subscript_check_ (tree array, tree element, int dim, int total_dims,
 649                          const char *array_name)
 650 {
 651   tree low = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
 652   tree high = TYPE_MAX_VALUE (TYPE_DOMAIN (array));
 653   tree cond;
 654   tree die;
 655   tree args;
 656
 657   if (element == error_mark_node)
 658     return element;
 659
 660   if (TREE_TYPE (low) != TREE_TYPE (element))
 661     {
 662       if (TYPE_PRECISION (TREE_TYPE (low))
 663           > TYPE_PRECISION (TREE_TYPE (element)))
 664         element = convert (TREE_TYPE (low), element);
 665       else
 666         {
 667           low = convert (TREE_TYPE (element), low);
 668           if (high)
 669             high = convert (TREE_TYPE (element), high);
 670         }
 671     }
 672
 673   element = ffecom_save_tree (element);
 674   cond = ffecom_2 (LE_EXPR, integer_type_node,
 675                    low,
 676                    element);
 677   if (high)
 678     {
 679       cond = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
 680                        cond,
 681                        ffecom_2 (LE_EXPR, integer_type_node,
 682                                  element,
 683                                  high));
 684     }
 685
 686   {
 687     int len;
 688     char *proc;
 689     char *var;
 690     tree arg3;
 691     tree arg2;
 692     tree arg1;
 693     tree arg4;
 694
 695     switch (total_dims)
 696       {
 697       case 0:
 698         var = concat (array_name, "[", (dim ? "end" : "start"),
 699                       "-substring]", NULL);
 700         len = strlen (var) + 1;
 701         arg1 = build_string (len, var);
 702         free (var);
 703         break;
 704
 705       case 1:
 706         len = strlen (array_name) + 1;
 707         arg1 = build_string (len, array_name);
 708         break;
 709
 710       default:
 711         var = xmalloc (strlen (array_name) + 40);
 712         sprintf (var, "%s[subscript-%d-of-%d]",
 713                  array_name,
 714                  dim + 1, total_dims);
 715         len = strlen (var) + 1;
 716         arg1 = build_string (len, var);
 717         free (var);
 718         break;
 719       }
 720
 721     TREE_TYPE (arg1)
 722       = build_type_variant (build_array_type (char_type_node,
 723                                               build_range_type
 724                                               (integer_type_node,
 725                                                integer_one_node,
 726                                                build_int_2 (len, 0))),
 727                             1, 0);
 728     TREE_CONSTANT (arg1) = 1;
 729     TREE_STATIC (arg1) = 1;
 730     arg1 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg1)),
 731                      arg1);
 732
 733     /* s_rnge adds one to the element to print it, so bias against
 734        that -- want to print a faithful *subscript* value.  */
 735     arg2 = convert (ffecom_f2c_ftnint_type_node,
 736                     ffecom_2 (MINUS_EXPR,
 737                               TREE_TYPE (element),
 738                               element,
 739                               convert (TREE_TYPE (element),
 740                                        integer_one_node)));
 741
 742     proc = concat (input_filename, "/",
 743                    IDENTIFIER_POINTER (DECL_NAME (current_function_decl)),
 744                    NULL);
 745     len = strlen (proc) + 1;
 746     arg3 = build_string (len, proc);
 747
 748     free (proc);
 749
 750     TREE_TYPE (arg3)
 751       = build_type_variant (build_array_type (char_type_node,
 752                                               build_range_type
 753                                               (integer_type_node,
 754                                                integer_one_node,
 755                                                build_int_2 (len, 0))),
 756                             1, 0);
 757     TREE_CONSTANT (arg3) = 1;
 758     TREE_STATIC (arg3) = 1;
 759     arg3 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg3)),
 760                      arg3);
 761
 762     arg4 = convert (ffecom_f2c_ftnint_type_node,
 763                     build_int_2 (lineno, 0));
 764
 765     arg1 = build_tree_list (NULL_TREE, arg1);
 766     arg2 = build_tree_list (NULL_TREE, arg2);
 767     arg3 = build_tree_list (NULL_TREE, arg3);
 768     arg4 = build_tree_list (NULL_TREE, arg4);
 769     TREE_CHAIN (arg3) = arg4;
 770     TREE_CHAIN (arg2) = arg3;
 771     TREE_CHAIN (arg1) = arg2;
 772
 773     args = arg1;
 774   }
 775   die = ffecom_call_gfrt (FFECOM_gfrtRANGE,
 776                           args, NULL_TREE);
 777   TREE_SIDE_EFFECTS (die) = 1;
 778
 779   element = ffecom_3 (COND_EXPR,
 780                       TREE_TYPE (element),
 781                       cond,
 782                       element,
 783                       die);
 784
 785   return element;
 786 }
 787
 788 /* Return the computed element of an array reference.
 789
 790    `item' is NULL_TREE, or the transformed pointer to the array.
 791    `expr' is the original opARRAYREF expression, which is transformed
 792      if `item' is NULL_TREE.
 793    `want_ptr' is non-zero if a pointer to the element, instead of
 794      the element itself, is to be returned.  */
 795
 796 static tree
 797 ffecom_arrayref_ (tree item, ffebld expr, int want_ptr)
 798 {
 799   ffebld dims[FFECOM_dimensionsMAX];
 800   int i;
 801   int total_dims;
 802   int flatten = ffe_is_flatten_arrays ();
 803   int need_ptr;
 804   tree array;
 805   tree element;
 806   tree tree_type;
 807   tree tree_type_x;
 808   const char *array_name;
 809   ffetype type;
 810   ffebld list;
 811
 812   if (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER)
 813     array_name = ffesymbol_text (ffebld_symter (ffebld_left (expr)));
 814   else
 815     array_name = "[expr?]";
 816
 817   /* Build up ARRAY_REFs in reverse order (since we're column major
 818      here in Fortran land). */
 819
 820   for (i = 0, list = ffebld_right (expr);
 821        list != NULL;
 822        ++i, list = ffebld_trail (list))
 823     {
 824       dims[i] = ffebld_head (list);
 825       type = ffeinfo_type (ffebld_basictype (dims[i]),
 826                            ffebld_kindtype (dims[i]));
 827       if (! flatten
 828           && ffecom_typesize_pointer_ > ffecom_typesize_integer1_
 829           && ffetype_size (type) > ffecom_typesize_integer1_)
 830         /* E.g. ARRAY(INDEX), given INTEGER*8 INDEX, on a system with 64-bit
 831            pointers and 32-bit integers.  Do the full 64-bit pointer
 832            arithmetic, for codes using arrays for nonstandard heap-like
 833            work.  */
 834         flatten = 1;
 835     }
 836
 837   total_dims = i;
 838
 839   need_ptr = want_ptr || flatten;
 840
 841   if (! item)
 842     {
 843       if (need_ptr)
 844         item = ffecom_ptr_to_expr (ffebld_left (expr));
 845       else
 846         item = ffecom_expr (ffebld_left (expr));
 847
 848       if (item == error_mark_node)
 849         return item;
 850
 851       if (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereFLEETING
 852           && ! mark_addressable (item))
 853         return error_mark_node;
 854     }
 855
 856   if (item == error_mark_node)
 857     return item;
 858
 859   if (need_ptr)
 860     {
 861       tree min;
 862
 863       for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
 864            i >= 0;
 865            --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array)))
 866         {
 867           min = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
 868           element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
 869           if (flag_bounds_check)
 870             element = ffecom_subscript_check_ (array, element, i, total_dims,
 871                                                array_name);
 872           if (element == error_mark_node)
 873             return element;
 874
 875           /* Widen integral arithmetic as desired while preserving
 876              signedness.  */
 877           tree_type = TREE_TYPE (element);
 878           tree_type_x = tree_type;
 879           if (tree_type
 880               && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
 881               && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
 882             tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
 883
 884           if (TREE_TYPE (min) != tree_type_x)
 885             min = convert (tree_type_x, min);
 886           if (TREE_TYPE (element) != tree_type_x)
 887             element = convert (tree_type_x, element);
 888
 889           item = ffecom_2 (PLUS_EXPR,
 890                            build_pointer_type (TREE_TYPE (array)),
 891                            item,
 892                            size_binop (MULT_EXPR,
 893                                        size_in_bytes (TREE_TYPE (array)),
 894                                        convert (sizetype,
 895                                                 fold (build (MINUS_EXPR,
 896                                                              tree_type_x,
 897                                                              element, min)))));
 898         }
 899       if (! want_ptr)
 900         {
 901           item = ffecom_1 (INDIRECT_REF,
 902                            TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
 903                            item);
 904         }
 905     }
 906   else
 907     {
 908       for (--i;
 909            i >= 0;
 910            --i)
 911         {
 912           array = TYPE_MAIN_VARIANT (TREE_TYPE (item));
 913
 914           element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
 915           if (flag_bounds_check)
 916             element = ffecom_subscript_check_ (array, element, i, total_dims,
 917                                                array_name);
 918           if (element == error_mark_node)
 919             return element;
 920
 921           /* Widen integral arithmetic as desired while preserving
 922              signedness.  */
 923           tree_type = TREE_TYPE (element);
 924           tree_type_x = tree_type;
 925           if (tree_type
 926               && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
 927               && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
 928             tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
 929
 930           element = convert (tree_type_x, element);
 931
 932           item = ffecom_2 (ARRAY_REF,
 933                            TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
 934                            item,
 935                            element);
 936         }
 937     }
 938
 939   return item;
 940 }
 941
 942 /* This is like gcc's stabilize_reference -- in fact, most of the code
 943    comes from that -- but it handles the situation where the reference
 944    is going to have its subparts picked at, and it shouldn't change
 945    (or trigger extra invocations of functions in the subtrees) due to
 946    this.  save_expr is a bit overzealous, because we don't need the
 947    entire thing calculated and saved like a temp.  So, for DECLs, no
 948    change is needed, because these are stable aggregates, and ARRAY_REF
 949    and such might well be stable too, but for things like calculations,
 950    we do need to calculate a snapshot of a value before picking at it.  */
 951
 952 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 953 static tree
 954 ffecom_stabilize_aggregate_ (tree ref)
 955 {
 956   tree result;
 957   enum tree_code code = TREE_CODE (ref);
 958
 959   switch (code)
 960     {
 961     case VAR_DECL:
 962     case PARM_DECL:
 963     case RESULT_DECL:
 964       /* No action is needed in this case.  */
 965       return ref;
 966
 967     case NOP_EXPR:
 968     case CONVERT_EXPR:
 969     case FLOAT_EXPR:
 970     case FIX_TRUNC_EXPR:
 971     case FIX_FLOOR_EXPR:
 972     case FIX_ROUND_EXPR:
 973     case FIX_CEIL_EXPR:
 974       result = build_nt (code, stabilize_reference (TREE_OPERAND (ref, 0)));
 975       break;
 976
 977     case INDIRECT_REF:
 978       result = build_nt (INDIRECT_REF,
 979                          stabilize_reference_1 (TREE_OPERAND (ref, 0)));
 980       break;
 981
 982     case COMPONENT_REF:
 983       result = build_nt (COMPONENT_REF,
 984                          stabilize_reference (TREE_OPERAND (ref, 0)),
 985                          TREE_OPERAND (ref, 1));
 986       break;
 987
 988     case BIT_FIELD_REF:
 989       result = build_nt (BIT_FIELD_REF,
 990                          stabilize_reference (TREE_OPERAND (ref, 0)),
 991                          stabilize_reference_1 (TREE_OPERAND (ref, 1)),
 992                          stabilize_reference_1 (TREE_OPERAND (ref, 2)));
 993       break;
 994
 995     case ARRAY_REF:
 996       result = build_nt (ARRAY_REF,
 997                          stabilize_reference (TREE_OPERAND (ref, 0)),
 998                          stabilize_reference_1 (TREE_OPERAND (ref, 1)));
 999       break;
1000
1001     case COMPOUND_EXPR:
1002       result = build_nt (COMPOUND_EXPR,
1003                          stabilize_reference_1 (TREE_OPERAND (ref, 0)),
1004                          stabilize_reference (TREE_OPERAND (ref, 1)));
1005       break;
1006
1007     case RTL_EXPR:
1008       abort ();
1009
1010
1011     default:
1012       return save_expr (ref);
1013
1014     case ERROR_MARK:
1015       return error_mark_node;
1016     }
1017
1018   TREE_TYPE (result) = TREE_TYPE (ref);
1019   TREE_READONLY (result) = TREE_READONLY (ref);
1020   TREE_SIDE_EFFECTS (result) = TREE_SIDE_EFFECTS (ref);
1021   TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref);
1022
1023   return result;
1024 }
1025 #endif
1026
1027 /* A rip-off of gcc's convert.c convert_to_complex function,
1028    reworked to handle complex implemented as C structures
1029    (RECORD_TYPE with two fields, real and imaginary `r' and `i').  */
1030
1031 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1032 static tree
1033 ffecom_convert_to_complex_ (tree type, tree expr)
1034 {
1035   register enum tree_code form = TREE_CODE (TREE_TYPE (expr));
1036   tree subtype;
1037
1038   assert (TREE_CODE (type) == RECORD_TYPE);
1039
1040   subtype = TREE_TYPE (TYPE_FIELDS (type));
1041
1042   if (form == REAL_TYPE || form == INTEGER_TYPE || form == ENUMERAL_TYPE)
1043     {
1044       expr = convert (subtype, expr);
1045       return ffecom_2 (COMPLEX_EXPR, type, expr,
1046                        convert (subtype, integer_zero_node));
1047     }
1048
1049   if (form == RECORD_TYPE)
1050     {
1051       tree elt_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr)));
1052       if (TYPE_MAIN_VARIANT (elt_type) == TYPE_MAIN_VARIANT (subtype))
1053         return expr;
1054       else
1055         {
1056           expr = save_expr (expr);
1057           return ffecom_2 (COMPLEX_EXPR,
1058                            type,
1059                            convert (subtype,
1060                                     ffecom_1 (REALPART_EXPR,
1061                                               TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1062                                               expr)),
1063                            convert (subtype,
1064                                     ffecom_1 (IMAGPART_EXPR,
1065                                               TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1066                                               expr)));
1067         }
1068     }
1069
1070   if (form == POINTER_TYPE || form == REFERENCE_TYPE)
1071     error ("pointer value used where a complex was expected");
1072   else
1073     error ("aggregate value used where a complex was expected");
1074
1075   return ffecom_2 (COMPLEX_EXPR, type,
1076                    convert (subtype, integer_zero_node),
1077                    convert (subtype, integer_zero_node));
1078 }
1079 #endif
1080
1081 /* Like gcc's convert(), but crashes if widening might happen.  */
1082
1083 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1084 static tree
1085 ffecom_convert_narrow_ (type, expr)
1086      tree type, expr;
1087 {
1088   register tree e = expr;
1089   register enum tree_code code = TREE_CODE (type);
1090
1091   if (type == TREE_TYPE (e)
1092       || TREE_CODE (e) == ERROR_MARK)
1093     return e;
1094   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1095     return fold (build1 (NOP_EXPR, type, e));
1096   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1097       || code == ERROR_MARK)
1098     return error_mark_node;
1099   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1100     {
1101       assert ("void value not ignored as it ought to be" == NULL);
1102       return error_mark_node;
1103     }
1104   assert (code != VOID_TYPE);
1105   if ((code != RECORD_TYPE)
1106       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1107     assert ("converting COMPLEX to REAL" == NULL);
1108   assert (code != ENUMERAL_TYPE);
1109   if (code == INTEGER_TYPE)
1110     {
1111       assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1112                && TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)))
1113               || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1114                   && (TYPE_PRECISION (type)
1115                       == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1116       return fold (convert_to_integer (type, e));
1117     }
1118   if (code == POINTER_TYPE)
1119     {
1120       assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1121       return fold (convert_to_pointer (type, e));
1122     }
1123   if (code == REAL_TYPE)
1124     {
1125       assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1126       assert (TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)));
1127       return fold (convert_to_real (type, e));
1128     }
1129   if (code == COMPLEX_TYPE)
1130     {
1131       assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1132       assert (TYPE_PRECISION (TREE_TYPE (type)) <= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1133       return fold (convert_to_complex (type, e));
1134     }
1135   if (code == RECORD_TYPE)
1136     {
1137       assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1138       /* Check that at least the first field name agrees.  */
1139       assert (DECL_NAME (TYPE_FIELDS (type))
1140               == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1141       assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1142               <= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1143       if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1144           == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1145         return e;
1146       return fold (ffecom_convert_to_complex_ (type, e));
1147     }
1148
1149   assert ("conversion to non-scalar type requested" == NULL);
1150   return error_mark_node;
1151 }
1152 #endif
1153
1154 /* Like gcc's convert(), but crashes if narrowing might happen.  */
1155
1156 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1157 static tree
1158 ffecom_convert_widen_ (type, expr)
1159      tree type, expr;
1160 {
1161   register tree e = expr;
1162   register enum tree_code code = TREE_CODE (type);
1163
1164   if (type == TREE_TYPE (e)
1165       || TREE_CODE (e) == ERROR_MARK)
1166     return e;
1167   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1168     return fold (build1 (NOP_EXPR, type, e));
1169   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1170       || code == ERROR_MARK)
1171     return error_mark_node;
1172   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1173     {
1174       assert ("void value not ignored as it ought to be" == NULL);
1175       return error_mark_node;
1176     }
1177   assert (code != VOID_TYPE);
1178   if ((code != RECORD_TYPE)
1179       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1180     assert ("narrowing COMPLEX to REAL" == NULL);
1181   assert (code != ENUMERAL_TYPE);
1182   if (code == INTEGER_TYPE)
1183     {
1184       assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1185                && TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)))
1186               || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1187                   && (TYPE_PRECISION (type)
1188                       == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1189       return fold (convert_to_integer (type, e));
1190     }
1191   if (code == POINTER_TYPE)
1192     {
1193       assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1194       return fold (convert_to_pointer (type, e));
1195     }
1196   if (code == REAL_TYPE)
1197     {
1198       assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1199       assert (TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)));
1200       return fold (convert_to_real (type, e));
1201     }
1202   if (code == COMPLEX_TYPE)
1203     {
1204       assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1205       assert (TYPE_PRECISION (TREE_TYPE (type)) >= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1206       return fold (convert_to_complex (type, e));
1207     }
1208   if (code == RECORD_TYPE)
1209     {
1210       assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1211       /* Check that at least the first field name agrees.  */
1212       assert (DECL_NAME (TYPE_FIELDS (type))
1213               == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1214       assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1215               >= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1216       if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1217           == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1218         return e;
1219       return fold (ffecom_convert_to_complex_ (type, e));
1220     }
1221
1222   assert ("conversion to non-scalar type requested" == NULL);
1223   return error_mark_node;
1224 }
1225 #endif
1226
1227 /* Handles making a COMPLEX type, either the standard
1228    (but buggy?) gbe way, or the safer (but less elegant?)
1229    f2c way.  */
1230
1231 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1232 static tree
1233 ffecom_make_complex_type_ (tree subtype)
1234 {
1235   tree type;
1236   tree realfield;
1237   tree imagfield;
1238
1239   if (ffe_is_emulate_complex ())
1240     {
1241       type = make_node (RECORD_TYPE);
1242       realfield = ffecom_decl_field (type, NULL_TREE, "r", subtype);
1243       imagfield = ffecom_decl_field (type, realfield, "i", subtype);
1244       TYPE_FIELDS (type) = realfield;
1245       layout_type (type);
1246     }
1247   else
1248     {
1249       type = make_node (COMPLEX_TYPE);
1250       TREE_TYPE (type) = subtype;
1251       layout_type (type);
1252     }
1253
1254   return type;
1255 }
1256 #endif
1257
1258 /* Chooses either the gbe or the f2c way to build a
1259    complex constant.  */
1260
1261 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1262 static tree
1263 ffecom_build_complex_constant_ (tree type, tree realpart, tree imagpart)
1264 {
1265   tree bothparts;
1266
1267   if (ffe_is_emulate_complex ())
1268     {
1269       bothparts = build_tree_list (TYPE_FIELDS (type), realpart);
1270       TREE_CHAIN (bothparts) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), imagpart);
1271       bothparts = build (CONSTRUCTOR, type, NULL_TREE, bothparts);
1272     }
1273   else
1274     {
1275       bothparts = build_complex (type, realpart, imagpart);
1276     }
1277
1278   return bothparts;
1279 }
1280 #endif
1281
1282 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1283 static tree
1284 ffecom_arglist_expr_ (const char *c, ffebld expr)
1285 {
1286   tree list;
1287   tree *plist = &list;
1288   tree trail = NULL_TREE;       /* Append char length args here. */
1289   tree *ptrail = &trail;
1290   tree length;
1291   ffebld exprh;
1292   tree item;
1293   bool ptr = FALSE;
1294   tree wanted = NULL_TREE;
1295   static char zed[] = "0";
1296
1297   if (c == NULL)
1298     c = &zed[0];
1299
1300   while (expr != NULL)
1301     {
1302       if (*c != '\0')
1303         {
1304           ptr = FALSE;
1305           if (*c == '&')
1306             {
1307               ptr = TRUE;
1308               ++c;
1309             }
1310           switch (*(c++))
1311             {
1312             case '\0':
1313               ptr = TRUE;
1314               wanted = NULL_TREE;
1315               break;
1316
1317             case 'a':
1318               assert (ptr);
1319               wanted = NULL_TREE;
1320               break;
1321
1322             case 'c':
1323               wanted = ffecom_f2c_complex_type_node;
1324               break;
1325
1326             case 'd':
1327               wanted = ffecom_f2c_doublereal_type_node;
1328               break;
1329
1330             case 'e':
1331               wanted = ffecom_f2c_doublecomplex_type_node;
1332               break;
1333
1334             case 'f':
1335               wanted = ffecom_f2c_real_type_node;
1336               break;
1337
1338             case 'i':
1339               wanted = ffecom_f2c_integer_type_node;
1340               break;
1341
1342             case 'j':
1343               wanted = ffecom_f2c_longint_type_node;
1344               break;
1345
1346             default:
1347               assert ("bad argstring code" == NULL);
1348               wanted = NULL_TREE;
1349               break;
1350             }
1351         }
1352
1353       exprh = ffebld_head (expr);
1354       if (exprh == NULL)
1355         wanted = NULL_TREE;
1356
1357       if ((wanted == NULL_TREE)
1358           || (ptr
1359               && (TYPE_MODE
1360                   (ffecom_tree_type[ffeinfo_basictype (ffebld_info (exprh))]
1361                    [ffeinfo_kindtype (ffebld_info (exprh))])
1362                    == TYPE_MODE (wanted))))
1363         *plist
1364           = build_tree_list (NULL_TREE,
1365                              ffecom_arg_ptr_to_expr (exprh,
1366                                                      &length));
1367       else
1368         {
1369           item = ffecom_arg_expr (exprh, &length);
1370           item = ffecom_convert_widen_ (wanted, item);
1371           if (ptr)
1372             {
1373               item = ffecom_1 (ADDR_EXPR,
1374                                build_pointer_type (TREE_TYPE (item)),
1375                                item);
1376             }
1377           *plist
1378             = build_tree_list (NULL_TREE,
1379                                item);
1380         }
1381
1382       plist = &TREE_CHAIN (*plist);
1383       expr = ffebld_trail (expr);
1384       if (length != NULL_TREE)
1385         {
1386           *ptrail = build_tree_list (NULL_TREE, length);
1387           ptrail = &TREE_CHAIN (*ptrail);
1388         }
1389     }
1390
1391   /* We've run out of args in the call; if the implementation expects
1392      more, supply null pointers for them, which the implementation can
1393      check to see if an arg was omitted. */
1394
1395   while (*c != '\0' && *c != '0')
1396     {
1397       if (*c == '&')
1398         ++c;
1399       else
1400         assert ("missing arg to run-time routine!" == NULL);
1401
1402       switch (*(c++))
1403         {
1404         case '\0':
1405         case 'a':
1406         case 'c':
1407         case 'd':
1408         case 'e':
1409         case 'f':
1410         case 'i':
1411         case 'j':
1412           break;
1413
1414         default:
1415           assert ("bad arg string code" == NULL);
1416           break;
1417         }
1418       *plist
1419         = build_tree_list (NULL_TREE,
1420                            null_pointer_node);
1421       plist = &TREE_CHAIN (*plist);
1422     }
1423
1424   *plist = trail;
1425
1426   return list;
1427 }
1428 #endif
1429
1430 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1431 static tree
1432 ffecom_widest_expr_type_ (ffebld list)
1433 {
1434   ffebld item;
1435   ffebld widest = NULL;
1436   ffetype type;
1437   ffetype widest_type = NULL;
1438   tree t;
1439
1440   for (; list != NULL; list = ffebld_trail (list))
1441     {
1442       item = ffebld_head (list);
1443       if (item == NULL)
1444         continue;
1445       if ((widest != NULL)
1446           && (ffeinfo_basictype (ffebld_info (item))
1447               != ffeinfo_basictype (ffebld_info (widest))))
1448         continue;
1449       type = ffeinfo_type (ffeinfo_basictype (ffebld_info (item)),
1450                            ffeinfo_kindtype (ffebld_info (item)));
1451       if ((widest == FFEINFO_kindtypeNONE)
1452           || (ffetype_size (type)
1453               > ffetype_size (widest_type)))
1454         {
1455           widest = item;
1456           widest_type = type;
1457         }
1458     }
1459
1460   assert (widest != NULL);
1461   t = ffecom_tree_type[ffeinfo_basictype (ffebld_info (widest))]
1462     [ffeinfo_kindtype (ffebld_info (widest))];
1463   assert (t != NULL_TREE);
1464   return t;
1465 }
1466 #endif
1467
1468 /* Check whether a partial overlap between two expressions is possible.
1469
1470    Can *starting* to write a portion of expr1 change the value
1471    computed (perhaps already, *partially*) by expr2?
1472
1473    Currently, this is a concern only for a COMPLEX expr1.  But if it
1474    isn't in COMMON or local EQUIVALENCE, since we don't support
1475    aliasing of arguments, it isn't a concern.  */
1476
1477 static bool
1478 ffecom_possible_partial_overlap_ (ffebld expr1, ffebld expr2 ATTRIBUTE_UNUSED)
1479 {
1480   ffesymbol sym;
1481   ffestorag st;
1482
1483   switch (ffebld_op (expr1))
1484     {
1485     case FFEBLD_opSYMTER:
1486       sym = ffebld_symter (expr1);
1487       break;
1488
1489     case FFEBLD_opARRAYREF:
1490       if (ffebld_op (ffebld_left (expr1)) != FFEBLD_opSYMTER)
1491         return FALSE;
1492       sym = ffebld_symter (ffebld_left (expr1));
1493       break;
1494
1495     default:
1496       return FALSE;
1497     }
1498
1499   if (ffesymbol_where (sym) != FFEINFO_whereCOMMON
1500       && (ffesymbol_where (sym) != FFEINFO_whereLOCAL
1501           || ! (st = ffesymbol_storage (sym))
1502           || ! ffestorag_parent (st)))
1503     return FALSE;
1504
1505   /* It's in COMMON or local EQUIVALENCE.  */
1506
1507   return TRUE;
1508 }
1509
1510 /* Check whether dest and source might overlap.  ffebld versions of these
1511    might or might not be passed, will be NULL if not.
1512
1513    The test is really whether source_tree is modifiable and, if modified,
1514    might overlap destination such that the value(s) in the destination might
1515    change before it is finally modified.  dest_* are the canonized
1516    destination itself.  */
1517
1518 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1519 static bool
1520 ffecom_overlap_ (tree dest_decl, tree dest_offset, tree dest_size,
1521                  tree source_tree, ffebld source UNUSED,
1522                  bool scalar_arg)
1523 {
1524   tree source_decl;
1525   tree source_offset;
1526   tree source_size;
1527   tree t;
1528
1529   if (source_tree == NULL_TREE)
1530     return FALSE;
1531
1532   switch (TREE_CODE (source_tree))
1533     {
1534     case ERROR_MARK:
1535     case IDENTIFIER_NODE:
1536     case INTEGER_CST:
1537     case REAL_CST:
1538     case COMPLEX_CST:
1539     case STRING_CST:
1540     case CONST_DECL:
1541     case VAR_DECL:
1542     case RESULT_DECL:
1543     case FIELD_DECL:
1544     case MINUS_EXPR:
1545     case MULT_EXPR:
1546     case TRUNC_DIV_EXPR:
1547     case CEIL_DIV_EXPR:
1548     case FLOOR_DIV_EXPR:
1549     case ROUND_DIV_EXPR:
1550     case TRUNC_MOD_EXPR:
1551     case CEIL_MOD_EXPR:
1552     case FLOOR_MOD_EXPR:
1553     case ROUND_MOD_EXPR:
1554     case RDIV_EXPR:
1555     case EXACT_DIV_EXPR:
1556     case FIX_TRUNC_EXPR:
1557     case FIX_CEIL_EXPR:
1558     case FIX_FLOOR_EXPR:
1559     case FIX_ROUND_EXPR:
1560     case FLOAT_EXPR:
1561     case NEGATE_EXPR:
1562     case MIN_EXPR:
1563     case MAX_EXPR:
1564     case ABS_EXPR:
1565     case FFS_EXPR:
1566     case LSHIFT_EXPR:
1567     case RSHIFT_EXPR:
1568     case LROTATE_EXPR:
1569     case RROTATE_EXPR:
1570     case BIT_IOR_EXPR:
1571     case BIT_XOR_EXPR:
1572     case BIT_AND_EXPR:
1573     case BIT_ANDTC_EXPR:
1574     case BIT_NOT_EXPR:
1575     case TRUTH_ANDIF_EXPR:
1576     case TRUTH_ORIF_EXPR:
1577     case TRUTH_AND_EXPR:
1578     case TRUTH_OR_EXPR:
1579     case TRUTH_XOR_EXPR:
1580     case TRUTH_NOT_EXPR:
1581     case LT_EXPR:
1582     case LE_EXPR:
1583     case GT_EXPR:
1584     case GE_EXPR:
1585     case EQ_EXPR:
1586     case NE_EXPR:
1587     case COMPLEX_EXPR:
1588     case CONJ_EXPR:
1589     case REALPART_EXPR:
1590     case IMAGPART_EXPR:
1591     case LABEL_EXPR:
1592     case COMPONENT_REF:
1593       return FALSE;
1594
1595     case COMPOUND_EXPR:
1596       return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1597                               TREE_OPERAND (source_tree, 1), NULL,
1598                               scalar_arg);
1599
1600     case MODIFY_EXPR:
1601       return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1602                               TREE_OPERAND (source_tree, 0), NULL,
1603                               scalar_arg);
1604
1605     case CONVERT_EXPR:
1606     case NOP_EXPR:
1607     case NON_LVALUE_EXPR:
1608     case PLUS_EXPR:
1609       if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1610         return TRUE;
1611
1612       ffecom_tree_canonize_ptr_ (&source_decl, &source_offset,
1613                                  source_tree);
1614       source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1615       break;
1616
1617     case COND_EXPR:
1618       return
1619         ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1620                          TREE_OPERAND (source_tree, 1), NULL,
1621                          scalar_arg)
1622           || ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1623                               TREE_OPERAND (source_tree, 2), NULL,
1624                               scalar_arg);
1625
1626
1627     case ADDR_EXPR:
1628       ffecom_tree_canonize_ref_ (&source_decl, &source_offset,
1629                                  &source_size,
1630                                  TREE_OPERAND (source_tree, 0));
1631       break;
1632
1633     case PARM_DECL:
1634       if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1635         return TRUE;
1636
1637       source_decl = source_tree;
1638       source_offset = bitsize_zero_node;
1639       source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1640       break;
1641
1642     case SAVE_EXPR:
1643     case REFERENCE_EXPR:
1644     case PREDECREMENT_EXPR:
1645     case PREINCREMENT_EXPR:
1646     case POSTDECREMENT_EXPR:
1647     case POSTINCREMENT_EXPR:
1648     case INDIRECT_REF:
1649     case ARRAY_REF:
1650     case CALL_EXPR:
1651     default:
1652       return TRUE;
1653     }
1654
1655   /* Come here when source_decl, source_offset, and source_size filled
1656      in appropriately.  */
1657
1658   if (source_decl == NULL_TREE)
1659     return FALSE;               /* No decl involved, so no overlap. */
1660
1661   if (source_decl != dest_decl)
1662     return FALSE;               /* Different decl, no overlap. */
1663
1664   if (TREE_CODE (dest_size) == ERROR_MARK)
1665     return TRUE;                /* Assignment into entire assumed-size
1666                                    array?  Shouldn't happen.... */
1667
1668   t = ffecom_2 (LE_EXPR, integer_type_node,
1669                 ffecom_2 (PLUS_EXPR, TREE_TYPE (dest_offset),
1670                           dest_offset,
1671                           convert (TREE_TYPE (dest_offset),
1672                                    dest_size)),
1673                 convert (TREE_TYPE (dest_offset),
1674                          source_offset));
1675
1676   if (integer_onep (t))
1677     return FALSE;               /* Destination precedes source. */
1678
1679   if (!scalar_arg
1680       || (source_size == NULL_TREE)
1681       || (TREE_CODE (source_size) == ERROR_MARK)
1682       || integer_zerop (source_size))
1683     return TRUE;                /* No way to tell if dest follows source. */
1684
1685   t = ffecom_2 (LE_EXPR, integer_type_node,
1686                 ffecom_2 (PLUS_EXPR, TREE_TYPE (source_offset),
1687                           source_offset,
1688                           convert (TREE_TYPE (source_offset),
1689                                    source_size)),
1690                 convert (TREE_TYPE (source_offset),
1691                          dest_offset));
1692
1693   if (integer_onep (t))
1694     return FALSE;               /* Destination follows source. */
1695
1696   return TRUE;          /* Destination and source overlap. */
1697 }
1698 #endif
1699
1700 /* Check whether dest might overlap any of a list of arguments or is
1701    in a COMMON area the callee might know about (and thus modify).  */
1702
1703 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1704 static bool
1705 ffecom_args_overlapping_ (tree dest_tree, ffebld dest UNUSED,
1706                           tree args, tree callee_commons,
1707                           bool scalar_args)
1708 {
1709   tree arg;
1710   tree dest_decl;
1711   tree dest_offset;
1712   tree dest_size;
1713
1714   ffecom_tree_canonize_ref_ (&dest_decl, &dest_offset, &dest_size,
1715                              dest_tree);
1716
1717   if (dest_decl == NULL_TREE)
1718     return FALSE;               /* Seems unlikely! */
1719
1720   /* If the decl cannot be determined reliably, or if its in COMMON
1721      and the callee isn't known to not futz with COMMON via other
1722      means, overlap might happen.  */
1723
1724   if ((TREE_CODE (dest_decl) == ERROR_MARK)
1725       || ((callee_commons != NULL_TREE)
1726           && TREE_PUBLIC (dest_decl)))
1727     return TRUE;
1728
1729   for (; args != NULL_TREE; args = TREE_CHAIN (args))
1730     {
1731       if (((arg = TREE_VALUE (args)) != NULL_TREE)
1732           && ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1733                               arg, NULL, scalar_args))
1734         return TRUE;
1735     }
1736
1737   return FALSE;
1738 }
1739 #endif
1740
1741 /* Build a string for a variable name as used by NAMELIST.  This means that
1742    if we're using the f2c library, we build an uppercase string, since
1743    f2c does this.  */
1744
1745 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1746 static tree
1747 ffecom_build_f2c_string_ (int i, const char *s)
1748 {
1749   if (!ffe_is_f2c_library ())
1750     return build_string (i, s);
1751
1752   {
1753     char *tmp;
1754     const char *p;
1755     char *q;
1756     char space[34];
1757     tree t;
1758
1759     if (((size_t) i) > ARRAY_SIZE (space))
1760       tmp = malloc_new_ks (malloc_pool_image (), "f2c_string", i);
1761     else
1762       tmp = &space[0];
1763
1764     for (p = s, q = tmp; *p != '\0'; ++p, ++q)
1765       *q = TOUPPER (*p);
1766     *q = '\0';
1767
1768     t = build_string (i, tmp);
1769
1770     if (((size_t) i) > ARRAY_SIZE (space))
1771       malloc_kill_ks (malloc_pool_image (), tmp, i);
1772
1773     return t;
1774   }
1775 }
1776
1777 #endif
1778 /* Returns CALL_EXPR or equivalent with given type (pass NULL_TREE for
1779    type to just get whatever the function returns), handling the
1780    f2c value-returning convention, if required, by prepending
1781    to the arglist a pointer to a temporary to receive the return value.  */
1782
1783 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1784 static tree
1785 ffecom_call_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1786               tree type, tree args, tree dest_tree,
1787               ffebld dest, bool *dest_used, tree callee_commons,
1788               bool scalar_args, tree hook)
1789 {
1790   tree item;
1791   tree tempvar;
1792
1793   if (dest_used != NULL)
1794     *dest_used = FALSE;
1795
1796   if (is_f2c_complex)
1797     {
1798       if ((dest_used == NULL)
1799           || (dest == NULL)
1800           || (ffeinfo_basictype (ffebld_info (dest))
1801               != FFEINFO_basictypeCOMPLEX)
1802           || (ffeinfo_kindtype (ffebld_info (dest)) != kt)
1803           || ((type != NULL_TREE) && (TREE_TYPE (dest_tree) != type))
1804           || ffecom_args_overlapping_ (dest_tree, dest, args,
1805                                        callee_commons,
1806                                        scalar_args))
1807         {
1808 #ifdef HOHO
1809           tempvar = ffecom_make_tempvar (ffecom_tree_type
1810                                          [FFEINFO_basictypeCOMPLEX][kt],
1811                                          FFETARGET_charactersizeNONE,
1812                                          -1);
1813 #else
1814           tempvar = hook;
1815           assert (tempvar);
1816 #endif
1817         }
1818       else
1819         {
1820           *dest_used = TRUE;
1821           tempvar = dest_tree;
1822           type = NULL_TREE;
1823         }
1824
1825       item
1826         = build_tree_list (NULL_TREE,
1827                            ffecom_1 (ADDR_EXPR,
1828                                      build_pointer_type (TREE_TYPE (tempvar)),
1829                                      tempvar));
1830       TREE_CHAIN (item) = args;
1831
1832       item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1833                         item, NULL_TREE);
1834
1835       if (tempvar != dest_tree)
1836         item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item, tempvar);
1837     }
1838   else
1839     item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1840                       args, NULL_TREE);
1841
1842   if ((type != NULL_TREE) && (TREE_TYPE (item) != type))
1843     item = ffecom_convert_narrow_ (type, item);
1844
1845   return item;
1846 }
1847 #endif
1848
1849 /* Given two arguments, transform them and make a call to the given
1850    function via ffecom_call_.  */
1851
1852 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1853 static tree
1854 ffecom_call_binop_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1855                     tree type, ffebld left, ffebld right,
1856                     tree dest_tree, ffebld dest, bool *dest_used,
1857                     tree callee_commons, bool scalar_args, bool ref, tree hook)
1858 {
1859   tree left_tree;
1860   tree right_tree;
1861   tree left_length;
1862   tree right_length;
1863
1864   if (ref)
1865     {
1866       /* Pass arguments by reference.  */
1867       left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
1868       right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
1869     }
1870   else
1871     {
1872       /* Pass arguments by value.  */
1873       left_tree = ffecom_arg_expr (left, &left_length);
1874       right_tree = ffecom_arg_expr (right, &right_length);
1875     }
1876
1877
1878   left_tree = build_tree_list (NULL_TREE, left_tree);
1879   right_tree = build_tree_list (NULL_TREE, right_tree);
1880   TREE_CHAIN (left_tree) = right_tree;
1881
1882   if (left_length != NULL_TREE)
1883     {
1884       left_length = build_tree_list (NULL_TREE, left_length);
1885       TREE_CHAIN (right_tree) = left_length;
1886     }
1887
1888   if (right_length != NULL_TREE)
1889     {
1890       right_length = build_tree_list (NULL_TREE, right_length);
1891       if (left_length != NULL_TREE)
1892         TREE_CHAIN (left_length) = right_length;
1893       else
1894         TREE_CHAIN (right_tree) = right_length;
1895     }
1896
1897   return ffecom_call_ (fn, kt, is_f2c_complex, type, left_tree,
1898                        dest_tree, dest, dest_used, callee_commons,
1899                        scalar_args, hook);
1900 }
1901 #endif
1902
1903 /* Return ptr/length args for char subexpression
1904
1905    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
1906    subexpressions by constructing the appropriate trees for the ptr-to-
1907    character-text and length-of-character-text arguments in a calling
1908    sequence.
1909
1910    Note that if with_null is TRUE, and the expression is an opCONTER,
1911    a null byte is appended to the string.  */
1912
1913 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1914 static void
1915 ffecom_char_args_x_ (tree *xitem, tree *length, ffebld expr, bool with_null)
1916 {
1917   tree item;
1918   tree high;
1919   ffetargetCharacter1 val;
1920   ffetargetCharacterSize newlen;
1921
1922   switch (ffebld_op (expr))
1923     {
1924     case FFEBLD_opCONTER:
1925       val = ffebld_constant_character1 (ffebld_conter (expr));
1926       newlen = ffetarget_length_character1 (val);
1927       if (with_null)
1928         {
1929           /* Begin FFETARGET-NULL-KLUDGE.  */
1930           if (newlen != 0)
1931             ++newlen;
1932         }
1933       *length = build_int_2 (newlen, 0);
1934       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
1935       high = build_int_2 (newlen, 0);
1936       TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
1937       item = build_string (newlen,
1938                            ffetarget_text_character1 (val));
1939       /* End FFETARGET-NULL-KLUDGE.  */
1940       TREE_TYPE (item)
1941         = build_type_variant
1942           (build_array_type
1943            (char_type_node,
1944             build_range_type
1945             (ffecom_f2c_ftnlen_type_node,
1946              ffecom_f2c_ftnlen_one_node,
1947              high)),
1948            1, 0);
1949       TREE_CONSTANT (item) = 1;
1950       TREE_STATIC (item) = 1;
1951       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
1952                        item);
1953       break;
1954
1955     case FFEBLD_opSYMTER:
1956       {
1957         ffesymbol s = ffebld_symter (expr);
1958
1959         item = ffesymbol_hook (s).decl_tree;
1960         if (item == NULL_TREE)
1961           {
1962             s = ffecom_sym_transform_ (s);
1963             item = ffesymbol_hook (s).decl_tree;
1964           }
1965         if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
1966           {
1967             if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
1968               *length = ffesymbol_hook (s).length_tree;
1969             else
1970               {
1971                 *length = build_int_2 (ffesymbol_size (s), 0);
1972                 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
1973               }
1974           }
1975         else if (item == error_mark_node)
1976           *length = error_mark_node;
1977         else
1978           /* FFEINFO_kindFUNCTION.  */
1979           *length = NULL_TREE;
1980         if (!ffesymbol_hook (s).addr
1981             && (item != error_mark_node))
1982           item = ffecom_1 (ADDR_EXPR,
1983                            build_pointer_type (TREE_TYPE (item)),
1984                            item);
1985       }
1986       break;
1987
1988     case FFEBLD_opARRAYREF:
1989       {
1990         ffecom_char_args_ (&item, length, ffebld_left (expr));
1991
1992         if (item == error_mark_node || *length == error_mark_node)
1993           {
1994             item = *length = error_mark_node;
1995             break;
1996           }
1997
1998         item = ffecom_arrayref_ (item, expr, 1);
1999       }
2000       break;
2001
2002     case FFEBLD_opSUBSTR:
2003       {
2004         ffebld start;
2005         ffebld end;
2006         ffebld thing = ffebld_right (expr);
2007         tree start_tree;
2008         tree end_tree;
2009         const char *char_name;
2010         ffebld left_symter;
2011         tree array;
2012
2013         assert (ffebld_op (thing) == FFEBLD_opITEM);
2014         start = ffebld_head (thing);
2015         thing = ffebld_trail (thing);
2016         assert (ffebld_trail (thing) == NULL);
2017         end = ffebld_head (thing);
2018
2019         /* Determine name for pretty-printing range-check errors.  */
2020         for (left_symter = ffebld_left (expr);
2021              left_symter && ffebld_op (left_symter) == FFEBLD_opARRAYREF;
2022              left_symter = ffebld_left (left_symter))
2023           ;
2024         if (ffebld_op (left_symter) == FFEBLD_opSYMTER)
2025           char_name = ffesymbol_text (ffebld_symter (left_symter));
2026         else
2027           char_name = "[expr?]";
2028
2029         ffecom_char_args_ (&item, length, ffebld_left (expr));
2030
2031         if (item == error_mark_node || *length == error_mark_node)
2032           {
2033             item = *length = error_mark_node;
2034             break;
2035           }
2036
2037         array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
2038
2039         /* ~~~~Handle INTEGER*8 start/end, a la FFEBLD_opARRAYREF.  */
2040
2041         if (start == NULL)
2042           {
2043             if (end == NULL)
2044               ;
2045             else
2046               {
2047                 end_tree = ffecom_expr (end);
2048                 if (flag_bounds_check)
2049                   end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2050                                                       char_name);
2051                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2052                                     end_tree);
2053
2054                 if (end_tree == error_mark_node)
2055                   {
2056                     item = *length = error_mark_node;
2057                     break;
2058                   }
2059
2060                 *length = end_tree;
2061               }
2062           }
2063         else
2064           {
2065             start_tree = ffecom_expr (start);
2066             if (flag_bounds_check)
2067               start_tree = ffecom_subscript_check_ (array, start_tree, 0, 0,
2068                                                     char_name);
2069             start_tree = convert (ffecom_f2c_ftnlen_type_node,
2070                                   start_tree);
2071
2072             if (start_tree == error_mark_node)
2073               {
2074                 item = *length = error_mark_node;
2075                 break;
2076               }
2077
2078             start_tree = ffecom_save_tree (start_tree);
2079
2080             item = ffecom_2 (PLUS_EXPR, TREE_TYPE (item),
2081                              item,
2082                              ffecom_2 (MINUS_EXPR,
2083                                        TREE_TYPE (start_tree),
2084                                        start_tree,
2085                                        ffecom_f2c_ftnlen_one_node));
2086
2087             if (end == NULL)
2088               {
2089                 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2090                                     ffecom_f2c_ftnlen_one_node,
2091                                     ffecom_2 (MINUS_EXPR,
2092                                               ffecom_f2c_ftnlen_type_node,
2093                                               *length,
2094                                               start_tree));
2095               }
2096             else
2097               {
2098                 end_tree = ffecom_expr (end);
2099                 if (flag_bounds_check)
2100                   end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2101                                                       char_name);
2102                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2103                                     end_tree);
2104
2105                 if (end_tree == error_mark_node)
2106                   {
2107                     item = *length = error_mark_node;
2108                     break;
2109                   }
2110
2111                 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2112                                     ffecom_f2c_ftnlen_one_node,
2113                                     ffecom_2 (MINUS_EXPR,
2114                                               ffecom_f2c_ftnlen_type_node,
2115                                               end_tree, start_tree));
2116               }
2117           }
2118       }
2119       break;
2120
2121     case FFEBLD_opFUNCREF:
2122       {
2123         ffesymbol s = ffebld_symter (ffebld_left (expr));
2124         tree tempvar;
2125         tree args;
2126         ffetargetCharacterSize size = ffeinfo_size (ffebld_info (expr));
2127         ffecomGfrt ix;
2128
2129         if (size == FFETARGET_charactersizeNONE)
2130           /* ~~Kludge alert!  This should someday be fixed. */
2131           size = 24;
2132
2133         *length = build_int_2 (size, 0);
2134         TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2135
2136         if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
2137             == FFEINFO_whereINTRINSIC)
2138           {
2139             if (size == 1)
2140               {
2141                 /* Invocation of an intrinsic returning CHARACTER*1.  */
2142                 item = ffecom_expr_intrinsic_ (expr, NULL_TREE,
2143                                                NULL, NULL);
2144                 break;
2145               }
2146             ix = ffeintrin_gfrt_direct (ffebld_symter_implementation (ffebld_left (expr)));
2147             assert (ix != FFECOM_gfrt);
2148             item = ffecom_gfrt_tree_ (ix);
2149           }
2150         else
2151           {
2152             ix = FFECOM_gfrt;
2153             item = ffesymbol_hook (s).decl_tree;
2154             if (item == NULL_TREE)
2155               {
2156                 s = ffecom_sym_transform_ (s);
2157                 item = ffesymbol_hook (s).decl_tree;
2158               }
2159             if (item == error_mark_node)
2160               {
2161                 item = *length = error_mark_node;
2162                 break;
2163               }
2164
2165             if (!ffesymbol_hook (s).addr)
2166               item = ffecom_1_fn (item);
2167           }
2168
2169 #ifdef HOHO
2170         tempvar = ffecom_push_tempvar (char_type_node, size, -1, TRUE);
2171 #else
2172         tempvar = ffebld_nonter_hook (expr);
2173         assert (tempvar);
2174 #endif
2175         tempvar = ffecom_1 (ADDR_EXPR,
2176                             build_pointer_type (TREE_TYPE (tempvar)),
2177                             tempvar);
2178
2179         args = build_tree_list (NULL_TREE, tempvar);
2180
2181         if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)       /* Sfunc args by value. */
2182           TREE_CHAIN (args) = ffecom_list_expr (ffebld_right (expr));
2183         else
2184           {
2185             TREE_CHAIN (args) = build_tree_list (NULL_TREE, *length);
2186             if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
2187               {
2188                 TREE_CHAIN (TREE_CHAIN (args))
2189                   = ffecom_arglist_expr_ (ffecom_gfrt_args_ (ix),
2190                                           ffebld_right (expr));
2191               }
2192             else
2193               {
2194                 TREE_CHAIN (TREE_CHAIN (args))
2195                   = ffecom_list_ptr_to_expr (ffebld_right (expr));
2196               }
2197           }
2198
2199         item = ffecom_3s (CALL_EXPR,
2200                           TREE_TYPE (TREE_TYPE (TREE_TYPE (item))),
2201                           item, args, NULL_TREE);
2202         item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item,
2203                          tempvar);
2204       }
2205       break;
2206
2207     case FFEBLD_opCONVERT:
2208
2209       ffecom_char_args_ (&item, length, ffebld_left (expr));
2210
2211       if (item == error_mark_node || *length == error_mark_node)
2212         {
2213           item = *length = error_mark_node;
2214           break;
2215         }
2216
2217       if ((ffebld_size_known (ffebld_left (expr))
2218            == FFETARGET_charactersizeNONE)
2219           || (ffebld_size_known (ffebld_left (expr)) < (ffebld_size (expr))))
2220         {                       /* Possible blank-padding needed, copy into
2221                                    temporary. */
2222           tree tempvar;
2223           tree args;
2224           tree newlen;
2225
2226 #ifdef HOHO
2227           tempvar = ffecom_make_tempvar (char_type_node,
2228                                          ffebld_size (expr), -1);
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           newlen = build_int_2 (ffebld_size (expr), 0);
2238           TREE_TYPE (newlen) = ffecom_f2c_ftnlen_type_node;
2239
2240           args = build_tree_list (NULL_TREE, tempvar);
2241           TREE_CHAIN (args) = build_tree_list (NULL_TREE, item);
2242           TREE_CHAIN (TREE_CHAIN (args)) = build_tree_list (NULL_TREE, newlen);
2243           TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (args)))
2244             = build_tree_list (NULL_TREE, *length);
2245
2246           item = ffecom_call_gfrt (FFECOM_gfrtCOPY, args, NULL_TREE);
2247           TREE_SIDE_EFFECTS (item) = 1;
2248           item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), fold (item),
2249                            tempvar);
2250           *length = newlen;
2251         }
2252       else
2253         {                       /* Just truncate the length. */
2254           *length = build_int_2 (ffebld_size (expr), 0);
2255           TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2256         }
2257       break;
2258
2259     default:
2260       assert ("bad op for single char arg expr" == NULL);
2261       item = NULL_TREE;
2262       break;
2263     }
2264
2265   *xitem = item;
2266 }
2267 #endif
2268
2269 /* Check the size of the type to be sure it doesn't overflow the
2270    "portable" capacities of the compiler back end.  `dummy' types
2271    can generally overflow the normal sizes as long as the computations
2272    themselves don't overflow.  A particular target of the back end
2273    must still enforce its size requirements, though, and the back
2274    end takes care of this in stor-layout.c.  */
2275
2276 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2277 static tree
2278 ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy)
2279 {
2280   if (TREE_CODE (type) == ERROR_MARK)
2281     return type;
2282
2283   if (TYPE_SIZE (type) == NULL_TREE)
2284     return type;
2285
2286   if (TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST)
2287     return type;
2288
2289   if ((tree_int_cst_sgn (TYPE_SIZE (type)) < 0)
2290       || (!dummy && (((TREE_INT_CST_HIGH (TYPE_SIZE (type)) != 0))
2291                      || TREE_OVERFLOW (TYPE_SIZE (type)))))
2292     {
2293       ffebad_start (FFEBAD_ARRAY_LARGE);
2294       ffebad_string (ffesymbol_text (s));
2295       ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s));
2296       ffebad_finish ();
2297
2298       return error_mark_node;
2299     }
2300
2301   return type;
2302 }
2303 #endif
2304
2305 /* Builds a length argument (PARM_DECL).  Also wraps type in an array type
2306    where the dimension info is (1:size) where <size> is ffesymbol_size(s) if
2307    known, length_arg if not known (FFETARGET_charactersizeNONE).  */
2308
2309 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2310 static tree
2311 ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s)
2312 {
2313   ffetargetCharacterSize sz = ffesymbol_size (s);
2314   tree highval;
2315   tree tlen;
2316   tree type = *xtype;
2317
2318   if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
2319     tlen = NULL_TREE;           /* A statement function, no length passed. */
2320   else
2321     {
2322       if (ffesymbol_where (s) == FFEINFO_whereDUMMY)
2323         tlen = ffecom_get_invented_identifier ("__g77_length_%s",
2324                                                ffesymbol_text (s));
2325       else
2326         tlen = ffecom_get_invented_identifier ("__g77_%s", "length");
2327       tlen = build_decl (PARM_DECL, tlen, ffecom_f2c_ftnlen_type_node);
2328 #if BUILT_FOR_270
2329       DECL_ARTIFICIAL (tlen) = 1;
2330 #endif
2331     }
2332
2333   if (sz == FFETARGET_charactersizeNONE)
2334     {
2335       assert (tlen != NULL_TREE);
2336       highval = variable_size (tlen);
2337     }
2338   else
2339     {
2340       highval = build_int_2 (sz, 0);
2341       TREE_TYPE (highval) = ffecom_f2c_ftnlen_type_node;
2342     }
2343
2344   type = build_array_type (type,
2345                            build_range_type (ffecom_f2c_ftnlen_type_node,
2346                                              ffecom_f2c_ftnlen_one_node,
2347                                              highval));
2348
2349   *xtype = type;
2350   return tlen;
2351 }
2352
2353 #endif
2354 /* ffecom_concat_list_gather_ -- Gather list of concatenated string exprs
2355
2356    ffecomConcatList_ catlist;
2357    ffebld expr;  // expr of CHARACTER basictype.
2358    ffetargetCharacterSize max;  // max chars to gather or _...NONE if no max
2359    catlist = ffecom_concat_list_gather_(catlist,expr,max);
2360
2361    Scans expr for character subexpressions, updates and returns catlist
2362    accordingly.  */
2363
2364 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2365 static ffecomConcatList_
2366 ffecom_concat_list_gather_ (ffecomConcatList_ catlist, ffebld expr,
2367                             ffetargetCharacterSize max)
2368 {
2369   ffetargetCharacterSize sz;
2370
2371 recurse:                        /* :::::::::::::::::::: */
2372
2373   if (expr == NULL)
2374     return catlist;
2375
2376   if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen >= max))
2377     return catlist;             /* Don't append any more items. */
2378
2379   switch (ffebld_op (expr))
2380     {
2381     case FFEBLD_opCONTER:
2382     case FFEBLD_opSYMTER:
2383     case FFEBLD_opARRAYREF:
2384     case FFEBLD_opFUNCREF:
2385     case FFEBLD_opSUBSTR:
2386     case FFEBLD_opCONVERT:      /* Callers should strip this off beforehand
2387                                    if they don't need to preserve it. */
2388       if (catlist.count == catlist.max)
2389         {                       /* Make a (larger) list. */
2390           ffebld *newx;
2391           int newmax;
2392
2393           newmax = (catlist.max == 0) ? 8 : catlist.max * 2;
2394           newx = malloc_new_ks (malloc_pool_image (), "catlist",
2395                                 newmax * sizeof (newx[0]));
2396           if (catlist.max != 0)
2397             {
2398               memcpy (newx, catlist.exprs, catlist.max * sizeof (newx[0]));
2399               malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2400                               catlist.max * sizeof (newx[0]));
2401             }
2402           catlist.max = newmax;
2403           catlist.exprs = newx;
2404         }
2405       if ((sz = ffebld_size_known (expr)) != FFETARGET_charactersizeNONE)
2406         catlist.minlen += sz;
2407       else
2408         ++catlist.minlen;       /* Not true for F90; can be 0 length. */
2409       if ((sz = ffebld_size_max (expr)) == FFETARGET_charactersizeNONE)
2410         catlist.maxlen = sz;
2411       else
2412         catlist.maxlen += sz;
2413       if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen > max))
2414         {                       /* This item overlaps (or is beyond) the end
2415                                    of the destination. */
2416           switch (ffebld_op (expr))
2417             {
2418             case FFEBLD_opCONTER:
2419             case FFEBLD_opSYMTER:
2420             case FFEBLD_opARRAYREF:
2421             case FFEBLD_opFUNCREF:
2422             case FFEBLD_opSUBSTR:
2423               /* ~~Do useful truncations here. */
2424               break;
2425
2426             default:
2427               assert ("op changed or inconsistent switches!" == NULL);
2428               break;
2429             }
2430         }
2431       catlist.exprs[catlist.count++] = expr;
2432       return catlist;
2433
2434     case FFEBLD_opPAREN:
2435       expr = ffebld_left (expr);
2436       goto recurse;             /* :::::::::::::::::::: */
2437
2438     case FFEBLD_opCONCATENATE:
2439       catlist = ffecom_concat_list_gather_ (catlist, ffebld_left (expr), max);
2440       expr = ffebld_right (expr);
2441       goto recurse;             /* :::::::::::::::::::: */
2442
2443 #if 0                           /* Breaks passing small actual arg to larger
2444                                    dummy arg of sfunc */
2445     case FFEBLD_opCONVERT:
2446       expr = ffebld_left (expr);
2447       {
2448         ffetargetCharacterSize cmax;
2449
2450         cmax = catlist.len + ffebld_size_known (expr);
2451
2452         if ((max == FFETARGET_charactersizeNONE) || (max > cmax))
2453           max = cmax;
2454       }
2455       goto recurse;             /* :::::::::::::::::::: */
2456 #endif
2457
2458     case FFEBLD_opANY:
2459       return catlist;
2460
2461     default:
2462       assert ("bad op in _gather_" == NULL);
2463       return catlist;
2464     }
2465 }
2466
2467 #endif
2468 /* ffecom_concat_list_kill_ -- Kill list of concatenated string exprs
2469
2470    ffecomConcatList_ catlist;
2471    ffecom_concat_list_kill_(catlist);
2472
2473    Anything allocated within the list info is deallocated.  */
2474
2475 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2476 static void
2477 ffecom_concat_list_kill_ (ffecomConcatList_ catlist)
2478 {
2479   if (catlist.max != 0)
2480     malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2481                     catlist.max * sizeof (catlist.exprs[0]));
2482 }
2483
2484 #endif
2485 /* Make list of concatenated string exprs.
2486
2487    Returns a flattened list of concatenated subexpressions given a
2488    tree of such expressions.  */
2489
2490 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2491 static ffecomConcatList_
2492 ffecom_concat_list_new_ (ffebld expr, ffetargetCharacterSize max)
2493 {
2494   ffecomConcatList_ catlist;
2495
2496   catlist.maxlen = catlist.minlen = catlist.max = catlist.count = 0;
2497   return ffecom_concat_list_gather_ (catlist, expr, max);
2498 }
2499
2500 #endif
2501
2502 /* Provide some kind of useful info on member of aggregate area,
2503    since current g77/gcc technology does not provide debug info
2504    on these members.  */
2505
2506 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2507 static void
2508 ffecom_debug_kludge_ (tree aggr, const char *aggr_type, ffesymbol member,
2509                       tree member_type UNUSED, ffetargetOffset offset)
2510 {
2511   tree value;
2512   tree decl;
2513   int len;
2514   char *buff;
2515   char space[120];
2516 #if 0
2517   tree type_id;
2518
2519   for (type_id = member_type;
2520        TREE_CODE (type_id) != IDENTIFIER_NODE;
2521        )
2522     {
2523       switch (TREE_CODE (type_id))
2524         {
2525         case INTEGER_TYPE:
2526         case REAL_TYPE:
2527           type_id = TYPE_NAME (type_id);
2528           break;
2529
2530         case ARRAY_TYPE:
2531         case COMPLEX_TYPE:
2532           type_id = TREE_TYPE (type_id);
2533           break;
2534
2535         default:
2536           assert ("no IDENTIFIER_NODE for type!" == NULL);
2537           type_id = error_mark_node;
2538           break;
2539         }
2540     }
2541 #endif
2542
2543   if (ffecom_transform_only_dummies_
2544       || !ffe_is_debug_kludge ())
2545     return;     /* Can't do this yet, maybe later. */
2546
2547   len = 60
2548     + strlen (aggr_type)
2549     + IDENTIFIER_LENGTH (DECL_NAME (aggr));
2550 #if 0
2551     + IDENTIFIER_LENGTH (type_id);
2552 #endif
2553
2554   if (((size_t) len) >= ARRAY_SIZE (space))
2555     buff = malloc_new_ks (malloc_pool_image (), "debug_kludge", len + 1);
2556   else
2557     buff = &space[0];
2558
2559   sprintf (&buff[0], "At (%s) `%s' plus %ld bytes",
2560            aggr_type,
2561            IDENTIFIER_POINTER (DECL_NAME (aggr)),
2562            (long int) offset);
2563
2564   value = build_string (len, buff);
2565   TREE_TYPE (value)
2566     = build_type_variant (build_array_type (char_type_node,
2567                                             build_range_type
2568                                             (integer_type_node,
2569                                              integer_one_node,
2570                                              build_int_2 (strlen (buff), 0))),
2571                           1, 0);
2572   decl = build_decl (VAR_DECL,
2573                      ffecom_get_identifier_ (ffesymbol_text (member)),
2574                      TREE_TYPE (value));
2575   TREE_CONSTANT (decl) = 1;
2576   TREE_STATIC (decl) = 1;
2577   DECL_INITIAL (decl) = error_mark_node;
2578   DECL_IN_SYSTEM_HEADER (decl) = 1;     /* Don't let -Wunused complain. */
2579   decl = start_decl (decl, FALSE);
2580   finish_decl (decl, value, FALSE);
2581
2582   if (buff != &space[0])
2583     malloc_kill_ks (malloc_pool_image (), buff, len + 1);
2584 }
2585 #endif
2586
2587 /* ffecom_do_entry_ -- Do compilation of a particular entrypoint
2588
2589    ffesymbol fn;  // the SUBROUTINE, FUNCTION, or ENTRY symbol itself
2590    int i;  // entry# for this entrypoint (used by master fn)
2591    ffecom_do_entrypoint_(s,i);
2592
2593    Makes a public entry point that calls our private master fn (already
2594    compiled).  */
2595
2596 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2597 static void
2598 ffecom_do_entry_ (ffesymbol fn, int entrynum)
2599 {
2600   ffebld item;
2601   tree type;                    /* Type of function. */
2602   tree multi_retval;            /* Var holding return value (union). */
2603   tree result;                  /* Var holding result. */
2604   ffeinfoBasictype bt;
2605   ffeinfoKindtype kt;
2606   ffeglobal g;
2607   ffeglobalType gt;
2608   bool charfunc;                /* All entry points return same type
2609                                    CHARACTER. */
2610   bool cmplxfunc;               /* Use f2c way of returning COMPLEX. */
2611   bool multi;                   /* Master fn has multiple return types. */
2612   bool altreturning = FALSE;    /* This entry point has alternate returns. */
2613   int old_lineno = lineno;
2614   const char *old_input_filename = input_filename;
2615
2616   input_filename = ffesymbol_where_filename (fn);
2617   lineno = ffesymbol_where_filelinenum (fn);
2618
2619   ffecom_doing_entry_ = TRUE;   /* Don't bother with array dimensions. */
2620
2621   switch (ffecom_primary_entry_kind_)
2622     {
2623     case FFEINFO_kindFUNCTION:
2624
2625       /* Determine actual return type for function. */
2626
2627       gt = FFEGLOBAL_typeFUNC;
2628       bt = ffesymbol_basictype (fn);
2629       kt = ffesymbol_kindtype (fn);
2630       if (bt == FFEINFO_basictypeNONE)
2631         {
2632           ffeimplic_establish_symbol (fn);
2633           if (ffesymbol_funcresult (fn) != NULL)
2634             ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
2635           bt = ffesymbol_basictype (fn);
2636           kt = ffesymbol_kindtype (fn);
2637         }
2638
2639       if (bt == FFEINFO_basictypeCHARACTER)
2640         charfunc = TRUE, cmplxfunc = FALSE;
2641       else if ((bt == FFEINFO_basictypeCOMPLEX)
2642                && ffesymbol_is_f2c (fn))
2643         charfunc = FALSE, cmplxfunc = TRUE;
2644       else
2645         charfunc = cmplxfunc = FALSE;
2646
2647       if (charfunc)
2648         type = ffecom_tree_fun_type_void;
2649       else if (ffesymbol_is_f2c (fn))
2650         type = ffecom_tree_fun_type[bt][kt];
2651       else
2652         type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
2653
2654       if ((type == NULL_TREE)
2655           || (TREE_TYPE (type) == NULL_TREE))
2656         type = ffecom_tree_fun_type_void;       /* _sym_exec_transition. */
2657
2658       multi = (ffecom_master_bt_ == FFEINFO_basictypeNONE);
2659       break;
2660
2661     case FFEINFO_kindSUBROUTINE:
2662       gt = FFEGLOBAL_typeSUBR;
2663       bt = FFEINFO_basictypeNONE;
2664       kt = FFEINFO_kindtypeNONE;
2665       if (ffecom_is_altreturning_)
2666         {                       /* Am _I_ altreturning? */
2667           for (item = ffesymbol_dummyargs (fn);
2668                item != NULL;
2669                item = ffebld_trail (item))
2670             {
2671               if (ffebld_op (ffebld_head (item)) == FFEBLD_opSTAR)
2672                 {
2673                   altreturning = TRUE;
2674                   break;
2675                 }
2676             }
2677           if (altreturning)
2678             type = ffecom_tree_subr_type;
2679           else
2680             type = ffecom_tree_fun_type_void;
2681         }
2682       else
2683         type = ffecom_tree_fun_type_void;
2684       charfunc = FALSE;
2685       cmplxfunc = FALSE;
2686       multi = FALSE;
2687       break;
2688
2689     default:
2690       assert ("say what??" == NULL);
2691       /* Fall through. */
2692     case FFEINFO_kindANY:
2693       gt = FFEGLOBAL_typeANY;
2694       bt = FFEINFO_basictypeNONE;
2695       kt = FFEINFO_kindtypeNONE;
2696       type = error_mark_node;
2697       charfunc = FALSE;
2698       cmplxfunc = FALSE;
2699       multi = FALSE;
2700       break;
2701     }
2702
2703   /* build_decl uses the current lineno and input_filename to set the decl
2704      source info.  So, I've putzed with ffestd and ffeste code to update that
2705      source info to point to the appropriate statement just before calling
2706      ffecom_do_entrypoint (which calls this fn).  */
2707
2708   start_function (ffecom_get_external_identifier_ (fn),
2709                   type,
2710                   0,            /* nested/inline */
2711                   1);           /* TREE_PUBLIC */
2712
2713   if (((g = ffesymbol_global (fn)) != NULL)
2714       && ((ffeglobal_type (g) == gt)
2715           || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
2716     {
2717       ffeglobal_set_hook (g, current_function_decl);
2718     }
2719
2720   /* Reset args in master arg list so they get retransitioned. */
2721
2722   for (item = ffecom_master_arglist_;
2723        item != NULL;
2724        item = ffebld_trail (item))
2725     {
2726       ffebld arg;
2727       ffesymbol s;
2728
2729       arg = ffebld_head (item);
2730       if (ffebld_op (arg) != FFEBLD_opSYMTER)
2731         continue;               /* Alternate return or some such thing. */
2732       s = ffebld_symter (arg);
2733       ffesymbol_hook (s).decl_tree = NULL_TREE;
2734       ffesymbol_hook (s).length_tree = NULL_TREE;
2735     }
2736
2737   /* Build dummy arg list for this entry point. */
2738
2739   if (charfunc || cmplxfunc)
2740     {                           /* Prepend arg for where result goes. */
2741       tree type;
2742       tree length;
2743
2744       if (charfunc)
2745         type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
2746       else
2747         type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
2748
2749       result = ffecom_get_invented_identifier ("__g77_%s", "result");
2750
2751       /* Make length arg _and_ enhance type info for CHAR arg itself.  */
2752
2753       if (charfunc)
2754         length = ffecom_char_enhance_arg_ (&type, fn);
2755       else
2756         length = NULL_TREE;     /* Not ref'd if !charfunc. */
2757
2758       type = build_pointer_type (type);
2759       result = build_decl (PARM_DECL, result, type);
2760
2761       push_parm_decl (result);
2762       ffecom_func_result_ = result;
2763
2764       if (charfunc)
2765         {
2766           push_parm_decl (length);
2767           ffecom_func_length_ = length;
2768         }
2769     }
2770   else
2771     result = DECL_RESULT (current_function_decl);
2772
2773   ffecom_push_dummy_decls_ (ffesymbol_dummyargs (fn), FALSE);
2774
2775   store_parm_decls (0);
2776
2777   ffecom_start_compstmt ();
2778   /* Disallow temp vars at this level.  */
2779   current_binding_level->prep_state = 2;
2780
2781   /* Make local var to hold return type for multi-type master fn. */
2782
2783   if (multi)
2784     {
2785       multi_retval = ffecom_get_invented_identifier ("__g77_%s",
2786                                                      "multi_retval");
2787       multi_retval = build_decl (VAR_DECL, multi_retval,
2788                                  ffecom_multi_type_node_);
2789       multi_retval = start_decl (multi_retval, FALSE);
2790       finish_decl (multi_retval, NULL_TREE, FALSE);
2791     }
2792   else
2793     multi_retval = NULL_TREE;   /* Not actually ref'd if !multi. */
2794
2795   /* Here we emit the actual code for the entry point. */
2796
2797   {
2798     ffebld list;
2799     ffebld arg;
2800     ffesymbol s;
2801     tree arglist = NULL_TREE;
2802     tree *plist = &arglist;
2803     tree prepend;
2804     tree call;
2805     tree actarg;
2806     tree master_fn;
2807
2808     /* Prepare actual arg list based on master arg list. */
2809
2810     for (list = ffecom_master_arglist_;
2811          list != NULL;
2812          list = ffebld_trail (list))
2813       {
2814         arg = ffebld_head (list);
2815         if (ffebld_op (arg) != FFEBLD_opSYMTER)
2816           continue;
2817         s = ffebld_symter (arg);
2818         if (ffesymbol_hook (s).decl_tree == NULL_TREE
2819             || ffesymbol_hook (s).decl_tree == error_mark_node)
2820           actarg = null_pointer_node;   /* We don't have this arg. */
2821         else
2822           actarg = ffesymbol_hook (s).decl_tree;
2823         *plist = build_tree_list (NULL_TREE, actarg);
2824         plist = &TREE_CHAIN (*plist);
2825       }
2826
2827     /* This code appends the length arguments for character
2828        variables/arrays.  */
2829
2830     for (list = ffecom_master_arglist_;
2831          list != NULL;
2832          list = ffebld_trail (list))
2833       {
2834         arg = ffebld_head (list);
2835         if (ffebld_op (arg) != FFEBLD_opSYMTER)
2836           continue;
2837         s = ffebld_symter (arg);
2838         if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
2839           continue;             /* Only looking for CHARACTER arguments. */
2840         if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
2841           continue;             /* Only looking for variables and arrays. */
2842         if (ffesymbol_hook (s).length_tree == NULL_TREE
2843             || ffesymbol_hook (s).length_tree == error_mark_node)
2844           actarg = ffecom_f2c_ftnlen_zero_node; /* We don't have this arg. */
2845         else
2846           actarg = ffesymbol_hook (s).length_tree;
2847         *plist = build_tree_list (NULL_TREE, actarg);
2848         plist = &TREE_CHAIN (*plist);
2849       }
2850
2851     /* Prepend character-value return info to actual arg list. */
2852
2853     if (charfunc)
2854       {
2855         prepend = build_tree_list (NULL_TREE, ffecom_func_result_);
2856         TREE_CHAIN (prepend)
2857           = build_tree_list (NULL_TREE, ffecom_func_length_);
2858         TREE_CHAIN (TREE_CHAIN (prepend)) = arglist;
2859         arglist = prepend;
2860       }
2861
2862     /* Prepend multi-type return value to actual arg list. */
2863
2864     if (multi)
2865       {
2866         prepend
2867           = build_tree_list (NULL_TREE,
2868                              ffecom_1 (ADDR_EXPR,
2869                               build_pointer_type (TREE_TYPE (multi_retval)),
2870                                        multi_retval));
2871         TREE_CHAIN (prepend) = arglist;
2872         arglist = prepend;
2873       }
2874
2875     /* Prepend my entry-point number to the actual arg list. */
2876
2877     prepend = build_tree_list (NULL_TREE, build_int_2 (entrynum, 0));
2878     TREE_CHAIN (prepend) = arglist;
2879     arglist = prepend;
2880
2881     /* Build the call to the master function. */
2882
2883     master_fn = ffecom_1_fn (ffecom_previous_function_decl_);
2884     call = ffecom_3s (CALL_EXPR,
2885                       TREE_TYPE (TREE_TYPE (TREE_TYPE (master_fn))),
2886                       master_fn, arglist, NULL_TREE);
2887
2888     /* Decide whether the master function is a function or subroutine, and
2889        handle the return value for my entry point. */
2890
2891     if (charfunc || ((ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
2892                      && !altreturning))
2893       {
2894         expand_expr_stmt (call);
2895         expand_null_return ();
2896       }
2897     else if (multi && cmplxfunc)
2898       {
2899         expand_expr_stmt (call);
2900         result
2901           = ffecom_1 (INDIRECT_REF,
2902                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
2903                       result);
2904         result = ffecom_modify (NULL_TREE, result,
2905                                 ffecom_2 (COMPONENT_REF, TREE_TYPE (result),
2906                                           multi_retval,
2907                                           ffecom_multi_fields_[bt][kt]));
2908         expand_expr_stmt (result);
2909         expand_null_return ();
2910       }
2911     else if (multi)
2912       {
2913         expand_expr_stmt (call);
2914         result
2915           = ffecom_modify (NULL_TREE, result,
2916                            convert (TREE_TYPE (result),
2917                                     ffecom_2 (COMPONENT_REF,
2918                                               ffecom_tree_type[bt][kt],
2919                                               multi_retval,
2920                                               ffecom_multi_fields_[bt][kt])));
2921         expand_return (result);
2922       }
2923     else if (cmplxfunc)
2924       {
2925         result
2926           = ffecom_1 (INDIRECT_REF,
2927                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
2928                       result);
2929         result = ffecom_modify (NULL_TREE, result, call);
2930         expand_expr_stmt (result);
2931         expand_null_return ();
2932       }
2933     else
2934       {
2935         result = ffecom_modify (NULL_TREE,
2936                                 result,
2937                                 convert (TREE_TYPE (result),
2938                                          call));
2939         expand_return (result);
2940       }
2941   }
2942
2943   ffecom_end_compstmt ();
2944
2945   finish_function (0);
2946
2947   lineno = old_lineno;
2948   input_filename = old_input_filename;
2949
2950   ffecom_doing_entry_ = FALSE;
2951 }
2952
2953 #endif
2954 /* Transform expr into gcc tree with possible destination
2955
2956    Recursive descent on expr while making corresponding tree nodes and
2957    attaching type info and such.  If destination supplied and compatible
2958    with temporary that would be made in certain cases, temporary isn't
2959    made, destination used instead, and dest_used flag set TRUE.  */
2960
2961 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2962 static tree
2963 ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
2964               bool *dest_used, bool assignp, bool widenp)
2965 {
2966   tree item;
2967   tree list;
2968   tree args;
2969   ffeinfoBasictype bt;
2970   ffeinfoKindtype kt;
2971   tree t;
2972   tree dt;                      /* decl_tree for an ffesymbol. */
2973   tree tree_type, tree_type_x;
2974   tree left, right;
2975   ffesymbol s;
2976   enum tree_code code;
2977
2978   assert (expr != NULL);
2979
2980   if (dest_used != NULL)
2981     *dest_used = FALSE;
2982
2983   bt = ffeinfo_basictype (ffebld_info (expr));
2984   kt = ffeinfo_kindtype (ffebld_info (expr));
2985   tree_type = ffecom_tree_type[bt][kt];
2986
2987   /* Widen integral arithmetic as desired while preserving signedness.  */
2988   tree_type_x = NULL_TREE;
2989   if (widenp && tree_type
2990       && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
2991       && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
2992     tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
2993
2994   switch (ffebld_op (expr))
2995     {
2996     case FFEBLD_opACCTER:
2997       {
2998         ffebitCount i;
2999         ffebit bits = ffebld_accter_bits (expr);
3000         ffetargetOffset source_offset = 0;
3001         ffetargetOffset dest_offset = ffebld_accter_pad (expr);
3002         tree purpose;
3003
3004         assert (dest_offset == 0
3005                 || (bt == FFEINFO_basictypeCHARACTER
3006                     && kt == FFEINFO_kindtypeCHARACTER1));
3007
3008         list = item = NULL;
3009         for (;;)
3010           {
3011             ffebldConstantUnion cu;
3012             ffebitCount length;
3013             bool value;
3014             ffebldConstantArray ca = ffebld_accter (expr);
3015
3016             ffebit_test (bits, source_offset, &value, &length);
3017             if (length == 0)
3018               break;
3019
3020             if (value)
3021               {
3022                 for (i = 0; i < length; ++i)
3023                   {
3024                     cu = ffebld_constantarray_get (ca, bt, kt,
3025                                                    source_offset + i);
3026
3027                     t = ffecom_constantunion (&cu, bt, kt, tree_type);
3028
3029                     if (i == 0
3030                         && dest_offset != 0)
3031                       purpose = build_int_2 (dest_offset, 0);
3032                     else
3033                       purpose = NULL_TREE;
3034
3035                     if (list == NULL_TREE)
3036                       list = item = build_tree_list (purpose, t);
3037                     else
3038                       {
3039                         TREE_CHAIN (item) = build_tree_list (purpose, t);
3040                         item = TREE_CHAIN (item);
3041                       }
3042                   }
3043               }
3044             source_offset += length;
3045             dest_offset += length;
3046           }
3047       }
3048
3049       item = build_int_2 ((ffebld_accter_size (expr)
3050                            + ffebld_accter_pad (expr)) - 1, 0);
3051       ffebit_kill (ffebld_accter_bits (expr));
3052       TREE_TYPE (item) = ffecom_integer_type_node;
3053       item
3054         = build_array_type
3055           (tree_type,
3056            build_range_type (ffecom_integer_type_node,
3057                              ffecom_integer_zero_node,
3058                              item));
3059       list = build (CONSTRUCTOR, item, NULL_TREE, list);
3060       TREE_CONSTANT (list) = 1;
3061       TREE_STATIC (list) = 1;
3062       return list;
3063
3064     case FFEBLD_opARRTER:
3065       {
3066         ffetargetOffset i;
3067
3068         list = NULL_TREE;
3069         if (ffebld_arrter_pad (expr) == 0)
3070           item = NULL_TREE;
3071         else
3072           {
3073             assert (bt == FFEINFO_basictypeCHARACTER
3074                     && kt == FFEINFO_kindtypeCHARACTER1);
3075
3076             /* Becomes PURPOSE first time through loop.  */
3077             item = build_int_2 (ffebld_arrter_pad (expr), 0);
3078           }
3079
3080         for (i = 0; i < ffebld_arrter_size (expr); ++i)
3081           {
3082             ffebldConstantUnion cu
3083             = ffebld_constantarray_get (ffebld_arrter (expr), bt, kt, i);
3084
3085             t = ffecom_constantunion (&cu, bt, kt, tree_type);
3086
3087             if (list == NULL_TREE)
3088               /* Assume item is PURPOSE first time through loop.  */
3089               list = item = build_tree_list (item, t);
3090             else
3091               {
3092                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
3093                 item = TREE_CHAIN (item);
3094               }
3095           }
3096       }
3097
3098       item = build_int_2 ((ffebld_arrter_size (expr)
3099                           + ffebld_arrter_pad (expr)) - 1, 0);
3100       TREE_TYPE (item) = ffecom_integer_type_node;
3101       item
3102         = build_array_type
3103           (tree_type,
3104            build_range_type (ffecom_integer_type_node,
3105                              ffecom_integer_zero_node,
3106                              item));
3107       list = build (CONSTRUCTOR, item, NULL_TREE, list);
3108       TREE_CONSTANT (list) = 1;
3109       TREE_STATIC (list) = 1;
3110       return list;
3111
3112     case FFEBLD_opCONTER:
3113       assert (ffebld_conter_pad (expr) == 0);
3114       item
3115         = ffecom_constantunion (&ffebld_constant_union (ffebld_conter (expr)),
3116                                 bt, kt, tree_type);
3117       return item;
3118
3119     case FFEBLD_opSYMTER:
3120       if ((ffebld_symter_generic (expr) != FFEINTRIN_genNONE)
3121           || (ffebld_symter_specific (expr) != FFEINTRIN_specNONE))
3122         return ffecom_ptr_to_expr (expr);       /* Same as %REF(intrinsic). */
3123       s = ffebld_symter (expr);
3124       t = ffesymbol_hook (s).decl_tree;
3125
3126       if (assignp)
3127         {                       /* ASSIGN'ed-label expr. */
3128           if (ffe_is_ugly_assign ())
3129             {
3130               /* User explicitly wants ASSIGN'ed variables to be at the same
3131                  memory address as the variables when used in non-ASSIGN
3132                  contexts.  That can make old, arcane, non-standard code
3133                  work, but don't try to do it when a pointer wouldn't fit
3134                  in the normal variable (take other approach, and warn,
3135                  instead).  */
3136
3137               if (t == NULL_TREE)
3138                 {
3139                   s = ffecom_sym_transform_ (s);
3140                   t = ffesymbol_hook (s).decl_tree;
3141                   assert (t != NULL_TREE);
3142                 }
3143
3144               if (t == error_mark_node)
3145                 return t;
3146
3147               if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t)))
3148                   >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
3149                 {
3150                   if (ffesymbol_hook (s).addr)
3151                     t = ffecom_1 (INDIRECT_REF,
3152                                   TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3153                   return t;
3154                 }
3155
3156               if (ffesymbol_hook (s).assign_tree == NULL_TREE)
3157                 {
3158                   ffebad_start_msg ("ASSIGN'ed label cannot fit into `%A' at %0 -- using wider sibling",
3159                                     FFEBAD_severityWARNING);
3160                   ffebad_string (ffesymbol_text (s));
3161                   ffebad_here (0, ffesymbol_where_line (s),
3162                                ffesymbol_where_column (s));
3163                   ffebad_finish ();
3164                 }
3165             }
3166
3167           /* Don't use the normal variable's tree for ASSIGN, though mark
3168              it as in the system header (housekeeping).  Use an explicit,
3169              specially created sibling that is known to be wide enough
3170              to hold pointers to labels.  */
3171
3172           if (t != NULL_TREE
3173               && TREE_CODE (t) == VAR_DECL)
3174             DECL_IN_SYSTEM_HEADER (t) = 1;      /* Don't let -Wunused complain. */
3175
3176           t = ffesymbol_hook (s).assign_tree;
3177           if (t == NULL_TREE)
3178             {
3179               s = ffecom_sym_transform_assign_ (s);
3180               t = ffesymbol_hook (s).assign_tree;
3181               assert (t != NULL_TREE);
3182             }
3183         }
3184       else
3185         {
3186           if (t == NULL_TREE)
3187             {
3188               s = ffecom_sym_transform_ (s);
3189               t = ffesymbol_hook (s).decl_tree;
3190               assert (t != NULL_TREE);
3191             }
3192           if (ffesymbol_hook (s).addr)
3193             t = ffecom_1 (INDIRECT_REF,
3194                           TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3195         }
3196       return t;
3197
3198     case FFEBLD_opARRAYREF:
3199       return ffecom_arrayref_ (NULL_TREE, expr, 0);
3200
3201     case FFEBLD_opUPLUS:
3202       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3203       return ffecom_1 (NOP_EXPR, tree_type, left);
3204
3205     case FFEBLD_opPAREN:
3206       /* ~~~Make sure Fortran rules respected here */
3207       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3208       return ffecom_1 (NOP_EXPR, tree_type, left);
3209
3210     case FFEBLD_opUMINUS:
3211       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3212       if (tree_type_x)
3213         {
3214           tree_type = tree_type_x;
3215           left = convert (tree_type, left);
3216         }
3217       return ffecom_1 (NEGATE_EXPR, tree_type, left);
3218
3219     case FFEBLD_opADD:
3220       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3221       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3222       if (tree_type_x)
3223         {
3224           tree_type = tree_type_x;
3225           left = convert (tree_type, left);
3226           right = convert (tree_type, right);
3227         }
3228       return ffecom_2 (PLUS_EXPR, tree_type, left, right);
3229
3230     case FFEBLD_opSUBTRACT:
3231       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3232       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3233       if (tree_type_x)
3234         {
3235           tree_type = tree_type_x;
3236           left = convert (tree_type, left);
3237           right = convert (tree_type, right);
3238         }
3239       return ffecom_2 (MINUS_EXPR, tree_type, left, right);
3240
3241     case FFEBLD_opMULTIPLY:
3242       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3243       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3244       if (tree_type_x)
3245         {
3246           tree_type = tree_type_x;
3247           left = convert (tree_type, left);
3248           right = convert (tree_type, right);
3249         }
3250       return ffecom_2 (MULT_EXPR, tree_type, left, right);
3251
3252     case FFEBLD_opDIVIDE:
3253       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3254       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3255       if (tree_type_x)
3256         {
3257           tree_type = tree_type_x;
3258           left = convert (tree_type, left);
3259           right = convert (tree_type, right);
3260         }
3261       return ffecom_tree_divide_ (tree_type, left, right,
3262                                   dest_tree, dest, dest_used,
3263                                   ffebld_nonter_hook (expr));
3264
3265     case FFEBLD_opPOWER:
3266       {
3267         ffebld left = ffebld_left (expr);
3268         ffebld right = ffebld_right (expr);
3269         ffecomGfrt code;
3270         ffeinfoKindtype rtkt;
3271         ffeinfoKindtype ltkt;
3272         bool ref = TRUE;
3273
3274         switch (ffeinfo_basictype (ffebld_info (right)))
3275           {
3276
3277           case FFEINFO_basictypeINTEGER:
3278             if (1 || optimize)
3279               {
3280                 item = ffecom_expr_power_integer_ (expr);
3281                 if (item != NULL_TREE)
3282                   return item;
3283               }
3284
3285             rtkt = FFEINFO_kindtypeINTEGER1;
3286             switch (ffeinfo_basictype (ffebld_info (left)))
3287               {
3288               case FFEINFO_basictypeINTEGER:
3289                 if ((ffeinfo_kindtype (ffebld_info (left))
3290                     == FFEINFO_kindtypeINTEGER4)
3291                     || (ffeinfo_kindtype (ffebld_info (right))
3292                         == FFEINFO_kindtypeINTEGER4))
3293                   {
3294                     code = FFECOM_gfrtPOW_QQ;
3295                     ltkt = FFEINFO_kindtypeINTEGER4;
3296                     rtkt = FFEINFO_kindtypeINTEGER4;
3297                   }
3298                 else
3299                   {
3300                     code = FFECOM_gfrtPOW_II;
3301                     ltkt = FFEINFO_kindtypeINTEGER1;
3302                   }
3303                 break;
3304
3305               case FFEINFO_basictypeREAL:
3306                 if (ffeinfo_kindtype (ffebld_info (left))
3307                     == FFEINFO_kindtypeREAL1)
3308                   {
3309                     code = FFECOM_gfrtPOW_RI;
3310                     ltkt = FFEINFO_kindtypeREAL1;
3311                   }
3312                 else
3313                   {
3314                     code = FFECOM_gfrtPOW_DI;
3315                     ltkt = FFEINFO_kindtypeREAL2;
3316                   }
3317                 break;
3318
3319               case FFEINFO_basictypeCOMPLEX:
3320                 if (ffeinfo_kindtype (ffebld_info (left))
3321                     == FFEINFO_kindtypeREAL1)
3322                   {
3323                     code = FFECOM_gfrtPOW_CI;   /* Overlapping result okay. */
3324                     ltkt = FFEINFO_kindtypeREAL1;
3325                   }
3326                 else
3327                   {
3328                     code = FFECOM_gfrtPOW_ZI;   /* Overlapping result okay. */
3329                     ltkt = FFEINFO_kindtypeREAL2;
3330                   }
3331                 break;
3332
3333               default:
3334                 assert ("bad pow_*i" == NULL);
3335                 code = FFECOM_gfrtPOW_CI;       /* Overlapping result okay. */
3336                 ltkt = FFEINFO_kindtypeREAL1;
3337                 break;
3338               }
3339             if (ffeinfo_kindtype (ffebld_info (left)) != ltkt)
3340               left = ffeexpr_convert (left, NULL, NULL,
3341                                       ffeinfo_basictype (ffebld_info (left)),
3342                                       ltkt, 0,
3343                                       FFETARGET_charactersizeNONE,
3344                                       FFEEXPR_contextLET);
3345             if (ffeinfo_kindtype (ffebld_info (right)) != rtkt)
3346               right = ffeexpr_convert (right, NULL, NULL,
3347                                        FFEINFO_basictypeINTEGER,
3348                                        rtkt, 0,
3349                                        FFETARGET_charactersizeNONE,
3350                                        FFEEXPR_contextLET);
3351             break;
3352
3353           case FFEINFO_basictypeREAL:
3354             if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3355               left = ffeexpr_convert (left, NULL, NULL, FFEINFO_basictypeREAL,
3356                                       FFEINFO_kindtypeREALDOUBLE, 0,
3357                                       FFETARGET_charactersizeNONE,
3358                                       FFEEXPR_contextLET);
3359             if (ffeinfo_kindtype (ffebld_info (right))
3360                 == FFEINFO_kindtypeREAL1)
3361               right = ffeexpr_convert (right, NULL, NULL,
3362                                        FFEINFO_basictypeREAL,
3363                                        FFEINFO_kindtypeREALDOUBLE, 0,
3364                                        FFETARGET_charactersizeNONE,
3365                                        FFEEXPR_contextLET);
3366             /* We used to call FFECOM_gfrtPOW_DD here,
3367                which passes arguments by reference.  */
3368             code = FFECOM_gfrtL_POW;
3369             /* Pass arguments by value. */
3370             ref  = FALSE;
3371             break;
3372
3373           case FFEINFO_basictypeCOMPLEX:
3374             if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3375               left = ffeexpr_convert (left, NULL, NULL,
3376                                       FFEINFO_basictypeCOMPLEX,
3377                                       FFEINFO_kindtypeREALDOUBLE, 0,
3378                                       FFETARGET_charactersizeNONE,
3379                                       FFEEXPR_contextLET);
3380             if (ffeinfo_kindtype (ffebld_info (right))
3381                 == FFEINFO_kindtypeREAL1)
3382               right = ffeexpr_convert (right, NULL, NULL,
3383                                        FFEINFO_basictypeCOMPLEX,
3384                                        FFEINFO_kindtypeREALDOUBLE, 0,
3385                                        FFETARGET_charactersizeNONE,
3386                                        FFEEXPR_contextLET);
3387             code = FFECOM_gfrtPOW_ZZ;   /* Overlapping result okay. */
3388             ref = TRUE;                 /* Pass arguments by reference. */
3389             break;
3390
3391           default:
3392             assert ("bad pow_x*" == NULL);
3393             code = FFECOM_gfrtPOW_II;
3394             break;
3395           }
3396         return ffecom_call_binop_ (ffecom_gfrt_tree_ (code),
3397                                    ffecom_gfrt_kindtype (code),
3398                                    (ffe_is_f2c_library ()
3399                                     && ffecom_gfrt_complex_[code]),
3400                                    tree_type, left, right,
3401                                    dest_tree, dest, dest_used,
3402                                    NULL_TREE, FALSE, ref,
3403                                    ffebld_nonter_hook (expr));
3404       }
3405
3406     case FFEBLD_opNOT:
3407       switch (bt)
3408         {
3409         case FFEINFO_basictypeLOGICAL:
3410           item = ffecom_truth_value_invert (ffecom_expr (ffebld_left (expr)));
3411           return convert (tree_type, item);
3412
3413         case FFEINFO_basictypeINTEGER:
3414           return ffecom_1 (BIT_NOT_EXPR, tree_type,
3415                            ffecom_expr (ffebld_left (expr)));
3416
3417         default:
3418           assert ("NOT bad basictype" == NULL);
3419           /* Fall through. */
3420         case FFEINFO_basictypeANY:
3421           return error_mark_node;
3422         }
3423       break;
3424
3425     case FFEBLD_opFUNCREF:
3426       assert (ffeinfo_basictype (ffebld_info (expr))
3427               != FFEINFO_basictypeCHARACTER);
3428       /* Fall through.   */
3429     case FFEBLD_opSUBRREF:
3430       if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
3431           == FFEINFO_whereINTRINSIC)
3432         {                       /* Invocation of an intrinsic. */
3433           item = ffecom_expr_intrinsic_ (expr, dest_tree, dest,
3434                                          dest_used);
3435           return item;
3436         }
3437       s = ffebld_symter (ffebld_left (expr));
3438       dt = ffesymbol_hook (s).decl_tree;
3439       if (dt == NULL_TREE)
3440         {
3441           s = ffecom_sym_transform_ (s);
3442           dt = ffesymbol_hook (s).decl_tree;
3443         }
3444       if (dt == error_mark_node)
3445         return dt;
3446
3447       if (ffesymbol_hook (s).addr)
3448         item = dt;
3449       else
3450         item = ffecom_1_fn (dt);
3451
3452       if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
3453         args = ffecom_list_expr (ffebld_right (expr));
3454       else
3455         args = ffecom_list_ptr_to_expr (ffebld_right (expr));
3456
3457       if (args == error_mark_node)
3458         return error_mark_node;
3459
3460       item = ffecom_call_ (item, kt,
3461                            ffesymbol_is_f2c (s)
3462                            && (bt == FFEINFO_basictypeCOMPLEX)
3463                            && (ffesymbol_where (s)
3464                                != FFEINFO_whereCONSTANT),
3465                            tree_type,
3466                            args,
3467                            dest_tree, dest, dest_used,
3468                            error_mark_node, FALSE,
3469                            ffebld_nonter_hook (expr));
3470       TREE_SIDE_EFFECTS (item) = 1;
3471       return item;
3472
3473     case FFEBLD_opAND:
3474       switch (bt)
3475         {
3476         case FFEINFO_basictypeLOGICAL:
3477           item
3478             = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3479                        ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3480                      ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3481           return convert (tree_type, item);
3482
3483         case FFEINFO_basictypeINTEGER:
3484           return ffecom_2 (BIT_AND_EXPR, tree_type,
3485                            ffecom_expr (ffebld_left (expr)),
3486                            ffecom_expr (ffebld_right (expr)));
3487
3488         default:
3489           assert ("AND bad basictype" == NULL);
3490           /* Fall through. */
3491         case FFEINFO_basictypeANY:
3492           return error_mark_node;
3493         }
3494       break;
3495
3496     case FFEBLD_opOR:
3497       switch (bt)
3498         {
3499         case FFEINFO_basictypeLOGICAL:
3500           item
3501             = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
3502                        ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3503                      ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3504           return convert (tree_type, item);
3505
3506         case FFEINFO_basictypeINTEGER:
3507           return ffecom_2 (BIT_IOR_EXPR, tree_type,
3508                            ffecom_expr (ffebld_left (expr)),
3509                            ffecom_expr (ffebld_right (expr)));
3510
3511         default:
3512           assert ("OR bad basictype" == NULL);
3513           /* Fall through. */
3514         case FFEINFO_basictypeANY:
3515           return error_mark_node;
3516         }
3517       break;
3518
3519     case FFEBLD_opXOR:
3520     case FFEBLD_opNEQV:
3521       switch (bt)
3522         {
3523         case FFEINFO_basictypeLOGICAL:
3524           item
3525             = ffecom_2 (NE_EXPR, integer_type_node,
3526                         ffecom_expr (ffebld_left (expr)),
3527                         ffecom_expr (ffebld_right (expr)));
3528           return convert (tree_type, ffecom_truth_value (item));
3529
3530         case FFEINFO_basictypeINTEGER:
3531           return ffecom_2 (BIT_XOR_EXPR, tree_type,
3532                            ffecom_expr (ffebld_left (expr)),
3533                            ffecom_expr (ffebld_right (expr)));
3534
3535         default:
3536           assert ("XOR/NEQV bad basictype" == NULL);
3537           /* Fall through. */
3538         case FFEINFO_basictypeANY:
3539           return error_mark_node;
3540         }
3541       break;
3542
3543     case FFEBLD_opEQV:
3544       switch (bt)
3545         {
3546         case FFEINFO_basictypeLOGICAL:
3547           item
3548             = ffecom_2 (EQ_EXPR, integer_type_node,
3549                         ffecom_expr (ffebld_left (expr)),
3550                         ffecom_expr (ffebld_right (expr)));
3551           return convert (tree_type, ffecom_truth_value (item));
3552
3553         case FFEINFO_basictypeINTEGER:
3554           return
3555             ffecom_1 (BIT_NOT_EXPR, tree_type,
3556                       ffecom_2 (BIT_XOR_EXPR, tree_type,
3557                                 ffecom_expr (ffebld_left (expr)),
3558                                 ffecom_expr (ffebld_right (expr))));
3559
3560         default:
3561           assert ("EQV bad basictype" == NULL);
3562           /* Fall through. */
3563         case FFEINFO_basictypeANY:
3564           return error_mark_node;
3565         }
3566       break;
3567
3568     case FFEBLD_opCONVERT:
3569       if (ffebld_op (ffebld_left (expr)) == FFEBLD_opANY)
3570         return error_mark_node;
3571
3572       switch (bt)
3573         {
3574         case FFEINFO_basictypeLOGICAL:
3575         case FFEINFO_basictypeINTEGER:
3576         case FFEINFO_basictypeREAL:
3577           return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3578
3579         case FFEINFO_basictypeCOMPLEX:
3580           switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3581             {
3582             case FFEINFO_basictypeINTEGER:
3583             case FFEINFO_basictypeLOGICAL:
3584             case FFEINFO_basictypeREAL:
3585               item = ffecom_expr (ffebld_left (expr));
3586               if (item == error_mark_node)
3587                 return error_mark_node;
3588               /* convert() takes care of converting to the subtype first,
3589                  at least in gcc-2.7.2. */
3590               item = convert (tree_type, item);
3591               return item;
3592
3593             case FFEINFO_basictypeCOMPLEX:
3594               return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3595
3596             default:
3597               assert ("CONVERT COMPLEX bad basictype" == NULL);
3598               /* Fall through. */
3599             case FFEINFO_basictypeANY:
3600               return error_mark_node;
3601             }
3602           break;
3603
3604         default:
3605           assert ("CONVERT bad basictype" == NULL);
3606           /* Fall through. */
3607         case FFEINFO_basictypeANY:
3608           return error_mark_node;
3609         }
3610       break;
3611
3612     case FFEBLD_opLT:
3613       code = LT_EXPR;
3614       goto relational;          /* :::::::::::::::::::: */
3615
3616     case FFEBLD_opLE:
3617       code = LE_EXPR;
3618       goto relational;          /* :::::::::::::::::::: */
3619
3620     case FFEBLD_opEQ:
3621       code = EQ_EXPR;
3622       goto relational;          /* :::::::::::::::::::: */
3623
3624     case FFEBLD_opNE:
3625       code = NE_EXPR;
3626       goto relational;          /* :::::::::::::::::::: */
3627
3628     case FFEBLD_opGT:
3629       code = GT_EXPR;
3630       goto relational;          /* :::::::::::::::::::: */
3631
3632     case FFEBLD_opGE:
3633       code = GE_EXPR;
3634
3635     relational:         /* :::::::::::::::::::: */
3636       switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3637         {
3638         case FFEINFO_basictypeLOGICAL:
3639         case FFEINFO_basictypeINTEGER:
3640         case FFEINFO_basictypeREAL:
3641           item = ffecom_2 (code, integer_type_node,
3642                            ffecom_expr (ffebld_left (expr)),
3643                            ffecom_expr (ffebld_right (expr)));
3644           return convert (tree_type, item);
3645
3646         case FFEINFO_basictypeCOMPLEX:
3647           assert (code == EQ_EXPR || code == NE_EXPR);
3648           {
3649             tree real_type;
3650             tree arg1 = ffecom_expr (ffebld_left (expr));
3651             tree arg2 = ffecom_expr (ffebld_right (expr));
3652
3653             if (arg1 == error_mark_node || arg2 == error_mark_node)
3654               return error_mark_node;
3655
3656             arg1 = ffecom_save_tree (arg1);
3657             arg2 = ffecom_save_tree (arg2);
3658
3659             if (TREE_CODE (TREE_TYPE (arg1)) == COMPLEX_TYPE)
3660               {
3661                 real_type = TREE_TYPE (TREE_TYPE (arg1));
3662                 assert (real_type == TREE_TYPE (TREE_TYPE (arg2)));
3663               }
3664             else
3665               {
3666                 real_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg1)));
3667                 assert (real_type == TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg2))));
3668               }
3669
3670             item
3671               = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3672                           ffecom_2 (EQ_EXPR, integer_type_node,
3673                                   ffecom_1 (REALPART_EXPR, real_type, arg1),
3674                                  ffecom_1 (REALPART_EXPR, real_type, arg2)),
3675                           ffecom_2 (EQ_EXPR, integer_type_node,
3676                                   ffecom_1 (IMAGPART_EXPR, real_type, arg1),
3677                                     ffecom_1 (IMAGPART_EXPR, real_type,
3678                                               arg2)));
3679             if (code == EQ_EXPR)
3680               item = ffecom_truth_value (item);
3681             else
3682               item = ffecom_truth_value_invert (item);
3683             return convert (tree_type, item);
3684           }
3685
3686         case FFEINFO_basictypeCHARACTER:
3687           {
3688             ffebld left = ffebld_left (expr);
3689             ffebld right = ffebld_right (expr);
3690             tree left_tree;
3691             tree right_tree;
3692             tree left_length;
3693             tree right_length;
3694
3695             /* f2c run-time functions do the implicit blank-padding for us,
3696                so we don't usually have to implement blank-padding ourselves.
3697                (The exception is when we pass an argument to a separately
3698                compiled statement function -- if we know the arg is not the
3699                same length as the dummy, we must truncate or extend it.  If
3700                we "inline" statement functions, that necessity goes away as
3701                well.)
3702
3703                Strip off the CONVERT operators that blank-pad.  (Truncation by
3704                CONVERT shouldn't happen here, but it can happen in
3705                assignments.) */
3706
3707             while (ffebld_op (left) == FFEBLD_opCONVERT)
3708               left = ffebld_left (left);
3709             while (ffebld_op (right) == FFEBLD_opCONVERT)
3710               right = ffebld_left (right);
3711
3712             left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
3713             right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
3714
3715             if (left_tree == error_mark_node || left_length == error_mark_node
3716                 || right_tree == error_mark_node
3717                 || right_length == error_mark_node)
3718               return error_mark_node;
3719
3720             if ((ffebld_size_known (left) == 1)
3721                 && (ffebld_size_known (right) == 1))
3722               {
3723                 left_tree
3724                   = ffecom_1 (INDIRECT_REF,
3725                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3726                               left_tree);
3727                 right_tree
3728                   = ffecom_1 (INDIRECT_REF,
3729                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3730                               right_tree);
3731
3732                 item
3733                   = ffecom_2 (code, integer_type_node,
3734                               ffecom_2 (ARRAY_REF,
3735                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3736                                         left_tree,
3737                                         integer_one_node),
3738                               ffecom_2 (ARRAY_REF,
3739                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3740                                         right_tree,
3741                                         integer_one_node));
3742               }
3743             else
3744               {
3745                 item = build_tree_list (NULL_TREE, left_tree);
3746                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, right_tree);
3747                 TREE_CHAIN (TREE_CHAIN (item)) = build_tree_list (NULL_TREE,
3748                                                                left_length);
3749                 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
3750                   = build_tree_list (NULL_TREE, right_length);
3751                 item = ffecom_call_gfrt (FFECOM_gfrtCMP, item, NULL_TREE);
3752                 item = ffecom_2 (code, integer_type_node,
3753                                  item,
3754                                  convert (TREE_TYPE (item),
3755                                           integer_zero_node));
3756               }
3757             item = convert (tree_type, item);
3758           }
3759
3760           return item;
3761
3762         default:
3763           assert ("relational bad basictype" == NULL);
3764           /* Fall through. */
3765         case FFEINFO_basictypeANY:
3766           return error_mark_node;
3767         }
3768       break;
3769
3770     case FFEBLD_opPERCENT_LOC:
3771       item = ffecom_arg_ptr_to_expr (ffebld_left (expr), &list);
3772       return convert (tree_type, item);
3773
3774     case FFEBLD_opITEM:
3775     case FFEBLD_opSTAR:
3776     case FFEBLD_opBOUNDS:
3777     case FFEBLD_opREPEAT:
3778     case FFEBLD_opLABTER:
3779     case FFEBLD_opLABTOK:
3780     case FFEBLD_opIMPDO:
3781     case FFEBLD_opCONCATENATE:
3782     case FFEBLD_opSUBSTR:
3783     default:
3784       assert ("bad op" == NULL);
3785       /* Fall through. */
3786     case FFEBLD_opANY:
3787       return error_mark_node;
3788     }
3789
3790 #if 1
3791   assert ("didn't think anything got here anymore!!" == NULL);
3792 #else
3793   switch (ffebld_arity (expr))
3794     {
3795     case 2:
3796       TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3797       TREE_OPERAND (item, 1) = ffecom_expr (ffebld_right (expr));
3798       if (TREE_OPERAND (item, 0) == error_mark_node
3799           || TREE_OPERAND (item, 1) == error_mark_node)
3800         return error_mark_node;
3801       break;
3802
3803     case 1:
3804       TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3805       if (TREE_OPERAND (item, 0) == error_mark_node)
3806         return error_mark_node;
3807       break;
3808
3809     default:
3810       break;
3811     }
3812
3813   return fold (item);
3814 #endif
3815 }
3816
3817 #endif
3818 /* Returns the tree that does the intrinsic invocation.
3819
3820    Note: this function applies only to intrinsics returning
3821    CHARACTER*1 or non-CHARACTER results, and to intrinsic
3822    subroutines.  */
3823
3824 #if FFECOM_targetCURRENT == FFECOM_targetGCC
3825 static tree
3826 ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
3827                         ffebld dest, bool *dest_used)
3828 {
3829   tree expr_tree;
3830   tree saved_expr1;             /* For those who need it. */
3831   tree saved_expr2;             /* For those who need it. */
3832   ffeinfoBasictype bt;
3833   ffeinfoKindtype kt;
3834   tree tree_type;
3835   tree arg1_type;
3836   tree real_type;               /* REAL type corresponding to COMPLEX. */
3837   tree tempvar;
3838   ffebld list = ffebld_right (expr);    /* List of (some) args. */
3839   ffebld arg1;                  /* For handy reference. */
3840   ffebld arg2;
3841   ffebld arg3;
3842   ffeintrinImp codegen_imp;
3843   ffecomGfrt gfrt;
3844
3845   assert (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER);
3846
3847   if (dest_used != NULL)
3848     *dest_used = FALSE;
3849
3850   bt = ffeinfo_basictype (ffebld_info (expr));
3851   kt = ffeinfo_kindtype (ffebld_info (expr));
3852   tree_type = ffecom_tree_type[bt][kt];
3853
3854   if (list != NULL)
3855     {
3856       arg1 = ffebld_head (list);
3857       if (arg1 != NULL && ffebld_op (arg1) == FFEBLD_opANY)
3858         return error_mark_node;
3859       if ((list = ffebld_trail (list)) != NULL)
3860         {
3861           arg2 = ffebld_head (list);
3862           if (arg2 != NULL && ffebld_op (arg2) == FFEBLD_opANY)
3863             return error_mark_node;
3864           if ((list = ffebld_trail (list)) != NULL)
3865             {
3866               arg3 = ffebld_head (list);
3867               if (arg3 != NULL && ffebld_op (arg3) == FFEBLD_opANY)
3868                 return error_mark_node;
3869             }
3870           else
3871             arg3 = NULL;
3872         }
3873       else
3874         arg2 = arg3 = NULL;
3875     }
3876   else
3877     arg1 = arg2 = arg3 = NULL;
3878
3879   /* <list> ends up at the opITEM of the 3rd arg, or NULL if there are < 3
3880      args.  This is used by the MAX/MIN expansions. */
3881
3882   if (arg1 != NULL)
3883     arg1_type = ffecom_tree_type
3884       [ffeinfo_basictype (ffebld_info (arg1))]
3885       [ffeinfo_kindtype (ffebld_info (arg1))];
3886   else
3887     arg1_type = NULL_TREE;      /* Really not needed, but might catch bugs
3888                                    here. */
3889
3890   /* There are several ways for each of the cases in the following switch
3891      statements to exit (from simplest to use to most complicated):
3892
3893      break;  (when expr_tree == NULL)
3894
3895      A standard call is made to the specific intrinsic just as if it had been
3896      passed in as a dummy procedure and called as any old procedure.  This
3897      method can produce slower code but in some cases it's the easiest way for
3898      now.  However, if a (presumably faster) direct call is available,
3899      that is used, so this is the easiest way in many more cases now.
3900
3901      gfrt = FFECOM_gfrtWHATEVER;
3902      break;
3903
3904      gfrt contains the gfrt index of a library function to call, passing the
3905      argument(s) by value rather than by reference.  Used when a more
3906      careful choice of library function is needed than that provided
3907      by the vanilla `break;'.
3908
3909      return expr_tree;
3910
3911      The expr_tree has been completely set up and is ready to be returned
3912      as is.  No further actions are taken.  Use this when the tree is not
3913      in the simple form for one of the arity_n labels.   */
3914
3915   /* For info on how the switch statement cases were written, see the files
3916      enclosed in comments below the switch statement. */
3917
3918   codegen_imp = ffebld_symter_implementation (ffebld_left (expr));
3919   gfrt = ffeintrin_gfrt_direct (codegen_imp);
3920   if (gfrt == FFECOM_gfrt)
3921     gfrt = ffeintrin_gfrt_indirect (codegen_imp);
3922
3923   switch (codegen_imp)
3924     {
3925     case FFEINTRIN_impABS:
3926     case FFEINTRIN_impCABS:
3927     case FFEINTRIN_impCDABS:
3928     case FFEINTRIN_impDABS:
3929     case FFEINTRIN_impIABS:
3930       if (ffeinfo_basictype (ffebld_info (arg1))
3931           == FFEINFO_basictypeCOMPLEX)
3932         {
3933           if (kt == FFEINFO_kindtypeREAL1)
3934             gfrt = FFECOM_gfrtCABS;
3935           else if (kt == FFEINFO_kindtypeREAL2)
3936             gfrt = FFECOM_gfrtCDABS;
3937           break;
3938         }
3939       return ffecom_1 (ABS_EXPR, tree_type,
3940                        convert (tree_type, ffecom_expr (arg1)));
3941
3942     case FFEINTRIN_impACOS:
3943     case FFEINTRIN_impDACOS:
3944       break;
3945
3946     case FFEINTRIN_impAIMAG:
3947     case FFEINTRIN_impDIMAG:
3948     case FFEINTRIN_impIMAGPART:
3949       if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
3950         arg1_type = TREE_TYPE (arg1_type);
3951       else
3952         arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
3953
3954       return
3955         convert (tree_type,
3956                  ffecom_1 (IMAGPART_EXPR, arg1_type,
3957                            ffecom_expr (arg1)));
3958
3959     case FFEINTRIN_impAINT:
3960     case FFEINTRIN_impDINT:
3961 #if 0
3962       /* ~~Someday implement FIX_TRUNC_EXPR yielding same type as arg.  */
3963       return ffecom_1 (FIX_TRUNC_EXPR, tree_type, ffecom_expr (arg1));
3964 #else /* in the meantime, must use floor to avoid range problems with ints */
3965       /* r__1 = r1 >= 0 ? floor(r1) : -floor(-r1); */
3966       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
3967       return
3968         convert (tree_type,
3969                  ffecom_3 (COND_EXPR, double_type_node,
3970                            ffecom_truth_value
3971                            (ffecom_2 (GE_EXPR, integer_type_node,
3972                                       saved_expr1,
3973                                       convert (arg1_type,
3974                                                ffecom_float_zero_))),
3975                            ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
3976                                              build_tree_list (NULL_TREE,
3977                                                   convert (double_type_node,
3978                                                            saved_expr1)),
3979                                              NULL_TREE),
3980                            ffecom_1 (NEGATE_EXPR, double_type_node,
3981                                      ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
3982                                                  build_tree_list (NULL_TREE,
3983                                                   convert (double_type_node,
3984                                                       ffecom_1 (NEGATE_EXPR,
3985                                                                 arg1_type,
3986                                                                saved_expr1))),
3987                                                        NULL_TREE)
3988                                      ))
3989                  );
3990 #endif
3991
3992     case FFEINTRIN_impANINT:
3993     case FFEINTRIN_impDNINT:
3994 #if 0                           /* This way of doing it won't handle real
3995                                    numbers of large magnitudes. */
3996       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
3997       expr_tree = convert (tree_type,
3998                            convert (integer_type_node,
3999                                     ffecom_3 (COND_EXPR, tree_type,
4000                                               ffecom_truth_value
4001                                               (ffecom_2 (GE_EXPR,
4002                                                          integer_type_node,
4003                                                          saved_expr1,
4004                                                        ffecom_float_zero_)),
4005                                               ffecom_2 (PLUS_EXPR,
4006                                                         tree_type,
4007                                                         saved_expr1,
4008                                                         ffecom_float_half_),
4009                                               ffecom_2 (MINUS_EXPR,
4010                                                         tree_type,
4011                                                         saved_expr1,
4012                                                      ffecom_float_half_))));
4013       return expr_tree;
4014 #else /* So we instead call floor. */
4015       /* r__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1) */
4016       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4017       return
4018         convert (tree_type,
4019                  ffecom_3 (COND_EXPR, double_type_node,
4020                            ffecom_truth_value
4021                            (ffecom_2 (GE_EXPR, integer_type_node,
4022                                       saved_expr1,
4023                                       convert (arg1_type,
4024                                                ffecom_float_zero_))),
4025                            ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4026                                              build_tree_list (NULL_TREE,
4027                                                   convert (double_type_node,
4028                                                            ffecom_2 (PLUS_EXPR,
4029                                                                      arg1_type,
4030                                                                      saved_expr1,
4031                                                                      convert (arg1_type,
4032                                                                               ffecom_float_half_)))),
4033                                              NULL_TREE),
4034                            ffecom_1 (NEGATE_EXPR, double_type_node,
4035                                      ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4036                                                        build_tree_list (NULL_TREE,
4037                                                                         convert (double_type_node,
4038                                                                                  ffecom_2 (MINUS_EXPR,
4039                                                                                            arg1_type,
4040                                                                                            convert (arg1_type,
4041                                                                                                     ffecom_float_half_),
4042                                                                                            saved_expr1))),
4043                                                        NULL_TREE))
4044                            )
4045                  );
4046 #endif
4047
4048     case FFEINTRIN_impASIN:
4049     case FFEINTRIN_impDASIN:
4050     case FFEINTRIN_impATAN:
4051     case FFEINTRIN_impDATAN:
4052     case FFEINTRIN_impATAN2:
4053     case FFEINTRIN_impDATAN2:
4054       break;
4055
4056     case FFEINTRIN_impCHAR:
4057     case FFEINTRIN_impACHAR:
4058 #ifdef HOHO
4059       tempvar = ffecom_make_tempvar (char_type_node, 1, -1);
4060 #else
4061       tempvar = ffebld_nonter_hook (expr);
4062       assert (tempvar);
4063 #endif
4064       {
4065         tree tmv = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (tempvar)));
4066
4067         expr_tree = ffecom_modify (tmv,
4068                                    ffecom_2 (ARRAY_REF, tmv, tempvar,
4069                                              integer_one_node),
4070                                    convert (tmv, ffecom_expr (arg1)));
4071       }
4072       expr_tree = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar),
4073                             expr_tree,
4074                             tempvar);
4075       expr_tree = ffecom_1 (ADDR_EXPR,
4076                             build_pointer_type (TREE_TYPE (expr_tree)),
4077                             expr_tree);
4078       return expr_tree;
4079
4080     case FFEINTRIN_impCMPLX:
4081     case FFEINTRIN_impDCMPLX:
4082       if (arg2 == NULL)
4083         return
4084           convert (tree_type, ffecom_expr (arg1));
4085
4086       real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4087       return
4088         ffecom_2 (COMPLEX_EXPR, tree_type,
4089                   convert (real_type, ffecom_expr (arg1)),
4090                   convert (real_type,
4091                            ffecom_expr (arg2)));
4092
4093     case FFEINTRIN_impCOMPLEX:
4094       return
4095         ffecom_2 (COMPLEX_EXPR, tree_type,
4096                   ffecom_expr (arg1),
4097                   ffecom_expr (arg2));
4098
4099     case FFEINTRIN_impCONJG:
4100     case FFEINTRIN_impDCONJG:
4101       {
4102         tree arg1_tree;
4103
4104         real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4105         arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4106         return
4107           ffecom_2 (COMPLEX_EXPR, tree_type,
4108                     ffecom_1 (REALPART_EXPR, real_type, arg1_tree),
4109                     ffecom_1 (NEGATE_EXPR, real_type,
4110                               ffecom_1 (IMAGPART_EXPR, real_type, arg1_tree)));
4111       }
4112
4113     case FFEINTRIN_impCOS:
4114     case FFEINTRIN_impCCOS:
4115     case FFEINTRIN_impCDCOS:
4116     case FFEINTRIN_impDCOS:
4117       if (bt == FFEINFO_basictypeCOMPLEX)
4118         {
4119           if (kt == FFEINFO_kindtypeREAL1)
4120             gfrt = FFECOM_gfrtCCOS;     /* Overlapping result okay. */
4121           else if (kt == FFEINFO_kindtypeREAL2)
4122             gfrt = FFECOM_gfrtCDCOS;    /* Overlapping result okay. */
4123         }
4124       break;
4125
4126     case FFEINTRIN_impCOSH:
4127     case FFEINTRIN_impDCOSH:
4128       break;
4129
4130     case FFEINTRIN_impDBLE:
4131     case FFEINTRIN_impDFLOAT:
4132     case FFEINTRIN_impDREAL:
4133     case FFEINTRIN_impFLOAT:
4134     case FFEINTRIN_impIDINT:
4135     case FFEINTRIN_impIFIX:
4136     case FFEINTRIN_impINT2:
4137     case FFEINTRIN_impINT8:
4138     case FFEINTRIN_impINT:
4139     case FFEINTRIN_impLONG:
4140     case FFEINTRIN_impREAL:
4141     case FFEINTRIN_impSHORT:
4142     case FFEINTRIN_impSNGL:
4143       return convert (tree_type, ffecom_expr (arg1));
4144
4145     case FFEINTRIN_impDIM:
4146     case FFEINTRIN_impDDIM:
4147     case FFEINTRIN_impIDIM:
4148       saved_expr1 = ffecom_save_tree (convert (tree_type,
4149                                                ffecom_expr (arg1)));
4150       saved_expr2 = ffecom_save_tree (convert (tree_type,
4151                                                ffecom_expr (arg2)));
4152       return
4153         ffecom_3 (COND_EXPR, tree_type,
4154                   ffecom_truth_value
4155                   (ffecom_2 (GT_EXPR, integer_type_node,
4156                              saved_expr1,
4157                              saved_expr2)),
4158                   ffecom_2 (MINUS_EXPR, tree_type,
4159                             saved_expr1,
4160                             saved_expr2),
4161                   convert (tree_type, ffecom_float_zero_));
4162
4163     case FFEINTRIN_impDPROD:
4164       return
4165         ffecom_2 (MULT_EXPR, tree_type,
4166                   convert (tree_type, ffecom_expr (arg1)),
4167                   convert (tree_type, ffecom_expr (arg2)));
4168
4169     case FFEINTRIN_impEXP:
4170     case FFEINTRIN_impCDEXP:
4171     case FFEINTRIN_impCEXP:
4172     case FFEINTRIN_impDEXP:
4173       if (bt == FFEINFO_basictypeCOMPLEX)
4174         {
4175           if (kt == FFEINFO_kindtypeREAL1)
4176             gfrt = FFECOM_gfrtCEXP;     /* Overlapping result okay. */
4177           else if (kt == FFEINFO_kindtypeREAL2)
4178             gfrt = FFECOM_gfrtCDEXP;    /* Overlapping result okay. */
4179         }
4180       break;
4181
4182     case FFEINTRIN_impICHAR:
4183     case FFEINTRIN_impIACHAR:
4184 #if 0                           /* The simple approach. */
4185       ffecom_char_args_ (&expr_tree, &saved_expr1 /* Ignored */ , arg1);
4186       expr_tree
4187         = ffecom_1 (INDIRECT_REF,
4188                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4189                     expr_tree);
4190       expr_tree
4191         = ffecom_2 (ARRAY_REF,
4192                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4193                     expr_tree,
4194                     integer_one_node);
4195       return convert (tree_type, expr_tree);
4196 #else /* The more interesting (and more optimal) approach. */
4197       expr_tree = ffecom_intrinsic_ichar_ (tree_type, arg1, &saved_expr1);
4198       expr_tree = ffecom_3 (COND_EXPR, tree_type,
4199                             saved_expr1,
4200                             expr_tree,
4201                             convert (tree_type, integer_zero_node));
4202       return expr_tree;
4203 #endif
4204
4205     case FFEINTRIN_impINDEX:
4206       break;
4207
4208     case FFEINTRIN_impLEN:
4209 #if 0
4210       break;                                    /* The simple approach. */
4211 #else
4212       return ffecom_intrinsic_len_ (arg1);      /* The more optimal approach. */
4213 #endif
4214
4215     case FFEINTRIN_impLGE:
4216     case FFEINTRIN_impLGT:
4217     case FFEINTRIN_impLLE:
4218     case FFEINTRIN_impLLT:
4219       break;
4220
4221     case FFEINTRIN_impLOG:
4222     case FFEINTRIN_impALOG:
4223     case FFEINTRIN_impCDLOG:
4224     case FFEINTRIN_impCLOG:
4225     case FFEINTRIN_impDLOG:
4226       if (bt == FFEINFO_basictypeCOMPLEX)
4227         {
4228           if (kt == FFEINFO_kindtypeREAL1)
4229             gfrt = FFECOM_gfrtCLOG;     /* Overlapping result okay. */
4230           else if (kt == FFEINFO_kindtypeREAL2)
4231             gfrt = FFECOM_gfrtCDLOG;    /* Overlapping result okay. */
4232         }
4233       break;
4234
4235     case FFEINTRIN_impLOG10:
4236     case FFEINTRIN_impALOG10:
4237     case FFEINTRIN_impDLOG10:
4238       if (gfrt != FFECOM_gfrt)
4239         break;  /* Already picked one, stick with it. */
4240
4241       if (kt == FFEINFO_kindtypeREAL1)
4242         /* We used to call FFECOM_gfrtALOG10 here.  */
4243         gfrt = FFECOM_gfrtL_LOG10;
4244       else if (kt == FFEINFO_kindtypeREAL2)
4245         /* We used to call FFECOM_gfrtDLOG10 here.  */
4246         gfrt = FFECOM_gfrtL_LOG10;
4247       break;
4248
4249     case FFEINTRIN_impMAX:
4250     case FFEINTRIN_impAMAX0:
4251     case FFEINTRIN_impAMAX1:
4252     case FFEINTRIN_impDMAX1:
4253     case FFEINTRIN_impMAX0:
4254     case FFEINTRIN_impMAX1:
4255       if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4256         arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4257       else
4258         arg1_type = tree_type;
4259       expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4260                             convert (arg1_type, ffecom_expr (arg1)),
4261                             convert (arg1_type, ffecom_expr (arg2)));
4262       for (; list != NULL; list = ffebld_trail (list))
4263         {
4264           if ((ffebld_head (list) == NULL)
4265               || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4266             continue;
4267           expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4268                                 expr_tree,
4269                                 convert (arg1_type,
4270                                          ffecom_expr (ffebld_head (list))));
4271         }
4272       return convert (tree_type, expr_tree);
4273
4274     case FFEINTRIN_impMIN:
4275     case FFEINTRIN_impAMIN0:
4276     case FFEINTRIN_impAMIN1:
4277     case FFEINTRIN_impDMIN1:
4278     case FFEINTRIN_impMIN0:
4279     case FFEINTRIN_impMIN1:
4280       if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4281         arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4282       else
4283         arg1_type = tree_type;
4284       expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4285                             convert (arg1_type, ffecom_expr (arg1)),
4286                             convert (arg1_type, ffecom_expr (arg2)));
4287       for (; list != NULL; list = ffebld_trail (list))
4288         {
4289           if ((ffebld_head (list) == NULL)
4290               || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4291             continue;
4292           expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4293                                 expr_tree,
4294                                 convert (arg1_type,
4295                                          ffecom_expr (ffebld_head (list))));
4296         }
4297       return convert (tree_type, expr_tree);
4298
4299     case FFEINTRIN_impMOD:
4300     case FFEINTRIN_impAMOD:
4301     case FFEINTRIN_impDMOD:
4302       if (bt != FFEINFO_basictypeREAL)
4303         return ffecom_2 (TRUNC_MOD_EXPR, tree_type,
4304                          convert (tree_type, ffecom_expr (arg1)),
4305                          convert (tree_type, ffecom_expr (arg2)));
4306
4307       if (kt == FFEINFO_kindtypeREAL1)
4308         /* We used to call FFECOM_gfrtAMOD here.  */
4309         gfrt = FFECOM_gfrtL_FMOD;
4310       else if (kt == FFEINFO_kindtypeREAL2)
4311         /* We used to call FFECOM_gfrtDMOD here.  */
4312         gfrt = FFECOM_gfrtL_FMOD;
4313       break;
4314
4315     case FFEINTRIN_impNINT:
4316     case FFEINTRIN_impIDNINT:
4317 #if 0
4318       /* ~~Ideally FIX_ROUND_EXPR would be implemented, but it ain't yet.  */
4319       return ffecom_1 (FIX_ROUND_EXPR, tree_type, ffecom_expr (arg1));
4320 #else
4321       /* i__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1); */
4322       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4323       return
4324         convert (ffecom_integer_type_node,
4325                  ffecom_3 (COND_EXPR, arg1_type,
4326                            ffecom_truth_value
4327                            (ffecom_2 (GE_EXPR, integer_type_node,
4328                                       saved_expr1,
4329                                       convert (arg1_type,
4330                                                ffecom_float_zero_))),
4331                            ffecom_2 (PLUS_EXPR, arg1_type,
4332                                      saved_expr1,
4333                                      convert (arg1_type,
4334                                               ffecom_float_half_)),
4335                            ffecom_2 (MINUS_EXPR, arg1_type,
4336                                      saved_expr1,
4337                                      convert (arg1_type,
4338                                               ffecom_float_half_))));
4339 #endif
4340
4341     case FFEINTRIN_impSIGN:
4342     case FFEINTRIN_impDSIGN:
4343     case FFEINTRIN_impISIGN:
4344       {
4345         tree arg2_tree = ffecom_expr (arg2);
4346
4347         saved_expr1
4348           = ffecom_save_tree
4349           (ffecom_1 (ABS_EXPR, tree_type,
4350                      convert (tree_type,
4351                               ffecom_expr (arg1))));
4352         expr_tree
4353           = ffecom_3 (COND_EXPR, tree_type,
4354                       ffecom_truth_value
4355                       (ffecom_2 (GE_EXPR, integer_type_node,
4356                                  arg2_tree,
4357                                  convert (TREE_TYPE (arg2_tree),
4358                                           integer_zero_node))),
4359                       saved_expr1,
4360                       ffecom_1 (NEGATE_EXPR, tree_type, saved_expr1));
4361         /* Make sure SAVE_EXPRs get referenced early enough. */
4362         expr_tree
4363           = ffecom_2 (COMPOUND_EXPR, tree_type,
4364                       convert (void_type_node, saved_expr1),
4365                       expr_tree);
4366       }
4367       return expr_tree;
4368
4369     case FFEINTRIN_impSIN:
4370     case FFEINTRIN_impCDSIN:
4371     case FFEINTRIN_impCSIN:
4372     case FFEINTRIN_impDSIN:
4373       if (bt == FFEINFO_basictypeCOMPLEX)
4374         {
4375           if (kt == FFEINFO_kindtypeREAL1)
4376             gfrt = FFECOM_gfrtCSIN;     /* Overlapping result okay. */
4377           else if (kt == FFEINFO_kindtypeREAL2)
4378             gfrt = FFECOM_gfrtCDSIN;    /* Overlapping result okay. */
4379         }
4380       break;
4381
4382     case FFEINTRIN_impSINH:
4383     case FFEINTRIN_impDSINH:
4384       break;
4385
4386     case FFEINTRIN_impSQRT:
4387     case FFEINTRIN_impCDSQRT:
4388     case FFEINTRIN_impCSQRT:
4389     case FFEINTRIN_impDSQRT:
4390       if (bt == FFEINFO_basictypeCOMPLEX)
4391         {
4392           if (kt == FFEINFO_kindtypeREAL1)
4393             gfrt = FFECOM_gfrtCSQRT;    /* Overlapping result okay. */
4394           else if (kt == FFEINFO_kindtypeREAL2)
4395             gfrt = FFECOM_gfrtCDSQRT;   /* Overlapping result okay. */
4396         }
4397       break;
4398
4399     case FFEINTRIN_impTAN:
4400     case FFEINTRIN_impDTAN:
4401     case FFEINTRIN_impTANH:
4402     case FFEINTRIN_impDTANH:
4403       break;
4404
4405     case FFEINTRIN_impREALPART:
4406       if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
4407         arg1_type = TREE_TYPE (arg1_type);
4408       else
4409         arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
4410
4411       return
4412         convert (tree_type,
4413                  ffecom_1 (REALPART_EXPR, arg1_type,
4414                            ffecom_expr (arg1)));
4415
4416     case FFEINTRIN_impIAND:
4417     case FFEINTRIN_impAND:
4418       return ffecom_2 (BIT_AND_EXPR, tree_type,
4419                        convert (tree_type,
4420                                 ffecom_expr (arg1)),
4421                        convert (tree_type,
4422                                 ffecom_expr (arg2)));
4423
4424     case FFEINTRIN_impIOR:
4425     case FFEINTRIN_impOR:
4426       return ffecom_2 (BIT_IOR_EXPR, tree_type,
4427                        convert (tree_type,
4428                                 ffecom_expr (arg1)),
4429                        convert (tree_type,
4430                                 ffecom_expr (arg2)));
4431
4432     case FFEINTRIN_impIEOR:
4433     case FFEINTRIN_impXOR:
4434       return ffecom_2 (BIT_XOR_EXPR, tree_type,
4435                        convert (tree_type,
4436                                 ffecom_expr (arg1)),
4437                        convert (tree_type,
4438                                 ffecom_expr (arg2)));
4439
4440     case FFEINTRIN_impLSHIFT:
4441       return ffecom_2 (LSHIFT_EXPR, tree_type,
4442                        ffecom_expr (arg1),
4443                        convert (integer_type_node,
4444                                 ffecom_expr (arg2)));
4445
4446     case FFEINTRIN_impRSHIFT:
4447       return ffecom_2 (RSHIFT_EXPR, tree_type,
4448                        ffecom_expr (arg1),
4449                        convert (integer_type_node,
4450                                 ffecom_expr (arg2)));
4451
4452     case FFEINTRIN_impNOT:
4453       return ffecom_1 (BIT_NOT_EXPR, tree_type, ffecom_expr (arg1));
4454
4455     case FFEINTRIN_impBIT_SIZE:
4456       return convert (tree_type, TYPE_SIZE (arg1_type));
4457
4458     case FFEINTRIN_impBTEST:
4459       {
4460         ffetargetLogical1 target_true;
4461         ffetargetLogical1 target_false;
4462         tree true_tree;
4463         tree false_tree;
4464
4465         ffetarget_logical1 (&target_true, TRUE);
4466         ffetarget_logical1 (&target_false, FALSE);
4467         if (target_true == 1)
4468           true_tree = convert (tree_type, integer_one_node);
4469         else
4470           true_tree = convert (tree_type, build_int_2 (target_true, 0));
4471         if (target_false == 0)
4472           false_tree = convert (tree_type, integer_zero_node);
4473         else
4474           false_tree = convert (tree_type, build_int_2 (target_false, 0));
4475
4476         return
4477           ffecom_3 (COND_EXPR, tree_type,
4478                     ffecom_truth_value
4479                     (ffecom_2 (EQ_EXPR, integer_type_node,
4480                                ffecom_2 (BIT_AND_EXPR, arg1_type,
4481                                          ffecom_expr (arg1),
4482                                          ffecom_2 (LSHIFT_EXPR, arg1_type,
4483                                                    convert (arg1_type,
4484                                                           integer_one_node),
4485                                                    convert (integer_type_node,
4486                                                             ffecom_expr (arg2)))),
4487                                convert (arg1_type,
4488                                         integer_zero_node))),
4489                     false_tree,
4490                     true_tree);
4491       }
4492
4493     case FFEINTRIN_impIBCLR:
4494       return
4495         ffecom_2 (BIT_AND_EXPR, tree_type,
4496                   ffecom_expr (arg1),
4497                   ffecom_1 (BIT_NOT_EXPR, tree_type,
4498                             ffecom_2 (LSHIFT_EXPR, tree_type,
4499                                       convert (tree_type,
4500                                                integer_one_node),
4501                                       convert (integer_type_node,
4502                                                ffecom_expr (arg2)))));
4503
4504     case FFEINTRIN_impIBITS:
4505       {
4506         tree arg3_tree = ffecom_save_tree (convert (integer_type_node,
4507                                                     ffecom_expr (arg3)));
4508         tree uns_type
4509         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4510
4511         expr_tree
4512           = ffecom_2 (BIT_AND_EXPR, tree_type,
4513                       ffecom_2 (RSHIFT_EXPR, tree_type,
4514                                 ffecom_expr (arg1),
4515                                 convert (integer_type_node,
4516                                          ffecom_expr (arg2))),
4517                       convert (tree_type,
4518                                ffecom_2 (RSHIFT_EXPR, uns_type,
4519                                          ffecom_1 (BIT_NOT_EXPR,
4520                                                    uns_type,
4521                                                    convert (uns_type,
4522                                                         integer_zero_node)),
4523                                          ffecom_2 (MINUS_EXPR,
4524                                                    integer_type_node,
4525                                                    TYPE_SIZE (uns_type),
4526                                                    arg3_tree))));
4527         /* Fix up, because the RSHIFT_EXPR above can't shift over TYPE_SIZE.  */
4528         expr_tree
4529           = ffecom_3 (COND_EXPR, tree_type,
4530                       ffecom_truth_value
4531                       (ffecom_2 (NE_EXPR, integer_type_node,
4532                                  arg3_tree,
4533                                  integer_zero_node)),
4534                       expr_tree,
4535                       convert (tree_type, integer_zero_node));
4536       }
4537       return expr_tree;
4538
4539     case FFEINTRIN_impIBSET:
4540       return
4541         ffecom_2 (BIT_IOR_EXPR, tree_type,
4542                   ffecom_expr (arg1),
4543                   ffecom_2 (LSHIFT_EXPR, tree_type,
4544                             convert (tree_type, integer_one_node),
4545                             convert (integer_type_node,
4546                                      ffecom_expr (arg2))));
4547
4548     case FFEINTRIN_impISHFT:
4549       {
4550         tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4551         tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4552                                                     ffecom_expr (arg2)));
4553         tree uns_type
4554         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4555
4556         expr_tree
4557           = ffecom_3 (COND_EXPR, tree_type,
4558                       ffecom_truth_value
4559                       (ffecom_2 (GE_EXPR, integer_type_node,
4560                                  arg2_tree,
4561                                  integer_zero_node)),
4562                       ffecom_2 (LSHIFT_EXPR, tree_type,
4563                                 arg1_tree,
4564                                 arg2_tree),
4565                       convert (tree_type,
4566                                ffecom_2 (RSHIFT_EXPR, uns_type,
4567                                          convert (uns_type, arg1_tree),
4568                                          ffecom_1 (NEGATE_EXPR,
4569                                                    integer_type_node,
4570                                                    arg2_tree))));
4571         /* Fix up, because {L|R}SHIFT_EXPR don't go over TYPE_SIZE bounds.  */
4572         expr_tree
4573           = ffecom_3 (COND_EXPR, tree_type,
4574                       ffecom_truth_value
4575                       (ffecom_2 (NE_EXPR, integer_type_node,
4576                                  ffecom_1 (ABS_EXPR,
4577                                            integer_type_node,
4578                                            arg2_tree),
4579                                  TYPE_SIZE (uns_type))),
4580                       expr_tree,
4581                       convert (tree_type, integer_zero_node));
4582         /* Make sure SAVE_EXPRs get referenced early enough. */
4583         expr_tree
4584           = ffecom_2 (COMPOUND_EXPR, tree_type,
4585                       convert (void_type_node, arg1_tree),
4586                       ffecom_2 (COMPOUND_EXPR, tree_type,
4587                                 convert (void_type_node, arg2_tree),
4588                                 expr_tree));
4589       }
4590       return expr_tree;
4591
4592     case FFEINTRIN_impISHFTC:
4593       {
4594         tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4595         tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4596                                                     ffecom_expr (arg2)));
4597         tree arg3_tree = (arg3 == NULL) ? TYPE_SIZE (tree_type)
4598         : ffecom_save_tree (convert (integer_type_node, ffecom_expr (arg3)));
4599         tree shift_neg;
4600         tree shift_pos;
4601         tree mask_arg1;
4602         tree masked_arg1;
4603         tree uns_type
4604         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4605
4606         mask_arg1
4607           = ffecom_2 (LSHIFT_EXPR, tree_type,
4608                       ffecom_1 (BIT_NOT_EXPR, tree_type,
4609                                 convert (tree_type, integer_zero_node)),
4610                       arg3_tree);
4611         /* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE.  */
4612         mask_arg1
4613           = ffecom_3 (COND_EXPR, tree_type,
4614                       ffecom_truth_value
4615                       (ffecom_2 (NE_EXPR, integer_type_node,
4616                                  arg3_tree,
4617                                  TYPE_SIZE (uns_type))),
4618                       mask_arg1,
4619                       convert (tree_type, integer_zero_node));
4620         mask_arg1 = ffecom_save_tree (mask_arg1);
4621         masked_arg1
4622           = ffecom_2 (BIT_AND_EXPR, tree_type,
4623                       arg1_tree,
4624                       ffecom_1 (BIT_NOT_EXPR, tree_type,
4625                                 mask_arg1));
4626         masked_arg1 = ffecom_save_tree (masked_arg1);
4627         shift_neg
4628           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4629                       convert (tree_type,
4630                                ffecom_2 (RSHIFT_EXPR, uns_type,
4631                                          convert (uns_type, masked_arg1),
4632                                          ffecom_1 (NEGATE_EXPR,
4633                                                    integer_type_node,
4634                                                    arg2_tree))),
4635                       ffecom_2 (LSHIFT_EXPR, tree_type,
4636                                 arg1_tree,
4637                                 ffecom_2 (PLUS_EXPR, integer_type_node,
4638                                           arg2_tree,
4639                                           arg3_tree)));
4640         shift_pos
4641           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4642                       ffecom_2 (LSHIFT_EXPR, tree_type,
4643                                 arg1_tree,
4644                                 arg2_tree),
4645                       convert (tree_type,
4646                                ffecom_2 (RSHIFT_EXPR, uns_type,
4647                                          convert (uns_type, masked_arg1),
4648                                          ffecom_2 (MINUS_EXPR,
4649                                                    integer_type_node,
4650                                                    arg3_tree,
4651                                                    arg2_tree))));
4652         expr_tree
4653           = ffecom_3 (COND_EXPR, tree_type,
4654                       ffecom_truth_value
4655                       (ffecom_2 (LT_EXPR, integer_type_node,
4656                                  arg2_tree,
4657                                  integer_zero_node)),
4658                       shift_neg,
4659                       shift_pos);
4660         expr_tree
4661           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4662                       ffecom_2 (BIT_AND_EXPR, tree_type,
4663                                 mask_arg1,
4664                                 arg1_tree),
4665                       ffecom_2 (BIT_AND_EXPR, tree_type,
4666                                 ffecom_1 (BIT_NOT_EXPR, tree_type,
4667                                           mask_arg1),
4668                                 expr_tree));
4669         expr_tree
4670           = ffecom_3 (COND_EXPR, tree_type,
4671                       ffecom_truth_value
4672                       (ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
4673                                  ffecom_2 (EQ_EXPR, integer_type_node,
4674                                            ffecom_1 (ABS_EXPR,
4675                                                      integer_type_node,
4676                                                      arg2_tree),
4677                                            arg3_tree),
4678                                  ffecom_2 (EQ_EXPR, integer_type_node,
4679                                            arg2_tree,
4680                                            integer_zero_node))),
4681                       arg1_tree,
4682                       expr_tree);
4683         /* Make sure SAVE_EXPRs get referenced early enough. */
4684         expr_tree
4685           = ffecom_2 (COMPOUND_EXPR, tree_type,
4686                       convert (void_type_node, arg1_tree),
4687                       ffecom_2 (COMPOUND_EXPR, tree_type,
4688                                 convert (void_type_node, arg2_tree),
4689                                 ffecom_2 (COMPOUND_EXPR, tree_type,
4690                                           convert (void_type_node,
4691                                                    mask_arg1),
4692                                           ffecom_2 (COMPOUND_EXPR, tree_type,
4693                                                     convert (void_type_node,
4694                                                              masked_arg1),
4695                                                     expr_tree))));
4696         expr_tree
4697           = ffecom_2 (COMPOUND_EXPR, tree_type,
4698                       convert (void_type_node,
4699                                arg3_tree),
4700                       expr_tree);
4701       }
4702       return expr_tree;
4703
4704     case FFEINTRIN_impLOC:
4705       {
4706         tree arg1_tree = ffecom_expr (arg1);
4707
4708         expr_tree
4709           = convert (tree_type,
4710                      ffecom_1 (ADDR_EXPR,
4711                                build_pointer_type (TREE_TYPE (arg1_tree)),
4712                                arg1_tree));
4713       }
4714       return expr_tree;
4715
4716     case FFEINTRIN_impMVBITS:
4717       {
4718         tree arg1_tree;
4719         tree arg2_tree;
4720         tree arg3_tree;
4721         ffebld arg4 = ffebld_head (ffebld_trail (list));
4722         tree arg4_tree;
4723         tree arg4_type;
4724         ffebld arg5 = ffebld_head (ffebld_trail (ffebld_trail (list)));
4725         tree arg5_tree;
4726         tree prep_arg1;
4727         tree prep_arg4;
4728         tree arg5_plus_arg3;
4729
4730         arg2_tree = convert (integer_type_node,
4731                              ffecom_expr (arg2));
4732         arg3_tree = ffecom_save_tree (convert (integer_type_node,
4733                                                ffecom_expr (arg3)));
4734         arg4_tree = ffecom_expr_rw (NULL_TREE, arg4);
4735         arg4_type = TREE_TYPE (arg4_tree);
4736
4737         arg1_tree = ffecom_save_tree (convert (arg4_type,
4738                                                ffecom_expr (arg1)));
4739
4740         arg5_tree = ffecom_save_tree (convert (integer_type_node,
4741                                                ffecom_expr (arg5)));
4742
4743         prep_arg1
4744           = ffecom_2 (LSHIFT_EXPR, arg4_type,
4745                       ffecom_2 (BIT_AND_EXPR, arg4_type,
4746                                 ffecom_2 (RSHIFT_EXPR, arg4_type,
4747                                           arg1_tree,
4748                                           arg2_tree),
4749                                 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4750                                           ffecom_2 (LSHIFT_EXPR, arg4_type,
4751                                                     ffecom_1 (BIT_NOT_EXPR,
4752                                                               arg4_type,
4753                                                               convert
4754                                                               (arg4_type,
4755                                                         integer_zero_node)),
4756                                                     arg3_tree))),
4757                       arg5_tree);
4758         arg5_plus_arg3
4759           = ffecom_save_tree (ffecom_2 (PLUS_EXPR, arg4_type,
4760                                         arg5_tree,
4761                                         arg3_tree));
4762         prep_arg4
4763           = ffecom_2 (LSHIFT_EXPR, arg4_type,
4764                       ffecom_1 (BIT_NOT_EXPR, arg4_type,
4765                                 convert (arg4_type,
4766                                          integer_zero_node)),
4767                       arg5_plus_arg3);
4768         /* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE.  */
4769         prep_arg4
4770           = ffecom_3 (COND_EXPR, arg4_type,
4771                       ffecom_truth_value
4772                       (ffecom_2 (NE_EXPR, integer_type_node,
4773                                  arg5_plus_arg3,
4774                                  convert (TREE_TYPE (arg5_plus_arg3),
4775                                           TYPE_SIZE (arg4_type)))),
4776                       prep_arg4,
4777                       convert (arg4_type, integer_zero_node));
4778         prep_arg4
4779           = ffecom_2 (BIT_AND_EXPR, arg4_type,
4780                       arg4_tree,
4781                       ffecom_2 (BIT_IOR_EXPR, arg4_type,
4782                                 prep_arg4,
4783                                 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4784                                           ffecom_2 (LSHIFT_EXPR, arg4_type,
4785                                                     ffecom_1 (BIT_NOT_EXPR,
4786                                                               arg4_type,
4787                                                               convert
4788                                                               (arg4_type,
4789                                                         integer_zero_node)),
4790                                                     arg5_tree))));
4791         prep_arg1
4792           = ffecom_2 (BIT_IOR_EXPR, arg4_type,
4793                       prep_arg1,
4794                       prep_arg4);
4795         /* Fix up (twice), because LSHIFT_EXPR above
4796            can't shift over TYPE_SIZE.  */
4797         prep_arg1
4798           = ffecom_3 (COND_EXPR, arg4_type,
4799                       ffecom_truth_value
4800                       (ffecom_2 (NE_EXPR, integer_type_node,
4801                                  arg3_tree,
4802                                  convert (TREE_TYPE (arg3_tree),
4803                                           integer_zero_node))),
4804                       prep_arg1,
4805                       arg4_tree);
4806         prep_arg1
4807           = ffecom_3 (COND_EXPR, arg4_type,
4808                       ffecom_truth_value
4809                       (ffecom_2 (NE_EXPR, integer_type_node,
4810                                  arg3_tree,
4811                                  convert (TREE_TYPE (arg3_tree),
4812                                           TYPE_SIZE (arg4_type)))),
4813                       prep_arg1,
4814                       arg1_tree);
4815         expr_tree
4816           = ffecom_2s (MODIFY_EXPR, void_type_node,
4817                        arg4_tree,
4818                        prep_arg1);
4819         /* Make sure SAVE_EXPRs get referenced early enough. */
4820         expr_tree
4821           = ffecom_2 (COMPOUND_EXPR, void_type_node,
4822                       arg1_tree,
4823                       ffecom_2 (COMPOUND_EXPR, void_type_node,
4824                                 arg3_tree,
4825                                 ffecom_2 (COMPOUND_EXPR, void_type_node,
4826                                           arg5_tree,
4827                                           ffecom_2 (COMPOUND_EXPR, void_type_node,
4828                                                     arg5_plus_arg3,
4829                                                     expr_tree))));
4830         expr_tree
4831           = ffecom_2 (COMPOUND_EXPR, void_type_node,
4832                       arg4_tree,
4833                       expr_tree);
4834
4835       }
4836       return expr_tree;
4837
4838     case FFEINTRIN_impDERF:
4839     case FFEINTRIN_impERF:
4840     case FFEINTRIN_impDERFC:
4841     case FFEINTRIN_impERFC:
4842       break;
4843
4844     case FFEINTRIN_impIARGC:
4845       /* extern int xargc; i__1 = xargc - 1; */
4846       expr_tree = ffecom_2 (MINUS_EXPR, TREE_TYPE (ffecom_tree_xargc_),
4847                             ffecom_tree_xargc_,
4848                             convert (TREE_TYPE (ffecom_tree_xargc_),
4849                                      integer_one_node));
4850       return expr_tree;
4851
4852     case FFEINTRIN_impSIGNAL_func:
4853     case FFEINTRIN_impSIGNAL_subr:
4854       {
4855         tree arg1_tree;
4856         tree arg2_tree;
4857         tree arg3_tree;
4858
4859         arg1_tree = convert (ffecom_f2c_integer_type_node,
4860                              ffecom_expr (arg1));
4861         arg1_tree = ffecom_1 (ADDR_EXPR,
4862                               build_pointer_type (TREE_TYPE (arg1_tree)),
4863                               arg1_tree);
4864
4865         /* Pass procedure as a pointer to it, anything else by value.  */
4866         if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
4867           arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
4868         else
4869           arg2_tree = ffecom_ptr_to_expr (arg2);
4870         arg2_tree = convert (TREE_TYPE (null_pointer_node),
4871                              arg2_tree);
4872
4873         if (arg3 != NULL)
4874           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
4875         else
4876           arg3_tree = NULL_TREE;
4877
4878         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4879         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4880         TREE_CHAIN (arg1_tree) = arg2_tree;
4881
4882         expr_tree
4883           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4884                           ffecom_gfrt_kindtype (gfrt),
4885                           FALSE,
4886                           ((codegen_imp == FFEINTRIN_impSIGNAL_subr) ?
4887                            NULL_TREE :
4888                            tree_type),
4889                           arg1_tree,
4890                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4891                           ffebld_nonter_hook (expr));
4892
4893         if (arg3_tree != NULL_TREE)
4894           expr_tree
4895             = ffecom_modify (NULL_TREE, arg3_tree,
4896                              convert (TREE_TYPE (arg3_tree),
4897                                       expr_tree));
4898       }
4899       return expr_tree;
4900
4901     case FFEINTRIN_impALARM:
4902       {
4903         tree arg1_tree;
4904         tree arg2_tree;
4905         tree arg3_tree;
4906
4907         arg1_tree = convert (ffecom_f2c_integer_type_node,
4908                              ffecom_expr (arg1));
4909         arg1_tree = ffecom_1 (ADDR_EXPR,
4910                               build_pointer_type (TREE_TYPE (arg1_tree)),
4911                               arg1_tree);
4912
4913         /* Pass procedure as a pointer to it, anything else by value.  */
4914         if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
4915           arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
4916         else
4917           arg2_tree = ffecom_ptr_to_expr (arg2);
4918         arg2_tree = convert (TREE_TYPE (null_pointer_node),
4919                              arg2_tree);
4920
4921         if (arg3 != NULL)
4922           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
4923         else
4924           arg3_tree = NULL_TREE;
4925
4926         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4927         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4928         TREE_CHAIN (arg1_tree) = arg2_tree;
4929
4930         expr_tree
4931           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4932                           ffecom_gfrt_kindtype (gfrt),
4933                           FALSE,
4934                           NULL_TREE,
4935                           arg1_tree,
4936                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4937                           ffebld_nonter_hook (expr));
4938
4939         if (arg3_tree != NULL_TREE)
4940           expr_tree
4941             = ffecom_modify (NULL_TREE, arg3_tree,
4942                              convert (TREE_TYPE (arg3_tree),
4943                                       expr_tree));
4944       }
4945       return expr_tree;
4946
4947     case FFEINTRIN_impCHDIR_subr:
4948     case FFEINTRIN_impFDATE_subr:
4949     case FFEINTRIN_impFGET_subr:
4950     case FFEINTRIN_impFPUT_subr:
4951     case FFEINTRIN_impGETCWD_subr:
4952     case FFEINTRIN_impHOSTNM_subr:
4953     case FFEINTRIN_impSYSTEM_subr:
4954     case FFEINTRIN_impUNLINK_subr:
4955       {
4956         tree arg1_len = integer_zero_node;
4957         tree arg1_tree;
4958         tree arg2_tree;
4959
4960         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
4961
4962         if (arg2 != NULL)
4963           arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
4964         else
4965           arg2_tree = NULL_TREE;
4966
4967         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4968         arg1_len = build_tree_list (NULL_TREE, arg1_len);
4969         TREE_CHAIN (arg1_tree) = arg1_len;
4970
4971         expr_tree
4972           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4973                           ffecom_gfrt_kindtype (gfrt),
4974                           FALSE,
4975                           NULL_TREE,
4976                           arg1_tree,
4977                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4978                           ffebld_nonter_hook (expr));
4979
4980         if (arg2_tree != NULL_TREE)
4981           expr_tree
4982             = ffecom_modify (NULL_TREE, arg2_tree,
4983                              convert (TREE_TYPE (arg2_tree),
4984                                       expr_tree));
4985       }
4986       return expr_tree;
4987
4988     case FFEINTRIN_impEXIT:
4989       if (arg1 != NULL)
4990         break;
4991
4992       expr_tree = build_tree_list (NULL_TREE,
4993                                    ffecom_1 (ADDR_EXPR,
4994                                              build_pointer_type
4995                                              (ffecom_integer_type_node),
4996                                              integer_zero_node));
4997
4998       return
4999         ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5000                       ffecom_gfrt_kindtype (gfrt),
5001                       FALSE,
5002                       void_type_node,
5003                       expr_tree,
5004                       NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5005                       ffebld_nonter_hook (expr));
5006
5007     case FFEINTRIN_impFLUSH:
5008       if (arg1 == NULL)
5009         gfrt = FFECOM_gfrtFLUSH;
5010       else
5011         gfrt = FFECOM_gfrtFLUSH1;
5012       break;
5013
5014     case FFEINTRIN_impCHMOD_subr:
5015     case FFEINTRIN_impLINK_subr:
5016     case FFEINTRIN_impRENAME_subr:
5017     case FFEINTRIN_impSYMLNK_subr:
5018       {
5019         tree arg1_len = integer_zero_node;
5020         tree arg1_tree;
5021         tree arg2_len = integer_zero_node;
5022         tree arg2_tree;
5023         tree arg3_tree;
5024
5025         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5026         arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
5027         if (arg3 != NULL)
5028           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5029         else
5030           arg3_tree = NULL_TREE;
5031
5032         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5033         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5034         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5035         arg2_len = build_tree_list (NULL_TREE, arg2_len);
5036         TREE_CHAIN (arg1_tree) = arg2_tree;
5037         TREE_CHAIN (arg2_tree) = arg1_len;
5038         TREE_CHAIN (arg1_len) = arg2_len;
5039         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5040                                   ffecom_gfrt_kindtype (gfrt),
5041                                   FALSE,
5042                                   NULL_TREE,
5043                                   arg1_tree,
5044                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5045                                   ffebld_nonter_hook (expr));
5046         if (arg3_tree != NULL_TREE)
5047           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5048                                      convert (TREE_TYPE (arg3_tree),
5049                                               expr_tree));
5050       }
5051       return expr_tree;
5052
5053     case FFEINTRIN_impLSTAT_subr:
5054     case FFEINTRIN_impSTAT_subr:
5055       {
5056         tree arg1_len = integer_zero_node;
5057         tree arg1_tree;
5058         tree arg2_tree;
5059         tree arg3_tree;
5060
5061         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5062
5063         arg2_tree = ffecom_ptr_to_expr (arg2);
5064
5065         if (arg3 != NULL)
5066           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5067         else
5068           arg3_tree = NULL_TREE;
5069
5070         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5071         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5072         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5073         TREE_CHAIN (arg1_tree) = arg2_tree;
5074         TREE_CHAIN (arg2_tree) = arg1_len;
5075         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5076                                   ffecom_gfrt_kindtype (gfrt),
5077                                   FALSE,
5078                                   NULL_TREE,
5079                                   arg1_tree,
5080                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5081                                   ffebld_nonter_hook (expr));
5082         if (arg3_tree != NULL_TREE)
5083           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5084                                      convert (TREE_TYPE (arg3_tree),
5085                                               expr_tree));
5086       }
5087       return expr_tree;
5088
5089     case FFEINTRIN_impFGETC_subr:
5090     case FFEINTRIN_impFPUTC_subr:
5091       {
5092         tree arg1_tree;
5093         tree arg2_tree;
5094         tree arg2_len = integer_zero_node;
5095         tree arg3_tree;
5096
5097         arg1_tree = convert (ffecom_f2c_integer_type_node,
5098                              ffecom_expr (arg1));
5099         arg1_tree = ffecom_1 (ADDR_EXPR,
5100                               build_pointer_type (TREE_TYPE (arg1_tree)),
5101                               arg1_tree);
5102
5103         arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
5104         if (arg3 != NULL)
5105           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5106         else
5107           arg3_tree = NULL_TREE;
5108
5109         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5110         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5111         arg2_len = build_tree_list (NULL_TREE, arg2_len);
5112         TREE_CHAIN (arg1_tree) = arg2_tree;
5113         TREE_CHAIN (arg2_tree) = arg2_len;
5114
5115         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5116                                   ffecom_gfrt_kindtype (gfrt),
5117                                   FALSE,
5118                                   NULL_TREE,
5119                                   arg1_tree,
5120                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5121                                   ffebld_nonter_hook (expr));
5122         if (arg3_tree != NULL_TREE)
5123           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5124                                      convert (TREE_TYPE (arg3_tree),
5125                                               expr_tree));
5126       }
5127       return expr_tree;
5128
5129     case FFEINTRIN_impFSTAT_subr:
5130       {
5131         tree arg1_tree;
5132         tree arg2_tree;
5133         tree arg3_tree;
5134
5135         arg1_tree = convert (ffecom_f2c_integer_type_node,
5136                              ffecom_expr (arg1));
5137         arg1_tree = ffecom_1 (ADDR_EXPR,
5138                               build_pointer_type (TREE_TYPE (arg1_tree)),
5139                               arg1_tree);
5140
5141         arg2_tree = convert (ffecom_f2c_ptr_to_integer_type_node,
5142                              ffecom_ptr_to_expr (arg2));
5143
5144         if (arg3 == NULL)
5145           arg3_tree = NULL_TREE;
5146         else
5147           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5148
5149         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5150         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5151         TREE_CHAIN (arg1_tree) = arg2_tree;
5152         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5153                                   ffecom_gfrt_kindtype (gfrt),
5154                                   FALSE,
5155                                   NULL_TREE,
5156                                   arg1_tree,
5157                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5158                                   ffebld_nonter_hook (expr));
5159         if (arg3_tree != NULL_TREE) {
5160           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5161                                      convert (TREE_TYPE (arg3_tree),
5162                                               expr_tree));
5163         }
5164       }
5165       return expr_tree;
5166
5167     case FFEINTRIN_impKILL_subr:
5168       {
5169         tree arg1_tree;
5170         tree arg2_tree;
5171         tree arg3_tree;
5172
5173         arg1_tree = convert (ffecom_f2c_integer_type_node,
5174                              ffecom_expr (arg1));
5175         arg1_tree = ffecom_1 (ADDR_EXPR,
5176                               build_pointer_type (TREE_TYPE (arg1_tree)),
5177                               arg1_tree);
5178
5179         arg2_tree = convert (ffecom_f2c_integer_type_node,
5180                              ffecom_expr (arg2));
5181         arg2_tree = ffecom_1 (ADDR_EXPR,
5182                               build_pointer_type (TREE_TYPE (arg2_tree)),
5183                               arg2_tree);
5184
5185         if (arg3 == NULL)
5186           arg3_tree = NULL_TREE;
5187         else
5188           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5189
5190         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5191         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5192         TREE_CHAIN (arg1_tree) = arg2_tree;
5193         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5194                                   ffecom_gfrt_kindtype (gfrt),
5195                                   FALSE,
5196                                   NULL_TREE,
5197                                   arg1_tree,
5198                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5199                                   ffebld_nonter_hook (expr));
5200         if (arg3_tree != NULL_TREE) {
5201           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5202                                      convert (TREE_TYPE (arg3_tree),
5203                                               expr_tree));
5204         }
5205       }
5206       return expr_tree;
5207
5208     case FFEINTRIN_impCTIME_subr:
5209     case FFEINTRIN_impTTYNAM_subr:
5210       {
5211         tree arg1_len = integer_zero_node;
5212         tree arg1_tree;
5213         tree arg2_tree;
5214
5215         arg1_tree = ffecom_arg_ptr_to_expr (arg2, &arg1_len);
5216
5217         arg2_tree = convert (((codegen_imp == FFEINTRIN_impCTIME_subr) ?
5218                               ffecom_f2c_longint_type_node :
5219                               ffecom_f2c_integer_type_node),
5220                              ffecom_expr (arg1));
5221         arg2_tree = ffecom_1 (ADDR_EXPR,
5222                               build_pointer_type (TREE_TYPE (arg2_tree)),
5223                               arg2_tree);
5224
5225         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5226         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5227         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5228         TREE_CHAIN (arg1_len) = arg2_tree;
5229         TREE_CHAIN (arg1_tree) = arg1_len;
5230
5231         expr_tree
5232           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5233                           ffecom_gfrt_kindtype (gfrt),
5234                           FALSE,
5235                           NULL_TREE,
5236                           arg1_tree,
5237                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5238                           ffebld_nonter_hook (expr));
5239         TREE_SIDE_EFFECTS (expr_tree) = 1;
5240       }
5241       return expr_tree;
5242
5243     case FFEINTRIN_impIRAND:
5244     case FFEINTRIN_impRAND:
5245       /* Arg defaults to 0 (normal random case) */
5246       {
5247         tree arg1_tree;
5248
5249         if (arg1 == NULL)
5250           arg1_tree = ffecom_integer_zero_node;
5251         else
5252           arg1_tree = ffecom_expr (arg1);
5253         arg1_tree = convert (ffecom_f2c_integer_type_node,
5254                              arg1_tree);
5255         arg1_tree = ffecom_1 (ADDR_EXPR,
5256                               build_pointer_type (TREE_TYPE (arg1_tree)),
5257                               arg1_tree);
5258         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5259
5260         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5261                                   ffecom_gfrt_kindtype (gfrt),
5262                                   FALSE,
5263                                   ((codegen_imp == FFEINTRIN_impIRAND) ?
5264                                    ffecom_f2c_integer_type_node :
5265                                    ffecom_f2c_real_type_node),
5266                                   arg1_tree,
5267                                   dest_tree, dest, dest_used,
5268                                   NULL_TREE, TRUE,
5269                                   ffebld_nonter_hook (expr));
5270       }
5271       return expr_tree;
5272
5273     case FFEINTRIN_impFTELL_subr:
5274     case FFEINTRIN_impUMASK_subr:
5275       {
5276         tree arg1_tree;
5277         tree arg2_tree;
5278
5279         arg1_tree = convert (ffecom_f2c_integer_type_node,
5280                              ffecom_expr (arg1));
5281         arg1_tree = ffecom_1 (ADDR_EXPR,
5282                               build_pointer_type (TREE_TYPE (arg1_tree)),
5283                               arg1_tree);
5284
5285         if (arg2 == NULL)
5286           arg2_tree = NULL_TREE;
5287         else
5288           arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
5289
5290         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5291                                   ffecom_gfrt_kindtype (gfrt),
5292                                   FALSE,
5293                                   NULL_TREE,
5294                                   build_tree_list (NULL_TREE, arg1_tree),
5295                                   NULL_TREE, NULL, NULL, NULL_TREE,
5296                                   TRUE,
5297                                   ffebld_nonter_hook (expr));
5298         if (arg2_tree != NULL_TREE) {
5299           expr_tree = ffecom_modify (NULL_TREE, arg2_tree,
5300                                      convert (TREE_TYPE (arg2_tree),
5301                                               expr_tree));
5302         }
5303       }
5304       return expr_tree;
5305
5306     case FFEINTRIN_impCPU_TIME:
5307     case FFEINTRIN_impSECOND_subr:
5308       {
5309         tree arg1_tree;
5310
5311         arg1_tree = ffecom_expr_w (NULL_TREE, arg1);
5312
5313         expr_tree
5314           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5315                           ffecom_gfrt_kindtype (gfrt),
5316                           FALSE,
5317                           NULL_TREE,
5318                           NULL_TREE,
5319                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5320                           ffebld_nonter_hook (expr));
5321
5322         expr_tree
5323           = ffecom_modify (NULL_TREE, arg1_tree,
5324                            convert (TREE_TYPE (arg1_tree),
5325                                     expr_tree));
5326       }
5327       return expr_tree;
5328
5329     case FFEINTRIN_impDTIME_subr:
5330     case FFEINTRIN_impETIME_subr:
5331       {
5332         tree arg1_tree;
5333         tree result_tree;
5334
5335         result_tree = ffecom_expr_w (NULL_TREE, arg2);
5336
5337         arg1_tree = ffecom_ptr_to_expr (arg1);
5338
5339         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5340                                   ffecom_gfrt_kindtype (gfrt),
5341                                   FALSE,
5342                                   NULL_TREE,
5343                                   build_tree_list (NULL_TREE, arg1_tree),
5344                                   NULL_TREE, NULL, NULL, NULL_TREE,
5345                                   TRUE,
5346                                   ffebld_nonter_hook (expr));
5347         expr_tree = ffecom_modify (NULL_TREE, result_tree,
5348                                    convert (TREE_TYPE (result_tree),
5349                                             expr_tree));
5350       }
5351       return expr_tree;
5352
5353       /* Straightforward calls of libf2c routines: */
5354     case FFEINTRIN_impABORT:
5355     case FFEINTRIN_impACCESS:
5356     case FFEINTRIN_impBESJ0:
5357     case FFEINTRIN_impBESJ1:
5358     case FFEINTRIN_impBESJN:
5359     case FFEINTRIN_impBESY0:
5360     case FFEINTRIN_impBESY1:
5361     case FFEINTRIN_impBESYN:
5362     case FFEINTRIN_impCHDIR_func:
5363     case FFEINTRIN_impCHMOD_func:
5364     case FFEINTRIN_impDATE:
5365     case FFEINTRIN_impDATE_AND_TIME:
5366     case FFEINTRIN_impDBESJ0:
5367     case FFEINTRIN_impDBESJ1:
5368     case FFEINTRIN_impDBESJN:
5369     case FFEINTRIN_impDBESY0:
5370     case FFEINTRIN_impDBESY1:
5371     case FFEINTRIN_impDBESYN:
5372     case FFEINTRIN_impDTIME_func:
5373     case FFEINTRIN_impETIME_func:
5374     case FFEINTRIN_impFGETC_func:
5375     case FFEINTRIN_impFGET_func:
5376     case FFEINTRIN_impFNUM:
5377     case FFEINTRIN_impFPUTC_func:
5378     case FFEINTRIN_impFPUT_func:
5379     case FFEINTRIN_impFSEEK:
5380     case FFEINTRIN_impFSTAT_func:
5381     case FFEINTRIN_impFTELL_func:
5382     case FFEINTRIN_impGERROR:
5383     case FFEINTRIN_impGETARG:
5384     case FFEINTRIN_impGETCWD_func:
5385     case FFEINTRIN_impGETENV:
5386     case FFEINTRIN_impGETGID:
5387     case FFEINTRIN_impGETLOG:
5388     case FFEINTRIN_impGETPID:
5389     case FFEINTRIN_impGETUID:
5390     case FFEINTRIN_impGMTIME:
5391     case FFEINTRIN_impHOSTNM_func:
5392     case FFEINTRIN_impIDATE_unix:
5393     case FFEINTRIN_impIDATE_vxt:
5394     case FFEINTRIN_impIERRNO:
5395     case FFEINTRIN_impISATTY:
5396     case FFEINTRIN_impITIME:
5397     case FFEINTRIN_impKILL_func:
5398     case FFEINTRIN_impLINK_func:
5399     case FFEINTRIN_impLNBLNK:
5400     case FFEINTRIN_impLSTAT_func:
5401     case FFEINTRIN_impLTIME:
5402     case FFEINTRIN_impMCLOCK8:
5403     case FFEINTRIN_impMCLOCK:
5404     case FFEINTRIN_impPERROR:
5405     case FFEINTRIN_impRENAME_func:
5406     case FFEINTRIN_impSECNDS:
5407     case FFEINTRIN_impSECOND_func:
5408     case FFEINTRIN_impSLEEP:
5409     case FFEINTRIN_impSRAND:
5410     case FFEINTRIN_impSTAT_func:
5411     case FFEINTRIN_impSYMLNK_func:
5412     case FFEINTRIN_impSYSTEM_CLOCK:
5413     case FFEINTRIN_impSYSTEM_func:
5414     case FFEINTRIN_impTIME8:
5415     case FFEINTRIN_impTIME_unix:
5416     case FFEINTRIN_impTIME_vxt:
5417     case FFEINTRIN_impUMASK_func:
5418     case FFEINTRIN_impUNLINK_func:
5419       break;
5420
5421     case FFEINTRIN_impCTIME_func:       /* CHARACTER functions not handled here. */
5422     case FFEINTRIN_impFDATE_func:       /* CHARACTER functions not handled here. */
5423     case FFEINTRIN_impTTYNAM_func:      /* CHARACTER functions not handled here. */
5424     case FFEINTRIN_impNONE:
5425     case FFEINTRIN_imp:         /* Hush up gcc warning. */
5426       fprintf (stderr, "No %s implementation.\n",
5427                ffeintrin_name_implementation (ffebld_symter_implementation (ffebld_left (expr))));
5428       assert ("unimplemented intrinsic" == NULL);
5429       return error_mark_node;
5430     }
5431
5432   assert (gfrt != FFECOM_gfrt); /* Must have an implementation! */
5433
5434   expr_tree = ffecom_arglist_expr_ (ffecom_gfrt_args_ (gfrt),
5435                                     ffebld_right (expr));
5436
5437   return ffecom_call_ (ffecom_gfrt_tree_ (gfrt), ffecom_gfrt_kindtype (gfrt),
5438                        (ffe_is_f2c_library () && ffecom_gfrt_complex_[gfrt]),
5439                        tree_type,
5440                        expr_tree, dest_tree, dest, dest_used,
5441                        NULL_TREE, TRUE,
5442                        ffebld_nonter_hook (expr));
5443
5444   /* See bottom of this file for f2c transforms used to determine
5445      many of the above implementations.  The info seems to confuse
5446      Emacs's C mode indentation, which is why it's been moved to
5447      the bottom of this source file.  */
5448 }
5449
5450 #endif
5451 /* For power (exponentiation) where right-hand operand is type INTEGER,
5452    generate in-line code to do it the fast way (which, if the operand
5453    is a constant, might just mean a series of multiplies).  */
5454
5455 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5456 static tree
5457 ffecom_expr_power_integer_ (ffebld expr)
5458 {
5459   tree l = ffecom_expr (ffebld_left (expr));
5460   tree r = ffecom_expr (ffebld_right (expr));
5461   tree ltype = TREE_TYPE (l);
5462   tree rtype = TREE_TYPE (r);
5463   tree result = NULL_TREE;
5464
5465   if (l == error_mark_node
5466       || r == error_mark_node)
5467     return error_mark_node;
5468
5469   if (TREE_CODE (r) == INTEGER_CST)
5470     {
5471       int sgn = tree_int_cst_sgn (r);
5472
5473       if (sgn == 0)
5474         return convert (ltype, integer_one_node);
5475
5476       if ((TREE_CODE (ltype) == INTEGER_TYPE)
5477           && (sgn < 0))
5478         {
5479           /* Reciprocal of integer is either 0, -1, or 1, so after
5480              calculating that (which we leave to the back end to do
5481              or not do optimally), don't bother with any multiplying.  */
5482
5483           result = ffecom_tree_divide_ (ltype,
5484                                         convert (ltype, integer_one_node),
5485                                         l,
5486                                         NULL_TREE, NULL, NULL, NULL_TREE);
5487           r = ffecom_1 (NEGATE_EXPR,
5488                         rtype,
5489                         r);
5490           if ((TREE_INT_CST_LOW (r) & 1) == 0)
5491             result = ffecom_1 (ABS_EXPR, rtype,
5492                                result);
5493         }
5494
5495       /* Generate appropriate series of multiplies, preceded
5496          by divide if the exponent is negative.  */
5497
5498       l = save_expr (l);
5499
5500       if (sgn < 0)
5501         {
5502           l = ffecom_tree_divide_ (ltype,
5503                                    convert (ltype, integer_one_node),
5504                                    l,
5505                                    NULL_TREE, NULL, NULL,
5506                                    ffebld_nonter_hook (expr));
5507           r = ffecom_1 (NEGATE_EXPR, rtype, r);
5508           assert (TREE_CODE (r) == INTEGER_CST);
5509
5510           if (tree_int_cst_sgn (r) < 0)
5511             {                   /* The "most negative" number.  */
5512               r = ffecom_1 (NEGATE_EXPR, rtype,
5513                             ffecom_2 (RSHIFT_EXPR, rtype,
5514                                       r,
5515                                       integer_one_node));
5516               l = save_expr (l);
5517               l = ffecom_2 (MULT_EXPR, ltype,
5518                             l,
5519                             l);
5520             }
5521         }
5522
5523       for (;;)
5524         {
5525           if (TREE_INT_CST_LOW (r) & 1)
5526             {
5527               if (result == NULL_TREE)
5528                 result = l;
5529               else
5530                 result = ffecom_2 (MULT_EXPR, ltype,
5531                                    result,
5532                                    l);
5533             }
5534
5535           r = ffecom_2 (RSHIFT_EXPR, rtype,
5536                         r,
5537                         integer_one_node);
5538           if (integer_zerop (r))
5539             break;
5540           assert (TREE_CODE (r) == INTEGER_CST);
5541
5542           l = save_expr (l);
5543           l = ffecom_2 (MULT_EXPR, ltype,
5544                         l,
5545                         l);
5546         }
5547       return result;
5548     }
5549
5550   /* Though rhs isn't a constant, in-line code cannot be expanded
5551      while transforming dummies
5552      because the back end cannot be easily convinced to generate
5553      stores (MODIFY_EXPR), handle temporaries, and so on before
5554      all the appropriate rtx's have been generated for things like
5555      dummy args referenced in rhs -- which doesn't happen until
5556      store_parm_decls() is called (expand_function_start, I believe,
5557      does the actual rtx-stuffing of PARM_DECLs).
5558
5559      So, in this case, let the caller generate the call to the
5560      run-time-library function to evaluate the power for us.  */
5561
5562   if (ffecom_transform_only_dummies_)
5563     return NULL_TREE;
5564
5565   /* Right-hand operand not a constant, expand in-line code to figure
5566      out how to do the multiplies, &c.
5567
5568      The returned expression is expressed this way in GNU C, where l and
5569      r are the "inputs":
5570
5571      ({ typeof (r) rtmp = r;
5572         typeof (l) ltmp = l;
5573         typeof (l) result;
5574
5575         if (rtmp == 0)
5576           result = 1;
5577         else
5578           {
5579             if ((basetypeof (l) == basetypeof (int))
5580                 && (rtmp < 0))
5581               {
5582                 result = ((typeof (l)) 1) / ltmp;
5583                 if ((ltmp < 0) && (((-rtmp) & 1) == 0))
5584                   result = -result;
5585               }
5586             else
5587               {
5588                 result = 1;
5589                 if ((basetypeof (l) != basetypeof (int))
5590                     && (rtmp < 0))
5591                   {
5592                     ltmp = ((typeof (l)) 1) / ltmp;
5593                     rtmp = -rtmp;
5594                     if (rtmp < 0)
5595                       {
5596                         rtmp = -(rtmp >> 1);
5597                         ltmp *= ltmp;
5598                       }
5599                   }
5600                 for (;;)
5601                   {
5602                     if (rtmp & 1)
5603                       result *= ltmp;
5604                     if ((rtmp >>= 1) == 0)
5605                       break;
5606                     ltmp *= ltmp;
5607                   }
5608               }
5609           }
5610         result;
5611      })
5612
5613      Note that some of the above is compile-time collapsable, such as
5614      the first part of the if statements that checks the base type of
5615      l against int.  The if statements are phrased that way to suggest
5616      an easy way to generate the if/else constructs here, knowing that
5617      the back end should (and probably does) eliminate the resulting
5618      dead code (either the int case or the non-int case), something
5619      it couldn't do without the redundant phrasing, requiring explicit
5620      dead-code elimination here, which would be kind of difficult to
5621      read.  */
5622
5623   {
5624     tree rtmp;
5625     tree ltmp;
5626     tree divide;
5627     tree basetypeof_l_is_int;
5628     tree se;
5629     tree t;
5630
5631     basetypeof_l_is_int
5632       = build_int_2 ((TREE_CODE (ltype) == INTEGER_TYPE), 0);
5633
5634     se = expand_start_stmt_expr ();
5635
5636     ffecom_start_compstmt ();
5637
5638 #ifndef HAHA
5639     rtmp = ffecom_make_tempvar ("power_r", rtype,
5640                                 FFETARGET_charactersizeNONE, -1);
5641     ltmp = ffecom_make_tempvar ("power_l", ltype,
5642                                 FFETARGET_charactersizeNONE, -1);
5643     result = ffecom_make_tempvar ("power_res", ltype,
5644                                   FFETARGET_charactersizeNONE, -1);
5645     if (TREE_CODE (ltype) == COMPLEX_TYPE
5646         || TREE_CODE (ltype) == RECORD_TYPE)
5647       divide = ffecom_make_tempvar ("power_div", ltype,
5648                                     FFETARGET_charactersizeNONE, -1);
5649     else
5650       divide = NULL_TREE;
5651 #else  /* HAHA */
5652     {
5653       tree hook;
5654
5655       hook = ffebld_nonter_hook (expr);
5656       assert (hook);
5657       assert (TREE_CODE (hook) == TREE_VEC);
5658       assert (TREE_VEC_LENGTH (hook) == 4);
5659       rtmp = TREE_VEC_ELT (hook, 0);
5660       ltmp = TREE_VEC_ELT (hook, 1);
5661       result = TREE_VEC_ELT (hook, 2);
5662       divide = TREE_VEC_ELT (hook, 3);
5663       if (TREE_CODE (ltype) == COMPLEX_TYPE
5664           || TREE_CODE (ltype) == RECORD_TYPE)
5665         assert (divide);
5666       else
5667         assert (! divide);
5668     }
5669 #endif  /* HAHA */
5670
5671     expand_expr_stmt (ffecom_modify (void_type_node,
5672                                      rtmp,
5673                                      r));
5674     expand_expr_stmt (ffecom_modify (void_type_node,
5675                                      ltmp,
5676                                      l));
5677     expand_start_cond (ffecom_truth_value
5678                        (ffecom_2 (EQ_EXPR, integer_type_node,
5679                                   rtmp,
5680                                   convert (rtype, integer_zero_node))),
5681                        0);
5682     expand_expr_stmt (ffecom_modify (void_type_node,
5683                                      result,
5684                                      convert (ltype, integer_one_node)));
5685     expand_start_else ();
5686     if (! integer_zerop (basetypeof_l_is_int))
5687       {
5688         expand_start_cond (ffecom_2 (LT_EXPR, integer_type_node,
5689                                      rtmp,
5690                                      convert (rtype,
5691                                               integer_zero_node)),
5692                            0);
5693         expand_expr_stmt (ffecom_modify (void_type_node,
5694                                          result,
5695                                          ffecom_tree_divide_
5696                                          (ltype,
5697                                           convert (ltype, integer_one_node),
5698                                           ltmp,
5699                                           NULL_TREE, NULL, NULL,
5700                                           divide)));
5701         expand_start_cond (ffecom_truth_value
5702                            (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5703                                       ffecom_2 (LT_EXPR, integer_type_node,
5704                                                 ltmp,
5705                                                 convert (ltype,
5706                                                          integer_zero_node)),
5707                                       ffecom_2 (EQ_EXPR, integer_type_node,
5708                                                 ffecom_2 (BIT_AND_EXPR,
5709                                                           rtype,
5710                                                           ffecom_1 (NEGATE_EXPR,
5711                                                                     rtype,
5712                                                                     rtmp),
5713                                                           convert (rtype,
5714                                                                    integer_one_node)),
5715                                                 convert (rtype,
5716                                                          integer_zero_node)))),
5717                            0);
5718         expand_expr_stmt (ffecom_modify (void_type_node,
5719                                          result,
5720                                          ffecom_1 (NEGATE_EXPR,
5721                                                    ltype,
5722                                                    result)));
5723         expand_end_cond ();
5724         expand_start_else ();
5725       }
5726     expand_expr_stmt (ffecom_modify (void_type_node,
5727                                      result,
5728                                      convert (ltype, integer_one_node)));
5729     expand_start_cond (ffecom_truth_value
5730                        (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5731                                   ffecom_truth_value_invert
5732                                   (basetypeof_l_is_int),
5733                                   ffecom_2 (LT_EXPR, integer_type_node,
5734                                             rtmp,
5735                                             convert (rtype,
5736                                                      integer_zero_node)))),
5737                        0);
5738     expand_expr_stmt (ffecom_modify (void_type_node,
5739                                      ltmp,
5740                                      ffecom_tree_divide_
5741                                      (ltype,
5742                                       convert (ltype, integer_one_node),
5743                                       ltmp,
5744                                       NULL_TREE, NULL, NULL,
5745                                       divide)));
5746     expand_expr_stmt (ffecom_modify (void_type_node,
5747                                      rtmp,
5748                                      ffecom_1 (NEGATE_EXPR, rtype,
5749                                                rtmp)));
5750     expand_start_cond (ffecom_truth_value
5751                        (ffecom_2 (LT_EXPR, integer_type_node,
5752                                   rtmp,
5753                                   convert (rtype, integer_zero_node))),
5754                        0);
5755     expand_expr_stmt (ffecom_modify (void_type_node,
5756                                      rtmp,
5757                                      ffecom_1 (NEGATE_EXPR, rtype,
5758                                                ffecom_2 (RSHIFT_EXPR,
5759                                                          rtype,
5760                                                          rtmp,
5761                                                          integer_one_node))));
5762     expand_expr_stmt (ffecom_modify (void_type_node,
5763                                      ltmp,
5764                                      ffecom_2 (MULT_EXPR, ltype,
5765                                                ltmp,
5766                                                ltmp)));
5767     expand_end_cond ();
5768     expand_end_cond ();
5769     expand_start_loop (1);
5770     expand_start_cond (ffecom_truth_value
5771                        (ffecom_2 (BIT_AND_EXPR, rtype,
5772                                   rtmp,
5773                                   convert (rtype, integer_one_node))),
5774                        0);
5775     expand_expr_stmt (ffecom_modify (void_type_node,
5776                                      result,
5777                                      ffecom_2 (MULT_EXPR, ltype,
5778                                                result,
5779                                                ltmp)));
5780     expand_end_cond ();
5781     expand_exit_loop_if_false (NULL,
5782                                ffecom_truth_value
5783                                (ffecom_modify (rtype,
5784                                                rtmp,
5785                                                ffecom_2 (RSHIFT_EXPR,
5786                                                          rtype,
5787                                                          rtmp,
5788                                                          integer_one_node))));
5789     expand_expr_stmt (ffecom_modify (void_type_node,
5790                                      ltmp,
5791                                      ffecom_2 (MULT_EXPR, ltype,
5792                                                ltmp,
5793                                                ltmp)));
5794     expand_end_loop ();
5795     expand_end_cond ();
5796     if (!integer_zerop (basetypeof_l_is_int))
5797       expand_end_cond ();
5798     expand_expr_stmt (result);
5799
5800     t = ffecom_end_compstmt ();
5801
5802     result = expand_end_stmt_expr (se);
5803
5804     /* This code comes from c-parse.in, after its expand_end_stmt_expr.  */
5805
5806     if (TREE_CODE (t) == BLOCK)
5807       {
5808         /* Make a BIND_EXPR for the BLOCK already made.  */
5809         result = build (BIND_EXPR, TREE_TYPE (result),
5810                         NULL_TREE, result, t);
5811         /* Remove the block from the tree at this point.
5812            It gets put back at the proper place
5813            when the BIND_EXPR is expanded.  */
5814         delete_block (t);
5815       }
5816     else
5817       result = t;
5818   }
5819
5820   return result;
5821 }
5822
5823 #endif
5824 /* ffecom_expr_transform_ -- Transform symbols in expr
5825
5826    ffebld expr;  // FFE expression.
5827    ffecom_expr_transform_ (expr);
5828
5829    Recursive descent on expr while transforming any untransformed SYMTERs.  */
5830
5831 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5832 static void
5833 ffecom_expr_transform_ (ffebld expr)
5834 {
5835   tree t;
5836   ffesymbol s;
5837
5838 tail_recurse:                   /* :::::::::::::::::::: */
5839
5840   if (expr == NULL)
5841     return;
5842
5843   switch (ffebld_op (expr))
5844     {
5845     case FFEBLD_opSYMTER:
5846       s = ffebld_symter (expr);
5847       t = ffesymbol_hook (s).decl_tree;
5848       if ((t == NULL_TREE)
5849           && ((ffesymbol_kind (s) != FFEINFO_kindNONE)
5850               || ((ffesymbol_where (s) != FFEINFO_whereNONE)
5851                   && (ffesymbol_where (s) != FFEINFO_whereINTRINSIC))))
5852         {
5853           s = ffecom_sym_transform_ (s);
5854           t = ffesymbol_hook (s).decl_tree;     /* Sfunc expr non-dummy,
5855                                                    DIMENSION expr? */
5856         }
5857       break;                    /* Ok if (t == NULL) here. */
5858
5859     case FFEBLD_opITEM:
5860       ffecom_expr_transform_ (ffebld_head (expr));
5861       expr = ffebld_trail (expr);
5862       goto tail_recurse;        /* :::::::::::::::::::: */
5863
5864     default:
5865       break;
5866     }
5867
5868   switch (ffebld_arity (expr))
5869     {
5870     case 2:
5871       ffecom_expr_transform_ (ffebld_left (expr));
5872       expr = ffebld_right (expr);
5873       goto tail_recurse;        /* :::::::::::::::::::: */
5874
5875     case 1:
5876       expr = ffebld_left (expr);
5877       goto tail_recurse;        /* :::::::::::::::::::: */
5878
5879     default:
5880       break;
5881     }
5882
5883   return;
5884 }
5885
5886 #endif
5887 /* Make a type based on info in live f2c.h file.  */
5888
5889 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5890 static void
5891 ffecom_f2c_make_type_ (tree *type, int tcode, const char *name)
5892 {
5893   switch (tcode)
5894     {
5895     case FFECOM_f2ccodeCHAR:
5896       *type = make_signed_type (CHAR_TYPE_SIZE);
5897       break;
5898
5899     case FFECOM_f2ccodeSHORT:
5900       *type = make_signed_type (SHORT_TYPE_SIZE);
5901       break;
5902
5903     case FFECOM_f2ccodeINT:
5904       *type = make_signed_type (INT_TYPE_SIZE);
5905       break;
5906
5907     case FFECOM_f2ccodeLONG:
5908       *type = make_signed_type (LONG_TYPE_SIZE);
5909       break;
5910
5911     case FFECOM_f2ccodeLONGLONG:
5912       *type = make_signed_type (LONG_LONG_TYPE_SIZE);
5913       break;
5914
5915     case FFECOM_f2ccodeCHARPTR:
5916       *type = build_pointer_type (DEFAULT_SIGNED_CHAR
5917                                   ? signed_char_type_node
5918                                   : unsigned_char_type_node);
5919       break;
5920
5921     case FFECOM_f2ccodeFLOAT:
5922       *type = make_node (REAL_TYPE);
5923       TYPE_PRECISION (*type) = FLOAT_TYPE_SIZE;
5924       layout_type (*type);
5925       break;
5926
5927     case FFECOM_f2ccodeDOUBLE:
5928       *type = make_node (REAL_TYPE);
5929       TYPE_PRECISION (*type) = DOUBLE_TYPE_SIZE;
5930       layout_type (*type);
5931       break;
5932
5933     case FFECOM_f2ccodeLONGDOUBLE:
5934       *type = make_node (REAL_TYPE);
5935       TYPE_PRECISION (*type) = LONG_DOUBLE_TYPE_SIZE;
5936       layout_type (*type);
5937       break;
5938
5939     case FFECOM_f2ccodeTWOREALS:
5940       *type = ffecom_make_complex_type_ (ffecom_f2c_real_type_node);
5941       break;
5942
5943     case FFECOM_f2ccodeTWODOUBLEREALS:
5944       *type = ffecom_make_complex_type_ (ffecom_f2c_doublereal_type_node);
5945       break;
5946
5947     default:
5948       assert ("unexpected FFECOM_f2ccodeXYZZY!" == NULL);
5949       *type = error_mark_node;
5950       return;
5951     }
5952
5953   pushdecl (build_decl (TYPE_DECL,
5954                         ffecom_get_invented_identifier ("__g77_f2c_%s", name),
5955                         *type));
5956 }
5957
5958 #endif
5959 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5960 /* Set the f2c list-directed-I/O code for whatever (integral) type has the
5961    given size.  */
5962
5963 static void
5964 ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
5965                           int code)
5966 {
5967   int j;
5968   tree t;
5969
5970   for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
5971     if ((t = ffecom_tree_type[bt][j]) != NULL_TREE
5972         && compare_tree_int (TYPE_SIZE (t), size) == 0)
5973       {
5974         assert (code != -1);
5975         ffecom_f2c_typecode_[bt][j] = code;
5976         code = -1;
5977       }
5978 }
5979
5980 #endif
5981 /* Finish up globals after doing all program units in file
5982
5983    Need to handle only uninitialized COMMON areas.  */
5984
5985 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5986 static ffeglobal
5987 ffecom_finish_global_ (ffeglobal global)
5988 {
5989   tree cbtype;
5990   tree cbt;
5991   tree size;
5992
5993   if (ffeglobal_type (global) != FFEGLOBAL_typeCOMMON)
5994       return global;
5995
5996   if (ffeglobal_common_init (global))
5997       return global;
5998
5999   cbt = ffeglobal_hook (global);
6000   if ((cbt == NULL_TREE)
6001       || !ffeglobal_common_have_size (global))
6002     return global;              /* No need to make common, never ref'd. */
6003
6004   DECL_EXTERNAL (cbt) = 0;
6005
6006   /* Give the array a size now.  */
6007
6008   size = build_int_2 ((ffeglobal_common_size (global)
6009                       + ffeglobal_common_pad (global)) - 1,
6010                       0);
6011
6012   cbtype = TREE_TYPE (cbt);
6013   TYPE_DOMAIN (cbtype) = build_range_type (integer_type_node,
6014                                            integer_zero_node,
6015                                            size);
6016   if (!TREE_TYPE (size))
6017     TREE_TYPE (size) = TYPE_DOMAIN (cbtype);
6018   layout_type (cbtype);
6019
6020   cbt = start_decl (cbt, FALSE);
6021   assert (cbt == ffeglobal_hook (global));
6022
6023   finish_decl (cbt, NULL_TREE, FALSE);
6024
6025   return global;
6026 }
6027
6028 #endif
6029 /* Finish up any untransformed symbols.  */
6030
6031 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6032 static ffesymbol
6033 ffecom_finish_symbol_transform_ (ffesymbol s)
6034 {
6035   if ((s == NULL) || (TREE_CODE (current_function_decl) == ERROR_MARK))
6036     return s;
6037
6038   /* It's easy to know to transform an untransformed symbol, to make sure
6039      we put out debugging info for it.  But COMMON variables, unlike
6040      EQUIVALENCE ones, aren't given declarations in addition to the
6041      tree expressions that specify offsets, because COMMON variables
6042      can be referenced in the outer scope where only dummy arguments
6043      (PARM_DECLs) should really be seen.  To be safe, just don't do any
6044      VAR_DECLs for COMMON variables when we transform them for real
6045      use, and therefore we do all the VAR_DECL creating here.  */
6046
6047   if (ffesymbol_hook (s).decl_tree == NULL_TREE)
6048     {
6049       if (ffesymbol_kind (s) != FFEINFO_kindNONE
6050           || (ffesymbol_where (s) != FFEINFO_whereNONE
6051               && ffesymbol_where (s) != FFEINFO_whereINTRINSIC
6052               && ffesymbol_where (s) != FFEINFO_whereDUMMY))
6053         /* Not transformed, and not CHARACTER*(*), and not a dummy
6054            argument, which can happen only if the entry point names
6055            it "rides in on" are all invalidated for other reasons.  */
6056         s = ffecom_sym_transform_ (s);
6057     }
6058
6059   if ((ffesymbol_where (s) == FFEINFO_whereCOMMON)
6060       && (ffesymbol_hook (s).decl_tree != error_mark_node))
6061     {
6062       /* This isn't working, at least for dbxout.  The .s file looks
6063          okay to me (burley), but in gdb 4.9 at least, the variables
6064          appear to reside somewhere outside of the common area, so
6065          it doesn't make sense to mislead anyone by generating the info
6066          on those variables until this is fixed.  NOTE: Same problem
6067          with EQUIVALENCE, sadly...see similar #if later.  */
6068       ffecom_member_phase2_ (ffesymbol_storage (ffesymbol_common (s)),
6069                              ffesymbol_storage (s));
6070     }
6071
6072   return s;
6073 }
6074
6075 #endif
6076 /* Append underscore(s) to name before calling get_identifier.  "us"
6077    is nonzero if the name already contains an underscore and thus
6078    needs two underscores appended.  */
6079
6080 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6081 static tree
6082 ffecom_get_appended_identifier_ (char us, const char *name)
6083 {
6084   int i;
6085   char *newname;
6086   tree id;
6087
6088   newname = xmalloc ((i = strlen (name)) + 1
6089                      + ffe_is_underscoring ()
6090                      + us);
6091   memcpy (newname, name, i);
6092   newname[i] = '_';
6093   newname[i + us] = '_';
6094   newname[i + 1 + us] = '\0';
6095   id = get_identifier (newname);
6096
6097   free (newname);
6098
6099   return id;
6100 }
6101
6102 #endif
6103 /* Decide whether to append underscore to name before calling
6104    get_identifier.  */
6105
6106 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6107 static tree
6108 ffecom_get_external_identifier_ (ffesymbol s)
6109 {
6110   char us;
6111   const char *name = ffesymbol_text (s);
6112
6113   /* If name is a built-in name, just return it as is.  */
6114
6115   if (!ffe_is_underscoring ()
6116       || (strcmp (name, FFETARGET_nameBLANK_COMMON) == 0)
6117 #if FFETARGET_isENFORCED_MAIN_NAME
6118       || (strcmp (name, FFETARGET_nameENFORCED_NAME) == 0)
6119 #else
6120       || (strcmp (name, FFETARGET_nameUNNAMED_MAIN) == 0)
6121 #endif
6122       || (strcmp (name, FFETARGET_nameUNNAMED_BLOCK_DATA) == 0))
6123     return get_identifier (name);
6124
6125   us = ffe_is_second_underscore ()
6126     ? (strchr (name, '_') != NULL)
6127       : 0;
6128
6129   return ffecom_get_appended_identifier_ (us, name);
6130 }
6131
6132 #endif
6133 /* Decide whether to append underscore to internal name before calling
6134    get_identifier.
6135
6136    This is for non-external, top-function-context names only.  Transform
6137    identifier so it doesn't conflict with the transformed result
6138    of using a _different_ external name.  E.g. if "CALL FOO" is
6139    transformed into "FOO_();", then the variable in "FOO_ = 3"
6140    must be transformed into something that does not conflict, since
6141    these two things should be independent.
6142
6143    The transformation is as follows.  If the name does not contain
6144    an underscore, there is no possible conflict, so just return.
6145    If the name does contain an underscore, then transform it just
6146    like we transform an external identifier.  */
6147
6148 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6149 static tree
6150 ffecom_get_identifier_ (const char *name)
6151 {
6152   /* If name does not contain an underscore, just return it as is.  */
6153
6154   if (!ffe_is_underscoring ()
6155       || (strchr (name, '_') == NULL))
6156     return get_identifier (name);
6157
6158   return ffecom_get_appended_identifier_ (ffe_is_second_underscore (),
6159                                           name);
6160 }
6161
6162 #endif
6163 /* ffecom_gen_sfuncdef_ -- Generate definition of statement function
6164
6165    tree t;
6166    ffesymbol s;  // kindFUNCTION, whereIMMEDIATE.
6167    t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s),
6168          ffesymbol_kindtype(s));
6169
6170    Call after setting up containing function and getting trees for all
6171    other symbols.  */
6172
6173 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6174 static tree
6175 ffecom_gen_sfuncdef_ (ffesymbol s, ffeinfoBasictype bt, ffeinfoKindtype kt)
6176 {
6177   ffebld expr = ffesymbol_sfexpr (s);
6178   tree type;
6179   tree func;
6180   tree result;
6181   bool charfunc = (bt == FFEINFO_basictypeCHARACTER);
6182   static bool recurse = FALSE;
6183   int old_lineno = lineno;
6184   const char *old_input_filename = input_filename;
6185
6186   ffecom_nested_entry_ = s;
6187
6188   /* For now, we don't have a handy pointer to where the sfunc is actually
6189      defined, though that should be easy to add to an ffesymbol. (The
6190      token/where info available might well point to the place where the type
6191      of the sfunc is declared, especially if that precedes the place where
6192      the sfunc itself is defined, which is typically the case.)  We should
6193      put out a null pointer rather than point somewhere wrong, but I want to
6194      see how it works at this point.  */
6195
6196   input_filename = ffesymbol_where_filename (s);
6197   lineno = ffesymbol_where_filelinenum (s);
6198
6199   /* Pretransform the expression so any newly discovered things belong to the
6200      outer program unit, not to the statement function. */
6201
6202   ffecom_expr_transform_ (expr);
6203
6204   /* Make sure no recursive invocation of this fn (a specific case of failing
6205      to pretransform an sfunc's expression, i.e. where its expression
6206      references another untransformed sfunc) happens. */
6207
6208   assert (!recurse);
6209   recurse = TRUE;
6210
6211   push_f_function_context ();
6212
6213   if (charfunc)
6214     type = void_type_node;
6215   else
6216     {
6217       type = ffecom_tree_type[bt][kt];
6218       if (type == NULL_TREE)
6219         type = integer_type_node;       /* _sym_exec_transition reports
6220                                            error. */
6221     }
6222
6223   start_function (ffecom_get_identifier_ (ffesymbol_text (s)),
6224                   build_function_type (type, NULL_TREE),
6225                   1,            /* nested/inline */
6226                   0);           /* TREE_PUBLIC */
6227
6228   /* We don't worry about COMPLEX return values here, because this is
6229      entirely internal to our code, and gcc has the ability to return COMPLEX
6230      directly as a value.  */
6231
6232   if (charfunc)
6233     {                           /* Prepend arg for where result goes. */
6234       tree type;
6235
6236       type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
6237
6238       result = ffecom_get_invented_identifier ("__g77_%s", "result");
6239
6240       ffecom_char_enhance_arg_ (&type, s);      /* Ignore returned length. */
6241
6242       type = build_pointer_type (type);
6243       result = build_decl (PARM_DECL, result, type);
6244
6245       push_parm_decl (result);
6246     }
6247   else
6248     result = NULL_TREE;         /* Not ref'd if !charfunc. */
6249
6250   ffecom_push_dummy_decls_ (ffesymbol_dummyargs (s), TRUE);
6251
6252   store_parm_decls (0);
6253
6254   ffecom_start_compstmt ();
6255
6256   if (expr != NULL)
6257     {
6258       if (charfunc)
6259         {
6260           ffetargetCharacterSize sz = ffesymbol_size (s);
6261           tree result_length;
6262
6263           result_length = build_int_2 (sz, 0);
6264           TREE_TYPE (result_length) = ffecom_f2c_ftnlen_type_node;
6265
6266           ffecom_prepare_let_char_ (sz, expr);
6267
6268           ffecom_prepare_end ();
6269
6270           ffecom_let_char_ (result, result_length, sz, expr);
6271           expand_null_return ();
6272         }
6273       else
6274         {
6275           ffecom_prepare_expr (expr);
6276
6277           ffecom_prepare_end ();
6278
6279           expand_return (ffecom_modify (NULL_TREE,
6280                                         DECL_RESULT (current_function_decl),
6281                                         ffecom_expr (expr)));
6282         }
6283     }
6284
6285   ffecom_end_compstmt ();
6286
6287   func = current_function_decl;
6288   finish_function (1);
6289
6290   pop_f_function_context ();
6291
6292   recurse = FALSE;
6293
6294   lineno = old_lineno;
6295   input_filename = old_input_filename;
6296
6297   ffecom_nested_entry_ = NULL;
6298
6299   return func;
6300 }
6301
6302 #endif
6303
6304 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6305 static const char *
6306 ffecom_gfrt_args_ (ffecomGfrt ix)
6307 {
6308   return ffecom_gfrt_argstring_[ix];
6309 }
6310
6311 #endif
6312 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6313 static tree
6314 ffecom_gfrt_tree_ (ffecomGfrt ix)
6315 {
6316   if (ffecom_gfrt_[ix] == NULL_TREE)
6317     ffecom_make_gfrt_ (ix);
6318
6319   return ffecom_1 (ADDR_EXPR,
6320                    build_pointer_type (TREE_TYPE (ffecom_gfrt_[ix])),
6321                    ffecom_gfrt_[ix]);
6322 }
6323
6324 #endif
6325 /* Return initialize-to-zero expression for this VAR_DECL.  */
6326
6327 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6328 /* A somewhat evil way to prevent the garbage collector
6329    from collecting 'tree' structures.  */
6330 #define NUM_TRACKED_CHUNK 63
6331 static struct tree_ggc_tracker
6332 {
6333   struct tree_ggc_tracker *next;
6334   tree trees[NUM_TRACKED_CHUNK];
6335 } *tracker_head = NULL;
6336
6337 static void
6338 mark_tracker_head (void *arg)
6339 {
6340   struct tree_ggc_tracker *head;
6341   int i;
6342
6343   for (head = * (struct tree_ggc_tracker **) arg;
6344        head != NULL;
6345        head = head->next)
6346   {
6347     ggc_mark (head);
6348     for (i = 0; i < NUM_TRACKED_CHUNK; i++)
6349       ggc_mark_tree (head->trees[i]);
6350   }
6351 }
6352
6353 void
6354 ffecom_save_tree_forever (tree t)
6355 {
6356   int i;
6357   if (tracker_head != NULL)
6358     for (i = 0; i < NUM_TRACKED_CHUNK; i++)
6359       if (tracker_head->trees[i] == NULL)
6360         {
6361           tracker_head->trees[i] = t;
6362           return;
6363         }
6364
6365   {
6366     /* Need to allocate a new block.  */
6367     struct tree_ggc_tracker *old_head = tracker_head;
6368
6369     tracker_head = ggc_alloc (sizeof (*tracker_head));
6370     tracker_head->next = old_head;
6371     tracker_head->trees[0] = t;
6372     for (i = 1; i < NUM_TRACKED_CHUNK; i++)
6373       tracker_head->trees[i] = NULL;
6374   }
6375 }
6376
6377 static tree
6378 ffecom_init_zero_ (tree decl)
6379 {
6380   tree init;
6381   int incremental = TREE_STATIC (decl);
6382   tree type = TREE_TYPE (decl);
6383
6384   if (incremental)
6385     {
6386       make_decl_rtl (decl, NULL);
6387       assemble_variable (decl, TREE_PUBLIC (decl) ? 1 : 0, 0, 1);
6388     }
6389
6390   if ((TREE_CODE (type) != ARRAY_TYPE)
6391       && (TREE_CODE (type) != RECORD_TYPE)
6392       && (TREE_CODE (type) != UNION_TYPE)
6393       && !incremental)
6394     init = convert (type, integer_zero_node);
6395   else if (!incremental)
6396     {
6397       init = build (CONSTRUCTOR, type, NULL_TREE, NULL_TREE);
6398       TREE_CONSTANT (init) = 1;
6399       TREE_STATIC (init) = 1;
6400     }
6401   else
6402     {
6403       assemble_zeros (int_size_in_bytes (type));
6404       init = error_mark_node;
6405     }
6406
6407   return init;
6408 }
6409
6410 #endif
6411 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6412 static tree
6413 ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
6414                          tree *maybe_tree)
6415 {
6416   tree expr_tree;
6417   tree length_tree;
6418
6419   switch (ffebld_op (arg))
6420     {
6421     case FFEBLD_opCONTER:       /* For F90, check 0-length. */
6422       if (ffetarget_length_character1
6423           (ffebld_constant_character1
6424            (ffebld_conter (arg))) == 0)
6425         {
6426           *maybe_tree = integer_zero_node;
6427           return convert (tree_type, integer_zero_node);
6428         }
6429
6430       *maybe_tree = integer_one_node;
6431       expr_tree = build_int_2 (*ffetarget_text_character1
6432                                (ffebld_constant_character1
6433                                 (ffebld_conter (arg))),
6434                                0);
6435       TREE_TYPE (expr_tree) = tree_type;
6436       return expr_tree;
6437
6438     case FFEBLD_opSYMTER:
6439     case FFEBLD_opARRAYREF:
6440     case FFEBLD_opFUNCREF:
6441     case FFEBLD_opSUBSTR:
6442       ffecom_char_args_ (&expr_tree, &length_tree, arg);
6443
6444       if ((expr_tree == error_mark_node)
6445           || (length_tree == error_mark_node))
6446         {
6447           *maybe_tree = error_mark_node;
6448           return error_mark_node;
6449         }
6450
6451       if (integer_zerop (length_tree))
6452         {
6453           *maybe_tree = integer_zero_node;
6454           return convert (tree_type, integer_zero_node);
6455         }
6456
6457       expr_tree
6458         = ffecom_1 (INDIRECT_REF,
6459                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6460                     expr_tree);
6461       expr_tree
6462         = ffecom_2 (ARRAY_REF,
6463                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6464                     expr_tree,
6465                     integer_one_node);
6466       expr_tree = convert (tree_type, expr_tree);
6467
6468       if (TREE_CODE (length_tree) == INTEGER_CST)
6469         *maybe_tree = integer_one_node;
6470       else                      /* Must check length at run time.  */
6471         *maybe_tree
6472           = ffecom_truth_value
6473             (ffecom_2 (GT_EXPR, integer_type_node,
6474                        length_tree,
6475                        ffecom_f2c_ftnlen_zero_node));
6476       return expr_tree;
6477
6478     case FFEBLD_opPAREN:
6479     case FFEBLD_opCONVERT:
6480       if (ffeinfo_size (ffebld_info (arg)) == 0)
6481         {
6482           *maybe_tree = integer_zero_node;
6483           return convert (tree_type, integer_zero_node);
6484         }
6485       return ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6486                                       maybe_tree);
6487
6488     case FFEBLD_opCONCATENATE:
6489       {
6490         tree maybe_left;
6491         tree maybe_right;
6492         tree expr_left;
6493         tree expr_right;
6494
6495         expr_left = ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6496                                              &maybe_left);
6497         expr_right = ffecom_intrinsic_ichar_ (tree_type, ffebld_right (arg),
6498                                               &maybe_right);
6499         *maybe_tree = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
6500                                 maybe_left,
6501                                 maybe_right);
6502         expr_tree = ffecom_3 (COND_EXPR, tree_type,
6503                               maybe_left,
6504                               expr_left,
6505                               expr_right);
6506         return expr_tree;
6507       }
6508
6509     default:
6510       assert ("bad op in ICHAR" == NULL);
6511       return error_mark_node;
6512     }
6513 }
6514
6515 #endif
6516 /* ffecom_intrinsic_len_ -- Return length info for char arg (LEN())
6517
6518    tree length_arg;
6519    ffebld expr;
6520    length_arg = ffecom_intrinsic_len_ (expr);
6521
6522    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
6523    subexpressions by constructing the appropriate tree for the
6524    length-of-character-text argument in a calling sequence.  */
6525
6526 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6527 static tree
6528 ffecom_intrinsic_len_ (ffebld expr)
6529 {
6530   ffetargetCharacter1 val;
6531   tree length;
6532
6533   switch (ffebld_op (expr))
6534     {
6535     case FFEBLD_opCONTER:
6536       val = ffebld_constant_character1 (ffebld_conter (expr));
6537       length = build_int_2 (ffetarget_length_character1 (val), 0);
6538       TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6539       break;
6540
6541     case FFEBLD_opSYMTER:
6542       {
6543         ffesymbol s = ffebld_symter (expr);
6544         tree item;
6545
6546         item = ffesymbol_hook (s).decl_tree;
6547         if (item == NULL_TREE)
6548           {
6549             s = ffecom_sym_transform_ (s);
6550             item = ffesymbol_hook (s).decl_tree;
6551           }
6552         if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
6553           {
6554             if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
6555               length = ffesymbol_hook (s).length_tree;
6556             else
6557               {
6558                 length = build_int_2 (ffesymbol_size (s), 0);
6559                 TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6560               }
6561           }
6562         else if (item == error_mark_node)
6563           length = error_mark_node;
6564         else                    /* FFEINFO_kindFUNCTION: */
6565           length = NULL_TREE;
6566       }
6567       break;
6568
6569     case FFEBLD_opARRAYREF:
6570       length = ffecom_intrinsic_len_ (ffebld_left (expr));
6571       break;
6572
6573     case FFEBLD_opSUBSTR:
6574       {
6575         ffebld start;
6576         ffebld end;
6577         ffebld thing = ffebld_right (expr);
6578         tree start_tree;
6579         tree end_tree;
6580
6581         assert (ffebld_op (thing) == FFEBLD_opITEM);
6582         start = ffebld_head (thing);
6583         thing = ffebld_trail (thing);
6584         assert (ffebld_trail (thing) == NULL);
6585         end = ffebld_head (thing);
6586
6587         length = ffecom_intrinsic_len_ (ffebld_left (expr));
6588
6589         if (length == error_mark_node)
6590           break;
6591
6592         if (start == NULL)
6593           {
6594             if (end == NULL)
6595               ;
6596             else
6597               {
6598                 length = convert (ffecom_f2c_ftnlen_type_node,
6599                                   ffecom_expr (end));
6600               }
6601           }
6602         else
6603           {
6604             start_tree = convert (ffecom_f2c_ftnlen_type_node,
6605                                   ffecom_expr (start));
6606
6607             if (start_tree == error_mark_node)
6608               {
6609                 length = error_mark_node;
6610                 break;
6611               }
6612
6613             if (end == NULL)
6614               {
6615                 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6616                                    ffecom_f2c_ftnlen_one_node,
6617                                    ffecom_2 (MINUS_EXPR,
6618                                              ffecom_f2c_ftnlen_type_node,
6619                                              length,
6620                                              start_tree));
6621               }
6622             else
6623               {
6624                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
6625                                     ffecom_expr (end));
6626
6627                 if (end_tree == error_mark_node)
6628                   {
6629                     length = error_mark_node;
6630                     break;
6631                   }
6632
6633                 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6634                                    ffecom_f2c_ftnlen_one_node,
6635                                    ffecom_2 (MINUS_EXPR,
6636                                              ffecom_f2c_ftnlen_type_node,
6637                                              end_tree, start_tree));
6638               }
6639           }
6640       }
6641       break;
6642
6643     case FFEBLD_opCONCATENATE:
6644       length
6645         = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6646                     ffecom_intrinsic_len_ (ffebld_left (expr)),
6647                     ffecom_intrinsic_len_ (ffebld_right (expr)));
6648       break;
6649
6650     case FFEBLD_opFUNCREF:
6651     case FFEBLD_opCONVERT:
6652       length = build_int_2 (ffebld_size (expr), 0);
6653       TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6654       break;
6655
6656     default:
6657       assert ("bad op for single char arg expr" == NULL);
6658       length = ffecom_f2c_ftnlen_zero_node;
6659       break;
6660     }
6661
6662   assert (length != NULL_TREE);
6663
6664   return length;
6665 }
6666
6667 #endif
6668 /* Handle CHARACTER assignments.
6669
6670    Generates code to do the assignment.  Used by ordinary assignment
6671    statement handler ffecom_let_stmt and by statement-function
6672    handler to generate code for a statement function.  */
6673
6674 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6675 static void
6676 ffecom_let_char_ (tree dest_tree, tree dest_length,
6677                   ffetargetCharacterSize dest_size, ffebld source)
6678 {
6679   ffecomConcatList_ catlist;
6680   tree source_length;
6681   tree source_tree;
6682   tree expr_tree;
6683
6684   if ((dest_tree == error_mark_node)
6685       || (dest_length == error_mark_node))
6686     return;
6687
6688   assert (dest_tree != NULL_TREE);
6689   assert (dest_length != NULL_TREE);
6690
6691   /* Source might be an opCONVERT, which just means it is a different size
6692      than the destination.  Since the underlying implementation here handles
6693      that (directly or via the s_copy or s_cat run-time-library functions),
6694      we don't need the "convenience" of an opCONVERT that tells us to
6695      truncate or blank-pad, particularly since the resulting implementation
6696      would probably be slower than otherwise. */
6697
6698   while (ffebld_op (source) == FFEBLD_opCONVERT)
6699     source = ffebld_left (source);
6700
6701   catlist = ffecom_concat_list_new_ (source, dest_size);
6702   switch (ffecom_concat_list_count_ (catlist))
6703     {
6704     case 0:                     /* Shouldn't happen, but in case it does... */
6705       ffecom_concat_list_kill_ (catlist);
6706       source_tree = null_pointer_node;
6707       source_length = ffecom_f2c_ftnlen_zero_node;
6708       expr_tree = build_tree_list (NULL_TREE, dest_tree);
6709       TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6710       TREE_CHAIN (TREE_CHAIN (expr_tree))
6711         = build_tree_list (NULL_TREE, dest_length);
6712       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6713         = build_tree_list (NULL_TREE, source_length);
6714
6715       expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6716       TREE_SIDE_EFFECTS (expr_tree) = 1;
6717
6718       expand_expr_stmt (expr_tree);
6719
6720       return;
6721
6722     case 1:                     /* The (fairly) easy case. */
6723       ffecom_char_args_ (&source_tree, &source_length,
6724                          ffecom_concat_list_expr_ (catlist, 0));
6725       ffecom_concat_list_kill_ (catlist);
6726       assert (source_tree != NULL_TREE);
6727       assert (source_length != NULL_TREE);
6728
6729       if ((source_tree == error_mark_node)
6730           || (source_length == error_mark_node))
6731         return;
6732
6733       if (dest_size == 1)
6734         {
6735           dest_tree
6736             = ffecom_1 (INDIRECT_REF,
6737                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6738                                                       (dest_tree))),
6739                         dest_tree);
6740           dest_tree
6741             = ffecom_2 (ARRAY_REF,
6742                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6743                                                       (dest_tree))),
6744                         dest_tree,
6745                         integer_one_node);
6746           source_tree
6747             = ffecom_1 (INDIRECT_REF,
6748                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6749                                                       (source_tree))),
6750                         source_tree);
6751           source_tree
6752             = ffecom_2 (ARRAY_REF,
6753                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6754                                                       (source_tree))),
6755                         source_tree,
6756                         integer_one_node);
6757
6758           expr_tree = ffecom_modify (void_type_node, dest_tree, source_tree);
6759
6760           expand_expr_stmt (expr_tree);
6761
6762           return;
6763         }
6764
6765       expr_tree = build_tree_list (NULL_TREE, dest_tree);
6766       TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6767       TREE_CHAIN (TREE_CHAIN (expr_tree))
6768         = build_tree_list (NULL_TREE, dest_length);
6769       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6770         = build_tree_list (NULL_TREE, source_length);
6771
6772       expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6773       TREE_SIDE_EFFECTS (expr_tree) = 1;
6774
6775       expand_expr_stmt (expr_tree);
6776
6777       return;
6778
6779     default:                    /* Must actually concatenate things. */
6780       break;
6781     }
6782
6783   /* Heavy-duty concatenation. */
6784
6785   {
6786     int count = ffecom_concat_list_count_ (catlist);
6787     int i;
6788     tree lengths;
6789     tree items;
6790     tree length_array;
6791     tree item_array;
6792     tree citem;
6793     tree clength;
6794
6795 #ifdef HOHO
6796     length_array
6797       = lengths
6798       = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
6799                              FFETARGET_charactersizeNONE, count, TRUE);
6800     item_array = items = ffecom_push_tempvar (ffecom_f2c_address_type_node,
6801                                               FFETARGET_charactersizeNONE,
6802                                               count, TRUE);
6803 #else
6804     {
6805       tree hook;
6806
6807       hook = ffebld_nonter_hook (source);
6808       assert (hook);
6809       assert (TREE_CODE (hook) == TREE_VEC);
6810       assert (TREE_VEC_LENGTH (hook) == 2);
6811       length_array = lengths = TREE_VEC_ELT (hook, 0);
6812       item_array = items = TREE_VEC_ELT (hook, 1);
6813     }
6814 #endif
6815
6816     for (i = 0; i < count; ++i)
6817       {
6818         ffecom_char_args_ (&citem, &clength,
6819                            ffecom_concat_list_expr_ (catlist, i));
6820         if ((citem == error_mark_node)
6821             || (clength == error_mark_node))
6822           {
6823             ffecom_concat_list_kill_ (catlist);
6824             return;
6825           }
6826
6827         items
6828           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
6829                       ffecom_modify (void_type_node,
6830                                      ffecom_2 (ARRAY_REF,
6831                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
6832                                                item_array,
6833                                                build_int_2 (i, 0)),
6834                                      citem),
6835                       items);
6836         lengths
6837           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
6838                       ffecom_modify (void_type_node,
6839                                      ffecom_2 (ARRAY_REF,
6840                    TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
6841                                                length_array,
6842                                                build_int_2 (i, 0)),
6843                                      clength),
6844                       lengths);
6845       }
6846
6847     expr_tree = build_tree_list (NULL_TREE, dest_tree);
6848     TREE_CHAIN (expr_tree)
6849       = build_tree_list (NULL_TREE,
6850                          ffecom_1 (ADDR_EXPR,
6851                                    build_pointer_type (TREE_TYPE (items)),
6852                                    items));
6853     TREE_CHAIN (TREE_CHAIN (expr_tree))
6854       = build_tree_list (NULL_TREE,
6855                          ffecom_1 (ADDR_EXPR,
6856                                    build_pointer_type (TREE_TYPE (lengths)),
6857                                    lengths));
6858     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6859       = build_tree_list
6860         (NULL_TREE,
6861          ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
6862                    convert (ffecom_f2c_ftnlen_type_node,
6863                             build_int_2 (count, 0))));
6864     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree))))
6865       = build_tree_list (NULL_TREE, dest_length);
6866
6867     expr_tree = ffecom_call_gfrt (FFECOM_gfrtCAT, expr_tree, NULL_TREE);
6868     TREE_SIDE_EFFECTS (expr_tree) = 1;
6869
6870     expand_expr_stmt (expr_tree);
6871   }
6872
6873   ffecom_concat_list_kill_ (catlist);
6874 }
6875
6876 #endif
6877 /* ffecom_make_gfrt_ -- Make initial info for run-time routine
6878
6879    ffecomGfrt ix;
6880    ffecom_make_gfrt_(ix);
6881
6882    Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL
6883    for the indicated run-time routine (ix).  */
6884
6885 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6886 static void
6887 ffecom_make_gfrt_ (ffecomGfrt ix)
6888 {
6889   tree t;
6890   tree ttype;
6891
6892   switch (ffecom_gfrt_type_[ix])
6893     {
6894     case FFECOM_rttypeVOID_:
6895       ttype = void_type_node;
6896       break;
6897
6898     case FFECOM_rttypeVOIDSTAR_:
6899       ttype = TREE_TYPE (null_pointer_node);    /* `void *'. */
6900       break;
6901
6902     case FFECOM_rttypeFTNINT_:
6903       ttype = ffecom_f2c_ftnint_type_node;
6904       break;
6905
6906     case FFECOM_rttypeINTEGER_:
6907       ttype = ffecom_f2c_integer_type_node;
6908       break;
6909
6910     case FFECOM_rttypeLONGINT_:
6911       ttype = ffecom_f2c_longint_type_node;
6912       break;
6913
6914     case FFECOM_rttypeLOGICAL_:
6915       ttype = ffecom_f2c_logical_type_node;
6916       break;
6917
6918     case FFECOM_rttypeREAL_F2C_:
6919       ttype = double_type_node;
6920       break;
6921
6922     case FFECOM_rttypeREAL_GNU_:
6923       ttype = float_type_node;
6924       break;
6925
6926     case FFECOM_rttypeCOMPLEX_F2C_:
6927       ttype = void_type_node;
6928       break;
6929
6930     case FFECOM_rttypeCOMPLEX_GNU_:
6931       ttype = ffecom_f2c_complex_type_node;
6932       break;
6933
6934     case FFECOM_rttypeDOUBLE_:
6935       ttype = double_type_node;
6936       break;
6937
6938     case FFECOM_rttypeDOUBLEREAL_:
6939       ttype = ffecom_f2c_doublereal_type_node;
6940       break;
6941
6942     case FFECOM_rttypeDBLCMPLX_F2C_:
6943       ttype = void_type_node;
6944       break;
6945
6946     case FFECOM_rttypeDBLCMPLX_GNU_:
6947       ttype = ffecom_f2c_doublecomplex_type_node;
6948       break;
6949
6950     case FFECOM_rttypeCHARACTER_:
6951       ttype = void_type_node;
6952       break;
6953
6954     default:
6955       ttype = NULL;
6956       assert ("bad rttype" == NULL);
6957       break;
6958     }
6959
6960   ttype = build_function_type (ttype, NULL_TREE);
6961   t = build_decl (FUNCTION_DECL,
6962                   get_identifier (ffecom_gfrt_name_[ix]),
6963                   ttype);
6964   DECL_EXTERNAL (t) = 1;
6965   TREE_READONLY (t) = ffecom_gfrt_const_[ix] ? 1 : 0;
6966   TREE_PUBLIC (t) = 1;
6967   TREE_THIS_VOLATILE (t) = ffecom_gfrt_volatile_[ix] ? 1 : 0;
6968
6969   /* Sanity check:  A function that's const cannot be volatile.  */
6970
6971   assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_volatile_[ix] : 1);
6972
6973   /* Sanity check: A function that's const cannot return complex.  */
6974
6975   assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_complex_[ix] : 1);
6976
6977   t = start_decl (t, TRUE);
6978
6979   finish_decl (t, NULL_TREE, TRUE);
6980
6981   ffecom_gfrt_[ix] = t;
6982 }
6983
6984 #endif
6985 /* Phase 1 pass over each member of a COMMON/EQUIVALENCE group.  */
6986
6987 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6988 static void
6989 ffecom_member_phase1_ (ffestorag mst UNUSED, ffestorag st)
6990 {
6991   ffesymbol s = ffestorag_symbol (st);
6992
6993   if (ffesymbol_namelisted (s))
6994     ffecom_member_namelisted_ = TRUE;
6995 }
6996
6997 #endif
6998 /* Phase 2 pass over each member of a COMMON/EQUIVALENCE group.  Declare
6999    the member so debugger will see it.  Otherwise nobody should be
7000    referencing the member.  */
7001
7002 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7003 static void
7004 ffecom_member_phase2_ (ffestorag mst, ffestorag st)
7005 {
7006   ffesymbol s;
7007   tree t;
7008   tree mt;
7009   tree type;
7010
7011   if ((mst == NULL)
7012       || ((mt = ffestorag_hook (mst)) == NULL)
7013       || (mt == error_mark_node))
7014     return;
7015
7016   if ((st == NULL)
7017       || ((s = ffestorag_symbol (st)) == NULL))
7018     return;
7019
7020   type = ffecom_type_localvar_ (s,
7021                                 ffesymbol_basictype (s),
7022                                 ffesymbol_kindtype (s));
7023   if (type == error_mark_node)
7024     return;
7025
7026   t = build_decl (VAR_DECL,
7027                   ffecom_get_identifier_ (ffesymbol_text (s)),
7028                   type);
7029
7030   TREE_STATIC (t) = TREE_STATIC (mt);
7031   DECL_INITIAL (t) = NULL_TREE;
7032   TREE_ASM_WRITTEN (t) = 1;
7033   TREE_USED (t) = 1;
7034
7035   SET_DECL_RTL (t,
7036                 gen_rtx (MEM, TYPE_MODE (type),
7037                          plus_constant (XEXP (DECL_RTL (mt), 0),
7038                                         ffestorag_modulo (mst)
7039                                         + ffestorag_offset (st)
7040                                         - ffestorag_offset (mst))));
7041
7042   t = start_decl (t, FALSE);
7043
7044   finish_decl (t, NULL_TREE, FALSE);
7045 }
7046
7047 #endif
7048 /* Prepare source expression for assignment into a destination perhaps known
7049    to be of a specific size.  */
7050
7051 static void
7052 ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size, ffebld source)
7053 {
7054   ffecomConcatList_ catlist;
7055   int count;
7056   int i;
7057   tree ltmp;
7058   tree itmp;
7059   tree tempvar = NULL_TREE;
7060
7061   while (ffebld_op (source) == FFEBLD_opCONVERT)
7062     source = ffebld_left (source);
7063
7064   catlist = ffecom_concat_list_new_ (source, dest_size);
7065   count = ffecom_concat_list_count_ (catlist);
7066
7067   if (count >= 2)
7068     {
7069       ltmp
7070         = ffecom_make_tempvar ("let_char_len", ffecom_f2c_ftnlen_type_node,
7071                                FFETARGET_charactersizeNONE, count);
7072       itmp
7073         = ffecom_make_tempvar ("let_char_item", ffecom_f2c_address_type_node,
7074                                FFETARGET_charactersizeNONE, count);
7075
7076       tempvar = make_tree_vec (2);
7077       TREE_VEC_ELT (tempvar, 0) = ltmp;
7078       TREE_VEC_ELT (tempvar, 1) = itmp;
7079     }
7080
7081   for (i = 0; i < count; ++i)
7082     ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist, i));
7083
7084   ffecom_concat_list_kill_ (catlist);
7085
7086   if (tempvar)
7087     {
7088       ffebld_nonter_set_hook (source, tempvar);
7089       current_binding_level->prep_state = 1;
7090     }
7091 }
7092
7093 /* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order
7094
7095    Ignores STAR (alternate-return) dummies.  All other get exec-transitioned
7096    (which generates their trees) and then their trees get push_parm_decl'd.
7097
7098    The second arg is TRUE if the dummies are for a statement function, in
7099    which case lengths are not pushed for character arguments (since they are
7100    always known by both the caller and the callee, though the code allows
7101    for someday permitting CHAR*(*) stmtfunc dummies).  */
7102
7103 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7104 static void
7105 ffecom_push_dummy_decls_ (ffebld dummy_list, bool stmtfunc)
7106 {
7107   ffebld dummy;
7108   ffebld dumlist;
7109   ffesymbol s;
7110   tree parm;
7111
7112   ffecom_transform_only_dummies_ = TRUE;
7113
7114   /* First push the parms corresponding to actual dummy "contents".  */
7115
7116   for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7117     {
7118       dummy = ffebld_head (dumlist);
7119       switch (ffebld_op (dummy))
7120         {
7121         case FFEBLD_opSTAR:
7122         case FFEBLD_opANY:
7123           continue;             /* Forget alternate returns. */
7124
7125         default:
7126           break;
7127         }
7128       assert (ffebld_op (dummy) == FFEBLD_opSYMTER);
7129       s = ffebld_symter (dummy);
7130       parm = ffesymbol_hook (s).decl_tree;
7131       if (parm == NULL_TREE)
7132         {
7133           s = ffecom_sym_transform_ (s);
7134           parm = ffesymbol_hook (s).decl_tree;
7135           assert (parm != NULL_TREE);
7136         }
7137       if (parm != error_mark_node)
7138         push_parm_decl (parm);
7139     }
7140
7141   /* Then, for CHARACTER dummies, push the parms giving their lengths.  */
7142
7143   for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7144     {
7145       dummy = ffebld_head (dumlist);
7146       switch (ffebld_op (dummy))
7147         {
7148         case FFEBLD_opSTAR:
7149         case FFEBLD_opANY:
7150           continue;             /* Forget alternate returns, they mean
7151                                    NOTHING! */
7152
7153         default:
7154           break;
7155         }
7156       s = ffebld_symter (dummy);
7157       if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
7158         continue;               /* Only looking for CHARACTER arguments. */
7159       if (stmtfunc && (ffesymbol_size (s) != FFETARGET_charactersizeNONE))
7160         continue;               /* Stmtfunc arg with known size needs no
7161                                    length param. */
7162       if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
7163         continue;               /* Only looking for variables and arrays. */
7164       parm = ffesymbol_hook (s).length_tree;
7165       assert (parm != NULL_TREE);
7166       if (parm != error_mark_node)
7167         push_parm_decl (parm);
7168     }
7169
7170   ffecom_transform_only_dummies_ = FALSE;
7171 }
7172
7173 #endif
7174 /* ffecom_start_progunit_ -- Beginning of program unit
7175
7176    Does GNU back end stuff necessary to teach it about the start of its
7177    equivalent of a Fortran program unit.  */
7178
7179 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7180 static void
7181 ffecom_start_progunit_ ()
7182 {
7183   ffesymbol fn = ffecom_primary_entry_;
7184   ffebld arglist;
7185   tree id;                      /* Identifier (name) of function. */
7186   tree type;                    /* Type of function. */
7187   tree result;                  /* Result of function. */
7188   ffeinfoBasictype bt;
7189   ffeinfoKindtype kt;
7190   ffeglobal g;
7191   ffeglobalType gt;
7192   ffeglobalType egt = FFEGLOBAL_type;
7193   bool charfunc;
7194   bool cmplxfunc;
7195   bool altentries = (ffecom_num_entrypoints_ != 0);
7196   bool multi
7197   = altentries
7198   && (ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
7199   && (ffecom_master_bt_ == FFEINFO_basictypeNONE);
7200   bool main_program = FALSE;
7201   int old_lineno = lineno;
7202   const char *old_input_filename = input_filename;
7203
7204   assert (fn != NULL);
7205   assert (ffesymbol_hook (fn).decl_tree == NULL_TREE);
7206
7207   input_filename = ffesymbol_where_filename (fn);
7208   lineno = ffesymbol_where_filelinenum (fn);
7209
7210   switch (ffecom_primary_entry_kind_)
7211     {
7212     case FFEINFO_kindPROGRAM:
7213       main_program = TRUE;
7214       gt = FFEGLOBAL_typeMAIN;
7215       bt = FFEINFO_basictypeNONE;
7216       kt = FFEINFO_kindtypeNONE;
7217       type = ffecom_tree_fun_type_void;
7218       charfunc = FALSE;
7219       cmplxfunc = FALSE;
7220       break;
7221
7222     case FFEINFO_kindBLOCKDATA:
7223       gt = FFEGLOBAL_typeBDATA;
7224       bt = FFEINFO_basictypeNONE;
7225       kt = FFEINFO_kindtypeNONE;
7226       type = ffecom_tree_fun_type_void;
7227       charfunc = FALSE;
7228       cmplxfunc = FALSE;
7229       break;
7230
7231     case FFEINFO_kindFUNCTION:
7232       gt = FFEGLOBAL_typeFUNC;
7233       egt = FFEGLOBAL_typeEXT;
7234       bt = ffesymbol_basictype (fn);
7235       kt = ffesymbol_kindtype (fn);
7236       if (bt == FFEINFO_basictypeNONE)
7237         {
7238           ffeimplic_establish_symbol (fn);
7239           if (ffesymbol_funcresult (fn) != NULL)
7240             ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
7241           bt = ffesymbol_basictype (fn);
7242           kt = ffesymbol_kindtype (fn);
7243         }
7244
7245       if (multi)
7246         charfunc = cmplxfunc = FALSE;
7247       else if (bt == FFEINFO_basictypeCHARACTER)
7248         charfunc = TRUE, cmplxfunc = FALSE;
7249       else if ((bt == FFEINFO_basictypeCOMPLEX)
7250                && ffesymbol_is_f2c (fn)
7251                && !altentries)
7252         charfunc = FALSE, cmplxfunc = TRUE;
7253       else
7254         charfunc = cmplxfunc = FALSE;
7255
7256       if (multi || charfunc)
7257         type = ffecom_tree_fun_type_void;
7258       else if (ffesymbol_is_f2c (fn) && !altentries)
7259         type = ffecom_tree_fun_type[bt][kt];
7260       else
7261         type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
7262
7263       if ((type == NULL_TREE)
7264           || (TREE_TYPE (type) == NULL_TREE))
7265         type = ffecom_tree_fun_type_void;       /* _sym_exec_transition. */
7266       break;
7267
7268     case FFEINFO_kindSUBROUTINE:
7269       gt = FFEGLOBAL_typeSUBR;
7270       egt = FFEGLOBAL_typeEXT;
7271       bt = FFEINFO_basictypeNONE;
7272       kt = FFEINFO_kindtypeNONE;
7273       if (ffecom_is_altreturning_)
7274         type = ffecom_tree_subr_type;
7275       else
7276         type = ffecom_tree_fun_type_void;
7277       charfunc = FALSE;
7278       cmplxfunc = FALSE;
7279       break;
7280
7281     default:
7282       assert ("say what??" == NULL);
7283       /* Fall through. */
7284     case FFEINFO_kindANY:
7285       gt = FFEGLOBAL_typeANY;
7286       bt = FFEINFO_basictypeNONE;
7287       kt = FFEINFO_kindtypeNONE;
7288       type = error_mark_node;
7289       charfunc = FALSE;
7290       cmplxfunc = FALSE;
7291       break;
7292     }
7293
7294   if (altentries)
7295     {
7296       id = ffecom_get_invented_identifier ("__g77_masterfun_%s",
7297                                            ffesymbol_text (fn));
7298     }
7299 #if FFETARGET_isENFORCED_MAIN
7300   else if (main_program)
7301     id = get_identifier (FFETARGET_nameENFORCED_MAIN_NAME);
7302 #endif
7303   else
7304     id = ffecom_get_external_identifier_ (fn);
7305
7306   start_function (id,
7307                   type,
7308                   0,            /* nested/inline */
7309                   !altentries); /* TREE_PUBLIC */
7310
7311   TREE_USED (current_function_decl) = 1;        /* Avoid spurious warning if altentries. */
7312
7313   if (!altentries
7314       && ((g = ffesymbol_global (fn)) != NULL)
7315       && ((ffeglobal_type (g) == gt)
7316           || (ffeglobal_type (g) == egt)))
7317     {
7318       ffeglobal_set_hook (g, current_function_decl);
7319     }
7320
7321   /* Arg handling needs exec-transitioned ffesymbols to work with.  But
7322      exec-transitioning needs current_function_decl to be filled in.  So we
7323      do these things in two phases. */
7324
7325   if (altentries)
7326     {                           /* 1st arg identifies which entrypoint. */
7327       ffecom_which_entrypoint_decl_
7328         = build_decl (PARM_DECL,
7329                       ffecom_get_invented_identifier ("__g77_%s",
7330                                                       "which_entrypoint"),
7331                       integer_type_node);
7332       push_parm_decl (ffecom_which_entrypoint_decl_);
7333     }
7334
7335   if (charfunc
7336       || cmplxfunc
7337       || multi)
7338     {                           /* Arg for result (return value). */
7339       tree type;
7340       tree length;
7341
7342       if (charfunc)
7343         type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
7344       else if (cmplxfunc)
7345         type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
7346       else
7347         type = ffecom_multi_type_node_;
7348
7349       result = ffecom_get_invented_identifier ("__g77_%s", "result");
7350
7351       /* Make length arg _and_ enhance type info for CHAR arg itself.  */
7352
7353       if (charfunc)
7354         length = ffecom_char_enhance_arg_ (&type, fn);
7355       else
7356         length = NULL_TREE;     /* Not ref'd if !charfunc. */
7357
7358       type = build_pointer_type (type);
7359       result = build_decl (PARM_DECL, result, type);
7360
7361       push_parm_decl (result);
7362       if (multi)
7363         ffecom_multi_retval_ = result;
7364       else
7365         ffecom_func_result_ = result;
7366
7367       if (charfunc)
7368         {
7369           push_parm_decl (length);
7370           ffecom_func_length_ = length;
7371         }
7372     }
7373
7374   if (ffecom_primary_entry_is_proc_)
7375     {
7376       if (altentries)
7377         arglist = ffecom_master_arglist_;
7378       else
7379         arglist = ffesymbol_dummyargs (fn);
7380       ffecom_push_dummy_decls_ (arglist, FALSE);
7381     }
7382
7383   if (TREE_CODE (current_function_decl) != ERROR_MARK)
7384     store_parm_decls (main_program ? 1 : 0);
7385
7386   ffecom_start_compstmt ();
7387   /* Disallow temp vars at this level.  */
7388   current_binding_level->prep_state = 2;
7389
7390   lineno = old_lineno;
7391   input_filename = old_input_filename;
7392
7393   /* This handles any symbols still untransformed, in case -g specified.
7394      This used to be done in ffecom_finish_progunit, but it turns out to
7395      be necessary to do it here so that statement functions are
7396      expanded before code.  But don't bother for BLOCK DATA.  */
7397
7398   if (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
7399     ffesymbol_drive (ffecom_finish_symbol_transform_);
7400 }
7401
7402 #endif
7403 /* ffecom_sym_transform_ -- Transform FFE sym into backend sym
7404
7405    ffesymbol s;
7406    ffecom_sym_transform_(s);
7407
7408    The ffesymbol_hook info for s is updated with appropriate backend info
7409    on the symbol.  */
7410
7411 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7412 static ffesymbol
7413 ffecom_sym_transform_ (ffesymbol s)
7414 {
7415   tree t;                       /* Transformed thingy. */
7416   tree tlen;                    /* Length if CHAR*(*). */
7417   bool addr;                    /* Is t the address of the thingy? */
7418   ffeinfoBasictype bt;
7419   ffeinfoKindtype kt;
7420   ffeglobal g;
7421   int old_lineno = lineno;
7422   const char *old_input_filename = input_filename;
7423
7424   /* Must ensure special ASSIGN variables are declared at top of outermost
7425      block, else they'll end up in the innermost block when their first
7426      ASSIGN is seen, which leaves them out of scope when they're the
7427      subject of a GOTO or I/O statement.
7428
7429      We make this variable even if -fugly-assign.  Just let it go unused,
7430      in case it turns out there are cases where we really want to use this
7431      variable anyway (e.g. ASSIGN to INTEGER*2 variable).  */
7432
7433   if (! ffecom_transform_only_dummies_
7434       && ffesymbol_assigned (s)
7435       && ! ffesymbol_hook (s).assign_tree)
7436     s = ffecom_sym_transform_assign_ (s);
7437
7438   if (ffesymbol_sfdummyparent (s) == NULL)
7439     {
7440       input_filename = ffesymbol_where_filename (s);
7441       lineno = ffesymbol_where_filelinenum (s);
7442     }
7443   else
7444     {
7445       ffesymbol sf = ffesymbol_sfdummyparent (s);
7446
7447       input_filename = ffesymbol_where_filename (sf);
7448       lineno = ffesymbol_where_filelinenum (sf);
7449     }
7450
7451   bt = ffeinfo_basictype (ffebld_info (s));
7452   kt = ffeinfo_kindtype (ffebld_info (s));
7453
7454   t = NULL_TREE;
7455   tlen = NULL_TREE;
7456   addr = FALSE;
7457
7458   switch (ffesymbol_kind (s))
7459     {
7460     case FFEINFO_kindNONE:
7461       switch (ffesymbol_where (s))
7462         {
7463         case FFEINFO_whereDUMMY:        /* Subroutine or function. */
7464           assert (ffecom_transform_only_dummies_);
7465
7466           /* Before 0.4, this could be ENTITY/DUMMY, but see
7467              ffestu_sym_end_transition -- no longer true (in particular, if
7468              it could be an ENTITY, it _will_ be made one, so that
7469              possibility won't come through here).  So we never make length
7470              arg for CHARACTER type.  */
7471
7472           t = build_decl (PARM_DECL,
7473                           ffecom_get_identifier_ (ffesymbol_text (s)),
7474                           ffecom_tree_ptr_to_subr_type);
7475 #if BUILT_FOR_270
7476           DECL_ARTIFICIAL (t) = 1;
7477 #endif
7478           addr = TRUE;
7479           break;
7480
7481         case FFEINFO_whereGLOBAL:       /* Subroutine or function. */
7482           assert (!ffecom_transform_only_dummies_);
7483
7484           if (((g = ffesymbol_global (s)) != NULL)
7485               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7486                   || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7487                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
7488               && (ffeglobal_hook (g) != NULL_TREE)
7489               && ffe_is_globals ())
7490             {
7491               t = ffeglobal_hook (g);
7492               break;
7493             }
7494
7495           t = build_decl (FUNCTION_DECL,
7496                           ffecom_get_external_identifier_ (s),
7497                           ffecom_tree_subr_type);       /* Assume subr. */
7498           DECL_EXTERNAL (t) = 1;
7499           TREE_PUBLIC (t) = 1;
7500
7501           t = start_decl (t, FALSE);
7502           finish_decl (t, NULL_TREE, FALSE);
7503
7504           if ((g != NULL)
7505               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7506                   || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7507                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
7508             ffeglobal_set_hook (g, t);
7509
7510           ffecom_save_tree_forever (t);
7511
7512           break;
7513
7514         default:
7515           assert ("NONE where unexpected" == NULL);
7516           /* Fall through. */
7517         case FFEINFO_whereANY:
7518           break;
7519         }
7520       break;
7521
7522     case FFEINFO_kindENTITY:
7523       switch (ffeinfo_where (ffesymbol_info (s)))
7524         {
7525
7526         case FFEINFO_whereCONSTANT:
7527           /* ~~Debugging info needed? */
7528           assert (!ffecom_transform_only_dummies_);
7529           t = error_mark_node;  /* Shouldn't ever see this in expr. */
7530           break;
7531
7532         case FFEINFO_whereLOCAL:
7533           assert (!ffecom_transform_only_dummies_);
7534
7535           {
7536             ffestorag st = ffesymbol_storage (s);
7537             tree type;
7538
7539             if ((st != NULL)
7540                 && (ffestorag_size (st) == 0))
7541               {
7542                 t = error_mark_node;
7543                 break;
7544               }
7545
7546             type = ffecom_type_localvar_ (s, bt, kt);
7547
7548             if (type == error_mark_node)
7549               {
7550                 t = error_mark_node;
7551                 break;
7552               }
7553
7554             if ((st != NULL)
7555                 && (ffestorag_parent (st) != NULL))
7556               {                 /* Child of EQUIVALENCE parent. */
7557                 ffestorag est;
7558                 tree et;
7559                 ffetargetOffset offset;
7560
7561                 est = ffestorag_parent (st);
7562                 ffecom_transform_equiv_ (est);
7563
7564                 et = ffestorag_hook (est);
7565                 assert (et != NULL_TREE);
7566
7567                 if (! TREE_STATIC (et))
7568                   put_var_into_stack (et);
7569
7570                 offset = ffestorag_modulo (est)
7571                   + ffestorag_offset (ffesymbol_storage (s))
7572                   - ffestorag_offset (est);
7573
7574                 ffecom_debug_kludge_ (et, "EQUIVALENCE", s, type, offset);
7575
7576                 /* (t_type *) (((char *) &et) + offset) */
7577
7578                 t = convert (string_type_node,  /* (char *) */
7579                              ffecom_1 (ADDR_EXPR,
7580                                        build_pointer_type (TREE_TYPE (et)),
7581                                        et));
7582                 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
7583                               t,
7584                               build_int_2 (offset, 0));
7585                 t = convert (build_pointer_type (type),
7586                              t);
7587                 TREE_CONSTANT (t) = staticp (et);
7588
7589                 addr = TRUE;
7590               }
7591             else
7592               {
7593                 tree initexpr;
7594                 bool init = ffesymbol_is_init (s);
7595
7596                 t = build_decl (VAR_DECL,
7597                                 ffecom_get_identifier_ (ffesymbol_text (s)),
7598                                 type);
7599
7600                 if (init
7601                     || ffesymbol_namelisted (s)
7602 #ifdef FFECOM_sizeMAXSTACKITEM
7603                     || ((st != NULL)
7604                         && (ffestorag_size (st) > FFECOM_sizeMAXSTACKITEM))
7605 #endif
7606                     || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
7607                         && (ffecom_primary_entry_kind_
7608                             != FFEINFO_kindBLOCKDATA)
7609                         && (ffesymbol_is_save (s) || ffe_is_saveall ())))
7610                   TREE_STATIC (t) = !ffesymbol_attr (s, FFESYMBOL_attrADJUSTABLE);
7611                 else
7612                   TREE_STATIC (t) = 0;  /* No need to make static. */
7613
7614                 if (init || ffe_is_init_local_zero ())
7615                   DECL_INITIAL (t) = error_mark_node;
7616
7617                 /* Keep -Wunused from complaining about var if it
7618                    is used as sfunc arg or DATA implied-DO.  */
7619                 if (ffesymbol_attrs (s) & FFESYMBOL_attrsSFARG)
7620                   DECL_IN_SYSTEM_HEADER (t) = 1;
7621
7622                 t = start_decl (t, FALSE);
7623
7624                 if (init)
7625                   {
7626                     if (ffesymbol_init (s) != NULL)
7627                       initexpr = ffecom_expr (ffesymbol_init (s));
7628                     else
7629                       initexpr = ffecom_init_zero_ (t);
7630                   }
7631                 else if (ffe_is_init_local_zero ())
7632                   initexpr = ffecom_init_zero_ (t);
7633                 else
7634                   initexpr = NULL_TREE; /* Not ref'd if !init. */
7635
7636                 finish_decl (t, initexpr, FALSE);
7637
7638                 if (st != NULL && DECL_SIZE (t) != error_mark_node)
7639                   {
7640                     assert (TREE_CODE (DECL_SIZE_UNIT (t)) == INTEGER_CST);
7641                     assert (0 == compare_tree_int (DECL_SIZE_UNIT (t),
7642                                                    ffestorag_size (st)));
7643                   }
7644               }
7645           }
7646           break;
7647
7648         case FFEINFO_whereRESULT:
7649           assert (!ffecom_transform_only_dummies_);
7650
7651           if (bt == FFEINFO_basictypeCHARACTER)
7652             {                   /* Result is already in list of dummies, use
7653                                    it (& length). */
7654               t = ffecom_func_result_;
7655               tlen = ffecom_func_length_;
7656               addr = TRUE;
7657               break;
7658             }
7659           if ((ffecom_num_entrypoints_ == 0)
7660               && (bt == FFEINFO_basictypeCOMPLEX)
7661               && (ffesymbol_is_f2c (ffecom_primary_entry_)))
7662             {                   /* Result is already in list of dummies, use
7663                                    it. */
7664               t = ffecom_func_result_;
7665               addr = TRUE;
7666               break;
7667             }
7668           if (ffecom_func_result_ != NULL_TREE)
7669             {
7670               t = ffecom_func_result_;
7671               break;
7672             }
7673           if ((ffecom_num_entrypoints_ != 0)
7674               && (ffecom_master_bt_ == FFEINFO_basictypeNONE))
7675             {
7676               assert (ffecom_multi_retval_ != NULL_TREE);
7677               t = ffecom_1 (INDIRECT_REF, ffecom_multi_type_node_,
7678                             ffecom_multi_retval_);
7679               t = ffecom_2 (COMPONENT_REF, ffecom_tree_type[bt][kt],
7680                             t, ffecom_multi_fields_[bt][kt]);
7681
7682               break;
7683             }
7684
7685           t = build_decl (VAR_DECL,
7686                           ffecom_get_identifier_ (ffesymbol_text (s)),
7687                           ffecom_tree_type[bt][kt]);
7688           TREE_STATIC (t) = 0;  /* Put result on stack. */
7689           t = start_decl (t, FALSE);
7690           finish_decl (t, NULL_TREE, FALSE);
7691
7692           ffecom_func_result_ = t;
7693
7694           break;
7695
7696         case FFEINFO_whereDUMMY:
7697           {
7698             tree type;
7699             ffebld dl;
7700             ffebld dim;
7701             tree low;
7702             tree high;
7703             tree old_sizes;
7704             bool adjustable = FALSE;    /* Conditionally adjustable? */
7705
7706             type = ffecom_tree_type[bt][kt];
7707             if (ffesymbol_sfdummyparent (s) != NULL)
7708               {
7709                 if (current_function_decl == ffecom_outer_function_decl_)
7710                   {                     /* Exec transition before sfunc
7711                                            context; get it later. */
7712                     break;
7713                   }
7714                 t = ffecom_get_identifier_ (ffesymbol_text
7715                                             (ffesymbol_sfdummyparent (s)));
7716               }
7717             else
7718               t = ffecom_get_identifier_ (ffesymbol_text (s));
7719
7720             assert (ffecom_transform_only_dummies_);
7721
7722             old_sizes = get_pending_sizes ();
7723             put_pending_sizes (old_sizes);
7724
7725             if (bt == FFEINFO_basictypeCHARACTER)
7726               tlen = ffecom_char_enhance_arg_ (&type, s);
7727             type = ffecom_check_size_overflow_ (s, type, TRUE);
7728
7729             for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
7730               {
7731                 if (type == error_mark_node)
7732                   break;
7733
7734                 dim = ffebld_head (dl);
7735                 assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
7736                 if ((ffebld_left (dim) == NULL) || ffecom_doing_entry_)
7737                   low = ffecom_integer_one_node;
7738                 else
7739                   low = ffecom_expr (ffebld_left (dim));
7740                 assert (ffebld_right (dim) != NULL);
7741                 if ((ffebld_op (ffebld_right (dim)) == FFEBLD_opSTAR)
7742                     || ffecom_doing_entry_)
7743                   {
7744                     /* Used to just do high=low.  But for ffecom_tree_
7745                        canonize_ref_, it probably is important to correctly
7746                        assess the size.  E.g. given COMPLEX C(*),CFUNC and
7747                        C(2)=CFUNC(C), overlap can happen, while it can't
7748                        for, say, C(1)=CFUNC(C(2)).  */
7749                     /* Even more recently used to set to INT_MAX, but that
7750                        broke when some overflow checking went into the back
7751                        end.  Now we just leave the upper bound unspecified.  */
7752                     high = NULL;
7753                   }
7754                 else
7755                   high = ffecom_expr (ffebld_right (dim));
7756
7757                 /* Determine whether array is conditionally adjustable,
7758                    to decide whether back-end magic is needed.
7759
7760                    Normally the front end uses the back-end function
7761                    variable_size to wrap SAVE_EXPR's around expressions
7762                    affecting the size/shape of an array so that the
7763                    size/shape info doesn't change during execution
7764                    of the compiled code even though variables and
7765                    functions referenced in those expressions might.
7766
7767                    variable_size also makes sure those saved expressions
7768                    get evaluated immediately upon entry to the
7769                    compiled procedure -- the front end normally doesn't
7770                    have to worry about that.
7771
7772                    However, there is a problem with this that affects
7773                    g77's implementation of entry points, and that is
7774                    that it is _not_ true that each invocation of the
7775                    compiled procedure is permitted to evaluate
7776                    array size/shape info -- because it is possible
7777                    that, for some invocations, that info is invalid (in
7778                    which case it is "promised" -- i.e. a violation of
7779                    the Fortran standard -- that the compiled code
7780                    won't reference the array or its size/shape
7781                    during that particular invocation).
7782
7783                    To phrase this in C terms, consider this gcc function:
7784
7785                      void foo (int *n, float (*a)[*n])
7786                      {
7787                        // a is "pointer to array ...", fyi.
7788                      }
7789
7790                    Suppose that, for some invocations, it is permitted
7791                    for a caller of foo to do this:
7792
7793                        foo (NULL, NULL);
7794
7795                    Now the _written_ code for foo can take such a call
7796                    into account by either testing explicitly for whether
7797                    (a == NULL) || (n == NULL) -- presumably it is
7798                    not permitted to reference *a in various fashions
7799                    if (n == NULL) I suppose -- or it can avoid it by
7800                    looking at other info (other arguments, static/global
7801                    data, etc.).
7802
7803                    However, this won't work in gcc 2.5.8 because it'll
7804                    automatically emit the code to save the "*n"
7805                    expression, which'll yield a NULL dereference for
7806                    the "foo (NULL, NULL)" call, something the code
7807                    for foo cannot prevent.
7808
7809                    g77 definitely needs to avoid executing such
7810                    code anytime the pointer to the adjustable array
7811                    is NULL, because even if its bounds expressions
7812                    don't have any references to possible "absent"
7813                    variables like "*n" -- say all variable references
7814                    are to COMMON variables, i.e. global (though in C,
7815                    local static could actually make sense) -- the
7816                    expressions could yield other run-time problems
7817                    for allowably "dead" values in those variables.
7818
7819                    For example, let's consider a more complicated
7820                    version of foo:
7821
7822                      extern int i;
7823                      extern int j;
7824
7825                      void foo (float (*a)[i/j])
7826                      {
7827                        ...
7828                      }
7829
7830                    The above is (essentially) quite valid for Fortran
7831                    but, again, for a call like "foo (NULL);", it is
7832                    permitted for i and j to be undefined when the
7833                    call is made.  If j happened to be zero, for
7834                    example, emitting the code to evaluate "i/j"
7835                    could result in a run-time error.
7836
7837                    Offhand, though I don't have my F77 or F90
7838                    standards handy, it might even be valid for a
7839                    bounds expression to contain a function reference,
7840                    in which case I doubt it is permitted for an
7841                    implementation to invoke that function in the
7842                    Fortran case involved here (invocation of an
7843                    alternate ENTRY point that doesn't have the adjustable
7844                    array as one of its arguments).
7845
7846                    So, the code that the compiler would normally emit
7847                    to preevaluate the size/shape info for an
7848                    adjustable array _must not_ be executed at run time
7849                    in certain cases.  Specifically, for Fortran,
7850                    the case is when the pointer to the adjustable
7851                    array == NULL.  (For gnu-ish C, it might be nice
7852                    for the source code itself to specify an expression
7853                    that, if TRUE, inhibits execution of the code.  Or
7854                    reverse the sense for elegance.)
7855
7856                    (Note that g77 could use a different test than NULL,
7857                    actually, since it happens to always pass an
7858                    integer to the called function that specifies which
7859                    entry point is being invoked.  Hmm, this might
7860                    solve the next problem.)
7861
7862                    One way a user could, I suppose, write "foo" so
7863                    it works is to insert COND_EXPR's for the
7864                    size/shape info so the dangerous stuff isn't
7865                    actually done, as in:
7866
7867                      void foo (int *n, float (*a)[(a == NULL) ? 0 : *n])
7868                      {
7869                        ...
7870                      }
7871
7872                    The next problem is that the front end needs to
7873                    be able to tell the back end about the array's
7874                    decl _before_ it tells it about the conditional
7875                    expression to inhibit evaluation of size/shape info,
7876                    as shown above.
7877
7878                    To solve this, the front end needs to be able
7879                    to give the back end the expression to inhibit
7880                    generation of the preevaluation code _after_
7881                    it makes the decl for the adjustable array.
7882
7883                    Until then, the above example using the COND_EXPR
7884                    doesn't pass muster with gcc because the "(a == NULL)"
7885                    part has a reference to "a", which is still
7886                    undefined at that point.
7887
7888                    g77 will therefore use a different mechanism in the
7889                    meantime.  */
7890
7891                 if (!adjustable
7892                     && ((TREE_CODE (low) != INTEGER_CST)
7893                         || (high && TREE_CODE (high) != INTEGER_CST)))
7894                   adjustable = TRUE;
7895
7896 #if 0                           /* Old approach -- see below. */
7897                 if (TREE_CODE (low) != INTEGER_CST)
7898                   low = ffecom_3 (COND_EXPR, integer_type_node,
7899                                   ffecom_adjarray_passed_ (s),
7900                                   low,
7901                                   ffecom_integer_zero_node);
7902
7903                 if (high && TREE_CODE (high) != INTEGER_CST)
7904                   high = ffecom_3 (COND_EXPR, integer_type_node,
7905                                    ffecom_adjarray_passed_ (s),
7906                                    high,
7907                                    ffecom_integer_zero_node);
7908 #endif
7909
7910                 /* ~~~gcc/stor-layout.c (layout_type) should do this,
7911                    probably.  Fixes 950302-1.f.  */
7912
7913                 if (TREE_CODE (low) != INTEGER_CST)
7914                   low = variable_size (low);
7915
7916                 /* ~~~Similarly, this fixes dumb0.f.  The C front end
7917                    does this, which is why dumb0.c would work.  */
7918
7919                 if (high && TREE_CODE (high) != INTEGER_CST)
7920                   high = variable_size (high);
7921
7922                 type
7923                   = build_array_type
7924                     (type,
7925                      build_range_type (ffecom_integer_type_node,
7926                                        low, high));
7927                 type = ffecom_check_size_overflow_ (s, type, TRUE);
7928               }
7929
7930             if (type == error_mark_node)
7931               {
7932                 t = error_mark_node;
7933                 break;
7934               }
7935
7936             if ((ffesymbol_sfdummyparent (s) == NULL)
7937                  || (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER))
7938               {
7939                 type = build_pointer_type (type);
7940                 addr = TRUE;
7941               }
7942
7943             t = build_decl (PARM_DECL, t, type);
7944 #if BUILT_FOR_270
7945             DECL_ARTIFICIAL (t) = 1;
7946 #endif
7947
7948             /* If this arg is present in every entry point's list of
7949                dummy args, then we're done.  */
7950
7951             if (ffesymbol_numentries (s)
7952                 == (ffecom_num_entrypoints_ + 1))
7953               break;
7954
7955 #if 1
7956
7957             /* If variable_size in stor-layout has been called during
7958                the above, then get_pending_sizes should have the
7959                yet-to-be-evaluated saved expressions pending.
7960                Make the whole lot of them get emitted, conditionally
7961                on whether the array decl ("t" above) is not NULL.  */
7962
7963             {
7964               tree sizes = get_pending_sizes ();
7965               tree tem;
7966
7967               for (tem = sizes;
7968                    tem != old_sizes;
7969                    tem = TREE_CHAIN (tem))
7970                 {
7971                   tree temv = TREE_VALUE (tem);
7972
7973                   if (sizes == tem)
7974                     sizes = temv;
7975                   else
7976                     sizes
7977                       = ffecom_2 (COMPOUND_EXPR,
7978                                   TREE_TYPE (sizes),
7979                                   temv,
7980                                   sizes);
7981                 }
7982
7983               if (sizes != tem)
7984                 {
7985                   sizes
7986                     = ffecom_3 (COND_EXPR,
7987                                 TREE_TYPE (sizes),
7988                                 ffecom_2 (NE_EXPR,
7989                                           integer_type_node,
7990                                           t,
7991                                           null_pointer_node),
7992                                 sizes,
7993                                 convert (TREE_TYPE (sizes),
7994                                          integer_zero_node));
7995                   sizes = ffecom_save_tree (sizes);
7996
7997                   sizes
7998                     = tree_cons (NULL_TREE, sizes, tem);
7999                 }
8000
8001               if (sizes)
8002                 put_pending_sizes (sizes);
8003             }
8004
8005 #else
8006 #if 0
8007             if (adjustable
8008                 && (ffesymbol_numentries (s)
8009                     != ffecom_num_entrypoints_ + 1))
8010               DECL_SOMETHING (t)
8011                 = ffecom_2 (NE_EXPR, integer_type_node,
8012                             t,
8013                             null_pointer_node);
8014 #else
8015 #if 0
8016             if (adjustable
8017                 && (ffesymbol_numentries (s)
8018                     != ffecom_num_entrypoints_ + 1))
8019               {
8020                 ffebad_start (FFEBAD_MISSING_ADJARRAY_UNSUPPORTED);
8021                 ffebad_here (0, ffesymbol_where_line (s),
8022                              ffesymbol_where_column (s));
8023                 ffebad_string (ffesymbol_text (s));
8024                 ffebad_finish ();
8025               }
8026 #endif
8027 #endif
8028 #endif
8029           }
8030           break;
8031
8032         case FFEINFO_whereCOMMON:
8033           {
8034             ffesymbol cs;
8035             ffeglobal cg;
8036             tree ct;
8037             ffestorag st = ffesymbol_storage (s);
8038             tree type;
8039
8040             cs = ffesymbol_common (s);  /* The COMMON area itself.  */
8041             if (st != NULL)     /* Else not laid out. */
8042               {
8043                 ffecom_transform_common_ (cs);
8044                 st = ffesymbol_storage (s);
8045               }
8046
8047             type = ffecom_type_localvar_ (s, bt, kt);
8048
8049             cg = ffesymbol_global (cs); /* The global COMMON info.  */
8050             if ((cg == NULL)
8051                 || (ffeglobal_type (cg) != FFEGLOBAL_typeCOMMON))
8052               ct = NULL_TREE;
8053             else
8054               ct = ffeglobal_hook (cg); /* The common area's tree.  */
8055
8056             if ((ct == NULL_TREE)
8057                 || (st == NULL)
8058                 || (type == error_mark_node))
8059               t = error_mark_node;
8060             else
8061               {
8062                 ffetargetOffset offset;
8063                 ffestorag cst;
8064
8065                 cst = ffestorag_parent (st);
8066                 assert (cst == ffesymbol_storage (cs));
8067
8068                 offset = ffestorag_modulo (cst)
8069                   + ffestorag_offset (st)
8070                   - ffestorag_offset (cst);
8071
8072                 ffecom_debug_kludge_ (ct, "COMMON", s, type, offset);
8073
8074                 /* (t_type *) (((char *) &ct) + offset) */
8075
8076                 t = convert (string_type_node,  /* (char *) */
8077                              ffecom_1 (ADDR_EXPR,
8078                                        build_pointer_type (TREE_TYPE (ct)),
8079                                        ct));
8080                 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
8081                               t,
8082                               build_int_2 (offset, 0));
8083                 t = convert (build_pointer_type (type),
8084                              t);
8085                 TREE_CONSTANT (t) = 1;
8086
8087                 addr = TRUE;
8088               }
8089           }
8090           break;
8091
8092         case FFEINFO_whereIMMEDIATE:
8093         case FFEINFO_whereGLOBAL:
8094         case FFEINFO_whereFLEETING:
8095         case FFEINFO_whereFLEETING_CADDR:
8096         case FFEINFO_whereFLEETING_IADDR:
8097         case FFEINFO_whereINTRINSIC:
8098         case FFEINFO_whereCONSTANT_SUBOBJECT:
8099         default:
8100           assert ("ENTITY where unheard of" == NULL);
8101           /* Fall through. */
8102         case FFEINFO_whereANY:
8103           t = error_mark_node;
8104           break;
8105         }
8106       break;
8107
8108     case FFEINFO_kindFUNCTION:
8109       switch (ffeinfo_where (ffesymbol_info (s)))
8110         {
8111         case FFEINFO_whereLOCAL:        /* Me. */
8112           assert (!ffecom_transform_only_dummies_);
8113           t = current_function_decl;
8114           break;
8115
8116         case FFEINFO_whereGLOBAL:
8117           assert (!ffecom_transform_only_dummies_);
8118
8119           if (((g = ffesymbol_global (s)) != NULL)
8120               && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8121                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8122               && (ffeglobal_hook (g) != NULL_TREE)
8123               && ffe_is_globals ())
8124             {
8125               t = ffeglobal_hook (g);
8126               break;
8127             }
8128
8129           if (ffesymbol_is_f2c (s)
8130               && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8131             t = ffecom_tree_fun_type[bt][kt];
8132           else
8133             t = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
8134
8135           t = build_decl (FUNCTION_DECL,
8136                           ffecom_get_external_identifier_ (s),
8137                           t);
8138           DECL_EXTERNAL (t) = 1;
8139           TREE_PUBLIC (t) = 1;
8140
8141           t = start_decl (t, FALSE);
8142           finish_decl (t, NULL_TREE, FALSE);
8143
8144           if ((g != NULL)
8145               && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8146                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8147             ffeglobal_set_hook (g, t);
8148
8149           ffecom_save_tree_forever (t);
8150
8151           break;
8152
8153         case FFEINFO_whereDUMMY:
8154           assert (ffecom_transform_only_dummies_);
8155
8156           if (ffesymbol_is_f2c (s)
8157               && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8158             t = ffecom_tree_ptr_to_fun_type[bt][kt];
8159           else
8160             t = build_pointer_type
8161               (build_function_type (ffecom_tree_type[bt][kt], NULL_TREE));
8162
8163           t = build_decl (PARM_DECL,
8164                           ffecom_get_identifier_ (ffesymbol_text (s)),
8165                           t);
8166 #if BUILT_FOR_270
8167           DECL_ARTIFICIAL (t) = 1;
8168 #endif
8169           addr = TRUE;
8170           break;
8171
8172         case FFEINFO_whereCONSTANT:     /* Statement function. */
8173           assert (!ffecom_transform_only_dummies_);
8174           t = ffecom_gen_sfuncdef_ (s, bt, kt);
8175           break;
8176
8177         case FFEINFO_whereINTRINSIC:
8178           assert (!ffecom_transform_only_dummies_);
8179           break;                /* Let actual references generate their
8180                                    decls. */
8181
8182         default:
8183           assert ("FUNCTION where unheard of" == NULL);
8184           /* Fall through. */
8185         case FFEINFO_whereANY:
8186           t = error_mark_node;
8187           break;
8188         }
8189       break;
8190
8191     case FFEINFO_kindSUBROUTINE:
8192       switch (ffeinfo_where (ffesymbol_info (s)))
8193         {
8194         case FFEINFO_whereLOCAL:        /* Me. */
8195           assert (!ffecom_transform_only_dummies_);
8196           t = current_function_decl;
8197           break;
8198
8199         case FFEINFO_whereGLOBAL:
8200           assert (!ffecom_transform_only_dummies_);
8201
8202           if (((g = ffesymbol_global (s)) != NULL)
8203               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8204                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8205               && (ffeglobal_hook (g) != NULL_TREE)
8206               && ffe_is_globals ())
8207             {
8208               t = ffeglobal_hook (g);
8209               break;
8210             }
8211
8212           t = build_decl (FUNCTION_DECL,
8213                           ffecom_get_external_identifier_ (s),
8214                           ffecom_tree_subr_type);
8215           DECL_EXTERNAL (t) = 1;
8216           TREE_PUBLIC (t) = 1;
8217
8218           t = start_decl (t, FALSE);
8219           finish_decl (t, NULL_TREE, FALSE);
8220
8221           if ((g != NULL)
8222               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8223                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8224             ffeglobal_set_hook (g, t);
8225
8226           ffecom_save_tree_forever (t);
8227
8228           break;
8229
8230         case FFEINFO_whereDUMMY:
8231           assert (ffecom_transform_only_dummies_);
8232
8233           t = build_decl (PARM_DECL,
8234                           ffecom_get_identifier_ (ffesymbol_text (s)),
8235                           ffecom_tree_ptr_to_subr_type);
8236 #if BUILT_FOR_270
8237           DECL_ARTIFICIAL (t) = 1;
8238 #endif
8239           addr = TRUE;
8240           break;
8241
8242         case FFEINFO_whereINTRINSIC:
8243           assert (!ffecom_transform_only_dummies_);
8244           break;                /* Let actual references generate their
8245                                    decls. */
8246
8247         default:
8248           assert ("SUBROUTINE where unheard of" == NULL);
8249           /* Fall through. */
8250         case FFEINFO_whereANY:
8251           t = error_mark_node;
8252           break;
8253         }
8254       break;
8255
8256     case FFEINFO_kindPROGRAM:
8257       switch (ffeinfo_where (ffesymbol_info (s)))
8258         {
8259         case FFEINFO_whereLOCAL:        /* Me. */
8260           assert (!ffecom_transform_only_dummies_);
8261           t = current_function_decl;
8262           break;
8263
8264         case FFEINFO_whereCOMMON:
8265         case FFEINFO_whereDUMMY:
8266         case FFEINFO_whereGLOBAL:
8267         case FFEINFO_whereRESULT:
8268         case FFEINFO_whereFLEETING:
8269         case FFEINFO_whereFLEETING_CADDR:
8270         case FFEINFO_whereFLEETING_IADDR:
8271         case FFEINFO_whereIMMEDIATE:
8272         case FFEINFO_whereINTRINSIC:
8273         case FFEINFO_whereCONSTANT:
8274         case FFEINFO_whereCONSTANT_SUBOBJECT:
8275         default:
8276           assert ("PROGRAM where unheard of" == NULL);
8277           /* Fall through. */
8278         case FFEINFO_whereANY:
8279           t = error_mark_node;
8280           break;
8281         }
8282       break;
8283
8284     case FFEINFO_kindBLOCKDATA:
8285       switch (ffeinfo_where (ffesymbol_info (s)))
8286         {
8287         case FFEINFO_whereLOCAL:        /* Me. */
8288           assert (!ffecom_transform_only_dummies_);
8289           t = current_function_decl;
8290           break;
8291
8292         case FFEINFO_whereGLOBAL:
8293           assert (!ffecom_transform_only_dummies_);
8294
8295           t = build_decl (FUNCTION_DECL,
8296                           ffecom_get_external_identifier_ (s),
8297                           ffecom_tree_blockdata_type);
8298           DECL_EXTERNAL (t) = 1;
8299           TREE_PUBLIC (t) = 1;
8300
8301           t = start_decl (t, FALSE);
8302           finish_decl (t, NULL_TREE, FALSE);
8303
8304           ffecom_save_tree_forever (t);
8305
8306           break;
8307
8308         case FFEINFO_whereCOMMON:
8309         case FFEINFO_whereDUMMY:
8310         case FFEINFO_whereRESULT:
8311         case FFEINFO_whereFLEETING:
8312         case FFEINFO_whereFLEETING_CADDR:
8313         case FFEINFO_whereFLEETING_IADDR:
8314         case FFEINFO_whereIMMEDIATE:
8315         case FFEINFO_whereINTRINSIC:
8316         case FFEINFO_whereCONSTANT:
8317         case FFEINFO_whereCONSTANT_SUBOBJECT:
8318         default:
8319           assert ("BLOCKDATA where unheard of" == NULL);
8320           /* Fall through. */
8321         case FFEINFO_whereANY:
8322           t = error_mark_node;
8323           break;
8324         }
8325       break;
8326
8327     case FFEINFO_kindCOMMON:
8328       switch (ffeinfo_where (ffesymbol_info (s)))
8329         {
8330         case FFEINFO_whereLOCAL:
8331           assert (!ffecom_transform_only_dummies_);
8332           ffecom_transform_common_ (s);
8333           break;
8334
8335         case FFEINFO_whereNONE:
8336         case FFEINFO_whereCOMMON:
8337         case FFEINFO_whereDUMMY:
8338         case FFEINFO_whereGLOBAL:
8339         case FFEINFO_whereRESULT:
8340         case FFEINFO_whereFLEETING:
8341         case FFEINFO_whereFLEETING_CADDR:
8342         case FFEINFO_whereFLEETING_IADDR:
8343         case FFEINFO_whereIMMEDIATE:
8344         case FFEINFO_whereINTRINSIC:
8345         case FFEINFO_whereCONSTANT:
8346         case FFEINFO_whereCONSTANT_SUBOBJECT:
8347         default:
8348           assert ("COMMON where unheard of" == NULL);
8349           /* Fall through. */
8350         case FFEINFO_whereANY:
8351           t = error_mark_node;
8352           break;
8353         }
8354       break;
8355
8356     case FFEINFO_kindCONSTRUCT:
8357       switch (ffeinfo_where (ffesymbol_info (s)))
8358         {
8359         case FFEINFO_whereLOCAL:
8360           assert (!ffecom_transform_only_dummies_);
8361           break;
8362
8363         case FFEINFO_whereNONE:
8364         case FFEINFO_whereCOMMON:
8365         case FFEINFO_whereDUMMY:
8366         case FFEINFO_whereGLOBAL:
8367         case FFEINFO_whereRESULT:
8368         case FFEINFO_whereFLEETING:
8369         case FFEINFO_whereFLEETING_CADDR:
8370         case FFEINFO_whereFLEETING_IADDR:
8371         case FFEINFO_whereIMMEDIATE:
8372         case FFEINFO_whereINTRINSIC:
8373         case FFEINFO_whereCONSTANT:
8374         case FFEINFO_whereCONSTANT_SUBOBJECT:
8375         default:
8376           assert ("CONSTRUCT where unheard of" == NULL);
8377           /* Fall through. */
8378         case FFEINFO_whereANY:
8379           t = error_mark_node;
8380           break;
8381         }
8382       break;
8383
8384     case FFEINFO_kindNAMELIST:
8385       switch (ffeinfo_where (ffesymbol_info (s)))
8386         {
8387         case FFEINFO_whereLOCAL:
8388           assert (!ffecom_transform_only_dummies_);
8389           t = ffecom_transform_namelist_ (s);
8390           break;
8391
8392         case FFEINFO_whereNONE:
8393         case FFEINFO_whereCOMMON:
8394         case FFEINFO_whereDUMMY:
8395         case FFEINFO_whereGLOBAL:
8396         case FFEINFO_whereRESULT:
8397         case FFEINFO_whereFLEETING:
8398         case FFEINFO_whereFLEETING_CADDR:
8399         case FFEINFO_whereFLEETING_IADDR:
8400         case FFEINFO_whereIMMEDIATE:
8401         case FFEINFO_whereINTRINSIC:
8402         case FFEINFO_whereCONSTANT:
8403         case FFEINFO_whereCONSTANT_SUBOBJECT:
8404         default:
8405           assert ("NAMELIST where unheard of" == NULL);
8406           /* Fall through. */
8407         case FFEINFO_whereANY:
8408           t = error_mark_node;
8409           break;
8410         }
8411       break;
8412
8413     default:
8414       assert ("kind unheard of" == NULL);
8415       /* Fall through. */
8416     case FFEINFO_kindANY:
8417       t = error_mark_node;
8418       break;
8419     }
8420
8421   ffesymbol_hook (s).decl_tree = t;
8422   ffesymbol_hook (s).length_tree = tlen;
8423   ffesymbol_hook (s).addr = addr;
8424
8425   lineno = old_lineno;
8426   input_filename = old_input_filename;
8427
8428   return s;
8429 }
8430
8431 #endif
8432 /* Transform into ASSIGNable symbol.
8433
8434    Symbol has already been transformed, but for whatever reason, the
8435    resulting decl_tree has been deemed not usable for an ASSIGN target.
8436    (E.g. it isn't wide enough to hold a pointer.)  So, here we invent
8437    another local symbol of type void * and stuff that in the assign_tree
8438    argument.  The F77/F90 standards allow this implementation.  */
8439
8440 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8441 static ffesymbol
8442 ffecom_sym_transform_assign_ (ffesymbol s)
8443 {
8444   tree t;                       /* Transformed thingy. */
8445   int old_lineno = lineno;
8446   const char *old_input_filename = input_filename;
8447
8448   if (ffesymbol_sfdummyparent (s) == NULL)
8449     {
8450       input_filename = ffesymbol_where_filename (s);
8451       lineno = ffesymbol_where_filelinenum (s);
8452     }
8453   else
8454     {
8455       ffesymbol sf = ffesymbol_sfdummyparent (s);
8456
8457       input_filename = ffesymbol_where_filename (sf);
8458       lineno = ffesymbol_where_filelinenum (sf);
8459     }
8460
8461   assert (!ffecom_transform_only_dummies_);
8462
8463   t = build_decl (VAR_DECL,
8464                   ffecom_get_invented_identifier ("__g77_ASSIGN_%s",
8465                                                    ffesymbol_text (s)),
8466                   TREE_TYPE (null_pointer_node));
8467
8468   switch (ffesymbol_where (s))
8469     {
8470     case FFEINFO_whereLOCAL:
8471       /* Unlike for regular vars, SAVE status is easy to determine for
8472          ASSIGNed vars, since there's no initialization, there's no
8473          effective storage association (so "SAVE J" does not apply to
8474          K even given "EQUIVALENCE (J,K)"), there's no size issue
8475          to worry about, etc.  */
8476       if ((ffesymbol_is_save (s) || ffe_is_saveall ())
8477           && (ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8478           && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA))
8479         TREE_STATIC (t) = 1;    /* SAVEd in proc, make static. */
8480       else
8481         TREE_STATIC (t) = 0;    /* No need to make static. */
8482       break;
8483
8484     case FFEINFO_whereCOMMON:
8485       TREE_STATIC (t) = 1;      /* Assume COMMONs always SAVEd. */
8486       break;
8487
8488     case FFEINFO_whereDUMMY:
8489       /* Note that twinning a DUMMY means the caller won't see
8490          the ASSIGNed value.  But both F77 and F90 allow implementations
8491          to do this, i.e. disallow Fortran code that would try and
8492          take advantage of actually putting a label into a variable
8493          via a dummy argument (or any other storage association, for
8494          that matter).  */
8495       TREE_STATIC (t) = 0;
8496       break;
8497
8498     default:
8499       TREE_STATIC (t) = 0;
8500       break;
8501     }
8502
8503   t = start_decl (t, FALSE);
8504   finish_decl (t, NULL_TREE, FALSE);
8505
8506   ffesymbol_hook (s).assign_tree = t;
8507
8508   lineno = old_lineno;
8509   input_filename = old_input_filename;
8510
8511   return s;
8512 }
8513
8514 #endif
8515 /* Implement COMMON area in back end.
8516
8517    Because COMMON-based variables can be referenced in the dimension
8518    expressions of dummy (adjustable) arrays, and because dummies
8519    (in the gcc back end) need to be put in the outer binding level
8520    of a function (which has two binding levels, the outer holding
8521    the dummies and the inner holding the other vars), special care
8522    must be taken to handle COMMON areas.
8523
8524    The current strategy is basically to always tell the back end about
8525    the COMMON area as a top-level external reference to just a block
8526    of storage of the master type of that area (e.g. integer, real,
8527    character, whatever -- not a structure).  As a distinct action,
8528    if initial values are provided, tell the back end about the area
8529    as a top-level non-external (initialized) area and remember not to
8530    allow further initialization or expansion of the area.  Meanwhile,
8531    if no initialization happens at all, tell the back end about
8532    the largest size we've seen declared so the space does get reserved.
8533    (This function doesn't handle all that stuff, but it does some
8534    of the important things.)
8535
8536    Meanwhile, for COMMON variables themselves, just keep creating
8537    references like *((float *) (&common_area + offset)) each time
8538    we reference the variable.  In other words, don't make a VAR_DECL
8539    or any kind of component reference (like we used to do before 0.4),
8540    though we might do that as well just for debugging purposes (and
8541    stuff the rtl with the appropriate offset expression).  */
8542
8543 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8544 static void
8545 ffecom_transform_common_ (ffesymbol s)
8546 {
8547   ffestorag st = ffesymbol_storage (s);
8548   ffeglobal g = ffesymbol_global (s);
8549   tree cbt;
8550   tree cbtype;
8551   tree init;
8552   tree high;
8553   bool is_init = ffestorag_is_init (st);
8554
8555   assert (st != NULL);
8556
8557   if ((g == NULL)
8558       || (ffeglobal_type (g) != FFEGLOBAL_typeCOMMON))
8559     return;
8560
8561   /* First update the size of the area in global terms.  */
8562
8563   ffeglobal_size_common (s, ffestorag_size (st));
8564
8565   if (!ffeglobal_common_init (g))
8566     is_init = FALSE;    /* No explicit init, don't let erroneous joins init. */
8567
8568   cbt = ffeglobal_hook (g);
8569
8570   /* If we already have declared this common block for a previous program
8571      unit, and either we already initialized it or we don't have new
8572      initialization for it, just return what we have without changing it.  */
8573
8574   if ((cbt != NULL_TREE)
8575       && (!is_init
8576           || !DECL_EXTERNAL (cbt)))
8577     {
8578       if (st->hook == NULL) ffestorag_set_hook (st, cbt);
8579       return;
8580     }
8581
8582   /* Process inits.  */
8583
8584   if (is_init)
8585     {
8586       if (ffestorag_init (st) != NULL)
8587         {
8588           ffebld sexp;
8589
8590           /* Set the padding for the expression, so ffecom_expr
8591              knows to insert that many zeros.  */
8592           switch (ffebld_op (sexp = ffestorag_init (st)))
8593             {
8594             case FFEBLD_opCONTER:
8595               ffebld_conter_set_pad (sexp, ffestorag_modulo (st));
8596               break;
8597
8598             case FFEBLD_opARRTER:
8599               ffebld_arrter_set_pad (sexp, ffestorag_modulo (st));
8600               break;
8601
8602             case FFEBLD_opACCTER:
8603               ffebld_accter_set_pad (sexp, ffestorag_modulo (st));
8604               break;
8605
8606             default:
8607               assert ("bad op for cmn init (pad)" == NULL);
8608               break;
8609             }
8610
8611           init = ffecom_expr (sexp);
8612           if (init == error_mark_node)
8613             {                   /* Hopefully the back end complained! */
8614               init = NULL_TREE;
8615               if (cbt != NULL_TREE)
8616                 return;
8617             }
8618         }
8619       else
8620         init = error_mark_node;
8621     }
8622   else
8623     init = NULL_TREE;
8624
8625   /* cbtype must be permanently allocated!  */
8626
8627   /* Allocate the MAX of the areas so far, seen filewide.  */
8628   high = build_int_2 ((ffeglobal_common_size (g)
8629                        + ffeglobal_common_pad (g)) - 1, 0);
8630   TREE_TYPE (high) = ffecom_integer_type_node;
8631
8632   if (init)
8633     cbtype = build_array_type (char_type_node,
8634                                build_range_type (integer_type_node,
8635                                                  integer_zero_node,
8636                                                  high));
8637   else
8638     cbtype = build_array_type (char_type_node, NULL_TREE);
8639
8640   if (cbt == NULL_TREE)
8641     {
8642       cbt
8643         = build_decl (VAR_DECL,
8644                       ffecom_get_external_identifier_ (s),
8645                       cbtype);
8646       TREE_STATIC (cbt) = 1;
8647       TREE_PUBLIC (cbt) = 1;
8648     }
8649   else
8650     {
8651       assert (is_init);
8652       TREE_TYPE (cbt) = cbtype;
8653     }
8654   DECL_EXTERNAL (cbt) = init ? 0 : 1;
8655   DECL_INITIAL (cbt) = init ? error_mark_node : NULL_TREE;
8656
8657   cbt = start_decl (cbt, TRUE);
8658   if (ffeglobal_hook (g) != NULL)
8659     assert (cbt == ffeglobal_hook (g));
8660
8661   assert (!init || !DECL_EXTERNAL (cbt));
8662
8663   /* Make sure that any type can live in COMMON and be referenced
8664      without getting a bus error.  We could pick the most restrictive
8665      alignment of all entities actually placed in the COMMON, but
8666      this seems easy enough.  */
8667
8668   DECL_ALIGN (cbt) = BIGGEST_ALIGNMENT;
8669   DECL_USER_ALIGN (cbt) = 0;
8670
8671   if (is_init && (ffestorag_init (st) == NULL))
8672     init = ffecom_init_zero_ (cbt);
8673
8674   finish_decl (cbt, init, TRUE);
8675
8676   if (is_init)
8677     ffestorag_set_init (st, ffebld_new_any ());
8678
8679   if (init)
8680     {
8681       assert (DECL_SIZE_UNIT (cbt) != NULL_TREE);
8682       assert (TREE_CODE (DECL_SIZE_UNIT (cbt)) == INTEGER_CST);
8683       assert (0 == compare_tree_int (DECL_SIZE_UNIT (cbt),
8684                                      (ffeglobal_common_size (g)
8685                                       + ffeglobal_common_pad (g))));
8686     }
8687
8688   ffeglobal_set_hook (g, cbt);
8689
8690   ffestorag_set_hook (st, cbt);
8691
8692   ffecom_save_tree_forever (cbt);
8693 }
8694
8695 #endif
8696 /* Make master area for local EQUIVALENCE.  */
8697
8698 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8699 static void
8700 ffecom_transform_equiv_ (ffestorag eqst)
8701 {
8702   tree eqt;
8703   tree eqtype;
8704   tree init;
8705   tree high;
8706   bool is_init = ffestorag_is_init (eqst);
8707
8708   assert (eqst != NULL);
8709
8710   eqt = ffestorag_hook (eqst);
8711
8712   if (eqt != NULL_TREE)
8713     return;
8714
8715   /* Process inits.  */
8716
8717   if (is_init)
8718     {
8719       if (ffestorag_init (eqst) != NULL)
8720         {
8721           ffebld sexp;
8722
8723           /* Set the padding for the expression, so ffecom_expr
8724              knows to insert that many zeros.  */
8725           switch (ffebld_op (sexp = ffestorag_init (eqst)))
8726             {
8727             case FFEBLD_opCONTER:
8728               ffebld_conter_set_pad (sexp, ffestorag_modulo (eqst));
8729               break;
8730
8731             case FFEBLD_opARRTER:
8732               ffebld_arrter_set_pad (sexp, ffestorag_modulo (eqst));
8733               break;
8734
8735             case FFEBLD_opACCTER:
8736               ffebld_accter_set_pad (sexp, ffestorag_modulo (eqst));
8737               break;
8738
8739             default:
8740               assert ("bad op for eqv init (pad)" == NULL);
8741               break;
8742             }
8743
8744           init = ffecom_expr (sexp);
8745           if (init == error_mark_node)
8746             init = NULL_TREE;   /* Hopefully the back end complained! */
8747         }
8748       else
8749         init = error_mark_node;
8750     }
8751   else if (ffe_is_init_local_zero ())
8752     init = error_mark_node;
8753   else
8754     init = NULL_TREE;
8755
8756   ffecom_member_namelisted_ = FALSE;
8757   ffestorag_drive (ffestorag_list_equivs (eqst),
8758                    &ffecom_member_phase1_,
8759                    eqst);
8760
8761   high = build_int_2 ((ffestorag_size (eqst)
8762                        + ffestorag_modulo (eqst)) - 1, 0);
8763   TREE_TYPE (high) = ffecom_integer_type_node;
8764
8765   eqtype = build_array_type (char_type_node,
8766                              build_range_type (ffecom_integer_type_node,
8767                                                ffecom_integer_zero_node,
8768                                                high));
8769
8770   eqt = build_decl (VAR_DECL,
8771                     ffecom_get_invented_identifier ("__g77_equiv_%s",
8772                                                     ffesymbol_text
8773                                                     (ffestorag_symbol (eqst))),
8774                     eqtype);
8775   DECL_EXTERNAL (eqt) = 0;
8776   if (is_init
8777       || ffecom_member_namelisted_
8778 #ifdef FFECOM_sizeMAXSTACKITEM
8779       || (ffestorag_size (eqst) > FFECOM_sizeMAXSTACKITEM)
8780 #endif
8781       || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8782           && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
8783           && (ffestorag_is_save (eqst) || ffe_is_saveall ())))
8784     TREE_STATIC (eqt) = 1;
8785   else
8786     TREE_STATIC (eqt) = 0;
8787   TREE_PUBLIC (eqt) = 0;
8788   TREE_ADDRESSABLE (eqt) = 1;  /* Ensure non-register allocation */
8789   DECL_CONTEXT (eqt) = current_function_decl;
8790   if (init)
8791     DECL_INITIAL (eqt) = error_mark_node;
8792   else
8793     DECL_INITIAL (eqt) = NULL_TREE;
8794
8795   eqt = start_decl (eqt, FALSE);
8796
8797   /* Make sure that any type can live in EQUIVALENCE and be referenced
8798      without getting a bus error.  We could pick the most restrictive
8799      alignment of all entities actually placed in the EQUIVALENCE, but
8800      this seems easy enough.  */
8801
8802   DECL_ALIGN (eqt) = BIGGEST_ALIGNMENT;
8803   DECL_USER_ALIGN (eqt) = 0;
8804
8805   if ((!is_init && ffe_is_init_local_zero ())
8806       || (is_init && (ffestorag_init (eqst) == NULL)))
8807     init = ffecom_init_zero_ (eqt);
8808
8809   finish_decl (eqt, init, FALSE);
8810
8811   if (is_init)
8812     ffestorag_set_init (eqst, ffebld_new_any ());
8813
8814   {
8815     assert (TREE_CODE (DECL_SIZE_UNIT (eqt)) == INTEGER_CST);
8816     assert (0 == compare_tree_int (DECL_SIZE_UNIT (eqt),
8817                                    (ffestorag_size (eqst)
8818                                     + ffestorag_modulo (eqst))));
8819   }
8820
8821   ffestorag_set_hook (eqst, eqt);
8822
8823   ffestorag_drive (ffestorag_list_equivs (eqst),
8824                    &ffecom_member_phase2_,
8825                    eqst);
8826 }
8827
8828 #endif
8829 /* Implement NAMELIST in back end.  See f2c/format.c for more info.  */
8830
8831 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8832 static tree
8833 ffecom_transform_namelist_ (ffesymbol s)
8834 {
8835   tree nmlt;
8836   tree nmltype = ffecom_type_namelist_ ();
8837   tree nmlinits;
8838   tree nameinit;
8839   tree varsinit;
8840   tree nvarsinit;
8841   tree field;
8842   tree high;
8843   int i;
8844   static int mynumber = 0;
8845
8846   nmlt = build_decl (VAR_DECL,
8847                      ffecom_get_invented_identifier ("__g77_namelist_%d",
8848                                                      mynumber++),
8849                      nmltype);
8850   TREE_STATIC (nmlt) = 1;
8851   DECL_INITIAL (nmlt) = error_mark_node;
8852
8853   nmlt = start_decl (nmlt, FALSE);
8854
8855   /* Process inits.  */
8856
8857   i = strlen (ffesymbol_text (s));
8858
8859   high = build_int_2 (i, 0);
8860   TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
8861
8862   nameinit = ffecom_build_f2c_string_ (i + 1,
8863                                        ffesymbol_text (s));
8864   TREE_TYPE (nameinit)
8865     = build_type_variant
8866     (build_array_type
8867      (char_type_node,
8868       build_range_type (ffecom_f2c_ftnlen_type_node,
8869                         ffecom_f2c_ftnlen_one_node,
8870                         high)),
8871      1, 0);
8872   TREE_CONSTANT (nameinit) = 1;
8873   TREE_STATIC (nameinit) = 1;
8874   nameinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (nameinit)),
8875                        nameinit);
8876
8877   varsinit = ffecom_vardesc_array_ (s);
8878   varsinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (varsinit)),
8879                        varsinit);
8880   TREE_CONSTANT (varsinit) = 1;
8881   TREE_STATIC (varsinit) = 1;
8882
8883   {
8884     ffebld b;
8885
8886     for (i = 0, b = ffesymbol_namelist (s); b != NULL; b = ffebld_trail (b))
8887       ++i;
8888   }
8889   nvarsinit = build_int_2 (i, 0);
8890   TREE_TYPE (nvarsinit) = integer_type_node;
8891   TREE_CONSTANT (nvarsinit) = 1;
8892   TREE_STATIC (nvarsinit) = 1;
8893
8894   nmlinits = build_tree_list ((field = TYPE_FIELDS (nmltype)), nameinit);
8895   TREE_CHAIN (nmlinits) = build_tree_list ((field = TREE_CHAIN (field)),
8896                                            varsinit);
8897   TREE_CHAIN (TREE_CHAIN (nmlinits))
8898     = build_tree_list ((field = TREE_CHAIN (field)), nvarsinit);
8899
8900   nmlinits = build (CONSTRUCTOR, nmltype, NULL_TREE, nmlinits);
8901   TREE_CONSTANT (nmlinits) = 1;
8902   TREE_STATIC (nmlinits) = 1;
8903
8904   finish_decl (nmlt, nmlinits, FALSE);
8905
8906   nmlt = ffecom_1 (ADDR_EXPR, build_pointer_type (nmltype), nmlt);
8907
8908   return nmlt;
8909 }
8910
8911 #endif
8912
8913 /* A subroutine of ffecom_tree_canonize_ref_.  The incoming tree is
8914    analyzed on the assumption it is calculating a pointer to be
8915    indirected through.  It must return the proper decl and offset,
8916    taking into account different units of measurements for offsets.  */
8917
8918 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8919 static void
8920 ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
8921                            tree t)
8922 {
8923   switch (TREE_CODE (t))
8924     {
8925     case NOP_EXPR:
8926     case CONVERT_EXPR:
8927     case NON_LVALUE_EXPR:
8928       ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
8929       break;
8930
8931     case PLUS_EXPR:
8932       ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
8933       if ((*decl == NULL_TREE)
8934           || (*decl == error_mark_node))
8935         break;
8936
8937       if (TREE_CODE (TREE_OPERAND (t, 1)) == INTEGER_CST)
8938         {
8939           /* An offset into COMMON.  */
8940           *offset = fold (build (PLUS_EXPR, TREE_TYPE (*offset),
8941                                  *offset, TREE_OPERAND (t, 1)));
8942           /* Convert offset (presumably in bytes) into canonical units
8943              (presumably bits).  */
8944           *offset = size_binop (MULT_EXPR,
8945                                 convert (bitsizetype, *offset),
8946                                 TYPE_SIZE (TREE_TYPE (TREE_TYPE (t))));
8947           break;
8948         }
8949       /* Not a COMMON reference, so an unrecognized pattern.  */
8950       *decl = error_mark_node;
8951       break;
8952
8953     case PARM_DECL:
8954       *decl = t;
8955       *offset = bitsize_zero_node;
8956       break;
8957
8958     case ADDR_EXPR:
8959       if (TREE_CODE (TREE_OPERAND (t, 0)) == VAR_DECL)
8960         {
8961           /* A reference to COMMON.  */
8962           *decl = TREE_OPERAND (t, 0);
8963           *offset = bitsize_zero_node;
8964           break;
8965         }
8966       /* Fall through.  */
8967     default:
8968       /* Not a COMMON reference, so an unrecognized pattern.  */
8969       *decl = error_mark_node;
8970       break;
8971     }
8972 }
8973 #endif
8974
8975 /* Given a tree that is possibly intended for use as an lvalue, return
8976    information representing a canonical view of that tree as a decl, an
8977    offset into that decl, and a size for the lvalue.
8978
8979    If there's no applicable decl, NULL_TREE is returned for the decl,
8980    and the other fields are left undefined.
8981
8982    If the tree doesn't fit the recognizable forms, an ERROR_MARK node
8983    is returned for the decl, and the other fields are left undefined.
8984
8985    Otherwise, the decl returned currently is either a VAR_DECL or a
8986    PARM_DECL.
8987
8988    The offset returned is always valid, but of course not necessarily
8989    a constant, and not necessarily converted into the appropriate
8990    type, leaving that up to the caller (so as to avoid that overhead
8991    if the decls being looked at are different anyway).
8992
8993    If the size cannot be determined (e.g. an adjustable array),
8994    an ERROR_MARK node is returned for the size.  Otherwise, the
8995    size returned is valid, not necessarily a constant, and not
8996    necessarily converted into the appropriate type as with the
8997    offset.
8998
8999    Note that the offset and size expressions are expressed in the
9000    base storage units (usually bits) rather than in the units of
9001    the type of the decl, because two decls with different types
9002    might overlap but with apparently non-overlapping array offsets,
9003    whereas converting the array offsets to consistant offsets will
9004    reveal the overlap.  */
9005
9006 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9007 static void
9008 ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
9009                            tree *size, tree t)
9010 {
9011   /* The default path is to report a nonexistant decl.  */
9012   *decl = NULL_TREE;
9013
9014   if (t == NULL_TREE)
9015     return;
9016
9017   switch (TREE_CODE (t))
9018     {
9019     case ERROR_MARK:
9020     case IDENTIFIER_NODE:
9021     case INTEGER_CST:
9022     case REAL_CST:
9023     case COMPLEX_CST:
9024     case STRING_CST:
9025     case CONST_DECL:
9026     case PLUS_EXPR:
9027     case MINUS_EXPR:
9028     case MULT_EXPR:
9029     case TRUNC_DIV_EXPR:
9030     case CEIL_DIV_EXPR:
9031     case FLOOR_DIV_EXPR:
9032     case ROUND_DIV_EXPR:
9033     case TRUNC_MOD_EXPR:
9034     case CEIL_MOD_EXPR:
9035     case FLOOR_MOD_EXPR:
9036     case ROUND_MOD_EXPR:
9037     case RDIV_EXPR:
9038     case EXACT_DIV_EXPR:
9039     case FIX_TRUNC_EXPR:
9040     case FIX_CEIL_EXPR:
9041     case FIX_FLOOR_EXPR:
9042     case FIX_ROUND_EXPR:
9043     case FLOAT_EXPR:
9044     case NEGATE_EXPR:
9045     case MIN_EXPR:
9046     case MAX_EXPR:
9047     case ABS_EXPR:
9048     case FFS_EXPR:
9049     case LSHIFT_EXPR:
9050     case RSHIFT_EXPR:
9051     case LROTATE_EXPR:
9052     case RROTATE_EXPR:
9053     case BIT_IOR_EXPR:
9054     case BIT_XOR_EXPR:
9055     case BIT_AND_EXPR:
9056     case BIT_ANDTC_EXPR:
9057     case BIT_NOT_EXPR:
9058     case TRUTH_ANDIF_EXPR:
9059     case TRUTH_ORIF_EXPR:
9060     case TRUTH_AND_EXPR:
9061     case TRUTH_OR_EXPR:
9062     case TRUTH_XOR_EXPR:
9063     case TRUTH_NOT_EXPR:
9064     case LT_EXPR:
9065     case LE_EXPR:
9066     case GT_EXPR:
9067     case GE_EXPR:
9068     case EQ_EXPR:
9069     case NE_EXPR:
9070     case COMPLEX_EXPR:
9071     case CONJ_EXPR:
9072     case REALPART_EXPR:
9073     case IMAGPART_EXPR:
9074     case LABEL_EXPR:
9075     case COMPONENT_REF:
9076     case COMPOUND_EXPR:
9077     case ADDR_EXPR:
9078       return;
9079
9080     case VAR_DECL:
9081     case PARM_DECL:
9082       *decl = t;
9083       *offset = bitsize_zero_node;
9084       *size = TYPE_SIZE (TREE_TYPE (t));
9085       return;
9086
9087     case ARRAY_REF:
9088       {
9089         tree array = TREE_OPERAND (t, 0);
9090         tree element = TREE_OPERAND (t, 1);
9091         tree init_offset;
9092
9093         if ((array == NULL_TREE)
9094             || (element == NULL_TREE))
9095           {
9096             *decl = error_mark_node;
9097             return;
9098           }
9099
9100         ffecom_tree_canonize_ref_ (decl, &init_offset, size,
9101                                    array);
9102         if ((*decl == NULL_TREE)
9103             || (*decl == error_mark_node))
9104           return;
9105
9106         /* Calculate ((element - base) * NBBY) + init_offset.  */
9107         *offset = fold (build (MINUS_EXPR, TREE_TYPE (element),
9108                                element,
9109                                TYPE_MIN_VALUE (TYPE_DOMAIN
9110                                                (TREE_TYPE (array)))));
9111
9112         *offset = size_binop (MULT_EXPR,
9113                               convert (bitsizetype, *offset),
9114                               TYPE_SIZE (TREE_TYPE (TREE_TYPE (array))));
9115
9116         *offset = size_binop (PLUS_EXPR, init_offset, *offset);
9117
9118         *size = TYPE_SIZE (TREE_TYPE (t));
9119         return;
9120       }
9121
9122     case INDIRECT_REF:
9123
9124       /* Most of this code is to handle references to COMMON.  And so
9125          far that is useful only for calling library functions, since
9126          external (user) functions might reference common areas.  But
9127          even calling an external function, it's worthwhile to decode
9128          COMMON references because if not storing into COMMON, we don't
9129          want COMMON-based arguments to gratuitously force use of a
9130          temporary.  */
9131
9132       *size = TYPE_SIZE (TREE_TYPE (t));
9133
9134       ffecom_tree_canonize_ptr_ (decl, offset,
9135                                  TREE_OPERAND (t, 0));
9136
9137       return;
9138
9139     case CONVERT_EXPR:
9140     case NOP_EXPR:
9141     case MODIFY_EXPR:
9142     case NON_LVALUE_EXPR:
9143     case RESULT_DECL:
9144     case FIELD_DECL:
9145     case COND_EXPR:             /* More cases than we can handle. */
9146     case SAVE_EXPR:
9147     case REFERENCE_EXPR:
9148     case PREDECREMENT_EXPR:
9149     case PREINCREMENT_EXPR:
9150     case POSTDECREMENT_EXPR:
9151     case POSTINCREMENT_EXPR:
9152     case CALL_EXPR:
9153     default:
9154       *decl = error_mark_node;
9155       return;
9156     }
9157 }
9158 #endif
9159
9160 /* Do divide operation appropriate to type of operands.  */
9161
9162 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9163 static tree
9164 ffecom_tree_divide_ (tree tree_type, tree left, tree right,
9165                      tree dest_tree, ffebld dest, bool *dest_used,
9166                      tree hook)
9167 {
9168   if ((left == error_mark_node)
9169       || (right == error_mark_node))
9170     return error_mark_node;
9171
9172   switch (TREE_CODE (tree_type))
9173     {
9174     case INTEGER_TYPE:
9175       return ffecom_2 (TRUNC_DIV_EXPR, tree_type,
9176                        left,
9177                        right);
9178
9179     case COMPLEX_TYPE:
9180       if (! optimize_size)
9181         return ffecom_2 (RDIV_EXPR, tree_type,
9182                          left,
9183                          right);
9184       {
9185         ffecomGfrt ix;
9186
9187         if (TREE_TYPE (tree_type)
9188             == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9189           ix = FFECOM_gfrtDIV_CC;       /* Overlapping result okay. */
9190         else
9191           ix = FFECOM_gfrtDIV_ZZ;       /* Overlapping result okay. */
9192
9193         left = ffecom_1 (ADDR_EXPR,
9194                          build_pointer_type (TREE_TYPE (left)),
9195                          left);
9196         left = build_tree_list (NULL_TREE, left);
9197         right = ffecom_1 (ADDR_EXPR,
9198                           build_pointer_type (TREE_TYPE (right)),
9199                           right);
9200         right = build_tree_list (NULL_TREE, right);
9201         TREE_CHAIN (left) = right;
9202
9203         return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9204                              ffecom_gfrt_kindtype (ix),
9205                              ffe_is_f2c_library (),
9206                              tree_type,
9207                              left,
9208                              dest_tree, dest, dest_used,
9209                              NULL_TREE, TRUE, hook);
9210       }
9211       break;
9212
9213     case RECORD_TYPE:
9214       {
9215         ffecomGfrt ix;
9216
9217         if (TREE_TYPE (TYPE_FIELDS (tree_type))
9218             == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9219           ix = FFECOM_gfrtDIV_CC;       /* Overlapping result okay. */
9220         else
9221           ix = FFECOM_gfrtDIV_ZZ;       /* Overlapping result okay. */
9222
9223         left = ffecom_1 (ADDR_EXPR,
9224                          build_pointer_type (TREE_TYPE (left)),
9225                          left);
9226         left = build_tree_list (NULL_TREE, left);
9227         right = ffecom_1 (ADDR_EXPR,
9228                           build_pointer_type (TREE_TYPE (right)),
9229                           right);
9230         right = build_tree_list (NULL_TREE, right);
9231         TREE_CHAIN (left) = right;
9232
9233         return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9234                              ffecom_gfrt_kindtype (ix),
9235                              ffe_is_f2c_library (),
9236                              tree_type,
9237                              left,
9238                              dest_tree, dest, dest_used,
9239                              NULL_TREE, TRUE, hook);
9240       }
9241       break;
9242
9243     default:
9244       return ffecom_2 (RDIV_EXPR, tree_type,
9245                        left,
9246                        right);
9247     }
9248 }
9249
9250 #endif
9251 /* Build type info for non-dummy variable.  */
9252
9253 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9254 static tree
9255 ffecom_type_localvar_ (ffesymbol s, ffeinfoBasictype bt,
9256                        ffeinfoKindtype kt)
9257 {
9258   tree type;
9259   ffebld dl;
9260   ffebld dim;
9261   tree lowt;
9262   tree hight;
9263
9264   type = ffecom_tree_type[bt][kt];
9265   if (bt == FFEINFO_basictypeCHARACTER)
9266     {
9267       hight = build_int_2 (ffesymbol_size (s), 0);
9268       TREE_TYPE (hight) = ffecom_f2c_ftnlen_type_node;
9269
9270       type
9271         = build_array_type
9272           (type,
9273            build_range_type (ffecom_f2c_ftnlen_type_node,
9274                              ffecom_f2c_ftnlen_one_node,
9275                              hight));
9276       type = ffecom_check_size_overflow_ (s, type, FALSE);
9277     }
9278
9279   for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
9280     {
9281       if (type == error_mark_node)
9282         break;
9283
9284       dim = ffebld_head (dl);
9285       assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
9286
9287       if (ffebld_left (dim) == NULL)
9288         lowt = integer_one_node;
9289       else
9290         lowt = ffecom_expr (ffebld_left (dim));
9291
9292       if (TREE_CODE (lowt) != INTEGER_CST)
9293         lowt = variable_size (lowt);
9294
9295       assert (ffebld_right (dim) != NULL);
9296       hight = ffecom_expr (ffebld_right (dim));
9297
9298       if (TREE_CODE (hight) != INTEGER_CST)
9299         hight = variable_size (hight);
9300
9301       type = build_array_type (type,
9302                                build_range_type (ffecom_integer_type_node,
9303                                                  lowt, hight));
9304       type = ffecom_check_size_overflow_ (s, type, FALSE);
9305     }
9306
9307   return type;
9308 }
9309
9310 #endif
9311 /* Build Namelist type.  */
9312
9313 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9314 static tree
9315 ffecom_type_namelist_ ()
9316 {
9317   static tree type = NULL_TREE;
9318
9319   if (type == NULL_TREE)
9320     {
9321       static tree namefield, varsfield, nvarsfield;
9322       tree vardesctype;
9323
9324       vardesctype = ffecom_type_vardesc_ ();
9325
9326       type = make_node (RECORD_TYPE);
9327
9328       vardesctype = build_pointer_type (build_pointer_type (vardesctype));
9329
9330       namefield = ffecom_decl_field (type, NULL_TREE, "name",
9331                                      string_type_node);
9332       varsfield = ffecom_decl_field (type, namefield, "vars", vardesctype);
9333       nvarsfield = ffecom_decl_field (type, varsfield, "nvars",
9334                                       integer_type_node);
9335
9336       TYPE_FIELDS (type) = namefield;
9337       layout_type (type);
9338
9339       ggc_add_tree_root (&type, 1);
9340     }
9341
9342   return type;
9343 }
9344
9345 #endif
9346
9347 /* Build Vardesc type.  */
9348
9349 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9350 static tree
9351 ffecom_type_vardesc_ ()
9352 {
9353   static tree type = NULL_TREE;
9354   static tree namefield, addrfield, dimsfield, typefield;
9355
9356   if (type == NULL_TREE)
9357     {
9358       type = make_node (RECORD_TYPE);
9359
9360       namefield = ffecom_decl_field (type, NULL_TREE, "name",
9361                                      string_type_node);
9362       addrfield = ffecom_decl_field (type, namefield, "addr",
9363                                      string_type_node);
9364       dimsfield = ffecom_decl_field (type, addrfield, "dims",
9365                                      ffecom_f2c_ptr_to_ftnlen_type_node);
9366       typefield = ffecom_decl_field (type, dimsfield, "type",
9367                                      integer_type_node);
9368
9369       TYPE_FIELDS (type) = namefield;
9370       layout_type (type);
9371
9372       ggc_add_tree_root (&type, 1);
9373     }
9374
9375   return type;
9376 }
9377
9378 #endif
9379
9380 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9381 static tree
9382 ffecom_vardesc_ (ffebld expr)
9383 {
9384   ffesymbol s;
9385
9386   assert (ffebld_op (expr) == FFEBLD_opSYMTER);
9387   s = ffebld_symter (expr);
9388
9389   if (ffesymbol_hook (s).vardesc_tree == NULL_TREE)
9390     {
9391       int i;
9392       tree vardesctype = ffecom_type_vardesc_ ();
9393       tree var;
9394       tree nameinit;
9395       tree dimsinit;
9396       tree addrinit;
9397       tree typeinit;
9398       tree field;
9399       tree varinits;
9400       static int mynumber = 0;
9401
9402       var = build_decl (VAR_DECL,
9403                         ffecom_get_invented_identifier ("__g77_vardesc_%d",
9404                                                         mynumber++),
9405                         vardesctype);
9406       TREE_STATIC (var) = 1;
9407       DECL_INITIAL (var) = error_mark_node;
9408
9409       var = start_decl (var, FALSE);
9410
9411       /* Process inits.  */
9412
9413       nameinit = ffecom_build_f2c_string_ ((i = strlen (ffesymbol_text (s)))
9414                                            + 1,
9415                                            ffesymbol_text (s));
9416       TREE_TYPE (nameinit)
9417         = build_type_variant
9418         (build_array_type
9419          (char_type_node,
9420           build_range_type (integer_type_node,
9421                             integer_one_node,
9422                             build_int_2 (i, 0))),
9423          1, 0);
9424       TREE_CONSTANT (nameinit) = 1;
9425       TREE_STATIC (nameinit) = 1;
9426       nameinit = ffecom_1 (ADDR_EXPR,
9427                            build_pointer_type (TREE_TYPE (nameinit)),
9428                            nameinit);
9429
9430       addrinit = ffecom_arg_ptr_to_expr (expr, &typeinit);
9431
9432       dimsinit = ffecom_vardesc_dims_ (s);
9433
9434       if (typeinit == NULL_TREE)
9435         {
9436           ffeinfoBasictype bt = ffesymbol_basictype (s);
9437           ffeinfoKindtype kt = ffesymbol_kindtype (s);
9438           int tc = ffecom_f2c_typecode (bt, kt);
9439
9440           assert (tc != -1);
9441           typeinit = build_int_2 (tc, (tc < 0) ? -1 : 0);
9442         }
9443       else
9444         typeinit = ffecom_1 (NEGATE_EXPR, TREE_TYPE (typeinit), typeinit);
9445
9446       varinits = build_tree_list ((field = TYPE_FIELDS (vardesctype)),
9447                                   nameinit);
9448       TREE_CHAIN (varinits) = build_tree_list ((field = TREE_CHAIN (field)),
9449                                                addrinit);
9450       TREE_CHAIN (TREE_CHAIN (varinits))
9451         = build_tree_list ((field = TREE_CHAIN (field)), dimsinit);
9452       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (varinits)))
9453         = build_tree_list ((field = TREE_CHAIN (field)), typeinit);
9454
9455       varinits = build (CONSTRUCTOR, vardesctype, NULL_TREE, varinits);
9456       TREE_CONSTANT (varinits) = 1;
9457       TREE_STATIC (varinits) = 1;
9458
9459       finish_decl (var, varinits, FALSE);
9460
9461       var = ffecom_1 (ADDR_EXPR, build_pointer_type (vardesctype), var);
9462
9463       ffesymbol_hook (s).vardesc_tree = var;
9464     }
9465
9466   return ffesymbol_hook (s).vardesc_tree;
9467 }
9468
9469 #endif
9470 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9471 static tree
9472 ffecom_vardesc_array_ (ffesymbol s)
9473 {
9474   ffebld b;
9475   tree list;
9476   tree item = NULL_TREE;
9477   tree var;
9478   int i;
9479   static int mynumber = 0;
9480
9481   for (i = 0, list = NULL_TREE, b = ffesymbol_namelist (s);
9482        b != NULL;
9483        b = ffebld_trail (b), ++i)
9484     {
9485       tree t;
9486
9487       t = ffecom_vardesc_ (ffebld_head (b));
9488
9489       if (list == NULL_TREE)
9490         list = item = build_tree_list (NULL_TREE, t);
9491       else
9492         {
9493           TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9494           item = TREE_CHAIN (item);
9495         }
9496     }
9497
9498   item = build_array_type (build_pointer_type (ffecom_type_vardesc_ ()),
9499                            build_range_type (integer_type_node,
9500                                              integer_one_node,
9501                                              build_int_2 (i, 0)));
9502   list = build (CONSTRUCTOR, item, NULL_TREE, list);
9503   TREE_CONSTANT (list) = 1;
9504   TREE_STATIC (list) = 1;
9505
9506   var = ffecom_get_invented_identifier ("__g77_vardesc_array_%d", mynumber++);
9507   var = build_decl (VAR_DECL, var, item);
9508   TREE_STATIC (var) = 1;
9509   DECL_INITIAL (var) = error_mark_node;
9510   var = start_decl (var, FALSE);
9511   finish_decl (var, list, FALSE);
9512
9513   return var;
9514 }
9515
9516 #endif
9517 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9518 static tree
9519 ffecom_vardesc_dims_ (ffesymbol s)
9520 {
9521   if (ffesymbol_dims (s) == NULL)
9522     return convert (ffecom_f2c_ptr_to_ftnlen_type_node,
9523                     integer_zero_node);
9524
9525   {
9526     ffebld b;
9527     ffebld e;
9528     tree list;
9529     tree backlist;
9530     tree item = NULL_TREE;
9531     tree var;
9532     tree numdim;
9533     tree numelem;
9534     tree baseoff = NULL_TREE;
9535     static int mynumber = 0;
9536
9537     numdim = build_int_2 ((int) ffesymbol_rank (s), 0);
9538     TREE_TYPE (numdim) = ffecom_f2c_ftnlen_type_node;
9539
9540     numelem = ffecom_expr (ffesymbol_arraysize (s));
9541     TREE_TYPE (numelem) = ffecom_f2c_ftnlen_type_node;
9542
9543     list = NULL_TREE;
9544     backlist = NULL_TREE;
9545     for (b = ffesymbol_dims (s), e = ffesymbol_extents (s);
9546          b != NULL;
9547          b = ffebld_trail (b), e = ffebld_trail (e))
9548       {
9549         tree t;
9550         tree low;
9551         tree back;
9552
9553         if (ffebld_trail (b) == NULL)
9554           t = NULL_TREE;
9555         else
9556           {
9557             t = convert (ffecom_f2c_ftnlen_type_node,
9558                          ffecom_expr (ffebld_head (e)));
9559
9560             if (list == NULL_TREE)
9561               list = item = build_tree_list (NULL_TREE, t);
9562             else
9563               {
9564                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9565                 item = TREE_CHAIN (item);
9566               }
9567           }
9568
9569         if (ffebld_left (ffebld_head (b)) == NULL)
9570           low = ffecom_integer_one_node;
9571         else
9572           low = ffecom_expr (ffebld_left (ffebld_head (b)));
9573         low = convert (ffecom_f2c_ftnlen_type_node, low);
9574
9575         back = build_tree_list (low, t);
9576         TREE_CHAIN (back) = backlist;
9577         backlist = back;
9578       }
9579
9580     for (item = backlist; item != NULL_TREE; item = TREE_CHAIN (item))
9581       {
9582         if (TREE_VALUE (item) == NULL_TREE)
9583           baseoff = TREE_PURPOSE (item);
9584         else
9585           baseoff = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
9586                               TREE_PURPOSE (item),
9587                               ffecom_2 (MULT_EXPR,
9588                                         ffecom_f2c_ftnlen_type_node,
9589                                         TREE_VALUE (item),
9590                                         baseoff));
9591       }
9592
9593     /* backlist now dead, along with all TREE_PURPOSEs on it.  */
9594
9595     baseoff = build_tree_list (NULL_TREE, baseoff);
9596     TREE_CHAIN (baseoff) = list;
9597
9598     numelem = build_tree_list (NULL_TREE, numelem);
9599     TREE_CHAIN (numelem) = baseoff;
9600
9601     numdim = build_tree_list (NULL_TREE, numdim);
9602     TREE_CHAIN (numdim) = numelem;
9603
9604     item = build_array_type (ffecom_f2c_ftnlen_type_node,
9605                              build_range_type (integer_type_node,
9606                                                integer_zero_node,
9607                                                build_int_2
9608                                                ((int) ffesymbol_rank (s)
9609                                                 + 2, 0)));
9610     list = build (CONSTRUCTOR, item, NULL_TREE, numdim);
9611     TREE_CONSTANT (list) = 1;
9612     TREE_STATIC (list) = 1;
9613
9614     var = ffecom_get_invented_identifier ("__g77_dims_%d", mynumber++);
9615     var = build_decl (VAR_DECL, var, item);
9616     TREE_STATIC (var) = 1;
9617     DECL_INITIAL (var) = error_mark_node;
9618     var = start_decl (var, FALSE);
9619     finish_decl (var, list, FALSE);
9620
9621     var = ffecom_1 (ADDR_EXPR, build_pointer_type (item), var);
9622
9623     return var;
9624   }
9625 }
9626
9627 #endif
9628 /* Essentially does a "fold (build1 (code, type, node))" while checking
9629    for certain housekeeping things.
9630
9631    NOTE: for building an ADDR_EXPR around a FUNCTION_DECL, use
9632    ffecom_1_fn instead.  */
9633
9634 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9635 tree
9636 ffecom_1 (enum tree_code code, tree type, tree node)
9637 {
9638   tree item;
9639
9640   if ((node == error_mark_node)
9641       || (type == error_mark_node))
9642     return error_mark_node;
9643
9644   if (code == ADDR_EXPR)
9645     {
9646       if (!mark_addressable (node))
9647         assert ("can't mark_addressable this node!" == NULL);
9648     }
9649
9650   switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9651     {
9652       tree realtype;
9653
9654     case REALPART_EXPR:
9655       item = build (COMPONENT_REF, type, node, TYPE_FIELDS (TREE_TYPE (node)));
9656       break;
9657
9658     case IMAGPART_EXPR:
9659       item = build (COMPONENT_REF, type, node, TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (node))));
9660       break;
9661
9662
9663     case NEGATE_EXPR:
9664       if (TREE_CODE (type) != RECORD_TYPE)
9665         {
9666           item = build1 (code, type, node);
9667           break;
9668         }
9669       node = ffecom_stabilize_aggregate_ (node);
9670       realtype = TREE_TYPE (TYPE_FIELDS (type));
9671       item =
9672         ffecom_2 (COMPLEX_EXPR, type,
9673                   ffecom_1 (NEGATE_EXPR, realtype,
9674                             ffecom_1 (REALPART_EXPR, realtype,
9675                                       node)),
9676                   ffecom_1 (NEGATE_EXPR, realtype,
9677                             ffecom_1 (IMAGPART_EXPR, realtype,
9678                                       node)));
9679       break;
9680
9681     default:
9682       item = build1 (code, type, node);
9683       break;
9684     }
9685
9686   if (TREE_SIDE_EFFECTS (node))
9687     TREE_SIDE_EFFECTS (item) = 1;
9688   if ((code == ADDR_EXPR) && staticp (node))
9689     TREE_CONSTANT (item) = 1;
9690   return fold (item);
9691 }
9692 #endif
9693
9694 /* Like ffecom_1 (ADDR_EXPR, TREE_TYPE (node), node), except
9695    handles TREE_CODE (node) == FUNCTION_DECL.  In particular,
9696    does not set TREE_ADDRESSABLE (because calling an inline
9697    function does not mean the function needs to be separately
9698    compiled).  */
9699
9700 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9701 tree
9702 ffecom_1_fn (tree node)
9703 {
9704   tree item;
9705   tree type;
9706
9707   if (node == error_mark_node)
9708     return error_mark_node;
9709
9710   type = build_type_variant (TREE_TYPE (node),
9711                              TREE_READONLY (node),
9712                              TREE_THIS_VOLATILE (node));
9713   item = build1 (ADDR_EXPR,
9714                  build_pointer_type (type), node);
9715   if (TREE_SIDE_EFFECTS (node))
9716     TREE_SIDE_EFFECTS (item) = 1;
9717   if (staticp (node))
9718     TREE_CONSTANT (item) = 1;
9719   return fold (item);
9720 }
9721 #endif
9722
9723 /* Essentially does a "fold (build (code, type, node1, node2))" while
9724    checking for certain housekeeping things.  */
9725
9726 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9727 tree
9728 ffecom_2 (enum tree_code code, tree type, tree node1,
9729           tree node2)
9730 {
9731   tree item;
9732
9733   if ((node1 == error_mark_node)
9734       || (node2 == error_mark_node)
9735       || (type == error_mark_node))
9736     return error_mark_node;
9737
9738   switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9739     {
9740       tree a, b, c, d, realtype;
9741
9742     case CONJ_EXPR:
9743       assert ("no CONJ_EXPR support yet" == NULL);
9744       return error_mark_node;
9745
9746     case COMPLEX_EXPR:
9747       item = build_tree_list (TYPE_FIELDS (type), node1);
9748       TREE_CHAIN (item) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), node2);
9749       item = build (CONSTRUCTOR, type, NULL_TREE, item);
9750       break;
9751
9752     case PLUS_EXPR:
9753       if (TREE_CODE (type) != RECORD_TYPE)
9754         {
9755           item = build (code, type, node1, node2);
9756           break;
9757         }
9758       node1 = ffecom_stabilize_aggregate_ (node1);
9759       node2 = ffecom_stabilize_aggregate_ (node2);
9760       realtype = TREE_TYPE (TYPE_FIELDS (type));
9761       item =
9762         ffecom_2 (COMPLEX_EXPR, type,
9763                   ffecom_2 (PLUS_EXPR, realtype,
9764                             ffecom_1 (REALPART_EXPR, realtype,
9765                                       node1),
9766                             ffecom_1 (REALPART_EXPR, realtype,
9767                                       node2)),
9768                   ffecom_2 (PLUS_EXPR, realtype,
9769                             ffecom_1 (IMAGPART_EXPR, realtype,
9770                                       node1),
9771                             ffecom_1 (IMAGPART_EXPR, realtype,
9772                                       node2)));
9773       break;
9774
9775     case MINUS_EXPR:
9776       if (TREE_CODE (type) != RECORD_TYPE)
9777         {
9778           item = build (code, type, node1, node2);
9779           break;
9780         }
9781       node1 = ffecom_stabilize_aggregate_ (node1);
9782       node2 = ffecom_stabilize_aggregate_ (node2);
9783       realtype = TREE_TYPE (TYPE_FIELDS (type));
9784       item =
9785         ffecom_2 (COMPLEX_EXPR, type,
9786                   ffecom_2 (MINUS_EXPR, realtype,
9787                             ffecom_1 (REALPART_EXPR, realtype,
9788                                       node1),
9789                             ffecom_1 (REALPART_EXPR, realtype,
9790                                       node2)),
9791                   ffecom_2 (MINUS_EXPR, realtype,
9792                             ffecom_1 (IMAGPART_EXPR, realtype,
9793                                       node1),
9794                             ffecom_1 (IMAGPART_EXPR, realtype,
9795                                       node2)));
9796       break;
9797
9798     case MULT_EXPR:
9799       if (TREE_CODE (type) != RECORD_TYPE)
9800         {
9801           item = build (code, type, node1, node2);
9802           break;
9803         }
9804       node1 = ffecom_stabilize_aggregate_ (node1);
9805       node2 = ffecom_stabilize_aggregate_ (node2);
9806       realtype = TREE_TYPE (TYPE_FIELDS (type));
9807       a = save_expr (ffecom_1 (REALPART_EXPR, realtype,
9808                                node1));
9809       b = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
9810                                node1));
9811       c = save_expr (ffecom_1 (REALPART_EXPR, realtype,
9812                                node2));
9813       d = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
9814                                node2));
9815       item =
9816         ffecom_2 (COMPLEX_EXPR, type,
9817                   ffecom_2 (MINUS_EXPR, realtype,
9818                             ffecom_2 (MULT_EXPR, realtype,
9819                                       a,
9820                                       c),
9821                             ffecom_2 (MULT_EXPR, realtype,
9822                                       b,
9823                                       d)),
9824                   ffecom_2 (PLUS_EXPR, realtype,
9825                             ffecom_2 (MULT_EXPR, realtype,
9826                                       a,
9827                                       d),
9828                             ffecom_2 (MULT_EXPR, realtype,
9829                                       c,
9830                                       b)));
9831       break;
9832
9833     case EQ_EXPR:
9834       if ((TREE_CODE (node1) != RECORD_TYPE)
9835           && (TREE_CODE (node2) != RECORD_TYPE))
9836         {
9837           item = build (code, type, node1, node2);
9838           break;
9839         }
9840       assert (TREE_CODE (node1) == RECORD_TYPE);
9841       assert (TREE_CODE (node2) == RECORD_TYPE);
9842       node1 = ffecom_stabilize_aggregate_ (node1);
9843       node2 = ffecom_stabilize_aggregate_ (node2);
9844       realtype = TREE_TYPE (TYPE_FIELDS (type));
9845       item =
9846         ffecom_2 (TRUTH_ANDIF_EXPR, type,
9847                   ffecom_2 (code, type,
9848                             ffecom_1 (REALPART_EXPR, realtype,
9849                                       node1),
9850                             ffecom_1 (REALPART_EXPR, realtype,
9851                                       node2)),
9852                   ffecom_2 (code, type,
9853                             ffecom_1 (IMAGPART_EXPR, realtype,
9854                                       node1),
9855                             ffecom_1 (IMAGPART_EXPR, realtype,
9856                                       node2)));
9857       break;
9858
9859     case NE_EXPR:
9860       if ((TREE_CODE (node1) != RECORD_TYPE)
9861           && (TREE_CODE (node2) != RECORD_TYPE))
9862         {
9863           item = build (code, type, node1, node2);
9864           break;
9865         }
9866       assert (TREE_CODE (node1) == RECORD_TYPE);
9867       assert (TREE_CODE (node2) == RECORD_TYPE);
9868       node1 = ffecom_stabilize_aggregate_ (node1);
9869       node2 = ffecom_stabilize_aggregate_ (node2);
9870       realtype = TREE_TYPE (TYPE_FIELDS (type));
9871       item =
9872         ffecom_2 (TRUTH_ORIF_EXPR, type,
9873                   ffecom_2 (code, type,
9874                             ffecom_1 (REALPART_EXPR, realtype,
9875                                       node1),
9876                             ffecom_1 (REALPART_EXPR, realtype,
9877                                       node2)),
9878                   ffecom_2 (code, type,
9879                             ffecom_1 (IMAGPART_EXPR, realtype,
9880                                       node1),
9881                             ffecom_1 (IMAGPART_EXPR, realtype,
9882                                       node2)));
9883       break;
9884
9885     default:
9886       item = build (code, type, node1, node2);
9887       break;
9888     }
9889
9890   if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2))
9891     TREE_SIDE_EFFECTS (item) = 1;
9892   return fold (item);
9893 }
9894
9895 #endif
9896 /* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint
9897
9898    ffesymbol s;  // the ENTRY point itself
9899    if (ffecom_2pass_advise_entrypoint(s))
9900        // the ENTRY point has been accepted
9901
9902    Does whatever compiler needs to do when it learns about the entrypoint,
9903    like determine the return type of the master function, count the
9904    number of entrypoints, etc.  Returns FALSE if the return type is
9905    not compatible with the return type(s) of other entrypoint(s).
9906
9907    NOTE: for every call to this fn that returns TRUE, _do_entrypoint must
9908    later (after _finish_progunit) be called with the same entrypoint(s)
9909    as passed to this fn for which TRUE was returned.
9910
9911    03-Jan-92  JCB  2.0
9912       Return FALSE if the return type conflicts with previous entrypoints.  */
9913
9914 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9915 bool
9916 ffecom_2pass_advise_entrypoint (ffesymbol entry)
9917 {
9918   ffebld list;                  /* opITEM. */
9919   ffebld mlist;                 /* opITEM. */
9920   ffebld plist;                 /* opITEM. */
9921   ffebld arg;                   /* ffebld_head(opITEM). */
9922   ffebld item;                  /* opITEM. */
9923   ffesymbol s;                  /* ffebld_symter(arg). */
9924   ffeinfoBasictype bt = ffesymbol_basictype (entry);
9925   ffeinfoKindtype kt = ffesymbol_kindtype (entry);
9926   ffetargetCharacterSize size = ffesymbol_size (entry);
9927   bool ok;
9928
9929   if (ffecom_num_entrypoints_ == 0)
9930     {                           /* First entrypoint, make list of main
9931                                    arglist's dummies. */
9932       assert (ffecom_primary_entry_ != NULL);
9933
9934       ffecom_master_bt_ = ffesymbol_basictype (ffecom_primary_entry_);
9935       ffecom_master_kt_ = ffesymbol_kindtype (ffecom_primary_entry_);
9936       ffecom_master_size_ = ffesymbol_size (ffecom_primary_entry_);
9937
9938       for (plist = NULL, list = ffesymbol_dummyargs (ffecom_primary_entry_);
9939            list != NULL;
9940            list = ffebld_trail (list))
9941         {
9942           arg = ffebld_head (list);
9943           if (ffebld_op (arg) != FFEBLD_opSYMTER)
9944             continue;           /* Alternate return or some such thing. */
9945           item = ffebld_new_item (arg, NULL);
9946           if (plist == NULL)
9947             ffecom_master_arglist_ = item;
9948           else
9949             ffebld_set_trail (plist, item);
9950           plist = item;
9951         }
9952     }
9953
9954   /* If necessary, scan entry arglist for alternate returns.  Do this scan
9955      apparently redundantly (it's done below to UNIONize the arglists) so
9956      that we don't complain about RETURN 1 if an offending ENTRY is the only
9957      one with an alternate return.  */
9958
9959   if (!ffecom_is_altreturning_)
9960     {
9961       for (list = ffesymbol_dummyargs (entry);
9962            list != NULL;
9963            list = ffebld_trail (list))
9964         {
9965           arg = ffebld_head (list);
9966           if (ffebld_op (arg) == FFEBLD_opSTAR)
9967             {
9968               ffecom_is_altreturning_ = TRUE;
9969               break;
9970             }
9971         }
9972     }
9973
9974   /* Now check type compatibility. */
9975
9976   switch (ffecom_master_bt_)
9977     {
9978     case FFEINFO_basictypeNONE:
9979       ok = (bt != FFEINFO_basictypeCHARACTER);
9980       break;
9981
9982     case FFEINFO_basictypeCHARACTER:
9983       ok
9984         = (bt == FFEINFO_basictypeCHARACTER)
9985         && (kt == ffecom_master_kt_)
9986         && (size == ffecom_master_size_);
9987       break;
9988
9989     case FFEINFO_basictypeANY:
9990       return FALSE;             /* Just don't bother. */
9991
9992     default:
9993       if (bt == FFEINFO_basictypeCHARACTER)
9994         {
9995           ok = FALSE;
9996           break;
9997         }
9998       ok = TRUE;
9999       if ((bt != ffecom_master_bt_) || (kt != ffecom_master_kt_))
10000         {
10001           ffecom_master_bt_ = FFEINFO_basictypeNONE;
10002           ffecom_master_kt_ = FFEINFO_kindtypeNONE;
10003         }
10004       break;
10005     }
10006
10007   if (!ok)
10008     {
10009       ffebad_start (FFEBAD_ENTRY_CONFLICTS);
10010       ffest_ffebad_here_current_stmt (0);
10011       ffebad_finish ();
10012       return FALSE;             /* Can't handle entrypoint. */
10013     }
10014
10015   /* Entrypoint type compatible with previous types. */
10016
10017   ++ffecom_num_entrypoints_;
10018
10019   /* Master-arg-list = UNION(Master-arg-list,entry-arg-list). */
10020
10021   for (list = ffesymbol_dummyargs (entry);
10022        list != NULL;
10023        list = ffebld_trail (list))
10024     {
10025       arg = ffebld_head (list);
10026       if (ffebld_op (arg) != FFEBLD_opSYMTER)
10027         continue;               /* Alternate return or some such thing. */
10028       s = ffebld_symter (arg);
10029       for (plist = NULL, mlist = ffecom_master_arglist_;
10030            mlist != NULL;
10031            plist = mlist, mlist = ffebld_trail (mlist))
10032         {                       /* plist points to previous item for easy
10033                                    appending of arg. */
10034           if (ffebld_symter (ffebld_head (mlist)) == s)
10035             break;              /* Already have this arg in the master list. */
10036         }
10037       if (mlist != NULL)
10038         continue;               /* Already have this arg in the master list. */
10039
10040       /* Append this arg to the master list. */
10041
10042       item = ffebld_new_item (arg, NULL);
10043       if (plist == NULL)
10044         ffecom_master_arglist_ = item;
10045       else
10046         ffebld_set_trail (plist, item);
10047     }
10048
10049   return TRUE;
10050 }
10051
10052 #endif
10053 /* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint
10054
10055    ffesymbol s;  // the ENTRY point itself
10056    ffecom_2pass_do_entrypoint(s);
10057
10058    Does whatever compiler needs to do to make the entrypoint actually
10059    happen.  Must be called for each entrypoint after
10060    ffecom_finish_progunit is called.  */
10061
10062 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10063 void
10064 ffecom_2pass_do_entrypoint (ffesymbol entry)
10065 {
10066   static int mfn_num = 0;
10067   static int ent_num;
10068
10069   if (mfn_num != ffecom_num_fns_)
10070     {                           /* First entrypoint for this program unit. */
10071       ent_num = 1;
10072       mfn_num = ffecom_num_fns_;
10073       ffecom_do_entry_ (ffecom_primary_entry_, 0);
10074     }
10075   else
10076     ++ent_num;
10077
10078   --ffecom_num_entrypoints_;
10079
10080   ffecom_do_entry_ (entry, ent_num);
10081 }
10082
10083 #endif
10084
10085 /* Essentially does a "fold (build (code, type, node1, node2))" while
10086    checking for certain housekeeping things.  Always sets
10087    TREE_SIDE_EFFECTS.  */
10088
10089 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10090 tree
10091 ffecom_2s (enum tree_code code, tree type, tree node1,
10092            tree node2)
10093 {
10094   tree item;
10095
10096   if ((node1 == error_mark_node)
10097       || (node2 == error_mark_node)
10098       || (type == error_mark_node))
10099     return error_mark_node;
10100
10101   item = build (code, type, node1, node2);
10102   TREE_SIDE_EFFECTS (item) = 1;
10103   return fold (item);
10104 }
10105
10106 #endif
10107 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10108    checking for certain housekeeping things.  */
10109
10110 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10111 tree
10112 ffecom_3 (enum tree_code code, tree type, tree node1,
10113           tree node2, tree node3)
10114 {
10115   tree item;
10116
10117   if ((node1 == error_mark_node)
10118       || (node2 == error_mark_node)
10119       || (node3 == error_mark_node)
10120       || (type == error_mark_node))
10121     return error_mark_node;
10122
10123   item = build (code, type, node1, node2, node3);
10124   if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2)
10125       || (node3 != NULL_TREE && TREE_SIDE_EFFECTS (node3)))
10126     TREE_SIDE_EFFECTS (item) = 1;
10127   return fold (item);
10128 }
10129
10130 #endif
10131 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10132    checking for certain housekeeping things.  Always sets
10133    TREE_SIDE_EFFECTS.  */
10134
10135 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10136 tree
10137 ffecom_3s (enum tree_code code, tree type, tree node1,
10138            tree node2, tree node3)
10139 {
10140   tree item;
10141
10142   if ((node1 == error_mark_node)
10143       || (node2 == error_mark_node)
10144       || (node3 == error_mark_node)
10145       || (type == error_mark_node))
10146     return error_mark_node;
10147
10148   item = build (code, type, node1, node2, node3);
10149   TREE_SIDE_EFFECTS (item) = 1;
10150   return fold (item);
10151 }
10152
10153 #endif
10154
10155 /* ffecom_arg_expr -- Transform argument expr into gcc tree
10156
10157    See use by ffecom_list_expr.
10158
10159    If expression is NULL, returns an integer zero tree.  If it is not
10160    a CHARACTER expression, returns whatever ffecom_expr
10161    returns and sets the length return value to NULL_TREE.  Otherwise
10162    generates code to evaluate the character expression, returns the proper
10163    pointer to the result, but does NOT set the length return value to a tree
10164    that specifies the length of the result.  (In other words, the length
10165    variable is always set to NULL_TREE, because a length is never passed.)
10166
10167    21-Dec-91  JCB  1.1
10168       Don't set returned length, since nobody needs it (yet; someday if
10169       we allow CHARACTER*(*) dummies to statement functions, we'll need
10170       it).  */
10171
10172 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10173 tree
10174 ffecom_arg_expr (ffebld expr, tree *length)
10175 {
10176   tree ign;
10177
10178   *length = NULL_TREE;
10179
10180   if (expr == NULL)
10181     return integer_zero_node;
10182
10183   if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10184     return ffecom_expr (expr);
10185
10186   return ffecom_arg_ptr_to_expr (expr, &ign);
10187 }
10188
10189 #endif
10190 /* Transform expression into constant argument-pointer-to-expression tree.
10191
10192    If the expression can be transformed into a argument-pointer-to-expression
10193    tree that is constant, that is done, and the tree returned.  Else
10194    NULL_TREE is returned.
10195
10196    That way, a caller can attempt to provide compile-time initialization
10197    of a variable and, if that fails, *then* choose to start a new block
10198    and resort to using temporaries, as appropriate.  */
10199
10200 tree
10201 ffecom_arg_ptr_to_const_expr (ffebld expr, tree *length)
10202 {
10203   if (! expr)
10204     return integer_zero_node;
10205
10206   if (ffebld_op (expr) == FFEBLD_opANY)
10207     {
10208       if (length)
10209         *length = error_mark_node;
10210       return error_mark_node;
10211     }
10212
10213   if (ffebld_arity (expr) == 0
10214       && (ffebld_op (expr) != FFEBLD_opSYMTER
10215           || ffebld_where (expr) == FFEINFO_whereCOMMON
10216           || ffebld_where (expr) == FFEINFO_whereGLOBAL
10217           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10218     {
10219       tree t;
10220
10221       t = ffecom_arg_ptr_to_expr (expr, length);
10222       assert (TREE_CONSTANT (t));
10223       assert (! length || TREE_CONSTANT (*length));
10224       return t;
10225     }
10226
10227   if (length
10228       && ffebld_size (expr) != FFETARGET_charactersizeNONE)
10229     *length = build_int_2 (ffebld_size (expr), 0);
10230   else if (length)
10231     *length = NULL_TREE;
10232   return NULL_TREE;
10233 }
10234
10235 /* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree
10236
10237    See use by ffecom_list_ptr_to_expr.
10238
10239    If expression is NULL, returns an integer zero tree.  If it is not
10240    a CHARACTER expression, returns whatever ffecom_ptr_to_expr
10241    returns and sets the length return value to NULL_TREE.  Otherwise
10242    generates code to evaluate the character expression, returns the proper
10243    pointer to the result, AND sets the length return value to a tree that
10244    specifies the length of the result.
10245
10246    If the length argument is NULL, this is a slightly special
10247    case of building a FORMAT expression, that is, an expression that
10248    will be used at run time without regard to length.  For the current
10249    implementation, which uses the libf2c library, this means it is nice
10250    to append a null byte to the end of the expression, where feasible,
10251    to make sure any diagnostic about the FORMAT string terminates at
10252    some useful point.
10253
10254    For now, treat %REF(char-expr) as the same as char-expr with a NULL
10255    length argument.  This might even be seen as a feature, if a null
10256    byte can always be appended.  */
10257
10258 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10259 tree
10260 ffecom_arg_ptr_to_expr (ffebld expr, tree *length)
10261 {
10262   tree item;
10263   tree ign_length;
10264   ffecomConcatList_ catlist;
10265
10266   if (length != NULL)
10267     *length = NULL_TREE;
10268
10269   if (expr == NULL)
10270     return integer_zero_node;
10271
10272   switch (ffebld_op (expr))
10273     {
10274     case FFEBLD_opPERCENT_VAL:
10275       if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10276         return ffecom_expr (ffebld_left (expr));
10277       {
10278         tree temp_exp;
10279         tree temp_length;
10280
10281         temp_exp = ffecom_arg_ptr_to_expr (ffebld_left (expr), &temp_length);
10282         if (temp_exp == error_mark_node)
10283           return error_mark_node;
10284
10285         return ffecom_1 (INDIRECT_REF, TREE_TYPE (TREE_TYPE (temp_exp)),
10286                          temp_exp);
10287       }
10288
10289     case FFEBLD_opPERCENT_REF:
10290       if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10291         return ffecom_ptr_to_expr (ffebld_left (expr));
10292       if (length != NULL)
10293         {
10294           ign_length = NULL_TREE;
10295           length = &ign_length;
10296         }
10297       expr = ffebld_left (expr);
10298       break;
10299
10300     case FFEBLD_opPERCENT_DESCR:
10301       switch (ffeinfo_basictype (ffebld_info (expr)))
10302         {
10303 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10304         case FFEINFO_basictypeHOLLERITH:
10305 #endif
10306         case FFEINFO_basictypeCHARACTER:
10307           break;                /* Passed by descriptor anyway. */
10308
10309         default:
10310           item = ffecom_ptr_to_expr (expr);
10311           if (item != error_mark_node)
10312             *length = TYPE_SIZE (TREE_TYPE (TREE_TYPE (item)));
10313           break;
10314         }
10315       break;
10316
10317     default:
10318       break;
10319     }
10320
10321 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10322   if ((ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeHOLLERITH)
10323       && (length != NULL))
10324     {                           /* Pass Hollerith by descriptor. */
10325       ffetargetHollerith h;
10326
10327       assert (ffebld_op (expr) == FFEBLD_opCONTER);
10328       h = ffebld_cu_val_hollerith (ffebld_constant_union
10329                                    (ffebld_conter (expr)));
10330       *length
10331         = build_int_2 (h.length, 0);
10332       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10333     }
10334 #endif
10335
10336   if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10337     return ffecom_ptr_to_expr (expr);
10338
10339   assert (ffeinfo_kindtype (ffebld_info (expr))
10340           == FFEINFO_kindtypeCHARACTER1);
10341
10342   while (ffebld_op (expr) == FFEBLD_opPAREN)
10343     expr = ffebld_left (expr);
10344
10345   catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
10346   switch (ffecom_concat_list_count_ (catlist))
10347     {
10348     case 0:                     /* Shouldn't happen, but in case it does... */
10349       if (length != NULL)
10350         {
10351           *length = ffecom_f2c_ftnlen_zero_node;
10352           TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10353         }
10354       ffecom_concat_list_kill_ (catlist);
10355       return null_pointer_node;
10356
10357     case 1:                     /* The (fairly) easy case. */
10358       if (length == NULL)
10359         ffecom_char_args_with_null_ (&item, &ign_length,
10360                                      ffecom_concat_list_expr_ (catlist, 0));
10361       else
10362         ffecom_char_args_ (&item, length,
10363                            ffecom_concat_list_expr_ (catlist, 0));
10364       ffecom_concat_list_kill_ (catlist);
10365       assert (item != NULL_TREE);
10366       return item;
10367
10368     default:                    /* Must actually concatenate things. */
10369       break;
10370     }
10371
10372   {
10373     int count = ffecom_concat_list_count_ (catlist);
10374     int i;
10375     tree lengths;
10376     tree items;
10377     tree length_array;
10378     tree item_array;
10379     tree citem;
10380     tree clength;
10381     tree temporary;
10382     tree num;
10383     tree known_length;
10384     ffetargetCharacterSize sz;
10385
10386     sz = ffecom_concat_list_maxlen_ (catlist);
10387     /* ~~Kludge! */
10388     assert (sz != FFETARGET_charactersizeNONE);
10389
10390 #ifdef HOHO
10391     length_array
10392       = lengths
10393       = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
10394                              FFETARGET_charactersizeNONE, count, TRUE);
10395     item_array
10396       = items
10397       = ffecom_push_tempvar (ffecom_f2c_address_type_node,
10398                              FFETARGET_charactersizeNONE, count, TRUE);
10399     temporary = ffecom_push_tempvar (char_type_node,
10400                                      sz, -1, TRUE);
10401 #else
10402     {
10403       tree hook;
10404
10405       hook = ffebld_nonter_hook (expr);
10406       assert (hook);
10407       assert (TREE_CODE (hook) == TREE_VEC);
10408       assert (TREE_VEC_LENGTH (hook) == 3);
10409       length_array = lengths = TREE_VEC_ELT (hook, 0);
10410       item_array = items = TREE_VEC_ELT (hook, 1);
10411       temporary = TREE_VEC_ELT (hook, 2);
10412     }
10413 #endif
10414
10415     known_length = ffecom_f2c_ftnlen_zero_node;
10416
10417     for (i = 0; i < count; ++i)
10418       {
10419         if ((i == count)
10420             && (length == NULL))
10421           ffecom_char_args_with_null_ (&citem, &clength,
10422                                        ffecom_concat_list_expr_ (catlist, i));
10423         else
10424           ffecom_char_args_ (&citem, &clength,
10425                              ffecom_concat_list_expr_ (catlist, i));
10426         if ((citem == error_mark_node)
10427             || (clength == error_mark_node))
10428           {
10429             ffecom_concat_list_kill_ (catlist);
10430             *length = error_mark_node;
10431             return error_mark_node;
10432           }
10433
10434         items
10435           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
10436                       ffecom_modify (void_type_node,
10437                                      ffecom_2 (ARRAY_REF,
10438                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
10439                                                item_array,
10440                                                build_int_2 (i, 0)),
10441                                      citem),
10442                       items);
10443         clength = ffecom_save_tree (clength);
10444         if (length != NULL)
10445           known_length
10446             = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
10447                         known_length,
10448                         clength);
10449         lengths
10450           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
10451                       ffecom_modify (void_type_node,
10452                                      ffecom_2 (ARRAY_REF,
10453                    TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
10454                                                length_array,
10455                                                build_int_2 (i, 0)),
10456                                      clength),
10457                       lengths);
10458       }
10459
10460     temporary = ffecom_1 (ADDR_EXPR,
10461                           build_pointer_type (TREE_TYPE (temporary)),
10462                           temporary);
10463
10464     item = build_tree_list (NULL_TREE, temporary);
10465     TREE_CHAIN (item)
10466       = build_tree_list (NULL_TREE,
10467                          ffecom_1 (ADDR_EXPR,
10468                                    build_pointer_type (TREE_TYPE (items)),
10469                                    items));
10470     TREE_CHAIN (TREE_CHAIN (item))
10471       = build_tree_list (NULL_TREE,
10472                          ffecom_1 (ADDR_EXPR,
10473                                    build_pointer_type (TREE_TYPE (lengths)),
10474                                    lengths));
10475     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
10476       = build_tree_list
10477         (NULL_TREE,
10478          ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
10479                    convert (ffecom_f2c_ftnlen_type_node,
10480                             build_int_2 (count, 0))));
10481     num = build_int_2 (sz, 0);
10482     TREE_TYPE (num) = ffecom_f2c_ftnlen_type_node;
10483     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item))))
10484       = build_tree_list (NULL_TREE, num);
10485
10486     item = ffecom_call_gfrt (FFECOM_gfrtCAT, item, NULL_TREE);
10487     TREE_SIDE_EFFECTS (item) = 1;
10488     item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (temporary),
10489                      item,
10490                      temporary);
10491
10492     if (length != NULL)
10493       *length = known_length;
10494   }
10495
10496   ffecom_concat_list_kill_ (catlist);
10497   assert (item != NULL_TREE);
10498   return item;
10499 }
10500
10501 #endif
10502 /* Generate call to run-time function.
10503
10504    The first arg is the GNU Fortran Run-Time function index, the second
10505    arg is the list of arguments to pass to it.  Returned is the expression
10506    (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the
10507    result (which may be void).  */
10508
10509 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10510 tree
10511 ffecom_call_gfrt (ffecomGfrt ix, tree args, tree hook)
10512 {
10513   return ffecom_call_ (ffecom_gfrt_tree_ (ix),
10514                        ffecom_gfrt_kindtype (ix),
10515                        ffe_is_f2c_library () && ffecom_gfrt_complex_[ix],
10516                        NULL_TREE, args, NULL_TREE, NULL,
10517                        NULL, NULL_TREE, TRUE, hook);
10518 }
10519 #endif
10520
10521 /* Transform constant-union to tree.  */
10522
10523 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10524 tree
10525 ffecom_constantunion (ffebldConstantUnion *cu, ffeinfoBasictype bt,
10526                       ffeinfoKindtype kt, tree tree_type)
10527 {
10528   tree item;
10529
10530   switch (bt)
10531     {
10532     case FFEINFO_basictypeINTEGER:
10533       {
10534         int val;
10535
10536         switch (kt)
10537           {
10538 #if FFETARGET_okINTEGER1
10539           case FFEINFO_kindtypeINTEGER1:
10540             val = ffebld_cu_val_integer1 (*cu);
10541             break;
10542 #endif
10543
10544 #if FFETARGET_okINTEGER2
10545           case FFEINFO_kindtypeINTEGER2:
10546             val = ffebld_cu_val_integer2 (*cu);
10547             break;
10548 #endif
10549
10550 #if FFETARGET_okINTEGER3
10551           case FFEINFO_kindtypeINTEGER3:
10552             val = ffebld_cu_val_integer3 (*cu);
10553             break;
10554 #endif
10555
10556 #if FFETARGET_okINTEGER4
10557           case FFEINFO_kindtypeINTEGER4:
10558             val = ffebld_cu_val_integer4 (*cu);
10559             break;
10560 #endif
10561
10562           default:
10563             assert ("bad INTEGER constant kind type" == NULL);
10564             /* Fall through. */
10565           case FFEINFO_kindtypeANY:
10566             return error_mark_node;
10567           }
10568         item = build_int_2 (val, (val < 0) ? -1 : 0);
10569         TREE_TYPE (item) = tree_type;
10570       }
10571       break;
10572
10573     case FFEINFO_basictypeLOGICAL:
10574       {
10575         int val;
10576
10577         switch (kt)
10578           {
10579 #if FFETARGET_okLOGICAL1
10580           case FFEINFO_kindtypeLOGICAL1:
10581             val = ffebld_cu_val_logical1 (*cu);
10582             break;
10583 #endif
10584
10585 #if FFETARGET_okLOGICAL2
10586           case FFEINFO_kindtypeLOGICAL2:
10587             val = ffebld_cu_val_logical2 (*cu);
10588             break;
10589 #endif
10590
10591 #if FFETARGET_okLOGICAL3
10592           case FFEINFO_kindtypeLOGICAL3:
10593             val = ffebld_cu_val_logical3 (*cu);
10594             break;
10595 #endif
10596
10597 #if FFETARGET_okLOGICAL4
10598           case FFEINFO_kindtypeLOGICAL4:
10599             val = ffebld_cu_val_logical4 (*cu);
10600             break;
10601 #endif
10602
10603           default:
10604             assert ("bad LOGICAL constant kind type" == NULL);
10605             /* Fall through. */
10606           case FFEINFO_kindtypeANY:
10607             return error_mark_node;
10608           }
10609         item = build_int_2 (val, (val < 0) ? -1 : 0);
10610         TREE_TYPE (item) = tree_type;
10611       }
10612       break;
10613
10614     case FFEINFO_basictypeREAL:
10615       {
10616         REAL_VALUE_TYPE val;
10617
10618         switch (kt)
10619           {
10620 #if FFETARGET_okREAL1
10621           case FFEINFO_kindtypeREAL1:
10622             val = ffetarget_value_real1 (ffebld_cu_val_real1 (*cu));
10623             break;
10624 #endif
10625
10626 #if FFETARGET_okREAL2
10627           case FFEINFO_kindtypeREAL2:
10628             val = ffetarget_value_real2 (ffebld_cu_val_real2 (*cu));
10629             break;
10630 #endif
10631
10632 #if FFETARGET_okREAL3
10633           case FFEINFO_kindtypeREAL3:
10634             val = ffetarget_value_real3 (ffebld_cu_val_real3 (*cu));
10635             break;
10636 #endif
10637
10638 #if FFETARGET_okREAL4
10639           case FFEINFO_kindtypeREAL4:
10640             val = ffetarget_value_real4 (ffebld_cu_val_real4 (*cu));
10641             break;
10642 #endif
10643
10644           default:
10645             assert ("bad REAL constant kind type" == NULL);
10646             /* Fall through. */
10647           case FFEINFO_kindtypeANY:
10648             return error_mark_node;
10649           }
10650         item = build_real (tree_type, val);
10651       }
10652       break;
10653
10654     case FFEINFO_basictypeCOMPLEX:
10655       {
10656         REAL_VALUE_TYPE real;
10657         REAL_VALUE_TYPE imag;
10658         tree el_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
10659
10660         switch (kt)
10661           {
10662 #if FFETARGET_okCOMPLEX1
10663           case FFEINFO_kindtypeREAL1:
10664             real = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).real);
10665             imag = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).imaginary);
10666             break;
10667 #endif
10668
10669 #if FFETARGET_okCOMPLEX2
10670           case FFEINFO_kindtypeREAL2:
10671             real = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).real);
10672             imag = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).imaginary);
10673             break;
10674 #endif
10675
10676 #if FFETARGET_okCOMPLEX3
10677           case FFEINFO_kindtypeREAL3:
10678             real = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).real);
10679             imag = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).imaginary);
10680             break;
10681 #endif
10682
10683 #if FFETARGET_okCOMPLEX4
10684           case FFEINFO_kindtypeREAL4:
10685             real = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).real);
10686             imag = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).imaginary);
10687             break;
10688 #endif
10689
10690           default:
10691             assert ("bad REAL constant kind type" == NULL);
10692             /* Fall through. */
10693           case FFEINFO_kindtypeANY:
10694             return error_mark_node;
10695           }
10696         item = ffecom_build_complex_constant_ (tree_type,
10697                                                build_real (el_type, real),
10698                                                build_real (el_type, imag));
10699       }
10700       break;
10701
10702     case FFEINFO_basictypeCHARACTER:
10703       {                         /* Happens only in DATA and similar contexts. */
10704         ffetargetCharacter1 val;
10705
10706         switch (kt)
10707           {
10708 #if FFETARGET_okCHARACTER1
10709           case FFEINFO_kindtypeLOGICAL1:
10710             val = ffebld_cu_val_character1 (*cu);
10711             break;
10712 #endif
10713
10714           default:
10715             assert ("bad CHARACTER constant kind type" == NULL);
10716             /* Fall through. */
10717           case FFEINFO_kindtypeANY:
10718             return error_mark_node;
10719           }
10720         item = build_string (ffetarget_length_character1 (val),
10721                              ffetarget_text_character1 (val));
10722         TREE_TYPE (item)
10723           = build_type_variant (build_array_type (char_type_node,
10724                                                   build_range_type
10725                                                   (integer_type_node,
10726                                                    integer_one_node,
10727                                                    build_int_2
10728                                                 (ffetarget_length_character1
10729                                                  (val), 0))),
10730                                 1, 0);
10731       }
10732       break;
10733
10734     case FFEINFO_basictypeHOLLERITH:
10735       {
10736         ffetargetHollerith h;
10737
10738         h = ffebld_cu_val_hollerith (*cu);
10739
10740         /* If not at least as wide as default INTEGER, widen it.  */
10741         if (h.length >= FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE)
10742           item = build_string (h.length, h.text);
10743         else
10744           {
10745             char str[FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE];
10746
10747             memcpy (str, h.text, h.length);
10748             memset (&str[h.length], ' ',
10749                     FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE
10750                     - h.length);
10751             item = build_string (FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE,
10752                                  str);
10753           }
10754         TREE_TYPE (item)
10755           = build_type_variant (build_array_type (char_type_node,
10756                                                   build_range_type
10757                                                   (integer_type_node,
10758                                                    integer_one_node,
10759                                                    build_int_2
10760                                                    (h.length, 0))),
10761                                 1, 0);
10762       }
10763       break;
10764
10765     case FFEINFO_basictypeTYPELESS:
10766       {
10767         ffetargetInteger1 ival;
10768         ffetargetTypeless tless;
10769         ffebad error;
10770
10771         tless = ffebld_cu_val_typeless (*cu);
10772         error = ffetarget_convert_integer1_typeless (&ival, tless);
10773         assert (error == FFEBAD);
10774
10775         item = build_int_2 ((int) ival, 0);
10776       }
10777       break;
10778
10779     default:
10780       assert ("not yet on constant type" == NULL);
10781       /* Fall through. */
10782     case FFEINFO_basictypeANY:
10783       return error_mark_node;
10784     }
10785
10786   TREE_CONSTANT (item) = 1;
10787
10788   return item;
10789 }
10790
10791 #endif
10792
10793 /* Transform expression into constant tree.
10794
10795    If the expression can be transformed into a tree that is constant,
10796    that is done, and the tree returned.  Else NULL_TREE is returned.
10797
10798    That way, a caller can attempt to provide compile-time initialization
10799    of a variable and, if that fails, *then* choose to start a new block
10800    and resort to using temporaries, as appropriate.  */
10801
10802 tree
10803 ffecom_const_expr (ffebld expr)
10804 {
10805   if (! expr)
10806     return integer_zero_node;
10807
10808   if (ffebld_op (expr) == FFEBLD_opANY)
10809     return error_mark_node;
10810
10811   if (ffebld_arity (expr) == 0
10812       && (ffebld_op (expr) != FFEBLD_opSYMTER
10813 #if NEWCOMMON
10814           /* ~~Enable once common/equivalence is handled properly?  */
10815           || ffebld_where (expr) == FFEINFO_whereCOMMON
10816 #endif
10817           || ffebld_where (expr) == FFEINFO_whereGLOBAL
10818           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10819     {
10820       tree t;
10821
10822       t = ffecom_expr (expr);
10823       assert (TREE_CONSTANT (t));
10824       return t;
10825     }
10826
10827   return NULL_TREE;
10828 }
10829
10830 /* Handy way to make a field in a struct/union.  */
10831
10832 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10833 tree
10834 ffecom_decl_field (tree context, tree prevfield,
10835                    const char *name, tree type)
10836 {
10837   tree field;
10838
10839   field = build_decl (FIELD_DECL, get_identifier (name), type);
10840   DECL_CONTEXT (field) = context;
10841   DECL_ALIGN (field) = 0;
10842   DECL_USER_ALIGN (field) = 0;
10843   if (prevfield != NULL_TREE)
10844     TREE_CHAIN (prevfield) = field;
10845
10846   return field;
10847 }
10848
10849 #endif
10850
10851 void
10852 ffecom_close_include (FILE *f)
10853 {
10854 #if FFECOM_GCC_INCLUDE
10855   ffecom_close_include_ (f);
10856 #endif
10857 }
10858
10859 int
10860 ffecom_decode_include_option (char *spec)
10861 {
10862 #if FFECOM_GCC_INCLUDE
10863   return ffecom_decode_include_option_ (spec);
10864 #else
10865   return 1;
10866 #endif
10867 }
10868
10869 /* End a compound statement (block).  */
10870
10871 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10872 tree
10873 ffecom_end_compstmt (void)
10874 {
10875   return bison_rule_compstmt_ ();
10876 }
10877 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
10878
10879 /* ffecom_end_transition -- Perform end transition on all symbols
10880
10881    ffecom_end_transition();
10882
10883    Calls ffecom_sym_end_transition for each global and local symbol.  */
10884
10885 void
10886 ffecom_end_transition ()
10887 {
10888 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10889   ffebld item;
10890 #endif
10891
10892   if (ffe_is_ffedebug ())
10893     fprintf (dmpout, "; end_stmt_transition\n");
10894
10895 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10896   ffecom_list_blockdata_ = NULL;
10897   ffecom_list_common_ = NULL;
10898 #endif
10899
10900   ffesymbol_drive (ffecom_sym_end_transition);
10901   if (ffe_is_ffedebug ())
10902     {
10903       ffestorag_report ();
10904 #if FFECOM_targetCURRENT == FFECOM_targetFFE
10905       ffesymbol_report_all ();
10906 #endif
10907     }
10908
10909 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10910   ffecom_start_progunit_ ();
10911
10912   for (item = ffecom_list_blockdata_;
10913        item != NULL;
10914        item = ffebld_trail (item))
10915     {
10916       ffebld callee;
10917       ffesymbol s;
10918       tree dt;
10919       tree t;
10920       tree var;
10921       static int number = 0;
10922
10923       callee = ffebld_head (item);
10924       s = ffebld_symter (callee);
10925       t = ffesymbol_hook (s).decl_tree;
10926       if (t == NULL_TREE)
10927         {
10928           s = ffecom_sym_transform_ (s);
10929           t = ffesymbol_hook (s).decl_tree;
10930         }
10931
10932       dt = build_pointer_type (TREE_TYPE (t));
10933
10934       var = build_decl (VAR_DECL,
10935                         ffecom_get_invented_identifier ("__g77_forceload_%d",
10936                                                         number++),
10937                         dt);
10938       DECL_EXTERNAL (var) = 0;
10939       TREE_STATIC (var) = 1;
10940       TREE_PUBLIC (var) = 0;
10941       DECL_INITIAL (var) = error_mark_node;
10942       TREE_USED (var) = 1;
10943
10944       var = start_decl (var, FALSE);
10945
10946       t = ffecom_1 (ADDR_EXPR, dt, t);
10947
10948       finish_decl (var, t, FALSE);
10949     }
10950
10951   /* This handles any COMMON areas that weren't referenced but have, for
10952      example, important initial data.  */
10953
10954   for (item = ffecom_list_common_;
10955        item != NULL;
10956        item = ffebld_trail (item))
10957     ffecom_transform_common_ (ffebld_symter (ffebld_head (item)));
10958
10959   ffecom_list_common_ = NULL;
10960 #endif
10961 }
10962
10963 /* ffecom_exec_transition -- Perform exec transition on all symbols
10964
10965    ffecom_exec_transition();
10966
10967    Calls ffecom_sym_exec_transition for each global and local symbol.
10968    Make sure error updating not inhibited.  */
10969
10970 void
10971 ffecom_exec_transition ()
10972 {
10973   bool inhibited;
10974
10975   if (ffe_is_ffedebug ())
10976     fprintf (dmpout, "; exec_stmt_transition\n");
10977
10978   inhibited = ffebad_inhibit ();
10979   ffebad_set_inhibit (FALSE);
10980
10981   ffesymbol_drive (ffecom_sym_exec_transition); /* Don't retract! */
10982   ffeequiv_exec_transition ();  /* Handle all pending EQUIVALENCEs. */
10983   if (ffe_is_ffedebug ())
10984     {
10985       ffestorag_report ();
10986 #if FFECOM_targetCURRENT == FFECOM_targetFFE
10987       ffesymbol_report_all ();
10988 #endif
10989     }
10990
10991   if (inhibited)
10992     ffebad_set_inhibit (TRUE);
10993 }
10994
10995 /* Handle assignment statement.
10996
10997    Convert dest and source using ffecom_expr, then join them
10998    with an ASSIGN op and pass the whole thing to expand_expr_stmt.  */
10999
11000 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11001 void
11002 ffecom_expand_let_stmt (ffebld dest, ffebld source)
11003 {
11004   tree dest_tree;
11005   tree dest_length;
11006   tree source_tree;
11007   tree expr_tree;
11008
11009   if (ffeinfo_basictype (ffebld_info (dest)) != FFEINFO_basictypeCHARACTER)
11010     {
11011       bool dest_used;
11012       tree assign_temp;
11013
11014       /* This attempts to replicate the test below, but must not be
11015          true when the test below is false.  (Always err on the side
11016          of creating unused temporaries, to avoid ICEs.)  */
11017       if (ffebld_op (dest) != FFEBLD_opSYMTER
11018           || ((dest_tree = ffesymbol_hook (ffebld_symter (dest)).decl_tree)
11019               && (TREE_CODE (dest_tree) != VAR_DECL
11020                   || TREE_ADDRESSABLE (dest_tree))))
11021         {
11022           ffecom_prepare_expr_ (source, dest);
11023           dest_used = TRUE;
11024         }
11025       else
11026         {
11027           ffecom_prepare_expr_ (source, NULL);
11028           dest_used = FALSE;
11029         }
11030
11031       ffecom_prepare_expr_w (NULL_TREE, dest);
11032
11033       /* For COMPLEX assignment like C1=C2, if partial overlap is possible,
11034          create a temporary through which the assignment is to take place,
11035          since MODIFY_EXPR doesn't handle partial overlap properly.  */
11036       if (ffebld_basictype (dest) == FFEINFO_basictypeCOMPLEX
11037           && ffecom_possible_partial_overlap_ (dest, source))
11038         {
11039           assign_temp = ffecom_make_tempvar ("complex_let",
11040                                              ffecom_tree_type
11041                                              [ffebld_basictype (dest)]
11042                                              [ffebld_kindtype (dest)],
11043                                              FFETARGET_charactersizeNONE,
11044                                              -1);
11045         }
11046       else
11047         assign_temp = NULL_TREE;
11048
11049       ffecom_prepare_end ();
11050
11051       dest_tree = ffecom_expr_w (NULL_TREE, dest);
11052       if (dest_tree == error_mark_node)
11053         return;
11054
11055       if ((TREE_CODE (dest_tree) != VAR_DECL)
11056           || TREE_ADDRESSABLE (dest_tree))
11057         source_tree = ffecom_expr_ (source, dest_tree, dest, &dest_used,
11058                                     FALSE, FALSE);
11059       else
11060         {
11061           assert (! dest_used);
11062           dest_used = FALSE;
11063           source_tree = ffecom_expr (source);
11064         }
11065       if (source_tree == error_mark_node)
11066         return;
11067
11068       if (dest_used)
11069         expr_tree = source_tree;
11070       else if (assign_temp)
11071         {
11072 #ifdef MOVE_EXPR
11073           /* The back end understands a conceptual move (evaluate source;
11074              store into dest), so use that, in case it can determine
11075              that it is going to use, say, two registers as temporaries
11076              anyway.  So don't use the temp (and someday avoid generating
11077              it, once this code starts triggering regularly).  */
11078           expr_tree = ffecom_2s (MOVE_EXPR, void_type_node,
11079                                  dest_tree,
11080                                  source_tree);
11081 #else
11082           expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
11083                                  assign_temp,
11084                                  source_tree);
11085           expand_expr_stmt (expr_tree);
11086           expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
11087                                  dest_tree,
11088                                  assign_temp);
11089 #endif
11090         }
11091       else
11092         expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
11093                                dest_tree,
11094                                source_tree);
11095
11096       expand_expr_stmt (expr_tree);
11097       return;
11098     }
11099
11100   ffecom_prepare_let_char_ (ffebld_size_known (dest), source);
11101   ffecom_prepare_expr_w (NULL_TREE, dest);
11102
11103   ffecom_prepare_end ();
11104
11105   ffecom_char_args_ (&dest_tree, &dest_length, dest);
11106   ffecom_let_char_ (dest_tree, dest_length, ffebld_size_known (dest),
11107                     source);
11108 }
11109
11110 #endif
11111 /* ffecom_expr -- Transform expr into gcc tree
11112
11113    tree t;
11114    ffebld expr;  // FFE expression.
11115    tree = ffecom_expr(expr);
11116
11117    Recursive descent on expr while making corresponding tree nodes and
11118    attaching type info and such.  */
11119
11120 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11121 tree
11122 ffecom_expr (ffebld expr)
11123 {
11124   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, FALSE, FALSE);
11125 }
11126
11127 #endif
11128 /* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT.  */
11129
11130 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11131 tree
11132 ffecom_expr_assign (ffebld expr)
11133 {
11134   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
11135 }
11136
11137 #endif
11138 /* Like ffecom_expr_rw, but return tree usable for ASSIGN.  */
11139
11140 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11141 tree
11142 ffecom_expr_assign_w (ffebld expr)
11143 {
11144   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
11145 }
11146
11147 #endif
11148 /* Transform expr for use as into read/write tree and stabilize the
11149    reference.  Not for use on CHARACTER expressions.
11150
11151    Recursive descent on expr while making corresponding tree nodes and
11152    attaching type info and such.  */
11153
11154 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11155 tree
11156 ffecom_expr_rw (tree type, ffebld expr)
11157 {
11158   assert (expr != NULL);
11159   /* Different target types not yet supported.  */
11160   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
11161
11162   return stabilize_reference (ffecom_expr (expr));
11163 }
11164
11165 #endif
11166 /* Transform expr for use as into write tree and stabilize the
11167    reference.  Not for use on CHARACTER expressions.
11168
11169    Recursive descent on expr while making corresponding tree nodes and
11170    attaching type info and such.  */
11171
11172 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11173 tree
11174 ffecom_expr_w (tree type, ffebld expr)
11175 {
11176   assert (expr != NULL);
11177   /* Different target types not yet supported.  */
11178   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
11179
11180   return stabilize_reference (ffecom_expr (expr));
11181 }
11182
11183 #endif
11184 /* Do global stuff.  */
11185
11186 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11187 void
11188 ffecom_finish_compile ()
11189 {
11190   assert (ffecom_outer_function_decl_ == NULL_TREE);
11191   assert (current_function_decl == NULL_TREE);
11192
11193   ffeglobal_drive (ffecom_finish_global_);
11194 }
11195
11196 #endif
11197 /* Public entry point for front end to access finish_decl.  */
11198
11199 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11200 void
11201 ffecom_finish_decl (tree decl, tree init, bool is_top_level)
11202 {
11203   assert (!is_top_level);
11204   finish_decl (decl, init, FALSE);
11205 }
11206
11207 #endif
11208 /* Finish a program unit.  */
11209
11210 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11211 void
11212 ffecom_finish_progunit ()
11213 {
11214   ffecom_end_compstmt ();
11215
11216   ffecom_previous_function_decl_ = current_function_decl;
11217   ffecom_which_entrypoint_decl_ = NULL_TREE;
11218
11219   finish_function (0);
11220 }
11221
11222 #endif
11223
11224 /* Wrapper for get_identifier.  pattern is sprintf-like.  */
11225
11226 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11227 tree
11228 ffecom_get_invented_identifier (const char *pattern, ...)
11229 {
11230   tree decl;
11231   char *nam;
11232   va_list ap;
11233
11234   va_start (ap, pattern);
11235   if (vasprintf (&nam, pattern, ap) == 0)
11236     abort ();
11237   va_end (ap);
11238   decl = get_identifier (nam);
11239   free (nam);
11240   IDENTIFIER_INVENTED (decl) = 1;
11241   return decl;
11242 }
11243
11244 ffeinfoBasictype
11245 ffecom_gfrt_basictype (ffecomGfrt gfrt)
11246 {
11247   assert (gfrt < FFECOM_gfrt);
11248
11249   switch (ffecom_gfrt_type_[gfrt])
11250     {
11251     case FFECOM_rttypeVOID_:
11252     case FFECOM_rttypeVOIDSTAR_:
11253       return FFEINFO_basictypeNONE;
11254
11255     case FFECOM_rttypeFTNINT_:
11256       return FFEINFO_basictypeINTEGER;
11257
11258     case FFECOM_rttypeINTEGER_:
11259       return FFEINFO_basictypeINTEGER;
11260
11261     case FFECOM_rttypeLONGINT_:
11262       return FFEINFO_basictypeINTEGER;
11263
11264     case FFECOM_rttypeLOGICAL_:
11265       return FFEINFO_basictypeLOGICAL;
11266
11267     case FFECOM_rttypeREAL_F2C_:
11268     case FFECOM_rttypeREAL_GNU_:
11269       return FFEINFO_basictypeREAL;
11270
11271     case FFECOM_rttypeCOMPLEX_F2C_:
11272     case FFECOM_rttypeCOMPLEX_GNU_:
11273       return FFEINFO_basictypeCOMPLEX;
11274
11275     case FFECOM_rttypeDOUBLE_:
11276     case FFECOM_rttypeDOUBLEREAL_:
11277       return FFEINFO_basictypeREAL;
11278
11279     case FFECOM_rttypeDBLCMPLX_F2C_:
11280     case FFECOM_rttypeDBLCMPLX_GNU_:
11281       return FFEINFO_basictypeCOMPLEX;
11282
11283     case FFECOM_rttypeCHARACTER_:
11284       return FFEINFO_basictypeCHARACTER;
11285
11286     default:
11287       return FFEINFO_basictypeANY;
11288     }
11289 }
11290
11291 ffeinfoKindtype
11292 ffecom_gfrt_kindtype (ffecomGfrt gfrt)
11293 {
11294   assert (gfrt < FFECOM_gfrt);
11295
11296   switch (ffecom_gfrt_type_[gfrt])
11297     {
11298     case FFECOM_rttypeVOID_:
11299     case FFECOM_rttypeVOIDSTAR_:
11300       return FFEINFO_kindtypeNONE;
11301
11302     case FFECOM_rttypeFTNINT_:
11303       return FFEINFO_kindtypeINTEGER1;
11304
11305     case FFECOM_rttypeINTEGER_:
11306       return FFEINFO_kindtypeINTEGER1;
11307
11308     case FFECOM_rttypeLONGINT_:
11309       return FFEINFO_kindtypeINTEGER4;
11310
11311     case FFECOM_rttypeLOGICAL_:
11312       return FFEINFO_kindtypeLOGICAL1;
11313
11314     case FFECOM_rttypeREAL_F2C_:
11315     case FFECOM_rttypeREAL_GNU_:
11316       return FFEINFO_kindtypeREAL1;
11317
11318     case FFECOM_rttypeCOMPLEX_F2C_:
11319     case FFECOM_rttypeCOMPLEX_GNU_:
11320       return FFEINFO_kindtypeREAL1;
11321
11322     case FFECOM_rttypeDOUBLE_:
11323     case FFECOM_rttypeDOUBLEREAL_:
11324       return FFEINFO_kindtypeREAL2;
11325
11326     case FFECOM_rttypeDBLCMPLX_F2C_:
11327     case FFECOM_rttypeDBLCMPLX_GNU_:
11328       return FFEINFO_kindtypeREAL2;
11329
11330     case FFECOM_rttypeCHARACTER_:
11331       return FFEINFO_kindtypeCHARACTER1;
11332
11333     default:
11334       return FFEINFO_kindtypeANY;
11335     }
11336 }
11337
11338 void
11339 ffecom_init_0 ()
11340 {
11341   tree endlink;
11342   int i;
11343   int j;
11344   tree t;
11345   tree field;
11346   ffetype type;
11347   ffetype base_type;
11348   tree double_ftype_double;
11349   tree float_ftype_float;
11350   tree ldouble_ftype_ldouble;
11351   tree ffecom_tree_ptr_to_fun_type_void;
11352
11353   /* This block of code comes from the now-obsolete cktyps.c.  It checks
11354      whether the compiler environment is buggy in known ways, some of which
11355      would, if not explicitly checked here, result in subtle bugs in g77.  */
11356
11357   if (ffe_is_do_internal_checks ())
11358     {
11359       static char names[][12]
11360         =
11361       {"bar", "bletch", "foo", "foobar"};
11362       char *name;
11363       unsigned long ul;
11364       double fl;
11365
11366       name = bsearch ("foo", &names[0], ARRAY_SIZE (names), sizeof (names[0]),
11367                       (int (*)(const void *, const void *)) strcmp);
11368       if (name != (char *) &names[2])
11369         {
11370           assert ("bsearch doesn't work, #define FFEPROJ_BSEARCH 0 in proj.h"
11371                   == NULL);
11372           abort ();
11373         }
11374
11375       ul = strtoul ("123456789", NULL, 10);
11376       if (ul != 123456789L)
11377         {
11378           assert ("strtoul doesn't have enough range, #define FFEPROJ_STRTOUL 0\
11379  in proj.h" == NULL);
11380           abort ();
11381         }
11382
11383       fl = atof ("56.789");
11384       if ((fl < 56.788) || (fl > 56.79))
11385         {
11386           assert ("atof not type double, fix your #include <stdio.h>"
11387                   == NULL);
11388           abort ();
11389         }
11390     }
11391
11392 #if FFECOM_GCC_INCLUDE
11393   ffecom_initialize_char_syntax_ ();
11394 #endif
11395
11396   ffecom_outer_function_decl_ = NULL_TREE;
11397   current_function_decl = NULL_TREE;
11398   named_labels = NULL_TREE;
11399   current_binding_level = NULL_BINDING_LEVEL;
11400   free_binding_level = NULL_BINDING_LEVEL;
11401   /* Make the binding_level structure for global names.  */
11402   pushlevel (0);
11403   global_binding_level = current_binding_level;
11404   current_binding_level->prep_state = 2;
11405
11406   build_common_tree_nodes (1);
11407
11408   /* Define `int' and `char' first so that dbx will output them first.  */
11409   pushdecl (build_decl (TYPE_DECL, get_identifier ("int"),
11410                         integer_type_node));
11411   /* CHARACTER*1 is unsigned in ICHAR contexts.  */
11412   char_type_node = make_unsigned_type (CHAR_TYPE_SIZE);
11413   pushdecl (build_decl (TYPE_DECL, get_identifier ("char"),
11414                         char_type_node));
11415   pushdecl (build_decl (TYPE_DECL, get_identifier ("long int"),
11416                         long_integer_type_node));
11417   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned int"),
11418                         unsigned_type_node));
11419   pushdecl (build_decl (TYPE_DECL, get_identifier ("long unsigned int"),
11420                         long_unsigned_type_node));
11421   pushdecl (build_decl (TYPE_DECL, get_identifier ("long long int"),
11422                         long_long_integer_type_node));
11423   pushdecl (build_decl (TYPE_DECL, get_identifier ("long long unsigned int"),
11424                         long_long_unsigned_type_node));
11425   pushdecl (build_decl (TYPE_DECL, get_identifier ("short int"),
11426                         short_integer_type_node));
11427   pushdecl (build_decl (TYPE_DECL, get_identifier ("short unsigned int"),
11428                         short_unsigned_type_node));
11429
11430   /* Set the sizetype before we make other types.  This *should* be the
11431      first type we create.  */
11432
11433   set_sizetype
11434     (TREE_TYPE (IDENTIFIER_GLOBAL_VALUE (get_identifier (SIZE_TYPE))));
11435   ffecom_typesize_pointer_
11436     = TREE_INT_CST_LOW (TYPE_SIZE (sizetype)) / BITS_PER_UNIT;
11437
11438   build_common_tree_nodes_2 (0);
11439
11440   /* Define both `signed char' and `unsigned char'.  */
11441   pushdecl (build_decl (TYPE_DECL, get_identifier ("signed char"),
11442                         signed_char_type_node));
11443
11444   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned char"),
11445                         unsigned_char_type_node));
11446
11447   pushdecl (build_decl (TYPE_DECL, get_identifier ("float"),
11448                         float_type_node));
11449   pushdecl (build_decl (TYPE_DECL, get_identifier ("double"),
11450                         double_type_node));
11451   pushdecl (build_decl (TYPE_DECL, get_identifier ("long double"),
11452                         long_double_type_node));
11453
11454   /* For now, override what build_common_tree_nodes has done.  */
11455   complex_integer_type_node = ffecom_make_complex_type_ (integer_type_node);
11456   complex_float_type_node = ffecom_make_complex_type_ (float_type_node);
11457   complex_double_type_node = ffecom_make_complex_type_ (double_type_node);
11458   complex_long_double_type_node
11459     = ffecom_make_complex_type_ (long_double_type_node);
11460
11461   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex int"),
11462                         complex_integer_type_node));
11463   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex float"),
11464                         complex_float_type_node));
11465   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex double"),
11466                         complex_double_type_node));
11467   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex long double"),
11468                         complex_long_double_type_node));
11469
11470   pushdecl (build_decl (TYPE_DECL, get_identifier ("void"),
11471                         void_type_node));
11472   /* We are not going to have real types in C with less than byte alignment,
11473      so we might as well not have any types that claim to have it.  */
11474   TYPE_ALIGN (void_type_node) = BITS_PER_UNIT;
11475   TYPE_USER_ALIGN (void_type_node) = 0;
11476
11477   string_type_node = build_pointer_type (char_type_node);
11478
11479   ffecom_tree_fun_type_void
11480     = build_function_type (void_type_node, NULL_TREE);
11481
11482   ffecom_tree_ptr_to_fun_type_void
11483     = build_pointer_type (ffecom_tree_fun_type_void);
11484
11485   endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE);
11486
11487   float_ftype_float
11488     = build_function_type (float_type_node,
11489                            tree_cons (NULL_TREE, float_type_node, endlink));
11490
11491   double_ftype_double
11492     = build_function_type (double_type_node,
11493                            tree_cons (NULL_TREE, double_type_node, endlink));
11494
11495   ldouble_ftype_ldouble
11496     = build_function_type (long_double_type_node,
11497                            tree_cons (NULL_TREE, long_double_type_node,
11498                                       endlink));
11499
11500   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11501     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11502       {
11503         ffecom_tree_type[i][j] = NULL_TREE;
11504         ffecom_tree_fun_type[i][j] = NULL_TREE;
11505         ffecom_tree_ptr_to_fun_type[i][j] = NULL_TREE;
11506         ffecom_f2c_typecode_[i][j] = -1;
11507       }
11508
11509   /* Set up standard g77 types.  Note that INTEGER and LOGICAL are set
11510      to size FLOAT_TYPE_SIZE because they have to be the same size as
11511      REAL, which also is FLOAT_TYPE_SIZE, according to the standard.
11512      Compiler options and other such stuff that change the ways these
11513      types are set should not affect this particular setup.  */
11514
11515   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1]
11516     = t = make_signed_type (FLOAT_TYPE_SIZE);
11517   pushdecl (build_decl (TYPE_DECL, get_identifier ("integer"),
11518                         t));
11519   type = ffetype_new ();
11520   base_type = type;
11521   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER1,
11522                     type);
11523   ffetype_set_ams (type,
11524                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11525                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11526   ffetype_set_star (base_type,
11527                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11528                     type);
11529   ffetype_set_kind (base_type, 1, type);
11530   ffecom_typesize_integer1_ = ffetype_size (type);
11531   assert (ffetype_size (type) == sizeof (ffetargetInteger1));
11532
11533   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER1]
11534     = t = make_unsigned_type (FLOAT_TYPE_SIZE); /* HOLLERITH means unsigned. */
11535   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned"),
11536                         t));
11537
11538   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER2]
11539     = t = make_signed_type (CHAR_TYPE_SIZE);
11540   pushdecl (build_decl (TYPE_DECL, get_identifier ("byte"),
11541                         t));
11542   type = ffetype_new ();
11543   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER2,
11544                     type);
11545   ffetype_set_ams (type,
11546                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11547                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11548   ffetype_set_star (base_type,
11549                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11550                     type);
11551   ffetype_set_kind (base_type, 3, type);
11552   assert (ffetype_size (type) == sizeof (ffetargetInteger2));
11553
11554   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER2]
11555     = t = make_unsigned_type (CHAR_TYPE_SIZE);
11556   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned byte"),
11557                         t));
11558
11559   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER3]
11560     = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11561   pushdecl (build_decl (TYPE_DECL, get_identifier ("word"),
11562                         t));
11563   type = ffetype_new ();
11564   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER3,
11565                     type);
11566   ffetype_set_ams (type,
11567                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11568                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11569   ffetype_set_star (base_type,
11570                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11571                     type);
11572   ffetype_set_kind (base_type, 6, type);
11573   assert (ffetype_size (type) == sizeof (ffetargetInteger3));
11574
11575   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER3]
11576     = t = make_unsigned_type (CHAR_TYPE_SIZE * 2);
11577   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned word"),
11578                         t));
11579
11580   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER4]
11581     = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11582   pushdecl (build_decl (TYPE_DECL, get_identifier ("integer4"),
11583                         t));
11584   type = ffetype_new ();
11585   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER4,
11586                     type);
11587   ffetype_set_ams (type,
11588                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11589                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11590   ffetype_set_star (base_type,
11591                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11592                     type);
11593   ffetype_set_kind (base_type, 2, type);
11594   assert (ffetype_size (type) == sizeof (ffetargetInteger4));
11595
11596   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER4]
11597     = t = make_unsigned_type (FLOAT_TYPE_SIZE * 2);
11598   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned4"),
11599                         t));
11600
11601 #if 0
11602   if (ffe_is_do_internal_checks ()
11603       && LONG_TYPE_SIZE != FLOAT_TYPE_SIZE
11604       && LONG_TYPE_SIZE != CHAR_TYPE_SIZE
11605       && LONG_TYPE_SIZE != SHORT_TYPE_SIZE
11606       && LONG_TYPE_SIZE != LONG_LONG_TYPE_SIZE)
11607     {
11608       fprintf (stderr, "Sorry, no g77 support for LONG_TYPE_SIZE (%d bits) yet.\n",
11609                LONG_TYPE_SIZE);
11610     }
11611 #endif
11612
11613   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL1]
11614     = t = make_signed_type (FLOAT_TYPE_SIZE);
11615   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical"),
11616                         t));
11617   type = ffetype_new ();
11618   base_type = type;
11619   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL1,
11620                     type);
11621   ffetype_set_ams (type,
11622                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11623                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11624   ffetype_set_star (base_type,
11625                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11626                     type);
11627   ffetype_set_kind (base_type, 1, type);
11628   assert (ffetype_size (type) == sizeof (ffetargetLogical1));
11629
11630   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL2]
11631     = t = make_signed_type (CHAR_TYPE_SIZE);
11632   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical2"),
11633                         t));
11634   type = ffetype_new ();
11635   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL2,
11636                     type);
11637   ffetype_set_ams (type,
11638                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11639                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11640   ffetype_set_star (base_type,
11641                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11642                     type);
11643   ffetype_set_kind (base_type, 3, type);
11644   assert (ffetype_size (type) == sizeof (ffetargetLogical2));
11645
11646   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL3]
11647     = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11648   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical3"),
11649                         t));
11650   type = ffetype_new ();
11651   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL3,
11652                     type);
11653   ffetype_set_ams (type,
11654                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11655                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11656   ffetype_set_star (base_type,
11657                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11658                     type);
11659   ffetype_set_kind (base_type, 6, type);
11660   assert (ffetype_size (type) == sizeof (ffetargetLogical3));
11661
11662   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL4]
11663     = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11664   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical4"),
11665                         t));
11666   type = ffetype_new ();
11667   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL4,
11668                     type);
11669   ffetype_set_ams (type,
11670                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11671                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11672   ffetype_set_star (base_type,
11673                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11674                     type);
11675   ffetype_set_kind (base_type, 2, type);
11676   assert (ffetype_size (type) == sizeof (ffetargetLogical4));
11677
11678   ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11679     = t = make_node (REAL_TYPE);
11680   TYPE_PRECISION (t) = FLOAT_TYPE_SIZE;
11681   pushdecl (build_decl (TYPE_DECL, get_identifier ("real"),
11682                         t));
11683   layout_type (t);
11684   type = ffetype_new ();
11685   base_type = type;
11686   ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL1,
11687                     type);
11688   ffetype_set_ams (type,
11689                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11690                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11691   ffetype_set_star (base_type,
11692                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11693                     type);
11694   ffetype_set_kind (base_type, 1, type);
11695   ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11696     = FFETARGET_f2cTYREAL;
11697   assert (ffetype_size (type) == sizeof (ffetargetReal1));
11698
11699   ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREALDOUBLE]
11700     = t = make_node (REAL_TYPE);
11701   TYPE_PRECISION (t) = FLOAT_TYPE_SIZE * 2;     /* Always twice REAL. */
11702   pushdecl (build_decl (TYPE_DECL, get_identifier ("double precision"),
11703                         t));
11704   layout_type (t);
11705   type = ffetype_new ();
11706   ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE,
11707                     type);
11708   ffetype_set_ams (type,
11709                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11710                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11711   ffetype_set_star (base_type,
11712                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11713                     type);
11714   ffetype_set_kind (base_type, 2, type);
11715   ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]
11716     = FFETARGET_f2cTYDREAL;
11717   assert (ffetype_size (type) == sizeof (ffetargetReal2));
11718
11719   ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11720     = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]);
11721   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex"),
11722                         t));
11723   type = ffetype_new ();
11724   base_type = type;
11725   ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL1,
11726                     type);
11727   ffetype_set_ams (type,
11728                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11729                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11730   ffetype_set_star (base_type,
11731                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11732                     type);
11733   ffetype_set_kind (base_type, 1, type);
11734   ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11735     = FFETARGET_f2cTYCOMPLEX;
11736   assert (ffetype_size (type) == sizeof (ffetargetComplex1));
11737
11738   ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREALDOUBLE]
11739     = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]);
11740   pushdecl (build_decl (TYPE_DECL, get_identifier ("double complex"),
11741                         t));
11742   type = ffetype_new ();
11743   ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREALDOUBLE,
11744                     type);
11745   ffetype_set_ams (type,
11746                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11747                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11748   ffetype_set_star (base_type,
11749                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11750                     type);
11751   ffetype_set_kind (base_type, 2,
11752                     type);
11753   ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL2]
11754     = FFETARGET_f2cTYDCOMPLEX;
11755   assert (ffetype_size (type) == sizeof (ffetargetComplex2));
11756
11757   /* Make function and ptr-to-function types for non-CHARACTER types. */
11758
11759   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11760     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11761       {
11762         if ((t = ffecom_tree_type[i][j]) != NULL_TREE)
11763           {
11764             if (i == FFEINFO_basictypeINTEGER)
11765               {
11766                 /* Figure out the smallest INTEGER type that can hold
11767                    a pointer on this machine. */
11768                 if (GET_MODE_SIZE (TYPE_MODE (t))
11769                     >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
11770                   {
11771                     if ((ffecom_pointer_kind_ == FFEINFO_kindtypeNONE)
11772                         || (GET_MODE_SIZE (TYPE_MODE (ffecom_tree_type[i][ffecom_pointer_kind_]))
11773                             > GET_MODE_SIZE (TYPE_MODE (t))))
11774                       ffecom_pointer_kind_ = j;
11775                   }
11776               }
11777             else if (i == FFEINFO_basictypeCOMPLEX)
11778               t = void_type_node;
11779             /* For f2c compatibility, REAL functions are really
11780                implemented as DOUBLE PRECISION.  */
11781             else if ((i == FFEINFO_basictypeREAL)
11782                      && (j == FFEINFO_kindtypeREAL1))
11783               t = ffecom_tree_type
11784                 [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2];
11785
11786             t = ffecom_tree_fun_type[i][j] = build_function_type (t,
11787                                                                   NULL_TREE);
11788             ffecom_tree_ptr_to_fun_type[i][j] = build_pointer_type (t);
11789           }
11790       }
11791
11792   /* Set up pointer types.  */
11793
11794   if (ffecom_pointer_kind_ == FFEINFO_basictypeNONE)
11795     fatal_error ("no INTEGER type can hold a pointer on this configuration");
11796   else if (0 && ffe_is_do_internal_checks ())
11797     fprintf (stderr, "Pointer type kt=%d\n", ffecom_pointer_kind_);
11798   ffetype_set_kind (ffeinfo_type (FFEINFO_basictypeINTEGER,
11799                                   FFEINFO_kindtypeINTEGERDEFAULT),
11800                     7,
11801                     ffeinfo_type (FFEINFO_basictypeINTEGER,
11802                                   ffecom_pointer_kind_));
11803
11804   if (ffe_is_ugly_assign ())
11805     ffecom_label_kind_ = ffecom_pointer_kind_;  /* Require ASSIGN etc to this. */
11806   else
11807     ffecom_label_kind_ = FFEINFO_kindtypeINTEGERDEFAULT;
11808   if (0 && ffe_is_do_internal_checks ())
11809     fprintf (stderr, "Label type kt=%d\n", ffecom_label_kind_);
11810
11811   ffecom_integer_type_node
11812     = ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1];
11813   ffecom_integer_zero_node = convert (ffecom_integer_type_node,
11814                                       integer_zero_node);
11815   ffecom_integer_one_node = convert (ffecom_integer_type_node,
11816                                      integer_one_node);
11817
11818   /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional.
11819      Turns out that by TYLONG, runtime/libI77/lio.h really means
11820      "whatever size an ftnint is".  For consistency and sanity,
11821      com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen
11822      all are INTEGER, which we also make out of whatever back-end
11823      integer type is FLOAT_TYPE_SIZE bits wide.  This change, from
11824      LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to
11825      accommodate machines like the Alpha.  Note that this suggests
11826      f2c and libf2c are missing a distinction perhaps needed on
11827      some machines between "int" and "long int".  -- burley 0.5.5 950215 */
11828
11829   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, FLOAT_TYPE_SIZE,
11830                             FFETARGET_f2cTYLONG);
11831   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, SHORT_TYPE_SIZE,
11832                             FFETARGET_f2cTYSHORT);
11833   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, CHAR_TYPE_SIZE,
11834                             FFETARGET_f2cTYINT1);
11835   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, LONG_LONG_TYPE_SIZE,
11836                             FFETARGET_f2cTYQUAD);
11837   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, FLOAT_TYPE_SIZE,
11838                             FFETARGET_f2cTYLOGICAL);
11839   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, SHORT_TYPE_SIZE,
11840                             FFETARGET_f2cTYLOGICAL2);
11841   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, CHAR_TYPE_SIZE,
11842                             FFETARGET_f2cTYLOGICAL1);
11843   /* ~~~Not really such a type in libf2c, e.g. I/O support?  */
11844   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, LONG_LONG_TYPE_SIZE,
11845                             FFETARGET_f2cTYQUAD);
11846
11847   /* CHARACTER stuff is all special-cased, so it is not handled in the above
11848      loop.  CHARACTER items are built as arrays of unsigned char.  */
11849
11850   ffecom_tree_type[FFEINFO_basictypeCHARACTER]
11851     [FFEINFO_kindtypeCHARACTER1] = t = char_type_node;
11852   type = ffetype_new ();
11853   base_type = type;
11854   ffeinfo_set_type (FFEINFO_basictypeCHARACTER,
11855                     FFEINFO_kindtypeCHARACTER1,
11856                     type);
11857   ffetype_set_ams (type,
11858                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11859                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11860   ffetype_set_kind (base_type, 1, type);
11861   assert (ffetype_size (type)
11862           == sizeof (((ffetargetCharacter1) { 0, NULL }).text[0]));
11863
11864   ffecom_tree_fun_type[FFEINFO_basictypeCHARACTER]
11865     [FFEINFO_kindtypeCHARACTER1] = ffecom_tree_fun_type_void;
11866   ffecom_tree_ptr_to_fun_type[FFEINFO_basictypeCHARACTER]
11867     [FFEINFO_kindtypeCHARACTER1]
11868     = ffecom_tree_ptr_to_fun_type_void;
11869   ffecom_f2c_typecode_[FFEINFO_basictypeCHARACTER][FFEINFO_kindtypeCHARACTER1]
11870     = FFETARGET_f2cTYCHAR;
11871
11872   ffecom_f2c_typecode_[FFEINFO_basictypeANY][FFEINFO_kindtypeANY]
11873     = 0;
11874
11875   /* Make multi-return-value type and fields. */
11876
11877   ffecom_multi_type_node_ = make_node (UNION_TYPE);
11878
11879   field = NULL_TREE;
11880
11881   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11882     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11883       {
11884         char name[30];
11885
11886         if (ffecom_tree_type[i][j] == NULL_TREE)
11887           continue;             /* Not supported. */
11888         sprintf (&name[0], "bt_%s_kt_%s",
11889                  ffeinfo_basictype_string ((ffeinfoBasictype) i),
11890                  ffeinfo_kindtype_string ((ffeinfoKindtype) j));
11891         ffecom_multi_fields_[i][j] = build_decl (FIELD_DECL,
11892                                                  get_identifier (name),
11893                                                  ffecom_tree_type[i][j]);
11894         DECL_CONTEXT (ffecom_multi_fields_[i][j])
11895           = ffecom_multi_type_node_;
11896         DECL_ALIGN (ffecom_multi_fields_[i][j]) = 0;
11897         DECL_USER_ALIGN (ffecom_multi_fields_[i][j]) = 0;
11898         TREE_CHAIN (ffecom_multi_fields_[i][j]) = field;
11899         field = ffecom_multi_fields_[i][j];
11900       }
11901
11902   TYPE_FIELDS (ffecom_multi_type_node_) = field;
11903   layout_type (ffecom_multi_type_node_);
11904
11905   /* Subroutines usually return integer because they might have alternate
11906      returns. */
11907
11908   ffecom_tree_subr_type
11909     = build_function_type (integer_type_node, NULL_TREE);
11910   ffecom_tree_ptr_to_subr_type
11911     = build_pointer_type (ffecom_tree_subr_type);
11912   ffecom_tree_blockdata_type
11913     = build_function_type (void_type_node, NULL_TREE);
11914
11915   builtin_function ("__builtin_sqrtf", float_ftype_float,
11916                     BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrtf");
11917   builtin_function ("__builtin_fsqrt", double_ftype_double,
11918                     BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrt");
11919   builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble,
11920                     BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrtl");
11921   builtin_function ("__builtin_sinf", float_ftype_float,
11922                     BUILT_IN_SIN, BUILT_IN_NORMAL, "sinf");
11923   builtin_function ("__builtin_sin", double_ftype_double,
11924                     BUILT_IN_SIN, BUILT_IN_NORMAL, "sin");
11925   builtin_function ("__builtin_sinl", ldouble_ftype_ldouble,
11926                     BUILT_IN_SIN, BUILT_IN_NORMAL, "sinl");
11927   builtin_function ("__builtin_cosf", float_ftype_float,
11928                     BUILT_IN_COS, BUILT_IN_NORMAL, "cosf");
11929   builtin_function ("__builtin_cos", double_ftype_double,
11930                     BUILT_IN_COS, BUILT_IN_NORMAL, "cos");
11931   builtin_function ("__builtin_cosl", ldouble_ftype_ldouble,
11932                     BUILT_IN_COS, BUILT_IN_NORMAL, "cosl");
11933
11934 #if BUILT_FOR_270
11935   pedantic_lvalues = FALSE;
11936 #endif
11937
11938   ffecom_f2c_make_type_ (&ffecom_f2c_integer_type_node,
11939                          FFECOM_f2cINTEGER,
11940                          "integer");
11941   ffecom_f2c_make_type_ (&ffecom_f2c_address_type_node,
11942                          FFECOM_f2cADDRESS,
11943                          "address");
11944   ffecom_f2c_make_type_ (&ffecom_f2c_real_type_node,
11945                          FFECOM_f2cREAL,
11946                          "real");
11947   ffecom_f2c_make_type_ (&ffecom_f2c_doublereal_type_node,
11948                          FFECOM_f2cDOUBLEREAL,
11949                          "doublereal");
11950   ffecom_f2c_make_type_ (&ffecom_f2c_complex_type_node,
11951                          FFECOM_f2cCOMPLEX,
11952                          "complex");
11953   ffecom_f2c_make_type_ (&ffecom_f2c_doublecomplex_type_node,
11954                          FFECOM_f2cDOUBLECOMPLEX,
11955                          "doublecomplex");
11956   ffecom_f2c_make_type_ (&ffecom_f2c_longint_type_node,
11957                          FFECOM_f2cLONGINT,
11958                          "longint");
11959   ffecom_f2c_make_type_ (&ffecom_f2c_logical_type_node,
11960                          FFECOM_f2cLOGICAL,
11961                          "logical");
11962   ffecom_f2c_make_type_ (&ffecom_f2c_flag_type_node,
11963                          FFECOM_f2cFLAG,
11964                          "flag");
11965   ffecom_f2c_make_type_ (&ffecom_f2c_ftnlen_type_node,
11966                          FFECOM_f2cFTNLEN,
11967                          "ftnlen");
11968   ffecom_f2c_make_type_ (&ffecom_f2c_ftnint_type_node,
11969                          FFECOM_f2cFTNINT,
11970                          "ftnint");
11971
11972   ffecom_f2c_ftnlen_zero_node
11973     = convert (ffecom_f2c_ftnlen_type_node, integer_zero_node);
11974
11975   ffecom_f2c_ftnlen_one_node
11976     = convert (ffecom_f2c_ftnlen_type_node, integer_one_node);
11977
11978   ffecom_f2c_ftnlen_two_node = build_int_2 (2, 0);
11979   TREE_TYPE (ffecom_f2c_ftnlen_two_node) = ffecom_integer_type_node;
11980
11981   ffecom_f2c_ptr_to_ftnlen_type_node
11982     = build_pointer_type (ffecom_f2c_ftnlen_type_node);
11983
11984   ffecom_f2c_ptr_to_ftnint_type_node
11985     = build_pointer_type (ffecom_f2c_ftnint_type_node);
11986
11987   ffecom_f2c_ptr_to_integer_type_node
11988     = build_pointer_type (ffecom_f2c_integer_type_node);
11989
11990   ffecom_f2c_ptr_to_real_type_node
11991     = build_pointer_type (ffecom_f2c_real_type_node);
11992
11993   ffecom_float_zero_ = build_real (float_type_node, dconst0);
11994   ffecom_double_zero_ = build_real (double_type_node, dconst0);
11995   {
11996     REAL_VALUE_TYPE point_5;
11997
11998 #ifdef REAL_ARITHMETIC
11999     REAL_ARITHMETIC (point_5, RDIV_EXPR, dconst1, dconst2);
12000 #else
12001     point_5 = .5;
12002 #endif
12003     ffecom_float_half_ = build_real (float_type_node, point_5);
12004     ffecom_double_half_ = build_real (double_type_node, point_5);
12005   }
12006
12007   /* Do "extern int xargc;".  */
12008
12009   ffecom_tree_xargc_ = build_decl (VAR_DECL,
12010                                    get_identifier ("f__xargc"),
12011                                    integer_type_node);
12012   DECL_EXTERNAL (ffecom_tree_xargc_) = 1;
12013   TREE_STATIC (ffecom_tree_xargc_) = 1;
12014   TREE_PUBLIC (ffecom_tree_xargc_) = 1;
12015   ffecom_tree_xargc_ = start_decl (ffecom_tree_xargc_, FALSE);
12016   finish_decl (ffecom_tree_xargc_, NULL_TREE, FALSE);
12017
12018 #if 0   /* This is being fixed, and seems to be working now. */
12019   if ((FLOAT_TYPE_SIZE != 32)
12020       || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))) != 32))
12021     {
12022       warning ("configuration: REAL, INTEGER, and LOGICAL are %d bits wide,",
12023                (int) FLOAT_TYPE_SIZE);
12024       warning ("and pointers are %d bits wide, but g77 doesn't yet work",
12025           (int) TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))));
12026       warning ("properly unless they all are 32 bits wide.");
12027       warning ("Please keep this in mind before you report bugs.  g77 should");
12028       warning ("support non-32-bit machines better as of version 0.6.");
12029     }
12030 #endif
12031
12032 #if 0   /* Code in ste.c that would crash has been commented out. */
12033   if (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)
12034       < TYPE_PRECISION (string_type_node))
12035     /* I/O will probably crash.  */
12036     warning ("configuration: char * holds %d bits, but ftnlen only %d",
12037              TYPE_PRECISION (string_type_node),
12038              TYPE_PRECISION (ffecom_f2c_ftnlen_type_node));
12039 #endif
12040
12041 #if 0   /* ASSIGN-related stuff has been changed to accommodate this. */
12042   if (TYPE_PRECISION (ffecom_integer_type_node)
12043       < TYPE_PRECISION (string_type_node))
12044     /* ASSIGN 10 TO I will crash.  */
12045     warning ("configuration: char * holds %d bits, but INTEGER only %d --\n\
12046  ASSIGN statement might fail",
12047              TYPE_PRECISION (string_type_node),
12048              TYPE_PRECISION (ffecom_integer_type_node));
12049 #endif
12050 }
12051
12052 #endif
12053 /* ffecom_init_2 -- Initialize
12054
12055    ffecom_init_2();  */
12056
12057 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12058 void
12059 ffecom_init_2 ()
12060 {
12061   assert (ffecom_outer_function_decl_ == NULL_TREE);
12062   assert (current_function_decl == NULL_TREE);
12063   assert (ffecom_which_entrypoint_decl_ == NULL_TREE);
12064
12065   ffecom_master_arglist_ = NULL;
12066   ++ffecom_num_fns_;
12067   ffecom_primary_entry_ = NULL;
12068   ffecom_is_altreturning_ = FALSE;
12069   ffecom_func_result_ = NULL_TREE;
12070   ffecom_multi_retval_ = NULL_TREE;
12071 }
12072
12073 #endif
12074 /* ffecom_list_expr -- Transform list of exprs into gcc tree
12075
12076    tree t;
12077    ffebld expr;  // FFE opITEM list.
12078    tree = ffecom_list_expr(expr);
12079
12080    List of actual args is transformed into corresponding gcc backend list.  */
12081
12082 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12083 tree
12084 ffecom_list_expr (ffebld expr)
12085 {
12086   tree list;
12087   tree *plist = &list;
12088   tree trail = NULL_TREE;       /* Append char length args here. */
12089   tree *ptrail = &trail;
12090   tree length;
12091
12092   while (expr != NULL)
12093     {
12094       tree texpr = ffecom_arg_expr (ffebld_head (expr), &length);
12095
12096       if (texpr == error_mark_node)
12097         return error_mark_node;
12098
12099       *plist = build_tree_list (NULL_TREE, texpr);
12100       plist = &TREE_CHAIN (*plist);
12101       expr = ffebld_trail (expr);
12102       if (length != NULL_TREE)
12103         {
12104           *ptrail = build_tree_list (NULL_TREE, length);
12105           ptrail = &TREE_CHAIN (*ptrail);
12106         }
12107     }
12108
12109   *plist = trail;
12110
12111   return list;
12112 }
12113
12114 #endif
12115 /* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree
12116
12117    tree t;
12118    ffebld expr;  // FFE opITEM list.
12119    tree = ffecom_list_ptr_to_expr(expr);
12120
12121    List of actual args is transformed into corresponding gcc backend list for
12122    use in calling an external procedure (vs. a statement function).  */
12123
12124 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12125 tree
12126 ffecom_list_ptr_to_expr (ffebld expr)
12127 {
12128   tree list;
12129   tree *plist = &list;
12130   tree trail = NULL_TREE;       /* Append char length args here. */
12131   tree *ptrail = &trail;
12132   tree length;
12133
12134   while (expr != NULL)
12135     {
12136       tree texpr = ffecom_arg_ptr_to_expr (ffebld_head (expr), &length);
12137
12138       if (texpr == error_mark_node)
12139         return error_mark_node;
12140
12141       *plist = build_tree_list (NULL_TREE, texpr);
12142       plist = &TREE_CHAIN (*plist);
12143       expr = ffebld_trail (expr);
12144       if (length != NULL_TREE)
12145         {
12146           *ptrail = build_tree_list (NULL_TREE, length);
12147           ptrail = &TREE_CHAIN (*ptrail);
12148         }
12149     }
12150
12151   *plist = trail;
12152
12153   return list;
12154 }
12155
12156 #endif
12157 /* Obtain gcc's LABEL_DECL tree for label.  */
12158
12159 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12160 tree
12161 ffecom_lookup_label (ffelab label)
12162 {
12163   tree glabel;
12164
12165   if (ffelab_hook (label) == NULL_TREE)
12166     {
12167       char labelname[16];
12168
12169       switch (ffelab_type (label))
12170         {
12171         case FFELAB_typeLOOPEND:
12172         case FFELAB_typeNOTLOOP:
12173         case FFELAB_typeENDIF:
12174           sprintf (labelname, "%" ffelabValue_f "u", ffelab_value (label));
12175           glabel = build_decl (LABEL_DECL, get_identifier (labelname),
12176                                void_type_node);
12177           DECL_CONTEXT (glabel) = current_function_decl;
12178           DECL_MODE (glabel) = VOIDmode;
12179           break;
12180
12181         case FFELAB_typeFORMAT:
12182           glabel = build_decl (VAR_DECL,
12183                                ffecom_get_invented_identifier
12184                                ("__g77_format_%d", (int) ffelab_value (label)),
12185                                build_type_variant (build_array_type
12186                                                    (char_type_node,
12187                                                     NULL_TREE),
12188                                                    1, 0));
12189           TREE_CONSTANT (glabel) = 1;
12190           TREE_STATIC (glabel) = 1;
12191           DECL_CONTEXT (glabel) = current_function_decl;
12192           DECL_INITIAL (glabel) = NULL;
12193           make_decl_rtl (glabel, NULL);
12194           expand_decl (glabel);
12195
12196           ffecom_save_tree_forever (glabel);
12197
12198           break;
12199
12200         case FFELAB_typeANY:
12201           glabel = error_mark_node;
12202           break;
12203
12204         default:
12205           assert ("bad label type" == NULL);
12206           glabel = NULL;
12207           break;
12208         }
12209       ffelab_set_hook (label, glabel);
12210     }
12211   else
12212     {
12213       glabel = ffelab_hook (label);
12214     }
12215
12216   return glabel;
12217 }
12218
12219 #endif
12220 /* Stabilizes the arguments.  Don't use this if the lhs and rhs come from
12221    a single source specification (as in the fourth argument of MVBITS).
12222    If the type is NULL_TREE, the type of lhs is used to make the type of
12223    the MODIFY_EXPR.  */
12224
12225 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12226 tree
12227 ffecom_modify (tree newtype, tree lhs,
12228                tree rhs)
12229 {
12230   if (lhs == error_mark_node || rhs == error_mark_node)
12231     return error_mark_node;
12232
12233   if (newtype == NULL_TREE)
12234     newtype = TREE_TYPE (lhs);
12235
12236   if (TREE_SIDE_EFFECTS (lhs))
12237     lhs = stabilize_reference (lhs);
12238
12239   return ffecom_2s (MODIFY_EXPR, newtype, lhs, rhs);
12240 }
12241
12242 #endif
12243
12244 /* Register source file name.  */
12245
12246 void
12247 ffecom_file (const char *name)
12248 {
12249 #if FFECOM_GCC_INCLUDE
12250   ffecom_file_ (name);
12251 #endif
12252 }
12253
12254 /* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed
12255
12256    ffestorag st;
12257    ffecom_notify_init_storage(st);
12258
12259    Gets called when all possible units in an aggregate storage area (a LOCAL
12260    with equivalences or a COMMON) have been initialized.  The initialization
12261    info either is in ffestorag_init or, if that is NULL,
12262    ffestorag_accretion:
12263
12264    ffestorag_init may contain an opCONTER or opARRTER.  opCONTER may occur
12265    even for an array if the array is one element in length!
12266
12267    ffestorag_accretion will contain an opACCTER.  It is much like an
12268    opARRTER except it has an ffebit object in it instead of just a size.
12269    The back end can use the info in the ffebit object, if it wants, to
12270    reduce the amount of actual initialization, but in any case it should
12271    kill the ffebit object when done.  Also, set accretion to NULL but
12272    init to a non-NULL value.
12273
12274    After performing initialization, DO NOT set init to NULL, because that'll
12275    tell the front end it is ok for more initialization to happen.  Instead,
12276    set init to an opANY expression or some such thing that you can use to
12277    tell that you've already initialized the object.
12278
12279    27-Oct-91  JCB  1.1
12280       Support two-pass FFE.  */
12281
12282 void
12283 ffecom_notify_init_storage (ffestorag st)
12284 {
12285   ffebld init;                  /* The initialization expression. */
12286 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12287   ffetargetOffset size;         /* The size of the entity. */
12288   ffetargetAlign pad;           /* Its initial padding. */
12289 #endif
12290
12291   if (ffestorag_init (st) == NULL)
12292     {
12293       init = ffestorag_accretion (st);
12294       assert (init != NULL);
12295       ffestorag_set_accretion (st, NULL);
12296       ffestorag_set_accretes (st, 0);
12297
12298 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12299       /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
12300       size = ffebld_accter_size (init);
12301       pad = ffebld_accter_pad (init);
12302       ffebit_kill (ffebld_accter_bits (init));
12303       ffebld_set_op (init, FFEBLD_opARRTER);
12304       ffebld_set_arrter (init, ffebld_accter (init));
12305       ffebld_arrter_set_size (init, size);
12306       ffebld_arrter_set_pad (init, size);
12307 #endif
12308
12309 #if FFECOM_TWOPASS
12310       ffestorag_set_init (st, init);
12311 #endif
12312     }
12313 #if FFECOM_ONEPASS
12314   else
12315     init = ffestorag_init (st);
12316 #endif
12317
12318 #if FFECOM_ONEPASS              /* Process the inits, wipe 'em out. */
12319   ffestorag_set_init (st, ffebld_new_any ());
12320
12321   if (ffebld_op (init) == FFEBLD_opANY)
12322     return;                     /* Oh, we already did this! */
12323
12324 #if FFECOM_targetCURRENT == FFECOM_targetFFE
12325   {
12326     ffesymbol s;
12327
12328     if (ffestorag_symbol (st) != NULL)
12329       s = ffestorag_symbol (st);
12330     else
12331       s = ffestorag_typesymbol (st);
12332
12333     fprintf (dmpout, "= initialize_storage \"%s\" ",
12334              (s != NULL) ? ffesymbol_text (s) : "(unnamed)");
12335     ffebld_dump (init);
12336     fputc ('\n', dmpout);
12337   }
12338 #endif
12339
12340 #endif /* if FFECOM_ONEPASS */
12341 }
12342
12343 /* ffecom_notify_init_symbol -- A symbol is now fully init'ed
12344
12345    ffesymbol s;
12346    ffecom_notify_init_symbol(s);
12347
12348    Gets called when all possible units in a symbol (not placed in COMMON
12349    or involved in EQUIVALENCE, unless it as yet has no ffestorag object)
12350    have been initialized.  The initialization info either is in
12351    ffesymbol_init or, if that is NULL, ffesymbol_accretion:
12352
12353    ffesymbol_init may contain an opCONTER or opARRTER.  opCONTER may occur
12354    even for an array if the array is one element in length!
12355
12356    ffesymbol_accretion will contain an opACCTER.  It is much like an
12357    opARRTER except it has an ffebit object in it instead of just a size.
12358    The back end can use the info in the ffebit object, if it wants, to
12359    reduce the amount of actual initialization, but in any case it should
12360    kill the ffebit object when done.  Also, set accretion to NULL but
12361    init to a non-NULL value.
12362
12363    After performing initialization, DO NOT set init to NULL, because that'll
12364    tell the front end it is ok for more initialization to happen.  Instead,
12365    set init to an opANY expression or some such thing that you can use to
12366    tell that you've already initialized the object.
12367
12368    27-Oct-91  JCB  1.1
12369       Support two-pass FFE.  */
12370
12371 void
12372 ffecom_notify_init_symbol (ffesymbol s)
12373 {
12374   ffebld init;                  /* The initialization expression. */
12375 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12376   ffetargetOffset size;         /* The size of the entity. */
12377   ffetargetAlign pad;           /* Its initial padding. */
12378 #endif
12379
12380   if (ffesymbol_storage (s) == NULL)
12381     return;                     /* Do nothing until COMMON/EQUIVALENCE
12382                                    possibilities checked. */
12383
12384   if ((ffesymbol_init (s) == NULL)
12385       && ((init = ffesymbol_accretion (s)) != NULL))
12386     {
12387       ffesymbol_set_accretion (s, NULL);
12388       ffesymbol_set_accretes (s, 0);
12389
12390 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12391       /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
12392       size = ffebld_accter_size (init);
12393       pad = ffebld_accter_pad (init);
12394       ffebit_kill (ffebld_accter_bits (init));
12395       ffebld_set_op (init, FFEBLD_opARRTER);
12396       ffebld_set_arrter (init, ffebld_accter (init));
12397       ffebld_arrter_set_size (init, size);
12398       ffebld_arrter_set_pad (init, size);
12399 #endif
12400
12401 #if FFECOM_TWOPASS
12402       ffesymbol_set_init (s, init);
12403 #endif
12404     }
12405 #if FFECOM_ONEPASS
12406   else
12407     init = ffesymbol_init (s);
12408 #endif
12409
12410 #if FFECOM_ONEPASS
12411   ffesymbol_set_init (s, ffebld_new_any ());
12412
12413   if (ffebld_op (init) == FFEBLD_opANY)
12414     return;                     /* Oh, we already did this! */
12415
12416 #if FFECOM_targetCURRENT == FFECOM_targetFFE
12417   fprintf (dmpout, "= initialize_symbol \"%s\" ", ffesymbol_text (s));
12418   ffebld_dump (init);
12419   fputc ('\n', dmpout);
12420 #endif
12421
12422 #endif /* if FFECOM_ONEPASS */
12423 }
12424
12425 /* ffecom_notify_primary_entry -- Learn which is the primary entry point
12426
12427    ffesymbol s;
12428    ffecom_notify_primary_entry(s);
12429
12430    Gets called when implicit or explicit PROGRAM statement seen or when
12431    FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary
12432    global symbol that serves as the entry point.  */
12433
12434 void
12435 ffecom_notify_primary_entry (ffesymbol s)
12436 {
12437   ffecom_primary_entry_ = s;
12438   ffecom_primary_entry_kind_ = ffesymbol_kind (s);
12439
12440   if ((ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
12441       || (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE))
12442     ffecom_primary_entry_is_proc_ = TRUE;
12443   else
12444     ffecom_primary_entry_is_proc_ = FALSE;
12445
12446   if (!ffe_is_silent ())
12447     {
12448       if (ffecom_primary_entry_kind_ == FFEINFO_kindPROGRAM)
12449         fprintf (stderr, "%s:\n", ffesymbol_text (s));
12450       else
12451         fprintf (stderr, "  %s:\n", ffesymbol_text (s));
12452     }
12453
12454 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12455   if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
12456     {
12457       ffebld list;
12458       ffebld arg;
12459
12460       for (list = ffesymbol_dummyargs (s);
12461            list != NULL;
12462            list = ffebld_trail (list))
12463         {
12464           arg = ffebld_head (list);
12465           if (ffebld_op (arg) == FFEBLD_opSTAR)
12466             {
12467               ffecom_is_altreturning_ = TRUE;
12468               break;
12469             }
12470         }
12471     }
12472 #endif
12473 }
12474
12475 FILE *
12476 ffecom_open_include (char *name, ffewhereLine l, ffewhereColumn c)
12477 {
12478 #if FFECOM_GCC_INCLUDE
12479   return ffecom_open_include_ (name, l, c);
12480 #else
12481   return fopen (name, "r");
12482 #endif
12483 }
12484
12485 /* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front
12486
12487    tree t;
12488    ffebld expr;  // FFE expression.
12489    tree = ffecom_ptr_to_expr(expr);
12490
12491    Like ffecom_expr, but sticks address-of in front of most things.  */
12492
12493 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12494 tree
12495 ffecom_ptr_to_expr (ffebld expr)
12496 {
12497   tree item;
12498   ffeinfoBasictype bt;
12499   ffeinfoKindtype kt;
12500   ffesymbol s;
12501
12502   assert (expr != NULL);
12503
12504   switch (ffebld_op (expr))
12505     {
12506     case FFEBLD_opSYMTER:
12507       s = ffebld_symter (expr);
12508       if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
12509         {
12510           ffecomGfrt ix;
12511
12512           ix = ffeintrin_gfrt_indirect (ffebld_symter_implementation (expr));
12513           assert (ix != FFECOM_gfrt);
12514           if ((item = ffecom_gfrt_[ix]) == NULL_TREE)
12515             {
12516               ffecom_make_gfrt_ (ix);
12517               item = ffecom_gfrt_[ix];
12518             }
12519         }
12520       else
12521         {
12522           item = ffesymbol_hook (s).decl_tree;
12523           if (item == NULL_TREE)
12524             {
12525               s = ffecom_sym_transform_ (s);
12526               item = ffesymbol_hook (s).decl_tree;
12527             }
12528         }
12529       assert (item != NULL);
12530       if (item == error_mark_node)
12531         return item;
12532       if (!ffesymbol_hook (s).addr)
12533         item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12534                          item);
12535       return item;
12536
12537     case FFEBLD_opARRAYREF:
12538       return ffecom_arrayref_ (NULL_TREE, expr, 1);
12539
12540     case FFEBLD_opCONTER:
12541
12542       bt = ffeinfo_basictype (ffebld_info (expr));
12543       kt = ffeinfo_kindtype (ffebld_info (expr));
12544
12545       item = ffecom_constantunion (&ffebld_constant_union
12546                                    (ffebld_conter (expr)), bt, kt,
12547                                    ffecom_tree_type[bt][kt]);
12548       if (item == error_mark_node)
12549         return error_mark_node;
12550       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12551                        item);
12552       return item;
12553
12554     case FFEBLD_opANY:
12555       return error_mark_node;
12556
12557     default:
12558       bt = ffeinfo_basictype (ffebld_info (expr));
12559       kt = ffeinfo_kindtype (ffebld_info (expr));
12560
12561       item = ffecom_expr (expr);
12562       if (item == error_mark_node)
12563         return error_mark_node;
12564
12565       /* The back end currently optimizes a bit too zealously for us, in that
12566          we fail JCB001 if the following block of code is omitted.  It checks
12567          to see if the transformed expression is a symbol or array reference,
12568          and encloses it in a SAVE_EXPR if that is the case.  */
12569
12570       STRIP_NOPS (item);
12571       if ((TREE_CODE (item) == VAR_DECL)
12572           || (TREE_CODE (item) == PARM_DECL)
12573           || (TREE_CODE (item) == RESULT_DECL)
12574           || (TREE_CODE (item) == INDIRECT_REF)
12575           || (TREE_CODE (item) == ARRAY_REF)
12576           || (TREE_CODE (item) == COMPONENT_REF)
12577 #ifdef OFFSET_REF
12578           || (TREE_CODE (item) == OFFSET_REF)
12579 #endif
12580           || (TREE_CODE (item) == BUFFER_REF)
12581           || (TREE_CODE (item) == REALPART_EXPR)
12582           || (TREE_CODE (item) == IMAGPART_EXPR))
12583         {
12584           item = ffecom_save_tree (item);
12585         }
12586
12587       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12588                        item);
12589       return item;
12590     }
12591
12592   assert ("fall-through error" == NULL);
12593   return error_mark_node;
12594 }
12595
12596 #endif
12597 /* Obtain a temp var with given data type.
12598
12599    size is FFETARGET_charactersizeNONE for a non-CHARACTER type
12600    or >= 0 for a CHARACTER type.
12601
12602    elements is -1 for a scalar or > 0 for an array of type.  */
12603
12604 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12605 tree
12606 ffecom_make_tempvar (const char *commentary, tree type,
12607                      ffetargetCharacterSize size, int elements)
12608 {
12609   tree t;
12610   static int mynumber;
12611
12612   assert (current_binding_level->prep_state < 2);
12613
12614   if (type == error_mark_node)
12615     return error_mark_node;
12616
12617   if (size != FFETARGET_charactersizeNONE)
12618     type = build_array_type (type,
12619                              build_range_type (ffecom_f2c_ftnlen_type_node,
12620                                                ffecom_f2c_ftnlen_one_node,
12621                                                build_int_2 (size, 0)));
12622   if (elements != -1)
12623     type = build_array_type (type,
12624                              build_range_type (integer_type_node,
12625                                                integer_zero_node,
12626                                                build_int_2 (elements - 1,
12627                                                             0)));
12628   t = build_decl (VAR_DECL,
12629                   ffecom_get_invented_identifier ("__g77_%s_%d",
12630                                                   commentary,
12631                                                   mynumber++),
12632                   type);
12633
12634   t = start_decl (t, FALSE);
12635   finish_decl (t, NULL_TREE, FALSE);
12636
12637   return t;
12638 }
12639 #endif
12640
12641 /* Prepare argument pointer to expression.
12642
12643    Like ffecom_prepare_expr, except for expressions to be evaluated
12644    via ffecom_arg_ptr_to_expr.  */
12645
12646 void
12647 ffecom_prepare_arg_ptr_to_expr (ffebld expr)
12648 {
12649   /* ~~For now, it seems to be the same thing.  */
12650   ffecom_prepare_expr (expr);
12651   return;
12652 }
12653
12654 /* End of preparations.  */
12655
12656 bool
12657 ffecom_prepare_end (void)
12658 {
12659   int prep_state = current_binding_level->prep_state;
12660
12661   assert (prep_state < 2);
12662   current_binding_level->prep_state = 2;
12663
12664   return (prep_state == 1) ? TRUE : FALSE;
12665 }
12666
12667 /* Prepare expression.
12668
12669    This is called before any code is generated for the current block.
12670    It scans the expression, declares any temporaries that might be needed
12671    during evaluation of the expression, and stores those temporaries in
12672    the appropriate "hook" fields of the expression.  `dest', if not NULL,
12673    specifies the destination that ffecom_expr_ will see, in case that
12674    helps avoid generating unused temporaries.
12675
12676    ~~Improve to avoid allocating unused temporaries by taking `dest'
12677    into account vis-a-vis aliasing requirements of complex/character
12678    functions.  */
12679
12680 void
12681 ffecom_prepare_expr_ (ffebld expr, ffebld dest UNUSED)
12682 {
12683   ffeinfoBasictype bt;
12684   ffeinfoKindtype kt;
12685   ffetargetCharacterSize sz;
12686   tree tempvar = NULL_TREE;
12687
12688   assert (current_binding_level->prep_state < 2);
12689
12690   if (! expr)
12691     return;
12692
12693   bt = ffeinfo_basictype (ffebld_info (expr));
12694   kt = ffeinfo_kindtype (ffebld_info (expr));
12695   sz = ffeinfo_size (ffebld_info (expr));
12696
12697   /* Generate whatever temporaries are needed to represent the result
12698      of the expression.  */
12699
12700   if (bt == FFEINFO_basictypeCHARACTER)
12701     {
12702       while (ffebld_op (expr) == FFEBLD_opPAREN)
12703         expr = ffebld_left (expr);
12704     }
12705
12706   switch (ffebld_op (expr))
12707     {
12708     default:
12709       /* Don't make temps for SYMTER, CONTER, etc.  */
12710       if (ffebld_arity (expr) == 0)
12711         break;
12712
12713       switch (bt)
12714         {
12715         case FFEINFO_basictypeCOMPLEX:
12716           if (ffebld_op (expr) == FFEBLD_opFUNCREF)
12717             {
12718               ffesymbol s;
12719
12720               if (ffebld_op (ffebld_left (expr)) != FFEBLD_opSYMTER)
12721                 break;
12722
12723               s = ffebld_symter (ffebld_left (expr));
12724               if (ffesymbol_where (s) == FFEINFO_whereCONSTANT
12725                   || (ffesymbol_where (s) != FFEINFO_whereINTRINSIC
12726                       && ! ffesymbol_is_f2c (s))
12727                   || (ffesymbol_where (s) == FFEINFO_whereINTRINSIC
12728                       && ! ffe_is_f2c_library ()))
12729                 break;
12730             }
12731           else if (ffebld_op (expr) == FFEBLD_opPOWER)
12732             {
12733               /* Requires special treatment.  There's no POW_CC function
12734                  in libg2c, so POW_ZZ is used, which means we always
12735                  need a double-complex temp, not a single-complex.  */
12736               kt = FFEINFO_kindtypeREAL2;
12737             }
12738           else if (ffebld_op (expr) != FFEBLD_opDIVIDE)
12739             /* The other ops don't need temps for complex operands.  */
12740             break;
12741
12742           /* ~~~Avoid making temps for some intrinsics, such as AIMAG(C),
12743              REAL(C).  See 19990325-0.f, routine `check', for cases.  */
12744           tempvar = ffecom_make_tempvar ("complex",
12745                                          ffecom_tree_type
12746                                          [FFEINFO_basictypeCOMPLEX][kt],
12747                                          FFETARGET_charactersizeNONE,
12748                                          -1);
12749           break;
12750
12751         case FFEINFO_basictypeCHARACTER:
12752           if (ffebld_op (expr) != FFEBLD_opFUNCREF)
12753             break;
12754
12755           if (sz == FFETARGET_charactersizeNONE)
12756             /* ~~Kludge alert!  This should someday be fixed. */
12757             sz = 24;
12758
12759           tempvar = ffecom_make_tempvar ("char", char_type_node, sz, -1);
12760           break;
12761
12762         default:
12763           break;
12764         }
12765       break;
12766
12767 #ifdef HAHA
12768     case FFEBLD_opPOWER:
12769       {
12770         tree rtype, ltype;
12771         tree rtmp, ltmp, result;
12772
12773         ltype = ffecom_type_expr (ffebld_left (expr));
12774         rtype = ffecom_type_expr (ffebld_right (expr));
12775
12776         rtmp = ffecom_make_tempvar (rtype, FFETARGET_charactersizeNONE, -1);
12777         ltmp = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
12778         result = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
12779
12780         tempvar = make_tree_vec (3);
12781         TREE_VEC_ELT (tempvar, 0) = rtmp;
12782         TREE_VEC_ELT (tempvar, 1) = ltmp;
12783         TREE_VEC_ELT (tempvar, 2) = result;
12784       }
12785       break;
12786 #endif  /* HAHA */
12787
12788     case FFEBLD_opCONCATENATE:
12789       {
12790         /* This gets special handling, because only one set of temps
12791            is needed for a tree of these -- the tree is treated as
12792            a flattened list of concatenations when generating code.  */
12793
12794         ffecomConcatList_ catlist;
12795         tree ltmp, itmp, result;
12796         int count;
12797         int i;
12798
12799         catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
12800         count = ffecom_concat_list_count_ (catlist);
12801
12802         if (count >= 2)
12803           {
12804             ltmp
12805               = ffecom_make_tempvar ("concat_len",
12806                                      ffecom_f2c_ftnlen_type_node,
12807                                      FFETARGET_charactersizeNONE, count);
12808             itmp
12809               = ffecom_make_tempvar ("concat_item",
12810                                      ffecom_f2c_address_type_node,
12811                                      FFETARGET_charactersizeNONE, count);
12812             result
12813               = ffecom_make_tempvar ("concat_res",
12814                                      char_type_node,
12815                                      ffecom_concat_list_maxlen_ (catlist),
12816                                      -1);
12817
12818             tempvar = make_tree_vec (3);
12819             TREE_VEC_ELT (tempvar, 0) = ltmp;
12820             TREE_VEC_ELT (tempvar, 1) = itmp;
12821             TREE_VEC_ELT (tempvar, 2) = result;
12822           }
12823
12824         for (i = 0; i < count; ++i)
12825           ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist,
12826                                                                     i));
12827
12828         ffecom_concat_list_kill_ (catlist);
12829
12830         if (tempvar)
12831           {
12832             ffebld_nonter_set_hook (expr, tempvar);
12833             current_binding_level->prep_state = 1;
12834           }
12835       }
12836       return;
12837
12838     case FFEBLD_opCONVERT:
12839       if (bt == FFEINFO_basictypeCHARACTER
12840           && ((ffebld_size_known (ffebld_left (expr))
12841                == FFETARGET_charactersizeNONE)
12842               || (ffebld_size_known (ffebld_left (expr)) >= sz)))
12843         tempvar = ffecom_make_tempvar ("convert", char_type_node, sz, -1);
12844       break;
12845     }
12846
12847   if (tempvar)
12848     {
12849       ffebld_nonter_set_hook (expr, tempvar);
12850       current_binding_level->prep_state = 1;
12851     }
12852
12853   /* Prepare subexpressions for this expr.  */
12854
12855   switch (ffebld_op (expr))
12856     {
12857     case FFEBLD_opPERCENT_LOC:
12858       ffecom_prepare_ptr_to_expr (ffebld_left (expr));
12859       break;
12860
12861     case FFEBLD_opPERCENT_VAL:
12862     case FFEBLD_opPERCENT_REF:
12863       ffecom_prepare_expr (ffebld_left (expr));
12864       break;
12865
12866     case FFEBLD_opPERCENT_DESCR:
12867       ffecom_prepare_arg_ptr_to_expr (ffebld_left (expr));
12868       break;
12869
12870     case FFEBLD_opITEM:
12871       {
12872         ffebld item;
12873
12874         for (item = expr;
12875              item != NULL;
12876              item = ffebld_trail (item))
12877           if (ffebld_head (item) != NULL)
12878             ffecom_prepare_expr (ffebld_head (item));
12879       }
12880       break;
12881
12882     default:
12883       /* Need to handle character conversion specially.  */
12884       switch (ffebld_arity (expr))
12885         {
12886         case 2:
12887           ffecom_prepare_expr (ffebld_left (expr));
12888           ffecom_prepare_expr (ffebld_right (expr));
12889           break;
12890
12891         case 1:
12892           ffecom_prepare_expr (ffebld_left (expr));
12893           break;
12894
12895         default:
12896           break;
12897         }
12898     }
12899
12900   return;
12901 }
12902
12903 /* Prepare expression for reading and writing.
12904
12905    Like ffecom_prepare_expr, except for expressions to be evaluated
12906    via ffecom_expr_rw.  */
12907
12908 void
12909 ffecom_prepare_expr_rw (tree type, ffebld expr)
12910 {
12911   /* This is all we support for now.  */
12912   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
12913
12914   /* ~~For now, it seems to be the same thing.  */
12915   ffecom_prepare_expr (expr);
12916   return;
12917 }
12918
12919 /* Prepare expression for writing.
12920
12921    Like ffecom_prepare_expr, except for expressions to be evaluated
12922    via ffecom_expr_w.  */
12923
12924 void
12925 ffecom_prepare_expr_w (tree type, ffebld expr)
12926 {
12927   /* This is all we support for now.  */
12928   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
12929
12930   /* ~~For now, it seems to be the same thing.  */
12931   ffecom_prepare_expr (expr);
12932   return;
12933 }
12934
12935 /* Prepare expression for returning.
12936
12937    Like ffecom_prepare_expr, except for expressions to be evaluated
12938    via ffecom_return_expr.  */
12939
12940 void
12941 ffecom_prepare_return_expr (ffebld expr)
12942 {
12943   assert (current_binding_level->prep_state < 2);
12944
12945   if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE
12946       && ffecom_is_altreturning_
12947       && expr != NULL)
12948     ffecom_prepare_expr (expr);
12949 }
12950
12951 /* Prepare pointer to expression.
12952
12953    Like ffecom_prepare_expr, except for expressions to be evaluated
12954    via ffecom_ptr_to_expr.  */
12955
12956 void
12957 ffecom_prepare_ptr_to_expr (ffebld expr)
12958 {
12959   /* ~~For now, it seems to be the same thing.  */
12960   ffecom_prepare_expr (expr);
12961   return;
12962 }
12963
12964 /* Transform expression into constant pointer-to-expression tree.
12965
12966    If the expression can be transformed into a pointer-to-expression tree
12967    that is constant, that is done, and the tree returned.  Else NULL_TREE
12968    is returned.
12969
12970    That way, a caller can attempt to provide compile-time initialization
12971    of a variable and, if that fails, *then* choose to start a new block
12972    and resort to using temporaries, as appropriate.  */
12973
12974 tree
12975 ffecom_ptr_to_const_expr (ffebld expr)
12976 {
12977   if (! expr)
12978     return integer_zero_node;
12979
12980   if (ffebld_op (expr) == FFEBLD_opANY)
12981     return error_mark_node;
12982
12983   if (ffebld_arity (expr) == 0
12984       && (ffebld_op (expr) != FFEBLD_opSYMTER
12985           || ffebld_where (expr) == FFEINFO_whereCOMMON
12986           || ffebld_where (expr) == FFEINFO_whereGLOBAL
12987           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
12988     {
12989       tree t;
12990
12991       t = ffecom_ptr_to_expr (expr);
12992       assert (TREE_CONSTANT (t));
12993       return t;
12994     }
12995
12996   return NULL_TREE;
12997 }
12998
12999 /* ffecom_return_expr -- Returns return-value expr given alt return expr
13000
13001    tree rtn;  // NULL_TREE means use expand_null_return()
13002    ffebld expr;  // NULL if no alt return expr to RETURN stmt
13003    rtn = ffecom_return_expr(expr);
13004
13005    Based on the program unit type and other info (like return function
13006    type, return master function type when alternate ENTRY points,
13007    whether subroutine has any alternate RETURN points, etc), returns the
13008    appropriate expression to be returned to the caller, or NULL_TREE
13009    meaning no return value or the caller expects it to be returned somewhere
13010    else (which is handled by other parts of this module).  */
13011
13012 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13013 tree
13014 ffecom_return_expr (ffebld expr)
13015 {
13016   tree rtn;
13017
13018   switch (ffecom_primary_entry_kind_)
13019     {
13020     case FFEINFO_kindPROGRAM:
13021     case FFEINFO_kindBLOCKDATA:
13022       rtn = NULL_TREE;
13023       break;
13024
13025     case FFEINFO_kindSUBROUTINE:
13026       if (!ffecom_is_altreturning_)
13027         rtn = NULL_TREE;        /* No alt returns, never an expr. */
13028       else if (expr == NULL)
13029         rtn = integer_zero_node;
13030       else
13031         rtn = ffecom_expr (expr);
13032       break;
13033
13034     case FFEINFO_kindFUNCTION:
13035       if ((ffecom_multi_retval_ != NULL_TREE)
13036           || (ffesymbol_basictype (ffecom_primary_entry_)
13037               == FFEINFO_basictypeCHARACTER)
13038           || ((ffesymbol_basictype (ffecom_primary_entry_)
13039                == FFEINFO_basictypeCOMPLEX)
13040               && (ffecom_num_entrypoints_ == 0)
13041               && ffesymbol_is_f2c (ffecom_primary_entry_)))
13042         {                       /* Value is returned by direct assignment
13043                                    into (implicit) dummy. */
13044           rtn = NULL_TREE;
13045           break;
13046         }
13047       rtn = ffecom_func_result_;
13048 #if 0
13049       /* Spurious error if RETURN happens before first reference!  So elide
13050          this code.  In particular, for debugging registry, rtn should always
13051          be non-null after all, but TREE_USED won't be set until we encounter
13052          a reference in the code.  Perfectly okay (but weird) code that,
13053          e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in
13054          this diagnostic for no reason.  Have people use -O -Wuninitialized
13055          and leave it to the back end to find obviously weird cases.  */
13056
13057       /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid
13058          situation; if the return value has never been referenced, it won't
13059          have a tree under 2pass mode. */
13060       if ((rtn == NULL_TREE)
13061           || !TREE_USED (rtn))
13062         {
13063           ffebad_start (FFEBAD_RETURN_VALUE_UNSET);
13064           ffebad_here (0, ffesymbol_where_line (ffecom_primary_entry_),
13065                        ffesymbol_where_column (ffecom_primary_entry_));
13066           ffebad_string (ffesymbol_text (ffesymbol_funcresult
13067                                          (ffecom_primary_entry_)));
13068           ffebad_finish ();
13069         }
13070 #endif
13071       break;
13072
13073     default:
13074       assert ("bad unit kind" == NULL);
13075     case FFEINFO_kindANY:
13076       rtn = error_mark_node;
13077       break;
13078     }
13079
13080   return rtn;
13081 }
13082
13083 #endif
13084 /* Do save_expr only if tree is not error_mark_node.  */
13085
13086 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13087 tree
13088 ffecom_save_tree (tree t)
13089 {
13090   return save_expr (t);
13091 }
13092 #endif
13093
13094 /* Start a compound statement (block).  */
13095
13096 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13097 void
13098 ffecom_start_compstmt (void)
13099 {
13100   bison_rule_pushlevel_ ();
13101 }
13102 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
13103
13104 /* Public entry point for front end to access start_decl.  */
13105
13106 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13107 tree
13108 ffecom_start_decl (tree decl, bool is_initialized)
13109 {
13110   DECL_INITIAL (decl) = is_initialized ? error_mark_node : NULL_TREE;
13111   return start_decl (decl, FALSE);
13112 }
13113
13114 #endif
13115 /* ffecom_sym_commit -- Symbol's state being committed to reality
13116
13117    ffesymbol s;
13118    ffecom_sym_commit(s);
13119
13120    Does whatever the backend needs when a symbol is committed after having
13121    been backtrackable for a period of time.  */
13122
13123 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13124 void
13125 ffecom_sym_commit (ffesymbol s UNUSED)
13126 {
13127   assert (!ffesymbol_retractable ());
13128 }
13129
13130 #endif
13131 /* ffecom_sym_end_transition -- Perform end transition on all symbols
13132
13133    ffecom_sym_end_transition();
13134
13135    Does backend-specific stuff and also calls ffest_sym_end_transition
13136    to do the necessary FFE stuff.
13137
13138    Backtracking is never enabled when this fn is called, so don't worry
13139    about it.  */
13140
13141 ffesymbol
13142 ffecom_sym_end_transition (ffesymbol s)
13143 {
13144   ffestorag st;
13145
13146   assert (!ffesymbol_retractable ());
13147
13148   s = ffest_sym_end_transition (s);
13149
13150 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13151   if ((ffesymbol_kind (s) == FFEINFO_kindBLOCKDATA)
13152       && (ffesymbol_where (s) == FFEINFO_whereGLOBAL))
13153     {
13154       ffecom_list_blockdata_
13155         = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
13156                                               FFEINTRIN_specNONE,
13157                                               FFEINTRIN_impNONE),
13158                            ffecom_list_blockdata_);
13159     }
13160 #endif
13161
13162   /* This is where we finally notice that a symbol has partial initialization
13163      and finalize it. */
13164
13165   if (ffesymbol_accretion (s) != NULL)
13166     {
13167       assert (ffesymbol_init (s) == NULL);
13168       ffecom_notify_init_symbol (s);
13169     }
13170   else if (((st = ffesymbol_storage (s)) != NULL)
13171            && ((st = ffestorag_parent (st)) != NULL)
13172            && (ffestorag_accretion (st) != NULL))
13173     {
13174       assert (ffestorag_init (st) == NULL);
13175       ffecom_notify_init_storage (st);
13176     }
13177
13178 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13179   if ((ffesymbol_kind (s) == FFEINFO_kindCOMMON)
13180       && (ffesymbol_where (s) == FFEINFO_whereLOCAL)
13181       && (ffesymbol_storage (s) != NULL))
13182     {
13183       ffecom_list_common_
13184         = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
13185                                               FFEINTRIN_specNONE,
13186                                               FFEINTRIN_impNONE),
13187                            ffecom_list_common_);
13188     }
13189 #endif
13190
13191   return s;
13192 }
13193
13194 /* ffecom_sym_exec_transition -- Perform exec transition on all symbols
13195
13196    ffecom_sym_exec_transition();
13197
13198    Does backend-specific stuff and also calls ffest_sym_exec_transition
13199    to do the necessary FFE stuff.
13200
13201    See the long-winded description in ffecom_sym_learned for info
13202    on handling the situation where backtracking is inhibited.  */
13203
13204 ffesymbol
13205 ffecom_sym_exec_transition (ffesymbol s)
13206 {
13207   s = ffest_sym_exec_transition (s);
13208
13209   return s;
13210 }
13211
13212 /* ffecom_sym_learned -- Initial or more info gained on symbol after exec
13213
13214    ffesymbol s;
13215    s = ffecom_sym_learned(s);
13216
13217    Called when a new symbol is seen after the exec transition or when more
13218    info (perhaps) is gained for an UNCERTAIN symbol.  The symbol state when
13219    it arrives here is that all its latest info is updated already, so its
13220    state may be UNCERTAIN or UNDERSTOOD, it might already have the hook
13221    field filled in if its gone through here or exec_transition first, and
13222    so on.
13223
13224    The backend probably wants to check ffesymbol_retractable() to see if
13225    backtracking is in effect.  If so, the FFE's changes to the symbol may
13226    be retracted (undone) or committed (ratified), at which time the
13227    appropriate ffecom_sym_retract or _commit function will be called
13228    for that function.
13229
13230    If the backend has its own backtracking mechanism, great, use it so that
13231    committal is a simple operation.  Though it doesn't make much difference,
13232    I suppose: the reason for tentative symbol evolution in the FFE is to
13233    enable error detection in weird incorrect statements early and to disable
13234    incorrect error detection on a correct statement.  The backend is not
13235    likely to introduce any information that'll get involved in these
13236    considerations, so it is probably just fine that the implementation
13237    model for this fn and for _exec_transition is to not do anything
13238    (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE
13239    and instead wait until ffecom_sym_commit is called (which it never
13240    will be as long as we're using ambiguity-detecting statement analysis in
13241    the FFE, which we are initially to shake out the code, but don't depend
13242    on this), otherwise go ahead and do whatever is needed.
13243
13244    In essence, then, when this fn and _exec_transition get called while
13245    backtracking is enabled, a general mechanism would be to flag which (or
13246    both) of these were called (and in what order? neat question as to what
13247    might happen that I'm too lame to think through right now) and then when
13248    _commit is called reproduce the original calling sequence, if any, for
13249    the two fns (at which point backtracking will, of course, be disabled).  */
13250
13251 ffesymbol
13252 ffecom_sym_learned (ffesymbol s)
13253 {
13254   ffestorag_exec_layout (s);
13255
13256   return s;
13257 }
13258
13259 /* ffecom_sym_retract -- Symbol's state being retracted from reality
13260
13261    ffesymbol s;
13262    ffecom_sym_retract(s);
13263
13264    Does whatever the backend needs when a symbol is retracted after having
13265    been backtrackable for a period of time.  */
13266
13267 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13268 void
13269 ffecom_sym_retract (ffesymbol s UNUSED)
13270 {
13271   assert (!ffesymbol_retractable ());
13272
13273 #if 0                           /* GCC doesn't commit any backtrackable sins,
13274                                    so nothing needed here. */
13275   switch (ffesymbol_hook (s).state)
13276     {
13277     case 0:                     /* nothing happened yet. */
13278       break;
13279
13280     case 1:                     /* exec transition happened. */
13281       break;
13282
13283     case 2:                     /* learned happened. */
13284       break;
13285
13286     case 3:                     /* learned then exec. */
13287       break;
13288
13289     case 4:                     /* exec then learned. */
13290       break;
13291
13292     default:
13293       assert ("bad hook state" == NULL);
13294       break;
13295     }
13296 #endif
13297 }
13298
13299 #endif
13300 /* Create temporary gcc label.  */
13301
13302 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13303 tree
13304 ffecom_temp_label ()
13305 {
13306   tree glabel;
13307   static int mynumber = 0;
13308
13309   glabel = build_decl (LABEL_DECL,
13310                        ffecom_get_invented_identifier ("__g77_label_%d",
13311                                                        mynumber++),
13312                        void_type_node);
13313   DECL_CONTEXT (glabel) = current_function_decl;
13314   DECL_MODE (glabel) = VOIDmode;
13315
13316   return glabel;
13317 }
13318
13319 #endif
13320 /* Return an expression that is usable as an arg in a conditional context
13321    (IF, DO WHILE, .NOT., and so on).
13322
13323    Use the one provided for the back end as of >2.6.0.  */
13324
13325 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13326 tree
13327 ffecom_truth_value (tree expr)
13328 {
13329   return truthvalue_conversion (expr);
13330 }
13331
13332 #endif
13333 /* Return the inversion of a truth value (the inversion of what
13334    ffecom_truth_value builds).
13335
13336    Apparently invert_truthvalue, which is properly in the back end, is
13337    enough for now, so just use it.  */
13338
13339 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13340 tree
13341 ffecom_truth_value_invert (tree expr)
13342 {
13343   return invert_truthvalue (ffecom_truth_value (expr));
13344 }
13345
13346 #endif
13347
13348 /* Return the tree that is the type of the expression, as would be
13349    returned in TREE_TYPE(ffecom_expr(expr)), without otherwise
13350    transforming the expression, generating temporaries, etc.  */
13351
13352 tree
13353 ffecom_type_expr (ffebld expr)
13354 {
13355   ffeinfoBasictype bt;
13356   ffeinfoKindtype kt;
13357   tree tree_type;
13358
13359   assert (expr != NULL);
13360
13361   bt = ffeinfo_basictype (ffebld_info (expr));
13362   kt = ffeinfo_kindtype (ffebld_info (expr));
13363   tree_type = ffecom_tree_type[bt][kt];
13364
13365   switch (ffebld_op (expr))
13366     {
13367     case FFEBLD_opCONTER:
13368     case FFEBLD_opSYMTER:
13369     case FFEBLD_opARRAYREF:
13370     case FFEBLD_opUPLUS:
13371     case FFEBLD_opPAREN:
13372     case FFEBLD_opUMINUS:
13373     case FFEBLD_opADD:
13374     case FFEBLD_opSUBTRACT:
13375     case FFEBLD_opMULTIPLY:
13376     case FFEBLD_opDIVIDE:
13377     case FFEBLD_opPOWER:
13378     case FFEBLD_opNOT:
13379     case FFEBLD_opFUNCREF:
13380     case FFEBLD_opSUBRREF:
13381     case FFEBLD_opAND:
13382     case FFEBLD_opOR:
13383     case FFEBLD_opXOR:
13384     case FFEBLD_opNEQV:
13385     case FFEBLD_opEQV:
13386     case FFEBLD_opCONVERT:
13387     case FFEBLD_opLT:
13388     case FFEBLD_opLE:
13389     case FFEBLD_opEQ:
13390     case FFEBLD_opNE:
13391     case FFEBLD_opGT:
13392     case FFEBLD_opGE:
13393     case FFEBLD_opPERCENT_LOC:
13394       return tree_type;
13395
13396     case FFEBLD_opACCTER:
13397     case FFEBLD_opARRTER:
13398     case FFEBLD_opITEM:
13399     case FFEBLD_opSTAR:
13400     case FFEBLD_opBOUNDS:
13401     case FFEBLD_opREPEAT:
13402     case FFEBLD_opLABTER:
13403     case FFEBLD_opLABTOK:
13404     case FFEBLD_opIMPDO:
13405     case FFEBLD_opCONCATENATE:
13406     case FFEBLD_opSUBSTR:
13407     default:
13408       assert ("bad op for ffecom_type_expr" == NULL);
13409       /* Fall through. */
13410     case FFEBLD_opANY:
13411       return error_mark_node;
13412     }
13413 }
13414
13415 /* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points
13416
13417    If the PARM_DECL already exists, return it, else create it.  It's an
13418    integer_type_node argument for the master function that implements a
13419    subroutine or function with more than one entrypoint and is bound at
13420    run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for
13421    first ENTRY statement, and so on).  */
13422
13423 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13424 tree
13425 ffecom_which_entrypoint_decl ()
13426 {
13427   assert (ffecom_which_entrypoint_decl_ != NULL_TREE);
13428
13429   return ffecom_which_entrypoint_decl_;
13430 }
13431
13432 #endif
13433 \f
13434 /* The following sections consists of private and public functions
13435    that have the same names and perform roughly the same functions
13436    as counterparts in the C front end.  Changes in the C front end
13437    might affect how things should be done here.  Only functions
13438    needed by the back end should be public here; the rest should
13439    be private (static in the C sense).  Functions needed by other
13440    g77 front-end modules should be accessed by them via public
13441    ffecom_* names, which should themselves call private versions
13442    in this section so the private versions are easy to recognize
13443    when upgrading to a new gcc and finding interesting changes
13444    in the front end.
13445
13446    Functions named after rule "foo:" in c-parse.y are named
13447    "bison_rule_foo_" so they are easy to find.  */
13448
13449 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13450
13451 static void
13452 bison_rule_pushlevel_ ()
13453 {
13454   emit_line_note (input_filename, lineno);
13455   pushlevel (0);
13456   clear_last_expr ();
13457   expand_start_bindings (0);
13458 }
13459
13460 static tree
13461 bison_rule_compstmt_ ()
13462 {
13463   tree t;
13464   int keep = kept_level_p ();
13465
13466   /* Make the temps go away.  */
13467   if (! keep)
13468     current_binding_level->names = NULL_TREE;
13469
13470   emit_line_note (input_filename, lineno);
13471   expand_end_bindings (getdecls (), keep, 0);
13472   t = poplevel (keep, 1, 0);
13473
13474   return t;
13475 }
13476
13477 /* Return a definition for a builtin function named NAME and whose data type
13478    is TYPE.  TYPE should be a function type with argument types.
13479    FUNCTION_CODE tells later passes how to compile calls to this function.
13480    See tree.h for its possible values.
13481
13482    If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
13483    the name to be called if we can't opencode the function.  */
13484
13485 tree
13486 builtin_function (const char *name, tree type, int function_code,
13487                   enum built_in_class class,
13488                   const char *library_name)
13489 {
13490   tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type);
13491   DECL_EXTERNAL (decl) = 1;
13492   TREE_PUBLIC (decl) = 1;
13493   if (library_name)
13494     SET_DECL_ASSEMBLER_NAME (decl, get_identifier (library_name));
13495   make_decl_rtl (decl, NULL);
13496   pushdecl (decl);
13497   DECL_BUILT_IN_CLASS (decl) = class;
13498   DECL_FUNCTION_CODE (decl) = function_code;
13499
13500   return decl;
13501 }
13502
13503 /* Handle when a new declaration NEWDECL
13504    has the same name as an old one OLDDECL
13505    in the same binding contour.
13506    Prints an error message if appropriate.
13507
13508    If safely possible, alter OLDDECL to look like NEWDECL, and return 1.
13509    Otherwise, return 0.  */
13510
13511 static int
13512 duplicate_decls (tree newdecl, tree olddecl)
13513 {
13514   int types_match = 1;
13515   int new_is_definition = (TREE_CODE (newdecl) == FUNCTION_DECL
13516                            && DECL_INITIAL (newdecl) != 0);
13517   tree oldtype = TREE_TYPE (olddecl);
13518   tree newtype = TREE_TYPE (newdecl);
13519
13520   if (olddecl == newdecl)
13521     return 1;
13522
13523   if (TREE_CODE (newtype) == ERROR_MARK
13524       || TREE_CODE (oldtype) == ERROR_MARK)
13525     types_match = 0;
13526
13527   /* New decl is completely inconsistent with the old one =>
13528      tell caller to replace the old one.
13529      This is always an error except in the case of shadowing a builtin.  */
13530   if (TREE_CODE (olddecl) != TREE_CODE (newdecl))
13531     return 0;
13532
13533   /* For real parm decl following a forward decl,
13534      return 1 so old decl will be reused.  */
13535   if (types_match && TREE_CODE (newdecl) == PARM_DECL
13536       && TREE_ASM_WRITTEN (olddecl) && ! TREE_ASM_WRITTEN (newdecl))
13537     return 1;
13538
13539   /* The new declaration is the same kind of object as the old one.
13540      The declarations may partially match.  Print warnings if they don't
13541      match enough.  Ultimately, copy most of the information from the new
13542      decl to the old one, and keep using the old one.  */
13543
13544   if (TREE_CODE (olddecl) == FUNCTION_DECL
13545       && DECL_BUILT_IN (olddecl))
13546     {
13547       /* A function declaration for a built-in function.  */
13548       if (!TREE_PUBLIC (newdecl))
13549         return 0;
13550       else if (!types_match)
13551         {
13552           /* Accept the return type of the new declaration if same modes.  */
13553           tree oldreturntype = TREE_TYPE (TREE_TYPE (olddecl));
13554           tree newreturntype = TREE_TYPE (TREE_TYPE (newdecl));
13555
13556           if (TYPE_MODE (oldreturntype) == TYPE_MODE (newreturntype))
13557             {
13558               /* Function types may be shared, so we can't just modify
13559                  the return type of olddecl's function type.  */
13560               tree newtype
13561                 = build_function_type (newreturntype,
13562                                        TYPE_ARG_TYPES (TREE_TYPE (olddecl)));
13563
13564               types_match = 1;
13565               if (types_match)
13566                 TREE_TYPE (olddecl) = newtype;
13567             }
13568         }
13569       if (!types_match)
13570         return 0;
13571     }
13572   else if (TREE_CODE (olddecl) == FUNCTION_DECL
13573            && DECL_SOURCE_LINE (olddecl) == 0)
13574     {
13575       /* A function declaration for a predeclared function
13576          that isn't actually built in.  */
13577       if (!TREE_PUBLIC (newdecl))
13578         return 0;
13579       else if (!types_match)
13580         {
13581           /* If the types don't match, preserve volatility indication.
13582              Later on, we will discard everything else about the
13583              default declaration.  */
13584           TREE_THIS_VOLATILE (newdecl) |= TREE_THIS_VOLATILE (olddecl);
13585         }
13586     }
13587
13588   /* Copy all the DECL_... slots specified in the new decl
13589      except for any that we copy here from the old type.
13590
13591      Past this point, we don't change OLDTYPE and NEWTYPE
13592      even if we change the types of NEWDECL and OLDDECL.  */
13593
13594   if (types_match)
13595     {
13596       /* Merge the data types specified in the two decls.  */
13597       if (TREE_CODE (newdecl) != FUNCTION_DECL || !DECL_BUILT_IN (olddecl))
13598         TREE_TYPE (newdecl)
13599           = TREE_TYPE (olddecl)
13600             = TREE_TYPE (newdecl);
13601
13602       /* Lay the type out, unless already done.  */
13603       if (oldtype != TREE_TYPE (newdecl))
13604         {
13605           if (TREE_TYPE (newdecl) != error_mark_node)
13606             layout_type (TREE_TYPE (newdecl));
13607           if (TREE_CODE (newdecl) != FUNCTION_DECL
13608               && TREE_CODE (newdecl) != TYPE_DECL
13609               && TREE_CODE (newdecl) != CONST_DECL)
13610             layout_decl (newdecl, 0);
13611         }
13612       else
13613         {
13614           /* Since the type is OLDDECL's, make OLDDECL's size go with.  */
13615           DECL_SIZE (newdecl) = DECL_SIZE (olddecl);
13616           DECL_SIZE_UNIT (newdecl) = DECL_SIZE_UNIT (olddecl);
13617           if (TREE_CODE (olddecl) != FUNCTION_DECL)
13618             if (DECL_ALIGN (olddecl) > DECL_ALIGN (newdecl))
13619               {
13620                 DECL_ALIGN (newdecl) = DECL_ALIGN (olddecl);
13621                 DECL_USER_ALIGN (newdecl) |= DECL_USER_ALIGN (olddecl);
13622               }
13623         }
13624
13625       /* Keep the old rtl since we can safely use it.  */
13626       COPY_DECL_RTL (olddecl, newdecl);
13627
13628       /* Merge the type qualifiers.  */
13629       if (DECL_BUILT_IN_NONANSI (olddecl) && TREE_THIS_VOLATILE (olddecl)
13630           && !TREE_THIS_VOLATILE (newdecl))
13631         TREE_THIS_VOLATILE (olddecl) = 0;
13632       if (TREE_READONLY (newdecl))
13633         TREE_READONLY (olddecl) = 1;
13634       if (TREE_THIS_VOLATILE (newdecl))
13635         {
13636           TREE_THIS_VOLATILE (olddecl) = 1;
13637           if (TREE_CODE (newdecl) == VAR_DECL)
13638             make_var_volatile (newdecl);
13639         }
13640
13641       /* Keep source location of definition rather than declaration.
13642          Likewise, keep decl at outer scope.  */
13643       if ((DECL_INITIAL (newdecl) == 0 && DECL_INITIAL (olddecl) != 0)
13644           || (DECL_CONTEXT (newdecl) != 0 && DECL_CONTEXT (olddecl) == 0))
13645         {
13646           DECL_SOURCE_LINE (newdecl) = DECL_SOURCE_LINE (olddecl);
13647           DECL_SOURCE_FILE (newdecl) = DECL_SOURCE_FILE (olddecl);
13648
13649           if (DECL_CONTEXT (olddecl) == 0
13650               && TREE_CODE (newdecl) != FUNCTION_DECL)
13651             DECL_CONTEXT (newdecl) = 0;
13652         }
13653
13654       /* Merge the unused-warning information.  */
13655       if (DECL_IN_SYSTEM_HEADER (olddecl))
13656         DECL_IN_SYSTEM_HEADER (newdecl) = 1;
13657       else if (DECL_IN_SYSTEM_HEADER (newdecl))
13658         DECL_IN_SYSTEM_HEADER (olddecl) = 1;
13659
13660       /* Merge the initialization information.  */
13661       if (DECL_INITIAL (newdecl) == 0)
13662         DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13663
13664       /* Merge the section attribute.
13665          We want to issue an error if the sections conflict but that must be
13666          done later in decl_attributes since we are called before attributes
13667          are assigned.  */
13668       if (DECL_SECTION_NAME (newdecl) == NULL_TREE)
13669         DECL_SECTION_NAME (newdecl) = DECL_SECTION_NAME (olddecl);
13670
13671 #if BUILT_FOR_270
13672       if (TREE_CODE (newdecl) == FUNCTION_DECL)
13673         {
13674           DECL_STATIC_CONSTRUCTOR(newdecl) |= DECL_STATIC_CONSTRUCTOR(olddecl);
13675           DECL_STATIC_DESTRUCTOR (newdecl) |= DECL_STATIC_DESTRUCTOR (olddecl);
13676         }
13677 #endif
13678     }
13679   /* If cannot merge, then use the new type and qualifiers,
13680      and don't preserve the old rtl.  */
13681   else
13682     {
13683       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13684       TREE_READONLY (olddecl) = TREE_READONLY (newdecl);
13685       TREE_THIS_VOLATILE (olddecl) = TREE_THIS_VOLATILE (newdecl);
13686       TREE_SIDE_EFFECTS (olddecl) = TREE_SIDE_EFFECTS (newdecl);
13687     }
13688
13689   /* Merge the storage class information.  */
13690   /* For functions, static overrides non-static.  */
13691   if (TREE_CODE (newdecl) == FUNCTION_DECL)
13692     {
13693       TREE_PUBLIC (newdecl) &= TREE_PUBLIC (olddecl);
13694       /* This is since we don't automatically
13695          copy the attributes of NEWDECL into OLDDECL.  */
13696       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13697       /* If this clears `static', clear it in the identifier too.  */
13698       if (! TREE_PUBLIC (olddecl))
13699         TREE_PUBLIC (DECL_NAME (olddecl)) = 0;
13700     }
13701   if (DECL_EXTERNAL (newdecl))
13702     {
13703       TREE_STATIC (newdecl) = TREE_STATIC (olddecl);
13704       DECL_EXTERNAL (newdecl) = DECL_EXTERNAL (olddecl);
13705       /* An extern decl does not override previous storage class.  */
13706       TREE_PUBLIC (newdecl) = TREE_PUBLIC (olddecl);
13707     }
13708   else
13709     {
13710       TREE_STATIC (olddecl) = TREE_STATIC (newdecl);
13711       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13712     }
13713
13714   /* If either decl says `inline', this fn is inline,
13715      unless its definition was passed already.  */
13716   if (DECL_INLINE (newdecl) && DECL_INITIAL (olddecl) == 0)
13717     DECL_INLINE (olddecl) = 1;
13718   DECL_INLINE (newdecl) = DECL_INLINE (olddecl);
13719
13720   /* Get rid of any built-in function if new arg types don't match it
13721      or if we have a function definition.  */
13722   if (TREE_CODE (newdecl) == FUNCTION_DECL
13723       && DECL_BUILT_IN (olddecl)
13724       && (!types_match || new_is_definition))
13725     {
13726       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13727       DECL_BUILT_IN_CLASS (olddecl) = NOT_BUILT_IN;
13728     }
13729
13730   /* If redeclaring a builtin function, and not a definition,
13731      it stays built in.
13732      Also preserve various other info from the definition.  */
13733   if (TREE_CODE (newdecl) == FUNCTION_DECL && !new_is_definition)
13734     {
13735       if (DECL_BUILT_IN (olddecl))
13736         {
13737           DECL_BUILT_IN_CLASS (newdecl) = DECL_BUILT_IN_CLASS (olddecl);
13738           DECL_FUNCTION_CODE (newdecl) = DECL_FUNCTION_CODE (olddecl);
13739         }
13740
13741       DECL_RESULT (newdecl) = DECL_RESULT (olddecl);
13742       DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13743       DECL_SAVED_INSNS (newdecl) = DECL_SAVED_INSNS (olddecl);
13744       DECL_ARGUMENTS (newdecl) = DECL_ARGUMENTS (olddecl);
13745     }
13746
13747   /* Copy most of the decl-specific fields of NEWDECL into OLDDECL.
13748      But preserve olddecl's DECL_UID.  */
13749   {
13750     register unsigned olddecl_uid = DECL_UID (olddecl);
13751
13752     memcpy ((char *) olddecl + sizeof (struct tree_common),
13753             (char *) newdecl + sizeof (struct tree_common),
13754             sizeof (struct tree_decl) - sizeof (struct tree_common));
13755     DECL_UID (olddecl) = olddecl_uid;
13756   }
13757
13758   return 1;
13759 }
13760
13761 /* Finish processing of a declaration;
13762    install its initial value.
13763    If the length of an array type is not known before,
13764    it must be determined now, from the initial value, or it is an error.  */
13765
13766 static void
13767 finish_decl (tree decl, tree init, bool is_top_level)
13768 {
13769   register tree type = TREE_TYPE (decl);
13770   int was_incomplete = (DECL_SIZE (decl) == 0);
13771   bool at_top_level = (current_binding_level == global_binding_level);
13772   bool top_level = is_top_level || at_top_level;
13773
13774   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13775      level anyway.  */
13776   assert (!is_top_level || !at_top_level);
13777
13778   if (TREE_CODE (decl) == PARM_DECL)
13779     assert (init == NULL_TREE);
13780   /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it
13781      overlaps DECL_ARG_TYPE.  */
13782   else if (init == NULL_TREE)
13783     assert (DECL_INITIAL (decl) == NULL_TREE);
13784   else
13785     assert (DECL_INITIAL (decl) == error_mark_node);
13786
13787   if (init != NULL_TREE)
13788     {
13789       if (TREE_CODE (decl) != TYPE_DECL)
13790         DECL_INITIAL (decl) = init;
13791       else
13792         {
13793           /* typedef foo = bar; store the type of bar as the type of foo.  */
13794           TREE_TYPE (decl) = TREE_TYPE (init);
13795           DECL_INITIAL (decl) = init = 0;
13796         }
13797     }
13798
13799   /* Deduce size of array from initialization, if not already known */
13800
13801   if (TREE_CODE (type) == ARRAY_TYPE
13802       && TYPE_DOMAIN (type) == 0
13803       && TREE_CODE (decl) != TYPE_DECL)
13804     {
13805       assert (top_level);
13806       assert (was_incomplete);
13807
13808       layout_decl (decl, 0);
13809     }
13810
13811   if (TREE_CODE (decl) == VAR_DECL)
13812     {
13813       if (DECL_SIZE (decl) == NULL_TREE
13814           && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
13815         layout_decl (decl, 0);
13816
13817       if (DECL_SIZE (decl) == NULL_TREE
13818           && (TREE_STATIC (decl)
13819               ?
13820       /* A static variable with an incomplete type is an error if it is
13821          initialized. Also if it is not file scope. Otherwise, let it
13822          through, but if it is not `extern' then it may cause an error
13823          message later.  */
13824               (DECL_INITIAL (decl) != 0 || DECL_CONTEXT (decl) != 0)
13825               :
13826       /* An automatic variable with an incomplete type is an error.  */
13827               !DECL_EXTERNAL (decl)))
13828         {
13829           assert ("storage size not known" == NULL);
13830           abort ();
13831         }
13832
13833       if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl))
13834           && (DECL_SIZE (decl) != 0)
13835           && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST))
13836         {
13837           assert ("storage size not constant" == NULL);
13838           abort ();
13839         }
13840     }
13841
13842   /* Output the assembler code and/or RTL code for variables and functions,
13843      unless the type is an undefined structure or union. If not, it will get
13844      done when the type is completed.  */
13845
13846   if (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == FUNCTION_DECL)
13847     {
13848       rest_of_decl_compilation (decl, NULL,
13849                                 DECL_CONTEXT (decl) == 0,
13850                                 0);
13851
13852       if (DECL_CONTEXT (decl) != 0)
13853         {
13854           /* Recompute the RTL of a local array now if it used to be an
13855              incomplete type.  */
13856           if (was_incomplete
13857               && !TREE_STATIC (decl) && !DECL_EXTERNAL (decl))
13858             {
13859               /* If we used it already as memory, it must stay in memory.  */
13860               TREE_ADDRESSABLE (decl) = TREE_USED (decl);
13861               /* If it's still incomplete now, no init will save it.  */
13862               if (DECL_SIZE (decl) == 0)
13863                 DECL_INITIAL (decl) = 0;
13864               expand_decl (decl);
13865             }
13866           /* Compute and store the initial value.  */
13867           if (TREE_CODE (decl) != FUNCTION_DECL)
13868             expand_decl_init (decl);
13869         }
13870     }
13871   else if (TREE_CODE (decl) == TYPE_DECL)
13872     {
13873       rest_of_decl_compilation (decl, NULL,
13874                                 DECL_CONTEXT (decl) == 0,
13875                                 0);
13876     }
13877
13878   /* At the end of a declaration, throw away any variable type sizes of types
13879      defined inside that declaration.  There is no use computing them in the
13880      following function definition.  */
13881   if (current_binding_level == global_binding_level)
13882     get_pending_sizes ();
13883 }
13884
13885 /* Finish up a function declaration and compile that function
13886    all the way to assembler language output.  The free the storage
13887    for the function definition.
13888
13889    This is called after parsing the body of the function definition.
13890
13891    NESTED is nonzero if the function being finished is nested in another.  */
13892
13893 static void
13894 finish_function (int nested)
13895 {
13896   register tree fndecl = current_function_decl;
13897
13898   assert (fndecl != NULL_TREE);
13899   if (TREE_CODE (fndecl) != ERROR_MARK)
13900     {
13901       if (nested)
13902         assert (DECL_CONTEXT (fndecl) != NULL_TREE);
13903       else
13904         assert (DECL_CONTEXT (fndecl) == NULL_TREE);
13905     }
13906
13907 /*  TREE_READONLY (fndecl) = 1;
13908     This caused &foo to be of type ptr-to-const-function
13909     which then got a warning when stored in a ptr-to-function variable.  */
13910
13911   poplevel (1, 0, 1);
13912
13913   if (TREE_CODE (fndecl) != ERROR_MARK)
13914     {
13915       BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
13916
13917       /* Must mark the RESULT_DECL as being in this function.  */
13918
13919       DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl;
13920
13921       /* Obey `register' declarations if `setjmp' is called in this fn.  */
13922       /* Generate rtl for function exit.  */
13923       expand_function_end (input_filename, lineno, 0);
13924
13925       /* If this is a nested function, protect the local variables in the stack
13926          above us from being collected while we're compiling this function.  */
13927       if (nested)
13928         ggc_push_context ();
13929
13930       /* Run the optimizers and output the assembler code for this function.  */
13931       rest_of_compilation (fndecl);
13932
13933       /* Undo the GC context switch.  */
13934       if (nested)
13935         ggc_pop_context ();
13936     }
13937
13938   if (TREE_CODE (fndecl) != ERROR_MARK
13939       && !nested
13940       && DECL_SAVED_INSNS (fndecl) == 0)
13941     {
13942       /* Stop pointing to the local nodes about to be freed.  */
13943       /* But DECL_INITIAL must remain nonzero so we know this was an actual
13944          function definition.  */
13945       /* For a nested function, this is done in pop_f_function_context.  */
13946       /* If rest_of_compilation set this to 0, leave it 0.  */
13947       if (DECL_INITIAL (fndecl) != 0)
13948         DECL_INITIAL (fndecl) = error_mark_node;
13949       DECL_ARGUMENTS (fndecl) = 0;
13950     }
13951
13952   if (!nested)
13953     {
13954       /* Let the error reporting routines know that we're outside a function.
13955          For a nested function, this value is used in pop_c_function_context
13956          and then reset via pop_function_context.  */
13957       ffecom_outer_function_decl_ = current_function_decl = NULL;
13958     }
13959 }
13960
13961 /* Plug-in replacement for identifying the name of a decl and, for a
13962    function, what we call it in diagnostics.  For now, "program unit"
13963    should suffice, since it's a bit of a hassle to figure out which
13964    of several kinds of things it is.  Note that it could conceivably
13965    be a statement function, which probably isn't really a program unit
13966    per se, but if that comes up, it should be easy to check (being a
13967    nested function and all).  */
13968
13969 static const char *
13970 lang_printable_name (tree decl, int v)
13971 {
13972   /* Just to keep GCC quiet about the unused variable.
13973      In theory, differing values of V should produce different
13974      output.  */
13975   switch (v)
13976     {
13977     default:
13978       if (TREE_CODE (decl) == ERROR_MARK)
13979         return "erroneous code";
13980       return IDENTIFIER_POINTER (DECL_NAME (decl));
13981     }
13982 }
13983
13984 /* g77's function to print out name of current function that caused
13985    an error.  */
13986
13987 #if BUILT_FOR_270
13988 static void
13989 lang_print_error_function (diagnostic_context *context __attribute__((unused)),
13990                            const char *file)
13991 {
13992   static ffeglobal last_g = NULL;
13993   static ffesymbol last_s = NULL;
13994   ffeglobal g;
13995   ffesymbol s;
13996   const char *kind;
13997
13998   if ((ffecom_primary_entry_ == NULL)
13999       || (ffesymbol_global (ffecom_primary_entry_) == NULL))
14000     {
14001       g = NULL;
14002       s = NULL;
14003       kind = NULL;
14004     }
14005   else
14006     {
14007       g = ffesymbol_global (ffecom_primary_entry_);
14008       if (ffecom_nested_entry_ == NULL)
14009         {
14010           s = ffecom_primary_entry_;
14011           switch (ffesymbol_kind (s))
14012             {
14013             case FFEINFO_kindFUNCTION:
14014               kind = "function";
14015               break;
14016
14017             case FFEINFO_kindSUBROUTINE:
14018               kind = "subroutine";
14019               break;
14020
14021             case FFEINFO_kindPROGRAM:
14022               kind = "program";
14023               break;
14024
14025             case FFEINFO_kindBLOCKDATA:
14026               kind = "block-data";
14027               break;
14028
14029             default:
14030               kind = ffeinfo_kind_message (ffesymbol_kind (s));
14031               break;
14032             }
14033         }
14034       else
14035         {
14036           s = ffecom_nested_entry_;
14037           kind = "statement function";
14038         }
14039     }
14040
14041   if ((last_g != g) || (last_s != s))
14042     {
14043       if (file)
14044         fprintf (stderr, "%s: ", file);
14045
14046       if (s == NULL)
14047         fprintf (stderr, "Outside of any program unit:\n");
14048       else
14049         {
14050           const char *name = ffesymbol_text (s);
14051
14052           fprintf (stderr, "In %s `%s':\n", kind, name);
14053         }
14054
14055       last_g = g;
14056       last_s = s;
14057     }
14058 }
14059 #endif
14060
14061 /* Similar to `lookup_name' but look only at current binding level.  */
14062
14063 static tree
14064 lookup_name_current_level (tree name)
14065 {
14066   register tree t;
14067
14068   if (current_binding_level == global_binding_level)
14069     return IDENTIFIER_GLOBAL_VALUE (name);
14070
14071   if (IDENTIFIER_LOCAL_VALUE (name) == 0)
14072     return 0;
14073
14074   for (t = current_binding_level->names; t; t = TREE_CHAIN (t))
14075     if (DECL_NAME (t) == name)
14076       break;
14077
14078   return t;
14079 }
14080
14081 /* Create a new `struct binding_level'.  */
14082
14083 static struct binding_level *
14084 make_binding_level ()
14085 {
14086   /* NOSTRICT */
14087   return (struct binding_level *) xmalloc (sizeof (struct binding_level));
14088 }
14089
14090 /* Save and restore the variables in this file and elsewhere
14091    that keep track of the progress of compilation of the current function.
14092    Used for nested functions.  */
14093
14094 struct f_function
14095 {
14096   struct f_function *next;
14097   tree named_labels;
14098   tree shadowed_labels;
14099   struct binding_level *binding_level;
14100 };
14101
14102 struct f_function *f_function_chain;
14103
14104 /* Restore the variables used during compilation of a C function.  */
14105
14106 static void
14107 pop_f_function_context ()
14108 {
14109   struct f_function *p = f_function_chain;
14110   tree link;
14111
14112   /* Bring back all the labels that were shadowed.  */
14113   for (link = shadowed_labels; link; link = TREE_CHAIN (link))
14114     if (DECL_NAME (TREE_VALUE (link)) != 0)
14115       IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link)))
14116         = TREE_VALUE (link);
14117
14118   if (current_function_decl != error_mark_node
14119       && DECL_SAVED_INSNS (current_function_decl) == 0)
14120     {
14121       /* Stop pointing to the local nodes about to be freed.  */
14122       /* But DECL_INITIAL must remain nonzero so we know this was an actual
14123          function definition.  */
14124       DECL_INITIAL (current_function_decl) = error_mark_node;
14125       DECL_ARGUMENTS (current_function_decl) = 0;
14126     }
14127
14128   pop_function_context ();
14129
14130   f_function_chain = p->next;
14131
14132   named_labels = p->named_labels;
14133   shadowed_labels = p->shadowed_labels;
14134   current_binding_level = p->binding_level;
14135
14136   free (p);
14137 }
14138
14139 /* Save and reinitialize the variables
14140    used during compilation of a C function.  */
14141
14142 static void
14143 push_f_function_context ()
14144 {
14145   struct f_function *p
14146   = (struct f_function *) xmalloc (sizeof (struct f_function));
14147
14148   push_function_context ();
14149
14150   p->next = f_function_chain;
14151   f_function_chain = p;
14152
14153   p->named_labels = named_labels;
14154   p->shadowed_labels = shadowed_labels;
14155   p->binding_level = current_binding_level;
14156 }
14157
14158 static void
14159 push_parm_decl (tree parm)
14160 {
14161   int old_immediate_size_expand = immediate_size_expand;
14162
14163   /* Don't try computing parm sizes now -- wait till fn is called.  */
14164
14165   immediate_size_expand = 0;
14166
14167   /* Fill in arg stuff.  */
14168
14169   DECL_ARG_TYPE (parm) = TREE_TYPE (parm);
14170   DECL_ARG_TYPE_AS_WRITTEN (parm) = TREE_TYPE (parm);
14171   TREE_READONLY (parm) = 1;     /* All implementation args are read-only. */
14172
14173   parm = pushdecl (parm);
14174
14175   immediate_size_expand = old_immediate_size_expand;
14176
14177   finish_decl (parm, NULL_TREE, FALSE);
14178 }
14179
14180 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate.  */
14181
14182 static tree
14183 pushdecl_top_level (x)
14184      tree x;
14185 {
14186   register tree t;
14187   register struct binding_level *b = current_binding_level;
14188   register tree f = current_function_decl;
14189
14190   current_binding_level = global_binding_level;
14191   current_function_decl = NULL_TREE;
14192   t = pushdecl (x);
14193   current_binding_level = b;
14194   current_function_decl = f;
14195   return t;
14196 }
14197
14198 /* Store the list of declarations of the current level.
14199    This is done for the parameter declarations of a function being defined,
14200    after they are modified in the light of any missing parameters.  */
14201
14202 static tree
14203 storedecls (decls)
14204      tree decls;
14205 {
14206   return current_binding_level->names = decls;
14207 }
14208
14209 /* Store the parameter declarations into the current function declaration.
14210    This is called after parsing the parameter declarations, before
14211    digesting the body of the function.
14212
14213    For an old-style definition, modify the function's type
14214    to specify at least the number of arguments.  */
14215
14216 static void
14217 store_parm_decls (int is_main_program UNUSED)
14218 {
14219   register tree fndecl = current_function_decl;
14220
14221   if (fndecl == error_mark_node)
14222     return;
14223
14224   /* This is a chain of PARM_DECLs from old-style parm declarations.  */
14225   DECL_ARGUMENTS (fndecl) = storedecls (nreverse (getdecls ()));
14226
14227   /* Initialize the RTL code for the function.  */
14228
14229   init_function_start (fndecl, input_filename, lineno);
14230
14231   /* Set up parameters and prepare for return, for the function.  */
14232
14233   expand_function_start (fndecl, 0);
14234 }
14235
14236 static tree
14237 start_decl (tree decl, bool is_top_level)
14238 {
14239   register tree tem;
14240   bool at_top_level = (current_binding_level == global_binding_level);
14241   bool top_level = is_top_level || at_top_level;
14242
14243   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
14244      level anyway.  */
14245   assert (!is_top_level || !at_top_level);
14246
14247   if (DECL_INITIAL (decl) != NULL_TREE)
14248     {
14249       assert (DECL_INITIAL (decl) == error_mark_node);
14250       assert (!DECL_EXTERNAL (decl));
14251     }
14252   else if (top_level)
14253     assert ((TREE_STATIC (decl) == 1) || DECL_EXTERNAL (decl) == 1);
14254
14255   /* For Fortran, we by default put things in .common when possible.  */
14256   DECL_COMMON (decl) = 1;
14257
14258   /* Add this decl to the current binding level. TEM may equal DECL or it may
14259      be a previous decl of the same name.  */
14260   if (is_top_level)
14261     tem = pushdecl_top_level (decl);
14262   else
14263     tem = pushdecl (decl);
14264
14265   /* For a local variable, define the RTL now.  */
14266   if (!top_level
14267   /* But not if this is a duplicate decl and we preserved the rtl from the
14268      previous one (which may or may not happen).  */
14269       && !DECL_RTL_SET_P (tem))
14270     {
14271       if (TYPE_SIZE (TREE_TYPE (tem)) != 0)
14272         expand_decl (tem);
14273       else if (TREE_CODE (TREE_TYPE (tem)) == ARRAY_TYPE
14274                && DECL_INITIAL (tem) != 0)
14275         expand_decl (tem);
14276     }
14277
14278   return tem;
14279 }
14280
14281 /* Create the FUNCTION_DECL for a function definition.
14282    DECLSPECS and DECLARATOR are the parts of the declaration;
14283    they describe the function's name and the type it returns,
14284    but twisted together in a fashion that parallels the syntax of C.
14285
14286    This function creates a binding context for the function body
14287    as well as setting up the FUNCTION_DECL in current_function_decl.
14288
14289    Returns 1 on success.  If the DECLARATOR is not suitable for a function
14290    (it defines a datum instead), we return 0, which tells
14291    yyparse to report a parse error.
14292
14293    NESTED is nonzero for a function nested within another function.  */
14294
14295 static void
14296 start_function (tree name, tree type, int nested, int public)
14297 {
14298   tree decl1;
14299   tree restype;
14300   int old_immediate_size_expand = immediate_size_expand;
14301
14302   named_labels = 0;
14303   shadowed_labels = 0;
14304
14305   /* Don't expand any sizes in the return type of the function.  */
14306   immediate_size_expand = 0;
14307
14308   if (nested)
14309     {
14310       assert (!public);
14311       assert (current_function_decl != NULL_TREE);
14312       assert (DECL_CONTEXT (current_function_decl) == NULL_TREE);
14313     }
14314   else
14315     {
14316       assert (current_function_decl == NULL_TREE);
14317     }
14318
14319   if (TREE_CODE (type) == ERROR_MARK)
14320     decl1 = current_function_decl = error_mark_node;
14321   else
14322     {
14323       decl1 = build_decl (FUNCTION_DECL,
14324                           name,
14325                           type);
14326       TREE_PUBLIC (decl1) = public ? 1 : 0;
14327       if (nested)
14328         DECL_INLINE (decl1) = 1;
14329       TREE_STATIC (decl1) = 1;
14330       DECL_EXTERNAL (decl1) = 0;
14331
14332       announce_function (decl1);
14333
14334       /* Make the init_value nonzero so pushdecl knows this is not tentative.
14335          error_mark_node is replaced below (in poplevel) with the BLOCK.  */
14336       DECL_INITIAL (decl1) = error_mark_node;
14337
14338       /* Record the decl so that the function name is defined. If we already have
14339          a decl for this name, and it is a FUNCTION_DECL, use the old decl.  */
14340
14341       current_function_decl = pushdecl (decl1);
14342     }
14343
14344   if (!nested)
14345     ffecom_outer_function_decl_ = current_function_decl;
14346
14347   pushlevel (0);
14348   current_binding_level->prep_state = 2;
14349
14350   if (TREE_CODE (current_function_decl) != ERROR_MARK)
14351     {
14352       make_decl_rtl (current_function_decl, NULL);
14353
14354       restype = TREE_TYPE (TREE_TYPE (current_function_decl));
14355       DECL_RESULT (current_function_decl)
14356         = build_decl (RESULT_DECL, NULL_TREE, restype);
14357     }
14358
14359   if (!nested && (TREE_CODE (current_function_decl) != ERROR_MARK))
14360     TREE_ADDRESSABLE (current_function_decl) = 1;
14361
14362   immediate_size_expand = old_immediate_size_expand;
14363 }
14364 \f
14365 /* Here are the public functions the GNU back end needs.  */
14366
14367 tree
14368 convert (type, expr)
14369      tree type, expr;
14370 {
14371   register tree e = expr;
14372   register enum tree_code code = TREE_CODE (type);
14373
14374   if (type == TREE_TYPE (e)
14375       || TREE_CODE (e) == ERROR_MARK)
14376     return e;
14377   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
14378     return fold (build1 (NOP_EXPR, type, e));
14379   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
14380       || code == ERROR_MARK)
14381     return error_mark_node;
14382   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
14383     {
14384       assert ("void value not ignored as it ought to be" == NULL);
14385       return error_mark_node;
14386     }
14387   if (code == VOID_TYPE)
14388     return build1 (CONVERT_EXPR, type, e);
14389   if ((code != RECORD_TYPE)
14390       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
14391     e = ffecom_1 (REALPART_EXPR, TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e))),
14392                   e);
14393   if (code == INTEGER_TYPE || code == ENUMERAL_TYPE)
14394     return fold (convert_to_integer (type, e));
14395   if (code == POINTER_TYPE)
14396     return fold (convert_to_pointer (type, e));
14397   if (code == REAL_TYPE)
14398     return fold (convert_to_real (type, e));
14399   if (code == COMPLEX_TYPE)
14400     return fold (convert_to_complex (type, e));
14401   if (code == RECORD_TYPE)
14402     return fold (ffecom_convert_to_complex_ (type, e));
14403
14404   assert ("conversion to non-scalar type requested" == NULL);
14405   return error_mark_node;
14406 }
14407
14408 /* integrate_decl_tree calls this function, but since we don't use the
14409    DECL_LANG_SPECIFIC field, this is a no-op.  */
14410
14411 void
14412 copy_lang_decl (node)
14413      tree node UNUSED;
14414 {
14415 }
14416
14417 /* Return the list of declarations of the current level.
14418    Note that this list is in reverse order unless/until
14419    you nreverse it; and when you do nreverse it, you must
14420    store the result back using `storedecls' or you will lose.  */
14421
14422 tree
14423 getdecls ()
14424 {
14425   return current_binding_level->names;
14426 }
14427
14428 /* Nonzero if we are currently in the global binding level.  */
14429
14430 int
14431 global_bindings_p ()
14432 {
14433   return current_binding_level == global_binding_level;
14434 }
14435
14436 /* Print an error message for invalid use of an incomplete type.
14437    VALUE is the expression that was used (or 0 if that isn't known)
14438    and TYPE is the type that was invalid.  */
14439
14440 void
14441 incomplete_type_error (value, type)
14442      tree value UNUSED;
14443      tree type;
14444 {
14445   if (TREE_CODE (type) == ERROR_MARK)
14446     return;
14447
14448   assert ("incomplete type?!?" == NULL);
14449 }
14450
14451 /* Mark ARG for GC.  */
14452 static void
14453 mark_binding_level (void *arg)
14454 {
14455   struct binding_level *level = *(struct binding_level **) arg;
14456
14457   while (level)
14458     {
14459       ggc_mark_tree (level->names);
14460       ggc_mark_tree (level->blocks);
14461       ggc_mark_tree (level->this_block);
14462       level = level->level_chain;
14463     }
14464 }
14465
14466 void
14467 init_decl_processing ()
14468 {
14469   static tree *const tree_roots[] = {
14470     &current_function_decl,
14471     &string_type_node,
14472     &ffecom_tree_fun_type_void,
14473     &ffecom_integer_zero_node,
14474     &ffecom_integer_one_node,
14475     &ffecom_tree_subr_type,
14476     &ffecom_tree_ptr_to_subr_type,
14477     &ffecom_tree_blockdata_type,
14478     &ffecom_tree_xargc_,
14479     &ffecom_f2c_integer_type_node,
14480     &ffecom_f2c_ptr_to_integer_type_node,
14481     &ffecom_f2c_address_type_node,
14482     &ffecom_f2c_real_type_node,
14483     &ffecom_f2c_ptr_to_real_type_node,
14484     &ffecom_f2c_doublereal_type_node,
14485     &ffecom_f2c_complex_type_node,
14486     &ffecom_f2c_doublecomplex_type_node,
14487     &ffecom_f2c_longint_type_node,
14488     &ffecom_f2c_logical_type_node,
14489     &ffecom_f2c_flag_type_node,
14490     &ffecom_f2c_ftnlen_type_node,
14491     &ffecom_f2c_ftnlen_zero_node,
14492     &ffecom_f2c_ftnlen_one_node,
14493     &ffecom_f2c_ftnlen_two_node,
14494     &ffecom_f2c_ptr_to_ftnlen_type_node,
14495     &ffecom_f2c_ftnint_type_node,
14496     &ffecom_f2c_ptr_to_ftnint_type_node,
14497     &ffecom_outer_function_decl_,
14498     &ffecom_previous_function_decl_,
14499     &ffecom_which_entrypoint_decl_,
14500     &ffecom_float_zero_,
14501     &ffecom_float_half_,
14502     &ffecom_double_zero_,
14503     &ffecom_double_half_,
14504     &ffecom_func_result_,
14505     &ffecom_func_length_,
14506     &ffecom_multi_type_node_,
14507     &ffecom_multi_retval_,
14508     &named_labels,
14509     &shadowed_labels
14510   };
14511   size_t i;
14512
14513   malloc_init ();
14514
14515   /* Record our roots.  */
14516   for (i = 0; i < ARRAY_SIZE (tree_roots); i++)
14517     ggc_add_tree_root (tree_roots[i], 1);
14518   ggc_add_tree_root (&ffecom_tree_type[0][0],
14519                      FFEINFO_basictype*FFEINFO_kindtype);
14520   ggc_add_tree_root (&ffecom_tree_fun_type[0][0],
14521                      FFEINFO_basictype*FFEINFO_kindtype);
14522   ggc_add_tree_root (&ffecom_tree_ptr_to_fun_type[0][0],
14523                      FFEINFO_basictype*FFEINFO_kindtype);
14524   ggc_add_tree_root (ffecom_gfrt_, FFECOM_gfrt);
14525   ggc_add_root (&current_binding_level, 1, sizeof current_binding_level,
14526                 mark_binding_level);
14527   ggc_add_root (&free_binding_level, 1, sizeof current_binding_level,
14528                 mark_binding_level);
14529   ggc_add_root (&tracker_head, 1, sizeof tracker_head, mark_tracker_head);
14530
14531   ffe_init_0 ();
14532 }
14533
14534 const char *
14535 init_parse (filename)
14536      const char *filename;
14537 {
14538   /* Open input file.  */
14539   if (filename == 0 || !strcmp (filename, "-"))
14540     {
14541       finput = stdin;
14542       filename = "stdin";
14543     }
14544   else
14545     finput = fopen (filename, "r");
14546   if (finput == 0)
14547     fatal_io_error ("can't open %s", filename);
14548
14549 #ifdef IO_BUFFER_SIZE
14550   setvbuf (finput, (char *) xmalloc (IO_BUFFER_SIZE), _IOFBF, IO_BUFFER_SIZE);
14551 #endif
14552
14553   /* Make identifier nodes long enough for the language-specific slots.  */
14554   set_identifier_size (sizeof (struct lang_identifier));
14555   decl_printable_name = lang_printable_name;
14556 #if BUILT_FOR_270
14557   print_error_function = lang_print_error_function;
14558 #endif
14559
14560   return filename;
14561 }
14562
14563 void
14564 finish_parse ()
14565 {
14566   fclose (finput);
14567 }
14568
14569 /* Delete the node BLOCK from the current binding level.
14570    This is used for the block inside a stmt expr ({...})
14571    so that the block can be reinserted where appropriate.  */
14572
14573 static void
14574 delete_block (block)
14575      tree block;
14576 {
14577   tree t;
14578   if (current_binding_level->blocks == block)
14579     current_binding_level->blocks = TREE_CHAIN (block);
14580   for (t = current_binding_level->blocks; t;)
14581     {
14582       if (TREE_CHAIN (t) == block)
14583         TREE_CHAIN (t) = TREE_CHAIN (block);
14584       else
14585         t = TREE_CHAIN (t);
14586     }
14587   TREE_CHAIN (block) = NULL;
14588   /* Clear TREE_USED which is always set by poplevel.
14589      The flag is set again if insert_block is called.  */
14590   TREE_USED (block) = 0;
14591 }
14592
14593 void
14594 insert_block (block)
14595      tree block;
14596 {
14597   TREE_USED (block) = 1;
14598   current_binding_level->blocks
14599     = chainon (current_binding_level->blocks, block);
14600 }
14601
14602 /* Each front end provides its own.  */
14603 static void ffe_init PARAMS ((void));
14604 static void ffe_finish PARAMS ((void));
14605 static void ffe_init_options PARAMS ((void));
14606
14607 struct lang_hooks lang_hooks = {ffe_init,
14608                                 ffe_finish,
14609                                 ffe_init_options,
14610                                 ffe_decode_option,
14611                                 NULL /* post_options */};
14612
14613 /* used by print-tree.c */
14614
14615 void
14616 lang_print_xnode (file, node, indent)
14617      FILE *file UNUSED;
14618      tree node UNUSED;
14619      int indent UNUSED;
14620 {
14621 }
14622
14623 static void
14624 ffe_finish ()
14625 {
14626   ffe_terminate_0 ();
14627
14628   if (ffe_is_ffedebug ())
14629     malloc_pool_display (malloc_pool_image ());
14630 }
14631
14632 const char *
14633 lang_identify ()
14634 {
14635   return "f77";
14636 }
14637
14638 /* Return the typed-based alias set for T, which may be an expression
14639    or a type.  Return -1 if we don't do anything special.  */
14640
14641 HOST_WIDE_INT
14642 lang_get_alias_set (t)
14643      tree t ATTRIBUTE_UNUSED;
14644 {
14645   /* We do not wish to use alias-set based aliasing at all.  Used in the
14646      extreme (every object with its own set, with equivalences recorded)
14647      it might be helpful, but there are problems when it comes to inlining.
14648      We get on ok with flag_argument_noalias, and alias-set aliasing does
14649      currently limit how stack slots can be reused, which is a lose.  */
14650   return 0;
14651 }
14652
14653 static void
14654 ffe_init_options ()
14655 {
14656   /* Set default options for Fortran.  */
14657   flag_move_all_movables = 1;
14658   flag_reduce_all_givs = 1;
14659   flag_argument_noalias = 2;
14660   flag_errno_math = 0;
14661   flag_complex_divide_method = 1;
14662 }
14663
14664 static void
14665 ffe_init ()
14666 {
14667   /* If the file is output from cpp, it should contain a first line
14668      `# 1 "real-filename"', and the current design of gcc (toplev.c
14669      in particular and the way it sets up information relied on by
14670      INCLUDE) requires that we read this now, and store the
14671      "real-filename" info in master_input_filename.  Ask the lexer
14672      to try doing this.  */
14673   ffelex_hash_kludge (finput);
14674 }
14675
14676 int
14677 mark_addressable (exp)
14678      tree exp;
14679 {
14680   register tree x = exp;
14681   while (1)
14682     switch (TREE_CODE (x))
14683       {
14684       case ADDR_EXPR:
14685       case COMPONENT_REF:
14686       case ARRAY_REF:
14687         x = TREE_OPERAND (x, 0);
14688         break;
14689
14690       case CONSTRUCTOR:
14691         TREE_ADDRESSABLE (x) = 1;
14692         return 1;
14693
14694       case VAR_DECL:
14695       case CONST_DECL:
14696       case PARM_DECL:
14697       case RESULT_DECL:
14698         if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x)
14699             && DECL_NONLOCAL (x))
14700           {
14701             if (TREE_PUBLIC (x))
14702               {
14703                 assert ("address of global register var requested" == NULL);
14704                 return 0;
14705               }
14706             assert ("address of register variable requested" == NULL);
14707           }
14708         else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x))
14709           {
14710             if (TREE_PUBLIC (x))
14711               {
14712                 assert ("address of global register var requested" == NULL);
14713                 return 0;
14714               }
14715             assert ("address of register var requested" == NULL);
14716           }
14717         put_var_into_stack (x);
14718
14719         /* drops in */
14720       case FUNCTION_DECL:
14721         TREE_ADDRESSABLE (x) = 1;
14722 #if 0                           /* poplevel deals with this now.  */
14723         if (DECL_CONTEXT (x) == 0)
14724           TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x)) = 1;
14725 #endif
14726
14727       default:
14728         return 1;
14729       }
14730 }
14731
14732 /* If DECL has a cleanup, build and return that cleanup here.
14733    This is a callback called by expand_expr.  */
14734
14735 tree
14736 maybe_build_cleanup (decl)
14737      tree decl UNUSED;
14738 {
14739   /* There are no cleanups in Fortran.  */
14740   return NULL_TREE;
14741 }
14742
14743 /* Exit a binding level.
14744    Pop the level off, and restore the state of the identifier-decl mappings
14745    that were in effect when this level was entered.
14746
14747    If KEEP is nonzero, this level had explicit declarations, so
14748    and create a "block" (a BLOCK node) for the level
14749    to record its declarations and subblocks for symbol table output.
14750
14751    If FUNCTIONBODY is nonzero, this level is the body of a function,
14752    so create a block as if KEEP were set and also clear out all
14753    label names.
14754
14755    If REVERSE is nonzero, reverse the order of decls before putting
14756    them into the BLOCK.  */
14757
14758 tree
14759 poplevel (keep, reverse, functionbody)
14760      int keep;
14761      int reverse;
14762      int functionbody;
14763 {
14764   register tree link;
14765   /* The chain of decls was accumulated in reverse order.
14766      Put it into forward order, just for cleanliness.  */
14767   tree decls;
14768   tree subblocks = current_binding_level->blocks;
14769   tree block = 0;
14770   tree decl;
14771   int block_previously_created;
14772
14773   /* Get the decls in the order they were written.
14774      Usually current_binding_level->names is in reverse order.
14775      But parameter decls were previously put in forward order.  */
14776
14777   if (reverse)
14778     current_binding_level->names
14779       = decls = nreverse (current_binding_level->names);
14780   else
14781     decls = current_binding_level->names;
14782
14783   /* Output any nested inline functions within this block
14784      if they weren't already output.  */
14785
14786   for (decl = decls; decl; decl = TREE_CHAIN (decl))
14787     if (TREE_CODE (decl) == FUNCTION_DECL
14788         && ! TREE_ASM_WRITTEN (decl)
14789         && DECL_INITIAL (decl) != 0
14790         && TREE_ADDRESSABLE (decl))
14791       {
14792         /* If this decl was copied from a file-scope decl
14793            on account of a block-scope extern decl,
14794            propagate TREE_ADDRESSABLE to the file-scope decl.
14795
14796            DECL_ABSTRACT_ORIGIN can be set to itself if warn_return_type is
14797            true, since then the decl goes through save_for_inline_copying.  */
14798         if (DECL_ABSTRACT_ORIGIN (decl) != 0
14799             && DECL_ABSTRACT_ORIGIN (decl) != decl)
14800           TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl)) = 1;
14801         else if (DECL_SAVED_INSNS (decl) != 0)
14802           {
14803             push_function_context ();
14804             output_inline_function (decl);
14805             pop_function_context ();
14806           }
14807       }
14808
14809   /* If there were any declarations or structure tags in that level,
14810      or if this level is a function body,
14811      create a BLOCK to record them for the life of this function.  */
14812
14813   block = 0;
14814   block_previously_created = (current_binding_level->this_block != 0);
14815   if (block_previously_created)
14816     block = current_binding_level->this_block;
14817   else if (keep || functionbody)
14818     block = make_node (BLOCK);
14819   if (block != 0)
14820     {
14821       BLOCK_VARS (block) = decls;
14822       BLOCK_SUBBLOCKS (block) = subblocks;
14823     }
14824
14825   /* In each subblock, record that this is its superior.  */
14826
14827   for (link = subblocks; link; link = TREE_CHAIN (link))
14828     BLOCK_SUPERCONTEXT (link) = block;
14829
14830   /* Clear out the meanings of the local variables of this level.  */
14831
14832   for (link = decls; link; link = TREE_CHAIN (link))
14833     {
14834       if (DECL_NAME (link) != 0)
14835         {
14836           /* If the ident. was used or addressed via a local extern decl,
14837              don't forget that fact.  */
14838           if (DECL_EXTERNAL (link))
14839             {
14840               if (TREE_USED (link))
14841                 TREE_USED (DECL_NAME (link)) = 1;
14842               if (TREE_ADDRESSABLE (link))
14843                 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (link)) = 1;
14844             }
14845           IDENTIFIER_LOCAL_VALUE (DECL_NAME (link)) = 0;
14846         }
14847     }
14848
14849   /* If the level being exited is the top level of a function,
14850      check over all the labels, and clear out the current
14851      (function local) meanings of their names.  */
14852
14853   if (functionbody)
14854     {
14855       /* If this is the top level block of a function,
14856          the vars are the function's parameters.
14857          Don't leave them in the BLOCK because they are
14858          found in the FUNCTION_DECL instead.  */
14859
14860       BLOCK_VARS (block) = 0;
14861     }
14862
14863   /* Pop the current level, and free the structure for reuse.  */
14864
14865   {
14866     register struct binding_level *level = current_binding_level;
14867     current_binding_level = current_binding_level->level_chain;
14868
14869     level->level_chain = free_binding_level;
14870     free_binding_level = level;
14871   }
14872
14873   /* Dispose of the block that we just made inside some higher level.  */
14874   if (functionbody
14875       && current_function_decl != error_mark_node)
14876     DECL_INITIAL (current_function_decl) = block;
14877   else if (block)
14878     {
14879       if (!block_previously_created)
14880         current_binding_level->blocks
14881           = chainon (current_binding_level->blocks, block);
14882     }
14883   /* If we did not make a block for the level just exited,
14884      any blocks made for inner levels
14885      (since they cannot be recorded as subblocks in that level)
14886      must be carried forward so they will later become subblocks
14887      of something else.  */
14888   else if (subblocks)
14889     current_binding_level->blocks
14890       = chainon (current_binding_level->blocks, subblocks);
14891
14892   if (block)
14893     TREE_USED (block) = 1;
14894   return block;
14895 }
14896
14897 void
14898 print_lang_decl (file, node, indent)
14899      FILE *file UNUSED;
14900      tree node UNUSED;
14901      int indent UNUSED;
14902 {
14903 }
14904
14905 void
14906 print_lang_identifier (file, node, indent)
14907      FILE *file;
14908      tree node;
14909      int indent;
14910 {
14911   print_node (file, "global", IDENTIFIER_GLOBAL_VALUE (node), indent + 4);
14912   print_node (file, "local", IDENTIFIER_LOCAL_VALUE (node), indent + 4);
14913 }
14914
14915 void
14916 print_lang_statistics ()
14917 {
14918 }
14919
14920 void
14921 print_lang_type (file, node, indent)
14922      FILE *file UNUSED;
14923      tree node UNUSED;
14924      int indent UNUSED;
14925 {
14926 }
14927
14928 /* Record a decl-node X as belonging to the current lexical scope.
14929    Check for errors (such as an incompatible declaration for the same
14930    name already seen in the same scope).
14931
14932    Returns either X or an old decl for the same name.
14933    If an old decl is returned, it may have been smashed
14934    to agree with what X says.  */
14935
14936 tree
14937 pushdecl (x)
14938      tree x;
14939 {
14940   register tree t;
14941   register tree name = DECL_NAME (x);
14942   register struct binding_level *b = current_binding_level;
14943
14944   if ((TREE_CODE (x) == FUNCTION_DECL)
14945       && (DECL_INITIAL (x) == 0)
14946       && DECL_EXTERNAL (x))
14947     DECL_CONTEXT (x) = NULL_TREE;
14948   else
14949     DECL_CONTEXT (x) = current_function_decl;
14950
14951   if (name)
14952     {
14953       if (IDENTIFIER_INVENTED (name))
14954         {
14955 #if BUILT_FOR_270
14956           DECL_ARTIFICIAL (x) = 1;
14957 #endif
14958           DECL_IN_SYSTEM_HEADER (x) = 1;
14959         }
14960
14961       t = lookup_name_current_level (name);
14962
14963       assert ((t == NULL_TREE) || (DECL_CONTEXT (x) == NULL_TREE));
14964
14965       /* Don't push non-parms onto list for parms until we understand
14966          why we're doing this and whether it works.  */
14967
14968       assert ((b == global_binding_level)
14969               || !ffecom_transform_only_dummies_
14970               || TREE_CODE (x) == PARM_DECL);
14971
14972       if ((t != NULL_TREE) && duplicate_decls (x, t))
14973         return t;
14974
14975       /* If we are processing a typedef statement, generate a whole new
14976          ..._TYPE node (which will be just an variant of the existing
14977          ..._TYPE node with identical properties) and then install the
14978          TYPE_DECL node generated to represent the typedef name as the
14979          TYPE_NAME of this brand new (duplicate) ..._TYPE node.
14980
14981          The whole point here is to end up with a situation where each and every
14982          ..._TYPE node the compiler creates will be uniquely associated with
14983          AT MOST one node representing a typedef name. This way, even though
14984          the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL
14985          (i.e. "typedef name") nodes very early on, later parts of the
14986          compiler can always do the reverse translation and get back the
14987          corresponding typedef name.  For example, given:
14988
14989          typedef struct S MY_TYPE; MY_TYPE object;
14990
14991          Later parts of the compiler might only know that `object' was of type
14992          `struct S' if it were not for code just below.  With this code
14993          however, later parts of the compiler see something like:
14994
14995          struct S' == struct S typedef struct S' MY_TYPE; struct S' object;
14996
14997          And they can then deduce (from the node for type struct S') that the
14998          original object declaration was:
14999
15000          MY_TYPE object;
15001
15002          Being able to do this is important for proper support of protoize, and
15003          also for generating precise symbolic debugging information which
15004          takes full account of the programmer's (typedef) vocabulary.
15005
15006          Obviously, we don't want to generate a duplicate ..._TYPE node if the
15007          TYPE_DECL node that we are now processing really represents a
15008          standard built-in type.
15009
15010          Since all standard types are effectively declared at line zero in the
15011          source file, we can easily check to see if we are working on a
15012          standard type by checking the current value of lineno.  */
15013
15014       if (TREE_CODE (x) == TYPE_DECL)
15015         {
15016           if (DECL_SOURCE_LINE (x) == 0)
15017             {
15018               if (TYPE_NAME (TREE_TYPE (x)) == 0)
15019                 TYPE_NAME (TREE_TYPE (x)) = x;
15020             }
15021           else if (TREE_TYPE (x) != error_mark_node)
15022             {
15023               tree tt = TREE_TYPE (x);
15024
15025               tt = build_type_copy (tt);
15026               TYPE_NAME (tt) = x;
15027               TREE_TYPE (x) = tt;
15028             }
15029         }
15030
15031       /* This name is new in its binding level. Install the new declaration
15032          and return it.  */
15033       if (b == global_binding_level)
15034         IDENTIFIER_GLOBAL_VALUE (name) = x;
15035       else
15036         IDENTIFIER_LOCAL_VALUE (name) = x;
15037     }
15038
15039   /* Put decls on list in reverse order. We will reverse them later if
15040      necessary.  */
15041   TREE_CHAIN (x) = b->names;
15042   b->names = x;
15043
15044   return x;
15045 }
15046
15047 /* Nonzero if the current level needs to have a BLOCK made.  */
15048
15049 static int
15050 kept_level_p ()
15051 {
15052   tree decl;
15053
15054   for (decl = current_binding_level->names;
15055        decl;
15056        decl = TREE_CHAIN (decl))
15057     {
15058       if (TREE_USED (decl) || TREE_CODE (decl) != VAR_DECL
15059           || (DECL_NAME (decl) && ! DECL_ARTIFICIAL (decl)))
15060         /* Currently, there aren't supposed to be non-artificial names
15061            at other than the top block for a function -- they're
15062            believed to always be temps.  But it's wise to check anyway.  */
15063         return 1;
15064     }
15065   return 0;
15066 }
15067
15068 /* Enter a new binding level.
15069    If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
15070    not for that of tags.  */
15071
15072 void
15073 pushlevel (tag_transparent)
15074      int tag_transparent;
15075 {
15076   register struct binding_level *newlevel = NULL_BINDING_LEVEL;
15077
15078   assert (! tag_transparent);
15079
15080   if (current_binding_level == global_binding_level)
15081     {
15082       named_labels = 0;
15083     }
15084
15085   /* Reuse or create a struct for this binding level.  */
15086
15087   if (free_binding_level)
15088     {
15089       newlevel = free_binding_level;
15090       free_binding_level = free_binding_level->level_chain;
15091     }
15092   else
15093     {
15094       newlevel = make_binding_level ();
15095     }
15096
15097   /* Add this level to the front of the chain (stack) of levels that
15098      are active.  */
15099
15100   *newlevel = clear_binding_level;
15101   newlevel->level_chain = current_binding_level;
15102   current_binding_level = newlevel;
15103 }
15104
15105 /* Set the BLOCK node for the innermost scope
15106    (the one we are currently in).  */
15107
15108 void
15109 set_block (block)
15110      register tree block;
15111 {
15112   current_binding_level->this_block = block;
15113   current_binding_level->names = chainon (current_binding_level->names,
15114                                           BLOCK_VARS (block));
15115   current_binding_level->blocks = chainon (current_binding_level->blocks,
15116                                            BLOCK_SUBBLOCKS (block));
15117 }
15118
15119 /* ~~gcc/tree.h *should* declare this, because toplev.c references it.  */
15120
15121 /* Can't 'yydebug' a front end not generated by yacc/bison!  */
15122
15123 void
15124 set_yydebug (value)
15125      int value;
15126 {
15127   if (value)
15128     fprintf (stderr, "warning: no yacc/bison-generated output to debug!\n");
15129 }
15130
15131 tree
15132 signed_or_unsigned_type (unsignedp, type)
15133      int unsignedp;
15134      tree type;
15135 {
15136   tree type2;
15137
15138   if (! INTEGRAL_TYPE_P (type))
15139     return type;
15140   if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node))
15141     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15142   if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node))
15143     return unsignedp ? unsigned_type_node : integer_type_node;
15144   if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node))
15145     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15146   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node))
15147     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15148   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node))
15149     return (unsignedp ? long_long_unsigned_type_node
15150             : long_long_integer_type_node);
15151
15152   type2 = type_for_size (TYPE_PRECISION (type), unsignedp);
15153   if (type2 == NULL_TREE)
15154     return type;
15155
15156   return type2;
15157 }
15158
15159 tree
15160 signed_type (type)
15161      tree type;
15162 {
15163   tree type1 = TYPE_MAIN_VARIANT (type);
15164   ffeinfoKindtype kt;
15165   tree type2;
15166
15167   if (type1 == unsigned_char_type_node || type1 == char_type_node)
15168     return signed_char_type_node;
15169   if (type1 == unsigned_type_node)
15170     return integer_type_node;
15171   if (type1 == short_unsigned_type_node)
15172     return short_integer_type_node;
15173   if (type1 == long_unsigned_type_node)
15174     return long_integer_type_node;
15175   if (type1 == long_long_unsigned_type_node)
15176     return long_long_integer_type_node;
15177 #if 0   /* gcc/c-* files only */
15178   if (type1 == unsigned_intDI_type_node)
15179     return intDI_type_node;
15180   if (type1 == unsigned_intSI_type_node)
15181     return intSI_type_node;
15182   if (type1 == unsigned_intHI_type_node)
15183     return intHI_type_node;
15184   if (type1 == unsigned_intQI_type_node)
15185     return intQI_type_node;
15186 #endif
15187
15188   type2 = type_for_size (TYPE_PRECISION (type1), 0);
15189   if (type2 != NULL_TREE)
15190     return type2;
15191
15192   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15193     {
15194       type2 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
15195
15196       if (type1 == type2)
15197         return ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15198     }
15199
15200   return type;
15201 }
15202
15203 /* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
15204    or validate its data type for an `if' or `while' statement or ?..: exp.
15205
15206    This preparation consists of taking the ordinary
15207    representation of an expression expr and producing a valid tree
15208    boolean expression describing whether expr is nonzero.  We could
15209    simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
15210    but we optimize comparisons, &&, ||, and !.
15211
15212    The resulting type should always be `integer_type_node'.  */
15213
15214 tree
15215 truthvalue_conversion (expr)
15216      tree expr;
15217 {
15218   if (TREE_CODE (expr) == ERROR_MARK)
15219     return expr;
15220
15221 #if 0 /* This appears to be wrong for C++.  */
15222   /* These really should return error_mark_node after 2.4 is stable.
15223      But not all callers handle ERROR_MARK properly.  */
15224   switch (TREE_CODE (TREE_TYPE (expr)))
15225     {
15226     case RECORD_TYPE:
15227       error ("struct type value used where scalar is required");
15228       return integer_zero_node;
15229
15230     case UNION_TYPE:
15231       error ("union type value used where scalar is required");
15232       return integer_zero_node;
15233
15234     case ARRAY_TYPE:
15235       error ("array type value used where scalar is required");
15236       return integer_zero_node;
15237
15238     default:
15239       break;
15240     }
15241 #endif /* 0 */
15242
15243   switch (TREE_CODE (expr))
15244     {
15245       /* It is simpler and generates better code to have only TRUTH_*_EXPR
15246          or comparison expressions as truth values at this level.  */
15247 #if 0
15248     case COMPONENT_REF:
15249       /* A one-bit unsigned bit-field is already acceptable.  */
15250       if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr, 1)))
15251           && TREE_UNSIGNED (TREE_OPERAND (expr, 1)))
15252         return expr;
15253       break;
15254 #endif
15255
15256     case EQ_EXPR:
15257       /* It is simpler and generates better code to have only TRUTH_*_EXPR
15258          or comparison expressions as truth values at this level.  */
15259 #if 0
15260       if (integer_zerop (TREE_OPERAND (expr, 1)))
15261         return build_unary_op (TRUTH_NOT_EXPR, TREE_OPERAND (expr, 0), 0);
15262 #endif
15263     case NE_EXPR: case LE_EXPR: case GE_EXPR: case LT_EXPR: case GT_EXPR:
15264     case TRUTH_ANDIF_EXPR:
15265     case TRUTH_ORIF_EXPR:
15266     case TRUTH_AND_EXPR:
15267     case TRUTH_OR_EXPR:
15268     case TRUTH_XOR_EXPR:
15269       TREE_TYPE (expr) = integer_type_node;
15270       return expr;
15271
15272     case ERROR_MARK:
15273       return expr;
15274
15275     case INTEGER_CST:
15276       return integer_zerop (expr) ? integer_zero_node : integer_one_node;
15277
15278     case REAL_CST:
15279       return real_zerop (expr) ? integer_zero_node : integer_one_node;
15280
15281     case ADDR_EXPR:
15282       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 0)))
15283         return build (COMPOUND_EXPR, integer_type_node,
15284                       TREE_OPERAND (expr, 0), integer_one_node);
15285       else
15286         return integer_one_node;
15287
15288     case COMPLEX_EXPR:
15289       return ffecom_2 ((TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1))
15290                         ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
15291                        integer_type_node,
15292                        truthvalue_conversion (TREE_OPERAND (expr, 0)),
15293                        truthvalue_conversion (TREE_OPERAND (expr, 1)));
15294
15295     case NEGATE_EXPR:
15296     case ABS_EXPR:
15297     case FLOAT_EXPR:
15298     case FFS_EXPR:
15299       /* These don't change whether an object is non-zero or zero.  */
15300       return truthvalue_conversion (TREE_OPERAND (expr, 0));
15301
15302     case LROTATE_EXPR:
15303     case RROTATE_EXPR:
15304       /* These don't change whether an object is zero or non-zero, but
15305          we can't ignore them if their second arg has side-effects.  */
15306       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1)))
15307         return build (COMPOUND_EXPR, integer_type_node, TREE_OPERAND (expr, 1),
15308                       truthvalue_conversion (TREE_OPERAND (expr, 0)));
15309       else
15310         return truthvalue_conversion (TREE_OPERAND (expr, 0));
15311
15312     case COND_EXPR:
15313       /* Distribute the conversion into the arms of a COND_EXPR.  */
15314       return fold (build (COND_EXPR, integer_type_node, TREE_OPERAND (expr, 0),
15315                           truthvalue_conversion (TREE_OPERAND (expr, 1)),
15316                           truthvalue_conversion (TREE_OPERAND (expr, 2))));
15317
15318     case CONVERT_EXPR:
15319       /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
15320          since that affects how `default_conversion' will behave.  */
15321       if (TREE_CODE (TREE_TYPE (expr)) == REFERENCE_TYPE
15322           || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) == REFERENCE_TYPE)
15323         break;
15324       /* fall through... */
15325     case NOP_EXPR:
15326       /* If this is widening the argument, we can ignore it.  */
15327       if (TYPE_PRECISION (TREE_TYPE (expr))
15328           >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr, 0))))
15329         return truthvalue_conversion (TREE_OPERAND (expr, 0));
15330       break;
15331
15332     case MINUS_EXPR:
15333       /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize
15334          this case.  */
15335       if (TARGET_FLOAT_FORMAT == IEEE_FLOAT_FORMAT
15336           && TREE_CODE (TREE_TYPE (expr)) == REAL_TYPE)
15337         break;
15338       /* fall through... */
15339     case BIT_XOR_EXPR:
15340       /* This and MINUS_EXPR can be changed into a comparison of the
15341          two objects.  */
15342       if (TREE_TYPE (TREE_OPERAND (expr, 0))
15343           == TREE_TYPE (TREE_OPERAND (expr, 1)))
15344         return ffecom_2 (NE_EXPR, integer_type_node,
15345                          TREE_OPERAND (expr, 0),
15346                          TREE_OPERAND (expr, 1));
15347       return ffecom_2 (NE_EXPR, integer_type_node,
15348                        TREE_OPERAND (expr, 0),
15349                        fold (build1 (NOP_EXPR,
15350                                      TREE_TYPE (TREE_OPERAND (expr, 0)),
15351                                      TREE_OPERAND (expr, 1))));
15352
15353     case BIT_AND_EXPR:
15354       if (integer_onep (TREE_OPERAND (expr, 1)))
15355         return expr;
15356       break;
15357
15358     case MODIFY_EXPR:
15359 #if 0                           /* No such thing in Fortran. */
15360       if (warn_parentheses && C_EXP_ORIGINAL_CODE (expr) == MODIFY_EXPR)
15361         warning ("suggest parentheses around assignment used as truth value");
15362 #endif
15363       break;
15364
15365     default:
15366       break;
15367     }
15368
15369   if (TREE_CODE (TREE_TYPE (expr)) == COMPLEX_TYPE)
15370     return (ffecom_2
15371             ((TREE_SIDE_EFFECTS (expr)
15372               ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
15373              integer_type_node,
15374              truthvalue_conversion (ffecom_1 (REALPART_EXPR,
15375                                               TREE_TYPE (TREE_TYPE (expr)),
15376                                               expr)),
15377              truthvalue_conversion (ffecom_1 (IMAGPART_EXPR,
15378                                               TREE_TYPE (TREE_TYPE (expr)),
15379                                               expr))));
15380
15381   return ffecom_2 (NE_EXPR, integer_type_node,
15382                    expr,
15383                    convert (TREE_TYPE (expr), integer_zero_node));
15384 }
15385
15386 tree
15387 type_for_mode (mode, unsignedp)
15388      enum machine_mode mode;
15389      int unsignedp;
15390 {
15391   int i;
15392   int j;
15393   tree t;
15394
15395   if (mode == TYPE_MODE (integer_type_node))
15396     return unsignedp ? unsigned_type_node : integer_type_node;
15397
15398   if (mode == TYPE_MODE (signed_char_type_node))
15399     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15400
15401   if (mode == TYPE_MODE (short_integer_type_node))
15402     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15403
15404   if (mode == TYPE_MODE (long_integer_type_node))
15405     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15406
15407   if (mode == TYPE_MODE (long_long_integer_type_node))
15408     return unsignedp ? long_long_unsigned_type_node : long_long_integer_type_node;
15409
15410 #if HOST_BITS_PER_WIDE_INT >= 64
15411   if (mode == TYPE_MODE (intTI_type_node))
15412     return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
15413 #endif
15414
15415   if (mode == TYPE_MODE (float_type_node))
15416     return float_type_node;
15417
15418   if (mode == TYPE_MODE (double_type_node))
15419     return double_type_node;
15420
15421   if (mode == TYPE_MODE (build_pointer_type (char_type_node)))
15422     return build_pointer_type (char_type_node);
15423
15424   if (mode == TYPE_MODE (build_pointer_type (integer_type_node)))
15425     return build_pointer_type (integer_type_node);
15426
15427   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
15428     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
15429       {
15430         if (((t = ffecom_tree_type[i][j]) != NULL_TREE)
15431             && (mode == TYPE_MODE (t)))
15432           {
15433             if ((i == FFEINFO_basictypeINTEGER) && unsignedp)
15434               return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][j];
15435             else
15436               return t;
15437           }
15438       }
15439
15440   return 0;
15441 }
15442
15443 tree
15444 type_for_size (bits, unsignedp)
15445      unsigned bits;
15446      int unsignedp;
15447 {
15448   ffeinfoKindtype kt;
15449   tree type_node;
15450
15451   if (bits == TYPE_PRECISION (integer_type_node))
15452     return unsignedp ? unsigned_type_node : integer_type_node;
15453
15454   if (bits == TYPE_PRECISION (signed_char_type_node))
15455     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15456
15457   if (bits == TYPE_PRECISION (short_integer_type_node))
15458     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15459
15460   if (bits == TYPE_PRECISION (long_integer_type_node))
15461     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15462
15463   if (bits == TYPE_PRECISION (long_long_integer_type_node))
15464     return (unsignedp ? long_long_unsigned_type_node
15465             : long_long_integer_type_node);
15466
15467   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15468     {
15469       type_node = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15470
15471       if ((type_node != NULL_TREE) && (bits == TYPE_PRECISION (type_node)))
15472         return unsignedp ? ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]
15473           : type_node;
15474     }
15475
15476   return 0;
15477 }
15478
15479 tree
15480 unsigned_type (type)
15481      tree type;
15482 {
15483   tree type1 = TYPE_MAIN_VARIANT (type);
15484   ffeinfoKindtype kt;
15485   tree type2;
15486
15487   if (type1 == signed_char_type_node || type1 == char_type_node)
15488     return unsigned_char_type_node;
15489   if (type1 == integer_type_node)
15490     return unsigned_type_node;
15491   if (type1 == short_integer_type_node)
15492     return short_unsigned_type_node;
15493   if (type1 == long_integer_type_node)
15494     return long_unsigned_type_node;
15495   if (type1 == long_long_integer_type_node)
15496     return long_long_unsigned_type_node;
15497 #if 0   /* gcc/c-* files only */
15498   if (type1 == intDI_type_node)
15499     return unsigned_intDI_type_node;
15500   if (type1 == intSI_type_node)
15501     return unsigned_intSI_type_node;
15502   if (type1 == intHI_type_node)
15503     return unsigned_intHI_type_node;
15504   if (type1 == intQI_type_node)
15505     return unsigned_intQI_type_node;
15506 #endif
15507
15508   type2 = type_for_size (TYPE_PRECISION (type1), 1);
15509   if (type2 != NULL_TREE)
15510     return type2;
15511
15512   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15513     {
15514       type2 = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15515
15516       if (type1 == type2)
15517         return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
15518     }
15519
15520   return type;
15521 }
15522
15523 void
15524 lang_mark_tree (t)
15525      union tree_node *t ATTRIBUTE_UNUSED;
15526 {
15527   if (TREE_CODE (t) == IDENTIFIER_NODE)
15528     {
15529       struct lang_identifier *i = (struct lang_identifier *) t;
15530       ggc_mark_tree (IDENTIFIER_GLOBAL_VALUE (i));
15531       ggc_mark_tree (IDENTIFIER_LOCAL_VALUE (i));
15532       ggc_mark_tree (IDENTIFIER_LABEL_VALUE (i));
15533     }
15534   else if (TYPE_P (t) && TYPE_LANG_SPECIFIC (t))
15535     ggc_mark (TYPE_LANG_SPECIFIC (t));
15536 }
15537
15538 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
15539 \f
15540 #if FFECOM_GCC_INCLUDE
15541
15542 /* From gcc/cccp.c, the code to handle -I.  */
15543
15544 /* Skip leading "./" from a directory name.
15545    This may yield the empty string, which represents the current directory.  */
15546
15547 static const char *
15548 skip_redundant_dir_prefix (const char *dir)
15549 {
15550   while (dir[0] == '.' && dir[1] == '/')
15551     for (dir += 2; *dir == '/'; dir++)
15552       continue;
15553   if (dir[0] == '.' && !dir[1])
15554     dir++;
15555   return dir;
15556 }
15557
15558 /* The file_name_map structure holds a mapping of file names for a
15559    particular directory.  This mapping is read from the file named
15560    FILE_NAME_MAP_FILE in that directory.  Such a file can be used to
15561    map filenames on a file system with severe filename restrictions,
15562    such as DOS.  The format of the file name map file is just a series
15563    of lines with two tokens on each line.  The first token is the name
15564    to map, and the second token is the actual name to use.  */
15565
15566 struct file_name_map
15567 {
15568   struct file_name_map *map_next;
15569   char *map_from;
15570   char *map_to;
15571 };
15572
15573 #define FILE_NAME_MAP_FILE "header.gcc"
15574
15575 /* Current maximum length of directory names in the search path
15576    for include files.  (Altered as we get more of them.)  */
15577
15578 static int max_include_len = 0;
15579
15580 struct file_name_list
15581   {
15582     struct file_name_list *next;
15583     char *fname;
15584     /* Mapping of file names for this directory.  */
15585     struct file_name_map *name_map;
15586     /* Non-zero if name_map is valid.  */
15587     int got_name_map;
15588   };
15589
15590 static struct file_name_list *include = NULL;   /* First dir to search */
15591 static struct file_name_list *last_include = NULL;      /* Last in chain */
15592
15593 /* I/O buffer structure.
15594    The `fname' field is nonzero for source files and #include files
15595    and for the dummy text used for -D and -U.
15596    It is zero for rescanning results of macro expansion
15597    and for expanding macro arguments.  */
15598 #define INPUT_STACK_MAX 400
15599 static struct file_buf {
15600   const char *fname;
15601   /* Filename specified with #line command.  */
15602   const char *nominal_fname;
15603   /* Record where in the search path this file was found.
15604      For #include_next.  */
15605   struct file_name_list *dir;
15606   ffewhereLine line;
15607   ffewhereColumn column;
15608 } instack[INPUT_STACK_MAX];
15609
15610 static int last_error_tick = 0;    /* Incremented each time we print it.  */
15611 static int input_file_stack_tick = 0;  /* Incremented when status changes.  */
15612
15613 /* Current nesting level of input sources.
15614    `instack[indepth]' is the level currently being read.  */
15615 static int indepth = -1;
15616
15617 typedef struct file_buf FILE_BUF;
15618
15619 typedef unsigned char U_CHAR;
15620
15621 /* table to tell if char can be part of a C identifier. */
15622 U_CHAR is_idchar[256];
15623 /* table to tell if char can be first char of a c identifier. */
15624 U_CHAR is_idstart[256];
15625 /* table to tell if c is horizontal space.  */
15626 U_CHAR is_hor_space[256];
15627 /* table to tell if c is horizontal or vertical space.  */
15628 static U_CHAR is_space[256];
15629
15630 #define SKIP_WHITE_SPACE(p) do { while (is_hor_space[*p]) p++; } while (0)
15631 #define SKIP_ALL_WHITE_SPACE(p) do { while (is_space[*p]) p++; } while (0)
15632
15633 /* Nonzero means -I- has been seen,
15634    so don't look for #include "foo" the source-file directory.  */
15635 static int ignore_srcdir;
15636
15637 #ifndef INCLUDE_LEN_FUDGE
15638 #define INCLUDE_LEN_FUDGE 0
15639 #endif
15640
15641 static void append_include_chain (struct file_name_list *first,
15642                                   struct file_name_list *last);
15643 static FILE *open_include_file (char *filename,
15644                                 struct file_name_list *searchptr);
15645 static void print_containing_files (ffebadSeverity sev);
15646 static char *read_filename_string (int ch, FILE *f);
15647 static struct file_name_map *read_name_map (const char *dirname);
15648
15649 /* Append a chain of `struct file_name_list's
15650    to the end of the main include chain.
15651    FIRST is the beginning of the chain to append, and LAST is the end.  */
15652
15653 static void
15654 append_include_chain (first, last)
15655      struct file_name_list *first, *last;
15656 {
15657   struct file_name_list *dir;
15658
15659   if (!first || !last)
15660     return;
15661
15662   if (include == 0)
15663     include = first;
15664   else
15665     last_include->next = first;
15666
15667   for (dir = first; ; dir = dir->next) {
15668     int len = strlen (dir->fname) + INCLUDE_LEN_FUDGE;
15669     if (len > max_include_len)
15670       max_include_len = len;
15671     if (dir == last)
15672       break;
15673   }
15674
15675   last->next = NULL;
15676   last_include = last;
15677 }
15678
15679 /* Try to open include file FILENAME.  SEARCHPTR is the directory
15680    being tried from the include file search path.  This function maps
15681    filenames on file systems based on information read by
15682    read_name_map.  */
15683
15684 static FILE *
15685 open_include_file (filename, searchptr)
15686      char *filename;
15687      struct file_name_list *searchptr;
15688 {
15689   register struct file_name_map *map;
15690   register char *from;
15691   char *p, *dir;
15692
15693   if (searchptr && ! searchptr->got_name_map)
15694     {
15695       searchptr->name_map = read_name_map (searchptr->fname
15696                                            ? searchptr->fname : ".");
15697       searchptr->got_name_map = 1;
15698     }
15699
15700   /* First check the mapping for the directory we are using.  */
15701   if (searchptr && searchptr->name_map)
15702     {
15703       from = filename;
15704       if (searchptr->fname)
15705         from += strlen (searchptr->fname) + 1;
15706       for (map = searchptr->name_map; map; map = map->map_next)
15707         {
15708           if (! strcmp (map->map_from, from))
15709             {
15710               /* Found a match.  */
15711               return fopen (map->map_to, "r");
15712             }
15713         }
15714     }
15715
15716   /* Try to find a mapping file for the particular directory we are
15717      looking in.  Thus #include <sys/types.h> will look up sys/types.h
15718      in /usr/include/header.gcc and look up types.h in
15719      /usr/include/sys/header.gcc.  */
15720   p = strrchr (filename, '/');
15721 #ifdef DIR_SEPARATOR
15722   if (! p) p = strrchr (filename, DIR_SEPARATOR);
15723   else {
15724     char *tmp = strrchr (filename, DIR_SEPARATOR);
15725     if (tmp != NULL && tmp > p) p = tmp;
15726   }
15727 #endif
15728   if (! p)
15729     p = filename;
15730   if (searchptr
15731       && searchptr->fname
15732       && strlen (searchptr->fname) == (size_t) (p - filename)
15733       && ! strncmp (searchptr->fname, filename, (int) (p - filename)))
15734     {
15735       /* FILENAME is in SEARCHPTR, which we've already checked.  */
15736       return fopen (filename, "r");
15737     }
15738
15739   if (p == filename)
15740     {
15741       from = filename;
15742       map = read_name_map (".");
15743     }
15744   else
15745     {
15746       dir = (char *) xmalloc (p - filename + 1);
15747       memcpy (dir, filename, p - filename);
15748       dir[p - filename] = '\0';
15749       from = p + 1;
15750       map = read_name_map (dir);
15751       free (dir);
15752     }
15753   for (; map; map = map->map_next)
15754     if (! strcmp (map->map_from, from))
15755       return fopen (map->map_to, "r");
15756
15757   return fopen (filename, "r");
15758 }
15759
15760 /* Print the file names and line numbers of the #include
15761    commands which led to the current file.  */
15762
15763 static void
15764 print_containing_files (ffebadSeverity sev)
15765 {
15766   FILE_BUF *ip = NULL;
15767   int i;
15768   int first = 1;
15769   const char *str1;
15770   const char *str2;
15771
15772   /* If stack of files hasn't changed since we last printed
15773      this info, don't repeat it.  */
15774   if (last_error_tick == input_file_stack_tick)
15775     return;
15776
15777   for (i = indepth; i >= 0; i--)
15778     if (instack[i].fname != NULL) {
15779       ip = &instack[i];
15780       break;
15781     }
15782
15783   /* Give up if we don't find a source file.  */
15784   if (ip == NULL)
15785     return;
15786
15787   /* Find the other, outer source files.  */
15788   for (i--; i >= 0; i--)
15789     if (instack[i].fname != NULL)
15790       {
15791         ip = &instack[i];
15792         if (first)
15793           {
15794             first = 0;
15795             str1 = "In file included";
15796           }
15797         else
15798           {
15799             str1 = "...          ...";
15800           }
15801
15802         if (i == 1)
15803           str2 = ":";
15804         else
15805           str2 = "";
15806
15807         ffebad_start_msg ("%A from %B at %0%C", sev);
15808         ffebad_here (0, ip->line, ip->column);
15809         ffebad_string (str1);
15810         ffebad_string (ip->nominal_fname);
15811         ffebad_string (str2);
15812         ffebad_finish ();
15813       }
15814
15815   /* Record we have printed the status as of this time.  */
15816   last_error_tick = input_file_stack_tick;
15817 }
15818
15819 /* Read a space delimited string of unlimited length from a stdio
15820    file.  */
15821
15822 static char *
15823 read_filename_string (ch, f)
15824      int ch;
15825      FILE *f;
15826 {
15827   char *alloc, *set;
15828   int len;
15829
15830   len = 20;
15831   set = alloc = xmalloc (len + 1);
15832   if (! is_space[ch])
15833     {
15834       *set++ = ch;
15835       while ((ch = getc (f)) != EOF && ! is_space[ch])
15836         {
15837           if (set - alloc == len)
15838             {
15839               len *= 2;
15840               alloc = xrealloc (alloc, len + 1);
15841               set = alloc + len / 2;
15842             }
15843           *set++ = ch;
15844         }
15845     }
15846   *set = '\0';
15847   ungetc (ch, f);
15848   return alloc;
15849 }
15850
15851 /* Read the file name map file for DIRNAME.  */
15852
15853 static struct file_name_map *
15854 read_name_map (dirname)
15855      const char *dirname;
15856 {
15857   /* This structure holds a linked list of file name maps, one per
15858      directory.  */
15859   struct file_name_map_list
15860     {
15861       struct file_name_map_list *map_list_next;
15862       char *map_list_name;
15863       struct file_name_map *map_list_map;
15864     };
15865   static struct file_name_map_list *map_list;
15866   register struct file_name_map_list *map_list_ptr;
15867   char *name;
15868   FILE *f;
15869   size_t dirlen;
15870   int separator_needed;
15871
15872   dirname = skip_redundant_dir_prefix (dirname);
15873
15874   for (map_list_ptr = map_list; map_list_ptr;
15875        map_list_ptr = map_list_ptr->map_list_next)
15876     if (! strcmp (map_list_ptr->map_list_name, dirname))
15877       return map_list_ptr->map_list_map;
15878
15879   map_list_ptr = ((struct file_name_map_list *)
15880                   xmalloc (sizeof (struct file_name_map_list)));
15881   map_list_ptr->map_list_name = xstrdup (dirname);
15882   map_list_ptr->map_list_map = NULL;
15883
15884   dirlen = strlen (dirname);
15885   separator_needed = dirlen != 0 && dirname[dirlen - 1] != '/';
15886   name = (char *) xmalloc (dirlen + strlen (FILE_NAME_MAP_FILE) + 2);
15887   strcpy (name, dirname);
15888   name[dirlen] = '/';
15889   strcpy (name + dirlen + separator_needed, FILE_NAME_MAP_FILE);
15890   f = fopen (name, "r");
15891   free (name);
15892   if (!f)
15893     map_list_ptr->map_list_map = NULL;
15894   else
15895     {
15896       int ch;
15897
15898       while ((ch = getc (f)) != EOF)
15899         {
15900           char *from, *to;
15901           struct file_name_map *ptr;
15902
15903           if (is_space[ch])
15904             continue;
15905           from = read_filename_string (ch, f);
15906           while ((ch = getc (f)) != EOF && is_hor_space[ch])
15907             ;
15908           to = read_filename_string (ch, f);
15909
15910           ptr = ((struct file_name_map *)
15911                  xmalloc (sizeof (struct file_name_map)));
15912           ptr->map_from = from;
15913
15914           /* Make the real filename absolute.  */
15915           if (*to == '/')
15916             ptr->map_to = to;
15917           else
15918             {
15919               ptr->map_to = xmalloc (dirlen + strlen (to) + 2);
15920               strcpy (ptr->map_to, dirname);
15921               ptr->map_to[dirlen] = '/';
15922               strcpy (ptr->map_to + dirlen + separator_needed, to);
15923               free (to);
15924             }
15925
15926           ptr->map_next = map_list_ptr->map_list_map;
15927           map_list_ptr->map_list_map = ptr;
15928
15929           while ((ch = getc (f)) != '\n')
15930             if (ch == EOF)
15931               break;
15932         }
15933       fclose (f);
15934     }
15935
15936   map_list_ptr->map_list_next = map_list;
15937   map_list = map_list_ptr;
15938
15939   return map_list_ptr->map_list_map;
15940 }
15941
15942 static void
15943 ffecom_file_ (const char *name)
15944 {
15945   FILE_BUF *fp;
15946
15947   /* Do partial setup of input buffer for the sake of generating
15948      early #line directives (when -g is in effect).  */
15949
15950   fp = &instack[++indepth];
15951   memset ((char *) fp, 0, sizeof (FILE_BUF));
15952   if (name == NULL)
15953     name = "";
15954   fp->nominal_fname = fp->fname = name;
15955 }
15956
15957 /* Initialize syntactic classifications of characters.  */
15958
15959 static void
15960 ffecom_initialize_char_syntax_ ()
15961 {
15962   register int i;
15963
15964   /*
15965    * Set up is_idchar and is_idstart tables.  These should be
15966    * faster than saying (is_alpha (c) || c == '_'), etc.
15967    * Set up these things before calling any routines tthat
15968    * refer to them.
15969    */
15970   for (i = 'a'; i <= 'z'; i++) {
15971     is_idchar[i - 'a' + 'A'] = 1;
15972     is_idchar[i] = 1;
15973     is_idstart[i - 'a' + 'A'] = 1;
15974     is_idstart[i] = 1;
15975   }
15976   for (i = '0'; i <= '9'; i++)
15977     is_idchar[i] = 1;
15978   is_idchar['_'] = 1;
15979   is_idstart['_'] = 1;
15980
15981   /* horizontal space table */
15982   is_hor_space[' '] = 1;
15983   is_hor_space['\t'] = 1;
15984   is_hor_space['\v'] = 1;
15985   is_hor_space['\f'] = 1;
15986   is_hor_space['\r'] = 1;
15987
15988   is_space[' '] = 1;
15989   is_space['\t'] = 1;
15990   is_space['\v'] = 1;
15991   is_space['\f'] = 1;
15992   is_space['\n'] = 1;
15993   is_space['\r'] = 1;
15994 }
15995
15996 static void
15997 ffecom_close_include_ (FILE *f)
15998 {
15999   fclose (f);
16000
16001   indepth--;
16002   input_file_stack_tick++;
16003
16004   ffewhere_line_kill (instack[indepth].line);
16005   ffewhere_column_kill (instack[indepth].column);
16006 }
16007
16008 static int
16009 ffecom_decode_include_option_ (char *spec)
16010 {
16011   struct file_name_list *dirtmp;
16012
16013   if (! ignore_srcdir && !strcmp (spec, "-"))
16014     ignore_srcdir = 1;
16015   else
16016     {
16017       dirtmp = (struct file_name_list *)
16018         xmalloc (sizeof (struct file_name_list));
16019       dirtmp->next = 0;         /* New one goes on the end */
16020       dirtmp->fname = spec;
16021       dirtmp->got_name_map = 0;
16022       if (spec[0] == 0)
16023         error ("Directory name must immediately follow -I");
16024       else
16025         append_include_chain (dirtmp, dirtmp);
16026     }
16027   return 1;
16028 }
16029
16030 /* Open INCLUDEd file.  */
16031
16032 static FILE *
16033 ffecom_open_include_ (char *name, ffewhereLine l, ffewhereColumn c)
16034 {
16035   char *fbeg = name;
16036   size_t flen = strlen (fbeg);
16037   struct file_name_list *search_start = include; /* Chain of dirs to search */
16038   struct file_name_list dsp[1]; /* First in chain, if #include "..." */
16039   struct file_name_list *searchptr = 0;
16040   char *fname;          /* Dynamically allocated fname buffer */
16041   FILE *f;
16042   FILE_BUF *fp;
16043
16044   if (flen == 0)
16045     return NULL;
16046
16047   dsp[0].fname = NULL;
16048
16049   /* If -I- was specified, don't search current dir, only spec'd ones. */
16050   if (!ignore_srcdir)
16051     {
16052       for (fp = &instack[indepth]; fp >= instack; fp--)
16053         {
16054           int n;
16055           char *ep;
16056           const char *nam;
16057
16058           if ((nam = fp->nominal_fname) != NULL)
16059             {
16060               /* Found a named file.  Figure out dir of the file,
16061                  and put it in front of the search list.  */
16062               dsp[0].next = search_start;
16063               search_start = dsp;
16064 #ifndef VMS
16065               ep = strrchr (nam, '/');
16066 #ifdef DIR_SEPARATOR
16067             if (ep == NULL) ep = strrchr (nam, DIR_SEPARATOR);
16068             else {
16069               char *tmp = strrchr (nam, DIR_SEPARATOR);
16070               if (tmp != NULL && tmp > ep) ep = tmp;
16071             }
16072 #endif
16073 #else                           /* VMS */
16074               ep = strrchr (nam, ']');
16075               if (ep == NULL) ep = strrchr (nam, '>');
16076               if (ep == NULL) ep = strrchr (nam, ':');
16077               if (ep != NULL) ep++;
16078 #endif                          /* VMS */
16079               if (ep != NULL)
16080                 {
16081                   n = ep - nam;
16082                   dsp[0].fname = (char *) xmalloc (n + 1);
16083                   strncpy (dsp[0].fname, nam, n);
16084                   dsp[0].fname[n] = '\0';
16085                   if (n + INCLUDE_LEN_FUDGE > max_include_len)
16086                     max_include_len = n + INCLUDE_LEN_FUDGE;
16087                 }
16088               else
16089                 dsp[0].fname = NULL; /* Current directory */
16090               dsp[0].got_name_map = 0;
16091               break;
16092             }
16093         }
16094     }
16095
16096   /* Allocate this permanently, because it gets stored in the definitions
16097      of macros.  */
16098   fname = xmalloc (max_include_len + flen + 4);
16099   /* + 2 above for slash and terminating null.  */
16100   /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED
16101      for g77 yet).  */
16102
16103   /* If specified file name is absolute, just open it.  */
16104
16105   if (*fbeg == '/'
16106 #ifdef DIR_SEPARATOR
16107       || *fbeg == DIR_SEPARATOR
16108 #endif
16109       )
16110     {
16111       strncpy (fname, (char *) fbeg, flen);
16112       fname[flen] = 0;
16113       f = open_include_file (fname, NULL);
16114     }
16115   else
16116     {
16117       f = NULL;
16118
16119       /* Search directory path, trying to open the file.
16120          Copy each filename tried into FNAME.  */
16121
16122       for (searchptr = search_start; searchptr; searchptr = searchptr->next)
16123         {
16124           if (searchptr->fname)
16125             {
16126               /* The empty string in a search path is ignored.
16127                  This makes it possible to turn off entirely
16128                  a standard piece of the list.  */
16129               if (searchptr->fname[0] == 0)
16130                 continue;
16131               strcpy (fname, skip_redundant_dir_prefix (searchptr->fname));
16132               if (fname[0] && fname[strlen (fname) - 1] != '/')
16133                 strcat (fname, "/");
16134               fname[strlen (fname) + flen] = 0;
16135             }
16136           else
16137             fname[0] = 0;
16138
16139           strncat (fname, fbeg, flen);
16140 #ifdef VMS
16141           /* Change this 1/2 Unix 1/2 VMS file specification into a
16142              full VMS file specification */
16143           if (searchptr->fname && (searchptr->fname[0] != 0))
16144             {
16145               /* Fix up the filename */
16146               hack_vms_include_specification (fname);
16147             }
16148           else
16149             {
16150               /* This is a normal VMS filespec, so use it unchanged.  */
16151               strncpy (fname, (char *) fbeg, flen);
16152               fname[flen] = 0;
16153 #if 0   /* Not for g77.  */
16154               /* if it's '#include filename', add the missing .h */
16155               if (strchr (fname, '.') == NULL)
16156                 strcat (fname, ".h");
16157 #endif
16158             }
16159 #endif /* VMS */
16160           f = open_include_file (fname, searchptr);
16161 #ifdef EACCES
16162           if (f == NULL && errno == EACCES)
16163             {
16164               print_containing_files (FFEBAD_severityWARNING);
16165               ffebad_start_msg ("At %0, INCLUDE file %A exists, but is not readable",
16166                                 FFEBAD_severityWARNING);
16167               ffebad_string (fname);
16168               ffebad_here (0, l, c);
16169               ffebad_finish ();
16170             }
16171 #endif
16172           if (f != NULL)
16173             break;
16174         }
16175     }
16176
16177   if (f == NULL)
16178     {
16179       /* A file that was not found.  */
16180
16181       strncpy (fname, (char *) fbeg, flen);
16182       fname[flen] = 0;
16183       print_containing_files (ffebad_severity (FFEBAD_OPEN_INCLUDE));
16184       ffebad_start (FFEBAD_OPEN_INCLUDE);
16185       ffebad_here (0, l, c);
16186       ffebad_string (fname);
16187       ffebad_finish ();
16188     }
16189
16190   if (dsp[0].fname != NULL)
16191     free (dsp[0].fname);
16192
16193   if (f == NULL)
16194     return NULL;
16195
16196   if (indepth >= (INPUT_STACK_MAX - 1))
16197     {
16198       print_containing_files (FFEBAD_severityFATAL);
16199       ffebad_start_msg ("At %0, INCLUDE nesting too deep",
16200                         FFEBAD_severityFATAL);
16201       ffebad_string (fname);
16202       ffebad_here (0, l, c);
16203       ffebad_finish ();
16204       return NULL;
16205     }
16206
16207   instack[indepth].line = ffewhere_line_use (l);
16208   instack[indepth].column = ffewhere_column_use (c);
16209
16210   fp = &instack[indepth + 1];
16211   memset ((char *) fp, 0, sizeof (FILE_BUF));
16212   fp->nominal_fname = fp->fname = fname;
16213   fp->dir = searchptr;
16214
16215   indepth++;
16216   input_file_stack_tick++;
16217
16218   return f;
16219 }
16220 #endif  /* FFECOM_GCC_INCLUDE */
16221
16222 /**INDENT* (Do not reformat this comment even with -fca option.)
16223    Data-gathering files: Given the source file listed below, compiled with
16224    f2c I obtained the output file listed after that, and from the output
16225    file I derived the above code.
16226
16227 -------- (begin input file to f2c)
16228         implicit none
16229         character*10 A1,A2
16230         complex C1,C2
16231         integer I1,I2
16232         real R1,R2
16233         double precision D1,D2
16234 C
16235         call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2)
16236 c /
16237         call fooI(I1/I2)
16238         call fooR(R1/I1)
16239         call fooD(D1/I1)
16240         call fooC(C1/I1)
16241         call fooR(R1/R2)
16242         call fooD(R1/D1)
16243         call fooD(D1/D2)
16244         call fooD(D1/R1)
16245         call fooC(C1/C2)
16246         call fooC(C1/R1)
16247         call fooZ(C1/D1)
16248 c **
16249         call fooI(I1**I2)
16250         call fooR(R1**I1)
16251         call fooD(D1**I1)
16252         call fooC(C1**I1)
16253         call fooR(R1**R2)
16254         call fooD(R1**D1)
16255         call fooD(D1**D2)
16256         call fooD(D1**R1)
16257         call fooC(C1**C2)
16258         call fooC(C1**R1)
16259         call fooZ(C1**D1)
16260 c FFEINTRIN_impABS
16261         call fooR(ABS(R1))
16262 c FFEINTRIN_impACOS
16263         call fooR(ACOS(R1))
16264 c FFEINTRIN_impAIMAG
16265         call fooR(AIMAG(C1))
16266 c FFEINTRIN_impAINT
16267         call fooR(AINT(R1))
16268 c FFEINTRIN_impALOG
16269         call fooR(ALOG(R1))
16270 c FFEINTRIN_impALOG10
16271         call fooR(ALOG10(R1))
16272 c FFEINTRIN_impAMAX0
16273         call fooR(AMAX0(I1,I2))
16274 c FFEINTRIN_impAMAX1
16275         call fooR(AMAX1(R1,R2))
16276 c FFEINTRIN_impAMIN0
16277         call fooR(AMIN0(I1,I2))
16278 c FFEINTRIN_impAMIN1
16279         call fooR(AMIN1(R1,R2))
16280 c FFEINTRIN_impAMOD
16281         call fooR(AMOD(R1,R2))
16282 c FFEINTRIN_impANINT
16283         call fooR(ANINT(R1))
16284 c FFEINTRIN_impASIN
16285         call fooR(ASIN(R1))
16286 c FFEINTRIN_impATAN
16287         call fooR(ATAN(R1))
16288 c FFEINTRIN_impATAN2
16289         call fooR(ATAN2(R1,R2))
16290 c FFEINTRIN_impCABS
16291         call fooR(CABS(C1))
16292 c FFEINTRIN_impCCOS
16293         call fooC(CCOS(C1))
16294 c FFEINTRIN_impCEXP
16295         call fooC(CEXP(C1))
16296 c FFEINTRIN_impCHAR
16297         call fooA(CHAR(I1))
16298 c FFEINTRIN_impCLOG
16299         call fooC(CLOG(C1))
16300 c FFEINTRIN_impCONJG
16301         call fooC(CONJG(C1))
16302 c FFEINTRIN_impCOS
16303         call fooR(COS(R1))
16304 c FFEINTRIN_impCOSH
16305         call fooR(COSH(R1))
16306 c FFEINTRIN_impCSIN
16307         call fooC(CSIN(C1))
16308 c FFEINTRIN_impCSQRT
16309         call fooC(CSQRT(C1))
16310 c FFEINTRIN_impDABS
16311         call fooD(DABS(D1))
16312 c FFEINTRIN_impDACOS
16313         call fooD(DACOS(D1))
16314 c FFEINTRIN_impDASIN
16315         call fooD(DASIN(D1))
16316 c FFEINTRIN_impDATAN
16317         call fooD(DATAN(D1))
16318 c FFEINTRIN_impDATAN2
16319         call fooD(DATAN2(D1,D2))
16320 c FFEINTRIN_impDCOS
16321         call fooD(DCOS(D1))
16322 c FFEINTRIN_impDCOSH
16323         call fooD(DCOSH(D1))
16324 c FFEINTRIN_impDDIM
16325         call fooD(DDIM(D1,D2))
16326 c FFEINTRIN_impDEXP
16327         call fooD(DEXP(D1))
16328 c FFEINTRIN_impDIM
16329         call fooR(DIM(R1,R2))
16330 c FFEINTRIN_impDINT
16331         call fooD(DINT(D1))
16332 c FFEINTRIN_impDLOG
16333         call fooD(DLOG(D1))
16334 c FFEINTRIN_impDLOG10
16335         call fooD(DLOG10(D1))
16336 c FFEINTRIN_impDMAX1
16337         call fooD(DMAX1(D1,D2))
16338 c FFEINTRIN_impDMIN1
16339         call fooD(DMIN1(D1,D2))
16340 c FFEINTRIN_impDMOD
16341         call fooD(DMOD(D1,D2))
16342 c FFEINTRIN_impDNINT
16343         call fooD(DNINT(D1))
16344 c FFEINTRIN_impDPROD
16345         call fooD(DPROD(R1,R2))
16346 c FFEINTRIN_impDSIGN
16347         call fooD(DSIGN(D1,D2))
16348 c FFEINTRIN_impDSIN
16349         call fooD(DSIN(D1))
16350 c FFEINTRIN_impDSINH
16351         call fooD(DSINH(D1))
16352 c FFEINTRIN_impDSQRT
16353         call fooD(DSQRT(D1))
16354 c FFEINTRIN_impDTAN
16355         call fooD(DTAN(D1))
16356 c FFEINTRIN_impDTANH
16357         call fooD(DTANH(D1))
16358 c FFEINTRIN_impEXP
16359         call fooR(EXP(R1))
16360 c FFEINTRIN_impIABS
16361         call fooI(IABS(I1))
16362 c FFEINTRIN_impICHAR
16363         call fooI(ICHAR(A1))
16364 c FFEINTRIN_impIDIM
16365         call fooI(IDIM(I1,I2))
16366 c FFEINTRIN_impIDNINT
16367         call fooI(IDNINT(D1))
16368 c FFEINTRIN_impINDEX
16369         call fooI(INDEX(A1,A2))
16370 c FFEINTRIN_impISIGN
16371         call fooI(ISIGN(I1,I2))
16372 c FFEINTRIN_impLEN
16373         call fooI(LEN(A1))
16374 c FFEINTRIN_impLGE
16375         call fooL(LGE(A1,A2))
16376 c FFEINTRIN_impLGT
16377         call fooL(LGT(A1,A2))
16378 c FFEINTRIN_impLLE
16379         call fooL(LLE(A1,A2))
16380 c FFEINTRIN_impLLT
16381         call fooL(LLT(A1,A2))
16382 c FFEINTRIN_impMAX0
16383         call fooI(MAX0(I1,I2))
16384 c FFEINTRIN_impMAX1
16385         call fooI(MAX1(R1,R2))
16386 c FFEINTRIN_impMIN0
16387         call fooI(MIN0(I1,I2))
16388 c FFEINTRIN_impMIN1
16389         call fooI(MIN1(R1,R2))
16390 c FFEINTRIN_impMOD
16391         call fooI(MOD(I1,I2))
16392 c FFEINTRIN_impNINT
16393         call fooI(NINT(R1))
16394 c FFEINTRIN_impSIGN
16395         call fooR(SIGN(R1,R2))
16396 c FFEINTRIN_impSIN
16397         call fooR(SIN(R1))
16398 c FFEINTRIN_impSINH
16399         call fooR(SINH(R1))
16400 c FFEINTRIN_impSQRT
16401         call fooR(SQRT(R1))
16402 c FFEINTRIN_impTAN
16403         call fooR(TAN(R1))
16404 c FFEINTRIN_impTANH
16405         call fooR(TANH(R1))
16406 c FFEINTRIN_imp_CMPLX_C
16407         call fooC(cmplx(C1,C2))
16408 c FFEINTRIN_imp_CMPLX_D
16409         call fooZ(cmplx(D1,D2))
16410 c FFEINTRIN_imp_CMPLX_I
16411         call fooC(cmplx(I1,I2))
16412 c FFEINTRIN_imp_CMPLX_R
16413         call fooC(cmplx(R1,R2))
16414 c FFEINTRIN_imp_DBLE_C
16415         call fooD(dble(C1))
16416 c FFEINTRIN_imp_DBLE_D
16417         call fooD(dble(D1))
16418 c FFEINTRIN_imp_DBLE_I
16419         call fooD(dble(I1))
16420 c FFEINTRIN_imp_DBLE_R
16421         call fooD(dble(R1))
16422 c FFEINTRIN_imp_INT_C
16423         call fooI(int(C1))
16424 c FFEINTRIN_imp_INT_D
16425         call fooI(int(D1))
16426 c FFEINTRIN_imp_INT_I
16427         call fooI(int(I1))
16428 c FFEINTRIN_imp_INT_R
16429         call fooI(int(R1))
16430 c FFEINTRIN_imp_REAL_C
16431         call fooR(real(C1))
16432 c FFEINTRIN_imp_REAL_D
16433         call fooR(real(D1))
16434 c FFEINTRIN_imp_REAL_I
16435         call fooR(real(I1))
16436 c FFEINTRIN_imp_REAL_R
16437         call fooR(real(R1))
16438 c
16439 c FFEINTRIN_imp_INT_D:
16440 c
16441 c FFEINTRIN_specIDINT
16442         call fooI(IDINT(D1))
16443 c
16444 c FFEINTRIN_imp_INT_R:
16445 c
16446 c FFEINTRIN_specIFIX
16447         call fooI(IFIX(R1))
16448 c FFEINTRIN_specINT
16449         call fooI(INT(R1))
16450 c
16451 c FFEINTRIN_imp_REAL_D:
16452 c
16453 c FFEINTRIN_specSNGL
16454         call fooR(SNGL(D1))
16455 c
16456 c FFEINTRIN_imp_REAL_I:
16457 c
16458 c FFEINTRIN_specFLOAT
16459         call fooR(FLOAT(I1))
16460 c FFEINTRIN_specREAL
16461         call fooR(REAL(I1))
16462 c
16463         end
16464 -------- (end input file to f2c)
16465
16466 -------- (begin output from providing above input file as input to:
16467 --------  `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
16468 --------     -e "s:^#.*$::g"')
16469
16470 //  -- translated by f2c (version 19950223).
16471    You must link the resulting object file with the libraries:
16472         -lf2c -lm   (in that order)
16473 //
16474
16475
16476 // f2c.h  --  Standard Fortran to C header file //
16477
16478 ///  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
16479
16480         - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
16481
16482
16483
16484
16485 // F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems //
16486 // we assume short, float are OK //
16487 typedef long int // long int // integer;
16488 typedef char *address;
16489 typedef short int shortint;
16490 typedef float real;
16491 typedef double doublereal;
16492 typedef struct { real r, i; } complex;
16493 typedef struct { doublereal r, i; } doublecomplex;
16494 typedef long int // long int // logical;
16495 typedef short int shortlogical;
16496 typedef char logical1;
16497 typedef char integer1;
16498 // typedef long long longint; // // system-dependent //
16499
16500
16501
16502
16503 // Extern is for use with -E //
16504
16505
16506
16507
16508 // I/O stuff //
16509
16510
16511
16512
16513
16514
16515
16516
16517 typedef long int // int or long int // flag;
16518 typedef long int // int or long int // ftnlen;
16519 typedef long int // int or long int // ftnint;
16520
16521
16522 //external read, write//
16523 typedef struct
16524 {       flag cierr;
16525         ftnint ciunit;
16526         flag ciend;
16527         char *cifmt;
16528         ftnint cirec;
16529 } cilist;
16530
16531 //internal read, write//
16532 typedef struct
16533 {       flag icierr;
16534         char *iciunit;
16535         flag iciend;
16536         char *icifmt;
16537         ftnint icirlen;
16538         ftnint icirnum;
16539 } icilist;
16540
16541 //open//
16542 typedef struct
16543 {       flag oerr;
16544         ftnint ounit;
16545         char *ofnm;
16546         ftnlen ofnmlen;
16547         char *osta;
16548         char *oacc;
16549         char *ofm;
16550         ftnint orl;
16551         char *oblnk;
16552 } olist;
16553
16554 //close//
16555 typedef struct
16556 {       flag cerr;
16557         ftnint cunit;
16558         char *csta;
16559 } cllist;
16560
16561 //rewind, backspace, endfile//
16562 typedef struct
16563 {       flag aerr;
16564         ftnint aunit;
16565 } alist;
16566
16567 // inquire //
16568 typedef struct
16569 {       flag inerr;
16570         ftnint inunit;
16571         char *infile;
16572         ftnlen infilen;
16573         ftnint  *inex;  //parameters in standard's order//
16574         ftnint  *inopen;
16575         ftnint  *innum;
16576         ftnint  *innamed;
16577         char    *inname;
16578         ftnlen  innamlen;
16579         char    *inacc;
16580         ftnlen  inacclen;
16581         char    *inseq;
16582         ftnlen  inseqlen;
16583         char    *indir;
16584         ftnlen  indirlen;
16585         char    *infmt;
16586         ftnlen  infmtlen;
16587         char    *inform;
16588         ftnint  informlen;
16589         char    *inunf;
16590         ftnlen  inunflen;
16591         ftnint  *inrecl;
16592         ftnint  *innrec;
16593         char    *inblank;
16594         ftnlen  inblanklen;
16595 } inlist;
16596
16597
16598
16599 union Multitype {       // for multiple entry points //
16600         integer1 g;
16601         shortint h;
16602         integer i;
16603         // longint j; //
16604         real r;
16605         doublereal d;
16606         complex c;
16607         doublecomplex z;
16608         };
16609
16610 typedef union Multitype Multitype;
16611
16612 typedef long Long;      // No longer used; formerly in Namelist //
16613
16614 struct Vardesc {        // for Namelist //
16615         char *name;
16616         char *addr;
16617         ftnlen *dims;
16618         int  type;
16619         };
16620 typedef struct Vardesc Vardesc;
16621
16622 struct Namelist {
16623         char *name;
16624         Vardesc **vars;
16625         int nvars;
16626         };
16627 typedef struct Namelist Namelist;
16628
16629
16630
16631
16632
16633
16634
16635
16636 // procedure parameter types for -A and -C++ //
16637
16638
16639
16640
16641 typedef int // Unknown procedure type // (*U_fp)();
16642 typedef shortint (*J_fp)();
16643 typedef integer (*I_fp)();
16644 typedef real (*R_fp)();
16645 typedef doublereal (*D_fp)(), (*E_fp)();
16646 typedef // Complex // void  (*C_fp)();
16647 typedef // Double Complex // void  (*Z_fp)();
16648 typedef logical (*L_fp)();
16649 typedef shortlogical (*K_fp)();
16650 typedef // Character // void  (*H_fp)();
16651 typedef // Subroutine // int (*S_fp)();
16652
16653 // E_fp is for real functions when -R is not specified //
16654 typedef void  C_f;      // complex function //
16655 typedef void  H_f;      // character function //
16656 typedef void  Z_f;      // double complex function //
16657 typedef doublereal E_f; // real function with -R not specified //
16658
16659 // undef any lower-case symbols that your C compiler predefines, e.g.: //
16660
16661
16662 // (No such symbols should be defined in a strict ANSI C compiler.
16663    We can avoid trouble with f2c-translated code by using
16664    gcc -ansi [-traditional].) //
16665
16666
16667
16668
16669
16670
16671
16672
16673
16674
16675
16676
16677
16678
16679
16680
16681
16682
16683
16684
16685
16686
16687
16688 // Main program // MAIN__()
16689 {
16690     // System generated locals //
16691     integer i__1;
16692     real r__1, r__2;
16693     doublereal d__1, d__2;
16694     complex q__1;
16695     doublecomplex z__1, z__2, z__3;
16696     logical L__1;
16697     char ch__1[1];
16698
16699     // Builtin functions //
16700     void c_div();
16701     integer pow_ii();
16702     double pow_ri(), pow_di();
16703     void pow_ci();
16704     double pow_dd();
16705     void pow_zz();
16706     double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
16707             asin(), atan(), atan2(), c_abs();
16708     void c_cos(), c_exp(), c_log(), r_cnjg();
16709     double cos(), cosh();
16710     void c_sin(), c_sqrt();
16711     double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
16712             d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
16713     integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
16714     logical l_ge(), l_gt(), l_le(), l_lt();
16715     integer i_nint();
16716     double r_sign();
16717
16718     // Local variables //
16719     extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
16720             fool_(), fooz_(), getem_();
16721     static char a1[10], a2[10];
16722     static complex c1, c2;
16723     static doublereal d1, d2;
16724     static integer i1, i2;
16725     static real r1, r2;
16726
16727
16728     getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L);
16729 // / //
16730     i__1 = i1 / i2;
16731     fooi_(&i__1);
16732     r__1 = r1 / i1;
16733     foor_(&r__1);
16734     d__1 = d1 / i1;
16735     food_(&d__1);
16736     d__1 = (doublereal) i1;
16737     q__1.r = c1.r / d__1, q__1.i = c1.i / d__1;
16738     fooc_(&q__1);
16739     r__1 = r1 / r2;
16740     foor_(&r__1);
16741     d__1 = r1 / d1;
16742     food_(&d__1);
16743     d__1 = d1 / d2;
16744     food_(&d__1);
16745     d__1 = d1 / r1;
16746     food_(&d__1);
16747     c_div(&q__1, &c1, &c2);
16748     fooc_(&q__1);
16749     q__1.r = c1.r / r1, q__1.i = c1.i / r1;
16750     fooc_(&q__1);
16751     z__1.r = c1.r / d1, z__1.i = c1.i / d1;
16752     fooz_(&z__1);
16753 // ** //
16754     i__1 = pow_ii(&i1, &i2);
16755     fooi_(&i__1);
16756     r__1 = pow_ri(&r1, &i1);
16757     foor_(&r__1);
16758     d__1 = pow_di(&d1, &i1);
16759     food_(&d__1);
16760     pow_ci(&q__1, &c1, &i1);
16761     fooc_(&q__1);
16762     d__1 = (doublereal) r1;
16763     d__2 = (doublereal) r2;
16764     r__1 = pow_dd(&d__1, &d__2);
16765     foor_(&r__1);
16766     d__2 = (doublereal) r1;
16767     d__1 = pow_dd(&d__2, &d1);
16768     food_(&d__1);
16769     d__1 = pow_dd(&d1, &d2);
16770     food_(&d__1);
16771     d__2 = (doublereal) r1;
16772     d__1 = pow_dd(&d1, &d__2);
16773     food_(&d__1);
16774     z__2.r = c1.r, z__2.i = c1.i;
16775     z__3.r = c2.r, z__3.i = c2.i;
16776     pow_zz(&z__1, &z__2, &z__3);
16777     q__1.r = z__1.r, q__1.i = z__1.i;
16778     fooc_(&q__1);
16779     z__2.r = c1.r, z__2.i = c1.i;
16780     z__3.r = r1, z__3.i = 0.;
16781     pow_zz(&z__1, &z__2, &z__3);
16782     q__1.r = z__1.r, q__1.i = z__1.i;
16783     fooc_(&q__1);
16784     z__2.r = c1.r, z__2.i = c1.i;
16785     z__3.r = d1, z__3.i = 0.;
16786     pow_zz(&z__1, &z__2, &z__3);
16787     fooz_(&z__1);
16788 // FFEINTRIN_impABS //
16789     r__1 = (doublereal)((  r1  ) >= 0 ? (  r1  ) : -(  r1  ))  ;
16790     foor_(&r__1);
16791 // FFEINTRIN_impACOS //
16792     r__1 = acos(r1);
16793     foor_(&r__1);
16794 // FFEINTRIN_impAIMAG //
16795     r__1 = r_imag(&c1);
16796     foor_(&r__1);
16797 // FFEINTRIN_impAINT //
16798     r__1 = r_int(&r1);
16799     foor_(&r__1);
16800 // FFEINTRIN_impALOG //
16801     r__1 = log(r1);
16802     foor_(&r__1);
16803 // FFEINTRIN_impALOG10 //
16804     r__1 = r_lg10(&r1);
16805     foor_(&r__1);
16806 // FFEINTRIN_impAMAX0 //
16807     r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16808     foor_(&r__1);
16809 // FFEINTRIN_impAMAX1 //
16810     r__1 = (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16811     foor_(&r__1);
16812 // FFEINTRIN_impAMIN0 //
16813     r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16814     foor_(&r__1);
16815 // FFEINTRIN_impAMIN1 //
16816     r__1 = (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16817     foor_(&r__1);
16818 // FFEINTRIN_impAMOD //
16819     r__1 = r_mod(&r1, &r2);
16820     foor_(&r__1);
16821 // FFEINTRIN_impANINT //
16822     r__1 = r_nint(&r1);
16823     foor_(&r__1);
16824 // FFEINTRIN_impASIN //
16825     r__1 = asin(r1);
16826     foor_(&r__1);
16827 // FFEINTRIN_impATAN //
16828     r__1 = atan(r1);
16829     foor_(&r__1);
16830 // FFEINTRIN_impATAN2 //
16831     r__1 = atan2(r1, r2);
16832     foor_(&r__1);
16833 // FFEINTRIN_impCABS //
16834     r__1 = c_abs(&c1);
16835     foor_(&r__1);
16836 // FFEINTRIN_impCCOS //
16837     c_cos(&q__1, &c1);
16838     fooc_(&q__1);
16839 // FFEINTRIN_impCEXP //
16840     c_exp(&q__1, &c1);
16841     fooc_(&q__1);
16842 // FFEINTRIN_impCHAR //
16843     *(unsigned char *)&ch__1[0] = i1;
16844     fooa_(ch__1, 1L);
16845 // FFEINTRIN_impCLOG //
16846     c_log(&q__1, &c1);
16847     fooc_(&q__1);
16848 // FFEINTRIN_impCONJG //
16849     r_cnjg(&q__1, &c1);
16850     fooc_(&q__1);
16851 // FFEINTRIN_impCOS //
16852     r__1 = cos(r1);
16853     foor_(&r__1);
16854 // FFEINTRIN_impCOSH //
16855     r__1 = cosh(r1);
16856     foor_(&r__1);
16857 // FFEINTRIN_impCSIN //
16858     c_sin(&q__1, &c1);
16859     fooc_(&q__1);
16860 // FFEINTRIN_impCSQRT //
16861     c_sqrt(&q__1, &c1);
16862     fooc_(&q__1);
16863 // FFEINTRIN_impDABS //
16864     d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ;
16865     food_(&d__1);
16866 // FFEINTRIN_impDACOS //
16867     d__1 = acos(d1);
16868     food_(&d__1);
16869 // FFEINTRIN_impDASIN //
16870     d__1 = asin(d1);
16871     food_(&d__1);
16872 // FFEINTRIN_impDATAN //
16873     d__1 = atan(d1);
16874     food_(&d__1);
16875 // FFEINTRIN_impDATAN2 //
16876     d__1 = atan2(d1, d2);
16877     food_(&d__1);
16878 // FFEINTRIN_impDCOS //
16879     d__1 = cos(d1);
16880     food_(&d__1);
16881 // FFEINTRIN_impDCOSH //
16882     d__1 = cosh(d1);
16883     food_(&d__1);
16884 // FFEINTRIN_impDDIM //
16885     d__1 = d_dim(&d1, &d2);
16886     food_(&d__1);
16887 // FFEINTRIN_impDEXP //
16888     d__1 = exp(d1);
16889     food_(&d__1);
16890 // FFEINTRIN_impDIM //
16891     r__1 = r_dim(&r1, &r2);
16892     foor_(&r__1);
16893 // FFEINTRIN_impDINT //
16894     d__1 = d_int(&d1);
16895     food_(&d__1);
16896 // FFEINTRIN_impDLOG //
16897     d__1 = log(d1);
16898     food_(&d__1);
16899 // FFEINTRIN_impDLOG10 //
16900     d__1 = d_lg10(&d1);
16901     food_(&d__1);
16902 // FFEINTRIN_impDMAX1 //
16903     d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ;
16904     food_(&d__1);
16905 // FFEINTRIN_impDMIN1 //
16906     d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ;
16907     food_(&d__1);
16908 // FFEINTRIN_impDMOD //
16909     d__1 = d_mod(&d1, &d2);
16910     food_(&d__1);
16911 // FFEINTRIN_impDNINT //
16912     d__1 = d_nint(&d1);
16913     food_(&d__1);
16914 // FFEINTRIN_impDPROD //
16915     d__1 = (doublereal) r1 * r2;
16916     food_(&d__1);
16917 // FFEINTRIN_impDSIGN //
16918     d__1 = d_sign(&d1, &d2);
16919     food_(&d__1);
16920 // FFEINTRIN_impDSIN //
16921     d__1 = sin(d1);
16922     food_(&d__1);
16923 // FFEINTRIN_impDSINH //
16924     d__1 = sinh(d1);
16925     food_(&d__1);
16926 // FFEINTRIN_impDSQRT //
16927     d__1 = sqrt(d1);
16928     food_(&d__1);
16929 // FFEINTRIN_impDTAN //
16930     d__1 = tan(d1);
16931     food_(&d__1);
16932 // FFEINTRIN_impDTANH //
16933     d__1 = tanh(d1);
16934     food_(&d__1);
16935 // FFEINTRIN_impEXP //
16936     r__1 = exp(r1);
16937     foor_(&r__1);
16938 // FFEINTRIN_impIABS //
16939     i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ;
16940     fooi_(&i__1);
16941 // FFEINTRIN_impICHAR //
16942     i__1 = *(unsigned char *)a1;
16943     fooi_(&i__1);
16944 // FFEINTRIN_impIDIM //
16945     i__1 = i_dim(&i1, &i2);
16946     fooi_(&i__1);
16947 // FFEINTRIN_impIDNINT //
16948     i__1 = i_dnnt(&d1);
16949     fooi_(&i__1);
16950 // FFEINTRIN_impINDEX //
16951     i__1 = i_indx(a1, a2, 10L, 10L);
16952     fooi_(&i__1);
16953 // FFEINTRIN_impISIGN //
16954     i__1 = i_sign(&i1, &i2);
16955     fooi_(&i__1);
16956 // FFEINTRIN_impLEN //
16957     i__1 = i_len(a1, 10L);
16958     fooi_(&i__1);
16959 // FFEINTRIN_impLGE //
16960     L__1 = l_ge(a1, a2, 10L, 10L);
16961     fool_(&L__1);
16962 // FFEINTRIN_impLGT //
16963     L__1 = l_gt(a1, a2, 10L, 10L);
16964     fool_(&L__1);
16965 // FFEINTRIN_impLLE //
16966     L__1 = l_le(a1, a2, 10L, 10L);
16967     fool_(&L__1);
16968 // FFEINTRIN_impLLT //
16969     L__1 = l_lt(a1, a2, 10L, 10L);
16970     fool_(&L__1);
16971 // FFEINTRIN_impMAX0 //
16972     i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16973     fooi_(&i__1);
16974 // FFEINTRIN_impMAX1 //
16975     i__1 = (integer) (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16976     fooi_(&i__1);
16977 // FFEINTRIN_impMIN0 //
16978     i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16979     fooi_(&i__1);
16980 // FFEINTRIN_impMIN1 //
16981     i__1 = (integer) (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16982     fooi_(&i__1);
16983 // FFEINTRIN_impMOD //
16984     i__1 = i1 % i2;
16985     fooi_(&i__1);
16986 // FFEINTRIN_impNINT //
16987     i__1 = i_nint(&r1);
16988     fooi_(&i__1);
16989 // FFEINTRIN_impSIGN //
16990     r__1 = r_sign(&r1, &r2);
16991     foor_(&r__1);
16992 // FFEINTRIN_impSIN //
16993     r__1 = sin(r1);
16994     foor_(&r__1);
16995 // FFEINTRIN_impSINH //
16996     r__1 = sinh(r1);
16997     foor_(&r__1);
16998 // FFEINTRIN_impSQRT //
16999     r__1 = sqrt(r1);
17000     foor_(&r__1);
17001 // FFEINTRIN_impTAN //
17002     r__1 = tan(r1);
17003     foor_(&r__1);
17004 // FFEINTRIN_impTANH //
17005     r__1 = tanh(r1);
17006     foor_(&r__1);
17007 // FFEINTRIN_imp_CMPLX_C //
17008     r__1 = c1.r;
17009     r__2 = c2.r;
17010     q__1.r = r__1, q__1.i = r__2;
17011     fooc_(&q__1);
17012 // FFEINTRIN_imp_CMPLX_D //
17013     z__1.r = d1, z__1.i = d2;
17014     fooz_(&z__1);
17015 // FFEINTRIN_imp_CMPLX_I //
17016     r__1 = (real) i1;
17017     r__2 = (real) i2;
17018     q__1.r = r__1, q__1.i = r__2;
17019     fooc_(&q__1);
17020 // FFEINTRIN_imp_CMPLX_R //
17021     q__1.r = r1, q__1.i = r2;
17022     fooc_(&q__1);
17023 // FFEINTRIN_imp_DBLE_C //
17024     d__1 = (doublereal) c1.r;
17025     food_(&d__1);
17026 // FFEINTRIN_imp_DBLE_D //
17027     d__1 = d1;
17028     food_(&d__1);
17029 // FFEINTRIN_imp_DBLE_I //
17030     d__1 = (doublereal) i1;
17031     food_(&d__1);
17032 // FFEINTRIN_imp_DBLE_R //
17033     d__1 = (doublereal) r1;
17034     food_(&d__1);
17035 // FFEINTRIN_imp_INT_C //
17036     i__1 = (integer) c1.r;
17037     fooi_(&i__1);
17038 // FFEINTRIN_imp_INT_D //
17039     i__1 = (integer) d1;
17040     fooi_(&i__1);
17041 // FFEINTRIN_imp_INT_I //
17042     i__1 = i1;
17043     fooi_(&i__1);
17044 // FFEINTRIN_imp_INT_R //
17045     i__1 = (integer) r1;
17046     fooi_(&i__1);
17047 // FFEINTRIN_imp_REAL_C //
17048     r__1 = c1.r;
17049     foor_(&r__1);
17050 // FFEINTRIN_imp_REAL_D //
17051     r__1 = (real) d1;
17052     foor_(&r__1);
17053 // FFEINTRIN_imp_REAL_I //
17054     r__1 = (real) i1;
17055     foor_(&r__1);
17056 // FFEINTRIN_imp_REAL_R //
17057     r__1 = r1;
17058     foor_(&r__1);
17059
17060 // FFEINTRIN_imp_INT_D: //
17061
17062 // FFEINTRIN_specIDINT //
17063     i__1 = (integer) d1;
17064     fooi_(&i__1);
17065
17066 // FFEINTRIN_imp_INT_R: //
17067
17068 // FFEINTRIN_specIFIX //
17069     i__1 = (integer) r1;
17070     fooi_(&i__1);
17071 // FFEINTRIN_specINT //
17072     i__1 = (integer) r1;
17073     fooi_(&i__1);
17074
17075 // FFEINTRIN_imp_REAL_D: //
17076
17077 // FFEINTRIN_specSNGL //
17078     r__1 = (real) d1;
17079     foor_(&r__1);
17080
17081 // FFEINTRIN_imp_REAL_I: //
17082
17083 // FFEINTRIN_specFLOAT //
17084     r__1 = (real) i1;
17085     foor_(&r__1);
17086 // FFEINTRIN_specREAL //
17087     r__1 = (real) i1;
17088     foor_(&r__1);
17089
17090 } // MAIN__ //
17091
17092 -------- (end output file from f2c)
17093
17094 */