contrib/gcc-3.4/gcc/f/com.c

   1 /* com.c -- Implementation File (module.c template V1.0)
   2    Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003
   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 #include "flags.h"
  85 #include "real.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 #include "intl.h"
  94 #include "langhooks.h"
  95 #include "langhooks-def.h"
  96 #include "debug.h"
  97
  98 /* VMS-specific definitions */
  99 #ifdef VMS
 100 #include <descrip.h>
 101 #define O_RDONLY        0       /* Open arg for Read/Only  */
 102 #define O_WRONLY        1       /* Open arg for Write/Only */
 103 #define read(fd,buf,size)       VMS_read (fd,buf,size)
 104 #define write(fd,buf,size)      VMS_write (fd,buf,size)
 105 #define open(fname,mode,prot)   VMS_open (fname,mode,prot)
 106 #define fopen(fname,mode)       VMS_fopen (fname,mode)
 107 #define freopen(fname,mode,ofile) VMS_freopen (fname,mode,ofile)
 108 #define strncat(dst,src,cnt) VMS_strncat (dst,src,cnt)
 109 #define fstat(fd,stbuf)         VMS_fstat (fd,stbuf)
 110 static int VMS_fstat (), VMS_stat ();
 111 static char * VMS_strncat ();
 112 static int VMS_read ();
 113 static int VMS_write ();
 114 static int VMS_open ();
 115 static FILE * VMS_fopen ();
 116 static FILE * VMS_freopen ();
 117 static void hack_vms_include_specification ();
 118 typedef struct { unsigned :16, :16, :16; } vms_ino_t;
 119 #define ino_t vms_ino_t
 120 #define INCLUDE_LEN_FUDGE 10    /* leave room for VMS syntax conversion */
 121 #endif /* VMS */
 122
 123 #define FFECOM_DETERMINE_TYPES 1 /* for com.h */
 124 #include "com.h"
 125 #include "bad.h"
 126 #include "bld.h"
 127 #include "equiv.h"
 128 #include "expr.h"
 129 #include "implic.h"
 130 #include "info.h"
 131 #include "malloc.h"
 132 #include "src.h"
 133 #include "st.h"
 134 #include "storag.h"
 135 #include "symbol.h"
 136 #include "target.h"
 137 #include "top.h"
 138 #include "type.h"
 139
 140 /* Externals defined here.  */
 141
 142 /* Stream for reading from the input file.  */
 143 FILE *finput;
 144
 145 /* These definitions parallel those in c-decl.c so that code from that
 146    module can be used pretty much as is.  Much of these defs aren't
 147    otherwise used, i.e. by g77 code per se, except some of them are used
 148    to build some of them that are.  The ones that are global (i.e. not
 149    "static") are those that ste.c and such might use (directly
 150    or by using com macros that reference them in their definitions).  */
 151
 152 tree string_type_node;
 153
 154 /* The rest of these are inventions for g77, though there might be
 155    similar things in the C front end.  As they are found, these
 156    inventions should be renamed to be canonical.  Note that only
 157    the ones currently required to be global are so.  */
 158
 159 static GTY(()) tree ffecom_tree_fun_type_void;
 160
 161 tree ffecom_integer_type_node;  /* Abbrev for _tree_type[blah][blah]. */
 162 tree ffecom_integer_zero_node;  /* Like *_*_* with g77's integer type. */
 163 tree ffecom_integer_one_node;   /* " */
 164 tree ffecom_tree_type[FFEINFO_basictype][FFEINFO_kindtype];
 165
 166 /* _fun_type things are the f2c-specific versions.  For -fno-f2c,
 167    just use build_function_type and build_pointer_type on the
 168    appropriate _tree_type array element.  */
 169
 170 static GTY(()) tree ffecom_tree_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
 171 static GTY(()) tree
 172   ffecom_tree_ptr_to_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
 173 static GTY(()) tree ffecom_tree_subr_type;
 174 static GTY(()) tree ffecom_tree_ptr_to_subr_type;
 175 static GTY(()) tree ffecom_tree_blockdata_type;
 176
 177 static GTY(()) tree ffecom_tree_xargc_;
 178
 179 ffecomSymbol ffecom_symbol_null_
 180 =
 181 {
 182   NULL_TREE,
 183   NULL_TREE,
 184   NULL_TREE,
 185   NULL_TREE,
 186   false
 187 };
 188 ffeinfoKindtype ffecom_pointer_kind_ = FFEINFO_basictypeNONE;
 189 ffeinfoKindtype ffecom_label_kind_ = FFEINFO_basictypeNONE;
 190
 191 int ffecom_f2c_typecode_[FFEINFO_basictype][FFEINFO_kindtype];
 192 tree ffecom_f2c_integer_type_node;
 193 static GTY(()) tree ffecom_f2c_ptr_to_integer_type_node;
 194 tree ffecom_f2c_address_type_node;
 195 tree ffecom_f2c_real_type_node;
 196 static GTY(()) tree ffecom_f2c_ptr_to_real_type_node;
 197 tree ffecom_f2c_doublereal_type_node;
 198 tree ffecom_f2c_complex_type_node;
 199 tree ffecom_f2c_doublecomplex_type_node;
 200 tree ffecom_f2c_longint_type_node;
 201 tree ffecom_f2c_logical_type_node;
 202 tree ffecom_f2c_flag_type_node;
 203 tree ffecom_f2c_ftnlen_type_node;
 204 tree ffecom_f2c_ftnlen_zero_node;
 205 tree ffecom_f2c_ftnlen_one_node;
 206 tree ffecom_f2c_ftnlen_two_node;
 207 tree ffecom_f2c_ptr_to_ftnlen_type_node;
 208 tree ffecom_f2c_ftnint_type_node;
 209 tree ffecom_f2c_ptr_to_ftnint_type_node;
 210
 211 /* Simple definitions and enumerations. */
 212
 213 #ifndef FFECOM_sizeMAXSTACKITEM
 214 #define FFECOM_sizeMAXSTACKITEM 32*1024 /* Keep user-declared things
 215                                            larger than this # bytes
 216                                            off stack if possible. */
 217 #endif
 218
 219 /* For systems that have large enough stacks, they should define
 220    this to 0, and here, for ease of use later on, we just undefine
 221    it if it is 0.  */
 222
 223 #if FFECOM_sizeMAXSTACKITEM == 0
 224 #undef FFECOM_sizeMAXSTACKITEM
 225 #endif
 226
 227 typedef enum
 228   {
 229     FFECOM_rttypeVOID_,
 230     FFECOM_rttypeVOIDSTAR_,     /* C's `void *' type. */
 231     FFECOM_rttypeFTNINT_,       /* f2c's `ftnint' type. */
 232     FFECOM_rttypeINTEGER_,      /* f2c's `integer' type. */
 233     FFECOM_rttypeLONGINT_,      /* f2c's `longint' type. */
 234     FFECOM_rttypeLOGICAL_,      /* f2c's `logical' type. */
 235     FFECOM_rttypeREAL_F2C_,     /* f2c's `real' returned as `double'. */
 236     FFECOM_rttypeREAL_GNU_,     /* `real' returned as such. */
 237     FFECOM_rttypeCOMPLEX_F2C_,  /* f2c's `complex' returned via 1st arg. */
 238     FFECOM_rttypeCOMPLEX_GNU_,  /* f2c's `complex' returned directly. */
 239     FFECOM_rttypeDOUBLE_,       /* C's `double' type. */
 240     FFECOM_rttypeDOUBLEREAL_,   /* f2c's `doublereal' type. */
 241     FFECOM_rttypeDBLCMPLX_F2C_, /* f2c's `doublecomplex' returned via 1st arg. */
 242     FFECOM_rttypeDBLCMPLX_GNU_, /* f2c's `doublecomplex' returned directly. */
 243     FFECOM_rttypeCHARACTER_,    /* f2c `char *'/`ftnlen' pair. */
 244     FFECOM_rttype_
 245   } ffecomRttype_;
 246
 247 /* Internal typedefs. */
 248
 249 typedef struct _ffecom_concat_list_ ffecomConcatList_;
 250
 251 /* Private include files. */
 252
 253
 254 /* Internal structure definitions. */
 255
 256 struct _ffecom_concat_list_
 257   {
 258     ffebld *exprs;
 259     int count;
 260     int max;
 261     ffetargetCharacterSize minlen;
 262     ffetargetCharacterSize maxlen;
 263   };
 264
 265 /* Static functions (internal). */
 266
 267 static tree ffe_type_for_mode (enum machine_mode, int);
 268 static tree ffe_type_for_size (unsigned int, int);
 269 static tree ffe_unsigned_type (tree);
 270 static tree ffe_signed_type (tree);
 271 static tree ffe_signed_or_unsigned_type (int, tree);
 272 static bool ffe_mark_addressable (tree);
 273 static tree ffe_truthvalue_conversion (tree);
 274 static void ffecom_init_decl_processing (void);
 275 static tree ffecom_arglist_expr_ (const char *argstring, ffebld args);
 276 static tree ffecom_widest_expr_type_ (ffebld list);
 277 static bool ffecom_overlap_ (tree dest_decl, tree dest_offset,
 278                              tree dest_size, tree source_tree,
 279                              ffebld source, bool scalar_arg);
 280 static bool ffecom_args_overlapping_ (tree dest_tree, ffebld dest,
 281                                       tree args, tree callee_commons,
 282                                       bool scalar_args);
 283 static tree ffecom_build_f2c_string_ (int i, const char *s);
 284 static tree ffecom_call_ (tree fn, ffeinfoKindtype kt,
 285                           bool is_f2c_complex, tree type,
 286                           tree args, tree dest_tree,
 287                           ffebld dest, bool *dest_used,
 288                           tree callee_commons, bool scalar_args, tree hook);
 289 static tree ffecom_call_binop_ (tree fn, ffeinfoKindtype kt,
 290                                 bool is_f2c_complex, tree type,
 291                                 ffebld left, ffebld right,
 292                                 tree dest_tree, ffebld dest,
 293                                 bool *dest_used, tree callee_commons,
 294                                 bool scalar_args, bool ref, tree hook);
 295 static void ffecom_char_args_x_ (tree *xitem, tree *length,
 296                                  ffebld expr, bool with_null);
 297 static tree ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy);
 298 static tree ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s);
 299 static ffecomConcatList_
 300   ffecom_concat_list_gather_ (ffecomConcatList_ catlist,
 301                               ffebld expr,
 302                               ffetargetCharacterSize max);
 303 static void ffecom_concat_list_kill_ (ffecomConcatList_ catlist);
 304 static ffecomConcatList_ ffecom_concat_list_new_ (ffebld expr,
 305                                                 ffetargetCharacterSize max);
 306 static void ffecom_debug_kludge_ (tree aggr, const char *aggr_type,
 307                                   ffesymbol member, tree member_type,
 308                                   ffetargetOffset offset);
 309 static void ffecom_do_entry_ (ffesymbol fn, int entrynum);
 310 static tree ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
 311                           bool *dest_used, bool assignp, bool widenp);
 312 static tree ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
 313                                     ffebld dest, bool *dest_used);
 314 static tree ffecom_expr_power_integer_ (ffebld expr);
 315 static void ffecom_expr_transform_ (ffebld expr);
 316 static void ffecom_f2c_make_type_ (tree *type, int tcode, const char *name);
 317 static void ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
 318                                       int code);
 319 static ffeglobal ffecom_finish_global_ (ffeglobal global);
 320 static ffesymbol ffecom_finish_symbol_transform_ (ffesymbol s);
 321 static tree ffecom_get_appended_identifier_ (char us, const char *text);
 322 static tree ffecom_get_external_identifier_ (ffesymbol s);
 323 static tree ffecom_get_identifier_ (const char *text);
 324 static tree ffecom_gen_sfuncdef_ (ffesymbol s,
 325                                   ffeinfoBasictype bt,
 326                                   ffeinfoKindtype kt);
 327 static const char *ffecom_gfrt_args_ (ffecomGfrt ix);
 328 static tree ffecom_gfrt_tree_ (ffecomGfrt ix);
 329 static tree ffecom_init_zero_ (tree decl);
 330 static tree ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
 331                                      tree *maybe_tree);
 332 static tree ffecom_intrinsic_len_ (ffebld expr);
 333 static void ffecom_let_char_ (tree dest_tree,
 334                               tree dest_length,
 335                               ffetargetCharacterSize dest_size,
 336                               ffebld source);
 337 static void ffecom_make_gfrt_ (ffecomGfrt ix);
 338 static void ffecom_member_phase1_ (ffestorag mst, ffestorag st);
 339 static void ffecom_member_phase2_ (ffestorag mst, ffestorag st);
 340 static void ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size,
 341                                       ffebld source);
 342 static void ffecom_push_dummy_decls_ (ffebld dumlist,
 343                                       bool stmtfunc);
 344 static void ffecom_start_progunit_ (void);
 345 static ffesymbol ffecom_sym_transform_ (ffesymbol s);
 346 static ffesymbol ffecom_sym_transform_assign_ (ffesymbol s);
 347 static void ffecom_transform_common_ (ffesymbol s);
 348 static void ffecom_transform_equiv_ (ffestorag st);
 349 static tree ffecom_transform_namelist_ (ffesymbol s);
 350 static void ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
 351                                        tree t);
 352 static void ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
 353                                        tree *size, tree tree);
 354 static tree ffecom_tree_divide_ (tree tree_type, tree left, tree right,
 355                                  tree dest_tree, ffebld dest,
 356                                  bool *dest_used, tree hook);
 357 static tree ffecom_type_localvar_ (ffesymbol s,
 358                                    ffeinfoBasictype bt,
 359                                    ffeinfoKindtype kt);
 360 static tree ffecom_type_namelist_ (void);
 361 static tree ffecom_type_vardesc_ (void);
 362 static tree ffecom_vardesc_ (ffebld expr);
 363 static tree ffecom_vardesc_array_ (ffesymbol s);
 364 static tree ffecom_vardesc_dims_ (ffesymbol s);
 365 static tree ffecom_convert_narrow_ (tree type, tree expr);
 366 static tree ffecom_convert_widen_ (tree type, tree expr);
 367
 368 /* These are static functions that parallel those found in the C front
 369    end and thus have the same names.  */
 370
 371 static tree bison_rule_compstmt_ (void);
 372 static void bison_rule_pushlevel_ (void);
 373 static void delete_block (tree block);
 374 static int duplicate_decls (tree newdecl, tree olddecl);
 375 static void finish_decl (tree decl, tree init, bool is_top_level);
 376 static void finish_function (int nested);
 377 static const char *ffe_printable_name (tree decl, int v);
 378 static void ffe_print_error_function (diagnostic_context *, const char *);
 379 static tree lookup_name_current_level (tree name);
 380 static struct f_binding_level *make_binding_level (void);
 381 static void pop_f_function_context (void);
 382 static void push_f_function_context (void);
 383 static void push_parm_decl (tree parm);
 384 static tree pushdecl_top_level (tree decl);
 385 static int kept_level_p (void);
 386 static tree storedecls (tree decls);
 387 static void store_parm_decls (int is_main_program);
 388 static tree start_decl (tree decl, bool is_top_level);
 389 static void start_function (tree name, tree type, int nested, int public);
 390 static void ffecom_file_ (const char *name);
 391 static void ffecom_close_include_ (FILE *f);
 392 static FILE *ffecom_open_include_ (char *name, ffewhereLine l,
 393                                    ffewhereColumn c);
 394
 395 /* Static objects accessed by functions in this module. */
 396
 397 static ffesymbol ffecom_primary_entry_ = NULL;
 398 static ffesymbol ffecom_nested_entry_ = NULL;
 399 static ffeinfoKind ffecom_primary_entry_kind_;
 400 static bool ffecom_primary_entry_is_proc_;
 401 static GTY(()) tree ffecom_outer_function_decl_;
 402 static GTY(()) tree ffecom_previous_function_decl_;
 403 static GTY(()) tree ffecom_which_entrypoint_decl_;
 404 static GTY(()) tree ffecom_float_zero_;
 405 static GTY(()) tree ffecom_float_half_;
 406 static GTY(()) tree ffecom_double_zero_;
 407 static GTY(()) tree ffecom_double_half_;
 408 static GTY(()) tree ffecom_func_result_;/* For functions. */
 409 static GTY(()) tree ffecom_func_length_;/* For CHARACTER fns. */
 410 static ffebld ffecom_list_blockdata_;
 411 static ffebld ffecom_list_common_;
 412 static ffebld ffecom_master_arglist_;
 413 static ffeinfoBasictype ffecom_master_bt_;
 414 static ffeinfoKindtype ffecom_master_kt_;
 415 static ffetargetCharacterSize ffecom_master_size_;
 416 static int ffecom_num_fns_ = 0;
 417 static int ffecom_num_entrypoints_ = 0;
 418 static bool ffecom_is_altreturning_ = FALSE;
 419 static GTY(()) tree ffecom_multi_type_node_;
 420 static GTY(()) tree ffecom_multi_retval_;
 421 static GTY(()) tree
 422   ffecom_multi_fields_[FFEINFO_basictype][FFEINFO_kindtype];
 423 static bool ffecom_member_namelisted_;  /* _member_phase1_ namelisted? */
 424 static bool ffecom_doing_entry_ = FALSE;
 425 static bool ffecom_transform_only_dummies_ = FALSE;
 426 static int ffecom_typesize_pointer_;
 427 static int ffecom_typesize_integer1_;
 428
 429 /* Holds pointer-to-function expressions.  */
 430
 431 static GTY(()) tree ffecom_gfrt_[FFECOM_gfrt];
 432
 433 /* Holds the external names of the functions.  */
 434
 435 static const char *const ffecom_gfrt_name_[FFECOM_gfrt]
 436 =
 437 {
 438 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NAME,
 439 #include "com-rt.def"
 440 #undef DEFGFRT
 441 };
 442
 443 /* Whether the function returns.  */
 444
 445 static const bool ffecom_gfrt_volatile_[FFECOM_gfrt]
 446 =
 447 {
 448 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) VOLATILE,
 449 #include "com-rt.def"
 450 #undef DEFGFRT
 451 };
 452
 453 /* Whether the function returns type complex.  */
 454
 455 static const bool ffecom_gfrt_complex_[FFECOM_gfrt]
 456 =
 457 {
 458 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) COMPLEX,
 459 #include "com-rt.def"
 460 #undef DEFGFRT
 461 };
 462
 463 /* Whether the function is const
 464    (i.e., has no side effects and only depends on its arguments).  */
 465
 466 static const bool ffecom_gfrt_const_[FFECOM_gfrt]
 467 =
 468 {
 469 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) CONST,
 470 #include "com-rt.def"
 471 #undef DEFGFRT
 472 };
 473
 474 /* Type code for the function return value.  */
 475
 476 static const ffecomRttype_ ffecom_gfrt_type_[FFECOM_gfrt]
 477 =
 478 {
 479 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) TYPE,
 480 #include "com-rt.def"
 481 #undef DEFGFRT
 482 };
 483
 484 /* String of codes for the function's arguments.  */
 485
 486 static const char *const ffecom_gfrt_argstring_[FFECOM_gfrt]
 487 =
 488 {
 489 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) ARGS,
 490 #include "com-rt.def"
 491 #undef DEFGFRT
 492 };
 493
 494 /* Internal macros. */
 495
 496 /* We let tm.h override the types used here, to handle trivial differences
 497    such as the choice of unsigned int or long unsigned int for size_t.
 498    When machines start needing nontrivial differences in the size type,
 499    it would be best to do something here to figure out automatically
 500    from other information what type to use.  */
 501
 502 #ifndef SIZE_TYPE
 503 #define SIZE_TYPE "long unsigned int"
 504 #endif
 505
 506 #define ffecom_concat_list_count_(catlist) ((catlist).count)
 507 #define ffecom_concat_list_expr_(catlist,i) ((catlist).exprs[(i)])
 508 #define ffecom_concat_list_maxlen_(catlist) ((catlist).maxlen)
 509 #define ffecom_concat_list_minlen_(catlist) ((catlist).minlen)
 510
 511 #define ffecom_char_args_(i,l,e) ffecom_char_args_x_((i),(l),(e),FALSE)
 512 #define ffecom_char_args_with_null_(i,l,e) ffecom_char_args_x_((i),(l),(e),TRUE)
 513
 514 /* For each binding contour we allocate a binding_level structure
 515  * which records the names defined in that contour.
 516  * Contours include:
 517  *  0) the global one
 518  *  1) one for each function definition,
 519  *     where internal declarations of the parameters appear.
 520  *
 521  * The current meaning of a name can be found by searching the levels from
 522  * the current one out to the global one.
 523  */
 524
 525 /* Note that the information in the `names' component of the global contour
 526    is duplicated in the IDENTIFIER_GLOBAL_VALUEs of all identifiers.  */
 527
 528 struct f_binding_level GTY(())
 529   {
 530     /* A chain of _DECL nodes for all variables, constants, functions,
 531        and typedef types.  These are in the reverse of the order supplied.
 532      */
 533     tree names;
 534
 535     /* For each level (except not the global one),
 536        a chain of BLOCK nodes for all the levels
 537        that were entered and exited one level down.  */
 538     tree blocks;
 539
 540     /* The BLOCK node for this level, if one has been preallocated.
 541        If 0, the BLOCK is allocated (if needed) when the level is popped.  */
 542     tree this_block;
 543
 544     /* The binding level which this one is contained in (inherits from).  */
 545     struct f_binding_level *level_chain;
 546
 547     /* 0: no ffecom_prepare_* functions called at this level yet;
 548        1: ffecom_prepare* functions called, except not ffecom_prepare_end;
 549        2: ffecom_prepare_end called.  */
 550     int prep_state;
 551   };
 552
 553 #define NULL_BINDING_LEVEL (struct f_binding_level *) NULL
 554
 555 /* The binding level currently in effect.  */
 556
 557 static GTY(()) struct f_binding_level *current_binding_level;
 558
 559 /* A chain of binding_level structures awaiting reuse.  */
 560
 561 static GTY((deletable (""))) struct f_binding_level *free_binding_level;
 562
 563 /* The outermost binding level, for names of file scope.
 564    This is created when the compiler is started and exists
 565    through the entire run.  */
 566
 567 static struct f_binding_level *global_binding_level;
 568
 569 /* Binding level structures are initialized by copying this one.  */
 570
 571 static const struct f_binding_level clear_binding_level
 572 =
 573 {NULL, NULL, NULL, NULL_BINDING_LEVEL, 0};
 574
 575 /* Language-dependent contents of an identifier.  */
 576
 577 struct lang_identifier GTY(())
 578 {
 579   struct tree_identifier common;
 580   tree global_value;
 581   tree local_value;
 582   tree label_value;
 583   bool invented;
 584 };
 585
 586 /* Macros for access to language-specific slots in an identifier.  */
 587 /* Each of these slots contains a DECL node or null.  */
 588
 589 /* This represents the value which the identifier has in the
 590    file-scope namespace.  */
 591 #define IDENTIFIER_GLOBAL_VALUE(NODE)   \
 592   (((struct lang_identifier *)(NODE))->global_value)
 593 /* This represents the value which the identifier has in the current
 594    scope.  */
 595 #define IDENTIFIER_LOCAL_VALUE(NODE)    \
 596   (((struct lang_identifier *)(NODE))->local_value)
 597 /* This represents the value which the identifier has as a label in
 598    the current label scope.  */
 599 #define IDENTIFIER_LABEL_VALUE(NODE)    \
 600   (((struct lang_identifier *)(NODE))->label_value)
 601 /* This is nonzero if the identifier was "made up" by g77 code.  */
 602 #define IDENTIFIER_INVENTED(NODE)       \
 603   (((struct lang_identifier *)(NODE))->invented)
 604
 605 /* The resulting tree type.  */
 606 union lang_tree_node
 607   GTY((desc ("TREE_CODE (&%h.generic) == IDENTIFIER_NODE"),
 608        chain_next ("(union lang_tree_node *)TREE_CHAIN (&%h.generic)")))
 609 {
 610   union tree_node GTY ((tag ("0"),
 611                         desc ("tree_node_structure (&%h)")))
 612     generic;
 613   struct lang_identifier GTY ((tag ("1"))) identifier;
 614 };
 615
 616 /* Fortran doesn't use either of these.  */
 617 struct lang_decl GTY(())
 618 {
 619 };
 620 struct lang_type GTY(())
 621 {
 622 };
 623
 624 /* In identifiers, C uses the following fields in a special way:
 625    TREE_PUBLIC        to record that there was a previous local extern decl.
 626    TREE_USED          to record that such a decl was used.
 627    TREE_ADDRESSABLE   to record that the address of such a decl was used.  */
 628
 629 /* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function
 630    that have names.  Here so we can clear out their names' definitions
 631    at the end of the function.  */
 632
 633 static GTY(()) tree named_labels;
 634
 635 /* A list of LABEL_DECLs from outer contexts that are currently shadowed.  */
 636
 637 static GTY(()) tree shadowed_labels;
 638 \f
 639 /* Return the subscript expression, modified to do range-checking.
 640
 641    `array' is the array type 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    `item' is the array decl or NULL_TREE.
 646 */
 647
 648 static tree
 649 ffecom_subscript_check_ (tree array, tree element, int dim, int total_dims,
 650                          const char *array_name, tree item)
 651 {
 652   tree low = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
 653   tree high = TYPE_MAX_VALUE (TYPE_DOMAIN (array));
 654   tree cond;
 655   tree die;
 656   tree args;
 657
 658   if (element == error_mark_node)
 659     return element;
 660
 661   if (TREE_TYPE (low) != TREE_TYPE (element))
 662     {
 663       if (TYPE_PRECISION (TREE_TYPE (low))
 664           > TYPE_PRECISION (TREE_TYPE (element)))
 665         element = convert (TREE_TYPE (low), element);
 666       else
 667         {
 668           low = convert (TREE_TYPE (element), low);
 669           if (high)
 670             high = convert (TREE_TYPE (element), high);
 671         }
 672     }
 673
 674   element = ffecom_save_tree (element);
 675   if (total_dims == 0)
 676     {
 677       /* Special handling for substring range checks.  Fortran allows the
 678          end subscript < begin subscript, which means that expressions like
 679        string(1:0) are valid (and yield a null string).  In view of this,
 680        enforce two simpler conditions:
 681           1) element<=high for end-substring;
 682           2) element>=low for start-substring.
 683        Run-time character movement will enforce remaining conditions.
 684
 685        More complicated checks would be better, but present structure only
 686        provides one index element at a time, so it is not possible to
 687        enforce a check of both i and j in string(i:j).  If it were, the
 688        complete set of rules would read,
 689          if ( ((j<i) && ((low<=i<=high) || (low<=j<=high))) ||
 690               ((low<=i<=high) && (low<=j<=high)) )
 691            ok ;
 692          else
 693            range error ;
 694       */
 695       if (dim)
 696         cond = ffecom_2 (LE_EXPR, integer_type_node, element, high);
 697       else
 698         cond = ffecom_2 (LE_EXPR, integer_type_node, low, element);
 699     }
 700   else
 701     {
 702       /* Array reference substring range checking.  */
 703
 704       cond = ffecom_2 (LE_EXPR, integer_type_node,
 705                      low,
 706                      element);
 707       if (high)
 708         {
 709           cond = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
 710                          cond,
 711                          ffecom_2 (LE_EXPR, integer_type_node,
 712                                    element,
 713                                    high));
 714         }
 715     }
 716
 717   /* If the array index is safe at compile-time, return element.  */
 718   if (integer_nonzerop (cond))
 719     return element;
 720
 721   {
 722     int len;
 723     char *proc;
 724     char *var;
 725     tree arg3;
 726     tree arg2;
 727     tree arg1;
 728     tree arg4;
 729
 730     switch (total_dims)
 731       {
 732       case 0:
 733         var = concat (array_name, "[", (dim ? "end" : "start"),
 734                       "-substring]", NULL);
 735         len = strlen (var) + 1;
 736         arg1 = build_string (len, var);
 737         free (var);
 738         break;
 739
 740       case 1:
 741         len = strlen (array_name) + 1;
 742         arg1 = build_string (len, array_name);
 743         break;
 744
 745       default:
 746         var = xmalloc (strlen (array_name) + 40);
 747         sprintf (var, "%s[subscript-%d-of-%d]",
 748                  array_name,
 749                  dim + 1, total_dims);
 750         len = strlen (var) + 1;
 751         arg1 = build_string (len, var);
 752         free (var);
 753         break;
 754       }
 755
 756     TREE_TYPE (arg1)
 757       = build_type_variant (build_array_type (char_type_node,
 758                                               build_range_type
 759                                               (integer_type_node,
 760                                                integer_one_node,
 761                                                build_int_2 (len, 0))),
 762                             1, 0);
 763     TREE_CONSTANT (arg1) = 1;
 764     TREE_STATIC (arg1) = 1;
 765     arg1 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg1)),
 766                      arg1);
 767
 768     /* s_rnge adds one to the element to print it, so bias against
 769        that -- want to print a faithful *subscript* value.  */
 770     arg2 = convert (ffecom_f2c_ftnint_type_node,
 771                     ffecom_2 (MINUS_EXPR,
 772                               TREE_TYPE (element),
 773                               element,
 774                               convert (TREE_TYPE (element),
 775                                        integer_one_node)));
 776
 777     proc = concat (input_filename, "/",
 778                    IDENTIFIER_POINTER (DECL_NAME (current_function_decl)),
 779                    NULL);
 780     len = strlen (proc) + 1;
 781     arg3 = build_string (len, proc);
 782
 783     free (proc);
 784
 785     TREE_TYPE (arg3)
 786       = build_type_variant (build_array_type (char_type_node,
 787                                               build_range_type
 788                                               (integer_type_node,
 789                                                integer_one_node,
 790                                                build_int_2 (len, 0))),
 791                             1, 0);
 792     TREE_CONSTANT (arg3) = 1;
 793     TREE_STATIC (arg3) = 1;
 794     arg3 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg3)),
 795                      arg3);
 796
 797     arg4 = convert (ffecom_f2c_ftnint_type_node,
 798                     build_int_2 (input_line, 0));
 799
 800     arg1 = build_tree_list (NULL_TREE, arg1);
 801     arg2 = build_tree_list (NULL_TREE, arg2);
 802     arg3 = build_tree_list (NULL_TREE, arg3);
 803     arg4 = build_tree_list (NULL_TREE, arg4);
 804     TREE_CHAIN (arg3) = arg4;
 805     TREE_CHAIN (arg2) = arg3;
 806     TREE_CHAIN (arg1) = arg2;
 807
 808     args = arg1;
 809   }
 810   die = ffecom_call_gfrt (FFECOM_gfrtRANGE,
 811                           args, NULL_TREE);
 812   TREE_SIDE_EFFECTS (die) = 1;
 813   die = convert (void_type_node, die);
 814
 815   if (integer_zerop (cond) && item)
 816     ffe_mark_addressable (item);
 817
 818   return ffecom_3 (COND_EXPR, TREE_TYPE (element), cond, element, die);
 819 }
 820
 821 /* Return the computed element of an array reference.
 822
 823    `item' is NULL_TREE, or the transformed pointer to the array.
 824    `expr' is the original opARRAYREF expression, which is transformed
 825      if `item' is NULL_TREE.
 826    `want_ptr' is nonzero if a pointer to the element, instead of
 827      the element itself, is to be returned.  */
 828
 829 static tree
 830 ffecom_arrayref_ (tree item, ffebld expr, int want_ptr)
 831 {
 832   ffebld dims[FFECOM_dimensionsMAX];
 833   int i;
 834   int total_dims;
 835   int flatten = ffe_is_flatten_arrays ();
 836   int need_ptr;
 837   tree array;
 838   tree element;
 839   tree tree_type;
 840   tree tree_type_x;
 841   const char *array_name;
 842   ffetype type;
 843   ffebld list;
 844
 845   if (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER)
 846     array_name = ffesymbol_text (ffebld_symter (ffebld_left (expr)));
 847   else
 848     array_name = "[expr?]";
 849
 850   /* Build up ARRAY_REFs in reverse order (since we're column major
 851      here in Fortran land). */
 852
 853   for (i = 0, list = ffebld_right (expr);
 854        list != NULL;
 855        ++i, list = ffebld_trail (list))
 856     {
 857       dims[i] = ffebld_head (list);
 858       type = ffeinfo_type (ffebld_basictype (dims[i]),
 859                            ffebld_kindtype (dims[i]));
 860       if (! flatten
 861           && ffecom_typesize_pointer_ > ffecom_typesize_integer1_
 862           && ffetype_size (type) > ffecom_typesize_integer1_)
 863         /* E.g. ARRAY(INDEX), given INTEGER*8 INDEX, on a system with 64-bit
 864            pointers and 32-bit integers.  Do the full 64-bit pointer
 865            arithmetic, for codes using arrays for nonstandard heap-like
 866            work.  */
 867         flatten = 1;
 868     }
 869
 870   total_dims = i;
 871
 872   need_ptr = want_ptr || flatten;
 873
 874   if (! item)
 875     {
 876       if (need_ptr)
 877         item = ffecom_ptr_to_expr (ffebld_left (expr));
 878       else
 879         item = ffecom_expr (ffebld_left (expr));
 880
 881       if (item == error_mark_node)
 882         return item;
 883
 884       if (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereFLEETING
 885           && ! ffe_mark_addressable (item))
 886         return error_mark_node;
 887     }
 888
 889   if (item == error_mark_node)
 890     return item;
 891
 892   if (need_ptr)
 893     {
 894       tree min;
 895
 896       for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
 897            i >= 0;
 898            --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array)))
 899         {
 900           min = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
 901           element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
 902           if (flag_bounds_check)
 903             element = ffecom_subscript_check_ (array, element, i, total_dims,
 904                                                array_name, item);
 905           if (element == error_mark_node)
 906             return element;
 907
 908           /* Widen integral arithmetic as desired while preserving
 909              signedness.  */
 910           tree_type = TREE_TYPE (element);
 911           tree_type_x = tree_type;
 912           if (tree_type
 913               && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
 914               && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
 915             tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
 916
 917           if (TREE_TYPE (min) != tree_type_x)
 918             min = convert (tree_type_x, min);
 919           if (TREE_TYPE (element) != tree_type_x)
 920             element = convert (tree_type_x, element);
 921
 922           item = ffecom_2 (PLUS_EXPR,
 923                            build_pointer_type (TREE_TYPE (array)),
 924                            item,
 925                            size_binop (MULT_EXPR,
 926                                        size_in_bytes (TREE_TYPE (array)),
 927                                        convert (sizetype,
 928                                                 fold (build (MINUS_EXPR,
 929                                                              tree_type_x,
 930                                                              element, min)))));
 931         }
 932       if (! want_ptr)
 933         {
 934           item = ffecom_1 (INDIRECT_REF,
 935                            TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
 936                            item);
 937         }
 938     }
 939   else
 940     {
 941       for (--i;
 942            i >= 0;
 943            --i)
 944         {
 945           array = TYPE_MAIN_VARIANT (TREE_TYPE (item));
 946
 947           element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
 948           if (flag_bounds_check)
 949             element = ffecom_subscript_check_ (array, element, i, total_dims,
 950                                                array_name, item);
 951           if (element == error_mark_node)
 952             return element;
 953
 954           /* Widen integral arithmetic as desired while preserving
 955              signedness.  */
 956           tree_type = TREE_TYPE (element);
 957           tree_type_x = tree_type;
 958           if (tree_type
 959               && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
 960               && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
 961             tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
 962
 963           element = convert (tree_type_x, element);
 964
 965           item = ffecom_2 (ARRAY_REF,
 966                            TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
 967                            item,
 968                            element);
 969         }
 970     }
 971
 972   return item;
 973 }
 974
 975 /* This is like gcc's stabilize_reference -- in fact, most of the code
 976    comes from that -- but it handles the situation where the reference
 977    is going to have its subparts picked at, and it shouldn't change
 978    (or trigger extra invocations of functions in the subtrees) due to
 979    this.  save_expr is a bit overzealous, because we don't need the
 980    entire thing calculated and saved like a temp.  So, for DECLs, no
 981    change is needed, because these are stable aggregates, and ARRAY_REF
 982    and such might well be stable too, but for things like calculations,
 983    we do need to calculate a snapshot of a value before picking at it.  */
 984
 985 static tree
 986 ffecom_stabilize_aggregate_ (tree ref)
 987 {
 988   tree result;
 989   enum tree_code code = TREE_CODE (ref);
 990
 991   switch (code)
 992     {
 993     case VAR_DECL:
 994     case PARM_DECL:
 995     case RESULT_DECL:
 996       /* No action is needed in this case.  */
 997       return ref;
 998
 999     case NOP_EXPR:
1000     case CONVERT_EXPR:
1001     case FLOAT_EXPR:
1002     case FIX_TRUNC_EXPR:
1003     case FIX_FLOOR_EXPR:
1004     case FIX_ROUND_EXPR:
1005     case FIX_CEIL_EXPR:
1006       result = build_nt (code, stabilize_reference (TREE_OPERAND (ref, 0)));
1007       break;
1008
1009     case INDIRECT_REF:
1010       result = build_nt (INDIRECT_REF,
1011                          stabilize_reference_1 (TREE_OPERAND (ref, 0)));
1012       break;
1013
1014     case COMPONENT_REF:
1015       result = build_nt (COMPONENT_REF,
1016                          stabilize_reference (TREE_OPERAND (ref, 0)),
1017                          TREE_OPERAND (ref, 1));
1018       break;
1019
1020     case BIT_FIELD_REF:
1021       result = build_nt (BIT_FIELD_REF,
1022                          stabilize_reference (TREE_OPERAND (ref, 0)),
1023                          stabilize_reference_1 (TREE_OPERAND (ref, 1)),
1024                          stabilize_reference_1 (TREE_OPERAND (ref, 2)));
1025       break;
1026
1027     case ARRAY_REF:
1028       result = build_nt (ARRAY_REF,
1029                          stabilize_reference (TREE_OPERAND (ref, 0)),
1030                          stabilize_reference_1 (TREE_OPERAND (ref, 1)));
1031       break;
1032
1033     case COMPOUND_EXPR:
1034       result = build_nt (COMPOUND_EXPR,
1035                          stabilize_reference_1 (TREE_OPERAND (ref, 0)),
1036                          stabilize_reference (TREE_OPERAND (ref, 1)));
1037       break;
1038
1039     case RTL_EXPR:
1040       abort ();
1041
1042
1043     default:
1044       return save_expr (ref);
1045
1046     case ERROR_MARK:
1047       return error_mark_node;
1048     }
1049
1050   TREE_TYPE (result) = TREE_TYPE (ref);
1051   TREE_READONLY (result) = TREE_READONLY (ref);
1052   TREE_SIDE_EFFECTS (result) = TREE_SIDE_EFFECTS (ref);
1053   TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref);
1054
1055   return result;
1056 }
1057
1058 /* A rip-off of gcc's convert.c convert_to_complex function,
1059    reworked to handle complex implemented as C structures
1060    (RECORD_TYPE with two fields, real and imaginary `r' and `i').  */
1061
1062 static tree
1063 ffecom_convert_to_complex_ (tree type, tree expr)
1064 {
1065   register enum tree_code form = TREE_CODE (TREE_TYPE (expr));
1066   tree subtype;
1067
1068   assert (TREE_CODE (type) == RECORD_TYPE);
1069
1070   subtype = TREE_TYPE (TYPE_FIELDS (type));
1071
1072   if (form == REAL_TYPE || form == INTEGER_TYPE || form == ENUMERAL_TYPE)
1073     {
1074       expr = convert (subtype, expr);
1075       return ffecom_2 (COMPLEX_EXPR, type, expr,
1076                        convert (subtype, integer_zero_node));
1077     }
1078
1079   if (form == RECORD_TYPE)
1080     {
1081       tree elt_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr)));
1082       if (TYPE_MAIN_VARIANT (elt_type) == TYPE_MAIN_VARIANT (subtype))
1083         return expr;
1084       else
1085         {
1086           expr = save_expr (expr);
1087           return ffecom_2 (COMPLEX_EXPR,
1088                            type,
1089                            convert (subtype,
1090                                     ffecom_1 (REALPART_EXPR,
1091                                               TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1092                                               expr)),
1093                            convert (subtype,
1094                                     ffecom_1 (IMAGPART_EXPR,
1095                                               TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1096                                               expr)));
1097         }
1098     }
1099
1100   if (form == POINTER_TYPE || form == REFERENCE_TYPE)
1101     error ("pointer value used where a complex was expected");
1102   else
1103     error ("aggregate value used where a complex was expected");
1104
1105   return ffecom_2 (COMPLEX_EXPR, type,
1106                    convert (subtype, integer_zero_node),
1107                    convert (subtype, integer_zero_node));
1108 }
1109
1110 /* Like gcc's convert(), but crashes if widening might happen.  */
1111
1112 static tree
1113 ffecom_convert_narrow_ (tree type, tree expr)
1114 {
1115   register tree e = expr;
1116   register enum tree_code code = TREE_CODE (type);
1117
1118   if (type == TREE_TYPE (e)
1119       || TREE_CODE (e) == ERROR_MARK)
1120     return e;
1121   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1122     return fold (build1 (NOP_EXPR, type, e));
1123   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1124       || code == ERROR_MARK)
1125     return error_mark_node;
1126   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1127     {
1128       assert ("void value not ignored as it ought to be" == NULL);
1129       return error_mark_node;
1130     }
1131   assert (code != VOID_TYPE);
1132   if ((code != RECORD_TYPE)
1133       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1134     assert ("converting COMPLEX to REAL" == NULL);
1135   assert (code != ENUMERAL_TYPE);
1136   if (code == INTEGER_TYPE)
1137     {
1138       assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1139                && TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)))
1140               || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1141                   && (TYPE_PRECISION (type)
1142                       == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1143       return fold (convert_to_integer (type, e));
1144     }
1145   if (code == POINTER_TYPE)
1146     {
1147       assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1148       return fold (convert_to_pointer (type, e));
1149     }
1150   if (code == REAL_TYPE)
1151     {
1152       assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1153       assert (TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)));
1154       return fold (convert_to_real (type, e));
1155     }
1156   if (code == COMPLEX_TYPE)
1157     {
1158       assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1159       assert (TYPE_PRECISION (TREE_TYPE (type)) <= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1160       return fold (convert_to_complex (type, e));
1161     }
1162   if (code == RECORD_TYPE)
1163     {
1164       assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1165       /* Check that at least the first field name agrees.  */
1166       assert (DECL_NAME (TYPE_FIELDS (type))
1167               == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1168       assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1169               <= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1170       if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1171           == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1172         return e;
1173       return fold (ffecom_convert_to_complex_ (type, e));
1174     }
1175
1176   assert ("conversion to non-scalar type requested" == NULL);
1177   return error_mark_node;
1178 }
1179
1180 /* Like gcc's convert(), but crashes if narrowing might happen.  */
1181
1182 static tree
1183 ffecom_convert_widen_ (tree type, tree expr)
1184 {
1185   register tree e = expr;
1186   register enum tree_code code = TREE_CODE (type);
1187
1188   if (type == TREE_TYPE (e)
1189       || TREE_CODE (e) == ERROR_MARK)
1190     return e;
1191   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1192     return fold (build1 (NOP_EXPR, type, e));
1193   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1194       || code == ERROR_MARK)
1195     return error_mark_node;
1196   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1197     {
1198       assert ("void value not ignored as it ought to be" == NULL);
1199       return error_mark_node;
1200     }
1201   assert (code != VOID_TYPE);
1202   if ((code != RECORD_TYPE)
1203       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1204     assert ("narrowing COMPLEX to REAL" == NULL);
1205   assert (code != ENUMERAL_TYPE);
1206   if (code == INTEGER_TYPE)
1207     {
1208       assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1209                && TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)))
1210               || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1211                   && (TYPE_PRECISION (type)
1212                       == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1213       return fold (convert_to_integer (type, e));
1214     }
1215   if (code == POINTER_TYPE)
1216     {
1217       assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1218       return fold (convert_to_pointer (type, e));
1219     }
1220   if (code == REAL_TYPE)
1221     {
1222       assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1223       assert (TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)));
1224       return fold (convert_to_real (type, e));
1225     }
1226   if (code == COMPLEX_TYPE)
1227     {
1228       assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1229       assert (TYPE_PRECISION (TREE_TYPE (type)) >= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1230       return fold (convert_to_complex (type, e));
1231     }
1232   if (code == RECORD_TYPE)
1233     {
1234       assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1235       /* Check that at least the first field name agrees.  */
1236       assert (DECL_NAME (TYPE_FIELDS (type))
1237               == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1238       assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1239               >= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1240       if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1241           == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1242         return e;
1243       return fold (ffecom_convert_to_complex_ (type, e));
1244     }
1245
1246   assert ("conversion to non-scalar type requested" == NULL);
1247   return error_mark_node;
1248 }
1249
1250 /* Handles making a COMPLEX type, either the standard
1251    (but buggy?) gbe way, or the safer (but less elegant?)
1252    f2c way.  */
1253
1254 static tree
1255 ffecom_make_complex_type_ (tree subtype)
1256 {
1257   tree type;
1258   tree realfield;
1259   tree imagfield;
1260
1261   if (ffe_is_emulate_complex ())
1262     {
1263       type = make_node (RECORD_TYPE);
1264       realfield = ffecom_decl_field (type, NULL_TREE, "r", subtype);
1265       imagfield = ffecom_decl_field (type, realfield, "i", subtype);
1266       TYPE_FIELDS (type) = realfield;
1267       layout_type (type);
1268     }
1269   else
1270     {
1271       type = make_node (COMPLEX_TYPE);
1272       TREE_TYPE (type) = subtype;
1273       layout_type (type);
1274     }
1275
1276   return type;
1277 }
1278
1279 /* Chooses either the gbe or the f2c way to build a
1280    complex constant.  */
1281
1282 static tree
1283 ffecom_build_complex_constant_ (tree type, tree realpart, tree imagpart)
1284 {
1285   tree bothparts;
1286
1287   if (ffe_is_emulate_complex ())
1288     {
1289       bothparts = build_tree_list (TYPE_FIELDS (type), realpart);
1290       TREE_CHAIN (bothparts) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), imagpart);
1291       bothparts = build_constructor (type, bothparts);
1292     }
1293   else
1294     {
1295       bothparts = build_complex (type, realpart, imagpart);
1296     }
1297
1298   return bothparts;
1299 }
1300
1301 static tree
1302 ffecom_arglist_expr_ (const char *c, ffebld expr)
1303 {
1304   tree list;
1305   tree *plist = &list;
1306   tree trail = NULL_TREE;       /* Append char length args here. */
1307   tree *ptrail = &trail;
1308   tree length;
1309   ffebld exprh;
1310   tree item;
1311   bool ptr = FALSE;
1312   tree wanted = NULL_TREE;
1313   static const char zed[] = "0";
1314
1315   if (c == NULL)
1316     c = &zed[0];
1317
1318   while (expr != NULL)
1319     {
1320       if (*c != '\0')
1321         {
1322           ptr = FALSE;
1323           if (*c == '&')
1324             {
1325               ptr = TRUE;
1326               ++c;
1327             }
1328           switch (*(c++))
1329             {
1330             case '\0':
1331               ptr = TRUE;
1332               wanted = NULL_TREE;
1333               break;
1334
1335             case 'a':
1336               assert (ptr);
1337               wanted = NULL_TREE;
1338               break;
1339
1340             case 'c':
1341               wanted = ffecom_f2c_complex_type_node;
1342               break;
1343
1344             case 'd':
1345               wanted = ffecom_f2c_doublereal_type_node;
1346               break;
1347
1348             case 'e':
1349               wanted = ffecom_f2c_doublecomplex_type_node;
1350               break;
1351
1352             case 'f':
1353               wanted = ffecom_f2c_real_type_node;
1354               break;
1355
1356             case 'i':
1357               wanted = ffecom_f2c_integer_type_node;
1358               break;
1359
1360             case 'j':
1361               wanted = ffecom_f2c_longint_type_node;
1362               break;
1363
1364             default:
1365               assert ("bad argstring code" == NULL);
1366               wanted = NULL_TREE;
1367               break;
1368             }
1369         }
1370
1371       exprh = ffebld_head (expr);
1372       if (exprh == NULL)
1373         wanted = NULL_TREE;
1374
1375       if ((wanted == NULL_TREE)
1376           || (ptr
1377               && (TYPE_MODE
1378                   (ffecom_tree_type[ffeinfo_basictype (ffebld_info (exprh))]
1379                    [ffeinfo_kindtype (ffebld_info (exprh))])
1380                    == TYPE_MODE (wanted))))
1381         *plist
1382           = build_tree_list (NULL_TREE,
1383                              ffecom_arg_ptr_to_expr (exprh,
1384                                                      &length));
1385       else
1386         {
1387           item = ffecom_arg_expr (exprh, &length);
1388           item = ffecom_convert_widen_ (wanted, item);
1389           if (ptr)
1390             {
1391               item = ffecom_1 (ADDR_EXPR,
1392                                build_pointer_type (TREE_TYPE (item)),
1393                                item);
1394             }
1395           *plist
1396             = build_tree_list (NULL_TREE,
1397                                item);
1398         }
1399
1400       plist = &TREE_CHAIN (*plist);
1401       expr = ffebld_trail (expr);
1402       if (length != NULL_TREE)
1403         {
1404           *ptrail = build_tree_list (NULL_TREE, length);
1405           ptrail = &TREE_CHAIN (*ptrail);
1406         }
1407     }
1408
1409   /* We've run out of args in the call; if the implementation expects
1410      more, supply null pointers for them, which the implementation can
1411      check to see if an arg was omitted. */
1412
1413   while (*c != '\0' && *c != '0')
1414     {
1415       if (*c == '&')
1416         ++c;
1417       else
1418         assert ("missing arg to run-time routine!" == NULL);
1419
1420       switch (*(c++))
1421         {
1422         case '\0':
1423         case 'a':
1424         case 'c':
1425         case 'd':
1426         case 'e':
1427         case 'f':
1428         case 'i':
1429         case 'j':
1430           break;
1431
1432         default:
1433           assert ("bad arg string code" == NULL);
1434           break;
1435         }
1436       *plist
1437         = build_tree_list (NULL_TREE,
1438                            null_pointer_node);
1439       plist = &TREE_CHAIN (*plist);
1440     }
1441
1442   *plist = trail;
1443
1444   return list;
1445 }
1446
1447 static tree
1448 ffecom_widest_expr_type_ (ffebld list)
1449 {
1450   ffebld item;
1451   ffebld widest = NULL;
1452   ffetype type;
1453   ffetype widest_type = NULL;
1454   tree t;
1455
1456   for (; list != NULL; list = ffebld_trail (list))
1457     {
1458       item = ffebld_head (list);
1459       if (item == NULL)
1460         continue;
1461       if ((widest != NULL)
1462           && (ffeinfo_basictype (ffebld_info (item))
1463               != ffeinfo_basictype (ffebld_info (widest))))
1464         continue;
1465       type = ffeinfo_type (ffeinfo_basictype (ffebld_info (item)),
1466                            ffeinfo_kindtype (ffebld_info (item)));
1467       if ((widest == FFEINFO_kindtypeNONE)
1468           || (ffetype_size (type)
1469               > ffetype_size (widest_type)))
1470         {
1471           widest = item;
1472           widest_type = type;
1473         }
1474     }
1475
1476   assert (widest != NULL);
1477   t = ffecom_tree_type[ffeinfo_basictype (ffebld_info (widest))]
1478     [ffeinfo_kindtype (ffebld_info (widest))];
1479   assert (t != NULL_TREE);
1480   return t;
1481 }
1482
1483 /* Check whether a partial overlap between two expressions is possible.
1484
1485    Can *starting* to write a portion of expr1 change the value
1486    computed (perhaps already, *partially*) by expr2?
1487
1488    Currently, this is a concern only for a COMPLEX expr1.  But if it
1489    isn't in COMMON or local EQUIVALENCE, since we don't support
1490    aliasing of arguments, it isn't a concern.  */
1491
1492 static bool
1493 ffecom_possible_partial_overlap_ (ffebld expr1, ffebld expr2 ATTRIBUTE_UNUSED)
1494 {
1495   ffesymbol sym;
1496   ffestorag st;
1497
1498   switch (ffebld_op (expr1))
1499     {
1500     case FFEBLD_opSYMTER:
1501       sym = ffebld_symter (expr1);
1502       break;
1503
1504     case FFEBLD_opARRAYREF:
1505       if (ffebld_op (ffebld_left (expr1)) != FFEBLD_opSYMTER)
1506         return FALSE;
1507       sym = ffebld_symter (ffebld_left (expr1));
1508       break;
1509
1510     default:
1511       return FALSE;
1512     }
1513
1514   if (ffesymbol_where (sym) != FFEINFO_whereCOMMON
1515       && (ffesymbol_where (sym) != FFEINFO_whereLOCAL
1516           || ! (st = ffesymbol_storage (sym))
1517           || ! ffestorag_parent (st)))
1518     return FALSE;
1519
1520   /* It's in COMMON or local EQUIVALENCE.  */
1521
1522   return TRUE;
1523 }
1524
1525 /* Check whether dest and source might overlap.  ffebld versions of these
1526    might or might not be passed, will be NULL if not.
1527
1528    The test is really whether source_tree is modifiable and, if modified,
1529    might overlap destination such that the value(s) in the destination might
1530    change before it is finally modified.  dest_* are the canonized
1531    destination itself.  */
1532
1533 static bool
1534 ffecom_overlap_ (tree dest_decl, tree dest_offset, tree dest_size,
1535                  tree source_tree, ffebld source UNUSED, bool scalar_arg)
1536 {
1537   tree source_decl;
1538   tree source_offset;
1539   tree source_size;
1540   tree t;
1541
1542   if (source_tree == NULL_TREE)
1543     return FALSE;
1544
1545   switch (TREE_CODE (source_tree))
1546     {
1547     case ERROR_MARK:
1548     case IDENTIFIER_NODE:
1549     case INTEGER_CST:
1550     case REAL_CST:
1551     case COMPLEX_CST:
1552     case STRING_CST:
1553     case CONST_DECL:
1554     case VAR_DECL:
1555     case RESULT_DECL:
1556     case FIELD_DECL:
1557     case MINUS_EXPR:
1558     case MULT_EXPR:
1559     case TRUNC_DIV_EXPR:
1560     case CEIL_DIV_EXPR:
1561     case FLOOR_DIV_EXPR:
1562     case ROUND_DIV_EXPR:
1563     case TRUNC_MOD_EXPR:
1564     case CEIL_MOD_EXPR:
1565     case FLOOR_MOD_EXPR:
1566     case ROUND_MOD_EXPR:
1567     case RDIV_EXPR:
1568     case EXACT_DIV_EXPR:
1569     case FIX_TRUNC_EXPR:
1570     case FIX_CEIL_EXPR:
1571     case FIX_FLOOR_EXPR:
1572     case FIX_ROUND_EXPR:
1573     case FLOAT_EXPR:
1574     case NEGATE_EXPR:
1575     case MIN_EXPR:
1576     case MAX_EXPR:
1577     case ABS_EXPR:
1578     case LSHIFT_EXPR:
1579     case RSHIFT_EXPR:
1580     case LROTATE_EXPR:
1581     case RROTATE_EXPR:
1582     case BIT_IOR_EXPR:
1583     case BIT_XOR_EXPR:
1584     case BIT_AND_EXPR:
1585     case BIT_NOT_EXPR:
1586     case TRUTH_ANDIF_EXPR:
1587     case TRUTH_ORIF_EXPR:
1588     case TRUTH_AND_EXPR:
1589     case TRUTH_OR_EXPR:
1590     case TRUTH_XOR_EXPR:
1591     case TRUTH_NOT_EXPR:
1592     case LT_EXPR:
1593     case LE_EXPR:
1594     case GT_EXPR:
1595     case GE_EXPR:
1596     case EQ_EXPR:
1597     case NE_EXPR:
1598     case COMPLEX_EXPR:
1599     case CONJ_EXPR:
1600     case REALPART_EXPR:
1601     case IMAGPART_EXPR:
1602     case LABEL_EXPR:
1603     case COMPONENT_REF:
1604       return FALSE;
1605
1606     case COMPOUND_EXPR:
1607       return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1608                               TREE_OPERAND (source_tree, 1), NULL,
1609                               scalar_arg);
1610
1611     case MODIFY_EXPR:
1612       return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1613                               TREE_OPERAND (source_tree, 0), NULL,
1614                               scalar_arg);
1615
1616     case CONVERT_EXPR:
1617     case NOP_EXPR:
1618     case NON_LVALUE_EXPR:
1619     case PLUS_EXPR:
1620       if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1621         return TRUE;
1622
1623       ffecom_tree_canonize_ptr_ (&source_decl, &source_offset,
1624                                  source_tree);
1625       source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1626       break;
1627
1628     case COND_EXPR:
1629       return
1630         ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1631                          TREE_OPERAND (source_tree, 1), NULL,
1632                          scalar_arg)
1633           || ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1634                               TREE_OPERAND (source_tree, 2), NULL,
1635                               scalar_arg);
1636
1637
1638     case ADDR_EXPR:
1639       ffecom_tree_canonize_ref_ (&source_decl, &source_offset,
1640                                  &source_size,
1641                                  TREE_OPERAND (source_tree, 0));
1642       break;
1643
1644     case PARM_DECL:
1645       if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1646         return TRUE;
1647
1648       source_decl = source_tree;
1649       source_offset = bitsize_zero_node;
1650       source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1651       break;
1652
1653     case SAVE_EXPR:
1654     case REFERENCE_EXPR:
1655     case PREDECREMENT_EXPR:
1656     case PREINCREMENT_EXPR:
1657     case POSTDECREMENT_EXPR:
1658     case POSTINCREMENT_EXPR:
1659     case INDIRECT_REF:
1660     case ARRAY_REF:
1661     case CALL_EXPR:
1662     default:
1663       return TRUE;
1664     }
1665
1666   /* Come here when source_decl, source_offset, and source_size filled
1667      in appropriately.  */
1668
1669   if (source_decl == NULL_TREE)
1670     return FALSE;               /* No decl involved, so no overlap. */
1671
1672   if (source_decl != dest_decl)
1673     return FALSE;               /* Different decl, no overlap. */
1674
1675   if (TREE_CODE (dest_size) == ERROR_MARK)
1676     return TRUE;                /* Assignment into entire assumed-size
1677                                    array?  Shouldn't happen.... */
1678
1679   t = ffecom_2 (LE_EXPR, integer_type_node,
1680                 ffecom_2 (PLUS_EXPR, TREE_TYPE (dest_offset),
1681                           dest_offset,
1682                           convert (TREE_TYPE (dest_offset),
1683                                    dest_size)),
1684                 convert (TREE_TYPE (dest_offset),
1685                          source_offset));
1686
1687   if (integer_onep (t))
1688     return FALSE;               /* Destination precedes source. */
1689
1690   if (!scalar_arg
1691       || (source_size == NULL_TREE)
1692       || (TREE_CODE (source_size) == ERROR_MARK)
1693       || integer_zerop (source_size))
1694     return TRUE;                /* No way to tell if dest follows source. */
1695
1696   t = ffecom_2 (LE_EXPR, integer_type_node,
1697                 ffecom_2 (PLUS_EXPR, TREE_TYPE (source_offset),
1698                           source_offset,
1699                           convert (TREE_TYPE (source_offset),
1700                                    source_size)),
1701                 convert (TREE_TYPE (source_offset),
1702                          dest_offset));
1703
1704   if (integer_onep (t))
1705     return FALSE;               /* Destination follows source. */
1706
1707   return TRUE;          /* Destination and source overlap. */
1708 }
1709
1710 /* Check whether dest might overlap any of a list of arguments or is
1711    in a COMMON area the callee might know about (and thus modify).  */
1712
1713 static bool
1714 ffecom_args_overlapping_ (tree dest_tree, ffebld dest UNUSED, tree args,
1715                           tree callee_commons, bool scalar_args)
1716 {
1717   tree arg;
1718   tree dest_decl;
1719   tree dest_offset;
1720   tree dest_size;
1721
1722   ffecom_tree_canonize_ref_ (&dest_decl, &dest_offset, &dest_size,
1723                              dest_tree);
1724
1725   if (dest_decl == NULL_TREE)
1726     return FALSE;               /* Seems unlikely! */
1727
1728   /* If the decl cannot be determined reliably, or if its in COMMON
1729      and the callee isn't known to not futz with COMMON via other
1730      means, overlap might happen.  */
1731
1732   if ((TREE_CODE (dest_decl) == ERROR_MARK)
1733       || ((callee_commons != NULL_TREE)
1734           && TREE_PUBLIC (dest_decl)))
1735     return TRUE;
1736
1737   for (; args != NULL_TREE; args = TREE_CHAIN (args))
1738     {
1739       if (((arg = TREE_VALUE (args)) != NULL_TREE)
1740           && ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1741                               arg, NULL, scalar_args))
1742         return TRUE;
1743     }
1744
1745   return FALSE;
1746 }
1747
1748 /* Build a string for a variable name as used by NAMELIST.  This means that
1749    if we're using the f2c library, we build an uppercase string, since
1750    f2c does this.  */
1751
1752 static tree
1753 ffecom_build_f2c_string_ (int i, const char *s)
1754 {
1755   if (!ffe_is_f2c_library ())
1756     return build_string (i, s);
1757
1758   {
1759     char *tmp;
1760     const char *p;
1761     char *q;
1762     char space[34];
1763     tree t;
1764
1765     if (((size_t) i) > ARRAY_SIZE (space))
1766       tmp = malloc_new_ks (malloc_pool_image (), "f2c_string", i);
1767     else
1768       tmp = &space[0];
1769
1770     for (p = s, q = tmp; *p != '\0'; ++p, ++q)
1771       *q = TOUPPER (*p);
1772     *q = '\0';
1773
1774     t = build_string (i, tmp);
1775
1776     if (((size_t) i) > ARRAY_SIZE (space))
1777       malloc_kill_ks (malloc_pool_image (), tmp, i);
1778
1779     return t;
1780   }
1781 }
1782
1783 /* Returns CALL_EXPR or equivalent with given type (pass NULL_TREE for
1784    type to just get whatever the function returns), handling the
1785    f2c value-returning convention, if required, by prepending
1786    to the arglist a pointer to a temporary to receive the return value.  */
1787
1788 static tree
1789 ffecom_call_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex, tree type,
1790               tree args, tree dest_tree, ffebld dest, bool *dest_used,
1791               tree callee_commons, bool scalar_args, tree hook)
1792 {
1793   tree item;
1794   tree tempvar;
1795
1796   if (dest_used != NULL)
1797     *dest_used = FALSE;
1798
1799   if (is_f2c_complex)
1800     {
1801       if ((dest_used == NULL)
1802           || (dest == NULL)
1803           || (ffeinfo_basictype (ffebld_info (dest))
1804               != FFEINFO_basictypeCOMPLEX)
1805           || (ffeinfo_kindtype (ffebld_info (dest)) != kt)
1806           || ((type != NULL_TREE) && (TREE_TYPE (dest_tree) != type))
1807           || ffecom_args_overlapping_ (dest_tree, dest, args,
1808                                        callee_commons,
1809                                        scalar_args))
1810         {
1811           tempvar = hook;
1812           assert (tempvar);
1813         }
1814       else
1815         {
1816           *dest_used = TRUE;
1817           tempvar = dest_tree;
1818           type = NULL_TREE;
1819         }
1820
1821       item
1822         = build_tree_list (NULL_TREE,
1823                            ffecom_1 (ADDR_EXPR,
1824                                      build_pointer_type (TREE_TYPE (tempvar)),
1825                                      tempvar));
1826       TREE_CHAIN (item) = args;
1827
1828       item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1829                         item, NULL_TREE);
1830
1831       if (tempvar != dest_tree)
1832         item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item, tempvar);
1833     }
1834   else
1835     item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1836                       args, NULL_TREE);
1837
1838   if ((type != NULL_TREE) && (TREE_TYPE (item) != type))
1839     item = ffecom_convert_narrow_ (type, item);
1840
1841   return item;
1842 }
1843
1844 /* Given two arguments, transform them and make a call to the given
1845    function via ffecom_call_.  */
1846
1847 static tree
1848 ffecom_call_binop_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1849                     tree type, ffebld left, ffebld right, tree dest_tree,
1850                     ffebld dest, bool *dest_used, tree callee_commons,
1851                     bool scalar_args, bool ref, tree hook)
1852 {
1853   tree left_tree;
1854   tree right_tree;
1855   tree left_length;
1856   tree right_length;
1857
1858   if (ref)
1859     {
1860       /* Pass arguments by reference.  */
1861       left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
1862       right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
1863     }
1864   else
1865     {
1866       /* Pass arguments by value.  */
1867       left_tree = ffecom_arg_expr (left, &left_length);
1868       right_tree = ffecom_arg_expr (right, &right_length);
1869     }
1870
1871
1872   left_tree = build_tree_list (NULL_TREE, left_tree);
1873   right_tree = build_tree_list (NULL_TREE, right_tree);
1874   TREE_CHAIN (left_tree) = right_tree;
1875
1876   if (left_length != NULL_TREE)
1877     {
1878       left_length = build_tree_list (NULL_TREE, left_length);
1879       TREE_CHAIN (right_tree) = left_length;
1880     }
1881
1882   if (right_length != NULL_TREE)
1883     {
1884       right_length = build_tree_list (NULL_TREE, right_length);
1885       if (left_length != NULL_TREE)
1886         TREE_CHAIN (left_length) = right_length;
1887       else
1888         TREE_CHAIN (right_tree) = right_length;
1889     }
1890
1891   return ffecom_call_ (fn, kt, is_f2c_complex, type, left_tree,
1892                        dest_tree, dest, dest_used, callee_commons,
1893                        scalar_args, hook);
1894 }
1895
1896 /* Return ptr/length args for char subexpression
1897
1898    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
1899    subexpressions by constructing the appropriate trees for the ptr-to-
1900    character-text and length-of-character-text arguments in a calling
1901    sequence.
1902
1903    Note that if with_null is TRUE, and the expression is an opCONTER,
1904    a null byte is appended to the string.  */
1905
1906 static void
1907 ffecom_char_args_x_ (tree *xitem, tree *length, ffebld expr, bool with_null)
1908 {
1909   tree item;
1910   tree high;
1911   ffetargetCharacter1 val;
1912   ffetargetCharacterSize newlen;
1913
1914   switch (ffebld_op (expr))
1915     {
1916     case FFEBLD_opCONTER:
1917       val = ffebld_constant_character1 (ffebld_conter (expr));
1918       newlen = ffetarget_length_character1 (val);
1919       if (with_null)
1920         {
1921           /* Begin FFETARGET-NULL-KLUDGE.  */
1922           if (newlen != 0)
1923             ++newlen;
1924         }
1925       *length = build_int_2 (newlen, 0);
1926       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
1927       high = build_int_2 (newlen, 0);
1928       TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
1929       item = build_string (newlen,
1930                            ffetarget_text_character1 (val));
1931       /* End FFETARGET-NULL-KLUDGE.  */
1932       TREE_TYPE (item)
1933         = build_type_variant
1934           (build_array_type
1935            (char_type_node,
1936             build_range_type
1937             (ffecom_f2c_ftnlen_type_node,
1938              ffecom_f2c_ftnlen_one_node,
1939              high)),
1940            1, 0);
1941       TREE_CONSTANT (item) = 1;
1942       TREE_STATIC (item) = 1;
1943       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
1944                        item);
1945       break;
1946
1947     case FFEBLD_opSYMTER:
1948       {
1949         ffesymbol s = ffebld_symter (expr);
1950
1951         item = ffesymbol_hook (s).decl_tree;
1952         if (item == NULL_TREE)
1953           {
1954             s = ffecom_sym_transform_ (s);
1955             item = ffesymbol_hook (s).decl_tree;
1956           }
1957         if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
1958           {
1959             if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
1960               *length = ffesymbol_hook (s).length_tree;
1961             else
1962               {
1963                 *length = build_int_2 (ffesymbol_size (s), 0);
1964                 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
1965               }
1966           }
1967         else if (item == error_mark_node)
1968           *length = error_mark_node;
1969         else
1970           /* FFEINFO_kindFUNCTION.  */
1971           *length = NULL_TREE;
1972         if (!ffesymbol_hook (s).addr
1973             && (item != error_mark_node))
1974           item = ffecom_1 (ADDR_EXPR,
1975                            build_pointer_type (TREE_TYPE (item)),
1976                            item);
1977       }
1978       break;
1979
1980     case FFEBLD_opARRAYREF:
1981       {
1982         ffecom_char_args_ (&item, length, ffebld_left (expr));
1983
1984         if (item == error_mark_node || *length == error_mark_node)
1985           {
1986             item = *length = error_mark_node;
1987             break;
1988           }
1989
1990         item = ffecom_arrayref_ (item, expr, 1);
1991       }
1992       break;
1993
1994     case FFEBLD_opSUBSTR:
1995       {
1996         ffebld start;
1997         ffebld end;
1998         ffebld thing = ffebld_right (expr);
1999         tree start_tree;
2000         tree end_tree;
2001         const char *char_name;
2002         ffebld left_symter;
2003         tree array;
2004
2005         assert (ffebld_op (thing) == FFEBLD_opITEM);
2006         start = ffebld_head (thing);
2007         thing = ffebld_trail (thing);
2008         assert (ffebld_trail (thing) == NULL);
2009         end = ffebld_head (thing);
2010
2011         /* Determine name for pretty-printing range-check errors.  */
2012         for (left_symter = ffebld_left (expr);
2013              left_symter && ffebld_op (left_symter) == FFEBLD_opARRAYREF;
2014              left_symter = ffebld_left (left_symter))
2015           ;
2016         if (ffebld_op (left_symter) == FFEBLD_opSYMTER)
2017           char_name = ffesymbol_text (ffebld_symter (left_symter));
2018         else
2019           char_name = "[expr?]";
2020
2021         ffecom_char_args_ (&item, length, ffebld_left (expr));
2022
2023         if (item == error_mark_node || *length == error_mark_node)
2024           {
2025             item = *length = error_mark_node;
2026             break;
2027           }
2028
2029         array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
2030
2031         /* ~~~~Handle INTEGER*8 start/end, a la FFEBLD_opARRAYREF.  */
2032
2033         if (start == NULL)
2034           {
2035             if (end == NULL)
2036               ;
2037             else
2038               {
2039                 end_tree = ffecom_expr (end);
2040                 if (flag_bounds_check)
2041                   end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2042                                                       char_name, NULL_TREE);
2043                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2044                                     end_tree);
2045
2046                 if (end_tree == error_mark_node)
2047                   {
2048                     item = *length = error_mark_node;
2049                     break;
2050                   }
2051
2052                 *length = end_tree;
2053               }
2054           }
2055         else
2056           {
2057             start_tree = ffecom_expr (start);
2058             if (flag_bounds_check)
2059               start_tree = ffecom_subscript_check_ (array, start_tree, 0, 0,
2060                                                     char_name, NULL_TREE);
2061             start_tree = convert (ffecom_f2c_ftnlen_type_node,
2062                                   start_tree);
2063
2064             if (start_tree == error_mark_node)
2065               {
2066                 item = *length = error_mark_node;
2067                 break;
2068               }
2069
2070             start_tree = ffecom_save_tree (start_tree);
2071
2072             item = ffecom_2 (PLUS_EXPR, TREE_TYPE (item),
2073                              item,
2074                              ffecom_2 (MINUS_EXPR,
2075                                        TREE_TYPE (start_tree),
2076                                        start_tree,
2077                                        ffecom_f2c_ftnlen_one_node));
2078
2079             if (end == NULL)
2080               {
2081                 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2082                                     ffecom_f2c_ftnlen_one_node,
2083                                     ffecom_2 (MINUS_EXPR,
2084                                               ffecom_f2c_ftnlen_type_node,
2085                                               *length,
2086                                               start_tree));
2087               }
2088             else
2089               {
2090                 end_tree = ffecom_expr (end);
2091                 if (flag_bounds_check)
2092                   end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2093                                                       char_name, NULL_TREE);
2094                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2095                                     end_tree);
2096
2097                 if (end_tree == error_mark_node)
2098                   {
2099                     item = *length = error_mark_node;
2100                     break;
2101                   }
2102
2103                 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2104                                     ffecom_f2c_ftnlen_one_node,
2105                                     ffecom_2 (MINUS_EXPR,
2106                                               ffecom_f2c_ftnlen_type_node,
2107                                               end_tree, start_tree));
2108               }
2109           }
2110       }
2111       break;
2112
2113     case FFEBLD_opFUNCREF:
2114       {
2115         ffesymbol s = ffebld_symter (ffebld_left (expr));
2116         tree tempvar;
2117         tree args;
2118         ffetargetCharacterSize size = ffeinfo_size (ffebld_info (expr));
2119         ffecomGfrt ix;
2120
2121         if (size == FFETARGET_charactersizeNONE)
2122           /* ~~Kludge alert!  This should someday be fixed. */
2123           size = 24;
2124
2125         *length = build_int_2 (size, 0);
2126         TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2127
2128         if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
2129             == FFEINFO_whereINTRINSIC)
2130           {
2131             if (size == 1)
2132               {
2133                 /* Invocation of an intrinsic returning CHARACTER*1.  */
2134                 item = ffecom_expr_intrinsic_ (expr, NULL_TREE,
2135                                                NULL, NULL);
2136                 break;
2137               }
2138             ix = ffeintrin_gfrt_direct (ffebld_symter_implementation (ffebld_left (expr)));
2139             assert (ix != FFECOM_gfrt);
2140             item = ffecom_gfrt_tree_ (ix);
2141           }
2142         else
2143           {
2144             ix = FFECOM_gfrt;
2145             item = ffesymbol_hook (s).decl_tree;
2146             if (item == NULL_TREE)
2147               {
2148                 s = ffecom_sym_transform_ (s);
2149                 item = ffesymbol_hook (s).decl_tree;
2150               }
2151             if (item == error_mark_node)
2152               {
2153                 item = *length = error_mark_node;
2154                 break;
2155               }
2156
2157             if (!ffesymbol_hook (s).addr)
2158               item = ffecom_1_fn (item);
2159           }
2160         tempvar = ffebld_nonter_hook (expr);
2161         assert (tempvar);
2162         tempvar = ffecom_1 (ADDR_EXPR,
2163                             build_pointer_type (TREE_TYPE (tempvar)),
2164                             tempvar);
2165
2166         args = build_tree_list (NULL_TREE, tempvar);
2167
2168         if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)       /* Sfunc args by value. */
2169           TREE_CHAIN (args) = ffecom_list_expr (ffebld_right (expr));
2170         else
2171           {
2172             TREE_CHAIN (args) = build_tree_list (NULL_TREE, *length);
2173             if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
2174               {
2175                 TREE_CHAIN (TREE_CHAIN (args))
2176                   = ffecom_arglist_expr_ (ffecom_gfrt_args_ (ix),
2177                                           ffebld_right (expr));
2178               }
2179             else
2180               {
2181                 TREE_CHAIN (TREE_CHAIN (args))
2182                   = ffecom_list_ptr_to_expr (ffebld_right (expr));
2183               }
2184           }
2185
2186         item = ffecom_3s (CALL_EXPR,
2187                           TREE_TYPE (TREE_TYPE (TREE_TYPE (item))),
2188                           item, args, NULL_TREE);
2189         item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item,
2190                          tempvar);
2191       }
2192       break;
2193
2194     case FFEBLD_opCONVERT:
2195
2196       ffecom_char_args_ (&item, length, ffebld_left (expr));
2197
2198       if (item == error_mark_node || *length == error_mark_node)
2199         {
2200           item = *length = error_mark_node;
2201           break;
2202         }
2203
2204       if ((ffebld_size_known (ffebld_left (expr))
2205            == FFETARGET_charactersizeNONE)
2206           || (ffebld_size_known (ffebld_left (expr)) < (ffebld_size (expr))))
2207         {                       /* Possible blank-padding needed, copy into
2208                                    temporary. */
2209           tree tempvar;
2210           tree args;
2211           tree newlen;
2212
2213           tempvar = ffebld_nonter_hook (expr);
2214           assert (tempvar);
2215           tempvar = ffecom_1 (ADDR_EXPR,
2216                               build_pointer_type (TREE_TYPE (tempvar)),
2217                               tempvar);
2218
2219           newlen = build_int_2 (ffebld_size (expr), 0);
2220           TREE_TYPE (newlen) = ffecom_f2c_ftnlen_type_node;
2221
2222           args = build_tree_list (NULL_TREE, tempvar);
2223           TREE_CHAIN (args) = build_tree_list (NULL_TREE, item);
2224           TREE_CHAIN (TREE_CHAIN (args)) = build_tree_list (NULL_TREE, newlen);
2225           TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (args)))
2226             = build_tree_list (NULL_TREE, *length);
2227
2228           item = ffecom_call_gfrt (FFECOM_gfrtCOPY, args, NULL_TREE);
2229           TREE_SIDE_EFFECTS (item) = 1;
2230           item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), fold (item),
2231                            tempvar);
2232           *length = newlen;
2233         }
2234       else
2235         {                       /* Just truncate the length. */
2236           *length = build_int_2 (ffebld_size (expr), 0);
2237           TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2238         }
2239       break;
2240
2241     default:
2242       assert ("bad op for single char arg expr" == NULL);
2243       item = NULL_TREE;
2244       break;
2245     }
2246
2247   *xitem = item;
2248 }
2249
2250 /* Check the size of the type to be sure it doesn't overflow the
2251    "portable" capacities of the compiler back end.  `dummy' types
2252    can generally overflow the normal sizes as long as the computations
2253    themselves don't overflow.  A particular target of the back end
2254    must still enforce its size requirements, though, and the back
2255    end takes care of this in stor-layout.c.  */
2256
2257 static tree
2258 ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy)
2259 {
2260   if (TREE_CODE (type) == ERROR_MARK)
2261     return type;
2262
2263   if (TYPE_SIZE (type) == NULL_TREE)
2264     return type;
2265
2266   if (TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST)
2267     return type;
2268
2269   /* An array is too large if size is negative or the type_size overflows
2270      or its "upper half" is larger than 3 (which would make the signed
2271      byte size and offset computations overflow).  */
2272
2273   if ((tree_int_cst_sgn (TYPE_SIZE (type)) < 0)
2274       || (!dummy && (TREE_INT_CST_HIGH (TYPE_SIZE (type)) > 3
2275                      || TREE_OVERFLOW (TYPE_SIZE (type)))))
2276     {
2277       ffebad_start (FFEBAD_ARRAY_LARGE);
2278       ffebad_string (ffesymbol_text (s));
2279       ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s));
2280       ffebad_finish ();
2281
2282       return error_mark_node;
2283     }
2284
2285   return type;
2286 }
2287
2288 /* Builds a length argument (PARM_DECL).  Also wraps type in an array type
2289    where the dimension info is (1:size) where <size> is ffesymbol_size(s) if
2290    known, length_arg if not known (FFETARGET_charactersizeNONE).  */
2291
2292 static tree
2293 ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s)
2294 {
2295   ffetargetCharacterSize sz = ffesymbol_size (s);
2296   tree highval;
2297   tree tlen;
2298   tree type = *xtype;
2299
2300   if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
2301     tlen = NULL_TREE;           /* A statement function, no length passed. */
2302   else
2303     {
2304       if (ffesymbol_where (s) == FFEINFO_whereDUMMY)
2305         tlen = ffecom_get_invented_identifier ("__g77_length_%s",
2306                                                ffesymbol_text (s));
2307       else
2308         tlen = ffecom_get_invented_identifier ("__g77_%s", "length");
2309       tlen = build_decl (PARM_DECL, tlen, ffecom_f2c_ftnlen_type_node);
2310       DECL_ARTIFICIAL (tlen) = 1;
2311     }
2312
2313   if (sz == FFETARGET_charactersizeNONE)
2314     {
2315       assert (tlen != NULL_TREE);
2316       highval = variable_size (tlen);
2317     }
2318   else
2319     {
2320       highval = build_int_2 (sz, 0);
2321       TREE_TYPE (highval) = ffecom_f2c_ftnlen_type_node;
2322     }
2323
2324   type = build_array_type (type,
2325                            build_range_type (ffecom_f2c_ftnlen_type_node,
2326                                              ffecom_f2c_ftnlen_one_node,
2327                                              highval));
2328
2329   *xtype = type;
2330   return tlen;
2331 }
2332
2333 /* ffecom_concat_list_gather_ -- Gather list of concatenated string exprs
2334
2335    ffecomConcatList_ catlist;
2336    ffebld expr;  // expr of CHARACTER basictype.
2337    ffetargetCharacterSize max;  // max chars to gather or _...NONE if no max
2338    catlist = ffecom_concat_list_gather_(catlist,expr,max);
2339
2340    Scans expr for character subexpressions, updates and returns catlist
2341    accordingly.  */
2342
2343 static ffecomConcatList_
2344 ffecom_concat_list_gather_ (ffecomConcatList_ catlist, ffebld expr,
2345                             ffetargetCharacterSize max)
2346 {
2347   ffetargetCharacterSize sz;
2348
2349  recurse:
2350
2351   if (expr == NULL)
2352     return catlist;
2353
2354   if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen >= max))
2355     return catlist;             /* Don't append any more items. */
2356
2357   switch (ffebld_op (expr))
2358     {
2359     case FFEBLD_opCONTER:
2360     case FFEBLD_opSYMTER:
2361     case FFEBLD_opARRAYREF:
2362     case FFEBLD_opFUNCREF:
2363     case FFEBLD_opSUBSTR:
2364     case FFEBLD_opCONVERT:      /* Callers should strip this off beforehand
2365                                    if they don't need to preserve it. */
2366       if (catlist.count == catlist.max)
2367         {                       /* Make a (larger) list. */
2368           ffebld *newx;
2369           int newmax;
2370
2371           newmax = (catlist.max == 0) ? 8 : catlist.max * 2;
2372           newx = malloc_new_ks (malloc_pool_image (), "catlist",
2373                                 newmax * sizeof (newx[0]));
2374           if (catlist.max != 0)
2375             {
2376               memcpy (newx, catlist.exprs, catlist.max * sizeof (newx[0]));
2377               malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2378                               catlist.max * sizeof (newx[0]));
2379             }
2380           catlist.max = newmax;
2381           catlist.exprs = newx;
2382         }
2383       if ((sz = ffebld_size_known (expr)) != FFETARGET_charactersizeNONE)
2384         catlist.minlen += sz;
2385       else
2386         ++catlist.minlen;       /* Not true for F90; can be 0 length. */
2387       if ((sz = ffebld_size_max (expr)) == FFETARGET_charactersizeNONE)
2388         catlist.maxlen = sz;
2389       else
2390         catlist.maxlen += sz;
2391       if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen > max))
2392         {                       /* This item overlaps (or is beyond) the end
2393                                    of the destination. */
2394           switch (ffebld_op (expr))
2395             {
2396             case FFEBLD_opCONTER:
2397             case FFEBLD_opSYMTER:
2398             case FFEBLD_opARRAYREF:
2399             case FFEBLD_opFUNCREF:
2400             case FFEBLD_opSUBSTR:
2401               /* ~~Do useful truncations here. */
2402               break;
2403
2404             default:
2405               assert ("op changed or inconsistent switches!" == NULL);
2406               break;
2407             }
2408         }
2409       catlist.exprs[catlist.count++] = expr;
2410       return catlist;
2411
2412     case FFEBLD_opPAREN:
2413       expr = ffebld_left (expr);
2414       goto recurse;             /* :::::::::::::::::::: */
2415
2416     case FFEBLD_opCONCATENATE:
2417       catlist = ffecom_concat_list_gather_ (catlist, ffebld_left (expr), max);
2418       expr = ffebld_right (expr);
2419       goto recurse;             /* :::::::::::::::::::: */
2420
2421 #if 0                           /* Breaks passing small actual arg to larger
2422                                    dummy arg of sfunc */
2423     case FFEBLD_opCONVERT:
2424       expr = ffebld_left (expr);
2425       {
2426         ffetargetCharacterSize cmax;
2427
2428         cmax = catlist.len + ffebld_size_known (expr);
2429
2430         if ((max == FFETARGET_charactersizeNONE) || (max > cmax))
2431           max = cmax;
2432       }
2433       goto recurse;             /* :::::::::::::::::::: */
2434 #endif
2435
2436     case FFEBLD_opANY:
2437       return catlist;
2438
2439     default:
2440       assert ("bad op in _gather_" == NULL);
2441       return catlist;
2442     }
2443 }
2444
2445 /* ffecom_concat_list_kill_ -- Kill list of concatenated string exprs
2446
2447    ffecomConcatList_ catlist;
2448    ffecom_concat_list_kill_(catlist);
2449
2450    Anything allocated within the list info is deallocated.  */
2451
2452 static void
2453 ffecom_concat_list_kill_ (ffecomConcatList_ catlist)
2454 {
2455   if (catlist.max != 0)
2456     malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2457                     catlist.max * sizeof (catlist.exprs[0]));
2458 }
2459
2460 /* Make list of concatenated string exprs.
2461
2462    Returns a flattened list of concatenated subexpressions given a
2463    tree of such expressions.  */
2464
2465 static ffecomConcatList_
2466 ffecom_concat_list_new_ (ffebld expr, ffetargetCharacterSize max)
2467 {
2468   ffecomConcatList_ catlist;
2469
2470   catlist.maxlen = catlist.minlen = catlist.max = catlist.count = 0;
2471   return ffecom_concat_list_gather_ (catlist, expr, max);
2472 }
2473
2474 /* Provide some kind of useful info on member of aggregate area,
2475    since current g77/gcc technology does not provide debug info
2476    on these members.  */
2477
2478 static void
2479 ffecom_debug_kludge_ (tree aggr, const char *aggr_type, ffesymbol member,
2480                       tree member_type UNUSED, ffetargetOffset offset)
2481 {
2482   tree value;
2483   tree decl;
2484   int len;
2485   char *buff;
2486   char space[120];
2487 #if 0
2488   tree type_id;
2489
2490   for (type_id = member_type;
2491        TREE_CODE (type_id) != IDENTIFIER_NODE;
2492        )
2493     {
2494       switch (TREE_CODE (type_id))
2495         {
2496         case INTEGER_TYPE:
2497         case REAL_TYPE:
2498           type_id = TYPE_NAME (type_id);
2499           break;
2500
2501         case ARRAY_TYPE:
2502         case COMPLEX_TYPE:
2503           type_id = TREE_TYPE (type_id);
2504           break;
2505
2506         default:
2507           assert ("no IDENTIFIER_NODE for type!" == NULL);
2508           type_id = error_mark_node;
2509           break;
2510         }
2511     }
2512 #endif
2513
2514   if (ffecom_transform_only_dummies_
2515       || !ffe_is_debug_kludge ())
2516     return;     /* Can't do this yet, maybe later. */
2517
2518   len = 60
2519     + strlen (aggr_type)
2520     + IDENTIFIER_LENGTH (DECL_NAME (aggr));
2521 #if 0
2522     + IDENTIFIER_LENGTH (type_id);
2523 #endif
2524
2525   if (((size_t) len) >= ARRAY_SIZE (space))
2526     buff = malloc_new_ks (malloc_pool_image (), "debug_kludge", len + 1);
2527   else
2528     buff = &space[0];
2529
2530   sprintf (&buff[0], "At (%s) `%s' plus %ld bytes",
2531            aggr_type,
2532            IDENTIFIER_POINTER (DECL_NAME (aggr)),
2533            (long int) offset);
2534
2535   value = build_string (len, buff);
2536   TREE_TYPE (value)
2537     = build_type_variant (build_array_type (char_type_node,
2538                                             build_range_type
2539                                             (integer_type_node,
2540                                              integer_one_node,
2541                                              build_int_2 (strlen (buff), 0))),
2542                           1, 0);
2543   decl = build_decl (VAR_DECL,
2544                      ffecom_get_identifier_ (ffesymbol_text (member)),
2545                      TREE_TYPE (value));
2546   TREE_CONSTANT (decl) = 1;
2547   TREE_STATIC (decl) = 1;
2548   DECL_INITIAL (decl) = error_mark_node;
2549   DECL_IN_SYSTEM_HEADER (decl) = 1;     /* Don't let -Wunused complain. */
2550   decl = start_decl (decl, FALSE);
2551   finish_decl (decl, value, FALSE);
2552
2553   if (buff != &space[0])
2554     malloc_kill_ks (malloc_pool_image (), buff, len + 1);
2555 }
2556
2557 /* ffecom_do_entry_ -- Do compilation of a particular entrypoint
2558
2559    ffesymbol fn;  // the SUBROUTINE, FUNCTION, or ENTRY symbol itself
2560    int i;  // entry# for this entrypoint (used by master fn)
2561    ffecom_do_entrypoint_(s,i);
2562
2563    Makes a public entry point that calls our private master fn (already
2564    compiled).  */
2565
2566 static void
2567 ffecom_do_entry_ (ffesymbol fn, int entrynum)
2568 {
2569   ffebld item;
2570   tree type;                    /* Type of function. */
2571   tree multi_retval;            /* Var holding return value (union). */
2572   tree result;                  /* Var holding result. */
2573   ffeinfoBasictype bt;
2574   ffeinfoKindtype kt;
2575   ffeglobal g;
2576   ffeglobalType gt;
2577   bool charfunc;                /* All entry points return same type
2578                                    CHARACTER. */
2579   bool cmplxfunc;               /* Use f2c way of returning COMPLEX. */
2580   bool multi;                   /* Master fn has multiple return types. */
2581   bool altreturning = FALSE;    /* This entry point has alternate
2582                                    returns. */
2583   location_t old_loc = input_location;
2584
2585   input_filename = ffesymbol_where_filename (fn);
2586   input_line = ffesymbol_where_filelinenum (fn);
2587
2588   ffecom_doing_entry_ = TRUE;   /* Don't bother with array dimensions. */
2589
2590   switch (ffecom_primary_entry_kind_)
2591     {
2592     case FFEINFO_kindFUNCTION:
2593
2594       /* Determine actual return type for function. */
2595
2596       gt = FFEGLOBAL_typeFUNC;
2597       bt = ffesymbol_basictype (fn);
2598       kt = ffesymbol_kindtype (fn);
2599       if (bt == FFEINFO_basictypeNONE)
2600         {
2601           ffeimplic_establish_symbol (fn);
2602           if (ffesymbol_funcresult (fn) != NULL)
2603             ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
2604           bt = ffesymbol_basictype (fn);
2605           kt = ffesymbol_kindtype (fn);
2606         }
2607
2608       if (bt == FFEINFO_basictypeCHARACTER)
2609         charfunc = TRUE, cmplxfunc = FALSE;
2610       else if ((bt == FFEINFO_basictypeCOMPLEX)
2611                && ffesymbol_is_f2c (fn))
2612         charfunc = FALSE, cmplxfunc = TRUE;
2613       else
2614         charfunc = cmplxfunc = FALSE;
2615
2616       if (charfunc)
2617         type = ffecom_tree_fun_type_void;
2618       else if (ffesymbol_is_f2c (fn))
2619         type = ffecom_tree_fun_type[bt][kt];
2620       else
2621         type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
2622
2623       if ((type == NULL_TREE)
2624           || (TREE_TYPE (type) == NULL_TREE))
2625         type = ffecom_tree_fun_type_void;       /* _sym_exec_transition. */
2626
2627       multi = (ffecom_master_bt_ == FFEINFO_basictypeNONE);
2628       break;
2629
2630     case FFEINFO_kindSUBROUTINE:
2631       gt = FFEGLOBAL_typeSUBR;
2632       bt = FFEINFO_basictypeNONE;
2633       kt = FFEINFO_kindtypeNONE;
2634       if (ffecom_is_altreturning_)
2635         {                       /* Am _I_ altreturning? */
2636           for (item = ffesymbol_dummyargs (fn);
2637                item != NULL;
2638                item = ffebld_trail (item))
2639             {
2640               if (ffebld_op (ffebld_head (item)) == FFEBLD_opSTAR)
2641                 {
2642                   altreturning = TRUE;
2643                   break;
2644                 }
2645             }
2646           if (altreturning)
2647             type = ffecom_tree_subr_type;
2648           else
2649             type = ffecom_tree_fun_type_void;
2650         }
2651       else
2652         type = ffecom_tree_fun_type_void;
2653       charfunc = FALSE;
2654       cmplxfunc = FALSE;
2655       multi = FALSE;
2656       break;
2657
2658     default:
2659       assert ("say what??" == NULL);
2660       /* Fall through. */
2661     case FFEINFO_kindANY:
2662       gt = FFEGLOBAL_typeANY;
2663       bt = FFEINFO_basictypeNONE;
2664       kt = FFEINFO_kindtypeNONE;
2665       type = error_mark_node;
2666       charfunc = FALSE;
2667       cmplxfunc = FALSE;
2668       multi = FALSE;
2669       break;
2670     }
2671
2672   /* build_decl uses the current lineno and input_filename to set the decl
2673      source info.  So, I've putzed with ffestd and ffeste code to update that
2674      source info to point to the appropriate statement just before calling
2675      ffecom_do_entrypoint (which calls this fn).  */
2676
2677   start_function (ffecom_get_external_identifier_ (fn),
2678                   type,
2679                   0,            /* nested/inline */
2680                   1);           /* TREE_PUBLIC */
2681
2682   if (((g = ffesymbol_global (fn)) != NULL)
2683       && ((ffeglobal_type (g) == gt)
2684           || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
2685     {
2686       ffeglobal_set_hook (g, current_function_decl);
2687     }
2688
2689   /* Reset args in master arg list so they get retransitioned. */
2690
2691   for (item = ffecom_master_arglist_;
2692        item != NULL;
2693        item = ffebld_trail (item))
2694     {
2695       ffebld arg;
2696       ffesymbol s;
2697
2698       arg = ffebld_head (item);
2699       if (ffebld_op (arg) != FFEBLD_opSYMTER)
2700         continue;               /* Alternate return or some such thing. */
2701       s = ffebld_symter (arg);
2702       ffesymbol_hook (s).decl_tree = NULL_TREE;
2703       ffesymbol_hook (s).length_tree = NULL_TREE;
2704     }
2705
2706   /* Build dummy arg list for this entry point. */
2707
2708   if (charfunc || cmplxfunc)
2709     {                           /* Prepend arg for where result goes. */
2710       tree type;
2711       tree length;
2712
2713       if (charfunc)
2714         type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
2715       else
2716         type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
2717
2718       result = ffecom_get_invented_identifier ("__g77_%s", "result");
2719
2720       /* Make length arg _and_ enhance type info for CHAR arg itself.  */
2721
2722       if (charfunc)
2723         length = ffecom_char_enhance_arg_ (&type, fn);
2724       else
2725         length = NULL_TREE;     /* Not ref'd if !charfunc. */
2726
2727       type = build_pointer_type (type);
2728       result = build_decl (PARM_DECL, result, type);
2729
2730       push_parm_decl (result);
2731       ffecom_func_result_ = result;
2732
2733       if (charfunc)
2734         {
2735           push_parm_decl (length);
2736           ffecom_func_length_ = length;
2737         }
2738     }
2739   else
2740     result = DECL_RESULT (current_function_decl);
2741
2742   ffecom_push_dummy_decls_ (ffesymbol_dummyargs (fn), FALSE);
2743
2744   store_parm_decls (0);
2745
2746   ffecom_start_compstmt ();
2747   /* Disallow temp vars at this level.  */
2748   current_binding_level->prep_state = 2;
2749
2750   /* Make local var to hold return type for multi-type master fn. */
2751
2752   if (multi)
2753     {
2754       multi_retval = ffecom_get_invented_identifier ("__g77_%s",
2755                                                      "multi_retval");
2756       multi_retval = build_decl (VAR_DECL, multi_retval,
2757                                  ffecom_multi_type_node_);
2758       multi_retval = start_decl (multi_retval, FALSE);
2759       finish_decl (multi_retval, NULL_TREE, FALSE);
2760     }
2761   else
2762     multi_retval = NULL_TREE;   /* Not actually ref'd if !multi. */
2763
2764   /* Here we emit the actual code for the entry point. */
2765
2766   {
2767     ffebld list;
2768     ffebld arg;
2769     ffesymbol s;
2770     tree arglist = NULL_TREE;
2771     tree *plist = &arglist;
2772     tree prepend;
2773     tree call;
2774     tree actarg;
2775     tree master_fn;
2776
2777     /* Prepare actual arg list based on master arg list. */
2778
2779     for (list = ffecom_master_arglist_;
2780          list != NULL;
2781          list = ffebld_trail (list))
2782       {
2783         arg = ffebld_head (list);
2784         if (ffebld_op (arg) != FFEBLD_opSYMTER)
2785           continue;
2786         s = ffebld_symter (arg);
2787         if (ffesymbol_hook (s).decl_tree == NULL_TREE
2788             || ffesymbol_hook (s).decl_tree == error_mark_node)
2789           actarg = null_pointer_node;   /* We don't have this arg. */
2790         else
2791           actarg = ffesymbol_hook (s).decl_tree;
2792         *plist = build_tree_list (NULL_TREE, actarg);
2793         plist = &TREE_CHAIN (*plist);
2794       }
2795
2796     /* This code appends the length arguments for character
2797        variables/arrays.  */
2798
2799     for (list = ffecom_master_arglist_;
2800          list != NULL;
2801          list = ffebld_trail (list))
2802       {
2803         arg = ffebld_head (list);
2804         if (ffebld_op (arg) != FFEBLD_opSYMTER)
2805           continue;
2806         s = ffebld_symter (arg);
2807         if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
2808           continue;             /* Only looking for CHARACTER arguments. */
2809         if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
2810           continue;             /* Only looking for variables and arrays. */
2811         if (ffesymbol_hook (s).length_tree == NULL_TREE
2812             || ffesymbol_hook (s).length_tree == error_mark_node)
2813           actarg = ffecom_f2c_ftnlen_zero_node; /* We don't have this arg. */
2814         else
2815           actarg = ffesymbol_hook (s).length_tree;
2816         *plist = build_tree_list (NULL_TREE, actarg);
2817         plist = &TREE_CHAIN (*plist);
2818       }
2819
2820     /* Prepend character-value return info to actual arg list. */
2821
2822     if (charfunc)
2823       {
2824         prepend = build_tree_list (NULL_TREE, ffecom_func_result_);
2825         TREE_CHAIN (prepend)
2826           = build_tree_list (NULL_TREE, ffecom_func_length_);
2827         TREE_CHAIN (TREE_CHAIN (prepend)) = arglist;
2828         arglist = prepend;
2829       }
2830
2831     /* Prepend multi-type return value to actual arg list. */
2832
2833     if (multi)
2834       {
2835         prepend
2836           = build_tree_list (NULL_TREE,
2837                              ffecom_1 (ADDR_EXPR,
2838                               build_pointer_type (TREE_TYPE (multi_retval)),
2839                                        multi_retval));
2840         TREE_CHAIN (prepend) = arglist;
2841         arglist = prepend;
2842       }
2843
2844     /* Prepend my entry-point number to the actual arg list. */
2845
2846     prepend = build_tree_list (NULL_TREE, build_int_2 (entrynum, 0));
2847     TREE_CHAIN (prepend) = arglist;
2848     arglist = prepend;
2849
2850     /* Build the call to the master function. */
2851
2852     master_fn = ffecom_1_fn (ffecom_previous_function_decl_);
2853     call = ffecom_3s (CALL_EXPR,
2854                       TREE_TYPE (TREE_TYPE (TREE_TYPE (master_fn))),
2855                       master_fn, arglist, NULL_TREE);
2856
2857     /* Decide whether the master function is a function or subroutine, and
2858        handle the return value for my entry point. */
2859
2860     if (charfunc || ((ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
2861                      && !altreturning))
2862       {
2863         expand_expr_stmt (call);
2864         expand_null_return ();
2865       }
2866     else if (multi && cmplxfunc)
2867       {
2868         expand_expr_stmt (call);
2869         result
2870           = ffecom_1 (INDIRECT_REF,
2871                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
2872                       result);
2873         result = ffecom_modify (NULL_TREE, result,
2874                                 ffecom_2 (COMPONENT_REF, TREE_TYPE (result),
2875                                           multi_retval,
2876                                           ffecom_multi_fields_[bt][kt]));
2877         expand_expr_stmt (result);
2878         expand_null_return ();
2879       }
2880     else if (multi)
2881       {
2882         expand_expr_stmt (call);
2883         result
2884           = ffecom_modify (NULL_TREE, result,
2885                            convert (TREE_TYPE (result),
2886                                     ffecom_2 (COMPONENT_REF,
2887                                               ffecom_tree_type[bt][kt],
2888                                               multi_retval,
2889                                               ffecom_multi_fields_[bt][kt])));
2890         expand_return (result);
2891       }
2892     else if (cmplxfunc)
2893       {
2894         result
2895           = ffecom_1 (INDIRECT_REF,
2896                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
2897                       result);
2898         result = ffecom_modify (NULL_TREE, result, call);
2899         expand_expr_stmt (result);
2900         expand_null_return ();
2901       }
2902     else
2903       {
2904         result = ffecom_modify (NULL_TREE,
2905                                 result,
2906                                 convert (TREE_TYPE (result),
2907                                          call));
2908         expand_return (result);
2909       }
2910   }
2911
2912   ffecom_end_compstmt ();
2913
2914   finish_function (0);
2915
2916   input_location = old_loc;
2917
2918   ffecom_doing_entry_ = FALSE;
2919 }
2920
2921 /* Transform expr into gcc tree with possible destination
2922
2923    Recursive descent on expr while making corresponding tree nodes and
2924    attaching type info and such.  If destination supplied and compatible
2925    with temporary that would be made in certain cases, temporary isn't
2926    made, destination used instead, and dest_used flag set TRUE.  */
2927
2928 static tree
2929 ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest, bool *dest_used,
2930               bool assignp, bool widenp)
2931 {
2932   tree item;
2933   tree list;
2934   tree args;
2935   ffeinfoBasictype bt;
2936   ffeinfoKindtype kt;
2937   tree t;
2938   tree dt;                      /* decl_tree for an ffesymbol. */
2939   tree tree_type, tree_type_x;
2940   tree left, right;
2941   ffesymbol s;
2942   enum tree_code code;
2943
2944   assert (expr != NULL);
2945
2946   if (dest_used != NULL)
2947     *dest_used = FALSE;
2948
2949   bt = ffeinfo_basictype (ffebld_info (expr));
2950   kt = ffeinfo_kindtype (ffebld_info (expr));
2951   tree_type = ffecom_tree_type[bt][kt];
2952
2953   /* Widen integral arithmetic as desired while preserving signedness.  */
2954   tree_type_x = NULL_TREE;
2955   if (widenp && tree_type
2956       && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
2957       && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
2958     tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
2959
2960   switch (ffebld_op (expr))
2961     {
2962     case FFEBLD_opACCTER:
2963       {
2964         ffebitCount i;
2965         ffebit bits = ffebld_accter_bits (expr);
2966         ffetargetOffset source_offset = 0;
2967         ffetargetOffset dest_offset = ffebld_accter_pad (expr);
2968         tree purpose;
2969
2970         assert (dest_offset == 0
2971                 || (bt == FFEINFO_basictypeCHARACTER
2972                     && kt == FFEINFO_kindtypeCHARACTER1));
2973
2974         list = item = NULL;
2975         for (;;)
2976           {
2977             ffebldConstantUnion cu;
2978             ffebitCount length;
2979             bool value;
2980             ffebldConstantArray ca = ffebld_accter (expr);
2981
2982             ffebit_test (bits, source_offset, &value, &length);
2983             if (length == 0)
2984               break;
2985
2986             if (value)
2987               {
2988                 for (i = 0; i < length; ++i)
2989                   {
2990                     cu = ffebld_constantarray_get (ca, bt, kt,
2991                                                    source_offset + i);
2992
2993                     t = ffecom_constantunion (&cu, bt, kt, tree_type);
2994
2995                     if (i == 0
2996                         && dest_offset != 0)
2997                       purpose = build_int_2 (dest_offset, 0);
2998                     else
2999                       purpose = NULL_TREE;
3000
3001                     if (list == NULL_TREE)
3002                       list = item = build_tree_list (purpose, t);
3003                     else
3004                       {
3005                         TREE_CHAIN (item) = build_tree_list (purpose, t);
3006                         item = TREE_CHAIN (item);
3007                       }
3008                   }
3009               }
3010             source_offset += length;
3011             dest_offset += length;
3012           }
3013       }
3014
3015       item = build_int_2 ((ffebld_accter_size (expr)
3016                            + ffebld_accter_pad (expr)) - 1, 0);
3017       ffebit_kill (ffebld_accter_bits (expr));
3018       TREE_TYPE (item) = ffecom_integer_type_node;
3019       item
3020         = build_array_type
3021           (tree_type,
3022            build_range_type (ffecom_integer_type_node,
3023                              ffecom_integer_zero_node,
3024                              item));
3025       list = build_constructor (item, list);
3026       TREE_CONSTANT (list) = 1;
3027       TREE_STATIC (list) = 1;
3028       return list;
3029
3030     case FFEBLD_opARRTER:
3031       {
3032         ffetargetOffset i;
3033
3034         list = NULL_TREE;
3035         if (ffebld_arrter_pad (expr) == 0)
3036           item = NULL_TREE;
3037         else
3038           {
3039             assert (bt == FFEINFO_basictypeCHARACTER
3040                     && kt == FFEINFO_kindtypeCHARACTER1);
3041
3042             /* Becomes PURPOSE first time through loop.  */
3043             item = build_int_2 (ffebld_arrter_pad (expr), 0);
3044           }
3045
3046         for (i = 0; i < ffebld_arrter_size (expr); ++i)
3047           {
3048             ffebldConstantUnion cu
3049             = ffebld_constantarray_get (ffebld_arrter (expr), bt, kt, i);
3050
3051             t = ffecom_constantunion (&cu, bt, kt, tree_type);
3052
3053             if (list == NULL_TREE)
3054               /* Assume item is PURPOSE first time through loop.  */
3055               list = item = build_tree_list (item, t);
3056             else
3057               {
3058                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
3059                 item = TREE_CHAIN (item);
3060               }
3061           }
3062       }
3063
3064       item = build_int_2 ((ffebld_arrter_size (expr)
3065                           + ffebld_arrter_pad (expr)) - 1, 0);
3066       TREE_TYPE (item) = ffecom_integer_type_node;
3067       item
3068         = build_array_type
3069           (tree_type,
3070            build_range_type (ffecom_integer_type_node,
3071                              ffecom_integer_zero_node,
3072                              item));
3073       list = build_constructor (item, list);
3074       TREE_CONSTANT (list) = 1;
3075       TREE_STATIC (list) = 1;
3076       return list;
3077
3078     case FFEBLD_opCONTER:
3079       assert (ffebld_conter_pad (expr) == 0);
3080       item
3081         = ffecom_constantunion (&ffebld_constant_union (ffebld_conter (expr)),
3082                                 bt, kt, tree_type);
3083       return item;
3084
3085     case FFEBLD_opSYMTER:
3086       if ((ffebld_symter_generic (expr) != FFEINTRIN_genNONE)
3087           || (ffebld_symter_specific (expr) != FFEINTRIN_specNONE))
3088         return ffecom_ptr_to_expr (expr);       /* Same as %REF(intrinsic). */
3089       s = ffebld_symter (expr);
3090       t = ffesymbol_hook (s).decl_tree;
3091
3092       if (assignp)
3093         {                       /* ASSIGN'ed-label expr. */
3094           if (ffe_is_ugly_assign ())
3095             {
3096               /* User explicitly wants ASSIGN'ed variables to be at the same
3097                  memory address as the variables when used in non-ASSIGN
3098                  contexts.  That can make old, arcane, non-standard code
3099                  work, but don't try to do it when a pointer wouldn't fit
3100                  in the normal variable (take other approach, and warn,
3101                  instead).  */
3102
3103               if (t == NULL_TREE)
3104                 {
3105                   s = ffecom_sym_transform_ (s);
3106                   t = ffesymbol_hook (s).decl_tree;
3107                   assert (t != NULL_TREE);
3108                 }
3109
3110               if (t == error_mark_node)
3111                 return t;
3112
3113               if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t)))
3114                   >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
3115                 {
3116                   if (ffesymbol_hook (s).addr)
3117                     t = ffecom_1 (INDIRECT_REF,
3118                                   TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3119                   return t;
3120                 }
3121
3122               if (ffesymbol_hook (s).assign_tree == NULL_TREE)
3123                 {
3124                   /* xgettext:no-c-format */
3125                   ffebad_start_msg ("ASSIGN'ed label cannot fit into `%A' at %0 -- using wider sibling",
3126                                     FFEBAD_severityWARNING);
3127                   ffebad_string (ffesymbol_text (s));
3128                   ffebad_here (0, ffesymbol_where_line (s),
3129                                ffesymbol_where_column (s));
3130                   ffebad_finish ();
3131                 }
3132             }
3133
3134           /* Don't use the normal variable's tree for ASSIGN, though mark
3135              it as in the system header (housekeeping).  Use an explicit,
3136              specially created sibling that is known to be wide enough
3137              to hold pointers to labels.  */
3138
3139           if (t != NULL_TREE
3140               && TREE_CODE (t) == VAR_DECL)
3141             DECL_IN_SYSTEM_HEADER (t) = 1;      /* Don't let -Wunused complain. */
3142
3143           t = ffesymbol_hook (s).assign_tree;
3144           if (t == NULL_TREE)
3145             {
3146               s = ffecom_sym_transform_assign_ (s);
3147               t = ffesymbol_hook (s).assign_tree;
3148               assert (t != NULL_TREE);
3149             }
3150         }
3151       else
3152         {
3153           if (t == NULL_TREE)
3154             {
3155               s = ffecom_sym_transform_ (s);
3156               t = ffesymbol_hook (s).decl_tree;
3157               assert (t != NULL_TREE);
3158             }
3159           if (ffesymbol_hook (s).addr)
3160             t = ffecom_1 (INDIRECT_REF,
3161                           TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3162         }
3163       return t;
3164
3165     case FFEBLD_opARRAYREF:
3166       return ffecom_arrayref_ (NULL_TREE, expr, 0);
3167
3168     case FFEBLD_opUPLUS:
3169       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3170       return ffecom_1 (NOP_EXPR, tree_type, left);
3171
3172     case FFEBLD_opPAREN:
3173       /* ~~~Make sure Fortran rules respected here */
3174       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3175       return ffecom_1 (NOP_EXPR, tree_type, left);
3176
3177     case FFEBLD_opUMINUS:
3178       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3179       if (tree_type_x)
3180         {
3181           tree_type = tree_type_x;
3182           left = convert (tree_type, left);
3183         }
3184       return ffecom_1 (NEGATE_EXPR, tree_type, left);
3185
3186     case FFEBLD_opADD:
3187       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3188       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3189       if (tree_type_x)
3190         {
3191           tree_type = tree_type_x;
3192           left = convert (tree_type, left);
3193           right = convert (tree_type, right);
3194         }
3195       return ffecom_2 (PLUS_EXPR, tree_type, left, right);
3196
3197     case FFEBLD_opSUBTRACT:
3198       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3199       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3200       if (tree_type_x)
3201         {
3202           tree_type = tree_type_x;
3203           left = convert (tree_type, left);
3204           right = convert (tree_type, right);
3205         }
3206       return ffecom_2 (MINUS_EXPR, tree_type, left, right);
3207
3208     case FFEBLD_opMULTIPLY:
3209       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3210       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3211       if (tree_type_x)
3212         {
3213           tree_type = tree_type_x;
3214           left = convert (tree_type, left);
3215           right = convert (tree_type, right);
3216         }
3217       return ffecom_2 (MULT_EXPR, tree_type, left, right);
3218
3219     case FFEBLD_opDIVIDE:
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_tree_divide_ (tree_type, left, right,
3229                                   dest_tree, dest, dest_used,
3230                                   ffebld_nonter_hook (expr));
3231
3232     case FFEBLD_opPOWER:
3233       {
3234         ffebld left = ffebld_left (expr);
3235         ffebld right = ffebld_right (expr);
3236         ffecomGfrt code;
3237         ffeinfoKindtype rtkt;
3238         ffeinfoKindtype ltkt;
3239         bool ref = TRUE;
3240
3241         switch (ffeinfo_basictype (ffebld_info (right)))
3242           {
3243
3244           case FFEINFO_basictypeINTEGER:
3245             if (1 || optimize)
3246               {
3247                 item = ffecom_expr_power_integer_ (expr);
3248                 if (item != NULL_TREE)
3249                   return item;
3250               }
3251
3252             rtkt = FFEINFO_kindtypeINTEGER1;
3253             switch (ffeinfo_basictype (ffebld_info (left)))
3254               {
3255               case FFEINFO_basictypeINTEGER:
3256                 if ((ffeinfo_kindtype (ffebld_info (left))
3257                     == FFEINFO_kindtypeINTEGER4)
3258                     || (ffeinfo_kindtype (ffebld_info (right))
3259                         == FFEINFO_kindtypeINTEGER4))
3260                   {
3261                     code = FFECOM_gfrtPOW_QQ;
3262                     ltkt = FFEINFO_kindtypeINTEGER4;
3263                     rtkt = FFEINFO_kindtypeINTEGER4;
3264                   }
3265                 else
3266                   {
3267                     code = FFECOM_gfrtPOW_II;
3268                     ltkt = FFEINFO_kindtypeINTEGER1;
3269                   }
3270                 break;
3271
3272               case FFEINFO_basictypeREAL:
3273                 if (ffeinfo_kindtype (ffebld_info (left))
3274                     == FFEINFO_kindtypeREAL1)
3275                   {
3276                     code = FFECOM_gfrtPOW_RI;
3277                     ltkt = FFEINFO_kindtypeREAL1;
3278                   }
3279                 else
3280                   {
3281                     code = FFECOM_gfrtPOW_DI;
3282                     ltkt = FFEINFO_kindtypeREAL2;
3283                   }
3284                 break;
3285
3286               case FFEINFO_basictypeCOMPLEX:
3287                 if (ffeinfo_kindtype (ffebld_info (left))
3288                     == FFEINFO_kindtypeREAL1)
3289                   {
3290                     code = FFECOM_gfrtPOW_CI;   /* Overlapping result okay. */
3291                     ltkt = FFEINFO_kindtypeREAL1;
3292                   }
3293                 else
3294                   {
3295                     code = FFECOM_gfrtPOW_ZI;   /* Overlapping result okay. */
3296                     ltkt = FFEINFO_kindtypeREAL2;
3297                   }
3298                 break;
3299
3300               default:
3301                 assert ("bad pow_*i" == NULL);
3302                 code = FFECOM_gfrtPOW_CI;       /* Overlapping result okay. */
3303                 ltkt = FFEINFO_kindtypeREAL1;
3304                 break;
3305               }
3306             if (ffeinfo_kindtype (ffebld_info (left)) != ltkt)
3307               left = ffeexpr_convert (left, NULL, NULL,
3308                                       ffeinfo_basictype (ffebld_info (left)),
3309                                       ltkt, 0,
3310                                       FFETARGET_charactersizeNONE,
3311                                       FFEEXPR_contextLET);
3312             if (ffeinfo_kindtype (ffebld_info (right)) != rtkt)
3313               right = ffeexpr_convert (right, NULL, NULL,
3314                                        FFEINFO_basictypeINTEGER,
3315                                        rtkt, 0,
3316                                        FFETARGET_charactersizeNONE,
3317                                        FFEEXPR_contextLET);
3318             break;
3319
3320           case FFEINFO_basictypeREAL:
3321             if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3322               left = ffeexpr_convert (left, NULL, NULL, FFEINFO_basictypeREAL,
3323                                       FFEINFO_kindtypeREALDOUBLE, 0,
3324                                       FFETARGET_charactersizeNONE,
3325                                       FFEEXPR_contextLET);
3326             if (ffeinfo_kindtype (ffebld_info (right))
3327                 == FFEINFO_kindtypeREAL1)
3328               right = ffeexpr_convert (right, NULL, NULL,
3329                                        FFEINFO_basictypeREAL,
3330                                        FFEINFO_kindtypeREALDOUBLE, 0,
3331                                        FFETARGET_charactersizeNONE,
3332                                        FFEEXPR_contextLET);
3333             /* We used to call FFECOM_gfrtPOW_DD here,
3334                which passes arguments by reference.  */
3335             code = FFECOM_gfrtL_POW;
3336             /* Pass arguments by value. */
3337             ref  = FALSE;
3338             break;
3339
3340           case FFEINFO_basictypeCOMPLEX:
3341             if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3342               left = ffeexpr_convert (left, NULL, NULL,
3343                                       FFEINFO_basictypeCOMPLEX,
3344                                       FFEINFO_kindtypeREALDOUBLE, 0,
3345                                       FFETARGET_charactersizeNONE,
3346                                       FFEEXPR_contextLET);
3347             if (ffeinfo_kindtype (ffebld_info (right))
3348                 == FFEINFO_kindtypeREAL1)
3349               right = ffeexpr_convert (right, NULL, NULL,
3350                                        FFEINFO_basictypeCOMPLEX,
3351                                        FFEINFO_kindtypeREALDOUBLE, 0,
3352                                        FFETARGET_charactersizeNONE,
3353                                        FFEEXPR_contextLET);
3354             code = FFECOM_gfrtPOW_ZZ;   /* Overlapping result okay. */
3355             ref = TRUE;                 /* Pass arguments by reference. */
3356             break;
3357
3358           default:
3359             assert ("bad pow_x*" == NULL);
3360             code = FFECOM_gfrtPOW_II;
3361             break;
3362           }
3363         return ffecom_call_binop_ (ffecom_gfrt_tree_ (code),
3364                                    ffecom_gfrt_kindtype (code),
3365                                    (ffe_is_f2c_library ()
3366                                     && ffecom_gfrt_complex_[code]),
3367                                    tree_type, left, right,
3368                                    dest_tree, dest, dest_used,
3369                                    NULL_TREE, FALSE, ref,
3370                                    ffebld_nonter_hook (expr));
3371       }
3372
3373     case FFEBLD_opNOT:
3374       switch (bt)
3375         {
3376         case FFEINFO_basictypeLOGICAL:
3377           item = ffecom_truth_value_invert (ffecom_expr (ffebld_left (expr)));
3378           return convert (tree_type, item);
3379
3380         case FFEINFO_basictypeINTEGER:
3381           return ffecom_1 (BIT_NOT_EXPR, tree_type,
3382                            ffecom_expr (ffebld_left (expr)));
3383
3384         default:
3385           assert ("NOT bad basictype" == NULL);
3386           /* Fall through. */
3387         case FFEINFO_basictypeANY:
3388           return error_mark_node;
3389         }
3390       break;
3391
3392     case FFEBLD_opFUNCREF:
3393       assert (ffeinfo_basictype (ffebld_info (expr))
3394               != FFEINFO_basictypeCHARACTER);
3395       /* Fall through.   */
3396     case FFEBLD_opSUBRREF:
3397       if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
3398           == FFEINFO_whereINTRINSIC)
3399         {                       /* Invocation of an intrinsic. */
3400           item = ffecom_expr_intrinsic_ (expr, dest_tree, dest,
3401                                          dest_used);
3402           return item;
3403         }
3404       s = ffebld_symter (ffebld_left (expr));
3405       dt = ffesymbol_hook (s).decl_tree;
3406       if (dt == NULL_TREE)
3407         {
3408           s = ffecom_sym_transform_ (s);
3409           dt = ffesymbol_hook (s).decl_tree;
3410         }
3411       if (dt == error_mark_node)
3412         return dt;
3413
3414       if (ffesymbol_hook (s).addr)
3415         item = dt;
3416       else
3417         item = ffecom_1_fn (dt);
3418
3419       if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
3420         args = ffecom_list_expr (ffebld_right (expr));
3421       else
3422         args = ffecom_list_ptr_to_expr (ffebld_right (expr));
3423
3424       if (args == error_mark_node)
3425         return error_mark_node;
3426
3427       item = ffecom_call_ (item, kt,
3428                            ffesymbol_is_f2c (s)
3429                            && (bt == FFEINFO_basictypeCOMPLEX)
3430                            && (ffesymbol_where (s)
3431                                != FFEINFO_whereCONSTANT),
3432                            tree_type,
3433                            args,
3434                            dest_tree, dest, dest_used,
3435                            error_mark_node, FALSE,
3436                            ffebld_nonter_hook (expr));
3437       TREE_SIDE_EFFECTS (item) = 1;
3438       return item;
3439
3440     case FFEBLD_opAND:
3441       switch (bt)
3442         {
3443         case FFEINFO_basictypeLOGICAL:
3444           item
3445             = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3446                        ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3447                      ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3448           return convert (tree_type, item);
3449
3450         case FFEINFO_basictypeINTEGER:
3451           return ffecom_2 (BIT_AND_EXPR, tree_type,
3452                            ffecom_expr (ffebld_left (expr)),
3453                            ffecom_expr (ffebld_right (expr)));
3454
3455         default:
3456           assert ("AND bad basictype" == NULL);
3457           /* Fall through. */
3458         case FFEINFO_basictypeANY:
3459           return error_mark_node;
3460         }
3461       break;
3462
3463     case FFEBLD_opOR:
3464       switch (bt)
3465         {
3466         case FFEINFO_basictypeLOGICAL:
3467           item
3468             = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
3469                        ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3470                      ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3471           return convert (tree_type, item);
3472
3473         case FFEINFO_basictypeINTEGER:
3474           return ffecom_2 (BIT_IOR_EXPR, tree_type,
3475                            ffecom_expr (ffebld_left (expr)),
3476                            ffecom_expr (ffebld_right (expr)));
3477
3478         default:
3479           assert ("OR bad basictype" == NULL);
3480           /* Fall through. */
3481         case FFEINFO_basictypeANY:
3482           return error_mark_node;
3483         }
3484       break;
3485
3486     case FFEBLD_opXOR:
3487     case FFEBLD_opNEQV:
3488       switch (bt)
3489         {
3490         case FFEINFO_basictypeLOGICAL:
3491           item
3492             = ffecom_2 (NE_EXPR, integer_type_node,
3493                         ffecom_expr (ffebld_left (expr)),
3494                         ffecom_expr (ffebld_right (expr)));
3495           return convert (tree_type, ffecom_truth_value (item));
3496
3497         case FFEINFO_basictypeINTEGER:
3498           return ffecom_2 (BIT_XOR_EXPR, tree_type,
3499                            ffecom_expr (ffebld_left (expr)),
3500                            ffecom_expr (ffebld_right (expr)));
3501
3502         default:
3503           assert ("XOR/NEQV bad basictype" == NULL);
3504           /* Fall through. */
3505         case FFEINFO_basictypeANY:
3506           return error_mark_node;
3507         }
3508       break;
3509
3510     case FFEBLD_opEQV:
3511       switch (bt)
3512         {
3513         case FFEINFO_basictypeLOGICAL:
3514           item
3515             = ffecom_2 (EQ_EXPR, integer_type_node,
3516                         ffecom_expr (ffebld_left (expr)),
3517                         ffecom_expr (ffebld_right (expr)));
3518           return convert (tree_type, ffecom_truth_value (item));
3519
3520         case FFEINFO_basictypeINTEGER:
3521           return
3522             ffecom_1 (BIT_NOT_EXPR, tree_type,
3523                       ffecom_2 (BIT_XOR_EXPR, tree_type,
3524                                 ffecom_expr (ffebld_left (expr)),
3525                                 ffecom_expr (ffebld_right (expr))));
3526
3527         default:
3528           assert ("EQV bad basictype" == NULL);
3529           /* Fall through. */
3530         case FFEINFO_basictypeANY:
3531           return error_mark_node;
3532         }
3533       break;
3534
3535     case FFEBLD_opCONVERT:
3536       if (ffebld_op (ffebld_left (expr)) == FFEBLD_opANY)
3537         return error_mark_node;
3538
3539       switch (bt)
3540         {
3541         case FFEINFO_basictypeLOGICAL:
3542         case FFEINFO_basictypeINTEGER:
3543         case FFEINFO_basictypeREAL:
3544           return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3545
3546         case FFEINFO_basictypeCOMPLEX:
3547           switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3548             {
3549             case FFEINFO_basictypeINTEGER:
3550             case FFEINFO_basictypeLOGICAL:
3551             case FFEINFO_basictypeREAL:
3552               item = ffecom_expr (ffebld_left (expr));
3553               if (item == error_mark_node)
3554                 return error_mark_node;
3555               /* convert() takes care of converting to the subtype first,
3556                  at least in gcc-2.7.2. */
3557               item = convert (tree_type, item);
3558               return item;
3559
3560             case FFEINFO_basictypeCOMPLEX:
3561               return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3562
3563             default:
3564               assert ("CONVERT COMPLEX bad basictype" == NULL);
3565               /* Fall through. */
3566             case FFEINFO_basictypeANY:
3567               return error_mark_node;
3568             }
3569           break;
3570
3571         default:
3572           assert ("CONVERT bad basictype" == NULL);
3573           /* Fall through. */
3574         case FFEINFO_basictypeANY:
3575           return error_mark_node;
3576         }
3577       break;
3578
3579     case FFEBLD_opLT:
3580       code = LT_EXPR;
3581       goto relational;          /* :::::::::::::::::::: */
3582
3583     case FFEBLD_opLE:
3584       code = LE_EXPR;
3585       goto relational;          /* :::::::::::::::::::: */
3586
3587     case FFEBLD_opEQ:
3588       code = EQ_EXPR;
3589       goto relational;          /* :::::::::::::::::::: */
3590
3591     case FFEBLD_opNE:
3592       code = NE_EXPR;
3593       goto relational;          /* :::::::::::::::::::: */
3594
3595     case FFEBLD_opGT:
3596       code = GT_EXPR;
3597       goto relational;          /* :::::::::::::::::::: */
3598
3599     case FFEBLD_opGE:
3600       code = GE_EXPR;
3601
3602     relational:         /* :::::::::::::::::::: */
3603       switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3604         {
3605         case FFEINFO_basictypeLOGICAL:
3606         case FFEINFO_basictypeINTEGER:
3607         case FFEINFO_basictypeREAL:
3608           item = ffecom_2 (code, integer_type_node,
3609                            ffecom_expr (ffebld_left (expr)),
3610                            ffecom_expr (ffebld_right (expr)));
3611           return convert (tree_type, item);
3612
3613         case FFEINFO_basictypeCOMPLEX:
3614           assert (code == EQ_EXPR || code == NE_EXPR);
3615           {
3616             tree real_type;
3617             tree arg1 = ffecom_expr (ffebld_left (expr));
3618             tree arg2 = ffecom_expr (ffebld_right (expr));
3619
3620             if (arg1 == error_mark_node || arg2 == error_mark_node)
3621               return error_mark_node;
3622
3623             arg1 = ffecom_save_tree (arg1);
3624             arg2 = ffecom_save_tree (arg2);
3625
3626             if (TREE_CODE (TREE_TYPE (arg1)) == COMPLEX_TYPE)
3627               {
3628                 real_type = TREE_TYPE (TREE_TYPE (arg1));
3629                 assert (real_type == TREE_TYPE (TREE_TYPE (arg2)));
3630               }
3631             else
3632               {
3633                 real_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg1)));
3634                 assert (real_type == TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg2))));
3635               }
3636
3637             item
3638               = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3639                           ffecom_2 (EQ_EXPR, integer_type_node,
3640                                   ffecom_1 (REALPART_EXPR, real_type, arg1),
3641                                  ffecom_1 (REALPART_EXPR, real_type, arg2)),
3642                           ffecom_2 (EQ_EXPR, integer_type_node,
3643                                   ffecom_1 (IMAGPART_EXPR, real_type, arg1),
3644                                     ffecom_1 (IMAGPART_EXPR, real_type,
3645                                               arg2)));
3646             if (code == EQ_EXPR)
3647               item = ffecom_truth_value (item);
3648             else
3649               item = ffecom_truth_value_invert (item);
3650             return convert (tree_type, item);
3651           }
3652
3653         case FFEINFO_basictypeCHARACTER:
3654           {
3655             ffebld left = ffebld_left (expr);
3656             ffebld right = ffebld_right (expr);
3657             tree left_tree;
3658             tree right_tree;
3659             tree left_length;
3660             tree right_length;
3661
3662             /* f2c run-time functions do the implicit blank-padding for us,
3663                so we don't usually have to implement blank-padding ourselves.
3664                (The exception is when we pass an argument to a separately
3665                compiled statement function -- if we know the arg is not the
3666                same length as the dummy, we must truncate or extend it.  If
3667                we "inline" statement functions, that necessity goes away as
3668                well.)
3669
3670                Strip off the CONVERT operators that blank-pad.  (Truncation by
3671                CONVERT shouldn't happen here, but it can happen in
3672                assignments.) */
3673
3674             while (ffebld_op (left) == FFEBLD_opCONVERT)
3675               left = ffebld_left (left);
3676             while (ffebld_op (right) == FFEBLD_opCONVERT)
3677               right = ffebld_left (right);
3678
3679             left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
3680             right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
3681
3682             if (left_tree == error_mark_node || left_length == error_mark_node
3683                 || right_tree == error_mark_node
3684                 || right_length == error_mark_node)
3685               return error_mark_node;
3686
3687             if ((ffebld_size_known (left) == 1)
3688                 && (ffebld_size_known (right) == 1))
3689               {
3690                 left_tree
3691                   = ffecom_1 (INDIRECT_REF,
3692                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3693                               left_tree);
3694                 right_tree
3695                   = ffecom_1 (INDIRECT_REF,
3696                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3697                               right_tree);
3698
3699                 item
3700                   = ffecom_2 (code, integer_type_node,
3701                               ffecom_2 (ARRAY_REF,
3702                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3703                                         left_tree,
3704                                         integer_one_node),
3705                               ffecom_2 (ARRAY_REF,
3706                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3707                                         right_tree,
3708                                         integer_one_node));
3709               }
3710             else
3711               {
3712                 item = build_tree_list (NULL_TREE, left_tree);
3713                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, right_tree);
3714                 TREE_CHAIN (TREE_CHAIN (item)) = build_tree_list (NULL_TREE,
3715                                                                left_length);
3716                 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
3717                   = build_tree_list (NULL_TREE, right_length);
3718                 item = ffecom_call_gfrt (FFECOM_gfrtCMP, item, NULL_TREE);
3719                 item = ffecom_2 (code, integer_type_node,
3720                                  item,
3721                                  convert (TREE_TYPE (item),
3722                                           integer_zero_node));
3723               }
3724             item = convert (tree_type, item);
3725           }
3726
3727           return item;
3728
3729         default:
3730           assert ("relational bad basictype" == NULL);
3731           /* Fall through. */
3732         case FFEINFO_basictypeANY:
3733           return error_mark_node;
3734         }
3735       break;
3736
3737     case FFEBLD_opPERCENT_LOC:
3738       item = ffecom_arg_ptr_to_expr (ffebld_left (expr), &list);
3739       return convert (tree_type, item);
3740
3741     case FFEBLD_opPERCENT_VAL:
3742       item = ffecom_arg_expr (ffebld_left (expr), &list);
3743       return convert (tree_type, item);
3744
3745     case FFEBLD_opITEM:
3746     case FFEBLD_opSTAR:
3747     case FFEBLD_opBOUNDS:
3748     case FFEBLD_opREPEAT:
3749     case FFEBLD_opLABTER:
3750     case FFEBLD_opLABTOK:
3751     case FFEBLD_opIMPDO:
3752     case FFEBLD_opCONCATENATE:
3753     case FFEBLD_opSUBSTR:
3754     default:
3755       assert ("bad op" == NULL);
3756       /* Fall through. */
3757     case FFEBLD_opANY:
3758       return error_mark_node;
3759     }
3760
3761 #if 1
3762   assert ("didn't think anything got here anymore!!" == NULL);
3763 #else
3764   switch (ffebld_arity (expr))
3765     {
3766     case 2:
3767       TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3768       TREE_OPERAND (item, 1) = ffecom_expr (ffebld_right (expr));
3769       if (TREE_OPERAND (item, 0) == error_mark_node
3770           || TREE_OPERAND (item, 1) == error_mark_node)
3771         return error_mark_node;
3772       break;
3773
3774     case 1:
3775       TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3776       if (TREE_OPERAND (item, 0) == error_mark_node)
3777         return error_mark_node;
3778       break;
3779
3780     default:
3781       break;
3782     }
3783
3784   return fold (item);
3785 #endif
3786 }
3787
3788 /* Returns the tree that does the intrinsic invocation.
3789
3790    Note: this function applies only to intrinsics returning
3791    CHARACTER*1 or non-CHARACTER results, and to intrinsic
3792    subroutines.  */
3793
3794 static tree
3795 ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree, ffebld dest,
3796                         bool *dest_used)
3797 {
3798   tree expr_tree;
3799   tree saved_expr1;             /* For those who need it. */
3800   tree saved_expr2;             /* For those who need it. */
3801   ffeinfoBasictype bt;
3802   ffeinfoKindtype kt;
3803   tree tree_type;
3804   tree arg1_type;
3805   tree real_type;               /* REAL type corresponding to COMPLEX. */
3806   tree tempvar;
3807   ffebld list = ffebld_right (expr);    /* List of (some) args. */
3808   ffebld arg1;                  /* For handy reference. */
3809   ffebld arg2;
3810   ffebld arg3;
3811   ffeintrinImp codegen_imp;
3812   ffecomGfrt gfrt;
3813
3814   assert (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER);
3815
3816   if (dest_used != NULL)
3817     *dest_used = FALSE;
3818
3819   bt = ffeinfo_basictype (ffebld_info (expr));
3820   kt = ffeinfo_kindtype (ffebld_info (expr));
3821   tree_type = ffecom_tree_type[bt][kt];
3822
3823   if (list != NULL)
3824     {
3825       arg1 = ffebld_head (list);
3826       if (arg1 != NULL && ffebld_op (arg1) == FFEBLD_opANY)
3827         return error_mark_node;
3828       if ((list = ffebld_trail (list)) != NULL)
3829         {
3830           arg2 = ffebld_head (list);
3831           if (arg2 != NULL && ffebld_op (arg2) == FFEBLD_opANY)
3832             return error_mark_node;
3833           if ((list = ffebld_trail (list)) != NULL)
3834             {
3835               arg3 = ffebld_head (list);
3836               if (arg3 != NULL && ffebld_op (arg3) == FFEBLD_opANY)
3837                 return error_mark_node;
3838             }
3839           else
3840             arg3 = NULL;
3841         }
3842       else
3843         arg2 = arg3 = NULL;
3844     }
3845   else
3846     arg1 = arg2 = arg3 = NULL;
3847
3848   /* <list> ends up at the opITEM of the 3rd arg, or NULL if there are < 3
3849      args.  This is used by the MAX/MIN expansions. */
3850
3851   if (arg1 != NULL)
3852     arg1_type = ffecom_tree_type
3853       [ffeinfo_basictype (ffebld_info (arg1))]
3854       [ffeinfo_kindtype (ffebld_info (arg1))];
3855   else
3856     arg1_type = NULL_TREE;      /* Really not needed, but might catch bugs
3857                                    here. */
3858
3859   /* There are several ways for each of the cases in the following switch
3860      statements to exit (from simplest to use to most complicated):
3861
3862      break;  (when expr_tree == NULL)
3863
3864      A standard call is made to the specific intrinsic just as if it had been
3865      passed in as a dummy procedure and called as any old procedure.  This
3866      method can produce slower code but in some cases it's the easiest way for
3867      now.  However, if a (presumably faster) direct call is available,
3868      that is used, so this is the easiest way in many more cases now.
3869
3870      gfrt = FFECOM_gfrtWHATEVER;
3871      break;
3872
3873      gfrt contains the gfrt index of a library function to call, passing the
3874      argument(s) by value rather than by reference.  Used when a more
3875      careful choice of library function is needed than that provided
3876      by the vanilla `break;'.
3877
3878      return expr_tree;
3879
3880      The expr_tree has been completely set up and is ready to be returned
3881      as is.  No further actions are taken.  Use this when the tree is not
3882      in the simple form for one of the arity_n labels.   */
3883
3884   /* For info on how the switch statement cases were written, see the files
3885      enclosed in comments below the switch statement. */
3886
3887   codegen_imp = ffebld_symter_implementation (ffebld_left (expr));
3888   gfrt = ffeintrin_gfrt_direct (codegen_imp);
3889   if (gfrt == FFECOM_gfrt)
3890     gfrt = ffeintrin_gfrt_indirect (codegen_imp);
3891
3892   switch (codegen_imp)
3893     {
3894     case FFEINTRIN_impABS:
3895     case FFEINTRIN_impCABS:
3896     case FFEINTRIN_impCDABS:
3897     case FFEINTRIN_impDABS:
3898     case FFEINTRIN_impIABS:
3899       if (ffeinfo_basictype (ffebld_info (arg1))
3900           == FFEINFO_basictypeCOMPLEX)
3901         {
3902           if (kt == FFEINFO_kindtypeREAL1)
3903             gfrt = FFECOM_gfrtCABS;
3904           else if (kt == FFEINFO_kindtypeREAL2)
3905             gfrt = FFECOM_gfrtCDABS;
3906           break;
3907         }
3908       return ffecom_1 (ABS_EXPR, tree_type,
3909                        convert (tree_type, ffecom_expr (arg1)));
3910
3911     case FFEINTRIN_impACOS:
3912     case FFEINTRIN_impDACOS:
3913       break;
3914
3915     case FFEINTRIN_impAIMAG:
3916     case FFEINTRIN_impDIMAG:
3917     case FFEINTRIN_impIMAGPART:
3918       if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
3919         arg1_type = TREE_TYPE (arg1_type);
3920       else
3921         arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
3922
3923       return
3924         convert (tree_type,
3925                  ffecom_1 (IMAGPART_EXPR, arg1_type,
3926                            ffecom_expr (arg1)));
3927
3928     case FFEINTRIN_impAINT:
3929     case FFEINTRIN_impDINT:
3930 #if 0
3931       /* ~~Someday implement FIX_TRUNC_EXPR yielding same type as arg.  */
3932       return ffecom_1 (FIX_TRUNC_EXPR, tree_type, ffecom_expr (arg1));
3933 #else /* in the meantime, must use floor to avoid range problems with ints */
3934       /* r__1 = r1 >= 0 ? floor(r1) : -floor(-r1); */
3935       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
3936       return
3937         convert (tree_type,
3938                  ffecom_3 (COND_EXPR, double_type_node,
3939                            ffecom_truth_value
3940                            (ffecom_2 (GE_EXPR, integer_type_node,
3941                                       saved_expr1,
3942                                       convert (arg1_type,
3943                                                ffecom_float_zero_))),
3944                            ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
3945                                              build_tree_list (NULL_TREE,
3946                                                   convert (double_type_node,
3947                                                            saved_expr1)),
3948                                              NULL_TREE),
3949                            ffecom_1 (NEGATE_EXPR, double_type_node,
3950                                      ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
3951                                                  build_tree_list (NULL_TREE,
3952                                                   convert (double_type_node,
3953                                                       ffecom_1 (NEGATE_EXPR,
3954                                                                 arg1_type,
3955                                                                saved_expr1))),
3956                                                        NULL_TREE)
3957                                      ))
3958                  );
3959 #endif
3960
3961     case FFEINTRIN_impANINT:
3962     case FFEINTRIN_impDNINT:
3963 #if 0                           /* This way of doing it won't handle real
3964                                    numbers of large magnitudes. */
3965       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
3966       expr_tree = convert (tree_type,
3967                            convert (integer_type_node,
3968                                     ffecom_3 (COND_EXPR, tree_type,
3969                                               ffecom_truth_value
3970                                               (ffecom_2 (GE_EXPR,
3971                                                          integer_type_node,
3972                                                          saved_expr1,
3973                                                        ffecom_float_zero_)),
3974                                               ffecom_2 (PLUS_EXPR,
3975                                                         tree_type,
3976                                                         saved_expr1,
3977                                                         ffecom_float_half_),
3978                                               ffecom_2 (MINUS_EXPR,
3979                                                         tree_type,
3980                                                         saved_expr1,
3981                                                      ffecom_float_half_))));
3982       return expr_tree;
3983 #else /* So we instead call floor. */
3984       /* r__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1) */
3985       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
3986       return
3987         convert (tree_type,
3988                  ffecom_3 (COND_EXPR, double_type_node,
3989                            ffecom_truth_value
3990                            (ffecom_2 (GE_EXPR, integer_type_node,
3991                                       saved_expr1,
3992                                       convert (arg1_type,
3993                                                ffecom_float_zero_))),
3994                            ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
3995                                              build_tree_list (NULL_TREE,
3996                                                   convert (double_type_node,
3997                                                            ffecom_2 (PLUS_EXPR,
3998                                                                      arg1_type,
3999                                                                      saved_expr1,
4000                                                                      convert (arg1_type,
4001                                                                               ffecom_float_half_)))),
4002                                              NULL_TREE),
4003                            ffecom_1 (NEGATE_EXPR, double_type_node,
4004                                      ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4005                                                        build_tree_list (NULL_TREE,
4006                                                                         convert (double_type_node,
4007                                                                                  ffecom_2 (MINUS_EXPR,
4008                                                                                            arg1_type,
4009                                                                                            convert (arg1_type,
4010                                                                                                     ffecom_float_half_),
4011                                                                                            saved_expr1))),
4012                                                        NULL_TREE))
4013                            )
4014                  );
4015 #endif
4016
4017     case FFEINTRIN_impASIN:
4018     case FFEINTRIN_impDASIN:
4019     case FFEINTRIN_impATAN:
4020     case FFEINTRIN_impDATAN:
4021     case FFEINTRIN_impATAN2:
4022     case FFEINTRIN_impDATAN2:
4023       break;
4024
4025     case FFEINTRIN_impCHAR:
4026     case FFEINTRIN_impACHAR:
4027       tempvar = ffebld_nonter_hook (expr);
4028       assert (tempvar);
4029       {
4030         tree tmv = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (tempvar)));
4031
4032         expr_tree = ffecom_modify (tmv,
4033                                    ffecom_2 (ARRAY_REF, tmv, tempvar,
4034                                              integer_one_node),
4035                                    convert (tmv, ffecom_expr (arg1)));
4036       }
4037       expr_tree = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar),
4038                             expr_tree,
4039                             tempvar);
4040       expr_tree = ffecom_1 (ADDR_EXPR,
4041                             build_pointer_type (TREE_TYPE (expr_tree)),
4042                             expr_tree);
4043       return expr_tree;
4044
4045     case FFEINTRIN_impCMPLX:
4046     case FFEINTRIN_impDCMPLX:
4047       if (arg2 == NULL)
4048         return
4049           convert (tree_type, ffecom_expr (arg1));
4050
4051       real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4052       return
4053         ffecom_2 (COMPLEX_EXPR, tree_type,
4054                   convert (real_type, ffecom_expr (arg1)),
4055                   convert (real_type,
4056                            ffecom_expr (arg2)));
4057
4058     case FFEINTRIN_impCOMPLEX:
4059       return
4060         ffecom_2 (COMPLEX_EXPR, tree_type,
4061                   ffecom_expr (arg1),
4062                   ffecom_expr (arg2));
4063
4064     case FFEINTRIN_impCONJG:
4065     case FFEINTRIN_impDCONJG:
4066       {
4067         tree arg1_tree;
4068
4069         real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4070         arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4071         return
4072           ffecom_2 (COMPLEX_EXPR, tree_type,
4073                     ffecom_1 (REALPART_EXPR, real_type, arg1_tree),
4074                     ffecom_1 (NEGATE_EXPR, real_type,
4075                               ffecom_1 (IMAGPART_EXPR, real_type, arg1_tree)));
4076       }
4077
4078     case FFEINTRIN_impCOS:
4079     case FFEINTRIN_impCCOS:
4080     case FFEINTRIN_impCDCOS:
4081     case FFEINTRIN_impDCOS:
4082       if (bt == FFEINFO_basictypeCOMPLEX)
4083         {
4084           if (kt == FFEINFO_kindtypeREAL1)
4085             gfrt = FFECOM_gfrtCCOS;     /* Overlapping result okay. */
4086           else if (kt == FFEINFO_kindtypeREAL2)
4087             gfrt = FFECOM_gfrtCDCOS;    /* Overlapping result okay. */
4088         }
4089       break;
4090
4091     case FFEINTRIN_impCOSH:
4092     case FFEINTRIN_impDCOSH:
4093       break;
4094
4095     case FFEINTRIN_impDBLE:
4096     case FFEINTRIN_impDFLOAT:
4097     case FFEINTRIN_impDREAL:
4098     case FFEINTRIN_impFLOAT:
4099     case FFEINTRIN_impIDINT:
4100     case FFEINTRIN_impIFIX:
4101     case FFEINTRIN_impINT2:
4102     case FFEINTRIN_impINT8:
4103     case FFEINTRIN_impINT:
4104     case FFEINTRIN_impLONG:
4105     case FFEINTRIN_impREAL:
4106     case FFEINTRIN_impSHORT:
4107     case FFEINTRIN_impSNGL:
4108       return convert (tree_type, ffecom_expr (arg1));
4109
4110     case FFEINTRIN_impDIM:
4111     case FFEINTRIN_impDDIM:
4112     case FFEINTRIN_impIDIM:
4113       saved_expr1 = ffecom_save_tree (convert (tree_type,
4114                                                ffecom_expr (arg1)));
4115       saved_expr2 = ffecom_save_tree (convert (tree_type,
4116                                                ffecom_expr (arg2)));
4117       return
4118         ffecom_3 (COND_EXPR, tree_type,
4119                   ffecom_truth_value
4120                   (ffecom_2 (GT_EXPR, integer_type_node,
4121                              saved_expr1,
4122                              saved_expr2)),
4123                   ffecom_2 (MINUS_EXPR, tree_type,
4124                             saved_expr1,
4125                             saved_expr2),
4126                   convert (tree_type, ffecom_float_zero_));
4127
4128     case FFEINTRIN_impDPROD:
4129       return
4130         ffecom_2 (MULT_EXPR, tree_type,
4131                   convert (tree_type, ffecom_expr (arg1)),
4132                   convert (tree_type, ffecom_expr (arg2)));
4133
4134     case FFEINTRIN_impEXP:
4135     case FFEINTRIN_impCDEXP:
4136     case FFEINTRIN_impCEXP:
4137     case FFEINTRIN_impDEXP:
4138       if (bt == FFEINFO_basictypeCOMPLEX)
4139         {
4140           if (kt == FFEINFO_kindtypeREAL1)
4141             gfrt = FFECOM_gfrtCEXP;     /* Overlapping result okay. */
4142           else if (kt == FFEINFO_kindtypeREAL2)
4143             gfrt = FFECOM_gfrtCDEXP;    /* Overlapping result okay. */
4144         }
4145       break;
4146
4147     case FFEINTRIN_impICHAR:
4148     case FFEINTRIN_impIACHAR:
4149 #if 0                           /* The simple approach. */
4150       ffecom_char_args_ (&expr_tree, &saved_expr1 /* Ignored */ , arg1);
4151       expr_tree
4152         = ffecom_1 (INDIRECT_REF,
4153                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4154                     expr_tree);
4155       expr_tree
4156         = ffecom_2 (ARRAY_REF,
4157                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4158                     expr_tree,
4159                     integer_one_node);
4160       return convert (tree_type, expr_tree);
4161 #else /* The more interesting (and more optimal) approach. */
4162       expr_tree = ffecom_intrinsic_ichar_ (tree_type, arg1, &saved_expr1);
4163       expr_tree = ffecom_3 (COND_EXPR, tree_type,
4164                             saved_expr1,
4165                             expr_tree,
4166                             convert (tree_type, integer_zero_node));
4167       return expr_tree;
4168 #endif
4169
4170     case FFEINTRIN_impINDEX:
4171       break;
4172
4173     case FFEINTRIN_impLEN:
4174 #if 0
4175       break;                                    /* The simple approach. */
4176 #else
4177       return ffecom_intrinsic_len_ (arg1);      /* The more optimal approach. */
4178 #endif
4179
4180     case FFEINTRIN_impLGE:
4181     case FFEINTRIN_impLGT:
4182     case FFEINTRIN_impLLE:
4183     case FFEINTRIN_impLLT:
4184       break;
4185
4186     case FFEINTRIN_impLOG:
4187     case FFEINTRIN_impALOG:
4188     case FFEINTRIN_impCDLOG:
4189     case FFEINTRIN_impCLOG:
4190     case FFEINTRIN_impDLOG:
4191       if (bt == FFEINFO_basictypeCOMPLEX)
4192         {
4193           if (kt == FFEINFO_kindtypeREAL1)
4194             gfrt = FFECOM_gfrtCLOG;     /* Overlapping result okay. */
4195           else if (kt == FFEINFO_kindtypeREAL2)
4196             gfrt = FFECOM_gfrtCDLOG;    /* Overlapping result okay. */
4197         }
4198       break;
4199
4200     case FFEINTRIN_impLOG10:
4201     case FFEINTRIN_impALOG10:
4202     case FFEINTRIN_impDLOG10:
4203       if (gfrt != FFECOM_gfrt)
4204         break;  /* Already picked one, stick with it. */
4205
4206       if (kt == FFEINFO_kindtypeREAL1)
4207         /* We used to call FFECOM_gfrtALOG10 here.  */
4208         gfrt = FFECOM_gfrtL_LOG10;
4209       else if (kt == FFEINFO_kindtypeREAL2)
4210         /* We used to call FFECOM_gfrtDLOG10 here.  */
4211         gfrt = FFECOM_gfrtL_LOG10;
4212       break;
4213
4214     case FFEINTRIN_impMAX:
4215     case FFEINTRIN_impAMAX0:
4216     case FFEINTRIN_impAMAX1:
4217     case FFEINTRIN_impDMAX1:
4218     case FFEINTRIN_impMAX0:
4219     case FFEINTRIN_impMAX1:
4220       if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4221         arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4222       else
4223         arg1_type = tree_type;
4224       expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4225                             convert (arg1_type, ffecom_expr (arg1)),
4226                             convert (arg1_type, ffecom_expr (arg2)));
4227       for (; list != NULL; list = ffebld_trail (list))
4228         {
4229           if ((ffebld_head (list) == NULL)
4230               || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4231             continue;
4232           expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4233                                 expr_tree,
4234                                 convert (arg1_type,
4235                                          ffecom_expr (ffebld_head (list))));
4236         }
4237       return convert (tree_type, expr_tree);
4238
4239     case FFEINTRIN_impMIN:
4240     case FFEINTRIN_impAMIN0:
4241     case FFEINTRIN_impAMIN1:
4242     case FFEINTRIN_impDMIN1:
4243     case FFEINTRIN_impMIN0:
4244     case FFEINTRIN_impMIN1:
4245       if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4246         arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4247       else
4248         arg1_type = tree_type;
4249       expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4250                             convert (arg1_type, ffecom_expr (arg1)),
4251                             convert (arg1_type, ffecom_expr (arg2)));
4252       for (; list != NULL; list = ffebld_trail (list))
4253         {
4254           if ((ffebld_head (list) == NULL)
4255               || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4256             continue;
4257           expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4258                                 expr_tree,
4259                                 convert (arg1_type,
4260                                          ffecom_expr (ffebld_head (list))));
4261         }
4262       return convert (tree_type, expr_tree);
4263
4264     case FFEINTRIN_impMOD:
4265     case FFEINTRIN_impAMOD:
4266     case FFEINTRIN_impDMOD:
4267       if (bt != FFEINFO_basictypeREAL)
4268         return ffecom_2 (TRUNC_MOD_EXPR, tree_type,
4269                          convert (tree_type, ffecom_expr (arg1)),
4270                          convert (tree_type, ffecom_expr (arg2)));
4271
4272       if (kt == FFEINFO_kindtypeREAL1)
4273         /* We used to call FFECOM_gfrtAMOD here.  */
4274         gfrt = FFECOM_gfrtL_FMOD;
4275       else if (kt == FFEINFO_kindtypeREAL2)
4276         /* We used to call FFECOM_gfrtDMOD here.  */
4277         gfrt = FFECOM_gfrtL_FMOD;
4278       break;
4279
4280     case FFEINTRIN_impNINT:
4281     case FFEINTRIN_impIDNINT:
4282 #if 0
4283       /* ~~Ideally FIX_ROUND_EXPR would be implemented, but it ain't yet.  */
4284       return ffecom_1 (FIX_ROUND_EXPR, tree_type, ffecom_expr (arg1));
4285 #else
4286       /* i__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1); */
4287       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4288       return
4289         convert (ffecom_integer_type_node,
4290                  ffecom_3 (COND_EXPR, arg1_type,
4291                            ffecom_truth_value
4292                            (ffecom_2 (GE_EXPR, integer_type_node,
4293                                       saved_expr1,
4294                                       convert (arg1_type,
4295                                                ffecom_float_zero_))),
4296                            ffecom_2 (PLUS_EXPR, arg1_type,
4297                                      saved_expr1,
4298                                      convert (arg1_type,
4299                                               ffecom_float_half_)),
4300                            ffecom_2 (MINUS_EXPR, arg1_type,
4301                                      saved_expr1,
4302                                      convert (arg1_type,
4303                                               ffecom_float_half_))));
4304 #endif
4305
4306     case FFEINTRIN_impSIGN:
4307     case FFEINTRIN_impDSIGN:
4308     case FFEINTRIN_impISIGN:
4309       {
4310         tree arg2_tree = ffecom_expr (arg2);
4311
4312         saved_expr1
4313           = ffecom_save_tree
4314           (ffecom_1 (ABS_EXPR, tree_type,
4315                      convert (tree_type,
4316                               ffecom_expr (arg1))));
4317         expr_tree
4318           = ffecom_3 (COND_EXPR, tree_type,
4319                       ffecom_truth_value
4320                       (ffecom_2 (GE_EXPR, integer_type_node,
4321                                  arg2_tree,
4322                                  convert (TREE_TYPE (arg2_tree),
4323                                           integer_zero_node))),
4324                       saved_expr1,
4325                       ffecom_1 (NEGATE_EXPR, tree_type, saved_expr1));
4326         /* Make sure SAVE_EXPRs get referenced early enough. */
4327         expr_tree
4328           = ffecom_2 (COMPOUND_EXPR, tree_type,
4329                       convert (void_type_node, saved_expr1),
4330                       expr_tree);
4331       }
4332       return expr_tree;
4333
4334     case FFEINTRIN_impSIN:
4335     case FFEINTRIN_impCDSIN:
4336     case FFEINTRIN_impCSIN:
4337     case FFEINTRIN_impDSIN:
4338       if (bt == FFEINFO_basictypeCOMPLEX)
4339         {
4340           if (kt == FFEINFO_kindtypeREAL1)
4341             gfrt = FFECOM_gfrtCSIN;     /* Overlapping result okay. */
4342           else if (kt == FFEINFO_kindtypeREAL2)
4343             gfrt = FFECOM_gfrtCDSIN;    /* Overlapping result okay. */
4344         }
4345       break;
4346
4347     case FFEINTRIN_impSINH:
4348     case FFEINTRIN_impDSINH:
4349       break;
4350
4351     case FFEINTRIN_impSQRT:
4352     case FFEINTRIN_impCDSQRT:
4353     case FFEINTRIN_impCSQRT:
4354     case FFEINTRIN_impDSQRT:
4355       if (bt == FFEINFO_basictypeCOMPLEX)
4356         {
4357           if (kt == FFEINFO_kindtypeREAL1)
4358             gfrt = FFECOM_gfrtCSQRT;    /* Overlapping result okay. */
4359           else if (kt == FFEINFO_kindtypeREAL2)
4360             gfrt = FFECOM_gfrtCDSQRT;   /* Overlapping result okay. */
4361         }
4362       break;
4363
4364     case FFEINTRIN_impTAN:
4365     case FFEINTRIN_impDTAN:
4366     case FFEINTRIN_impTANH:
4367     case FFEINTRIN_impDTANH:
4368       break;
4369
4370     case FFEINTRIN_impREALPART:
4371       if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
4372         arg1_type = TREE_TYPE (arg1_type);
4373       else
4374         arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
4375
4376       return
4377         convert (tree_type,
4378                  ffecom_1 (REALPART_EXPR, arg1_type,
4379                            ffecom_expr (arg1)));
4380
4381     case FFEINTRIN_impIAND:
4382     case FFEINTRIN_impAND:
4383       return ffecom_2 (BIT_AND_EXPR, tree_type,
4384                        convert (tree_type,
4385                                 ffecom_expr (arg1)),
4386                        convert (tree_type,
4387                                 ffecom_expr (arg2)));
4388
4389     case FFEINTRIN_impIOR:
4390     case FFEINTRIN_impOR:
4391       return ffecom_2 (BIT_IOR_EXPR, tree_type,
4392                        convert (tree_type,
4393                                 ffecom_expr (arg1)),
4394                        convert (tree_type,
4395                                 ffecom_expr (arg2)));
4396
4397     case FFEINTRIN_impIEOR:
4398     case FFEINTRIN_impXOR:
4399       return ffecom_2 (BIT_XOR_EXPR, tree_type,
4400                        convert (tree_type,
4401                                 ffecom_expr (arg1)),
4402                        convert (tree_type,
4403                                 ffecom_expr (arg2)));
4404
4405     case FFEINTRIN_impLSHIFT:
4406       return ffecom_2 (LSHIFT_EXPR, tree_type,
4407                        ffecom_expr (arg1),
4408                        convert (integer_type_node,
4409                                 ffecom_expr (arg2)));
4410
4411     case FFEINTRIN_impRSHIFT:
4412       return ffecom_2 (RSHIFT_EXPR, tree_type,
4413                        ffecom_expr (arg1),
4414                        convert (integer_type_node,
4415                                 ffecom_expr (arg2)));
4416
4417     case FFEINTRIN_impNOT:
4418       return ffecom_1 (BIT_NOT_EXPR, tree_type, ffecom_expr (arg1));
4419
4420     case FFEINTRIN_impBIT_SIZE:
4421       return convert (tree_type, TYPE_SIZE (arg1_type));
4422
4423     case FFEINTRIN_impBTEST:
4424       {
4425         ffetargetLogical1 target_true;
4426         ffetargetLogical1 target_false;
4427         tree true_tree;
4428         tree false_tree;
4429
4430         ffetarget_logical1 (&target_true, TRUE);
4431         ffetarget_logical1 (&target_false, FALSE);
4432         if (target_true == 1)
4433           true_tree = convert (tree_type, integer_one_node);
4434         else
4435           true_tree = convert (tree_type, build_int_2 (target_true, 0));
4436         if (target_false == 0)
4437           false_tree = convert (tree_type, integer_zero_node);
4438         else
4439           false_tree = convert (tree_type, build_int_2 (target_false, 0));
4440
4441         return
4442           ffecom_3 (COND_EXPR, tree_type,
4443                     ffecom_truth_value
4444                     (ffecom_2 (EQ_EXPR, integer_type_node,
4445                                ffecom_2 (BIT_AND_EXPR, arg1_type,
4446                                          ffecom_expr (arg1),
4447                                          ffecom_2 (LSHIFT_EXPR, arg1_type,
4448                                                    convert (arg1_type,
4449                                                           integer_one_node),
4450                                                    convert (integer_type_node,
4451                                                             ffecom_expr (arg2)))),
4452                                convert (arg1_type,
4453                                         integer_zero_node))),
4454                     false_tree,
4455                     true_tree);
4456       }
4457
4458     case FFEINTRIN_impIBCLR:
4459       return
4460         ffecom_2 (BIT_AND_EXPR, tree_type,
4461                   ffecom_expr (arg1),
4462                   ffecom_1 (BIT_NOT_EXPR, tree_type,
4463                             ffecom_2 (LSHIFT_EXPR, tree_type,
4464                                       convert (tree_type,
4465                                                integer_one_node),
4466                                       convert (integer_type_node,
4467                                                ffecom_expr (arg2)))));
4468
4469     case FFEINTRIN_impIBITS:
4470       {
4471         tree arg3_tree = ffecom_save_tree (convert (integer_type_node,
4472                                                     ffecom_expr (arg3)));
4473         tree uns_type
4474         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4475
4476         expr_tree
4477           = ffecom_2 (BIT_AND_EXPR, tree_type,
4478                       ffecom_2 (RSHIFT_EXPR, tree_type,
4479                                 ffecom_expr (arg1),
4480                                 convert (integer_type_node,
4481                                          ffecom_expr (arg2))),
4482                       convert (tree_type,
4483                                ffecom_2 (RSHIFT_EXPR, uns_type,
4484                                          ffecom_1 (BIT_NOT_EXPR,
4485                                                    uns_type,
4486                                                    convert (uns_type,
4487                                                         integer_zero_node)),
4488                                          ffecom_2 (MINUS_EXPR,
4489                                                    integer_type_node,
4490                                                    TYPE_SIZE (uns_type),
4491                                                    arg3_tree))));
4492         /* Fix up, because the RSHIFT_EXPR above can't shift over TYPE_SIZE.  */
4493         expr_tree
4494           = ffecom_3 (COND_EXPR, tree_type,
4495                       ffecom_truth_value
4496                       (ffecom_2 (NE_EXPR, integer_type_node,
4497                                  arg3_tree,
4498                                  integer_zero_node)),
4499                       expr_tree,
4500                       convert (tree_type, integer_zero_node));
4501       }
4502       return expr_tree;
4503
4504     case FFEINTRIN_impIBSET:
4505       return
4506         ffecom_2 (BIT_IOR_EXPR, tree_type,
4507                   ffecom_expr (arg1),
4508                   ffecom_2 (LSHIFT_EXPR, tree_type,
4509                             convert (tree_type, integer_one_node),
4510                             convert (integer_type_node,
4511                                      ffecom_expr (arg2))));
4512
4513     case FFEINTRIN_impISHFT:
4514       {
4515         tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4516         tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4517                                                     ffecom_expr (arg2)));
4518         tree uns_type
4519         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4520
4521         expr_tree
4522           = ffecom_3 (COND_EXPR, tree_type,
4523                       ffecom_truth_value
4524                       (ffecom_2 (GE_EXPR, integer_type_node,
4525                                  arg2_tree,
4526                                  integer_zero_node)),
4527                       ffecom_2 (LSHIFT_EXPR, tree_type,
4528                                 arg1_tree,
4529                                 arg2_tree),
4530                       convert (tree_type,
4531                                ffecom_2 (RSHIFT_EXPR, uns_type,
4532                                          convert (uns_type, arg1_tree),
4533                                          ffecom_1 (NEGATE_EXPR,
4534                                                    integer_type_node,
4535                                                    arg2_tree))));
4536         /* Fix up, because {L|R}SHIFT_EXPR don't go over TYPE_SIZE bounds.  */
4537         expr_tree
4538           = ffecom_3 (COND_EXPR, tree_type,
4539                       ffecom_truth_value
4540                       (ffecom_2 (NE_EXPR, integer_type_node,
4541                                  ffecom_1 (ABS_EXPR,
4542                                            integer_type_node,
4543                                            arg2_tree),
4544                                  TYPE_SIZE (uns_type))),
4545                       expr_tree,
4546                       convert (tree_type, integer_zero_node));
4547         /* Make sure SAVE_EXPRs get referenced early enough. */
4548         expr_tree
4549           = ffecom_2 (COMPOUND_EXPR, tree_type,
4550                       convert (void_type_node, arg1_tree),
4551                       ffecom_2 (COMPOUND_EXPR, tree_type,
4552                                 convert (void_type_node, arg2_tree),
4553                                 expr_tree));
4554       }
4555       return expr_tree;
4556
4557     case FFEINTRIN_impISHFTC:
4558       {
4559         tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4560         tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4561                                                     ffecom_expr (arg2)));
4562         tree arg3_tree = (arg3 == NULL) ? TYPE_SIZE (tree_type)
4563         : ffecom_save_tree (convert (integer_type_node, ffecom_expr (arg3)));
4564         tree shift_neg;
4565         tree shift_pos;
4566         tree mask_arg1;
4567         tree masked_arg1;
4568         tree uns_type
4569         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4570
4571         mask_arg1
4572           = ffecom_2 (LSHIFT_EXPR, tree_type,
4573                       ffecom_1 (BIT_NOT_EXPR, tree_type,
4574                                 convert (tree_type, integer_zero_node)),
4575                       arg3_tree);
4576         /* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE.  */
4577         mask_arg1
4578           = ffecom_3 (COND_EXPR, tree_type,
4579                       ffecom_truth_value
4580                       (ffecom_2 (NE_EXPR, integer_type_node,
4581                                  arg3_tree,
4582                                  TYPE_SIZE (uns_type))),
4583                       mask_arg1,
4584                       convert (tree_type, integer_zero_node));
4585         mask_arg1 = ffecom_save_tree (mask_arg1);
4586         masked_arg1
4587           = ffecom_2 (BIT_AND_EXPR, tree_type,
4588                       arg1_tree,
4589                       ffecom_1 (BIT_NOT_EXPR, tree_type,
4590                                 mask_arg1));
4591         masked_arg1 = ffecom_save_tree (masked_arg1);
4592         shift_neg
4593           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4594                       convert (tree_type,
4595                                ffecom_2 (RSHIFT_EXPR, uns_type,
4596                                          convert (uns_type, masked_arg1),
4597                                          ffecom_1 (NEGATE_EXPR,
4598                                                    integer_type_node,
4599                                                    arg2_tree))),
4600                       ffecom_2 (LSHIFT_EXPR, tree_type,
4601                                 arg1_tree,
4602                                 ffecom_2 (PLUS_EXPR, integer_type_node,
4603                                           arg2_tree,
4604                                           arg3_tree)));
4605         shift_pos
4606           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4607                       ffecom_2 (LSHIFT_EXPR, tree_type,
4608                                 arg1_tree,
4609                                 arg2_tree),
4610                       convert (tree_type,
4611                                ffecom_2 (RSHIFT_EXPR, uns_type,
4612                                          convert (uns_type, masked_arg1),
4613                                          ffecom_2 (MINUS_EXPR,
4614                                                    integer_type_node,
4615                                                    arg3_tree,
4616                                                    arg2_tree))));
4617         expr_tree
4618           = ffecom_3 (COND_EXPR, tree_type,
4619                       ffecom_truth_value
4620                       (ffecom_2 (LT_EXPR, integer_type_node,
4621                                  arg2_tree,
4622                                  integer_zero_node)),
4623                       shift_neg,
4624                       shift_pos);
4625         expr_tree
4626           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4627                       ffecom_2 (BIT_AND_EXPR, tree_type,
4628                                 mask_arg1,
4629                                 arg1_tree),
4630                       ffecom_2 (BIT_AND_EXPR, tree_type,
4631                                 ffecom_1 (BIT_NOT_EXPR, tree_type,
4632                                           mask_arg1),
4633                                 expr_tree));
4634         expr_tree
4635           = ffecom_3 (COND_EXPR, tree_type,
4636                       ffecom_truth_value
4637                       (ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
4638                                  ffecom_2 (EQ_EXPR, integer_type_node,
4639                                            ffecom_1 (ABS_EXPR,
4640                                                      integer_type_node,
4641                                                      arg2_tree),
4642                                            arg3_tree),
4643                                  ffecom_2 (EQ_EXPR, integer_type_node,
4644                                            arg2_tree,
4645                                            integer_zero_node))),
4646                       arg1_tree,
4647                       expr_tree);
4648         /* Make sure SAVE_EXPRs get referenced early enough. */
4649         expr_tree
4650           = ffecom_2 (COMPOUND_EXPR, tree_type,
4651                       convert (void_type_node, arg1_tree),
4652                       ffecom_2 (COMPOUND_EXPR, tree_type,
4653                                 convert (void_type_node, arg2_tree),
4654                                 ffecom_2 (COMPOUND_EXPR, tree_type,
4655                                           convert (void_type_node,
4656                                                    mask_arg1),
4657                                           ffecom_2 (COMPOUND_EXPR, tree_type,
4658                                                     convert (void_type_node,
4659                                                              masked_arg1),
4660                                                     expr_tree))));
4661         expr_tree
4662           = ffecom_2 (COMPOUND_EXPR, tree_type,
4663                       convert (void_type_node,
4664                                arg3_tree),
4665                       expr_tree);
4666       }
4667       return expr_tree;
4668
4669     case FFEINTRIN_impLOC:
4670       {
4671         tree arg1_tree = ffecom_expr (arg1);
4672
4673         expr_tree
4674           = convert (tree_type,
4675                      ffecom_1 (ADDR_EXPR,
4676                                build_pointer_type (TREE_TYPE (arg1_tree)),
4677                                arg1_tree));
4678       }
4679       return expr_tree;
4680
4681     case FFEINTRIN_impMVBITS:
4682       {
4683         tree arg1_tree;
4684         tree arg2_tree;
4685         tree arg3_tree;
4686         ffebld arg4 = ffebld_head (ffebld_trail (list));
4687         tree arg4_tree;
4688         tree arg4_type;
4689         ffebld arg5 = ffebld_head (ffebld_trail (ffebld_trail (list)));
4690         tree arg5_tree;
4691         tree prep_arg1;
4692         tree prep_arg4;
4693         tree arg5_plus_arg3;
4694
4695         arg2_tree = convert (integer_type_node,
4696                              ffecom_expr (arg2));
4697         arg3_tree = ffecom_save_tree (convert (integer_type_node,
4698                                                ffecom_expr (arg3)));
4699         arg4_tree = ffecom_expr_rw (NULL_TREE, arg4);
4700         arg4_type = TREE_TYPE (arg4_tree);
4701
4702         arg1_tree = ffecom_save_tree (convert (arg4_type,
4703                                                ffecom_expr (arg1)));
4704
4705         arg5_tree = ffecom_save_tree (convert (integer_type_node,
4706                                                ffecom_expr (arg5)));
4707
4708         prep_arg1
4709           = ffecom_2 (LSHIFT_EXPR, arg4_type,
4710                       ffecom_2 (BIT_AND_EXPR, arg4_type,
4711                                 ffecom_2 (RSHIFT_EXPR, arg4_type,
4712                                           arg1_tree,
4713                                           arg2_tree),
4714                                 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4715                                           ffecom_2 (LSHIFT_EXPR, arg4_type,
4716                                                     ffecom_1 (BIT_NOT_EXPR,
4717                                                               arg4_type,
4718                                                               convert
4719                                                               (arg4_type,
4720                                                         integer_zero_node)),
4721                                                     arg3_tree))),
4722                       arg5_tree);
4723         arg5_plus_arg3
4724           = ffecom_save_tree (ffecom_2 (PLUS_EXPR, arg4_type,
4725                                         arg5_tree,
4726                                         arg3_tree));
4727         prep_arg4
4728           = ffecom_2 (LSHIFT_EXPR, arg4_type,
4729                       ffecom_1 (BIT_NOT_EXPR, arg4_type,
4730                                 convert (arg4_type,
4731                                          integer_zero_node)),
4732                       arg5_plus_arg3);
4733         /* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE.  */
4734         prep_arg4
4735           = ffecom_3 (COND_EXPR, arg4_type,
4736                       ffecom_truth_value
4737                       (ffecom_2 (NE_EXPR, integer_type_node,
4738                                  arg5_plus_arg3,
4739                                  convert (TREE_TYPE (arg5_plus_arg3),
4740                                           TYPE_SIZE (arg4_type)))),
4741                       prep_arg4,
4742                       convert (arg4_type, integer_zero_node));
4743         prep_arg4
4744           = ffecom_2 (BIT_AND_EXPR, arg4_type,
4745                       arg4_tree,
4746                       ffecom_2 (BIT_IOR_EXPR, arg4_type,
4747                                 prep_arg4,
4748                                 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4749                                           ffecom_2 (LSHIFT_EXPR, arg4_type,
4750                                                     ffecom_1 (BIT_NOT_EXPR,
4751                                                               arg4_type,
4752                                                               convert
4753                                                               (arg4_type,
4754                                                         integer_zero_node)),
4755                                                     arg5_tree))));
4756         prep_arg1
4757           = ffecom_2 (BIT_IOR_EXPR, arg4_type,
4758                       prep_arg1,
4759                       prep_arg4);
4760         /* Fix up (twice), because LSHIFT_EXPR above
4761            can't shift over TYPE_SIZE.  */
4762         prep_arg1
4763           = ffecom_3 (COND_EXPR, arg4_type,
4764                       ffecom_truth_value
4765                       (ffecom_2 (NE_EXPR, integer_type_node,
4766                                  arg3_tree,
4767                                  convert (TREE_TYPE (arg3_tree),
4768                                           integer_zero_node))),
4769                       prep_arg1,
4770                       arg4_tree);
4771         prep_arg1
4772           = ffecom_3 (COND_EXPR, arg4_type,
4773                       ffecom_truth_value
4774                       (ffecom_2 (NE_EXPR, integer_type_node,
4775                                  arg3_tree,
4776                                  convert (TREE_TYPE (arg3_tree),
4777                                           TYPE_SIZE (arg4_type)))),
4778                       prep_arg1,
4779                       arg1_tree);
4780         expr_tree
4781           = ffecom_2s (MODIFY_EXPR, void_type_node,
4782                        arg4_tree,
4783                        prep_arg1);
4784         /* Make sure SAVE_EXPRs get referenced early enough. */
4785         expr_tree
4786           = ffecom_2 (COMPOUND_EXPR, void_type_node,
4787                       arg1_tree,
4788                       ffecom_2 (COMPOUND_EXPR, void_type_node,
4789                                 arg3_tree,
4790                                 ffecom_2 (COMPOUND_EXPR, void_type_node,
4791                                           arg5_tree,
4792                                           ffecom_2 (COMPOUND_EXPR, void_type_node,
4793                                                     arg5_plus_arg3,
4794                                                     expr_tree))));
4795         expr_tree
4796           = ffecom_2 (COMPOUND_EXPR, void_type_node,
4797                       arg4_tree,
4798                       expr_tree);
4799
4800       }
4801       return expr_tree;
4802
4803     case FFEINTRIN_impDERF:
4804     case FFEINTRIN_impERF:
4805     case FFEINTRIN_impDERFC:
4806     case FFEINTRIN_impERFC:
4807       break;
4808
4809     case FFEINTRIN_impIARGC:
4810       /* extern int xargc; i__1 = xargc - 1; */
4811       expr_tree = ffecom_2 (MINUS_EXPR, TREE_TYPE (ffecom_tree_xargc_),
4812                             ffecom_tree_xargc_,
4813                             convert (TREE_TYPE (ffecom_tree_xargc_),
4814                                      integer_one_node));
4815       return expr_tree;
4816
4817     case FFEINTRIN_impSIGNAL_func:
4818     case FFEINTRIN_impSIGNAL_subr:
4819       {
4820         tree arg1_tree;
4821         tree arg2_tree;
4822         tree arg3_tree;
4823
4824         arg1_tree = convert (ffecom_f2c_integer_type_node,
4825                              ffecom_expr (arg1));
4826         arg1_tree = ffecom_1 (ADDR_EXPR,
4827                               build_pointer_type (TREE_TYPE (arg1_tree)),
4828                               arg1_tree);
4829
4830         /* Pass procedure as a pointer to it, anything else by value.  */
4831         if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
4832           arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
4833         else
4834           arg2_tree = ffecom_ptr_to_expr (arg2);
4835         arg2_tree = convert (TREE_TYPE (null_pointer_node),
4836                              arg2_tree);
4837
4838         if (arg3 != NULL)
4839           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
4840         else
4841           arg3_tree = NULL_TREE;
4842
4843         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4844         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4845         TREE_CHAIN (arg1_tree) = arg2_tree;
4846
4847         expr_tree
4848           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4849                           ffecom_gfrt_kindtype (gfrt),
4850                           FALSE,
4851                           ((codegen_imp == FFEINTRIN_impSIGNAL_subr) ?
4852                            NULL_TREE :
4853                            tree_type),
4854                           arg1_tree,
4855                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4856                           ffebld_nonter_hook (expr));
4857
4858         if (arg3_tree != NULL_TREE)
4859           expr_tree
4860             = ffecom_modify (NULL_TREE, arg3_tree,
4861                              convert (TREE_TYPE (arg3_tree),
4862                                       expr_tree));
4863       }
4864       return expr_tree;
4865
4866     case FFEINTRIN_impALARM:
4867       {
4868         tree arg1_tree;
4869         tree arg2_tree;
4870         tree arg3_tree;
4871
4872         arg1_tree = convert (ffecom_f2c_integer_type_node,
4873                              ffecom_expr (arg1));
4874         arg1_tree = ffecom_1 (ADDR_EXPR,
4875                               build_pointer_type (TREE_TYPE (arg1_tree)),
4876                               arg1_tree);
4877
4878         /* Pass procedure as a pointer to it, anything else by value.  */
4879         if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
4880           arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
4881         else
4882           arg2_tree = ffecom_ptr_to_expr (arg2);
4883         arg2_tree = convert (TREE_TYPE (null_pointer_node),
4884                              arg2_tree);
4885
4886         if (arg3 != NULL)
4887           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
4888         else
4889           arg3_tree = NULL_TREE;
4890
4891         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4892         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4893         TREE_CHAIN (arg1_tree) = arg2_tree;
4894
4895         expr_tree
4896           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4897                           ffecom_gfrt_kindtype (gfrt),
4898                           FALSE,
4899                           NULL_TREE,
4900                           arg1_tree,
4901                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4902                           ffebld_nonter_hook (expr));
4903
4904         if (arg3_tree != NULL_TREE)
4905           expr_tree
4906             = ffecom_modify (NULL_TREE, arg3_tree,
4907                              convert (TREE_TYPE (arg3_tree),
4908                                       expr_tree));
4909       }
4910       return expr_tree;
4911
4912     case FFEINTRIN_impCHDIR_subr:
4913     case FFEINTRIN_impFDATE_subr:
4914     case FFEINTRIN_impFGET_subr:
4915     case FFEINTRIN_impFPUT_subr:
4916     case FFEINTRIN_impGETCWD_subr:
4917     case FFEINTRIN_impHOSTNM_subr:
4918     case FFEINTRIN_impSYSTEM_subr:
4919     case FFEINTRIN_impUNLINK_subr:
4920       {
4921         tree arg1_len = integer_zero_node;
4922         tree arg1_tree;
4923         tree arg2_tree;
4924
4925         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
4926
4927         if (arg2 != NULL)
4928           arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
4929         else
4930           arg2_tree = NULL_TREE;
4931
4932         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4933         arg1_len = build_tree_list (NULL_TREE, arg1_len);
4934         TREE_CHAIN (arg1_tree) = arg1_len;
4935
4936         expr_tree
4937           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4938                           ffecom_gfrt_kindtype (gfrt),
4939                           FALSE,
4940                           NULL_TREE,
4941                           arg1_tree,
4942                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4943                           ffebld_nonter_hook (expr));
4944
4945         if (arg2_tree != NULL_TREE)
4946           expr_tree
4947             = ffecom_modify (NULL_TREE, arg2_tree,
4948                              convert (TREE_TYPE (arg2_tree),
4949                                       expr_tree));
4950       }
4951       return expr_tree;
4952
4953     case FFEINTRIN_impEXIT:
4954       if (arg1 != NULL)
4955         break;
4956
4957       expr_tree = build_tree_list (NULL_TREE,
4958                                    ffecom_1 (ADDR_EXPR,
4959                                              build_pointer_type
4960                                              (ffecom_integer_type_node),
4961                                              integer_zero_node));
4962
4963       return
4964         ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4965                       ffecom_gfrt_kindtype (gfrt),
4966                       FALSE,
4967                       void_type_node,
4968                       expr_tree,
4969                       NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4970                       ffebld_nonter_hook (expr));
4971
4972     case FFEINTRIN_impFLUSH:
4973       if (arg1 == NULL)
4974         gfrt = FFECOM_gfrtFLUSH;
4975       else
4976         gfrt = FFECOM_gfrtFLUSH1;
4977       break;
4978
4979     case FFEINTRIN_impCHMOD_subr:
4980     case FFEINTRIN_impLINK_subr:
4981     case FFEINTRIN_impRENAME_subr:
4982     case FFEINTRIN_impSYMLNK_subr:
4983       {
4984         tree arg1_len = integer_zero_node;
4985         tree arg1_tree;
4986         tree arg2_len = integer_zero_node;
4987         tree arg2_tree;
4988         tree arg3_tree;
4989
4990         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
4991         arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
4992         if (arg3 != NULL)
4993           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
4994         else
4995           arg3_tree = NULL_TREE;
4996
4997         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4998         arg1_len = build_tree_list (NULL_TREE, arg1_len);
4999         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5000         arg2_len = build_tree_list (NULL_TREE, arg2_len);
5001         TREE_CHAIN (arg1_tree) = arg2_tree;
5002         TREE_CHAIN (arg2_tree) = arg1_len;
5003         TREE_CHAIN (arg1_len) = arg2_len;
5004         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5005                                   ffecom_gfrt_kindtype (gfrt),
5006                                   FALSE,
5007                                   NULL_TREE,
5008                                   arg1_tree,
5009                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5010                                   ffebld_nonter_hook (expr));
5011         if (arg3_tree != NULL_TREE)
5012           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5013                                      convert (TREE_TYPE (arg3_tree),
5014                                               expr_tree));
5015       }
5016       return expr_tree;
5017
5018     case FFEINTRIN_impLSTAT_subr:
5019     case FFEINTRIN_impSTAT_subr:
5020       {
5021         tree arg1_len = integer_zero_node;
5022         tree arg1_tree;
5023         tree arg2_tree;
5024         tree arg3_tree;
5025
5026         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5027
5028         arg2_tree = ffecom_ptr_to_expr (arg2);
5029
5030         if (arg3 != NULL)
5031           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5032         else
5033           arg3_tree = NULL_TREE;
5034
5035         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5036         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5037         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5038         TREE_CHAIN (arg1_tree) = arg2_tree;
5039         TREE_CHAIN (arg2_tree) = arg1_len;
5040         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5041                                   ffecom_gfrt_kindtype (gfrt),
5042                                   FALSE,
5043                                   NULL_TREE,
5044                                   arg1_tree,
5045                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5046                                   ffebld_nonter_hook (expr));
5047         if (arg3_tree != NULL_TREE)
5048           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5049                                      convert (TREE_TYPE (arg3_tree),
5050                                               expr_tree));
5051       }
5052       return expr_tree;
5053
5054     case FFEINTRIN_impFGETC_subr:
5055     case FFEINTRIN_impFPUTC_subr:
5056       {
5057         tree arg1_tree;
5058         tree arg2_tree;
5059         tree arg2_len = integer_zero_node;
5060         tree arg3_tree;
5061
5062         arg1_tree = convert (ffecom_f2c_integer_type_node,
5063                              ffecom_expr (arg1));
5064         arg1_tree = ffecom_1 (ADDR_EXPR,
5065                               build_pointer_type (TREE_TYPE (arg1_tree)),
5066                               arg1_tree);
5067
5068         arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
5069         if (arg3 != NULL)
5070           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5071         else
5072           arg3_tree = NULL_TREE;
5073
5074         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5075         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5076         arg2_len = build_tree_list (NULL_TREE, arg2_len);
5077         TREE_CHAIN (arg1_tree) = arg2_tree;
5078         TREE_CHAIN (arg2_tree) = arg2_len;
5079
5080         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5081                                   ffecom_gfrt_kindtype (gfrt),
5082                                   FALSE,
5083                                   NULL_TREE,
5084                                   arg1_tree,
5085                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5086                                   ffebld_nonter_hook (expr));
5087         if (arg3_tree != NULL_TREE)
5088           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5089                                      convert (TREE_TYPE (arg3_tree),
5090                                               expr_tree));
5091       }
5092       return expr_tree;
5093
5094     case FFEINTRIN_impFSTAT_subr:
5095       {
5096         tree arg1_tree;
5097         tree arg2_tree;
5098         tree arg3_tree;
5099
5100         arg1_tree = convert (ffecom_f2c_integer_type_node,
5101                              ffecom_expr (arg1));
5102         arg1_tree = ffecom_1 (ADDR_EXPR,
5103                               build_pointer_type (TREE_TYPE (arg1_tree)),
5104                               arg1_tree);
5105
5106         arg2_tree = convert (ffecom_f2c_ptr_to_integer_type_node,
5107                              ffecom_ptr_to_expr (arg2));
5108
5109         if (arg3 == NULL)
5110           arg3_tree = NULL_TREE;
5111         else
5112           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5113
5114         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5115         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5116         TREE_CHAIN (arg1_tree) = arg2_tree;
5117         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5118                                   ffecom_gfrt_kindtype (gfrt),
5119                                   FALSE,
5120                                   NULL_TREE,
5121                                   arg1_tree,
5122                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5123                                   ffebld_nonter_hook (expr));
5124         if (arg3_tree != NULL_TREE) {
5125           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5126                                      convert (TREE_TYPE (arg3_tree),
5127                                               expr_tree));
5128         }
5129       }
5130       return expr_tree;
5131
5132     case FFEINTRIN_impKILL_subr:
5133       {
5134         tree arg1_tree;
5135         tree arg2_tree;
5136         tree arg3_tree;
5137
5138         arg1_tree = convert (ffecom_f2c_integer_type_node,
5139                              ffecom_expr (arg1));
5140         arg1_tree = ffecom_1 (ADDR_EXPR,
5141                               build_pointer_type (TREE_TYPE (arg1_tree)),
5142                               arg1_tree);
5143
5144         arg2_tree = convert (ffecom_f2c_integer_type_node,
5145                              ffecom_expr (arg2));
5146         arg2_tree = ffecom_1 (ADDR_EXPR,
5147                               build_pointer_type (TREE_TYPE (arg2_tree)),
5148                               arg2_tree);
5149
5150         if (arg3 == NULL)
5151           arg3_tree = NULL_TREE;
5152         else
5153           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5154
5155         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5156         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5157         TREE_CHAIN (arg1_tree) = arg2_tree;
5158         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5159                                   ffecom_gfrt_kindtype (gfrt),
5160                                   FALSE,
5161                                   NULL_TREE,
5162                                   arg1_tree,
5163                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5164                                   ffebld_nonter_hook (expr));
5165         if (arg3_tree != NULL_TREE) {
5166           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5167                                      convert (TREE_TYPE (arg3_tree),
5168                                               expr_tree));
5169         }
5170       }
5171       return expr_tree;
5172
5173     case FFEINTRIN_impCTIME_subr:
5174     case FFEINTRIN_impTTYNAM_subr:
5175       {
5176         tree arg1_len = integer_zero_node;
5177         tree arg1_tree;
5178         tree arg2_tree;
5179
5180         arg1_tree = ffecom_arg_ptr_to_expr (arg2, &arg1_len);
5181
5182         arg2_tree = convert (((codegen_imp == FFEINTRIN_impCTIME_subr) ?
5183                               ffecom_f2c_longint_type_node :
5184                               ffecom_f2c_integer_type_node),
5185                              ffecom_expr (arg1));
5186         arg2_tree = ffecom_1 (ADDR_EXPR,
5187                               build_pointer_type (TREE_TYPE (arg2_tree)),
5188                               arg2_tree);
5189
5190         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5191         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5192         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5193         TREE_CHAIN (arg1_len) = arg2_tree;
5194         TREE_CHAIN (arg1_tree) = arg1_len;
5195
5196         expr_tree
5197           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5198                           ffecom_gfrt_kindtype (gfrt),
5199                           FALSE,
5200                           NULL_TREE,
5201                           arg1_tree,
5202                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5203                           ffebld_nonter_hook (expr));
5204         TREE_SIDE_EFFECTS (expr_tree) = 1;
5205       }
5206       return expr_tree;
5207
5208     case FFEINTRIN_impIRAND:
5209     case FFEINTRIN_impRAND:
5210       /* Arg defaults to 0 (normal random case) */
5211       {
5212         tree arg1_tree;
5213
5214         if (arg1 == NULL)
5215           arg1_tree = ffecom_integer_zero_node;
5216         else
5217           arg1_tree = ffecom_expr (arg1);
5218         arg1_tree = convert (ffecom_f2c_integer_type_node,
5219                              arg1_tree);
5220         arg1_tree = ffecom_1 (ADDR_EXPR,
5221                               build_pointer_type (TREE_TYPE (arg1_tree)),
5222                               arg1_tree);
5223         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5224
5225         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5226                                   ffecom_gfrt_kindtype (gfrt),
5227                                   FALSE,
5228                                   ((codegen_imp == FFEINTRIN_impIRAND) ?
5229                                    ffecom_f2c_integer_type_node :
5230                                    ffecom_f2c_real_type_node),
5231                                   arg1_tree,
5232                                   dest_tree, dest, dest_used,
5233                                   NULL_TREE, TRUE,
5234                                   ffebld_nonter_hook (expr));
5235       }
5236       return expr_tree;
5237
5238     case FFEINTRIN_impFTELL_subr:
5239     case FFEINTRIN_impUMASK_subr:
5240       {
5241         tree arg1_tree;
5242         tree arg2_tree;
5243
5244         arg1_tree = convert (ffecom_f2c_integer_type_node,
5245                              ffecom_expr (arg1));
5246         arg1_tree = ffecom_1 (ADDR_EXPR,
5247                               build_pointer_type (TREE_TYPE (arg1_tree)),
5248                               arg1_tree);
5249
5250         if (arg2 == NULL)
5251           arg2_tree = NULL_TREE;
5252         else
5253           arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
5254
5255         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5256                                   ffecom_gfrt_kindtype (gfrt),
5257                                   FALSE,
5258                                   NULL_TREE,
5259                                   build_tree_list (NULL_TREE, arg1_tree),
5260                                   NULL_TREE, NULL, NULL, NULL_TREE,
5261                                   TRUE,
5262                                   ffebld_nonter_hook (expr));
5263         if (arg2_tree != NULL_TREE) {
5264           expr_tree = ffecom_modify (NULL_TREE, arg2_tree,
5265                                      convert (TREE_TYPE (arg2_tree),
5266                                               expr_tree));
5267         }
5268       }
5269       return expr_tree;
5270
5271     case FFEINTRIN_impCPU_TIME:
5272     case FFEINTRIN_impSECOND_subr:
5273       {
5274         tree arg1_tree;
5275
5276         arg1_tree = ffecom_expr_w (NULL_TREE, arg1);
5277
5278         expr_tree
5279           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5280                           ffecom_gfrt_kindtype (gfrt),
5281                           FALSE,
5282                           NULL_TREE,
5283                           NULL_TREE,
5284                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5285                           ffebld_nonter_hook (expr));
5286
5287         expr_tree
5288           = ffecom_modify (NULL_TREE, arg1_tree,
5289                            convert (TREE_TYPE (arg1_tree),
5290                                     expr_tree));
5291       }
5292       return expr_tree;
5293
5294     case FFEINTRIN_impDTIME_subr:
5295     case FFEINTRIN_impETIME_subr:
5296       {
5297         tree arg1_tree;
5298         tree result_tree;
5299
5300         result_tree = ffecom_expr_w (NULL_TREE, arg2);
5301
5302         arg1_tree = ffecom_ptr_to_expr (arg1);
5303
5304         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5305                                   ffecom_gfrt_kindtype (gfrt),
5306                                   FALSE,
5307                                   NULL_TREE,
5308                                   build_tree_list (NULL_TREE, arg1_tree),
5309                                   NULL_TREE, NULL, NULL, NULL_TREE,
5310                                   TRUE,
5311                                   ffebld_nonter_hook (expr));
5312         expr_tree = ffecom_modify (NULL_TREE, result_tree,
5313                                    convert (TREE_TYPE (result_tree),
5314                                             expr_tree));
5315       }
5316       return expr_tree;
5317
5318       /* Straightforward calls of libf2c routines: */
5319     case FFEINTRIN_impABORT:
5320     case FFEINTRIN_impACCESS:
5321     case FFEINTRIN_impBESJ0:
5322     case FFEINTRIN_impBESJ1:
5323     case FFEINTRIN_impBESJN:
5324     case FFEINTRIN_impBESY0:
5325     case FFEINTRIN_impBESY1:
5326     case FFEINTRIN_impBESYN:
5327     case FFEINTRIN_impCHDIR_func:
5328     case FFEINTRIN_impCHMOD_func:
5329     case FFEINTRIN_impDATE:
5330     case FFEINTRIN_impDATE_AND_TIME:
5331     case FFEINTRIN_impDBESJ0:
5332     case FFEINTRIN_impDBESJ1:
5333     case FFEINTRIN_impDBESJN:
5334     case FFEINTRIN_impDBESY0:
5335     case FFEINTRIN_impDBESY1:
5336     case FFEINTRIN_impDBESYN:
5337     case FFEINTRIN_impDTIME_func:
5338     case FFEINTRIN_impETIME_func:
5339     case FFEINTRIN_impFGETC_func:
5340     case FFEINTRIN_impFGET_func:
5341     case FFEINTRIN_impFNUM:
5342     case FFEINTRIN_impFPUTC_func:
5343     case FFEINTRIN_impFPUT_func:
5344     case FFEINTRIN_impFSEEK:
5345     case FFEINTRIN_impFSTAT_func:
5346     case FFEINTRIN_impFTELL_func:
5347     case FFEINTRIN_impGERROR:
5348     case FFEINTRIN_impGETARG:
5349     case FFEINTRIN_impGETCWD_func:
5350     case FFEINTRIN_impGETENV:
5351     case FFEINTRIN_impGETGID:
5352     case FFEINTRIN_impGETLOG:
5353     case FFEINTRIN_impGETPID:
5354     case FFEINTRIN_impGETUID:
5355     case FFEINTRIN_impGMTIME:
5356     case FFEINTRIN_impHOSTNM_func:
5357     case FFEINTRIN_impIDATE_unix:
5358     case FFEINTRIN_impIDATE_vxt:
5359     case FFEINTRIN_impIERRNO:
5360     case FFEINTRIN_impISATTY:
5361     case FFEINTRIN_impITIME:
5362     case FFEINTRIN_impKILL_func:
5363     case FFEINTRIN_impLINK_func:
5364     case FFEINTRIN_impLNBLNK:
5365     case FFEINTRIN_impLSTAT_func:
5366     case FFEINTRIN_impLTIME:
5367     case FFEINTRIN_impMCLOCK8:
5368     case FFEINTRIN_impMCLOCK:
5369     case FFEINTRIN_impPERROR:
5370     case FFEINTRIN_impRENAME_func:
5371     case FFEINTRIN_impSECNDS:
5372     case FFEINTRIN_impSECOND_func:
5373     case FFEINTRIN_impSLEEP:
5374     case FFEINTRIN_impSRAND:
5375     case FFEINTRIN_impSTAT_func:
5376     case FFEINTRIN_impSYMLNK_func:
5377     case FFEINTRIN_impSYSTEM_CLOCK:
5378     case FFEINTRIN_impSYSTEM_func:
5379     case FFEINTRIN_impTIME8:
5380     case FFEINTRIN_impTIME_unix:
5381     case FFEINTRIN_impTIME_vxt:
5382     case FFEINTRIN_impUMASK_func:
5383     case FFEINTRIN_impUNLINK_func:
5384       break;
5385
5386     case FFEINTRIN_impCTIME_func:       /* CHARACTER functions not handled here. */
5387     case FFEINTRIN_impFDATE_func:       /* CHARACTER functions not handled here. */
5388     case FFEINTRIN_impTTYNAM_func:      /* CHARACTER functions not handled here. */
5389     case FFEINTRIN_impNONE:
5390     case FFEINTRIN_imp:         /* Hush up gcc warning. */
5391       fprintf (stderr, "No %s implementation.\n",
5392                ffeintrin_name_implementation (ffebld_symter_implementation (ffebld_left (expr))));
5393       assert ("unimplemented intrinsic" == NULL);
5394       return error_mark_node;
5395     }
5396
5397   assert (gfrt != FFECOM_gfrt); /* Must have an implementation! */
5398
5399   expr_tree = ffecom_arglist_expr_ (ffecom_gfrt_args_ (gfrt),
5400                                     ffebld_right (expr));
5401
5402   return ffecom_call_ (ffecom_gfrt_tree_ (gfrt), ffecom_gfrt_kindtype (gfrt),
5403                        (ffe_is_f2c_library () && ffecom_gfrt_complex_[gfrt]),
5404                        tree_type,
5405                        expr_tree, dest_tree, dest, dest_used,
5406                        NULL_TREE, TRUE,
5407                        ffebld_nonter_hook (expr));
5408
5409   /* See bottom of this file for f2c transforms used to determine
5410      many of the above implementations.  The info seems to confuse
5411      Emacs's C mode indentation, which is why it's been moved to
5412      the bottom of this source file.  */
5413 }
5414
5415 /* For power (exponentiation) where right-hand operand is type INTEGER,
5416    generate in-line code to do it the fast way (which, if the operand
5417    is a constant, might just mean a series of multiplies).  */
5418
5419 static tree
5420 ffecom_expr_power_integer_ (ffebld expr)
5421 {
5422   tree l = ffecom_expr (ffebld_left (expr));
5423   tree r = ffecom_expr (ffebld_right (expr));
5424   tree ltype = TREE_TYPE (l);
5425   tree rtype = TREE_TYPE (r);
5426   tree result = NULL_TREE;
5427
5428   if (l == error_mark_node
5429       || r == error_mark_node)
5430     return error_mark_node;
5431
5432   if (TREE_CODE (r) == INTEGER_CST)
5433     {
5434       int sgn = tree_int_cst_sgn (r);
5435
5436       if (sgn == 0)
5437         return convert (ltype, integer_one_node);
5438
5439       if ((TREE_CODE (ltype) == INTEGER_TYPE)
5440           && (sgn < 0))
5441         {
5442           /* Reciprocal of integer is either 0, -1, or 1, so after
5443              calculating that (which we leave to the back end to do
5444              or not do optimally), don't bother with any multiplying.  */
5445
5446           result = ffecom_tree_divide_ (ltype,
5447                                         convert (ltype, integer_one_node),
5448                                         l,
5449                                         NULL_TREE, NULL, NULL, NULL_TREE);
5450           r = ffecom_1 (NEGATE_EXPR,
5451                         rtype,
5452                         r);
5453           if ((TREE_INT_CST_LOW (r) & 1) == 0)
5454             result = ffecom_1 (ABS_EXPR, rtype,
5455                                result);
5456         }
5457
5458       /* Generate appropriate series of multiplies, preceded
5459          by divide if the exponent is negative.  */
5460
5461       l = save_expr (l);
5462
5463       if (sgn < 0)
5464         {
5465           l = ffecom_tree_divide_ (ltype,
5466                                    convert (ltype, integer_one_node),
5467                                    l,
5468                                    NULL_TREE, NULL, NULL,
5469                                    ffebld_nonter_hook (expr));
5470           r = ffecom_1 (NEGATE_EXPR, rtype, r);
5471           assert (TREE_CODE (r) == INTEGER_CST);
5472
5473           if (tree_int_cst_sgn (r) < 0)
5474             {                   /* The "most negative" number.  */
5475               r = ffecom_1 (NEGATE_EXPR, rtype,
5476                             ffecom_2 (RSHIFT_EXPR, rtype,
5477                                       r,
5478                                       integer_one_node));
5479               l = save_expr (l);
5480               l = ffecom_2 (MULT_EXPR, ltype,
5481                             l,
5482                             l);
5483             }
5484         }
5485
5486       for (;;)
5487         {
5488           if (TREE_INT_CST_LOW (r) & 1)
5489             {
5490               if (result == NULL_TREE)
5491                 result = l;
5492               else
5493                 result = ffecom_2 (MULT_EXPR, ltype,
5494                                    result,
5495                                    l);
5496             }
5497
5498           r = ffecom_2 (RSHIFT_EXPR, rtype,
5499                         r,
5500                         integer_one_node);
5501           if (integer_zerop (r))
5502             break;
5503           assert (TREE_CODE (r) == INTEGER_CST);
5504
5505           l = save_expr (l);
5506           l = ffecom_2 (MULT_EXPR, ltype,
5507                         l,
5508                         l);
5509         }
5510       return result;
5511     }
5512
5513   /* Though rhs isn't a constant, in-line code cannot be expanded
5514      while transforming dummies
5515      because the back end cannot be easily convinced to generate
5516      stores (MODIFY_EXPR), handle temporaries, and so on before
5517      all the appropriate rtx's have been generated for things like
5518      dummy args referenced in rhs -- which doesn't happen until
5519      store_parm_decls() is called (expand_function_start, I believe,
5520      does the actual rtx-stuffing of PARM_DECLs).
5521
5522      So, in this case, let the caller generate the call to the
5523      run-time-library function to evaluate the power for us.  */
5524
5525   if (ffecom_transform_only_dummies_)
5526     return NULL_TREE;
5527
5528   /* Right-hand operand not a constant, expand in-line code to figure
5529      out how to do the multiplies, &c.
5530
5531      The returned expression is expressed this way in GNU C, where l and
5532      r are the "inputs":
5533
5534      ({ typeof (r) rtmp = r;
5535         typeof (l) ltmp = l;
5536         typeof (l) result;
5537
5538         if (rtmp == 0)
5539           result = 1;
5540         else
5541           {
5542             if ((basetypeof (l) == basetypeof (int))
5543                 && (rtmp < 0))
5544               {
5545                 result = ((typeof (l)) 1) / ltmp;
5546                 if ((ltmp < 0) && (((-rtmp) & 1) == 0))
5547                   result = -result;
5548               }
5549             else
5550               {
5551                 result = 1;
5552                 if ((basetypeof (l) != basetypeof (int))
5553                     && (rtmp < 0))
5554                   {
5555                     ltmp = ((typeof (l)) 1) / ltmp;
5556                     rtmp = -rtmp;
5557                     if (rtmp < 0)
5558                       {
5559                         rtmp = -(rtmp >> 1);
5560                         ltmp *= ltmp;
5561                       }
5562                   }
5563                 for (;;)
5564                   {
5565                     if (rtmp & 1)
5566                       result *= ltmp;
5567                     if ((rtmp >>= 1) == 0)
5568                       break;
5569                     ltmp *= ltmp;
5570                   }
5571               }
5572           }
5573         result;
5574      })
5575
5576      Note that some of the above is compile-time collapsable, such as
5577      the first part of the if statements that checks the base type of
5578      l against int.  The if statements are phrased that way to suggest
5579      an easy way to generate the if/else constructs here, knowing that
5580      the back end should (and probably does) eliminate the resulting
5581      dead code (either the int case or the non-int case), something
5582      it couldn't do without the redundant phrasing, requiring explicit
5583      dead-code elimination here, which would be kind of difficult to
5584      read.  */
5585
5586   {
5587     tree rtmp;
5588     tree ltmp;
5589     tree divide;
5590     tree basetypeof_l_is_int;
5591     tree se;
5592     tree t;
5593
5594     basetypeof_l_is_int
5595       = build_int_2 ((TREE_CODE (ltype) == INTEGER_TYPE), 0);
5596
5597     se = expand_start_stmt_expr (/*has_scope=*/1);
5598
5599     ffecom_start_compstmt ();
5600
5601     rtmp = ffecom_make_tempvar ("power_r", rtype,
5602                                 FFETARGET_charactersizeNONE, -1);
5603     ltmp = ffecom_make_tempvar ("power_l", ltype,
5604                                 FFETARGET_charactersizeNONE, -1);
5605     result = ffecom_make_tempvar ("power_res", ltype,
5606                                   FFETARGET_charactersizeNONE, -1);
5607     if (TREE_CODE (ltype) == COMPLEX_TYPE
5608         || TREE_CODE (ltype) == RECORD_TYPE)
5609       divide = ffecom_make_tempvar ("power_div", ltype,
5610                                     FFETARGET_charactersizeNONE, -1);
5611     else
5612       divide = NULL_TREE;
5613
5614     expand_expr_stmt (ffecom_modify (void_type_node,
5615                                      rtmp,
5616                                      r));
5617     expand_expr_stmt (ffecom_modify (void_type_node,
5618                                      ltmp,
5619                                      l));
5620     expand_start_cond (ffecom_truth_value
5621                        (ffecom_2 (EQ_EXPR, integer_type_node,
5622                                   rtmp,
5623                                   convert (rtype, integer_zero_node))),
5624                        0);
5625     expand_expr_stmt (ffecom_modify (void_type_node,
5626                                      result,
5627                                      convert (ltype, integer_one_node)));
5628     expand_start_else ();
5629     if (! integer_zerop (basetypeof_l_is_int))
5630       {
5631         expand_start_cond (ffecom_2 (LT_EXPR, integer_type_node,
5632                                      rtmp,
5633                                      convert (rtype,
5634                                               integer_zero_node)),
5635                            0);
5636         expand_expr_stmt (ffecom_modify (void_type_node,
5637                                          result,
5638                                          ffecom_tree_divide_
5639                                          (ltype,
5640                                           convert (ltype, integer_one_node),
5641                                           ltmp,
5642                                           NULL_TREE, NULL, NULL,
5643                                           divide)));
5644         expand_start_cond (ffecom_truth_value
5645                            (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5646                                       ffecom_2 (LT_EXPR, integer_type_node,
5647                                                 ltmp,
5648                                                 convert (ltype,
5649                                                          integer_zero_node)),
5650                                       ffecom_2 (EQ_EXPR, integer_type_node,
5651                                                 ffecom_2 (BIT_AND_EXPR,
5652                                                           rtype,
5653                                                           ffecom_1 (NEGATE_EXPR,
5654                                                                     rtype,
5655                                                                     rtmp),
5656                                                           convert (rtype,
5657                                                                    integer_one_node)),
5658                                                 convert (rtype,
5659                                                          integer_zero_node)))),
5660                            0);
5661         expand_expr_stmt (ffecom_modify (void_type_node,
5662                                          result,
5663                                          ffecom_1 (NEGATE_EXPR,
5664                                                    ltype,
5665                                                    result)));
5666         expand_end_cond ();
5667         expand_start_else ();
5668       }
5669     expand_expr_stmt (ffecom_modify (void_type_node,
5670                                      result,
5671                                      convert (ltype, integer_one_node)));
5672     expand_start_cond (ffecom_truth_value
5673                        (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5674                                   ffecom_truth_value_invert
5675                                   (basetypeof_l_is_int),
5676                                   ffecom_2 (LT_EXPR, integer_type_node,
5677                                             rtmp,
5678                                             convert (rtype,
5679                                                      integer_zero_node)))),
5680                        0);
5681     expand_expr_stmt (ffecom_modify (void_type_node,
5682                                      ltmp,
5683                                      ffecom_tree_divide_
5684                                      (ltype,
5685                                       convert (ltype, integer_one_node),
5686                                       ltmp,
5687                                       NULL_TREE, NULL, NULL,
5688                                       divide)));
5689     expand_expr_stmt (ffecom_modify (void_type_node,
5690                                      rtmp,
5691                                      ffecom_1 (NEGATE_EXPR, rtype,
5692                                                rtmp)));
5693     expand_start_cond (ffecom_truth_value
5694                        (ffecom_2 (LT_EXPR, integer_type_node,
5695                                   rtmp,
5696                                   convert (rtype, integer_zero_node))),
5697                        0);
5698     expand_expr_stmt (ffecom_modify (void_type_node,
5699                                      rtmp,
5700                                      ffecom_1 (NEGATE_EXPR, rtype,
5701                                                ffecom_2 (RSHIFT_EXPR,
5702                                                          rtype,
5703                                                          rtmp,
5704                                                          integer_one_node))));
5705     expand_expr_stmt (ffecom_modify (void_type_node,
5706                                      ltmp,
5707                                      ffecom_2 (MULT_EXPR, ltype,
5708                                                ltmp,
5709                                                ltmp)));
5710     expand_end_cond ();
5711     expand_end_cond ();
5712     expand_start_loop (1);
5713     expand_start_cond (ffecom_truth_value
5714                        (ffecom_2 (BIT_AND_EXPR, rtype,
5715                                   rtmp,
5716                                   convert (rtype, integer_one_node))),
5717                        0);
5718     expand_expr_stmt (ffecom_modify (void_type_node,
5719                                      result,
5720                                      ffecom_2 (MULT_EXPR, ltype,
5721                                                result,
5722                                                ltmp)));
5723     expand_end_cond ();
5724     expand_exit_loop_if_false (NULL,
5725                                ffecom_truth_value
5726                                (ffecom_modify (rtype,
5727                                                rtmp,
5728                                                ffecom_2 (RSHIFT_EXPR,
5729                                                          rtype,
5730                                                          rtmp,
5731                                                          integer_one_node))));
5732     expand_expr_stmt (ffecom_modify (void_type_node,
5733                                      ltmp,
5734                                      ffecom_2 (MULT_EXPR, ltype,
5735                                                ltmp,
5736                                                ltmp)));
5737     expand_end_loop ();
5738     expand_end_cond ();
5739     if (!integer_zerop (basetypeof_l_is_int))
5740       expand_end_cond ();
5741     expand_expr_stmt (result);
5742
5743     t = ffecom_end_compstmt ();
5744
5745     result = expand_end_stmt_expr (se);
5746
5747     /* This code comes from c-parse.in, after its expand_end_stmt_expr.  */
5748
5749     if (TREE_CODE (t) == BLOCK)
5750       {
5751         /* Make a BIND_EXPR for the BLOCK already made.  */
5752         result = build (BIND_EXPR, TREE_TYPE (result),
5753                         NULL_TREE, result, t);
5754         /* Remove the block from the tree at this point.
5755            It gets put back at the proper place
5756            when the BIND_EXPR is expanded.  */
5757         delete_block (t);
5758       }
5759     else
5760       result = t;
5761   }
5762
5763   return result;
5764 }
5765
5766 /* ffecom_expr_transform_ -- Transform symbols in expr
5767
5768    ffebld expr;  // FFE expression.
5769    ffecom_expr_transform_ (expr);
5770
5771    Recursive descent on expr while transforming any untransformed SYMTERs.  */
5772
5773 static void
5774 ffecom_expr_transform_ (ffebld expr)
5775 {
5776   tree t;
5777   ffesymbol s;
5778
5779  tail_recurse:
5780
5781   if (expr == NULL)
5782     return;
5783
5784   switch (ffebld_op (expr))
5785     {
5786     case FFEBLD_opSYMTER:
5787       s = ffebld_symter (expr);
5788       t = ffesymbol_hook (s).decl_tree;
5789       if ((t == NULL_TREE)
5790           && ((ffesymbol_kind (s) != FFEINFO_kindNONE)
5791               || ((ffesymbol_where (s) != FFEINFO_whereNONE)
5792                   && (ffesymbol_where (s) != FFEINFO_whereINTRINSIC))))
5793         {
5794           s = ffecom_sym_transform_ (s);
5795           t = ffesymbol_hook (s).decl_tree;     /* Sfunc expr non-dummy,
5796                                                    DIMENSION expr? */
5797         }
5798       break;                    /* Ok if (t == NULL) here. */
5799
5800     case FFEBLD_opITEM:
5801       ffecom_expr_transform_ (ffebld_head (expr));
5802       expr = ffebld_trail (expr);
5803       goto tail_recurse;        /* :::::::::::::::::::: */
5804
5805     default:
5806       break;
5807     }
5808
5809   switch (ffebld_arity (expr))
5810     {
5811     case 2:
5812       ffecom_expr_transform_ (ffebld_left (expr));
5813       expr = ffebld_right (expr);
5814       goto tail_recurse;        /* :::::::::::::::::::: */
5815
5816     case 1:
5817       expr = ffebld_left (expr);
5818       goto tail_recurse;        /* :::::::::::::::::::: */
5819
5820     default:
5821       break;
5822     }
5823
5824   return;
5825 }
5826
5827 /* Make a type based on info in live f2c.h file.  */
5828
5829 static void
5830 ffecom_f2c_make_type_ (tree *type, int tcode, const char *name)
5831 {
5832   switch (tcode)
5833     {
5834     case FFECOM_f2ccodeCHAR:
5835       *type = make_signed_type (CHAR_TYPE_SIZE);
5836       break;
5837
5838     case FFECOM_f2ccodeSHORT:
5839       *type = make_signed_type (SHORT_TYPE_SIZE);
5840       break;
5841
5842     case FFECOM_f2ccodeINT:
5843       *type = make_signed_type (INT_TYPE_SIZE);
5844       break;
5845
5846     case FFECOM_f2ccodeLONG:
5847       *type = make_signed_type (LONG_TYPE_SIZE);
5848       break;
5849
5850     case FFECOM_f2ccodeLONGLONG:
5851       *type = make_signed_type (LONG_LONG_TYPE_SIZE);
5852       break;
5853
5854     case FFECOM_f2ccodeCHARPTR:
5855       *type = build_pointer_type (DEFAULT_SIGNED_CHAR
5856                                   ? signed_char_type_node
5857                                   : unsigned_char_type_node);
5858       break;
5859
5860     case FFECOM_f2ccodeFLOAT:
5861       *type = make_node (REAL_TYPE);
5862       TYPE_PRECISION (*type) = FLOAT_TYPE_SIZE;
5863       layout_type (*type);
5864       break;
5865
5866     case FFECOM_f2ccodeDOUBLE:
5867       *type = make_node (REAL_TYPE);
5868       TYPE_PRECISION (*type) = DOUBLE_TYPE_SIZE;
5869       layout_type (*type);
5870       break;
5871
5872     case FFECOM_f2ccodeLONGDOUBLE:
5873       *type = make_node (REAL_TYPE);
5874       TYPE_PRECISION (*type) = LONG_DOUBLE_TYPE_SIZE;
5875       layout_type (*type);
5876       break;
5877
5878     case FFECOM_f2ccodeTWOREALS:
5879       *type = ffecom_make_complex_type_ (ffecom_f2c_real_type_node);
5880       break;
5881
5882     case FFECOM_f2ccodeTWODOUBLEREALS:
5883       *type = ffecom_make_complex_type_ (ffecom_f2c_doublereal_type_node);
5884       break;
5885
5886     default:
5887       assert ("unexpected FFECOM_f2ccodeXYZZY!" == NULL);
5888       *type = error_mark_node;
5889       return;
5890     }
5891
5892   pushdecl (build_decl (TYPE_DECL,
5893                         ffecom_get_invented_identifier ("__g77_f2c_%s", name),
5894                         *type));
5895 }
5896
5897 /* Set the f2c list-directed-I/O code for whatever (integral) type has the
5898    given size.  */
5899
5900 static void
5901 ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size, int code)
5902 {
5903   int j;
5904   tree t;
5905
5906   for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
5907     if ((t = ffecom_tree_type[bt][j]) != NULL_TREE
5908         && compare_tree_int (TYPE_SIZE (t), size) == 0)
5909       {
5910         assert (code != -1);
5911         ffecom_f2c_typecode_[bt][j] = code;
5912         code = -1;
5913       }
5914 }
5915
5916 /* Finish up globals after doing all program units in file
5917
5918    Need to handle only uninitialized COMMON areas.  */
5919
5920 static ffeglobal
5921 ffecom_finish_global_ (ffeglobal global)
5922 {
5923   tree cbtype;
5924   tree cbt;
5925   tree size;
5926
5927   if (ffeglobal_type (global) != FFEGLOBAL_typeCOMMON)
5928       return global;
5929
5930   if (ffeglobal_common_init (global))
5931       return global;
5932
5933   cbt = ffeglobal_hook (global);
5934   if ((cbt == NULL_TREE)
5935       || !ffeglobal_common_have_size (global))
5936     return global;              /* No need to make common, never ref'd. */
5937
5938   DECL_EXTERNAL (cbt) = 0;
5939
5940   /* Give the array a size now.  */
5941
5942   size = build_int_2 ((ffeglobal_common_size (global)
5943                       + ffeglobal_common_pad (global)) - 1,
5944                       0);
5945
5946   cbtype = TREE_TYPE (cbt);
5947   TYPE_DOMAIN (cbtype) = build_range_type (integer_type_node,
5948                                            integer_zero_node,
5949                                            size);
5950   if (!TREE_TYPE (size))
5951     TREE_TYPE (size) = TYPE_DOMAIN (cbtype);
5952   layout_type (cbtype);
5953
5954   cbt = start_decl (cbt, FALSE);
5955   assert (cbt == ffeglobal_hook (global));
5956
5957   finish_decl (cbt, NULL_TREE, FALSE);
5958
5959   return global;
5960 }
5961
5962 /* Finish up any untransformed symbols.  */
5963
5964 static ffesymbol
5965 ffecom_finish_symbol_transform_ (ffesymbol s)
5966 {
5967   if ((s == NULL) || (TREE_CODE (current_function_decl) == ERROR_MARK))
5968     return s;
5969
5970   /* It's easy to know to transform an untransformed symbol, to make sure
5971      we put out debugging info for it.  But COMMON variables, unlike
5972      EQUIVALENCE ones, aren't given declarations in addition to the
5973      tree expressions that specify offsets, because COMMON variables
5974      can be referenced in the outer scope where only dummy arguments
5975      (PARM_DECLs) should really be seen.  To be safe, just don't do any
5976      VAR_DECLs for COMMON variables when we transform them for real
5977      use, and therefore we do all the VAR_DECL creating here.  */
5978
5979   if (ffesymbol_hook (s).decl_tree == NULL_TREE)
5980     {
5981       if (ffesymbol_kind (s) != FFEINFO_kindNONE
5982           || (ffesymbol_where (s) != FFEINFO_whereNONE
5983               && ffesymbol_where (s) != FFEINFO_whereINTRINSIC
5984               && ffesymbol_where (s) != FFEINFO_whereDUMMY))
5985         /* Not transformed, and not CHARACTER*(*), and not a dummy
5986            argument, which can happen only if the entry point names
5987            it "rides in on" are all invalidated for other reasons.  */
5988         s = ffecom_sym_transform_ (s);
5989     }
5990
5991   if ((ffesymbol_where (s) == FFEINFO_whereCOMMON)
5992       && (ffesymbol_hook (s).decl_tree != error_mark_node))
5993     {
5994       /* This isn't working, at least for dbxout.  The .s file looks
5995          okay to me (burley), but in gdb 4.9 at least, the variables
5996          appear to reside somewhere outside of the common area, so
5997          it doesn't make sense to mislead anyone by generating the info
5998          on those variables until this is fixed.  NOTE: Same problem
5999          with EQUIVALENCE, sadly...see similar #if later.  */
6000       ffecom_member_phase2_ (ffesymbol_storage (ffesymbol_common (s)),
6001                              ffesymbol_storage (s));
6002     }
6003
6004   return s;
6005 }
6006
6007 /* Append underscore(s) to name before calling get_identifier.  "us"
6008    is nonzero if the name already contains an underscore and thus
6009    needs two underscores appended.  */
6010
6011 static tree
6012 ffecom_get_appended_identifier_ (char us, const char *name)
6013 {
6014   int i;
6015   char *newname;
6016   tree id;
6017
6018   newname = xmalloc ((i = strlen (name)) + 1
6019                      + ffe_is_underscoring ()
6020                      + us);
6021   memcpy (newname, name, i);
6022   newname[i] = '_';
6023   newname[i + us] = '_';
6024   newname[i + 1 + us] = '\0';
6025   id = get_identifier (newname);
6026
6027   free (newname);
6028
6029   return id;
6030 }
6031
6032 /* Decide whether to append underscore to name before calling
6033    get_identifier.  */
6034
6035 static tree
6036 ffecom_get_external_identifier_ (ffesymbol s)
6037 {
6038   char us;
6039   const char *name = ffesymbol_text (s);
6040
6041   /* If name is a built-in name, just return it as is.  */
6042
6043   if (!ffe_is_underscoring ()
6044       || (strcmp (name, FFETARGET_nameBLANK_COMMON) == 0)
6045       || (strcmp (name, FFETARGET_nameUNNAMED_MAIN) == 0)
6046       || (strcmp (name, FFETARGET_nameUNNAMED_BLOCK_DATA) == 0))
6047     return get_identifier (name);
6048
6049   us = ffe_is_second_underscore ()
6050     ? (strchr (name, '_') != NULL)
6051       : 0;
6052
6053   return ffecom_get_appended_identifier_ (us, name);
6054 }
6055
6056 /* Decide whether to append underscore to internal name before calling
6057    get_identifier.
6058
6059    This is for non-external, top-function-context names only.  Transform
6060    identifier so it doesn't conflict with the transformed result
6061    of using a _different_ external name.  E.g. if "CALL FOO" is
6062    transformed into "FOO_();", then the variable in "FOO_ = 3"
6063    must be transformed into something that does not conflict, since
6064    these two things should be independent.
6065
6066    The transformation is as follows.  If the name does not contain
6067    an underscore, there is no possible conflict, so just return.
6068    If the name does contain an underscore, then transform it just
6069    like we transform an external identifier.  */
6070
6071 static tree
6072 ffecom_get_identifier_ (const char *name)
6073 {
6074   /* If name does not contain an underscore, just return it as is.  */
6075
6076   if (!ffe_is_underscoring ()
6077       || (strchr (name, '_') == NULL))
6078     return get_identifier (name);
6079
6080   return ffecom_get_appended_identifier_ (ffe_is_second_underscore (),
6081                                           name);
6082 }
6083
6084 /* ffecom_gen_sfuncdef_ -- Generate definition of statement function
6085
6086    tree t;
6087    ffesymbol s;  // kindFUNCTION, whereIMMEDIATE.
6088    t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s),
6089          ffesymbol_kindtype(s));
6090
6091    Call after setting up containing function and getting trees for all
6092    other symbols.  */
6093
6094 static tree
6095 ffecom_gen_sfuncdef_ (ffesymbol s, ffeinfoBasictype bt, ffeinfoKindtype kt)
6096 {
6097   ffebld expr = ffesymbol_sfexpr (s);
6098   tree type;
6099   tree func;
6100   tree result;
6101   bool charfunc = (bt == FFEINFO_basictypeCHARACTER);
6102   static bool recurse = FALSE;
6103   location_t old_loc = input_location;
6104
6105   ffecom_nested_entry_ = s;
6106
6107   /* For now, we don't have a handy pointer to where the sfunc is actually
6108      defined, though that should be easy to add to an ffesymbol. (The
6109      token/where info available might well point to the place where the type
6110      of the sfunc is declared, especially if that precedes the place where
6111      the sfunc itself is defined, which is typically the case.)  We should
6112      put out a null pointer rather than point somewhere wrong, but I want to
6113      see how it works at this point.  */
6114
6115   input_filename = ffesymbol_where_filename (s);
6116   input_line = ffesymbol_where_filelinenum (s);
6117
6118   /* Pretransform the expression so any newly discovered things belong to the
6119      outer program unit, not to the statement function. */
6120
6121   ffecom_expr_transform_ (expr);
6122
6123   /* Make sure no recursive invocation of this fn (a specific case of failing
6124      to pretransform an sfunc's expression, i.e. where its expression
6125      references another untransformed sfunc) happens. */
6126
6127   assert (!recurse);
6128   recurse = TRUE;
6129
6130   push_f_function_context ();
6131
6132   if (charfunc)
6133     type = void_type_node;
6134   else
6135     {
6136       type = ffecom_tree_type[bt][kt];
6137       if (type == NULL_TREE)
6138         type = integer_type_node;       /* _sym_exec_transition reports
6139                                            error. */
6140     }
6141
6142   start_function (ffecom_get_identifier_ (ffesymbol_text (s)),
6143                   build_function_type (type, NULL_TREE),
6144                   1,            /* nested/inline */
6145                   0);           /* TREE_PUBLIC */
6146
6147   /* We don't worry about COMPLEX return values here, because this is
6148      entirely internal to our code, and gcc has the ability to return COMPLEX
6149      directly as a value.  */
6150
6151   if (charfunc)
6152     {                           /* Prepend arg for where result goes. */
6153       tree type;
6154
6155       type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
6156
6157       result = ffecom_get_invented_identifier ("__g77_%s", "result");
6158
6159       ffecom_char_enhance_arg_ (&type, s);      /* Ignore returned length. */
6160
6161       type = build_pointer_type (type);
6162       result = build_decl (PARM_DECL, result, type);
6163
6164       push_parm_decl (result);
6165     }
6166   else
6167     result = NULL_TREE;         /* Not ref'd if !charfunc. */
6168
6169   ffecom_push_dummy_decls_ (ffesymbol_dummyargs (s), TRUE);
6170
6171   store_parm_decls (0);
6172
6173   ffecom_start_compstmt ();
6174
6175   if (expr != NULL)
6176     {
6177       if (charfunc)
6178         {
6179           ffetargetCharacterSize sz = ffesymbol_size (s);
6180           tree result_length;
6181
6182           result_length = build_int_2 (sz, 0);
6183           TREE_TYPE (result_length) = ffecom_f2c_ftnlen_type_node;
6184
6185           ffecom_prepare_let_char_ (sz, expr);
6186
6187           ffecom_prepare_end ();
6188
6189           ffecom_let_char_ (result, result_length, sz, expr);
6190           expand_null_return ();
6191         }
6192       else
6193         {
6194           ffecom_prepare_expr (expr);
6195
6196           ffecom_prepare_end ();
6197
6198           expand_return (ffecom_modify (NULL_TREE,
6199                                         DECL_RESULT (current_function_decl),
6200                                         ffecom_expr (expr)));
6201         }
6202     }
6203
6204   ffecom_end_compstmt ();
6205
6206   func = current_function_decl;
6207   finish_function (1);
6208
6209   pop_f_function_context ();
6210
6211   recurse = FALSE;
6212
6213   input_location = old_loc;
6214
6215   ffecom_nested_entry_ = NULL;
6216
6217   return func;
6218 }
6219
6220 static const char *
6221 ffecom_gfrt_args_ (ffecomGfrt ix)
6222 {
6223   return ffecom_gfrt_argstring_[ix];
6224 }
6225
6226 static tree
6227 ffecom_gfrt_tree_ (ffecomGfrt ix)
6228 {
6229   if (ffecom_gfrt_[ix] == NULL_TREE)
6230     ffecom_make_gfrt_ (ix);
6231
6232   return ffecom_1 (ADDR_EXPR,
6233                    build_pointer_type (TREE_TYPE (ffecom_gfrt_[ix])),
6234                    ffecom_gfrt_[ix]);
6235 }
6236
6237 /* Return initialize-to-zero expression for this VAR_DECL.  */
6238
6239 /* A somewhat evil way to prevent the garbage collector
6240    from collecting 'tree' structures.  */
6241 #define NUM_TRACKED_CHUNK 63
6242 struct tree_ggc_tracker GTY(())
6243 {
6244   struct tree_ggc_tracker *next;
6245   tree trees[NUM_TRACKED_CHUNK];
6246 };
6247 static GTY(()) struct tree_ggc_tracker *tracker_head;
6248
6249 void
6250 ffecom_save_tree_forever (tree t)
6251 {
6252   int i;
6253   if (tracker_head != NULL)
6254     for (i = 0; i < NUM_TRACKED_CHUNK; i++)
6255       if (tracker_head->trees[i] == NULL)
6256         {
6257           tracker_head->trees[i] = t;
6258           return;
6259         }
6260
6261   {
6262     /* Need to allocate a new block.  */
6263     struct tree_ggc_tracker *old_head = tracker_head;
6264
6265     tracker_head = ggc_alloc (sizeof (*tracker_head));
6266     tracker_head->next = old_head;
6267     tracker_head->trees[0] = t;
6268     for (i = 1; i < NUM_TRACKED_CHUNK; i++)
6269       tracker_head->trees[i] = NULL;
6270   }
6271 }
6272
6273 static tree
6274 ffecom_init_zero_ (tree decl)
6275 {
6276   tree init;
6277   int incremental = TREE_STATIC (decl);
6278   tree type = TREE_TYPE (decl);
6279
6280   if (incremental)
6281     {
6282       make_decl_rtl (decl, NULL);
6283       assemble_variable (decl, TREE_PUBLIC (decl) ? 1 : 0, 0, 1);
6284     }
6285
6286   if ((TREE_CODE (type) != ARRAY_TYPE)
6287       && (TREE_CODE (type) != RECORD_TYPE)
6288       && (TREE_CODE (type) != UNION_TYPE)
6289       && !incremental)
6290     init = convert (type, integer_zero_node);
6291   else if (!incremental)
6292     {
6293       init = build_constructor (type, NULL_TREE);
6294       TREE_CONSTANT (init) = 1;
6295       TREE_STATIC (init) = 1;
6296     }
6297   else
6298     {
6299       assemble_zeros (int_size_in_bytes (type));
6300       init = error_mark_node;
6301     }
6302
6303   return init;
6304 }
6305
6306 static tree
6307 ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg, tree *maybe_tree)
6308 {
6309   tree expr_tree;
6310   tree length_tree;
6311
6312   switch (ffebld_op (arg))
6313     {
6314     case FFEBLD_opCONTER:       /* For F90, check 0-length. */
6315       if (ffetarget_length_character1
6316           (ffebld_constant_character1
6317            (ffebld_conter (arg))) == 0)
6318         {
6319           *maybe_tree = integer_zero_node;
6320           return convert (tree_type, integer_zero_node);
6321         }
6322
6323       *maybe_tree = integer_one_node;
6324       expr_tree = build_int_2 (*ffetarget_text_character1
6325                                (ffebld_constant_character1
6326                                 (ffebld_conter (arg))),
6327                                0);
6328       TREE_TYPE (expr_tree) = tree_type;
6329       return expr_tree;
6330
6331     case FFEBLD_opSYMTER:
6332     case FFEBLD_opARRAYREF:
6333     case FFEBLD_opFUNCREF:
6334     case FFEBLD_opSUBSTR:
6335       ffecom_char_args_ (&expr_tree, &length_tree, arg);
6336
6337       if ((expr_tree == error_mark_node)
6338           || (length_tree == error_mark_node))
6339         {
6340           *maybe_tree = error_mark_node;
6341           return error_mark_node;
6342         }
6343
6344       if (integer_zerop (length_tree))
6345         {
6346           *maybe_tree = integer_zero_node;
6347           return convert (tree_type, integer_zero_node);
6348         }
6349
6350       expr_tree
6351         = ffecom_1 (INDIRECT_REF,
6352                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6353                     expr_tree);
6354       expr_tree
6355         = ffecom_2 (ARRAY_REF,
6356                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6357                     expr_tree,
6358                     integer_one_node);
6359       expr_tree = convert (tree_type, expr_tree);
6360
6361       if (TREE_CODE (length_tree) == INTEGER_CST)
6362         *maybe_tree = integer_one_node;
6363       else                      /* Must check length at run time.  */
6364         *maybe_tree
6365           = ffecom_truth_value
6366             (ffecom_2 (GT_EXPR, integer_type_node,
6367                        length_tree,
6368                        ffecom_f2c_ftnlen_zero_node));
6369       return expr_tree;
6370
6371     case FFEBLD_opPAREN:
6372     case FFEBLD_opCONVERT:
6373       if (ffeinfo_size (ffebld_info (arg)) == 0)
6374         {
6375           *maybe_tree = integer_zero_node;
6376           return convert (tree_type, integer_zero_node);
6377         }
6378       return ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6379                                       maybe_tree);
6380
6381     case FFEBLD_opCONCATENATE:
6382       {
6383         tree maybe_left;
6384         tree maybe_right;
6385         tree expr_left;
6386         tree expr_right;
6387
6388         expr_left = ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6389                                              &maybe_left);
6390         expr_right = ffecom_intrinsic_ichar_ (tree_type, ffebld_right (arg),
6391                                               &maybe_right);
6392         *maybe_tree = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
6393                                 maybe_left,
6394                                 maybe_right);
6395         expr_tree = ffecom_3 (COND_EXPR, tree_type,
6396                               maybe_left,
6397                               expr_left,
6398                               expr_right);
6399         return expr_tree;
6400       }
6401
6402     default:
6403       assert ("bad op in ICHAR" == NULL);
6404       return error_mark_node;
6405     }
6406 }
6407
6408 /* ffecom_intrinsic_len_ -- Return length info for char arg (LEN())
6409
6410    tree length_arg;
6411    ffebld expr;
6412    length_arg = ffecom_intrinsic_len_ (expr);
6413
6414    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
6415    subexpressions by constructing the appropriate tree for the
6416    length-of-character-text argument in a calling sequence.  */
6417
6418 static tree
6419 ffecom_intrinsic_len_ (ffebld expr)
6420 {
6421   ffetargetCharacter1 val;
6422   tree length;
6423
6424   switch (ffebld_op (expr))
6425     {
6426     case FFEBLD_opCONTER:
6427       val = ffebld_constant_character1 (ffebld_conter (expr));
6428       length = build_int_2 (ffetarget_length_character1 (val), 0);
6429       TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6430       break;
6431
6432     case FFEBLD_opSYMTER:
6433       {
6434         ffesymbol s = ffebld_symter (expr);
6435         tree item;
6436
6437         item = ffesymbol_hook (s).decl_tree;
6438         if (item == NULL_TREE)
6439           {
6440             s = ffecom_sym_transform_ (s);
6441             item = ffesymbol_hook (s).decl_tree;
6442           }
6443         if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
6444           {
6445             if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
6446               length = ffesymbol_hook (s).length_tree;
6447             else
6448               {
6449                 length = build_int_2 (ffesymbol_size (s), 0);
6450                 TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6451               }
6452           }
6453         else if (item == error_mark_node)
6454           length = error_mark_node;
6455         else                    /* FFEINFO_kindFUNCTION: */
6456           length = NULL_TREE;
6457       }
6458       break;
6459
6460     case FFEBLD_opARRAYREF:
6461       length = ffecom_intrinsic_len_ (ffebld_left (expr));
6462       break;
6463
6464     case FFEBLD_opSUBSTR:
6465       {
6466         ffebld start;
6467         ffebld end;
6468         ffebld thing = ffebld_right (expr);
6469         tree start_tree;
6470         tree end_tree;
6471
6472         assert (ffebld_op (thing) == FFEBLD_opITEM);
6473         start = ffebld_head (thing);
6474         thing = ffebld_trail (thing);
6475         assert (ffebld_trail (thing) == NULL);
6476         end = ffebld_head (thing);
6477
6478         length = ffecom_intrinsic_len_ (ffebld_left (expr));
6479
6480         if (length == error_mark_node)
6481           break;
6482
6483         if (start == NULL)
6484           {
6485             if (end == NULL)
6486               ;
6487             else
6488               {
6489                 length = convert (ffecom_f2c_ftnlen_type_node,
6490                                   ffecom_expr (end));
6491               }
6492           }
6493         else
6494           {
6495             start_tree = convert (ffecom_f2c_ftnlen_type_node,
6496                                   ffecom_expr (start));
6497
6498             if (start_tree == error_mark_node)
6499               {
6500                 length = error_mark_node;
6501                 break;
6502               }
6503
6504             if (end == NULL)
6505               {
6506                 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6507                                    ffecom_f2c_ftnlen_one_node,
6508                                    ffecom_2 (MINUS_EXPR,
6509                                              ffecom_f2c_ftnlen_type_node,
6510                                              length,
6511                                              start_tree));
6512               }
6513             else
6514               {
6515                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
6516                                     ffecom_expr (end));
6517
6518                 if (end_tree == error_mark_node)
6519                   {
6520                     length = error_mark_node;
6521                     break;
6522                   }
6523
6524                 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6525                                    ffecom_f2c_ftnlen_one_node,
6526                                    ffecom_2 (MINUS_EXPR,
6527                                              ffecom_f2c_ftnlen_type_node,
6528                                              end_tree, start_tree));
6529               }
6530           }
6531       }
6532       break;
6533
6534     case FFEBLD_opCONCATENATE:
6535       length
6536         = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6537                     ffecom_intrinsic_len_ (ffebld_left (expr)),
6538                     ffecom_intrinsic_len_ (ffebld_right (expr)));
6539       break;
6540
6541     case FFEBLD_opFUNCREF:
6542     case FFEBLD_opCONVERT:
6543       length = build_int_2 (ffebld_size (expr), 0);
6544       TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6545       break;
6546
6547     default:
6548       assert ("bad op for single char arg expr" == NULL);
6549       length = ffecom_f2c_ftnlen_zero_node;
6550       break;
6551     }
6552
6553   assert (length != NULL_TREE);
6554
6555   return length;
6556 }
6557
6558 /* Handle CHARACTER assignments.
6559
6560    Generates code to do the assignment.  Used by ordinary assignment
6561    statement handler ffecom_let_stmt and by statement-function
6562    handler to generate code for a statement function.  */
6563
6564 static void
6565 ffecom_let_char_ (tree dest_tree, tree dest_length,
6566                   ffetargetCharacterSize dest_size, ffebld source)
6567 {
6568   ffecomConcatList_ catlist;
6569   tree source_length;
6570   tree source_tree;
6571   tree expr_tree;
6572
6573   if ((dest_tree == error_mark_node)
6574       || (dest_length == error_mark_node))
6575     return;
6576
6577   assert (dest_tree != NULL_TREE);
6578   assert (dest_length != NULL_TREE);
6579
6580   /* Source might be an opCONVERT, which just means it is a different size
6581      than the destination.  Since the underlying implementation here handles
6582      that (directly or via the s_copy or s_cat run-time-library functions),
6583      we don't need the "convenience" of an opCONVERT that tells us to
6584      truncate or blank-pad, particularly since the resulting implementation
6585      would probably be slower than otherwise. */
6586
6587   while (ffebld_op (source) == FFEBLD_opCONVERT)
6588     source = ffebld_left (source);
6589
6590   catlist = ffecom_concat_list_new_ (source, dest_size);
6591   switch (ffecom_concat_list_count_ (catlist))
6592     {
6593     case 0:                     /* Shouldn't happen, but in case it does... */
6594       ffecom_concat_list_kill_ (catlist);
6595       source_tree = null_pointer_node;
6596       source_length = ffecom_f2c_ftnlen_zero_node;
6597       expr_tree = build_tree_list (NULL_TREE, dest_tree);
6598       TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6599       TREE_CHAIN (TREE_CHAIN (expr_tree))
6600         = build_tree_list (NULL_TREE, dest_length);
6601       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6602         = build_tree_list (NULL_TREE, source_length);
6603
6604       expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6605       TREE_SIDE_EFFECTS (expr_tree) = 1;
6606
6607       expand_expr_stmt (expr_tree);
6608
6609       return;
6610
6611     case 1:                     /* The (fairly) easy case. */
6612       ffecom_char_args_ (&source_tree, &source_length,
6613                          ffecom_concat_list_expr_ (catlist, 0));
6614       ffecom_concat_list_kill_ (catlist);
6615       assert (source_tree != NULL_TREE);
6616       assert (source_length != NULL_TREE);
6617
6618       if ((source_tree == error_mark_node)
6619           || (source_length == error_mark_node))
6620         return;
6621
6622       if (dest_size == 1)
6623         {
6624           dest_tree
6625             = ffecom_1 (INDIRECT_REF,
6626                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6627                                                       (dest_tree))),
6628                         dest_tree);
6629           dest_tree
6630             = ffecom_2 (ARRAY_REF,
6631                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6632                                                       (dest_tree))),
6633                         dest_tree,
6634                         integer_one_node);
6635           source_tree
6636             = ffecom_1 (INDIRECT_REF,
6637                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6638                                                       (source_tree))),
6639                         source_tree);
6640           source_tree
6641             = ffecom_2 (ARRAY_REF,
6642                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6643                                                       (source_tree))),
6644                         source_tree,
6645                         integer_one_node);
6646
6647           expr_tree = ffecom_modify (void_type_node, dest_tree, source_tree);
6648
6649           expand_expr_stmt (expr_tree);
6650
6651           return;
6652         }
6653
6654       expr_tree = build_tree_list (NULL_TREE, dest_tree);
6655       TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6656       TREE_CHAIN (TREE_CHAIN (expr_tree))
6657         = build_tree_list (NULL_TREE, dest_length);
6658       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6659         = build_tree_list (NULL_TREE, source_length);
6660
6661       expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6662       TREE_SIDE_EFFECTS (expr_tree) = 1;
6663
6664       expand_expr_stmt (expr_tree);
6665
6666       return;
6667
6668     default:                    /* Must actually concatenate things. */
6669       break;
6670     }
6671
6672   /* Heavy-duty concatenation. */
6673
6674   {
6675     int count = ffecom_concat_list_count_ (catlist);
6676     int i;
6677     tree lengths;
6678     tree items;
6679     tree length_array;
6680     tree item_array;
6681     tree citem;
6682     tree clength;
6683
6684     {
6685       tree hook;
6686
6687       hook = ffebld_nonter_hook (source);
6688       assert (hook);
6689       assert (TREE_CODE (hook) == TREE_VEC);
6690       assert (TREE_VEC_LENGTH (hook) == 2);
6691       length_array = lengths = TREE_VEC_ELT (hook, 0);
6692       item_array = items = TREE_VEC_ELT (hook, 1);
6693     }
6694
6695     for (i = 0; i < count; ++i)
6696       {
6697         ffecom_char_args_ (&citem, &clength,
6698                            ffecom_concat_list_expr_ (catlist, i));
6699         if ((citem == error_mark_node)
6700             || (clength == error_mark_node))
6701           {
6702             ffecom_concat_list_kill_ (catlist);
6703             return;
6704           }
6705
6706         items
6707           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
6708                       ffecom_modify (void_type_node,
6709                                      ffecom_2 (ARRAY_REF,
6710                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
6711                                                item_array,
6712                                                build_int_2 (i, 0)),
6713                                      citem),
6714                       items);
6715         lengths
6716           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
6717                       ffecom_modify (void_type_node,
6718                                      ffecom_2 (ARRAY_REF,
6719                    TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
6720                                                length_array,
6721                                                build_int_2 (i, 0)),
6722                                      clength),
6723                       lengths);
6724       }
6725
6726     expr_tree = build_tree_list (NULL_TREE, dest_tree);
6727     TREE_CHAIN (expr_tree)
6728       = build_tree_list (NULL_TREE,
6729                          ffecom_1 (ADDR_EXPR,
6730                                    build_pointer_type (TREE_TYPE (items)),
6731                                    items));
6732     TREE_CHAIN (TREE_CHAIN (expr_tree))
6733       = build_tree_list (NULL_TREE,
6734                          ffecom_1 (ADDR_EXPR,
6735                                    build_pointer_type (TREE_TYPE (lengths)),
6736                                    lengths));
6737     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6738       = build_tree_list
6739         (NULL_TREE,
6740          ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
6741                    convert (ffecom_f2c_ftnlen_type_node,
6742                             build_int_2 (count, 0))));
6743     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree))))
6744       = build_tree_list (NULL_TREE, dest_length);
6745
6746     expr_tree = ffecom_call_gfrt (FFECOM_gfrtCAT, expr_tree, NULL_TREE);
6747     TREE_SIDE_EFFECTS (expr_tree) = 1;
6748
6749     expand_expr_stmt (expr_tree);
6750   }
6751
6752   ffecom_concat_list_kill_ (catlist);
6753 }
6754
6755 /* ffecom_make_gfrt_ -- Make initial info for run-time routine
6756
6757    ffecomGfrt ix;
6758    ffecom_make_gfrt_(ix);
6759
6760    Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL
6761    for the indicated run-time routine (ix).  */
6762
6763 static void
6764 ffecom_make_gfrt_ (ffecomGfrt ix)
6765 {
6766   tree t;
6767   tree ttype;
6768
6769   switch (ffecom_gfrt_type_[ix])
6770     {
6771     case FFECOM_rttypeVOID_:
6772       ttype = void_type_node;
6773       break;
6774
6775     case FFECOM_rttypeVOIDSTAR_:
6776       ttype = TREE_TYPE (null_pointer_node);    /* `void *'. */
6777       break;
6778
6779     case FFECOM_rttypeFTNINT_:
6780       ttype = ffecom_f2c_ftnint_type_node;
6781       break;
6782
6783     case FFECOM_rttypeINTEGER_:
6784       ttype = ffecom_f2c_integer_type_node;
6785       break;
6786
6787     case FFECOM_rttypeLONGINT_:
6788       ttype = ffecom_f2c_longint_type_node;
6789       break;
6790
6791     case FFECOM_rttypeLOGICAL_:
6792       ttype = ffecom_f2c_logical_type_node;
6793       break;
6794
6795     case FFECOM_rttypeREAL_F2C_:
6796       ttype = double_type_node;
6797       break;
6798
6799     case FFECOM_rttypeREAL_GNU_:
6800       ttype = float_type_node;
6801       break;
6802
6803     case FFECOM_rttypeCOMPLEX_F2C_:
6804       ttype = void_type_node;
6805       break;
6806
6807     case FFECOM_rttypeCOMPLEX_GNU_:
6808       ttype = ffecom_f2c_complex_type_node;
6809       break;
6810
6811     case FFECOM_rttypeDOUBLE_:
6812       ttype = double_type_node;
6813       break;
6814
6815     case FFECOM_rttypeDOUBLEREAL_:
6816       ttype = ffecom_f2c_doublereal_type_node;
6817       break;
6818
6819     case FFECOM_rttypeDBLCMPLX_F2C_:
6820       ttype = void_type_node;
6821       break;
6822
6823     case FFECOM_rttypeDBLCMPLX_GNU_:
6824       ttype = ffecom_f2c_doublecomplex_type_node;
6825       break;
6826
6827     case FFECOM_rttypeCHARACTER_:
6828       ttype = void_type_node;
6829       break;
6830
6831     default:
6832       ttype = NULL;
6833       assert ("bad rttype" == NULL);
6834       break;
6835     }
6836
6837   ttype = build_function_type (ttype, NULL_TREE);
6838   t = build_decl (FUNCTION_DECL,
6839                   get_identifier (ffecom_gfrt_name_[ix]),
6840                   ttype);
6841   DECL_EXTERNAL (t) = 1;
6842   TREE_READONLY (t) = ffecom_gfrt_const_[ix] ? 1 : 0;
6843   TREE_PUBLIC (t) = 1;
6844   TREE_THIS_VOLATILE (t) = ffecom_gfrt_volatile_[ix] ? 1 : 0;
6845
6846   /* Sanity check:  A function that's const cannot be volatile.  */
6847
6848   assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_volatile_[ix] : 1);
6849
6850   /* Sanity check: A function that's const cannot return complex.  */
6851
6852   assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_complex_[ix] : 1);
6853
6854   t = start_decl (t, TRUE);
6855
6856   finish_decl (t, NULL_TREE, TRUE);
6857
6858   ffecom_gfrt_[ix] = t;
6859 }
6860
6861 /* Phase 1 pass over each member of a COMMON/EQUIVALENCE group.  */
6862
6863 static void
6864 ffecom_member_phase1_ (ffestorag mst UNUSED, ffestorag st)
6865 {
6866   ffesymbol s = ffestorag_symbol (st);
6867
6868   if (ffesymbol_namelisted (s))
6869     ffecom_member_namelisted_ = TRUE;
6870 }
6871
6872 /* Phase 2 pass over each member of a COMMON/EQUIVALENCE group.  Declare
6873    the member so debugger will see it.  Otherwise nobody should be
6874    referencing the member.  */
6875
6876 static void
6877 ffecom_member_phase2_ (ffestorag mst, ffestorag st)
6878 {
6879   ffesymbol s;
6880   tree t;
6881   tree mt;
6882   tree type;
6883
6884   if ((mst == NULL)
6885       || ((mt = ffestorag_hook (mst)) == NULL)
6886       || (mt == error_mark_node))
6887     return;
6888
6889   if ((st == NULL)
6890       || ((s = ffestorag_symbol (st)) == NULL))
6891     return;
6892
6893   type = ffecom_type_localvar_ (s,
6894                                 ffesymbol_basictype (s),
6895                                 ffesymbol_kindtype (s));
6896   if (type == error_mark_node)
6897     return;
6898
6899   t = build_decl (VAR_DECL,
6900                   ffecom_get_identifier_ (ffesymbol_text (s)),
6901                   type);
6902
6903   TREE_STATIC (t) = TREE_STATIC (mt);
6904   DECL_INITIAL (t) = NULL_TREE;
6905   TREE_ASM_WRITTEN (t) = 1;
6906   TREE_USED (t) = 1;
6907
6908   SET_DECL_RTL (t,
6909                 gen_rtx (MEM, TYPE_MODE (type),
6910                          plus_constant (XEXP (DECL_RTL (mt), 0),
6911                                         ffestorag_modulo (mst)
6912                                         + ffestorag_offset (st)
6913                                         - ffestorag_offset (mst))));
6914
6915   t = start_decl (t, FALSE);
6916
6917   finish_decl (t, NULL_TREE, FALSE);
6918 }
6919
6920 /* Prepare source expression for assignment into a destination perhaps known
6921    to be of a specific size.  */
6922
6923 static void
6924 ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size, ffebld source)
6925 {
6926   ffecomConcatList_ catlist;
6927   int count;
6928   int i;
6929   tree ltmp;
6930   tree itmp;
6931   tree tempvar = NULL_TREE;
6932
6933   while (ffebld_op (source) == FFEBLD_opCONVERT)
6934     source = ffebld_left (source);
6935
6936   catlist = ffecom_concat_list_new_ (source, dest_size);
6937   count = ffecom_concat_list_count_ (catlist);
6938
6939   if (count >= 2)
6940     {
6941       ltmp
6942         = ffecom_make_tempvar ("let_char_len", ffecom_f2c_ftnlen_type_node,
6943                                FFETARGET_charactersizeNONE, count);
6944       itmp
6945         = ffecom_make_tempvar ("let_char_item", ffecom_f2c_address_type_node,
6946                                FFETARGET_charactersizeNONE, count);
6947
6948       tempvar = make_tree_vec (2);
6949       TREE_VEC_ELT (tempvar, 0) = ltmp;
6950       TREE_VEC_ELT (tempvar, 1) = itmp;
6951     }
6952
6953   for (i = 0; i < count; ++i)
6954     ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist, i));
6955
6956   ffecom_concat_list_kill_ (catlist);
6957
6958   if (tempvar)
6959     {
6960       ffebld_nonter_set_hook (source, tempvar);
6961       current_binding_level->prep_state = 1;
6962     }
6963 }
6964
6965 /* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order
6966
6967    Ignores STAR (alternate-return) dummies.  All other get exec-transitioned
6968    (which generates their trees) and then their trees get push_parm_decl'd.
6969
6970    The second arg is TRUE if the dummies are for a statement function, in
6971    which case lengths are not pushed for character arguments (since they are
6972    always known by both the caller and the callee, though the code allows
6973    for someday permitting CHAR*(*) stmtfunc dummies).  */
6974
6975 static void
6976 ffecom_push_dummy_decls_ (ffebld dummy_list, bool stmtfunc)
6977 {
6978   ffebld dummy;
6979   ffebld dumlist;
6980   ffesymbol s;
6981   tree parm;
6982
6983   ffecom_transform_only_dummies_ = TRUE;
6984
6985   /* First push the parms corresponding to actual dummy "contents".  */
6986
6987   for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
6988     {
6989       dummy = ffebld_head (dumlist);
6990       switch (ffebld_op (dummy))
6991         {
6992         case FFEBLD_opSTAR:
6993         case FFEBLD_opANY:
6994           continue;             /* Forget alternate returns. */
6995
6996         default:
6997           break;
6998         }
6999       assert (ffebld_op (dummy) == FFEBLD_opSYMTER);
7000       s = ffebld_symter (dummy);
7001       parm = ffesymbol_hook (s).decl_tree;
7002       if (parm == NULL_TREE)
7003         {
7004           s = ffecom_sym_transform_ (s);
7005           parm = ffesymbol_hook (s).decl_tree;
7006           assert (parm != NULL_TREE);
7007         }
7008       if (parm != error_mark_node)
7009         push_parm_decl (parm);
7010     }
7011
7012   /* Then, for CHARACTER dummies, push the parms giving their lengths.  */
7013
7014   for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7015     {
7016       dummy = ffebld_head (dumlist);
7017       switch (ffebld_op (dummy))
7018         {
7019         case FFEBLD_opSTAR:
7020         case FFEBLD_opANY:
7021           continue;             /* Forget alternate returns, they mean
7022                                    NOTHING! */
7023
7024         default:
7025           break;
7026         }
7027       s = ffebld_symter (dummy);
7028       if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
7029         continue;               /* Only looking for CHARACTER arguments. */
7030       if (stmtfunc && (ffesymbol_size (s) != FFETARGET_charactersizeNONE))
7031         continue;               /* Stmtfunc arg with known size needs no
7032                                    length param. */
7033       if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
7034         continue;               /* Only looking for variables and arrays. */
7035       parm = ffesymbol_hook (s).length_tree;
7036       assert (parm != NULL_TREE);
7037       if (parm != error_mark_node)
7038         push_parm_decl (parm);
7039     }
7040
7041   ffecom_transform_only_dummies_ = FALSE;
7042 }
7043
7044 /* ffecom_start_progunit_ -- Beginning of program unit
7045
7046    Does GNU back end stuff necessary to teach it about the start of its
7047    equivalent of a Fortran program unit.  */
7048
7049 static void
7050 ffecom_start_progunit_ (void)
7051 {
7052   ffesymbol fn = ffecom_primary_entry_;
7053   ffebld arglist;
7054   tree id;                      /* Identifier (name) of function. */
7055   tree type;                    /* Type of function. */
7056   tree result;                  /* Result of function. */
7057   ffeinfoBasictype bt;
7058   ffeinfoKindtype kt;
7059   ffeglobal g;
7060   ffeglobalType gt;
7061   ffeglobalType egt = FFEGLOBAL_type;
7062   bool charfunc;
7063   bool cmplxfunc;
7064   bool altentries = (ffecom_num_entrypoints_ != 0);
7065   bool multi
7066   = altentries
7067   && (ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
7068   && (ffecom_master_bt_ == FFEINFO_basictypeNONE);
7069   bool main_program = FALSE;
7070   location_t old_loc = input_location;
7071
7072   assert (fn != NULL);
7073   assert (ffesymbol_hook (fn).decl_tree == NULL_TREE);
7074
7075   input_filename = ffesymbol_where_filename (fn);
7076   input_line = ffesymbol_where_filelinenum (fn);
7077
7078   switch (ffecom_primary_entry_kind_)
7079     {
7080     case FFEINFO_kindPROGRAM:
7081       main_program = TRUE;
7082       gt = FFEGLOBAL_typeMAIN;
7083       bt = FFEINFO_basictypeNONE;
7084       kt = FFEINFO_kindtypeNONE;
7085       type = ffecom_tree_fun_type_void;
7086       charfunc = FALSE;
7087       cmplxfunc = FALSE;
7088       break;
7089
7090     case FFEINFO_kindBLOCKDATA:
7091       gt = FFEGLOBAL_typeBDATA;
7092       bt = FFEINFO_basictypeNONE;
7093       kt = FFEINFO_kindtypeNONE;
7094       type = ffecom_tree_fun_type_void;
7095       charfunc = FALSE;
7096       cmplxfunc = FALSE;
7097       break;
7098
7099     case FFEINFO_kindFUNCTION:
7100       gt = FFEGLOBAL_typeFUNC;
7101       egt = FFEGLOBAL_typeEXT;
7102       bt = ffesymbol_basictype (fn);
7103       kt = ffesymbol_kindtype (fn);
7104       if (bt == FFEINFO_basictypeNONE)
7105         {
7106           ffeimplic_establish_symbol (fn);
7107           if (ffesymbol_funcresult (fn) != NULL)
7108             ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
7109           bt = ffesymbol_basictype (fn);
7110           kt = ffesymbol_kindtype (fn);
7111         }
7112
7113       if (multi)
7114         charfunc = cmplxfunc = FALSE;
7115       else if (bt == FFEINFO_basictypeCHARACTER)
7116         charfunc = TRUE, cmplxfunc = FALSE;
7117       else if ((bt == FFEINFO_basictypeCOMPLEX)
7118                && ffesymbol_is_f2c (fn)
7119                && !altentries)
7120         charfunc = FALSE, cmplxfunc = TRUE;
7121       else
7122         charfunc = cmplxfunc = FALSE;
7123
7124       if (multi || charfunc)
7125         type = ffecom_tree_fun_type_void;
7126       else if (ffesymbol_is_f2c (fn) && !altentries)
7127         type = ffecom_tree_fun_type[bt][kt];
7128       else
7129         type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
7130
7131       if ((type == NULL_TREE)
7132           || (TREE_TYPE (type) == NULL_TREE))
7133         type = ffecom_tree_fun_type_void;       /* _sym_exec_transition. */
7134       break;
7135
7136     case FFEINFO_kindSUBROUTINE:
7137       gt = FFEGLOBAL_typeSUBR;
7138       egt = FFEGLOBAL_typeEXT;
7139       bt = FFEINFO_basictypeNONE;
7140       kt = FFEINFO_kindtypeNONE;
7141       if (ffecom_is_altreturning_)
7142         type = ffecom_tree_subr_type;
7143       else
7144         type = ffecom_tree_fun_type_void;
7145       charfunc = FALSE;
7146       cmplxfunc = FALSE;
7147       break;
7148
7149     default:
7150       assert ("say what??" == NULL);
7151       /* Fall through. */
7152     case FFEINFO_kindANY:
7153       gt = FFEGLOBAL_typeANY;
7154       bt = FFEINFO_basictypeNONE;
7155       kt = FFEINFO_kindtypeNONE;
7156       type = error_mark_node;
7157       charfunc = FALSE;
7158       cmplxfunc = FALSE;
7159       break;
7160     }
7161
7162   if (altentries)
7163     {
7164       id = ffecom_get_invented_identifier ("__g77_masterfun_%s",
7165                                            ffesymbol_text (fn));
7166     }
7167 #if FFETARGET_isENFORCED_MAIN
7168   else if (main_program)
7169     id = get_identifier (FFETARGET_nameENFORCED_MAIN_NAME);
7170 #endif
7171   else
7172     id = ffecom_get_external_identifier_ (fn);
7173
7174   start_function (id,
7175                   type,
7176                   0,            /* nested/inline */
7177                   !altentries); /* TREE_PUBLIC */
7178
7179   TREE_USED (current_function_decl) = 1;        /* Avoid spurious warning if altentries. */
7180
7181   if (!altentries
7182       && ((g = ffesymbol_global (fn)) != NULL)
7183       && ((ffeglobal_type (g) == gt)
7184           || (ffeglobal_type (g) == egt)))
7185     {
7186       ffeglobal_set_hook (g, current_function_decl);
7187     }
7188
7189   /* Arg handling needs exec-transitioned ffesymbols to work with.  But
7190      exec-transitioning needs current_function_decl to be filled in.  So we
7191      do these things in two phases. */
7192
7193   if (altentries)
7194     {                           /* 1st arg identifies which entrypoint. */
7195       ffecom_which_entrypoint_decl_
7196         = build_decl (PARM_DECL,
7197                       ffecom_get_invented_identifier ("__g77_%s",
7198                                                       "which_entrypoint"),
7199                       integer_type_node);
7200       push_parm_decl (ffecom_which_entrypoint_decl_);
7201     }
7202
7203   if (charfunc
7204       || cmplxfunc
7205       || multi)
7206     {                           /* Arg for result (return value). */
7207       tree type;
7208       tree length;
7209
7210       if (charfunc)
7211         type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
7212       else if (cmplxfunc)
7213         type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
7214       else
7215         type = ffecom_multi_type_node_;
7216
7217       result = ffecom_get_invented_identifier ("__g77_%s", "result");
7218
7219       /* Make length arg _and_ enhance type info for CHAR arg itself.  */
7220
7221       if (charfunc)
7222         length = ffecom_char_enhance_arg_ (&type, fn);
7223       else
7224         length = NULL_TREE;     /* Not ref'd if !charfunc. */
7225
7226       type = build_pointer_type (type);
7227       result = build_decl (PARM_DECL, result, type);
7228
7229       push_parm_decl (result);
7230       if (multi)
7231         ffecom_multi_retval_ = result;
7232       else
7233         ffecom_func_result_ = result;
7234
7235       if (charfunc)
7236         {
7237           push_parm_decl (length);
7238           ffecom_func_length_ = length;
7239         }
7240     }
7241
7242   if (ffecom_primary_entry_is_proc_)
7243     {
7244       if (altentries)
7245         arglist = ffecom_master_arglist_;
7246       else
7247         arglist = ffesymbol_dummyargs (fn);
7248       ffecom_push_dummy_decls_ (arglist, FALSE);
7249     }
7250
7251   if (TREE_CODE (current_function_decl) != ERROR_MARK)
7252     store_parm_decls (main_program ? 1 : 0);
7253
7254   ffecom_start_compstmt ();
7255   /* Disallow temp vars at this level.  */
7256   current_binding_level->prep_state = 2;
7257
7258   input_location = old_loc;
7259
7260   /* This handles any symbols still untransformed, in case -g specified.
7261      This used to be done in ffecom_finish_progunit, but it turns out to
7262      be necessary to do it here so that statement functions are
7263      expanded before code.  But don't bother for BLOCK DATA.  */
7264
7265   if (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
7266     ffesymbol_drive (ffecom_finish_symbol_transform_);
7267 }
7268
7269 /* ffecom_sym_transform_ -- Transform FFE sym into backend sym
7270
7271    ffesymbol s;
7272    ffecom_sym_transform_(s);
7273
7274    The ffesymbol_hook info for s is updated with appropriate backend info
7275    on the symbol.  */
7276
7277 static ffesymbol
7278 ffecom_sym_transform_ (ffesymbol s)
7279 {
7280   tree t;                       /* Transformed thingy. */
7281   tree tlen;                    /* Length if CHAR*(*). */
7282   bool addr;                    /* Is t the address of the thingy? */
7283   ffeinfoBasictype bt;
7284   ffeinfoKindtype kt;
7285   ffeglobal g;
7286   location_t old_loc = input_location;
7287
7288   /* Must ensure special ASSIGN variables are declared at top of outermost
7289      block, else they'll end up in the innermost block when their first
7290      ASSIGN is seen, which leaves them out of scope when they're the
7291      subject of a GOTO or I/O statement.
7292
7293      We make this variable even if -fugly-assign.  Just let it go unused,
7294      in case it turns out there are cases where we really want to use this
7295      variable anyway (e.g. ASSIGN to INTEGER*2 variable).  */
7296
7297   if (! ffecom_transform_only_dummies_
7298       && ffesymbol_assigned (s)
7299       && ! ffesymbol_hook (s).assign_tree)
7300     s = ffecom_sym_transform_assign_ (s);
7301
7302   if (ffesymbol_sfdummyparent (s) == NULL)
7303     {
7304       input_filename = ffesymbol_where_filename (s);
7305       input_line = ffesymbol_where_filelinenum (s);
7306     }
7307   else
7308     {
7309       ffesymbol sf = ffesymbol_sfdummyparent (s);
7310
7311       input_filename = ffesymbol_where_filename (sf);
7312       input_line = ffesymbol_where_filelinenum (sf);
7313     }
7314
7315   bt = ffeinfo_basictype (ffebld_info (s));
7316   kt = ffeinfo_kindtype (ffebld_info (s));
7317
7318   t = NULL_TREE;
7319   tlen = NULL_TREE;
7320   addr = FALSE;
7321
7322   switch (ffesymbol_kind (s))
7323     {
7324     case FFEINFO_kindNONE:
7325       switch (ffesymbol_where (s))
7326         {
7327         case FFEINFO_whereDUMMY:        /* Subroutine or function. */
7328           assert (ffecom_transform_only_dummies_);
7329
7330           /* Before 0.4, this could be ENTITY/DUMMY, but see
7331              ffestu_sym_end_transition -- no longer true (in particular, if
7332              it could be an ENTITY, it _will_ be made one, so that
7333              possibility won't come through here).  So we never make length
7334              arg for CHARACTER type.  */
7335
7336           t = build_decl (PARM_DECL,
7337                           ffecom_get_identifier_ (ffesymbol_text (s)),
7338                           ffecom_tree_ptr_to_subr_type);
7339           DECL_ARTIFICIAL (t) = 1;
7340           addr = TRUE;
7341           break;
7342
7343         case FFEINFO_whereGLOBAL:       /* Subroutine or function. */
7344           assert (!ffecom_transform_only_dummies_);
7345
7346           if (((g = ffesymbol_global (s)) != NULL)
7347               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7348                   || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7349                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
7350               && (ffeglobal_hook (g) != NULL_TREE)
7351               && ffe_is_globals ())
7352             {
7353               t = ffeglobal_hook (g);
7354               break;
7355             }
7356
7357           t = build_decl (FUNCTION_DECL,
7358                           ffecom_get_external_identifier_ (s),
7359                           ffecom_tree_subr_type);       /* Assume subr. */
7360           DECL_EXTERNAL (t) = 1;
7361           TREE_PUBLIC (t) = 1;
7362
7363           t = start_decl (t, FALSE);
7364           finish_decl (t, NULL_TREE, FALSE);
7365
7366           if ((g != NULL)
7367               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7368                   || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7369                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
7370             ffeglobal_set_hook (g, t);
7371
7372           ffecom_save_tree_forever (t);
7373
7374           break;
7375
7376         default:
7377           assert ("NONE where unexpected" == NULL);
7378           /* Fall through. */
7379         case FFEINFO_whereANY:
7380           break;
7381         }
7382       break;
7383
7384     case FFEINFO_kindENTITY:
7385       switch (ffeinfo_where (ffesymbol_info (s)))
7386         {
7387
7388         case FFEINFO_whereCONSTANT:
7389           /* ~~Debugging info needed? */
7390           assert (!ffecom_transform_only_dummies_);
7391           t = error_mark_node;  /* Shouldn't ever see this in expr. */
7392           break;
7393
7394         case FFEINFO_whereLOCAL:
7395           assert (!ffecom_transform_only_dummies_);
7396
7397           {
7398             ffestorag st = ffesymbol_storage (s);
7399             tree type;
7400
7401             type = ffecom_type_localvar_ (s, bt, kt);
7402
7403             if (type == error_mark_node)
7404               {
7405                 t = error_mark_node;
7406                 break;
7407               }
7408
7409             if ((st != NULL)
7410                 && (ffestorag_size (st) == 0))
7411               {
7412                 t = error_mark_node;
7413                 break;
7414               }
7415
7416             if ((st != NULL)
7417                 && (ffestorag_parent (st) != NULL))
7418               {                 /* Child of EQUIVALENCE parent. */
7419                 ffestorag est;
7420                 tree et;
7421                 ffetargetOffset offset;
7422
7423                 est = ffestorag_parent (st);
7424                 ffecom_transform_equiv_ (est);
7425
7426                 et = ffestorag_hook (est);
7427                 assert (et != NULL_TREE);
7428
7429                 if (! TREE_STATIC (et))
7430                   put_var_into_stack (et, /*rescan=*/true);
7431
7432                 offset = ffestorag_modulo (est)
7433                   + ffestorag_offset (ffesymbol_storage (s))
7434                   - ffestorag_offset (est);
7435
7436                 ffecom_debug_kludge_ (et, "EQUIVALENCE", s, type, offset);
7437
7438                 /* (t_type *) (((char *) &et) + offset) */
7439
7440                 t = convert (string_type_node,  /* (char *) */
7441                              ffecom_1 (ADDR_EXPR,
7442                                        build_pointer_type (TREE_TYPE (et)),
7443                                        et));
7444                 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
7445                               t,
7446                               build_int_2 (offset, 0));
7447                 t = convert (build_pointer_type (type),
7448                              t);
7449                 TREE_CONSTANT (t) = staticp (et);
7450
7451                 addr = TRUE;
7452               }
7453             else
7454               {
7455                 tree initexpr;
7456                 bool init = ffesymbol_is_init (s);
7457
7458                 t = build_decl (VAR_DECL,
7459                                 ffecom_get_identifier_ (ffesymbol_text (s)),
7460                                 type);
7461
7462                 if (init
7463                     || ffesymbol_namelisted (s)
7464 #ifdef FFECOM_sizeMAXSTACKITEM
7465                     || ((st != NULL)
7466                         && (ffestorag_size (st) > FFECOM_sizeMAXSTACKITEM))
7467 #endif
7468                     || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
7469                         && (ffecom_primary_entry_kind_
7470                             != FFEINFO_kindBLOCKDATA)
7471                         && (ffesymbol_is_save (s) || ffe_is_saveall ())))
7472                   TREE_STATIC (t) = !ffesymbol_attr (s, FFESYMBOL_attrADJUSTABLE);
7473                 else
7474                   TREE_STATIC (t) = 0;  /* No need to make static. */
7475
7476                 if (init || ffe_is_init_local_zero ())
7477                   DECL_INITIAL (t) = error_mark_node;
7478
7479                 /* Keep -Wunused from complaining about var if it
7480                    is used as sfunc arg or DATA implied-DO.  */
7481                 if (ffesymbol_attrs (s) & FFESYMBOL_attrsSFARG)
7482                   DECL_IN_SYSTEM_HEADER (t) = 1;
7483
7484                 t = start_decl (t, FALSE);
7485
7486                 if (init)
7487                   {
7488                     if (ffesymbol_init (s) != NULL)
7489                       initexpr = ffecom_expr (ffesymbol_init (s));
7490                     else
7491                       initexpr = ffecom_init_zero_ (t);
7492                   }
7493                 else if (ffe_is_init_local_zero ())
7494                   initexpr = ffecom_init_zero_ (t);
7495                 else
7496                   initexpr = NULL_TREE; /* Not ref'd if !init. */
7497
7498                 finish_decl (t, initexpr, FALSE);
7499
7500                 if (st != NULL && DECL_SIZE (t) != error_mark_node)
7501                   {
7502                     assert (TREE_CODE (DECL_SIZE_UNIT (t)) == INTEGER_CST);
7503                     assert (0 == compare_tree_int (DECL_SIZE_UNIT (t),
7504                                                    ffestorag_size (st)));
7505                   }
7506               }
7507           }
7508           break;
7509
7510         case FFEINFO_whereRESULT:
7511           assert (!ffecom_transform_only_dummies_);
7512
7513           if (bt == FFEINFO_basictypeCHARACTER)
7514             {                   /* Result is already in list of dummies, use
7515                                    it (& length). */
7516               t = ffecom_func_result_;
7517               tlen = ffecom_func_length_;
7518               addr = TRUE;
7519               break;
7520             }
7521           if ((ffecom_num_entrypoints_ == 0)
7522               && (bt == FFEINFO_basictypeCOMPLEX)
7523               && (ffesymbol_is_f2c (ffecom_primary_entry_)))
7524             {                   /* Result is already in list of dummies, use
7525                                    it. */
7526               t = ffecom_func_result_;
7527               addr = TRUE;
7528               break;
7529             }
7530           if (ffecom_func_result_ != NULL_TREE)
7531             {
7532               t = ffecom_func_result_;
7533               break;
7534             }
7535           if ((ffecom_num_entrypoints_ != 0)
7536               && (ffecom_master_bt_ == FFEINFO_basictypeNONE))
7537             {
7538               assert (ffecom_multi_retval_ != NULL_TREE);
7539               t = ffecom_1 (INDIRECT_REF, ffecom_multi_type_node_,
7540                             ffecom_multi_retval_);
7541               t = ffecom_2 (COMPONENT_REF, ffecom_tree_type[bt][kt],
7542                             t, ffecom_multi_fields_[bt][kt]);
7543
7544               break;
7545             }
7546
7547           t = build_decl (VAR_DECL,
7548                           ffecom_get_identifier_ (ffesymbol_text (s)),
7549                           ffecom_tree_type[bt][kt]);
7550           TREE_STATIC (t) = 0;  /* Put result on stack. */
7551           t = start_decl (t, FALSE);
7552           finish_decl (t, NULL_TREE, FALSE);
7553
7554           ffecom_func_result_ = t;
7555
7556           break;
7557
7558         case FFEINFO_whereDUMMY:
7559           {
7560             tree type;
7561             ffebld dl;
7562             ffebld dim;
7563             tree low;
7564             tree high;
7565             tree old_sizes;
7566             bool adjustable = FALSE;    /* Conditionally adjustable? */
7567
7568             type = ffecom_tree_type[bt][kt];
7569             if (ffesymbol_sfdummyparent (s) != NULL)
7570               {
7571                 if (current_function_decl == ffecom_outer_function_decl_)
7572                   {                     /* Exec transition before sfunc
7573                                            context; get it later. */
7574                     break;
7575                   }
7576                 t = ffecom_get_identifier_ (ffesymbol_text
7577                                             (ffesymbol_sfdummyparent (s)));
7578               }
7579             else
7580               t = ffecom_get_identifier_ (ffesymbol_text (s));
7581
7582             assert (ffecom_transform_only_dummies_);
7583
7584             old_sizes = get_pending_sizes ();
7585             put_pending_sizes (old_sizes);
7586
7587             if (bt == FFEINFO_basictypeCHARACTER)
7588               tlen = ffecom_char_enhance_arg_ (&type, s);
7589             type = ffecom_check_size_overflow_ (s, type, TRUE);
7590
7591             for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
7592               {
7593                 if (type == error_mark_node)
7594                   break;
7595
7596                 dim = ffebld_head (dl);
7597                 assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
7598                 if ((ffebld_left (dim) == NULL) || ffecom_doing_entry_)
7599                   low = ffecom_integer_one_node;
7600                 else
7601                   low = ffecom_expr (ffebld_left (dim));
7602                 assert (ffebld_right (dim) != NULL);
7603                 if ((ffebld_op (ffebld_right (dim)) == FFEBLD_opSTAR)
7604                     || ffecom_doing_entry_)
7605                   {
7606                     /* Used to just do high=low.  But for ffecom_tree_
7607                        canonize_ref_, it probably is important to correctly
7608                        assess the size.  E.g. given COMPLEX C(*),CFUNC and
7609                        C(2)=CFUNC(C), overlap can happen, while it can't
7610                        for, say, C(1)=CFUNC(C(2)).  */
7611                     /* Even more recently used to set to INT_MAX, but that
7612                        broke when some overflow checking went into the back
7613                        end.  Now we just leave the upper bound unspecified.  */
7614                     high = NULL;
7615                   }
7616                 else
7617                   high = ffecom_expr (ffebld_right (dim));
7618
7619                 /* Determine whether array is conditionally adjustable,
7620                    to decide whether back-end magic is needed.
7621
7622                    Normally the front end uses the back-end function
7623                    variable_size to wrap SAVE_EXPR's around expressions
7624                    affecting the size/shape of an array so that the
7625                    size/shape info doesn't change during execution
7626                    of the compiled code even though variables and
7627                    functions referenced in those expressions might.
7628
7629                    variable_size also makes sure those saved expressions
7630                    get evaluated immediately upon entry to the
7631                    compiled procedure -- the front end normally doesn't
7632                    have to worry about that.
7633
7634                    However, there is a problem with this that affects
7635                    g77's implementation of entry points, and that is
7636                    that it is _not_ true that each invocation of the
7637                    compiled procedure is permitted to evaluate
7638                    array size/shape info -- because it is possible
7639                    that, for some invocations, that info is invalid (in
7640                    which case it is "promised" -- i.e. a violation of
7641                    the Fortran standard -- that the compiled code
7642                    won't reference the array or its size/shape
7643                    during that particular invocation).
7644
7645                    To phrase this in C terms, consider this gcc function:
7646
7647                      void foo (int *n, float (*a)[*n])
7648                      {
7649                        // a is "pointer to array ...", fyi.
7650                      }
7651
7652                    Suppose that, for some invocations, it is permitted
7653                    for a caller of foo to do this:
7654
7655                        foo (NULL, NULL);
7656
7657                    Now the _written_ code for foo can take such a call
7658                    into account by either testing explicitly for whether
7659                    (a == NULL) || (n == NULL) -- presumably it is
7660                    not permitted to reference *a in various fashions
7661                    if (n == NULL) I suppose -- or it can avoid it by
7662                    looking at other info (other arguments, static/global
7663                    data, etc.).
7664
7665                    However, this won't work in gcc 2.5.8 because it'll
7666                    automatically emit the code to save the "*n"
7667                    expression, which'll yield a NULL dereference for
7668                    the "foo (NULL, NULL)" call, something the code
7669                    for foo cannot prevent.
7670
7671                    g77 definitely needs to avoid executing such
7672                    code anytime the pointer to the adjustable array
7673                    is NULL, because even if its bounds expressions
7674                    don't have any references to possible "absent"
7675                    variables like "*n" -- say all variable references
7676                    are to COMMON variables, i.e. global (though in C,
7677                    local static could actually make sense) -- the
7678                    expressions could yield other run-time problems
7679                    for allowably "dead" values in those variables.
7680
7681                    For example, let's consider a more complicated
7682                    version of foo:
7683
7684                      extern int i;
7685                      extern int j;
7686
7687                      void foo (float (*a)[i/j])
7688                      {
7689                        ...
7690                      }
7691
7692                    The above is (essentially) quite valid for Fortran
7693                    but, again, for a call like "foo (NULL);", it is
7694                    permitted for i and j to be undefined when the
7695                    call is made.  If j happened to be zero, for
7696                    example, emitting the code to evaluate "i/j"
7697                    could result in a run-time error.
7698
7699                    Offhand, though I don't have my F77 or F90
7700                    standards handy, it might even be valid for a
7701                    bounds expression to contain a function reference,
7702                    in which case I doubt it is permitted for an
7703                    implementation to invoke that function in the
7704                    Fortran case involved here (invocation of an
7705                    alternate ENTRY point that doesn't have the adjustable
7706                    array as one of its arguments).
7707
7708                    So, the code that the compiler would normally emit
7709                    to preevaluate the size/shape info for an
7710                    adjustable array _must not_ be executed at run time
7711                    in certain cases.  Specifically, for Fortran,
7712                    the case is when the pointer to the adjustable
7713                    array == NULL.  (For gnu-ish C, it might be nice
7714                    for the source code itself to specify an expression
7715                    that, if TRUE, inhibits execution of the code.  Or
7716                    reverse the sense for elegance.)
7717
7718                    (Note that g77 could use a different test than NULL,
7719                    actually, since it happens to always pass an
7720                    integer to the called function that specifies which
7721                    entry point is being invoked.  Hmm, this might
7722                    solve the next problem.)
7723
7724                    One way a user could, I suppose, write "foo" so
7725                    it works is to insert COND_EXPR's for the
7726                    size/shape info so the dangerous stuff isn't
7727                    actually done, as in:
7728
7729                      void foo (int *n, float (*a)[(a == NULL) ? 0 : *n])
7730                      {
7731                        ...
7732                      }
7733
7734                    The next problem is that the front end needs to
7735                    be able to tell the back end about the array's
7736                    decl _before_ it tells it about the conditional
7737                    expression to inhibit evaluation of size/shape info,
7738                    as shown above.
7739
7740                    To solve this, the front end needs to be able
7741                    to give the back end the expression to inhibit
7742                    generation of the preevaluation code _after_
7743                    it makes the decl for the adjustable array.
7744
7745                    Until then, the above example using the COND_EXPR
7746                    doesn't pass muster with gcc because the "(a == NULL)"
7747                    part has a reference to "a", which is still
7748                    undefined at that point.
7749
7750                    g77 will therefore use a different mechanism in the
7751                    meantime.  */
7752
7753                 if (!adjustable
7754                     && ((TREE_CODE (low) != INTEGER_CST)
7755                         || (high && TREE_CODE (high) != INTEGER_CST)))
7756                   adjustable = TRUE;
7757
7758 #if 0                           /* Old approach -- see below. */
7759                 if (TREE_CODE (low) != INTEGER_CST)
7760                   low = ffecom_3 (COND_EXPR, integer_type_node,
7761                                   ffecom_adjarray_passed_ (s),
7762                                   low,
7763                                   ffecom_integer_zero_node);
7764
7765                 if (high && TREE_CODE (high) != INTEGER_CST)
7766                   high = ffecom_3 (COND_EXPR, integer_type_node,
7767                                    ffecom_adjarray_passed_ (s),
7768                                    high,
7769                                    ffecom_integer_zero_node);
7770 #endif
7771
7772                 /* ~~~gcc/stor-layout.c (layout_type) should do this,
7773                    probably.  Fixes 950302-1.f.  */
7774
7775                 if (TREE_CODE (low) != INTEGER_CST)
7776                   low = variable_size (low);
7777
7778                 /* ~~~Similarly, this fixes dumb0.f.  The C front end
7779                    does this, which is why dumb0.c would work.  */
7780
7781                 if (high && TREE_CODE (high) != INTEGER_CST)
7782                   high = variable_size (high);
7783
7784                 type
7785                   = build_array_type
7786                     (type,
7787                      build_range_type (ffecom_integer_type_node,
7788                                        low, high));
7789                 type = ffecom_check_size_overflow_ (s, type, TRUE);
7790               }
7791
7792             if (type == error_mark_node)
7793               {
7794                 t = error_mark_node;
7795                 break;
7796               }
7797
7798             if ((ffesymbol_sfdummyparent (s) == NULL)
7799                  || (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER))
7800               {
7801                 type = build_pointer_type (type);
7802                 addr = TRUE;
7803               }
7804
7805             t = build_decl (PARM_DECL, t, type);
7806             DECL_ARTIFICIAL (t) = 1;
7807
7808             /* If this arg is present in every entry point's list of
7809                dummy args, then we're done.  */
7810
7811             if (ffesymbol_numentries (s)
7812                 == (ffecom_num_entrypoints_ + 1))
7813               break;
7814
7815 #if 1
7816
7817             /* If variable_size in stor-layout has been called during
7818                the above, then get_pending_sizes should have the
7819                yet-to-be-evaluated saved expressions pending.
7820                Make the whole lot of them get emitted, conditionally
7821                on whether the array decl ("t" above) is not NULL.  */
7822
7823             {
7824               tree sizes = get_pending_sizes ();
7825               tree tem;
7826
7827               for (tem = sizes;
7828                    tem != old_sizes;
7829                    tem = TREE_CHAIN (tem))
7830                 {
7831                   tree temv = TREE_VALUE (tem);
7832
7833                   if (sizes == tem)
7834                     sizes = temv;
7835                   else
7836                     sizes
7837                       = ffecom_2 (COMPOUND_EXPR,
7838                                   TREE_TYPE (sizes),
7839                                   temv,
7840                                   sizes);
7841                 }
7842
7843               if (sizes != tem)
7844                 {
7845                   sizes
7846                     = ffecom_3 (COND_EXPR,
7847                                 TREE_TYPE (sizes),
7848                                 ffecom_2 (NE_EXPR,
7849                                           integer_type_node,
7850                                           t,
7851                                           null_pointer_node),
7852                                 sizes,
7853                                 convert (TREE_TYPE (sizes),
7854                                          integer_zero_node));
7855                   sizes = ffecom_save_tree (sizes);
7856
7857                   sizes
7858                     = tree_cons (NULL_TREE, sizes, tem);
7859                 }
7860
7861               if (sizes)
7862                 put_pending_sizes (sizes);
7863             }
7864
7865 #else
7866 #if 0
7867             if (adjustable
7868                 && (ffesymbol_numentries (s)
7869                     != ffecom_num_entrypoints_ + 1))
7870               DECL_SOMETHING (t)
7871                 = ffecom_2 (NE_EXPR, integer_type_node,
7872                             t,
7873                             null_pointer_node);
7874 #else
7875 #if 0
7876             if (adjustable
7877                 && (ffesymbol_numentries (s)
7878                     != ffecom_num_entrypoints_ + 1))
7879               {
7880                 ffebad_start (FFEBAD_MISSING_ADJARRAY_UNSUPPORTED);
7881                 ffebad_here (0, ffesymbol_where_line (s),
7882                              ffesymbol_where_column (s));
7883                 ffebad_string (ffesymbol_text (s));
7884                 ffebad_finish ();
7885               }
7886 #endif
7887 #endif
7888 #endif
7889           }
7890           break;
7891
7892         case FFEINFO_whereCOMMON:
7893           {
7894             ffesymbol cs;
7895             ffeglobal cg;
7896             tree ct;
7897             ffestorag st = ffesymbol_storage (s);
7898             tree type;
7899
7900             cs = ffesymbol_common (s);  /* The COMMON area itself.  */
7901             if (st != NULL)     /* Else not laid out. */
7902               {
7903                 ffecom_transform_common_ (cs);
7904                 st = ffesymbol_storage (s);
7905               }
7906
7907             type = ffecom_type_localvar_ (s, bt, kt);
7908
7909             cg = ffesymbol_global (cs); /* The global COMMON info.  */
7910             if ((cg == NULL)
7911                 || (ffeglobal_type (cg) != FFEGLOBAL_typeCOMMON))
7912               ct = NULL_TREE;
7913             else
7914               ct = ffeglobal_hook (cg); /* The common area's tree.  */
7915
7916             if ((ct == NULL_TREE)
7917                 || (st == NULL)
7918                 || (type == error_mark_node))
7919               t = error_mark_node;
7920             else
7921               {
7922                 ffetargetOffset offset;
7923                 ffestorag cst;
7924                 tree toffset;
7925
7926                 cst = ffestorag_parent (st);
7927                 assert (cst == ffesymbol_storage (cs));
7928
7929                 offset = ffestorag_modulo (cst)
7930                   + ffestorag_offset (st)
7931                   - ffestorag_offset (cst);
7932
7933                 ffecom_debug_kludge_ (ct, "COMMON", s, type, offset);
7934
7935                 /* (t_type *) (((char *) &ct) + offset) */
7936
7937                 t = convert (string_type_node,  /* (char *) */
7938                              ffecom_1 (ADDR_EXPR,
7939                                        build_pointer_type (TREE_TYPE (ct)),
7940                                        ct));
7941                 toffset = build_int_2 (offset, 0);
7942                 TREE_TYPE (toffset) = ssizetype;
7943                 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
7944                               t, toffset);
7945                 t = convert (build_pointer_type (type),
7946                              t);
7947                 TREE_CONSTANT (t) = 1;
7948
7949                 addr = TRUE;
7950               }
7951           }
7952           break;
7953
7954         case FFEINFO_whereIMMEDIATE:
7955         case FFEINFO_whereGLOBAL:
7956         case FFEINFO_whereFLEETING:
7957         case FFEINFO_whereFLEETING_CADDR:
7958         case FFEINFO_whereFLEETING_IADDR:
7959         case FFEINFO_whereINTRINSIC:
7960         case FFEINFO_whereCONSTANT_SUBOBJECT:
7961         default:
7962           assert ("ENTITY where unheard of" == NULL);
7963           /* Fall through. */
7964         case FFEINFO_whereANY:
7965           t = error_mark_node;
7966           break;
7967         }
7968       break;
7969
7970     case FFEINFO_kindFUNCTION:
7971       switch (ffeinfo_where (ffesymbol_info (s)))
7972         {
7973         case FFEINFO_whereLOCAL:        /* Me. */
7974           assert (!ffecom_transform_only_dummies_);
7975           t = current_function_decl;
7976           break;
7977
7978         case FFEINFO_whereGLOBAL:
7979           assert (!ffecom_transform_only_dummies_);
7980
7981           if (((g = ffesymbol_global (s)) != NULL)
7982               && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7983                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
7984               && (ffeglobal_hook (g) != NULL_TREE)
7985               && ffe_is_globals ())
7986             {
7987               t = ffeglobal_hook (g);
7988               break;
7989             }
7990
7991           if (ffesymbol_is_f2c (s)
7992               && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
7993             t = ffecom_tree_fun_type[bt][kt];
7994           else
7995             t = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
7996
7997           t = build_decl (FUNCTION_DECL,
7998                           ffecom_get_external_identifier_ (s),
7999                           t);
8000           DECL_EXTERNAL (t) = 1;
8001           TREE_PUBLIC (t) = 1;
8002
8003           t = start_decl (t, FALSE);
8004           finish_decl (t, NULL_TREE, FALSE);
8005
8006           if ((g != NULL)
8007               && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8008                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8009             ffeglobal_set_hook (g, t);
8010
8011           ffecom_save_tree_forever (t);
8012
8013           break;
8014
8015         case FFEINFO_whereDUMMY:
8016           assert (ffecom_transform_only_dummies_);
8017
8018           if (ffesymbol_is_f2c (s)
8019               && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8020             t = ffecom_tree_ptr_to_fun_type[bt][kt];
8021           else
8022             t = build_pointer_type
8023               (build_function_type (ffecom_tree_type[bt][kt], NULL_TREE));
8024
8025           t = build_decl (PARM_DECL,
8026                           ffecom_get_identifier_ (ffesymbol_text (s)),
8027                           t);
8028           DECL_ARTIFICIAL (t) = 1;
8029           addr = TRUE;
8030           break;
8031
8032         case FFEINFO_whereCONSTANT:     /* Statement function. */
8033           assert (!ffecom_transform_only_dummies_);
8034           t = ffecom_gen_sfuncdef_ (s, bt, kt);
8035           break;
8036
8037         case FFEINFO_whereINTRINSIC:
8038           assert (!ffecom_transform_only_dummies_);
8039           break;                /* Let actual references generate their
8040                                    decls. */
8041
8042         default:
8043           assert ("FUNCTION where unheard of" == NULL);
8044           /* Fall through. */
8045         case FFEINFO_whereANY:
8046           t = error_mark_node;
8047           break;
8048         }
8049       break;
8050
8051     case FFEINFO_kindSUBROUTINE:
8052       switch (ffeinfo_where (ffesymbol_info (s)))
8053         {
8054         case FFEINFO_whereLOCAL:        /* Me. */
8055           assert (!ffecom_transform_only_dummies_);
8056           t = current_function_decl;
8057           break;
8058
8059         case FFEINFO_whereGLOBAL:
8060           assert (!ffecom_transform_only_dummies_);
8061
8062           if (((g = ffesymbol_global (s)) != NULL)
8063               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8064                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8065               && (ffeglobal_hook (g) != NULL_TREE)
8066               && ffe_is_globals ())
8067             {
8068               t = ffeglobal_hook (g);
8069               break;
8070             }
8071
8072           t = build_decl (FUNCTION_DECL,
8073                           ffecom_get_external_identifier_ (s),
8074                           ffecom_tree_subr_type);
8075           DECL_EXTERNAL (t) = 1;
8076           TREE_PUBLIC (t) = 1;
8077
8078           t = start_decl (t, ffe_is_globals ());
8079           finish_decl (t, NULL_TREE, ffe_is_globals ());
8080
8081           if ((g != NULL)
8082               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8083                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8084             ffeglobal_set_hook (g, t);
8085
8086           ffecom_save_tree_forever (t);
8087
8088           break;
8089
8090         case FFEINFO_whereDUMMY:
8091           assert (ffecom_transform_only_dummies_);
8092
8093           t = build_decl (PARM_DECL,
8094                           ffecom_get_identifier_ (ffesymbol_text (s)),
8095                           ffecom_tree_ptr_to_subr_type);
8096           DECL_ARTIFICIAL (t) = 1;
8097           addr = TRUE;
8098           break;
8099
8100         case FFEINFO_whereINTRINSIC:
8101           assert (!ffecom_transform_only_dummies_);
8102           break;                /* Let actual references generate their
8103                                    decls. */
8104
8105         default:
8106           assert ("SUBROUTINE where unheard of" == NULL);
8107           /* Fall through. */
8108         case FFEINFO_whereANY:
8109           t = error_mark_node;
8110           break;
8111         }
8112       break;
8113
8114     case FFEINFO_kindPROGRAM:
8115       switch (ffeinfo_where (ffesymbol_info (s)))
8116         {
8117         case FFEINFO_whereLOCAL:        /* Me. */
8118           assert (!ffecom_transform_only_dummies_);
8119           t = current_function_decl;
8120           break;
8121
8122         case FFEINFO_whereCOMMON:
8123         case FFEINFO_whereDUMMY:
8124         case FFEINFO_whereGLOBAL:
8125         case FFEINFO_whereRESULT:
8126         case FFEINFO_whereFLEETING:
8127         case FFEINFO_whereFLEETING_CADDR:
8128         case FFEINFO_whereFLEETING_IADDR:
8129         case FFEINFO_whereIMMEDIATE:
8130         case FFEINFO_whereINTRINSIC:
8131         case FFEINFO_whereCONSTANT:
8132         case FFEINFO_whereCONSTANT_SUBOBJECT:
8133         default:
8134           assert ("PROGRAM where unheard of" == NULL);
8135           /* Fall through. */
8136         case FFEINFO_whereANY:
8137           t = error_mark_node;
8138           break;
8139         }
8140       break;
8141
8142     case FFEINFO_kindBLOCKDATA:
8143       switch (ffeinfo_where (ffesymbol_info (s)))
8144         {
8145         case FFEINFO_whereLOCAL:        /* Me. */
8146           assert (!ffecom_transform_only_dummies_);
8147           t = current_function_decl;
8148           break;
8149
8150         case FFEINFO_whereGLOBAL:
8151           assert (!ffecom_transform_only_dummies_);
8152
8153           t = build_decl (FUNCTION_DECL,
8154                           ffecom_get_external_identifier_ (s),
8155                           ffecom_tree_blockdata_type);
8156           DECL_EXTERNAL (t) = 1;
8157           TREE_PUBLIC (t) = 1;
8158
8159           t = start_decl (t, FALSE);
8160           finish_decl (t, NULL_TREE, FALSE);
8161
8162           ffecom_save_tree_forever (t);
8163
8164           break;
8165
8166         case FFEINFO_whereCOMMON:
8167         case FFEINFO_whereDUMMY:
8168         case FFEINFO_whereRESULT:
8169         case FFEINFO_whereFLEETING:
8170         case FFEINFO_whereFLEETING_CADDR:
8171         case FFEINFO_whereFLEETING_IADDR:
8172         case FFEINFO_whereIMMEDIATE:
8173         case FFEINFO_whereINTRINSIC:
8174         case FFEINFO_whereCONSTANT:
8175         case FFEINFO_whereCONSTANT_SUBOBJECT:
8176         default:
8177           assert ("BLOCKDATA where unheard of" == NULL);
8178           /* Fall through. */
8179         case FFEINFO_whereANY:
8180           t = error_mark_node;
8181           break;
8182         }
8183       break;
8184
8185     case FFEINFO_kindCOMMON:
8186       switch (ffeinfo_where (ffesymbol_info (s)))
8187         {
8188         case FFEINFO_whereLOCAL:
8189           assert (!ffecom_transform_only_dummies_);
8190           ffecom_transform_common_ (s);
8191           break;
8192
8193         case FFEINFO_whereNONE:
8194         case FFEINFO_whereCOMMON:
8195         case FFEINFO_whereDUMMY:
8196         case FFEINFO_whereGLOBAL:
8197         case FFEINFO_whereRESULT:
8198         case FFEINFO_whereFLEETING:
8199         case FFEINFO_whereFLEETING_CADDR:
8200         case FFEINFO_whereFLEETING_IADDR:
8201         case FFEINFO_whereIMMEDIATE:
8202         case FFEINFO_whereINTRINSIC:
8203         case FFEINFO_whereCONSTANT:
8204         case FFEINFO_whereCONSTANT_SUBOBJECT:
8205         default:
8206           assert ("COMMON where unheard of" == NULL);
8207           /* Fall through. */
8208         case FFEINFO_whereANY:
8209           t = error_mark_node;
8210           break;
8211         }
8212       break;
8213
8214     case FFEINFO_kindCONSTRUCT:
8215       switch (ffeinfo_where (ffesymbol_info (s)))
8216         {
8217         case FFEINFO_whereLOCAL:
8218           assert (!ffecom_transform_only_dummies_);
8219           break;
8220
8221         case FFEINFO_whereNONE:
8222         case FFEINFO_whereCOMMON:
8223         case FFEINFO_whereDUMMY:
8224         case FFEINFO_whereGLOBAL:
8225         case FFEINFO_whereRESULT:
8226         case FFEINFO_whereFLEETING:
8227         case FFEINFO_whereFLEETING_CADDR:
8228         case FFEINFO_whereFLEETING_IADDR:
8229         case FFEINFO_whereIMMEDIATE:
8230         case FFEINFO_whereINTRINSIC:
8231         case FFEINFO_whereCONSTANT:
8232         case FFEINFO_whereCONSTANT_SUBOBJECT:
8233         default:
8234           assert ("CONSTRUCT where unheard of" == NULL);
8235           /* Fall through. */
8236         case FFEINFO_whereANY:
8237           t = error_mark_node;
8238           break;
8239         }
8240       break;
8241
8242     case FFEINFO_kindNAMELIST:
8243       switch (ffeinfo_where (ffesymbol_info (s)))
8244         {
8245         case FFEINFO_whereLOCAL:
8246           assert (!ffecom_transform_only_dummies_);
8247           t = ffecom_transform_namelist_ (s);
8248           break;
8249
8250         case FFEINFO_whereNONE:
8251         case FFEINFO_whereCOMMON:
8252         case FFEINFO_whereDUMMY:
8253         case FFEINFO_whereGLOBAL:
8254         case FFEINFO_whereRESULT:
8255         case FFEINFO_whereFLEETING:
8256         case FFEINFO_whereFLEETING_CADDR:
8257         case FFEINFO_whereFLEETING_IADDR:
8258         case FFEINFO_whereIMMEDIATE:
8259         case FFEINFO_whereINTRINSIC:
8260         case FFEINFO_whereCONSTANT:
8261         case FFEINFO_whereCONSTANT_SUBOBJECT:
8262         default:
8263           assert ("NAMELIST where unheard of" == NULL);
8264           /* Fall through. */
8265         case FFEINFO_whereANY:
8266           t = error_mark_node;
8267           break;
8268         }
8269       break;
8270
8271     default:
8272       assert ("kind unheard of" == NULL);
8273       /* Fall through. */
8274     case FFEINFO_kindANY:
8275       t = error_mark_node;
8276       break;
8277     }
8278
8279   ffesymbol_hook (s).decl_tree = t;
8280   ffesymbol_hook (s).length_tree = tlen;
8281   ffesymbol_hook (s).addr = addr;
8282
8283   input_location = old_loc;
8284
8285   return s;
8286 }
8287
8288 /* Transform into ASSIGNable symbol.
8289
8290    Symbol has already been transformed, but for whatever reason, the
8291    resulting decl_tree has been deemed not usable for an ASSIGN target.
8292    (E.g. it isn't wide enough to hold a pointer.)  So, here we invent
8293    another local symbol of type void * and stuff that in the assign_tree
8294    argument.  The F77/F90 standards allow this implementation.  */
8295
8296 static ffesymbol
8297 ffecom_sym_transform_assign_ (ffesymbol s)
8298 {
8299   tree t;                       /* Transformed thingy. */
8300   location_t old_loc = input_location;
8301
8302   if (ffesymbol_sfdummyparent (s) == NULL)
8303     {
8304       input_filename = ffesymbol_where_filename (s);
8305       input_line = ffesymbol_where_filelinenum (s);
8306     }
8307   else
8308     {
8309       ffesymbol sf = ffesymbol_sfdummyparent (s);
8310
8311       input_filename = ffesymbol_where_filename (sf);
8312       input_line = ffesymbol_where_filelinenum (sf);
8313     }
8314
8315   assert (!ffecom_transform_only_dummies_);
8316
8317   t = build_decl (VAR_DECL,
8318                   ffecom_get_invented_identifier ("__g77_ASSIGN_%s",
8319                                                    ffesymbol_text (s)),
8320                   TREE_TYPE (null_pointer_node));
8321
8322   switch (ffesymbol_where (s))
8323     {
8324     case FFEINFO_whereLOCAL:
8325       /* Unlike for regular vars, SAVE status is easy to determine for
8326          ASSIGNed vars, since there's no initialization, there's no
8327          effective storage association (so "SAVE J" does not apply to
8328          K even given "EQUIVALENCE (J,K)"), there's no size issue
8329          to worry about, etc.  */
8330       if ((ffesymbol_is_save (s) || ffe_is_saveall ())
8331           && (ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8332           && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA))
8333         TREE_STATIC (t) = 1;    /* SAVEd in proc, make static. */
8334       else
8335         TREE_STATIC (t) = 0;    /* No need to make static. */
8336       break;
8337
8338     case FFEINFO_whereCOMMON:
8339       TREE_STATIC (t) = 1;      /* Assume COMMONs always SAVEd. */
8340       break;
8341
8342     case FFEINFO_whereDUMMY:
8343       /* Note that twinning a DUMMY means the caller won't see
8344          the ASSIGNed value.  But both F77 and F90 allow implementations
8345          to do this, i.e. disallow Fortran code that would try and
8346          take advantage of actually putting a label into a variable
8347          via a dummy argument (or any other storage association, for
8348          that matter).  */
8349       TREE_STATIC (t) = 0;
8350       break;
8351
8352     default:
8353       TREE_STATIC (t) = 0;
8354       break;
8355     }
8356
8357   t = start_decl (t, FALSE);
8358   finish_decl (t, NULL_TREE, FALSE);
8359
8360   ffesymbol_hook (s).assign_tree = t;
8361
8362   input_location = old_loc;
8363
8364   return s;
8365 }
8366
8367 /* Implement COMMON area in back end.
8368
8369    Because COMMON-based variables can be referenced in the dimension
8370    expressions of dummy (adjustable) arrays, and because dummies
8371    (in the gcc back end) need to be put in the outer binding level
8372    of a function (which has two binding levels, the outer holding
8373    the dummies and the inner holding the other vars), special care
8374    must be taken to handle COMMON areas.
8375
8376    The current strategy is basically to always tell the back end about
8377    the COMMON area as a top-level external reference to just a block
8378    of storage of the master type of that area (e.g. integer, real,
8379    character, whatever -- not a structure).  As a distinct action,
8380    if initial values are provided, tell the back end about the area
8381    as a top-level non-external (initialized) area and remember not to
8382    allow further initialization or expansion of the area.  Meanwhile,
8383    if no initialization happens at all, tell the back end about
8384    the largest size we've seen declared so the space does get reserved.
8385    (This function doesn't handle all that stuff, but it does some
8386    of the important things.)
8387
8388    Meanwhile, for COMMON variables themselves, just keep creating
8389    references like *((float *) (&common_area + offset)) each time
8390    we reference the variable.  In other words, don't make a VAR_DECL
8391    or any kind of component reference (like we used to do before 0.4),
8392    though we might do that as well just for debugging purposes (and
8393    stuff the rtl with the appropriate offset expression).  */
8394
8395 static void
8396 ffecom_transform_common_ (ffesymbol s)
8397 {
8398   ffestorag st = ffesymbol_storage (s);
8399   ffeglobal g = ffesymbol_global (s);
8400   tree cbt;
8401   tree cbtype;
8402   tree init;
8403   tree high;
8404   bool is_init = ffestorag_is_init (st);
8405
8406   assert (st != NULL);
8407
8408   if ((g == NULL)
8409       || (ffeglobal_type (g) != FFEGLOBAL_typeCOMMON))
8410     return;
8411
8412   /* First update the size of the area in global terms.  */
8413
8414   ffeglobal_size_common (s, ffestorag_size (st));
8415
8416   if (!ffeglobal_common_init (g))
8417     is_init = FALSE;    /* No explicit init, don't let erroneous joins init. */
8418
8419   cbt = ffeglobal_hook (g);
8420
8421   /* If we already have declared this common block for a previous program
8422      unit, and either we already initialized it or we don't have new
8423      initialization for it, just return what we have without changing it.  */
8424
8425   if ((cbt != NULL_TREE)
8426       && (!is_init
8427           || !DECL_EXTERNAL (cbt)))
8428     {
8429       if (st->hook == NULL) ffestorag_set_hook (st, cbt);
8430       return;
8431     }
8432
8433   /* Process inits.  */
8434
8435   if (is_init)
8436     {
8437       if (ffestorag_init (st) != NULL)
8438         {
8439           ffebld sexp;
8440
8441           /* Set the padding for the expression, so ffecom_expr
8442              knows to insert that many zeros.  */
8443           switch (ffebld_op (sexp = ffestorag_init (st)))
8444             {
8445             case FFEBLD_opCONTER:
8446               ffebld_conter_set_pad (sexp, ffestorag_modulo (st));
8447               break;
8448
8449             case FFEBLD_opARRTER:
8450               ffebld_arrter_set_pad (sexp, ffestorag_modulo (st));
8451               break;
8452
8453             case FFEBLD_opACCTER:
8454               ffebld_accter_set_pad (sexp, ffestorag_modulo (st));
8455               break;
8456
8457             default:
8458               assert ("bad op for cmn init (pad)" == NULL);
8459               break;
8460             }
8461
8462           init = ffecom_expr (sexp);
8463           if (init == error_mark_node)
8464             {                   /* Hopefully the back end complained! */
8465               init = NULL_TREE;
8466               if (cbt != NULL_TREE)
8467                 return;
8468             }
8469         }
8470       else
8471         init = error_mark_node;
8472     }
8473   else
8474     init = NULL_TREE;
8475
8476   /* cbtype must be permanently allocated!  */
8477
8478   /* Allocate the MAX of the areas so far, seen filewide.  */
8479   high = build_int_2 ((ffeglobal_common_size (g)
8480                        + ffeglobal_common_pad (g)) - 1, 0);
8481   TREE_TYPE (high) = ffecom_integer_type_node;
8482
8483   if (init)
8484     cbtype = build_array_type (char_type_node,
8485                                build_range_type (integer_type_node,
8486                                                  integer_zero_node,
8487                                                  high));
8488   else
8489     cbtype = build_array_type (char_type_node, NULL_TREE);
8490
8491   if (cbt == NULL_TREE)
8492     {
8493       cbt
8494         = build_decl (VAR_DECL,
8495                       ffecom_get_external_identifier_ (s),
8496                       cbtype);
8497       TREE_STATIC (cbt) = 1;
8498       TREE_PUBLIC (cbt) = 1;
8499     }
8500   else
8501     {
8502       assert (is_init);
8503       TREE_TYPE (cbt) = cbtype;
8504     }
8505   DECL_EXTERNAL (cbt) = init ? 0 : 1;
8506   DECL_INITIAL (cbt) = init ? error_mark_node : NULL_TREE;
8507
8508   cbt = start_decl (cbt, TRUE);
8509   if (ffeglobal_hook (g) != NULL)
8510     assert (cbt == ffeglobal_hook (g));
8511
8512   assert (!init || !DECL_EXTERNAL (cbt));
8513
8514   /* Make sure that any type can live in COMMON and be referenced
8515      without getting a bus error.  We could pick the most restrictive
8516      alignment of all entities actually placed in the COMMON, but
8517      this seems easy enough.  */
8518
8519   DECL_ALIGN (cbt) = BIGGEST_ALIGNMENT;
8520   DECL_USER_ALIGN (cbt) = 0;
8521
8522   if (is_init && (ffestorag_init (st) == NULL))
8523     init = ffecom_init_zero_ (cbt);
8524
8525   finish_decl (cbt, init, TRUE);
8526
8527   if (is_init)
8528     ffestorag_set_init (st, ffebld_new_any ());
8529
8530   if (init)
8531     {
8532       assert (DECL_SIZE_UNIT (cbt) != NULL_TREE);
8533       assert (TREE_CODE (DECL_SIZE_UNIT (cbt)) == INTEGER_CST);
8534       assert (0 == compare_tree_int (DECL_SIZE_UNIT (cbt),
8535                                      (ffeglobal_common_size (g)
8536                                       + ffeglobal_common_pad (g))));
8537     }
8538
8539   ffeglobal_set_hook (g, cbt);
8540
8541   ffestorag_set_hook (st, cbt);
8542
8543   ffecom_save_tree_forever (cbt);
8544 }
8545
8546 /* Make master area for local EQUIVALENCE.  */
8547
8548 static void
8549 ffecom_transform_equiv_ (ffestorag eqst)
8550 {
8551   tree eqt;
8552   tree eqtype;
8553   tree init;
8554   tree high;
8555   bool is_init = ffestorag_is_init (eqst);
8556
8557   assert (eqst != NULL);
8558
8559   eqt = ffestorag_hook (eqst);
8560
8561   if (eqt != NULL_TREE)
8562     return;
8563
8564   /* Process inits.  */
8565
8566   if (is_init)
8567     {
8568       if (ffestorag_init (eqst) != NULL)
8569         {
8570           ffebld sexp;
8571
8572           /* Set the padding for the expression, so ffecom_expr
8573              knows to insert that many zeros.  */
8574           switch (ffebld_op (sexp = ffestorag_init (eqst)))
8575             {
8576             case FFEBLD_opCONTER:
8577               ffebld_conter_set_pad (sexp, ffestorag_modulo (eqst));
8578               break;
8579
8580             case FFEBLD_opARRTER:
8581               ffebld_arrter_set_pad (sexp, ffestorag_modulo (eqst));
8582               break;
8583
8584             case FFEBLD_opACCTER:
8585               ffebld_accter_set_pad (sexp, ffestorag_modulo (eqst));
8586               break;
8587
8588             default:
8589               assert ("bad op for eqv init (pad)" == NULL);
8590               break;
8591             }
8592
8593           init = ffecom_expr (sexp);
8594           if (init == error_mark_node)
8595             init = NULL_TREE;   /* Hopefully the back end complained! */
8596         }
8597       else
8598         init = error_mark_node;
8599     }
8600   else if (ffe_is_init_local_zero ())
8601     init = error_mark_node;
8602   else
8603     init = NULL_TREE;
8604
8605   ffecom_member_namelisted_ = FALSE;
8606   ffestorag_drive (ffestorag_list_equivs (eqst),
8607                    &ffecom_member_phase1_,
8608                    eqst);
8609
8610   high = build_int_2 ((ffestorag_size (eqst)
8611                        + ffestorag_modulo (eqst)) - 1, 0);
8612   TREE_TYPE (high) = ffecom_integer_type_node;
8613
8614   eqtype = build_array_type (char_type_node,
8615                              build_range_type (ffecom_integer_type_node,
8616                                                ffecom_integer_zero_node,
8617                                                high));
8618
8619   eqt = build_decl (VAR_DECL,
8620                     ffecom_get_invented_identifier ("__g77_equiv_%s",
8621                                                     ffesymbol_text
8622                                                     (ffestorag_symbol (eqst))),
8623                     eqtype);
8624   DECL_EXTERNAL (eqt) = 0;
8625   if (is_init
8626       || ffecom_member_namelisted_
8627 #ifdef FFECOM_sizeMAXSTACKITEM
8628       || (ffestorag_size (eqst) > FFECOM_sizeMAXSTACKITEM)
8629 #endif
8630       || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8631           && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
8632           && (ffestorag_is_save (eqst) || ffe_is_saveall ())))
8633     TREE_STATIC (eqt) = 1;
8634   else
8635     TREE_STATIC (eqt) = 0;
8636   TREE_PUBLIC (eqt) = 0;
8637   TREE_ADDRESSABLE (eqt) = 1;  /* Ensure non-register allocation */
8638   DECL_CONTEXT (eqt) = current_function_decl;
8639   if (init)
8640     DECL_INITIAL (eqt) = error_mark_node;
8641   else
8642     DECL_INITIAL (eqt) = NULL_TREE;
8643
8644   eqt = start_decl (eqt, FALSE);
8645
8646   /* Make sure that any type can live in EQUIVALENCE and be referenced
8647      without getting a bus error.  We could pick the most restrictive
8648      alignment of all entities actually placed in the EQUIVALENCE, but
8649      this seems easy enough.  */
8650
8651   DECL_ALIGN (eqt) = BIGGEST_ALIGNMENT;
8652   DECL_USER_ALIGN (eqt) = 0;
8653
8654   if ((!is_init && ffe_is_init_local_zero ())
8655       || (is_init && (ffestorag_init (eqst) == NULL)))
8656     init = ffecom_init_zero_ (eqt);
8657
8658   finish_decl (eqt, init, FALSE);
8659
8660   if (is_init)
8661     ffestorag_set_init (eqst, ffebld_new_any ());
8662
8663   {
8664     assert (TREE_CODE (DECL_SIZE_UNIT (eqt)) == INTEGER_CST);
8665     assert (0 == compare_tree_int (DECL_SIZE_UNIT (eqt),
8666                                    (ffestorag_size (eqst)
8667                                     + ffestorag_modulo (eqst))));
8668   }
8669
8670   ffestorag_set_hook (eqst, eqt);
8671
8672   ffestorag_drive (ffestorag_list_equivs (eqst),
8673                    &ffecom_member_phase2_,
8674                    eqst);
8675 }
8676
8677 /* Implement NAMELIST in back end.  See f2c/format.c for more info.  */
8678
8679 static tree
8680 ffecom_transform_namelist_ (ffesymbol s)
8681 {
8682   tree nmlt;
8683   tree nmltype = ffecom_type_namelist_ ();
8684   tree nmlinits;
8685   tree nameinit;
8686   tree varsinit;
8687   tree nvarsinit;
8688   tree field;
8689   tree high;
8690   int i;
8691   static int mynumber = 0;
8692
8693   nmlt = build_decl (VAR_DECL,
8694                      ffecom_get_invented_identifier ("__g77_namelist_%d",
8695                                                      mynumber++),
8696                      nmltype);
8697   TREE_STATIC (nmlt) = 1;
8698   DECL_INITIAL (nmlt) = error_mark_node;
8699
8700   nmlt = start_decl (nmlt, FALSE);
8701
8702   /* Process inits.  */
8703
8704   i = strlen (ffesymbol_text (s));
8705
8706   high = build_int_2 (i, 0);
8707   TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
8708
8709   nameinit = ffecom_build_f2c_string_ (i + 1,
8710                                        ffesymbol_text (s));
8711   TREE_TYPE (nameinit)
8712     = build_type_variant
8713     (build_array_type
8714      (char_type_node,
8715       build_range_type (ffecom_f2c_ftnlen_type_node,
8716                         ffecom_f2c_ftnlen_one_node,
8717                         high)),
8718      1, 0);
8719   TREE_CONSTANT (nameinit) = 1;
8720   TREE_STATIC (nameinit) = 1;
8721   nameinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (nameinit)),
8722                        nameinit);
8723
8724   varsinit = ffecom_vardesc_array_ (s);
8725   varsinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (varsinit)),
8726                        varsinit);
8727   TREE_CONSTANT (varsinit) = 1;
8728   TREE_STATIC (varsinit) = 1;
8729
8730   {
8731     ffebld b;
8732
8733     for (i = 0, b = ffesymbol_namelist (s); b != NULL; b = ffebld_trail (b))
8734       ++i;
8735   }
8736   nvarsinit = build_int_2 (i, 0);
8737   TREE_TYPE (nvarsinit) = integer_type_node;
8738   TREE_CONSTANT (nvarsinit) = 1;
8739   TREE_STATIC (nvarsinit) = 1;
8740
8741   nmlinits = build_tree_list ((field = TYPE_FIELDS (nmltype)), nameinit);
8742   TREE_CHAIN (nmlinits) = build_tree_list ((field = TREE_CHAIN (field)),
8743                                            varsinit);
8744   TREE_CHAIN (TREE_CHAIN (nmlinits))
8745     = build_tree_list ((field = TREE_CHAIN (field)), nvarsinit);
8746
8747   nmlinits = build_constructor (nmltype, nmlinits);
8748   TREE_CONSTANT (nmlinits) = 1;
8749   TREE_STATIC (nmlinits) = 1;
8750
8751   finish_decl (nmlt, nmlinits, FALSE);
8752
8753   nmlt = ffecom_1 (ADDR_EXPR, build_pointer_type (nmltype), nmlt);
8754
8755   return nmlt;
8756 }
8757
8758 /* A subroutine of ffecom_tree_canonize_ref_.  The incoming tree is
8759    analyzed on the assumption it is calculating a pointer to be
8760    indirected through.  It must return the proper decl and offset,
8761    taking into account different units of measurements for offsets.  */
8762
8763 static void
8764 ffecom_tree_canonize_ptr_ (tree *decl, tree *offset, tree t)
8765 {
8766   switch (TREE_CODE (t))
8767     {
8768     case NOP_EXPR:
8769     case CONVERT_EXPR:
8770     case NON_LVALUE_EXPR:
8771       ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
8772       break;
8773
8774     case PLUS_EXPR:
8775       ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
8776       if ((*decl == NULL_TREE)
8777           || (*decl == error_mark_node))
8778         break;
8779
8780       if (TREE_CODE (TREE_OPERAND (t, 1)) == INTEGER_CST)
8781         {
8782           /* An offset into COMMON.  */
8783           *offset = fold (build (PLUS_EXPR, TREE_TYPE (*offset),
8784                                  *offset, TREE_OPERAND (t, 1)));
8785           /* Convert offset (presumably in bytes) into canonical units
8786              (presumably bits).  */
8787           *offset = size_binop (MULT_EXPR,
8788                                 convert (bitsizetype, *offset),
8789                                 TYPE_SIZE (TREE_TYPE (TREE_TYPE (t))));
8790           break;
8791         }
8792       /* Not a COMMON reference, so an unrecognized pattern.  */
8793       *decl = error_mark_node;
8794       break;
8795
8796     case PARM_DECL:
8797       *decl = t;
8798       *offset = bitsize_zero_node;
8799       break;
8800
8801     case ADDR_EXPR:
8802       if (TREE_CODE (TREE_OPERAND (t, 0)) == VAR_DECL)
8803         {
8804           /* A reference to COMMON.  */
8805           *decl = TREE_OPERAND (t, 0);
8806           *offset = bitsize_zero_node;
8807           break;
8808         }
8809       /* Fall through.  */
8810     default:
8811       /* Not a COMMON reference, so an unrecognized pattern.  */
8812       *decl = error_mark_node;
8813       break;
8814     }
8815 }
8816
8817 /* Given a tree that is possibly intended for use as an lvalue, return
8818    information representing a canonical view of that tree as a decl, an
8819    offset into that decl, and a size for the lvalue.
8820
8821    If there's no applicable decl, NULL_TREE is returned for the decl,
8822    and the other fields are left undefined.
8823
8824    If the tree doesn't fit the recognizable forms, an ERROR_MARK node
8825    is returned for the decl, and the other fields are left undefined.
8826
8827    Otherwise, the decl returned currently is either a VAR_DECL or a
8828    PARM_DECL.
8829
8830    The offset returned is always valid, but of course not necessarily
8831    a constant, and not necessarily converted into the appropriate
8832    type, leaving that up to the caller (so as to avoid that overhead
8833    if the decls being looked at are different anyway).
8834
8835    If the size cannot be determined (e.g. an adjustable array),
8836    an ERROR_MARK node is returned for the size.  Otherwise, the
8837    size returned is valid, not necessarily a constant, and not
8838    necessarily converted into the appropriate type as with the
8839    offset.
8840
8841    Note that the offset and size expressions are expressed in the
8842    base storage units (usually bits) rather than in the units of
8843    the type of the decl, because two decls with different types
8844    might overlap but with apparently non-overlapping array offsets,
8845    whereas converting the array offsets to consistant offsets will
8846    reveal the overlap.  */
8847
8848 static void
8849 ffecom_tree_canonize_ref_ (tree *decl, tree *offset, tree *size, tree t)
8850 {
8851   /* The default path is to report a nonexistant decl.  */
8852   *decl = NULL_TREE;
8853
8854   if (t == NULL_TREE)
8855     return;
8856
8857   switch (TREE_CODE (t))
8858     {
8859     case ERROR_MARK:
8860     case IDENTIFIER_NODE:
8861     case INTEGER_CST:
8862     case REAL_CST:
8863     case COMPLEX_CST:
8864     case STRING_CST:
8865     case CONST_DECL:
8866     case PLUS_EXPR:
8867     case MINUS_EXPR:
8868     case MULT_EXPR:
8869     case TRUNC_DIV_EXPR:
8870     case CEIL_DIV_EXPR:
8871     case FLOOR_DIV_EXPR:
8872     case ROUND_DIV_EXPR:
8873     case TRUNC_MOD_EXPR:
8874     case CEIL_MOD_EXPR:
8875     case FLOOR_MOD_EXPR:
8876     case ROUND_MOD_EXPR:
8877     case RDIV_EXPR:
8878     case EXACT_DIV_EXPR:
8879     case FIX_TRUNC_EXPR:
8880     case FIX_CEIL_EXPR:
8881     case FIX_FLOOR_EXPR:
8882     case FIX_ROUND_EXPR:
8883     case FLOAT_EXPR:
8884     case NEGATE_EXPR:
8885     case MIN_EXPR:
8886     case MAX_EXPR:
8887     case ABS_EXPR:
8888     case LSHIFT_EXPR:
8889     case RSHIFT_EXPR:
8890     case LROTATE_EXPR:
8891     case RROTATE_EXPR:
8892     case BIT_IOR_EXPR:
8893     case BIT_XOR_EXPR:
8894     case BIT_AND_EXPR:
8895     case BIT_NOT_EXPR:
8896     case TRUTH_ANDIF_EXPR:
8897     case TRUTH_ORIF_EXPR:
8898     case TRUTH_AND_EXPR:
8899     case TRUTH_OR_EXPR:
8900     case TRUTH_XOR_EXPR:
8901     case TRUTH_NOT_EXPR:
8902     case LT_EXPR:
8903     case LE_EXPR:
8904     case GT_EXPR:
8905     case GE_EXPR:
8906     case EQ_EXPR:
8907     case NE_EXPR:
8908     case COMPLEX_EXPR:
8909     case CONJ_EXPR:
8910     case REALPART_EXPR:
8911     case IMAGPART_EXPR:
8912     case LABEL_EXPR:
8913     case COMPONENT_REF:
8914     case COMPOUND_EXPR:
8915     case ADDR_EXPR:
8916       return;
8917
8918     case VAR_DECL:
8919     case PARM_DECL:
8920       *decl = t;
8921       *offset = bitsize_zero_node;
8922       *size = TYPE_SIZE (TREE_TYPE (t));
8923       return;
8924
8925     case ARRAY_REF:
8926       {
8927         tree array = TREE_OPERAND (t, 0);
8928         tree element = TREE_OPERAND (t, 1);
8929         tree init_offset;
8930
8931         if ((array == NULL_TREE)
8932             || (element == NULL_TREE))
8933           {
8934             *decl = error_mark_node;
8935             return;
8936           }
8937
8938         ffecom_tree_canonize_ref_ (decl, &init_offset, size,
8939                                    array);
8940         if ((*decl == NULL_TREE)
8941             || (*decl == error_mark_node))
8942           return;
8943
8944         /* Calculate ((element - base) * NBBY) + init_offset.  */
8945         *offset = fold (build (MINUS_EXPR, TREE_TYPE (element),
8946                                element,
8947                                TYPE_MIN_VALUE (TYPE_DOMAIN
8948                                                (TREE_TYPE (array)))));
8949
8950         *offset = size_binop (MULT_EXPR,
8951                               convert (bitsizetype, *offset),
8952                               TYPE_SIZE (TREE_TYPE (TREE_TYPE (array))));
8953
8954         *offset = size_binop (PLUS_EXPR, init_offset, *offset);
8955
8956         *size = TYPE_SIZE (TREE_TYPE (t));
8957         return;
8958       }
8959
8960     case INDIRECT_REF:
8961
8962       /* Most of this code is to handle references to COMMON.  And so
8963          far that is useful only for calling library functions, since
8964          external (user) functions might reference common areas.  But
8965          even calling an external function, it's worthwhile to decode
8966          COMMON references because if not storing into COMMON, we don't
8967          want COMMON-based arguments to gratuitously force use of a
8968          temporary.  */
8969
8970       *size = TYPE_SIZE (TREE_TYPE (t));
8971
8972       ffecom_tree_canonize_ptr_ (decl, offset,
8973                                  TREE_OPERAND (t, 0));
8974
8975       return;
8976
8977     case CONVERT_EXPR:
8978     case NOP_EXPR:
8979     case MODIFY_EXPR:
8980     case NON_LVALUE_EXPR:
8981     case RESULT_DECL:
8982     case FIELD_DECL:
8983     case COND_EXPR:             /* More cases than we can handle. */
8984     case SAVE_EXPR:
8985     case REFERENCE_EXPR:
8986     case PREDECREMENT_EXPR:
8987     case PREINCREMENT_EXPR:
8988     case POSTDECREMENT_EXPR:
8989     case POSTINCREMENT_EXPR:
8990     case CALL_EXPR:
8991     default:
8992       *decl = error_mark_node;
8993       return;
8994     }
8995 }
8996
8997 /* Do divide operation appropriate to type of operands.  */
8998
8999 static tree
9000 ffecom_tree_divide_ (tree tree_type, tree left, tree right, tree dest_tree,
9001                      ffebld dest, bool *dest_used, tree hook)
9002 {
9003   if ((left == error_mark_node)
9004       || (right == error_mark_node))
9005     return error_mark_node;
9006
9007   switch (TREE_CODE (tree_type))
9008     {
9009     case INTEGER_TYPE:
9010       return ffecom_2 (TRUNC_DIV_EXPR, tree_type,
9011                        left,
9012                        right);
9013
9014     case COMPLEX_TYPE:
9015       if (! optimize_size)
9016         return ffecom_2 (RDIV_EXPR, tree_type,
9017                          left,
9018                          right);
9019       {
9020         ffecomGfrt ix;
9021
9022         if (TREE_TYPE (tree_type)
9023             == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9024           ix = FFECOM_gfrtDIV_CC;       /* Overlapping result okay. */
9025         else
9026           ix = FFECOM_gfrtDIV_ZZ;       /* Overlapping result okay. */
9027
9028         left = ffecom_1 (ADDR_EXPR,
9029                          build_pointer_type (TREE_TYPE (left)),
9030                          left);
9031         left = build_tree_list (NULL_TREE, left);
9032         right = ffecom_1 (ADDR_EXPR,
9033                           build_pointer_type (TREE_TYPE (right)),
9034                           right);
9035         right = build_tree_list (NULL_TREE, right);
9036         TREE_CHAIN (left) = right;
9037
9038         return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9039                              ffecom_gfrt_kindtype (ix),
9040                              ffe_is_f2c_library (),
9041                              tree_type,
9042                              left,
9043                              dest_tree, dest, dest_used,
9044                              NULL_TREE, TRUE, hook);
9045       }
9046       break;
9047
9048     case RECORD_TYPE:
9049       {
9050         ffecomGfrt ix;
9051
9052         if (TREE_TYPE (TYPE_FIELDS (tree_type))
9053             == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9054           ix = FFECOM_gfrtDIV_CC;       /* Overlapping result okay. */
9055         else
9056           ix = FFECOM_gfrtDIV_ZZ;       /* Overlapping result okay. */
9057
9058         left = ffecom_1 (ADDR_EXPR,
9059                          build_pointer_type (TREE_TYPE (left)),
9060                          left);
9061         left = build_tree_list (NULL_TREE, left);
9062         right = ffecom_1 (ADDR_EXPR,
9063                           build_pointer_type (TREE_TYPE (right)),
9064                           right);
9065         right = build_tree_list (NULL_TREE, right);
9066         TREE_CHAIN (left) = right;
9067
9068         return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9069                              ffecom_gfrt_kindtype (ix),
9070                              ffe_is_f2c_library (),
9071                              tree_type,
9072                              left,
9073                              dest_tree, dest, dest_used,
9074                              NULL_TREE, TRUE, hook);
9075       }
9076       break;
9077
9078     default:
9079       return ffecom_2 (RDIV_EXPR, tree_type,
9080                        left,
9081                        right);
9082     }
9083 }
9084
9085 /* Build type info for non-dummy variable.  */
9086
9087 static tree
9088 ffecom_type_localvar_ (ffesymbol s, ffeinfoBasictype bt, ffeinfoKindtype kt)
9089 {
9090   tree type;
9091   ffebld dl;
9092   ffebld dim;
9093   tree lowt;
9094   tree hight;
9095
9096   type = ffecom_tree_type[bt][kt];
9097   if (bt == FFEINFO_basictypeCHARACTER)
9098     {
9099       hight = build_int_2 (ffesymbol_size (s), 0);
9100       TREE_TYPE (hight) = ffecom_f2c_ftnlen_type_node;
9101
9102       type
9103         = build_array_type
9104           (type,
9105            build_range_type (ffecom_f2c_ftnlen_type_node,
9106                              ffecom_f2c_ftnlen_one_node,
9107                              hight));
9108       type = ffecom_check_size_overflow_ (s, type, FALSE);
9109     }
9110
9111   for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
9112     {
9113       if (type == error_mark_node)
9114         break;
9115
9116       dim = ffebld_head (dl);
9117       assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
9118
9119       if (ffebld_left (dim) == NULL)
9120         lowt = integer_one_node;
9121       else
9122         lowt = ffecom_expr (ffebld_left (dim));
9123
9124       if (TREE_CODE (lowt) != INTEGER_CST)
9125         lowt = variable_size (lowt);
9126
9127       assert (ffebld_right (dim) != NULL);
9128       hight = ffecom_expr (ffebld_right (dim));
9129
9130       if (TREE_CODE (hight) != INTEGER_CST)
9131         hight = variable_size (hight);
9132
9133       type = build_array_type (type,
9134                                build_range_type (ffecom_integer_type_node,
9135                                                  lowt, hight));
9136       type = ffecom_check_size_overflow_ (s, type, FALSE);
9137     }
9138
9139   return type;
9140 }
9141
9142 /* Build Namelist type.  */
9143
9144 static GTY(()) tree ffecom_type_namelist_var;
9145 static tree
9146 ffecom_type_namelist_ (void)
9147 {
9148   if (ffecom_type_namelist_var == NULL_TREE)
9149     {
9150       tree namefield, varsfield, nvarsfield, vardesctype, type;
9151
9152       vardesctype = ffecom_type_vardesc_ ();
9153
9154       type = make_node (RECORD_TYPE);
9155
9156       vardesctype = build_pointer_type (build_pointer_type (vardesctype));
9157
9158       namefield = ffecom_decl_field (type, NULL_TREE, "name",
9159                                      string_type_node);
9160       varsfield = ffecom_decl_field (type, namefield, "vars", vardesctype);
9161       nvarsfield = ffecom_decl_field (type, varsfield, "nvars",
9162                                       integer_type_node);
9163
9164       TYPE_FIELDS (type) = namefield;
9165       layout_type (type);
9166
9167       ffecom_type_namelist_var = type;
9168     }
9169
9170   return ffecom_type_namelist_var;
9171 }
9172
9173 /* Build Vardesc type.  */
9174
9175 static GTY(()) tree ffecom_type_vardesc_var;
9176 static tree
9177 ffecom_type_vardesc_ (void)
9178 {
9179   if (ffecom_type_vardesc_var == NULL_TREE)
9180     {
9181       tree namefield, addrfield, dimsfield, typefield, type;
9182       type = make_node (RECORD_TYPE);
9183
9184       namefield = ffecom_decl_field (type, NULL_TREE, "name",
9185                                      string_type_node);
9186       addrfield = ffecom_decl_field (type, namefield, "addr",
9187                                      string_type_node);
9188       dimsfield = ffecom_decl_field (type, addrfield, "dims",
9189                                      ffecom_f2c_ptr_to_ftnlen_type_node);
9190       typefield = ffecom_decl_field (type, dimsfield, "type",
9191                                      integer_type_node);
9192
9193       TYPE_FIELDS (type) = namefield;
9194       layout_type (type);
9195
9196       ffecom_type_vardesc_var = type;
9197     }
9198
9199   return ffecom_type_vardesc_var;
9200 }
9201
9202 static tree
9203 ffecom_vardesc_ (ffebld expr)
9204 {
9205   ffesymbol s;
9206
9207   assert (ffebld_op (expr) == FFEBLD_opSYMTER);
9208   s = ffebld_symter (expr);
9209
9210   if (ffesymbol_hook (s).vardesc_tree == NULL_TREE)
9211     {
9212       int i;
9213       tree vardesctype = ffecom_type_vardesc_ ();
9214       tree var;
9215       tree nameinit;
9216       tree dimsinit;
9217       tree addrinit;
9218       tree typeinit;
9219       tree field;
9220       tree varinits;
9221       static int mynumber = 0;
9222
9223       var = build_decl (VAR_DECL,
9224                         ffecom_get_invented_identifier ("__g77_vardesc_%d",
9225                                                         mynumber++),
9226                         vardesctype);
9227       TREE_STATIC (var) = 1;
9228       DECL_INITIAL (var) = error_mark_node;
9229
9230       var = start_decl (var, FALSE);
9231
9232       /* Process inits.  */
9233
9234       nameinit = ffecom_build_f2c_string_ ((i = strlen (ffesymbol_text (s)))
9235                                            + 1,
9236                                            ffesymbol_text (s));
9237       TREE_TYPE (nameinit)
9238         = build_type_variant
9239         (build_array_type
9240          (char_type_node,
9241           build_range_type (integer_type_node,
9242                             integer_one_node,
9243                             build_int_2 (i, 0))),
9244          1, 0);
9245       TREE_CONSTANT (nameinit) = 1;
9246       TREE_STATIC (nameinit) = 1;
9247       nameinit = ffecom_1 (ADDR_EXPR,
9248                            build_pointer_type (TREE_TYPE (nameinit)),
9249                            nameinit);
9250
9251       addrinit = ffecom_arg_ptr_to_expr (expr, &typeinit);
9252
9253       dimsinit = ffecom_vardesc_dims_ (s);
9254
9255       if (typeinit == NULL_TREE)
9256         {
9257           ffeinfoBasictype bt = ffesymbol_basictype (s);
9258           ffeinfoKindtype kt = ffesymbol_kindtype (s);
9259           int tc = ffecom_f2c_typecode (bt, kt);
9260
9261           assert (tc != -1);
9262           typeinit = build_int_2 (tc, (tc < 0) ? -1 : 0);
9263         }
9264       else
9265         typeinit = ffecom_1 (NEGATE_EXPR, TREE_TYPE (typeinit), typeinit);
9266
9267       varinits = build_tree_list ((field = TYPE_FIELDS (vardesctype)),
9268                                   nameinit);
9269       TREE_CHAIN (varinits) = build_tree_list ((field = TREE_CHAIN (field)),
9270                                                addrinit);
9271       TREE_CHAIN (TREE_CHAIN (varinits))
9272         = build_tree_list ((field = TREE_CHAIN (field)), dimsinit);
9273       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (varinits)))
9274         = build_tree_list ((field = TREE_CHAIN (field)), typeinit);
9275
9276       varinits = build_constructor (vardesctype, varinits);
9277       TREE_CONSTANT (varinits) = 1;
9278       TREE_STATIC (varinits) = 1;
9279
9280       finish_decl (var, varinits, FALSE);
9281
9282       var = ffecom_1 (ADDR_EXPR, build_pointer_type (vardesctype), var);
9283
9284       ffesymbol_hook (s).vardesc_tree = var;
9285     }
9286
9287   return ffesymbol_hook (s).vardesc_tree;
9288 }
9289
9290 static tree
9291 ffecom_vardesc_array_ (ffesymbol s)
9292 {
9293   ffebld b;
9294   tree list;
9295   tree item = NULL_TREE;
9296   tree var;
9297   int i;
9298   static int mynumber = 0;
9299
9300   for (i = 0, list = NULL_TREE, b = ffesymbol_namelist (s);
9301        b != NULL;
9302        b = ffebld_trail (b), ++i)
9303     {
9304       tree t;
9305
9306       t = ffecom_vardesc_ (ffebld_head (b));
9307
9308       if (list == NULL_TREE)
9309         list = item = build_tree_list (NULL_TREE, t);
9310       else
9311         {
9312           TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9313           item = TREE_CHAIN (item);
9314         }
9315     }
9316
9317   item = build_array_type (build_pointer_type (ffecom_type_vardesc_ ()),
9318                            build_range_type (integer_type_node,
9319                                              integer_one_node,
9320                                              build_int_2 (i, 0)));
9321   list = build_constructor (item, list);
9322   TREE_CONSTANT (list) = 1;
9323   TREE_STATIC (list) = 1;
9324
9325   var = ffecom_get_invented_identifier ("__g77_vardesc_array_%d", mynumber++);
9326   var = build_decl (VAR_DECL, var, item);
9327   TREE_STATIC (var) = 1;
9328   DECL_INITIAL (var) = error_mark_node;
9329   var = start_decl (var, FALSE);
9330   finish_decl (var, list, FALSE);
9331
9332   return var;
9333 }
9334
9335 static tree
9336 ffecom_vardesc_dims_ (ffesymbol s)
9337 {
9338   if (ffesymbol_dims (s) == NULL)
9339     return convert (ffecom_f2c_ptr_to_ftnlen_type_node,
9340                     integer_zero_node);
9341
9342   {
9343     ffebld b;
9344     ffebld e;
9345     tree list;
9346     tree backlist;
9347     tree item = NULL_TREE;
9348     tree var;
9349     tree numdim;
9350     tree numelem;
9351     tree baseoff = NULL_TREE;
9352     static int mynumber = 0;
9353
9354     numdim = build_int_2 ((int) ffesymbol_rank (s), 0);
9355     TREE_TYPE (numdim) = ffecom_f2c_ftnlen_type_node;
9356
9357     numelem = ffecom_expr (ffesymbol_arraysize (s));
9358     TREE_TYPE (numelem) = ffecom_f2c_ftnlen_type_node;
9359
9360     list = NULL_TREE;
9361     backlist = NULL_TREE;
9362     for (b = ffesymbol_dims (s), e = ffesymbol_extents (s);
9363          b != NULL;
9364          b = ffebld_trail (b), e = ffebld_trail (e))
9365       {
9366         tree t;
9367         tree low;
9368         tree back;
9369
9370         if (ffebld_trail (b) == NULL)
9371           t = NULL_TREE;
9372         else
9373           {
9374             t = convert (ffecom_f2c_ftnlen_type_node,
9375                          ffecom_expr (ffebld_head (e)));
9376
9377             if (list == NULL_TREE)
9378               list = item = build_tree_list (NULL_TREE, t);
9379             else
9380               {
9381                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9382                 item = TREE_CHAIN (item);
9383               }
9384           }
9385
9386         if (ffebld_left (ffebld_head (b)) == NULL)
9387           low = ffecom_integer_one_node;
9388         else
9389           low = ffecom_expr (ffebld_left (ffebld_head (b)));
9390         low = convert (ffecom_f2c_ftnlen_type_node, low);
9391
9392         back = build_tree_list (low, t);
9393         TREE_CHAIN (back) = backlist;
9394         backlist = back;
9395       }
9396
9397     for (item = backlist; item != NULL_TREE; item = TREE_CHAIN (item))
9398       {
9399         if (TREE_VALUE (item) == NULL_TREE)
9400           baseoff = TREE_PURPOSE (item);
9401         else
9402           baseoff = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
9403                               TREE_PURPOSE (item),
9404                               ffecom_2 (MULT_EXPR,
9405                                         ffecom_f2c_ftnlen_type_node,
9406                                         TREE_VALUE (item),
9407                                         baseoff));
9408       }
9409
9410     /* backlist now dead, along with all TREE_PURPOSEs on it.  */
9411
9412     baseoff = build_tree_list (NULL_TREE, baseoff);
9413     TREE_CHAIN (baseoff) = list;
9414
9415     numelem = build_tree_list (NULL_TREE, numelem);
9416     TREE_CHAIN (numelem) = baseoff;
9417
9418     numdim = build_tree_list (NULL_TREE, numdim);
9419     TREE_CHAIN (numdim) = numelem;
9420
9421     item = build_array_type (ffecom_f2c_ftnlen_type_node,
9422                              build_range_type (integer_type_node,
9423                                                integer_zero_node,
9424                                                build_int_2
9425                                                ((int) ffesymbol_rank (s)
9426                                                 + 2, 0)));
9427     list = build_constructor (item, numdim);
9428     TREE_CONSTANT (list) = 1;
9429     TREE_STATIC (list) = 1;
9430
9431     var = ffecom_get_invented_identifier ("__g77_dims_%d", mynumber++);
9432     var = build_decl (VAR_DECL, var, item);
9433     TREE_STATIC (var) = 1;
9434     DECL_INITIAL (var) = error_mark_node;
9435     var = start_decl (var, FALSE);
9436     finish_decl (var, list, FALSE);
9437
9438     var = ffecom_1 (ADDR_EXPR, build_pointer_type (item), var);
9439
9440     return var;
9441   }
9442 }
9443
9444 /* Essentially does a "fold (build1 (code, type, node))" while checking
9445    for certain housekeeping things.
9446
9447    NOTE: for building an ADDR_EXPR around a FUNCTION_DECL, use
9448    ffecom_1_fn instead.  */
9449
9450 tree
9451 ffecom_1 (enum tree_code code, tree type, tree node)
9452 {
9453   tree item;
9454
9455   if ((node == error_mark_node)
9456       || (type == error_mark_node))
9457     return error_mark_node;
9458
9459   if (code == ADDR_EXPR)
9460     {
9461       if (!ffe_mark_addressable (node))
9462         assert ("can't mark_addressable this node!" == NULL);
9463     }
9464
9465   switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9466     {
9467       tree realtype;
9468
9469     case REALPART_EXPR:
9470       item = build (COMPONENT_REF, type, node, TYPE_FIELDS (TREE_TYPE (node)));
9471       break;
9472
9473     case IMAGPART_EXPR:
9474       item = build (COMPONENT_REF, type, node, TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (node))));
9475       break;
9476
9477
9478     case NEGATE_EXPR:
9479       if (TREE_CODE (type) != RECORD_TYPE)
9480         {
9481           item = build1 (code, type, node);
9482           break;
9483         }
9484       node = ffecom_stabilize_aggregate_ (node);
9485       realtype = TREE_TYPE (TYPE_FIELDS (type));
9486       item =
9487         ffecom_2 (COMPLEX_EXPR, type,
9488                   ffecom_1 (NEGATE_EXPR, realtype,
9489                             ffecom_1 (REALPART_EXPR, realtype,
9490                                       node)),
9491                   ffecom_1 (NEGATE_EXPR, realtype,
9492                             ffecom_1 (IMAGPART_EXPR, realtype,
9493                                       node)));
9494       break;
9495
9496     default:
9497       item = build1 (code, type, node);
9498       break;
9499     }
9500
9501   if (TREE_SIDE_EFFECTS (node))
9502     TREE_SIDE_EFFECTS (item) = 1;
9503   if (code == ADDR_EXPR && staticp (node))
9504     TREE_CONSTANT (item) = 1;
9505   else if (code == INDIRECT_REF)
9506     TREE_READONLY (item) = TYPE_READONLY (type);
9507   return fold (item);
9508 }
9509
9510 /* Like ffecom_1 (ADDR_EXPR, TREE_TYPE (node), node), except
9511    handles TREE_CODE (node) == FUNCTION_DECL.  In particular,
9512    does not set TREE_ADDRESSABLE (because calling an inline
9513    function does not mean the function needs to be separately
9514    compiled).  */
9515
9516 tree
9517 ffecom_1_fn (tree node)
9518 {
9519   tree item;
9520   tree type;
9521
9522   if (node == error_mark_node)
9523     return error_mark_node;
9524
9525   type = build_type_variant (TREE_TYPE (node),
9526                              TREE_READONLY (node),
9527                              TREE_THIS_VOLATILE (node));
9528   item = build1 (ADDR_EXPR,
9529                  build_pointer_type (type), node);
9530   if (TREE_SIDE_EFFECTS (node))
9531     TREE_SIDE_EFFECTS (item) = 1;
9532   if (staticp (node))
9533     TREE_CONSTANT (item) = 1;
9534   return fold (item);
9535 }
9536
9537 /* Essentially does a "fold (build (code, type, node1, node2))" while
9538    checking for certain housekeeping things.  */
9539
9540 tree
9541 ffecom_2 (enum tree_code code, tree type, tree node1, tree node2)
9542 {
9543   tree item;
9544
9545   if ((node1 == error_mark_node)
9546       || (node2 == error_mark_node)
9547       || (type == error_mark_node))
9548     return error_mark_node;
9549
9550   switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9551     {
9552       tree a, b, c, d, realtype;
9553
9554     case CONJ_EXPR:
9555       assert ("no CONJ_EXPR support yet" == NULL);
9556       return error_mark_node;
9557
9558     case COMPLEX_EXPR:
9559       item = build_tree_list (TYPE_FIELDS (type), node1);
9560       TREE_CHAIN (item) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), node2);
9561       item = build_constructor (type, item);
9562       break;
9563
9564     case PLUS_EXPR:
9565       if (TREE_CODE (type) != RECORD_TYPE)
9566         {
9567           item = build (code, type, node1, node2);
9568           break;
9569         }
9570       node1 = ffecom_stabilize_aggregate_ (node1);
9571       node2 = ffecom_stabilize_aggregate_ (node2);
9572       realtype = TREE_TYPE (TYPE_FIELDS (type));
9573       item =
9574         ffecom_2 (COMPLEX_EXPR, type,
9575                   ffecom_2 (PLUS_EXPR, realtype,
9576                             ffecom_1 (REALPART_EXPR, realtype,
9577                                       node1),
9578                             ffecom_1 (REALPART_EXPR, realtype,
9579                                       node2)),
9580                   ffecom_2 (PLUS_EXPR, realtype,
9581                             ffecom_1 (IMAGPART_EXPR, realtype,
9582                                       node1),
9583                             ffecom_1 (IMAGPART_EXPR, realtype,
9584                                       node2)));
9585       break;
9586
9587     case MINUS_EXPR:
9588       if (TREE_CODE (type) != RECORD_TYPE)
9589         {
9590           item = build (code, type, node1, node2);
9591           break;
9592         }
9593       node1 = ffecom_stabilize_aggregate_ (node1);
9594       node2 = ffecom_stabilize_aggregate_ (node2);
9595       realtype = TREE_TYPE (TYPE_FIELDS (type));
9596       item =
9597         ffecom_2 (COMPLEX_EXPR, type,
9598                   ffecom_2 (MINUS_EXPR, realtype,
9599                             ffecom_1 (REALPART_EXPR, realtype,
9600                                       node1),
9601                             ffecom_1 (REALPART_EXPR, realtype,
9602                                       node2)),
9603                   ffecom_2 (MINUS_EXPR, realtype,
9604                             ffecom_1 (IMAGPART_EXPR, realtype,
9605                                       node1),
9606                             ffecom_1 (IMAGPART_EXPR, realtype,
9607                                       node2)));
9608       break;
9609
9610     case MULT_EXPR:
9611       if (TREE_CODE (type) != RECORD_TYPE)
9612         {
9613           item = build (code, type, node1, node2);
9614           break;
9615         }
9616       node1 = ffecom_stabilize_aggregate_ (node1);
9617       node2 = ffecom_stabilize_aggregate_ (node2);
9618       realtype = TREE_TYPE (TYPE_FIELDS (type));
9619       a = save_expr (ffecom_1 (REALPART_EXPR, realtype,
9620                                node1));
9621       b = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
9622                                node1));
9623       c = save_expr (ffecom_1 (REALPART_EXPR, realtype,
9624                                node2));
9625       d = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
9626                                node2));
9627       item =
9628         ffecom_2 (COMPLEX_EXPR, type,
9629                   ffecom_2 (MINUS_EXPR, realtype,
9630                             ffecom_2 (MULT_EXPR, realtype,
9631                                       a,
9632                                       c),
9633                             ffecom_2 (MULT_EXPR, realtype,
9634                                       b,
9635                                       d)),
9636                   ffecom_2 (PLUS_EXPR, realtype,
9637                             ffecom_2 (MULT_EXPR, realtype,
9638                                       a,
9639                                       d),
9640                             ffecom_2 (MULT_EXPR, realtype,
9641                                       c,
9642                                       b)));
9643       break;
9644
9645     case EQ_EXPR:
9646       if ((TREE_CODE (node1) != RECORD_TYPE)
9647           && (TREE_CODE (node2) != RECORD_TYPE))
9648         {
9649           item = build (code, type, node1, node2);
9650           break;
9651         }
9652       assert (TREE_CODE (node1) == RECORD_TYPE);
9653       assert (TREE_CODE (node2) == RECORD_TYPE);
9654       node1 = ffecom_stabilize_aggregate_ (node1);
9655       node2 = ffecom_stabilize_aggregate_ (node2);
9656       realtype = TREE_TYPE (TYPE_FIELDS (type));
9657       item =
9658         ffecom_2 (TRUTH_ANDIF_EXPR, type,
9659                   ffecom_2 (code, type,
9660                             ffecom_1 (REALPART_EXPR, realtype,
9661                                       node1),
9662                             ffecom_1 (REALPART_EXPR, realtype,
9663                                       node2)),
9664                   ffecom_2 (code, type,
9665                             ffecom_1 (IMAGPART_EXPR, realtype,
9666                                       node1),
9667                             ffecom_1 (IMAGPART_EXPR, realtype,
9668                                       node2)));
9669       break;
9670
9671     case NE_EXPR:
9672       if ((TREE_CODE (node1) != RECORD_TYPE)
9673           && (TREE_CODE (node2) != RECORD_TYPE))
9674         {
9675           item = build (code, type, node1, node2);
9676           break;
9677         }
9678       assert (TREE_CODE (node1) == RECORD_TYPE);
9679       assert (TREE_CODE (node2) == RECORD_TYPE);
9680       node1 = ffecom_stabilize_aggregate_ (node1);
9681       node2 = ffecom_stabilize_aggregate_ (node2);
9682       realtype = TREE_TYPE (TYPE_FIELDS (type));
9683       item =
9684         ffecom_2 (TRUTH_ORIF_EXPR, type,
9685                   ffecom_2 (code, type,
9686                             ffecom_1 (REALPART_EXPR, realtype,
9687                                       node1),
9688                             ffecom_1 (REALPART_EXPR, realtype,
9689                                       node2)),
9690                   ffecom_2 (code, type,
9691                             ffecom_1 (IMAGPART_EXPR, realtype,
9692                                       node1),
9693                             ffecom_1 (IMAGPART_EXPR, realtype,
9694                                       node2)));
9695       break;
9696
9697     default:
9698       item = build (code, type, node1, node2);
9699       break;
9700     }
9701
9702   if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2))
9703     TREE_SIDE_EFFECTS (item) = 1;
9704   return fold (item);
9705 }
9706
9707 /* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint
9708
9709    ffesymbol s;  // the ENTRY point itself
9710    if (ffecom_2pass_advise_entrypoint(s))
9711        // the ENTRY point has been accepted
9712
9713    Does whatever compiler needs to do when it learns about the entrypoint,
9714    like determine the return type of the master function, count the
9715    number of entrypoints, etc.  Returns FALSE if the return type is
9716    not compatible with the return type(s) of other entrypoint(s).
9717
9718    NOTE: for every call to this fn that returns TRUE, _do_entrypoint must
9719    later (after _finish_progunit) be called with the same entrypoint(s)
9720    as passed to this fn for which TRUE was returned.
9721
9722    03-Jan-92  JCB  2.0
9723       Return FALSE if the return type conflicts with previous entrypoints.  */
9724
9725 bool
9726 ffecom_2pass_advise_entrypoint (ffesymbol entry)
9727 {
9728   ffebld list;                  /* opITEM. */
9729   ffebld mlist;                 /* opITEM. */
9730   ffebld plist;                 /* opITEM. */
9731   ffebld arg;                   /* ffebld_head(opITEM). */
9732   ffebld item;                  /* opITEM. */
9733   ffesymbol s;                  /* ffebld_symter(arg). */
9734   ffeinfoBasictype bt = ffesymbol_basictype (entry);
9735   ffeinfoKindtype kt = ffesymbol_kindtype (entry);
9736   ffetargetCharacterSize size = ffesymbol_size (entry);
9737   bool ok;
9738
9739   if (ffecom_num_entrypoints_ == 0)
9740     {                           /* First entrypoint, make list of main
9741                                    arglist's dummies. */
9742       assert (ffecom_primary_entry_ != NULL);
9743
9744       ffecom_master_bt_ = ffesymbol_basictype (ffecom_primary_entry_);
9745       ffecom_master_kt_ = ffesymbol_kindtype (ffecom_primary_entry_);
9746       ffecom_master_size_ = ffesymbol_size (ffecom_primary_entry_);
9747
9748       for (plist = NULL, list = ffesymbol_dummyargs (ffecom_primary_entry_);
9749            list != NULL;
9750            list = ffebld_trail (list))
9751         {
9752           arg = ffebld_head (list);
9753           if (ffebld_op (arg) != FFEBLD_opSYMTER)
9754             continue;           /* Alternate return or some such thing. */
9755           item = ffebld_new_item (arg, NULL);
9756           if (plist == NULL)
9757             ffecom_master_arglist_ = item;
9758           else
9759             ffebld_set_trail (plist, item);
9760           plist = item;
9761         }
9762     }
9763
9764   /* If necessary, scan entry arglist for alternate returns.  Do this scan
9765      apparently redundantly (it's done below to UNIONize the arglists) so
9766      that we don't complain about RETURN 1 if an offending ENTRY is the only
9767      one with an alternate return.  */
9768
9769   if (!ffecom_is_altreturning_)
9770     {
9771       for (list = ffesymbol_dummyargs (entry);
9772            list != NULL;
9773            list = ffebld_trail (list))
9774         {
9775           arg = ffebld_head (list);
9776           if (ffebld_op (arg) == FFEBLD_opSTAR)
9777             {
9778               ffecom_is_altreturning_ = TRUE;
9779               break;
9780             }
9781         }
9782     }
9783
9784   /* Now check type compatibility. */
9785
9786   switch (ffecom_master_bt_)
9787     {
9788     case FFEINFO_basictypeNONE:
9789       ok = (bt != FFEINFO_basictypeCHARACTER);
9790       break;
9791
9792     case FFEINFO_basictypeCHARACTER:
9793       ok
9794         = (bt == FFEINFO_basictypeCHARACTER)
9795         && (kt == ffecom_master_kt_)
9796         && (size == ffecom_master_size_);
9797       break;
9798
9799     case FFEINFO_basictypeANY:
9800       return FALSE;             /* Just don't bother. */
9801
9802     default:
9803       if (bt == FFEINFO_basictypeCHARACTER)
9804         {
9805           ok = FALSE;
9806           break;
9807         }
9808       ok = TRUE;
9809       if ((bt != ffecom_master_bt_) || (kt != ffecom_master_kt_))
9810         {
9811           ffecom_master_bt_ = FFEINFO_basictypeNONE;
9812           ffecom_master_kt_ = FFEINFO_kindtypeNONE;
9813         }
9814       break;
9815     }
9816
9817   if (!ok)
9818     {
9819       ffebad_start (FFEBAD_ENTRY_CONFLICTS);
9820       ffest_ffebad_here_current_stmt (0);
9821       ffebad_finish ();
9822       return FALSE;             /* Can't handle entrypoint. */
9823     }
9824
9825   /* Entrypoint type compatible with previous types. */
9826
9827   ++ffecom_num_entrypoints_;
9828
9829   /* Master-arg-list = UNION(Master-arg-list,entry-arg-list). */
9830
9831   for (list = ffesymbol_dummyargs (entry);
9832        list != NULL;
9833        list = ffebld_trail (list))
9834     {
9835       arg = ffebld_head (list);
9836       if (ffebld_op (arg) != FFEBLD_opSYMTER)
9837         continue;               /* Alternate return or some such thing. */
9838       s = ffebld_symter (arg);
9839       for (plist = NULL, mlist = ffecom_master_arglist_;
9840            mlist != NULL;
9841            plist = mlist, mlist = ffebld_trail (mlist))
9842         {                       /* plist points to previous item for easy
9843                                    appending of arg. */
9844           if (ffebld_symter (ffebld_head (mlist)) == s)
9845             break;              /* Already have this arg in the master list. */
9846         }
9847       if (mlist != NULL)
9848         continue;               /* Already have this arg in the master list. */
9849
9850       /* Append this arg to the master list. */
9851
9852       item = ffebld_new_item (arg, NULL);
9853       if (plist == NULL)
9854         ffecom_master_arglist_ = item;
9855       else
9856         ffebld_set_trail (plist, item);
9857     }
9858
9859   return TRUE;
9860 }
9861
9862 /* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint
9863
9864    ffesymbol s;  // the ENTRY point itself
9865    ffecom_2pass_do_entrypoint(s);
9866
9867    Does whatever compiler needs to do to make the entrypoint actually
9868    happen.  Must be called for each entrypoint after
9869    ffecom_finish_progunit is called.  */
9870
9871 void
9872 ffecom_2pass_do_entrypoint (ffesymbol entry)
9873 {
9874   static int mfn_num = 0;
9875   static int ent_num;
9876
9877   if (mfn_num != ffecom_num_fns_)
9878     {                           /* First entrypoint for this program unit. */
9879       ent_num = 1;
9880       mfn_num = ffecom_num_fns_;
9881       ffecom_do_entry_ (ffecom_primary_entry_, 0);
9882     }
9883   else
9884     ++ent_num;
9885
9886   --ffecom_num_entrypoints_;
9887
9888   ffecom_do_entry_ (entry, ent_num);
9889 }
9890
9891 /* Essentially does a "fold (build (code, type, node1, node2))" while
9892    checking for certain housekeeping things.  Always sets
9893    TREE_SIDE_EFFECTS.  */
9894
9895 tree
9896 ffecom_2s (enum tree_code code, tree type, tree node1, tree node2)
9897 {
9898   tree item;
9899
9900   if ((node1 == error_mark_node)
9901       || (node2 == error_mark_node)
9902       || (type == error_mark_node))
9903     return error_mark_node;
9904
9905   item = build (code, type, node1, node2);
9906   TREE_SIDE_EFFECTS (item) = 1;
9907   return fold (item);
9908 }
9909
9910 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
9911    checking for certain housekeeping things.  */
9912
9913 tree
9914 ffecom_3 (enum tree_code code, tree type, tree node1, tree node2, tree node3)
9915 {
9916   tree item;
9917
9918   if ((node1 == error_mark_node)
9919       || (node2 == error_mark_node)
9920       || (node3 == error_mark_node)
9921       || (type == error_mark_node))
9922     return error_mark_node;
9923
9924   item = build (code, type, node1, node2, node3);
9925   if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2)
9926       || (node3 != NULL_TREE && TREE_SIDE_EFFECTS (node3)))
9927     TREE_SIDE_EFFECTS (item) = 1;
9928   return fold (item);
9929 }
9930
9931 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
9932    checking for certain housekeeping things.  Always sets
9933    TREE_SIDE_EFFECTS.  */
9934
9935 tree
9936 ffecom_3s (enum tree_code code, tree type, tree node1, tree node2, tree node3)
9937 {
9938   tree item;
9939
9940   if ((node1 == error_mark_node)
9941       || (node2 == error_mark_node)
9942       || (node3 == error_mark_node)
9943       || (type == error_mark_node))
9944     return error_mark_node;
9945
9946   item = build (code, type, node1, node2, node3);
9947   TREE_SIDE_EFFECTS (item) = 1;
9948   return fold (item);
9949 }
9950
9951 /* ffecom_arg_expr -- Transform argument expr into gcc tree
9952
9953    See use by ffecom_list_expr.
9954
9955    If expression is NULL, returns an integer zero tree.  If it is not
9956    a CHARACTER expression, returns whatever ffecom_expr
9957    returns and sets the length return value to NULL_TREE.  Otherwise
9958    generates code to evaluate the character expression, returns the proper
9959    pointer to the result, but does NOT set the length return value to a tree
9960    that specifies the length of the result.  (In other words, the length
9961    variable is always set to NULL_TREE, because a length is never passed.)
9962
9963    21-Dec-91  JCB  1.1
9964       Don't set returned length, since nobody needs it (yet; someday if
9965       we allow CHARACTER*(*) dummies to statement functions, we'll need
9966       it).  */
9967
9968 tree
9969 ffecom_arg_expr (ffebld expr, tree *length)
9970 {
9971   tree ign;
9972
9973   *length = NULL_TREE;
9974
9975   if (expr == NULL)
9976     return integer_zero_node;
9977
9978   if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
9979     return ffecom_expr (expr);
9980
9981   return ffecom_arg_ptr_to_expr (expr, &ign);
9982 }
9983
9984 /* Transform expression into constant argument-pointer-to-expression tree.
9985
9986    If the expression can be transformed into a argument-pointer-to-expression
9987    tree that is constant, that is done, and the tree returned.  Else
9988    NULL_TREE is returned.
9989
9990    That way, a caller can attempt to provide compile-time initialization
9991    of a variable and, if that fails, *then* choose to start a new block
9992    and resort to using temporaries, as appropriate.  */
9993
9994 tree
9995 ffecom_arg_ptr_to_const_expr (ffebld expr, tree *length)
9996 {
9997   if (! expr)
9998     return integer_zero_node;
9999
10000   if (ffebld_op (expr) == FFEBLD_opANY)
10001     {
10002       if (length)
10003         *length = error_mark_node;
10004       return error_mark_node;
10005     }
10006
10007   if (ffebld_arity (expr) == 0
10008       && (ffebld_op (expr) != FFEBLD_opSYMTER
10009           || ffebld_where (expr) == FFEINFO_whereCOMMON
10010           || ffebld_where (expr) == FFEINFO_whereGLOBAL
10011           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10012     {
10013       tree t;
10014
10015       t = ffecom_arg_ptr_to_expr (expr, length);
10016       assert (TREE_CONSTANT (t));
10017       assert (! length || TREE_CONSTANT (*length));
10018       return t;
10019     }
10020
10021   if (length
10022       && ffebld_size (expr) != FFETARGET_charactersizeNONE)
10023     *length = build_int_2 (ffebld_size (expr), 0);
10024   else if (length)
10025     *length = NULL_TREE;
10026   return NULL_TREE;
10027 }
10028
10029 /* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree
10030
10031    See use by ffecom_list_ptr_to_expr.
10032
10033    If expression is NULL, returns an integer zero tree.  If it is not
10034    a CHARACTER expression, returns whatever ffecom_ptr_to_expr
10035    returns and sets the length return value to NULL_TREE.  Otherwise
10036    generates code to evaluate the character expression, returns the proper
10037    pointer to the result, AND sets the length return value to a tree that
10038    specifies the length of the result.
10039
10040    If the length argument is NULL, this is a slightly special
10041    case of building a FORMAT expression, that is, an expression that
10042    will be used at run time without regard to length.  For the current
10043    implementation, which uses the libf2c library, this means it is nice
10044    to append a null byte to the end of the expression, where feasible,
10045    to make sure any diagnostic about the FORMAT string terminates at
10046    some useful point.
10047
10048    For now, treat %REF(char-expr) as the same as char-expr with a NULL
10049    length argument.  This might even be seen as a feature, if a null
10050    byte can always be appended.  */
10051
10052 tree
10053 ffecom_arg_ptr_to_expr (ffebld expr, tree *length)
10054 {
10055   tree item;
10056   tree ign_length;
10057   ffecomConcatList_ catlist;
10058
10059   if (length != NULL)
10060     *length = NULL_TREE;
10061
10062   if (expr == NULL)
10063     return integer_zero_node;
10064
10065   switch (ffebld_op (expr))
10066     {
10067     case FFEBLD_opPERCENT_VAL:
10068       if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10069         return ffecom_expr (ffebld_left (expr));
10070       {
10071         tree temp_exp;
10072         tree temp_length;
10073
10074         temp_exp = ffecom_arg_ptr_to_expr (ffebld_left (expr), &temp_length);
10075         if (temp_exp == error_mark_node)
10076           return error_mark_node;
10077
10078         return ffecom_1 (INDIRECT_REF, TREE_TYPE (TREE_TYPE (temp_exp)),
10079                          temp_exp);
10080       }
10081
10082     case FFEBLD_opPERCENT_REF:
10083       if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10084         return ffecom_ptr_to_expr (ffebld_left (expr));
10085       if (length != NULL)
10086         {
10087           ign_length = NULL_TREE;
10088           length = &ign_length;
10089         }
10090       expr = ffebld_left (expr);
10091       break;
10092
10093     case FFEBLD_opPERCENT_DESCR:
10094       switch (ffeinfo_basictype (ffebld_info (expr)))
10095         {
10096         case FFEINFO_basictypeCHARACTER:
10097           break;                /* Passed by descriptor anyway. */
10098
10099         default:
10100           item = ffecom_ptr_to_expr (expr);
10101           if (item != error_mark_node)
10102             *length = TYPE_SIZE (TREE_TYPE (TREE_TYPE (item)));
10103           break;
10104         }
10105       break;
10106
10107     default:
10108       break;
10109     }
10110
10111   if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10112     return ffecom_ptr_to_expr (expr);
10113
10114   assert (ffeinfo_kindtype (ffebld_info (expr))
10115           == FFEINFO_kindtypeCHARACTER1);
10116
10117   while (ffebld_op (expr) == FFEBLD_opPAREN)
10118     expr = ffebld_left (expr);
10119
10120   catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
10121   switch (ffecom_concat_list_count_ (catlist))
10122     {
10123     case 0:                     /* Shouldn't happen, but in case it does... */
10124       if (length != NULL)
10125         {
10126           *length = ffecom_f2c_ftnlen_zero_node;
10127           TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10128         }
10129       ffecom_concat_list_kill_ (catlist);
10130       return null_pointer_node;
10131
10132     case 1:                     /* The (fairly) easy case. */
10133       if (length == NULL)
10134         ffecom_char_args_with_null_ (&item, &ign_length,
10135                                      ffecom_concat_list_expr_ (catlist, 0));
10136       else
10137         ffecom_char_args_ (&item, length,
10138                            ffecom_concat_list_expr_ (catlist, 0));
10139       ffecom_concat_list_kill_ (catlist);
10140       assert (item != NULL_TREE);
10141       return item;
10142
10143     default:                    /* Must actually concatenate things. */
10144       break;
10145     }
10146
10147   {
10148     int count = ffecom_concat_list_count_ (catlist);
10149     int i;
10150     tree lengths;
10151     tree items;
10152     tree length_array;
10153     tree item_array;
10154     tree citem;
10155     tree clength;
10156     tree temporary;
10157     tree num;
10158     tree known_length;
10159     ffetargetCharacterSize sz;
10160
10161     sz = ffecom_concat_list_maxlen_ (catlist);
10162     /* ~~Kludge! */
10163     assert (sz != FFETARGET_charactersizeNONE);
10164
10165     {
10166       tree hook;
10167
10168       hook = ffebld_nonter_hook (expr);
10169       assert (hook);
10170       assert (TREE_CODE (hook) == TREE_VEC);
10171       assert (TREE_VEC_LENGTH (hook) == 3);
10172       length_array = lengths = TREE_VEC_ELT (hook, 0);
10173       item_array = items = TREE_VEC_ELT (hook, 1);
10174       temporary = TREE_VEC_ELT (hook, 2);
10175     }
10176
10177     known_length = ffecom_f2c_ftnlen_zero_node;
10178
10179     for (i = 0; i < count; ++i)
10180       {
10181         if ((i == count)
10182             && (length == NULL))
10183           ffecom_char_args_with_null_ (&citem, &clength,
10184                                        ffecom_concat_list_expr_ (catlist, i));
10185         else
10186           ffecom_char_args_ (&citem, &clength,
10187                              ffecom_concat_list_expr_ (catlist, i));
10188         if ((citem == error_mark_node)
10189             || (clength == error_mark_node))
10190           {
10191             ffecom_concat_list_kill_ (catlist);
10192             *length = error_mark_node;
10193             return error_mark_node;
10194           }
10195
10196         items
10197           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
10198                       ffecom_modify (void_type_node,
10199                                      ffecom_2 (ARRAY_REF,
10200                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
10201                                                item_array,
10202                                                build_int_2 (i, 0)),
10203                                      citem),
10204                       items);
10205         clength = ffecom_save_tree (clength);
10206         if (length != NULL)
10207           known_length
10208             = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
10209                         known_length,
10210                         clength);
10211         lengths
10212           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
10213                       ffecom_modify (void_type_node,
10214                                      ffecom_2 (ARRAY_REF,
10215                    TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
10216                                                length_array,
10217                                                build_int_2 (i, 0)),
10218                                      clength),
10219                       lengths);
10220       }
10221
10222     temporary = ffecom_1 (ADDR_EXPR,
10223                           build_pointer_type (TREE_TYPE (temporary)),
10224                           temporary);
10225
10226     item = build_tree_list (NULL_TREE, temporary);
10227     TREE_CHAIN (item)
10228       = build_tree_list (NULL_TREE,
10229                          ffecom_1 (ADDR_EXPR,
10230                                    build_pointer_type (TREE_TYPE (items)),
10231                                    items));
10232     TREE_CHAIN (TREE_CHAIN (item))
10233       = build_tree_list (NULL_TREE,
10234                          ffecom_1 (ADDR_EXPR,
10235                                    build_pointer_type (TREE_TYPE (lengths)),
10236                                    lengths));
10237     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
10238       = build_tree_list
10239         (NULL_TREE,
10240          ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
10241                    convert (ffecom_f2c_ftnlen_type_node,
10242                             build_int_2 (count, 0))));
10243     num = build_int_2 (sz, 0);
10244     TREE_TYPE (num) = ffecom_f2c_ftnlen_type_node;
10245     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item))))
10246       = build_tree_list (NULL_TREE, num);
10247
10248     item = ffecom_call_gfrt (FFECOM_gfrtCAT, item, NULL_TREE);
10249     TREE_SIDE_EFFECTS (item) = 1;
10250     item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (temporary),
10251                      item,
10252                      temporary);
10253
10254     if (length != NULL)
10255       *length = known_length;
10256   }
10257
10258   ffecom_concat_list_kill_ (catlist);
10259   assert (item != NULL_TREE);
10260   return item;
10261 }
10262
10263 /* Generate call to run-time function.
10264
10265    The first arg is the GNU Fortran Run-Time function index, the second
10266    arg is the list of arguments to pass to it.  Returned is the expression
10267    (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the
10268    result (which may be void).  */
10269
10270 tree
10271 ffecom_call_gfrt (ffecomGfrt ix, tree args, tree hook)
10272 {
10273   return ffecom_call_ (ffecom_gfrt_tree_ (ix),
10274                        ffecom_gfrt_kindtype (ix),
10275                        ffe_is_f2c_library () && ffecom_gfrt_complex_[ix],
10276                        NULL_TREE, args, NULL_TREE, NULL,
10277                        NULL, NULL_TREE, TRUE, hook);
10278 }
10279
10280 /* Transform constant-union to tree.  */
10281
10282 tree
10283 ffecom_constantunion (ffebldConstantUnion *cu, ffeinfoBasictype bt,
10284                       ffeinfoKindtype kt, tree tree_type)
10285 {
10286   tree item;
10287
10288   switch (bt)
10289     {
10290     case FFEINFO_basictypeINTEGER:
10291       {
10292         HOST_WIDE_INT hi, lo;
10293
10294         switch (kt)
10295           {
10296 #if FFETARGET_okINTEGER1
10297           case FFEINFO_kindtypeINTEGER1:
10298             lo = ffebld_cu_val_integer1 (*cu);
10299             hi = (lo < 0) ? -1 : 0;
10300             break;
10301 #endif
10302
10303 #if FFETARGET_okINTEGER2
10304           case FFEINFO_kindtypeINTEGER2:
10305             lo = ffebld_cu_val_integer2 (*cu);
10306             hi = (lo < 0) ? -1 : 0;
10307             break;
10308 #endif
10309
10310 #if FFETARGET_okINTEGER3
10311           case FFEINFO_kindtypeINTEGER3:
10312             lo = ffebld_cu_val_integer3 (*cu);
10313             hi = (lo < 0) ? -1 : 0;
10314             break;
10315 #endif
10316
10317 #if FFETARGET_okINTEGER4
10318           case FFEINFO_kindtypeINTEGER4:
10319 #if HOST_BITS_PER_LONGLONG > HOST_BITS_PER_WIDE_INT
10320             {
10321               long long int big = ffebld_cu_val_integer4 (*cu);
10322               hi = (HOST_WIDE_INT) (big >> HOST_BITS_PER_WIDE_INT);
10323               lo = (HOST_WIDE_INT) big;
10324             }
10325 #else
10326             lo = ffebld_cu_val_integer4 (*cu);
10327             hi = (lo < 0) ? -1 : 0;
10328 #endif
10329             break;
10330 #endif
10331
10332           default:
10333             assert ("bad INTEGER constant kind type" == NULL);
10334             /* Fall through. */
10335           case FFEINFO_kindtypeANY:
10336             return error_mark_node;
10337           }
10338         item = build_int_2 (lo, hi);
10339         TREE_TYPE (item) = tree_type;
10340       }
10341       break;
10342
10343     case FFEINFO_basictypeLOGICAL:
10344       {
10345         int val;
10346
10347         switch (kt)
10348           {
10349 #if FFETARGET_okLOGICAL1
10350           case FFEINFO_kindtypeLOGICAL1:
10351             val = ffebld_cu_val_logical1 (*cu);
10352             break;
10353 #endif
10354
10355 #if FFETARGET_okLOGICAL2
10356           case FFEINFO_kindtypeLOGICAL2:
10357             val = ffebld_cu_val_logical2 (*cu);
10358             break;
10359 #endif
10360
10361 #if FFETARGET_okLOGICAL3
10362           case FFEINFO_kindtypeLOGICAL3:
10363             val = ffebld_cu_val_logical3 (*cu);
10364             break;
10365 #endif
10366
10367 #if FFETARGET_okLOGICAL4
10368           case FFEINFO_kindtypeLOGICAL4:
10369             val = ffebld_cu_val_logical4 (*cu);
10370             break;
10371 #endif
10372
10373           default:
10374             assert ("bad LOGICAL constant kind type" == NULL);
10375             /* Fall through. */
10376           case FFEINFO_kindtypeANY:
10377             return error_mark_node;
10378           }
10379         item = build_int_2 (val, (val < 0) ? -1 : 0);
10380         TREE_TYPE (item) = tree_type;
10381       }
10382       break;
10383
10384     case FFEINFO_basictypeREAL:
10385       {
10386         REAL_VALUE_TYPE val;
10387
10388         switch (kt)
10389           {
10390 #if FFETARGET_okREAL1
10391           case FFEINFO_kindtypeREAL1:
10392             val = ffetarget_value_real1 (ffebld_cu_val_real1 (*cu));
10393             break;
10394 #endif
10395
10396 #if FFETARGET_okREAL2
10397           case FFEINFO_kindtypeREAL2:
10398             val = ffetarget_value_real2 (ffebld_cu_val_real2 (*cu));
10399             break;
10400 #endif
10401
10402 #if FFETARGET_okREAL3
10403           case FFEINFO_kindtypeREAL3:
10404             val = ffetarget_value_real3 (ffebld_cu_val_real3 (*cu));
10405             break;
10406 #endif
10407
10408           default:
10409             assert ("bad REAL constant kind type" == NULL);
10410             /* Fall through. */
10411           case FFEINFO_kindtypeANY:
10412             return error_mark_node;
10413           }
10414         item = build_real (tree_type, val);
10415       }
10416       break;
10417
10418     case FFEINFO_basictypeCOMPLEX:
10419       {
10420         REAL_VALUE_TYPE real;
10421         REAL_VALUE_TYPE imag;
10422         tree el_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
10423
10424         switch (kt)
10425           {
10426 #if FFETARGET_okCOMPLEX1
10427           case FFEINFO_kindtypeREAL1:
10428             real = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).real);
10429             imag = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).imaginary);
10430             break;
10431 #endif
10432
10433 #if FFETARGET_okCOMPLEX2
10434           case FFEINFO_kindtypeREAL2:
10435             real = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).real);
10436             imag = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).imaginary);
10437             break;
10438 #endif
10439
10440 #if FFETARGET_okCOMPLEX3
10441           case FFEINFO_kindtypeREAL3:
10442             real = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).real);
10443             imag = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).imaginary);
10444             break;
10445 #endif
10446
10447           default:
10448             assert ("bad REAL constant kind type" == NULL);
10449             /* Fall through. */
10450           case FFEINFO_kindtypeANY:
10451             return error_mark_node;
10452           }
10453         item = ffecom_build_complex_constant_ (tree_type,
10454                                                build_real (el_type, real),
10455                                                build_real (el_type, imag));
10456       }
10457       break;
10458
10459     case FFEINFO_basictypeCHARACTER:
10460       {                         /* Happens only in DATA and similar contexts. */
10461         ffetargetCharacter1 val;
10462
10463         switch (kt)
10464           {
10465 #if FFETARGET_okCHARACTER1
10466           case FFEINFO_kindtypeLOGICAL1:
10467             val = ffebld_cu_val_character1 (*cu);
10468             break;
10469 #endif
10470
10471           default:
10472             assert ("bad CHARACTER constant kind type" == NULL);
10473             /* Fall through. */
10474           case FFEINFO_kindtypeANY:
10475             return error_mark_node;
10476           }
10477         item = build_string (ffetarget_length_character1 (val),
10478                              ffetarget_text_character1 (val));
10479         TREE_TYPE (item)
10480           = build_type_variant (build_array_type (char_type_node,
10481                                                   build_range_type
10482                                                   (integer_type_node,
10483                                                    integer_one_node,
10484                                                    build_int_2
10485                                                 (ffetarget_length_character1
10486                                                  (val), 0))),
10487                                 1, 0);
10488       }
10489       break;
10490
10491     case FFEINFO_basictypeHOLLERITH:
10492       {
10493         ffetargetHollerith h;
10494
10495         h = ffebld_cu_val_hollerith (*cu);
10496
10497         /* If not at least as wide as default INTEGER, widen it.  */
10498         if (h.length >= FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE)
10499           item = build_string (h.length, h.text);
10500         else
10501           {
10502             char str[FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE];
10503
10504             memcpy (str, h.text, h.length);
10505             memset (&str[h.length], ' ',
10506                     FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE
10507                     - h.length);
10508             item = build_string (FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE,
10509                                  str);
10510           }
10511         TREE_TYPE (item)
10512           = build_type_variant (build_array_type (char_type_node,
10513                                                   build_range_type
10514                                                   (integer_type_node,
10515                                                    integer_one_node,
10516                                                    build_int_2
10517                                                    (h.length, 0))),
10518                                 1, 0);
10519       }
10520       break;
10521
10522     case FFEINFO_basictypeTYPELESS:
10523       {
10524         ffetargetInteger1 ival;
10525         ffetargetTypeless tless;
10526         ffebad error;
10527
10528         tless = ffebld_cu_val_typeless (*cu);
10529         error = ffetarget_convert_integer1_typeless (&ival, tless);
10530         assert (error == FFEBAD);
10531
10532         item = build_int_2 ((int) ival, 0);
10533       }
10534       break;
10535
10536     default:
10537       assert ("not yet on constant type" == NULL);
10538       /* Fall through. */
10539     case FFEINFO_basictypeANY:
10540       return error_mark_node;
10541     }
10542
10543   TREE_CONSTANT (item) = 1;
10544
10545   return item;
10546 }
10547
10548 /* Transform constant-union to tree, with the type known.  */
10549
10550 tree
10551 ffecom_constantunion_with_type (ffebldConstantUnion *cu, tree tree_type,
10552                                 ffebldConst ct)
10553 {
10554   tree item;
10555
10556   int val;
10557
10558   switch (ct)
10559   {
10560 #if FFETARGET_okINTEGER1
10561           case  FFEBLD_constINTEGER1:
10562           val = ffebld_cu_val_integer1 (*cu);
10563                   item = build_int_2 (val, (val < 0) ? -1 : 0);
10564                   break;
10565 #endif
10566 #if FFETARGET_okINTEGER2
10567           case  FFEBLD_constINTEGER2:
10568                   val = ffebld_cu_val_integer2 (*cu);
10569                   item = build_int_2 (val, (val < 0) ? -1 : 0);
10570                   break;
10571 #endif
10572 #if FFETARGET_okINTEGER3
10573           case  FFEBLD_constINTEGER3:
10574                   val = ffebld_cu_val_integer3 (*cu);
10575                   item = build_int_2 (val, (val < 0) ? -1 : 0);
10576                   break;
10577 #endif
10578 #if FFETARGET_okINTEGER4
10579           case  FFEBLD_constINTEGER4:
10580 #if HOST_BITS_PER_LONGLONG > HOST_BITS_PER_WIDE_INT
10581                   {
10582                     long long int big = ffebld_cu_val_integer4 (*cu);
10583                     item = build_int_2 ((HOST_WIDE_INT) big,
10584                                         (HOST_WIDE_INT)
10585                                         (big >> HOST_BITS_PER_WIDE_INT));
10586                   }
10587 #else
10588                   val = ffebld_cu_val_integer4 (*cu);
10589                   item = build_int_2 (val, (val < 0) ? -1 : 0);
10590 #endif
10591                   break;
10592 #endif
10593 #if FFETARGET_okLOGICAL1
10594           case  FFEBLD_constLOGICAL1:
10595                   val = ffebld_cu_val_logical1 (*cu);
10596                   item = build_int_2 (val, (val < 0) ? -1 : 0);
10597                   break;
10598 #endif
10599 #if FFETARGET_okLOGICAL2
10600           case  FFEBLD_constLOGICAL2:
10601                   val = ffebld_cu_val_logical2 (*cu);
10602                   item = build_int_2 (val, (val < 0) ? -1 : 0);
10603                   break;
10604 #endif
10605 #if FFETARGET_okLOGICAL3
10606           case  FFEBLD_constLOGICAL3:
10607                   val = ffebld_cu_val_logical3 (*cu);
10608                   item = build_int_2 (val, (val < 0) ? -1 : 0);
10609                   break;
10610 #endif
10611 #if FFETARGET_okLOGICAL4
10612           case  FFEBLD_constLOGICAL4:
10613                   val = ffebld_cu_val_logical4 (*cu);
10614                   item = build_int_2 (val, (val < 0) ? -1 : 0);
10615                   break;
10616 #endif
10617           default:
10618                   assert ("constant type not supported"==NULL);
10619                   return error_mark_node;
10620                   break;
10621   }
10622
10623   TREE_TYPE (item) = tree_type;
10624
10625   TREE_CONSTANT (item) = 1;
10626
10627   return item;
10628 }
10629 /* Transform expression into constant tree.
10630
10631    If the expression can be transformed into a tree that is constant,
10632    that is done, and the tree returned.  Else NULL_TREE is returned.
10633
10634    That way, a caller can attempt to provide compile-time initialization
10635    of a variable and, if that fails, *then* choose to start a new block
10636    and resort to using temporaries, as appropriate.  */
10637
10638 tree
10639 ffecom_const_expr (ffebld expr)
10640 {
10641   if (! expr)
10642     return integer_zero_node;
10643
10644   if (ffebld_op (expr) == FFEBLD_opANY)
10645     return error_mark_node;
10646
10647   if (ffebld_arity (expr) == 0
10648       && (ffebld_op (expr) != FFEBLD_opSYMTER
10649           || ffebld_where (expr) == FFEINFO_whereGLOBAL
10650           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10651     {
10652       tree t;
10653
10654       t = ffecom_expr (expr);
10655       assert (TREE_CONSTANT (t));
10656       return t;
10657     }
10658
10659   return NULL_TREE;
10660 }
10661
10662 /* Handy way to make a field in a struct/union.  */
10663
10664 tree
10665 ffecom_decl_field (tree context, tree prevfield, const char *name, tree type)
10666 {
10667   tree field;
10668
10669   field = build_decl (FIELD_DECL, get_identifier (name), type);
10670   DECL_CONTEXT (field) = context;
10671   DECL_ALIGN (field) = 0;
10672   DECL_USER_ALIGN (field) = 0;
10673   if (prevfield != NULL_TREE)
10674     TREE_CHAIN (prevfield) = field;
10675
10676   return field;
10677 }
10678
10679 void
10680 ffecom_close_include (FILE *f)
10681 {
10682   ffecom_close_include_ (f);
10683 }
10684
10685 /* End a compound statement (block).  */
10686
10687 tree
10688 ffecom_end_compstmt (void)
10689 {
10690   return bison_rule_compstmt_ ();
10691 }
10692
10693 /* ffecom_end_transition -- Perform end transition on all symbols
10694
10695    ffecom_end_transition();
10696
10697    Calls ffecom_sym_end_transition for each global and local symbol.  */
10698
10699 void
10700 ffecom_end_transition (void)
10701 {
10702   ffebld item;
10703
10704   if (ffe_is_ffedebug ())
10705     fprintf (dmpout, "; end_stmt_transition\n");
10706
10707   ffecom_list_blockdata_ = NULL;
10708   ffecom_list_common_ = NULL;
10709
10710   ffesymbol_drive (ffecom_sym_end_transition);
10711   if (ffe_is_ffedebug ())
10712     {
10713       ffestorag_report ();
10714     }
10715
10716   ffecom_start_progunit_ ();
10717
10718   for (item = ffecom_list_blockdata_;
10719        item != NULL;
10720        item = ffebld_trail (item))
10721     {
10722       ffebld callee;
10723       ffesymbol s;
10724       tree dt;
10725       tree t;
10726       tree var;
10727       static int number = 0;
10728
10729       callee = ffebld_head (item);
10730       s = ffebld_symter (callee);
10731       t = ffesymbol_hook (s).decl_tree;
10732       if (t == NULL_TREE)
10733         {
10734           s = ffecom_sym_transform_ (s);
10735           t = ffesymbol_hook (s).decl_tree;
10736         }
10737
10738       dt = build_pointer_type (TREE_TYPE (t));
10739
10740       var = build_decl (VAR_DECL,
10741                         ffecom_get_invented_identifier ("__g77_forceload_%d",
10742                                                         number++),
10743                         dt);
10744       DECL_EXTERNAL (var) = 0;
10745       TREE_STATIC (var) = 1;
10746       TREE_PUBLIC (var) = 0;
10747       DECL_INITIAL (var) = error_mark_node;
10748       TREE_USED (var) = 1;
10749
10750       var = start_decl (var, FALSE);
10751
10752       t = ffecom_1 (ADDR_EXPR, dt, t);
10753
10754       finish_decl (var, t, FALSE);
10755     }
10756
10757   /* This handles any COMMON areas that weren't referenced but have, for
10758      example, important initial data.  */
10759
10760   for (item = ffecom_list_common_;
10761        item != NULL;
10762        item = ffebld_trail (item))
10763     ffecom_transform_common_ (ffebld_symter (ffebld_head (item)));
10764
10765   ffecom_list_common_ = NULL;
10766 }
10767
10768 /* ffecom_exec_transition -- Perform exec transition on all symbols
10769
10770    ffecom_exec_transition();
10771
10772    Calls ffecom_sym_exec_transition for each global and local symbol.
10773    Make sure error updating not inhibited.  */
10774
10775 void
10776 ffecom_exec_transition (void)
10777 {
10778   bool inhibited;
10779
10780   if (ffe_is_ffedebug ())
10781     fprintf (dmpout, "; exec_stmt_transition\n");
10782
10783   inhibited = ffebad_inhibit ();
10784   ffebad_set_inhibit (FALSE);
10785
10786   ffesymbol_drive (ffecom_sym_exec_transition); /* Don't retract! */
10787   ffeequiv_exec_transition ();  /* Handle all pending EQUIVALENCEs. */
10788   if (ffe_is_ffedebug ())
10789     {
10790       ffestorag_report ();
10791     }
10792
10793   if (inhibited)
10794     ffebad_set_inhibit (TRUE);
10795 }
10796
10797 /* Handle assignment statement.
10798
10799    Convert dest and source using ffecom_expr, then join them
10800    with an ASSIGN op and pass the whole thing to expand_expr_stmt.  */
10801
10802 void
10803 ffecom_expand_let_stmt (ffebld dest, ffebld source)
10804 {
10805   tree dest_tree;
10806   tree dest_length;
10807   tree source_tree;
10808   tree expr_tree;
10809
10810   if (ffeinfo_basictype (ffebld_info (dest)) != FFEINFO_basictypeCHARACTER)
10811     {
10812       bool dest_used;
10813       tree assign_temp;
10814
10815       /* This attempts to replicate the test below, but must not be
10816          true when the test below is false.  (Always err on the side
10817          of creating unused temporaries, to avoid ICEs.)  */
10818       if (ffebld_op (dest) != FFEBLD_opSYMTER
10819           || ((dest_tree = ffesymbol_hook (ffebld_symter (dest)).decl_tree)
10820               && (TREE_CODE (dest_tree) != VAR_DECL
10821                   || TREE_ADDRESSABLE (dest_tree))))
10822         {
10823           ffecom_prepare_expr_ (source, dest);
10824           dest_used = TRUE;
10825         }
10826       else
10827         {
10828           ffecom_prepare_expr_ (source, NULL);
10829           dest_used = FALSE;
10830         }
10831
10832       ffecom_prepare_expr_w (NULL_TREE, dest);
10833
10834       /* For COMPLEX assignment like C1=C2, if partial overlap is possible,
10835          create a temporary through which the assignment is to take place,
10836          since MODIFY_EXPR doesn't handle partial overlap properly.  */
10837       if (ffebld_basictype (dest) == FFEINFO_basictypeCOMPLEX
10838           && ffecom_possible_partial_overlap_ (dest, source))
10839         {
10840           assign_temp = ffecom_make_tempvar ("complex_let",
10841                                              ffecom_tree_type
10842                                              [ffebld_basictype (dest)]
10843                                              [ffebld_kindtype (dest)],
10844                                              FFETARGET_charactersizeNONE,
10845                                              -1);
10846         }
10847       else
10848         assign_temp = NULL_TREE;
10849
10850       ffecom_prepare_end ();
10851
10852       dest_tree = ffecom_expr_w (NULL_TREE, dest);
10853       if (dest_tree == error_mark_node)
10854         return;
10855
10856       if ((TREE_CODE (dest_tree) != VAR_DECL)
10857           || TREE_ADDRESSABLE (dest_tree))
10858         source_tree = ffecom_expr_ (source, dest_tree, dest, &dest_used,
10859                                     FALSE, FALSE);
10860       else
10861         {
10862           assert (! dest_used);
10863           dest_used = FALSE;
10864           source_tree = ffecom_expr (source);
10865         }
10866       if (source_tree == error_mark_node)
10867         return;
10868
10869       if (dest_used)
10870         expr_tree = source_tree;
10871       else if (assign_temp)
10872         {
10873           expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
10874                                  assign_temp,
10875                                  source_tree);
10876           expand_expr_stmt (expr_tree);
10877           expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
10878                                  dest_tree,
10879                                  assign_temp);
10880         }
10881       else
10882         expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
10883                                dest_tree,
10884                                source_tree);
10885
10886       expand_expr_stmt (expr_tree);
10887       return;
10888     }
10889
10890   ffecom_prepare_let_char_ (ffebld_size_known (dest), source);
10891   ffecom_prepare_expr_w (NULL_TREE, dest);
10892
10893   ffecom_prepare_end ();
10894
10895   ffecom_char_args_ (&dest_tree, &dest_length, dest);
10896   ffecom_let_char_ (dest_tree, dest_length, ffebld_size_known (dest),
10897                     source);
10898 }
10899
10900 /* ffecom_expr -- Transform expr into gcc tree
10901
10902    tree t;
10903    ffebld expr;  // FFE expression.
10904    tree = ffecom_expr(expr);
10905
10906    Recursive descent on expr while making corresponding tree nodes and
10907    attaching type info and such.  */
10908
10909 tree
10910 ffecom_expr (ffebld expr)
10911 {
10912   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, FALSE, FALSE);
10913 }
10914
10915 /* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT.  */
10916
10917 tree
10918 ffecom_expr_assign (ffebld expr)
10919 {
10920   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
10921 }
10922
10923 /* Like ffecom_expr_rw, but return tree usable for ASSIGN.  */
10924
10925 tree
10926 ffecom_expr_assign_w (ffebld expr)
10927 {
10928   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
10929 }
10930
10931 /* Transform expr for use as into read/write tree and stabilize the
10932    reference.  Not for use on CHARACTER expressions.
10933
10934    Recursive descent on expr while making corresponding tree nodes and
10935    attaching type info and such.  */
10936
10937 tree
10938 ffecom_expr_rw (tree type, ffebld expr)
10939 {
10940   assert (expr != NULL);
10941   /* Different target types not yet supported.  */
10942   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
10943
10944   return stabilize_reference (ffecom_expr (expr));
10945 }
10946
10947 /* Transform expr for use as into write tree and stabilize the
10948    reference.  Not for use on CHARACTER expressions.
10949
10950    Recursive descent on expr while making corresponding tree nodes and
10951    attaching type info and such.  */
10952
10953 tree
10954 ffecom_expr_w (tree type, ffebld expr)
10955 {
10956   assert (expr != NULL);
10957   /* Different target types not yet supported.  */
10958   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
10959
10960   return stabilize_reference (ffecom_expr (expr));
10961 }
10962
10963 /* Do global stuff.  */
10964
10965 void
10966 ffecom_finish_compile (void)
10967 {
10968   assert (ffecom_outer_function_decl_ == NULL_TREE);
10969   assert (current_function_decl == NULL_TREE);
10970
10971   ffeglobal_drive (ffecom_finish_global_);
10972 }
10973
10974 /* Public entry point for front end to access finish_decl.  */
10975
10976 void
10977 ffecom_finish_decl (tree decl, tree init, bool is_top_level)
10978 {
10979   assert (!is_top_level);
10980   finish_decl (decl, init, FALSE);
10981 }
10982
10983 /* Finish a program unit.  */
10984
10985 void
10986 ffecom_finish_progunit (void)
10987 {
10988   ffecom_end_compstmt ();
10989
10990   ffecom_previous_function_decl_ = current_function_decl;
10991   ffecom_which_entrypoint_decl_ = NULL_TREE;
10992
10993   finish_function (0);
10994 }
10995
10996 /* Wrapper for get_identifier.  pattern is sprintf-like.  */
10997
10998 tree
10999 ffecom_get_invented_identifier (const char *pattern, ...)
11000 {
11001   tree decl;
11002   char *nam;
11003   va_list ap;
11004
11005   va_start (ap, pattern);
11006   if (vasprintf (&nam, pattern, ap) == 0)
11007     abort ();
11008   va_end (ap);
11009   decl = get_identifier (nam);
11010   free (nam);
11011   IDENTIFIER_INVENTED (decl) = 1;
11012   return decl;
11013 }
11014
11015 ffeinfoBasictype
11016 ffecom_gfrt_basictype (ffecomGfrt gfrt)
11017 {
11018   assert (gfrt < FFECOM_gfrt);
11019
11020   switch (ffecom_gfrt_type_[gfrt])
11021     {
11022     case FFECOM_rttypeVOID_:
11023     case FFECOM_rttypeVOIDSTAR_:
11024       return FFEINFO_basictypeNONE;
11025
11026     case FFECOM_rttypeFTNINT_:
11027       return FFEINFO_basictypeINTEGER;
11028
11029     case FFECOM_rttypeINTEGER_:
11030       return FFEINFO_basictypeINTEGER;
11031
11032     case FFECOM_rttypeLONGINT_:
11033       return FFEINFO_basictypeINTEGER;
11034
11035     case FFECOM_rttypeLOGICAL_:
11036       return FFEINFO_basictypeLOGICAL;
11037
11038     case FFECOM_rttypeREAL_F2C_:
11039     case FFECOM_rttypeREAL_GNU_:
11040       return FFEINFO_basictypeREAL;
11041
11042     case FFECOM_rttypeCOMPLEX_F2C_:
11043     case FFECOM_rttypeCOMPLEX_GNU_:
11044       return FFEINFO_basictypeCOMPLEX;
11045
11046     case FFECOM_rttypeDOUBLE_:
11047     case FFECOM_rttypeDOUBLEREAL_:
11048       return FFEINFO_basictypeREAL;
11049
11050     case FFECOM_rttypeDBLCMPLX_F2C_:
11051     case FFECOM_rttypeDBLCMPLX_GNU_:
11052       return FFEINFO_basictypeCOMPLEX;
11053
11054     case FFECOM_rttypeCHARACTER_:
11055       return FFEINFO_basictypeCHARACTER;
11056
11057     default:
11058       return FFEINFO_basictypeANY;
11059     }
11060 }
11061
11062 ffeinfoKindtype
11063 ffecom_gfrt_kindtype (ffecomGfrt gfrt)
11064 {
11065   assert (gfrt < FFECOM_gfrt);
11066
11067   switch (ffecom_gfrt_type_[gfrt])
11068     {
11069     case FFECOM_rttypeVOID_:
11070     case FFECOM_rttypeVOIDSTAR_:
11071       return FFEINFO_kindtypeNONE;
11072
11073     case FFECOM_rttypeFTNINT_:
11074       return FFEINFO_kindtypeINTEGER1;
11075
11076     case FFECOM_rttypeINTEGER_:
11077       return FFEINFO_kindtypeINTEGER1;
11078
11079     case FFECOM_rttypeLONGINT_:
11080       return FFEINFO_kindtypeINTEGER4;
11081
11082     case FFECOM_rttypeLOGICAL_:
11083       return FFEINFO_kindtypeLOGICAL1;
11084
11085     case FFECOM_rttypeREAL_F2C_:
11086     case FFECOM_rttypeREAL_GNU_:
11087       return FFEINFO_kindtypeREAL1;
11088
11089     case FFECOM_rttypeCOMPLEX_F2C_:
11090     case FFECOM_rttypeCOMPLEX_GNU_:
11091       return FFEINFO_kindtypeREAL1;
11092
11093     case FFECOM_rttypeDOUBLE_:
11094     case FFECOM_rttypeDOUBLEREAL_:
11095       return FFEINFO_kindtypeREAL2;
11096
11097     case FFECOM_rttypeDBLCMPLX_F2C_:
11098     case FFECOM_rttypeDBLCMPLX_GNU_:
11099       return FFEINFO_kindtypeREAL2;
11100
11101     case FFECOM_rttypeCHARACTER_:
11102       return FFEINFO_kindtypeCHARACTER1;
11103
11104     default:
11105       return FFEINFO_kindtypeANY;
11106     }
11107 }
11108
11109 void
11110 ffecom_init_0 (void)
11111 {
11112   tree endlink;
11113   int i;
11114   int j;
11115   tree t;
11116   tree field;
11117   ffetype type;
11118   ffetype base_type;
11119   tree double_ftype_double, double_ftype_double_double;
11120   tree float_ftype_float, float_ftype_float_float;
11121   tree ldouble_ftype_ldouble, ldouble_ftype_ldouble_ldouble;
11122   tree ffecom_tree_ptr_to_fun_type_void;
11123
11124   /* This block of code comes from the now-obsolete cktyps.c.  It checks
11125      whether the compiler environment is buggy in known ways, some of which
11126      would, if not explicitly checked here, result in subtle bugs in g77.  */
11127
11128   if (ffe_is_do_internal_checks ())
11129     {
11130       static const char names[][12]
11131         =
11132       {"bar", "bletch", "foo", "foobar"};
11133       const char *name;
11134       unsigned long ul;
11135       double fl;
11136
11137       name = bsearch ("foo", &names[0], ARRAY_SIZE (names), sizeof (names[0]),
11138                       (int (*)(const void *, const void *)) strcmp);
11139       if (name != &names[2][0])
11140         {
11141           assert ("bsearch doesn't work, #define FFEPROJ_BSEARCH 0 in proj.h"
11142                   == NULL);
11143           abort ();
11144         }
11145
11146       ul = strtoul ("123456789", NULL, 10);
11147       if (ul != 123456789L)
11148         {
11149           assert ("strtoul doesn't have enough range, #define FFEPROJ_STRTOUL 0\
11150  in proj.h" == NULL);
11151           abort ();
11152         }
11153
11154       fl = atof ("56.789");
11155       if ((fl < 56.788) || (fl > 56.79))
11156         {
11157           assert ("atof not type double, fix your #include <stdio.h>"
11158                   == NULL);
11159           abort ();
11160         }
11161     }
11162
11163   ffecom_outer_function_decl_ = NULL_TREE;
11164   current_function_decl = NULL_TREE;
11165   named_labels = NULL_TREE;
11166   current_binding_level = NULL_BINDING_LEVEL;
11167   free_binding_level = NULL_BINDING_LEVEL;
11168   /* Make the binding_level structure for global names.  */
11169   pushlevel (0);
11170   global_binding_level = current_binding_level;
11171   current_binding_level->prep_state = 2;
11172
11173   build_common_tree_nodes (1);
11174
11175   /* Define `int' and `char' first so that dbx will output them first.  */
11176   pushdecl (build_decl (TYPE_DECL, get_identifier ("int"),
11177                         integer_type_node));
11178   /* CHARACTER*1 is unsigned in ICHAR contexts.  */
11179   char_type_node = make_unsigned_type (CHAR_TYPE_SIZE);
11180   pushdecl (build_decl (TYPE_DECL, get_identifier ("char"),
11181                         char_type_node));
11182   pushdecl (build_decl (TYPE_DECL, get_identifier ("long int"),
11183                         long_integer_type_node));
11184   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned int"),
11185                         unsigned_type_node));
11186   pushdecl (build_decl (TYPE_DECL, get_identifier ("long unsigned int"),
11187                         long_unsigned_type_node));
11188   pushdecl (build_decl (TYPE_DECL, get_identifier ("long long int"),
11189                         long_long_integer_type_node));
11190   pushdecl (build_decl (TYPE_DECL, get_identifier ("long long unsigned int"),
11191                         long_long_unsigned_type_node));
11192   pushdecl (build_decl (TYPE_DECL, get_identifier ("short int"),
11193                         short_integer_type_node));
11194   pushdecl (build_decl (TYPE_DECL, get_identifier ("short unsigned int"),
11195                         short_unsigned_type_node));
11196
11197   /* Set the sizetype before we make other types.  This *should* be the
11198      first type we create.  */
11199
11200   set_sizetype
11201     (TREE_TYPE (IDENTIFIER_GLOBAL_VALUE (get_identifier (SIZE_TYPE))));
11202   ffecom_typesize_pointer_
11203     = TREE_INT_CST_LOW (TYPE_SIZE (sizetype)) / BITS_PER_UNIT;
11204
11205   build_common_tree_nodes_2 (0);
11206
11207   /* Define both `signed char' and `unsigned char'.  */
11208   pushdecl (build_decl (TYPE_DECL, get_identifier ("signed char"),
11209                         signed_char_type_node));
11210
11211   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned char"),
11212                         unsigned_char_type_node));
11213
11214   pushdecl (build_decl (TYPE_DECL, get_identifier ("float"),
11215                         float_type_node));
11216   pushdecl (build_decl (TYPE_DECL, get_identifier ("double"),
11217                         double_type_node));
11218   pushdecl (build_decl (TYPE_DECL, get_identifier ("long double"),
11219                         long_double_type_node));
11220
11221   /* For now, override what build_common_tree_nodes has done.  */
11222   complex_integer_type_node = ffecom_make_complex_type_ (integer_type_node);
11223   complex_float_type_node = ffecom_make_complex_type_ (float_type_node);
11224   complex_double_type_node = ffecom_make_complex_type_ (double_type_node);
11225   complex_long_double_type_node
11226     = ffecom_make_complex_type_ (long_double_type_node);
11227
11228   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex int"),
11229                         complex_integer_type_node));
11230   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex float"),
11231                         complex_float_type_node));
11232   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex double"),
11233                         complex_double_type_node));
11234   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex long double"),
11235                         complex_long_double_type_node));
11236
11237   pushdecl (build_decl (TYPE_DECL, get_identifier ("void"),
11238                         void_type_node));
11239   /* We are not going to have real types in C with less than byte alignment,
11240      so we might as well not have any types that claim to have it.  */
11241   TYPE_ALIGN (void_type_node) = BITS_PER_UNIT;
11242   TYPE_USER_ALIGN (void_type_node) = 0;
11243
11244   string_type_node = build_pointer_type (char_type_node);
11245
11246   ffecom_tree_fun_type_void
11247     = build_function_type (void_type_node, NULL_TREE);
11248
11249   ffecom_tree_ptr_to_fun_type_void
11250     = build_pointer_type (ffecom_tree_fun_type_void);
11251
11252   endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE);
11253
11254   t = tree_cons (NULL_TREE, float_type_node, endlink);
11255   float_ftype_float = build_function_type (float_type_node, t);
11256   t = tree_cons (NULL_TREE, float_type_node, t);
11257   float_ftype_float_float = build_function_type (float_type_node, t);
11258
11259   t = tree_cons (NULL_TREE, double_type_node, endlink);
11260   double_ftype_double = build_function_type (double_type_node, t);
11261   t = tree_cons (NULL_TREE, double_type_node, t);
11262   double_ftype_double_double = build_function_type (double_type_node, t);
11263
11264   t = tree_cons (NULL_TREE, long_double_type_node, endlink);
11265   ldouble_ftype_ldouble = build_function_type (long_double_type_node, t);
11266   t = tree_cons (NULL_TREE, long_double_type_node, t);
11267   ldouble_ftype_ldouble_ldouble = build_function_type (long_double_type_node,
11268                                                        t);
11269
11270   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11271     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11272       {
11273         ffecom_tree_type[i][j] = NULL_TREE;
11274         ffecom_tree_fun_type[i][j] = NULL_TREE;
11275         ffecom_tree_ptr_to_fun_type[i][j] = NULL_TREE;
11276         ffecom_f2c_typecode_[i][j] = -1;
11277       }
11278
11279   /* Set up standard g77 types.  Note that INTEGER and LOGICAL are set
11280      to size FLOAT_TYPE_SIZE because they have to be the same size as
11281      REAL, which also is FLOAT_TYPE_SIZE, according to the standard.
11282      Compiler options and other such stuff that change the ways these
11283      types are set should not affect this particular setup.  */
11284
11285   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1]
11286     = t = make_signed_type (FLOAT_TYPE_SIZE);
11287   pushdecl (build_decl (TYPE_DECL, get_identifier ("integer"),
11288                         t));
11289   type = ffetype_new ();
11290   base_type = type;
11291   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER1,
11292                     type);
11293   ffetype_set_ams (type,
11294                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11295                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11296   ffetype_set_star (base_type,
11297                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11298                     type);
11299   ffetype_set_kind (base_type, 1, type);
11300   ffecom_typesize_integer1_ = ffetype_size (type);
11301   assert (ffetype_size (type) == sizeof (ffetargetInteger1));
11302
11303   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER1]
11304     = t = make_unsigned_type (FLOAT_TYPE_SIZE); /* HOLLERITH means unsigned. */
11305   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned"),
11306                         t));
11307
11308   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER2]
11309     = t = make_signed_type (CHAR_TYPE_SIZE);
11310   pushdecl (build_decl (TYPE_DECL, get_identifier ("byte"),
11311                         t));
11312   type = ffetype_new ();
11313   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER2,
11314                     type);
11315   ffetype_set_ams (type,
11316                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11317                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11318   ffetype_set_star (base_type,
11319                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11320                     type);
11321   ffetype_set_kind (base_type, 3, type);
11322   assert (ffetype_size (type) == sizeof (ffetargetInteger2));
11323
11324   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER2]
11325     = t = make_unsigned_type (CHAR_TYPE_SIZE);
11326   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned byte"),
11327                         t));
11328
11329   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER3]
11330     = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11331   pushdecl (build_decl (TYPE_DECL, get_identifier ("word"),
11332                         t));
11333   type = ffetype_new ();
11334   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER3,
11335                     type);
11336   ffetype_set_ams (type,
11337                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11338                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11339   ffetype_set_star (base_type,
11340                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11341                     type);
11342   ffetype_set_kind (base_type, 6, type);
11343   assert (ffetype_size (type) == sizeof (ffetargetInteger3));
11344
11345   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER3]
11346     = t = make_unsigned_type (CHAR_TYPE_SIZE * 2);
11347   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned word"),
11348                         t));
11349
11350   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER4]
11351     = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11352   pushdecl (build_decl (TYPE_DECL, get_identifier ("integer4"),
11353                         t));
11354   type = ffetype_new ();
11355   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER4,
11356                     type);
11357   ffetype_set_ams (type,
11358                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11359                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11360   ffetype_set_star (base_type,
11361                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11362                     type);
11363   ffetype_set_kind (base_type, 2, type);
11364   assert (ffetype_size (type) == sizeof (ffetargetInteger4));
11365
11366   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER4]
11367     = t = make_unsigned_type (FLOAT_TYPE_SIZE * 2);
11368   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned4"),
11369                         t));
11370
11371 #if 0
11372   if (ffe_is_do_internal_checks ()
11373       && LONG_TYPE_SIZE != FLOAT_TYPE_SIZE
11374       && LONG_TYPE_SIZE != CHAR_TYPE_SIZE
11375       && LONG_TYPE_SIZE != SHORT_TYPE_SIZE
11376       && LONG_TYPE_SIZE != LONG_LONG_TYPE_SIZE)
11377     {
11378       fprintf (stderr, "Sorry, no g77 support for LONG_TYPE_SIZE (%d bits) yet.\n",
11379                LONG_TYPE_SIZE);
11380     }
11381 #endif
11382
11383   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL1]
11384     = t = make_signed_type (FLOAT_TYPE_SIZE);
11385   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical"),
11386                         t));
11387   type = ffetype_new ();
11388   base_type = type;
11389   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL1,
11390                     type);
11391   ffetype_set_ams (type,
11392                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11393                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11394   ffetype_set_star (base_type,
11395                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11396                     type);
11397   ffetype_set_kind (base_type, 1, type);
11398   assert (ffetype_size (type) == sizeof (ffetargetLogical1));
11399
11400   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL2]
11401     = t = make_signed_type (CHAR_TYPE_SIZE);
11402   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical2"),
11403                         t));
11404   type = ffetype_new ();
11405   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL2,
11406                     type);
11407   ffetype_set_ams (type,
11408                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11409                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11410   ffetype_set_star (base_type,
11411                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11412                     type);
11413   ffetype_set_kind (base_type, 3, type);
11414   assert (ffetype_size (type) == sizeof (ffetargetLogical2));
11415
11416   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL3]
11417     = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11418   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical3"),
11419                         t));
11420   type = ffetype_new ();
11421   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL3,
11422                     type);
11423   ffetype_set_ams (type,
11424                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11425                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11426   ffetype_set_star (base_type,
11427                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11428                     type);
11429   ffetype_set_kind (base_type, 6, type);
11430   assert (ffetype_size (type) == sizeof (ffetargetLogical3));
11431
11432   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL4]
11433     = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11434   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical4"),
11435                         t));
11436   type = ffetype_new ();
11437   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL4,
11438                     type);
11439   ffetype_set_ams (type,
11440                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11441                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11442   ffetype_set_star (base_type,
11443                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11444                     type);
11445   ffetype_set_kind (base_type, 2, type);
11446   assert (ffetype_size (type) == sizeof (ffetargetLogical4));
11447
11448   ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11449     = t = make_node (REAL_TYPE);
11450   TYPE_PRECISION (t) = FLOAT_TYPE_SIZE;
11451   pushdecl (build_decl (TYPE_DECL, get_identifier ("real"),
11452                         t));
11453   layout_type (t);
11454   type = ffetype_new ();
11455   base_type = type;
11456   ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL1,
11457                     type);
11458   ffetype_set_ams (type,
11459                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11460                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11461   ffetype_set_star (base_type,
11462                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11463                     type);
11464   ffetype_set_kind (base_type, 1, type);
11465   ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11466     = FFETARGET_f2cTYREAL;
11467   assert (ffetype_size (type) == sizeof (ffetargetReal1));
11468
11469   ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREALDOUBLE]
11470     = t = make_node (REAL_TYPE);
11471   TYPE_PRECISION (t) = FLOAT_TYPE_SIZE * 2;     /* Always twice REAL. */
11472   pushdecl (build_decl (TYPE_DECL, get_identifier ("double precision"),
11473                         t));
11474   layout_type (t);
11475   type = ffetype_new ();
11476   ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE,
11477                     type);
11478   ffetype_set_ams (type,
11479                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11480                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11481   ffetype_set_star (base_type,
11482                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11483                     type);
11484   ffetype_set_kind (base_type, 2, type);
11485   ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]
11486     = FFETARGET_f2cTYDREAL;
11487   assert (ffetype_size (type) == sizeof (ffetargetReal2));
11488
11489   ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11490     = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]);
11491   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex"),
11492                         t));
11493   type = ffetype_new ();
11494   base_type = type;
11495   ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL1,
11496                     type);
11497   ffetype_set_ams (type,
11498                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11499                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11500   ffetype_set_star (base_type,
11501                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11502                     type);
11503   ffetype_set_kind (base_type, 1, type);
11504   ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11505     = FFETARGET_f2cTYCOMPLEX;
11506   assert (ffetype_size (type) == sizeof (ffetargetComplex1));
11507
11508   ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREALDOUBLE]
11509     = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]);
11510   pushdecl (build_decl (TYPE_DECL, get_identifier ("double complex"),
11511                         t));
11512   type = ffetype_new ();
11513   ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREALDOUBLE,
11514                     type);
11515   ffetype_set_ams (type,
11516                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11517                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11518   ffetype_set_star (base_type,
11519                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11520                     type);
11521   ffetype_set_kind (base_type, 2,
11522                     type);
11523   ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL2]
11524     = FFETARGET_f2cTYDCOMPLEX;
11525   assert (ffetype_size (type) == sizeof (ffetargetComplex2));
11526
11527   /* Make function and ptr-to-function types for non-CHARACTER types. */
11528
11529   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11530     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11531       {
11532         if ((t = ffecom_tree_type[i][j]) != NULL_TREE)
11533           {
11534             if (i == FFEINFO_basictypeINTEGER)
11535               {
11536                 /* Figure out the smallest INTEGER type that can hold
11537                    a pointer on this machine. */
11538                 if (GET_MODE_SIZE (TYPE_MODE (t))
11539                     >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
11540                   {
11541                     if ((ffecom_pointer_kind_ == FFEINFO_kindtypeNONE)
11542                         || (GET_MODE_SIZE (TYPE_MODE (ffecom_tree_type[i][ffecom_pointer_kind_]))
11543                             > GET_MODE_SIZE (TYPE_MODE (t))))
11544                       ffecom_pointer_kind_ = j;
11545                   }
11546               }
11547             else if (i == FFEINFO_basictypeCOMPLEX)
11548               t = void_type_node;
11549             /* For f2c compatibility, REAL functions are really
11550                implemented as DOUBLE PRECISION.  */
11551             else if ((i == FFEINFO_basictypeREAL)
11552                      && (j == FFEINFO_kindtypeREAL1))
11553               t = ffecom_tree_type
11554                 [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2];
11555
11556             t = ffecom_tree_fun_type[i][j] = build_function_type (t,
11557                                                                   NULL_TREE);
11558             ffecom_tree_ptr_to_fun_type[i][j] = build_pointer_type (t);
11559           }
11560       }
11561
11562   /* Set up pointer types.  */
11563
11564   if (ffecom_pointer_kind_ == FFEINFO_basictypeNONE)
11565     fatal_error ("no INTEGER type can hold a pointer on this configuration");
11566   else if (0 && ffe_is_do_internal_checks ())
11567     fprintf (stderr, "Pointer type kt=%d\n", ffecom_pointer_kind_);
11568   ffetype_set_kind (ffeinfo_type (FFEINFO_basictypeINTEGER,
11569                                   FFEINFO_kindtypeINTEGERDEFAULT),
11570                     7,
11571                     ffeinfo_type (FFEINFO_basictypeINTEGER,
11572                                   ffecom_pointer_kind_));
11573
11574   if (ffe_is_ugly_assign ())
11575     ffecom_label_kind_ = ffecom_pointer_kind_;  /* Require ASSIGN etc to this. */
11576   else
11577     ffecom_label_kind_ = FFEINFO_kindtypeINTEGERDEFAULT;
11578   if (0 && ffe_is_do_internal_checks ())
11579     fprintf (stderr, "Label type kt=%d\n", ffecom_label_kind_);
11580
11581   ffecom_integer_type_node
11582     = ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1];
11583   ffecom_integer_zero_node = convert (ffecom_integer_type_node,
11584                                       integer_zero_node);
11585   ffecom_integer_one_node = convert (ffecom_integer_type_node,
11586                                      integer_one_node);
11587
11588   /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional.
11589      Turns out that by TYLONG, runtime/libI77/lio.h really means
11590      "whatever size an ftnint is".  For consistency and sanity,
11591      com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen
11592      all are INTEGER, which we also make out of whatever back-end
11593      integer type is FLOAT_TYPE_SIZE bits wide.  This change, from
11594      LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to
11595      accommodate machines like the Alpha.  Note that this suggests
11596      f2c and libf2c are missing a distinction perhaps needed on
11597      some machines between "int" and "long int".  -- burley 0.5.5 950215 */
11598
11599   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, FLOAT_TYPE_SIZE,
11600                             FFETARGET_f2cTYLONG);
11601   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, SHORT_TYPE_SIZE,
11602                             FFETARGET_f2cTYSHORT);
11603   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, CHAR_TYPE_SIZE,
11604                             FFETARGET_f2cTYINT1);
11605   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, LONG_LONG_TYPE_SIZE,
11606                             FFETARGET_f2cTYQUAD);
11607   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, FLOAT_TYPE_SIZE,
11608                             FFETARGET_f2cTYLOGICAL);
11609   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, SHORT_TYPE_SIZE,
11610                             FFETARGET_f2cTYLOGICAL2);
11611   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, CHAR_TYPE_SIZE,
11612                             FFETARGET_f2cTYLOGICAL1);
11613   /* ~~~Not really such a type in libf2c, e.g. I/O support?  */
11614   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, LONG_LONG_TYPE_SIZE,
11615                             FFETARGET_f2cTYQUAD);
11616
11617   /* CHARACTER stuff is all special-cased, so it is not handled in the above
11618      loop.  CHARACTER items are built as arrays of unsigned char.  */
11619
11620   ffecom_tree_type[FFEINFO_basictypeCHARACTER]
11621     [FFEINFO_kindtypeCHARACTER1] = t = char_type_node;
11622   type = ffetype_new ();
11623   base_type = type;
11624   ffeinfo_set_type (FFEINFO_basictypeCHARACTER,
11625                     FFEINFO_kindtypeCHARACTER1,
11626                     type);
11627   ffetype_set_ams (type,
11628                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11629                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11630   ffetype_set_kind (base_type, 1, type);
11631   assert (ffetype_size (type)
11632           == sizeof (((ffetargetCharacter1) { 0, NULL }).text[0]));
11633
11634   ffecom_tree_fun_type[FFEINFO_basictypeCHARACTER]
11635     [FFEINFO_kindtypeCHARACTER1] = ffecom_tree_fun_type_void;
11636   ffecom_tree_ptr_to_fun_type[FFEINFO_basictypeCHARACTER]
11637     [FFEINFO_kindtypeCHARACTER1]
11638     = ffecom_tree_ptr_to_fun_type_void;
11639   ffecom_f2c_typecode_[FFEINFO_basictypeCHARACTER][FFEINFO_kindtypeCHARACTER1]
11640     = FFETARGET_f2cTYCHAR;
11641
11642   ffecom_f2c_typecode_[FFEINFO_basictypeANY][FFEINFO_kindtypeANY]
11643     = 0;
11644
11645   /* Make multi-return-value type and fields. */
11646
11647   ffecom_multi_type_node_ = make_node (UNION_TYPE);
11648
11649   field = NULL_TREE;
11650
11651   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11652     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11653       {
11654         char name[30];
11655
11656         if (ffecom_tree_type[i][j] == NULL_TREE)
11657           continue;             /* Not supported. */
11658         sprintf (&name[0], "bt_%s_kt_%s",
11659                  ffeinfo_basictype_string ((ffeinfoBasictype) i),
11660                  ffeinfo_kindtype_string ((ffeinfoKindtype) j));
11661         ffecom_multi_fields_[i][j] = build_decl (FIELD_DECL,
11662                                                  get_identifier (name),
11663                                                  ffecom_tree_type[i][j]);
11664         DECL_CONTEXT (ffecom_multi_fields_[i][j])
11665           = ffecom_multi_type_node_;
11666         DECL_ALIGN (ffecom_multi_fields_[i][j]) = 0;
11667         DECL_USER_ALIGN (ffecom_multi_fields_[i][j]) = 0;
11668         TREE_CHAIN (ffecom_multi_fields_[i][j]) = field;
11669         field = ffecom_multi_fields_[i][j];
11670       }
11671
11672   TYPE_FIELDS (ffecom_multi_type_node_) = field;
11673   layout_type (ffecom_multi_type_node_);
11674
11675   /* Subroutines usually return integer because they might have alternate
11676      returns. */
11677
11678   ffecom_tree_subr_type
11679     = build_function_type (integer_type_node, NULL_TREE);
11680   ffecom_tree_ptr_to_subr_type
11681     = build_pointer_type (ffecom_tree_subr_type);
11682   ffecom_tree_blockdata_type
11683     = build_function_type (void_type_node, NULL_TREE);
11684
11685   builtin_function ("__builtin_atanf", float_ftype_float,
11686                     BUILT_IN_ATANF, BUILT_IN_NORMAL, "atanf", NULL_TREE);
11687   builtin_function ("__builtin_atan", double_ftype_double,
11688                     BUILT_IN_ATAN, BUILT_IN_NORMAL, "atan", NULL_TREE);
11689   builtin_function ("__builtin_atanl", ldouble_ftype_ldouble,
11690                     BUILT_IN_ATANL, BUILT_IN_NORMAL, "atanl", NULL_TREE);
11691
11692   builtin_function ("__builtin_atan2f", float_ftype_float_float,
11693                     BUILT_IN_ATAN2F, BUILT_IN_NORMAL, "atan2f", NULL_TREE);
11694   builtin_function ("__builtin_atan2", double_ftype_double_double,
11695                     BUILT_IN_ATAN2, BUILT_IN_NORMAL, "atan2", NULL_TREE);
11696   builtin_function ("__builtin_atan2l", ldouble_ftype_ldouble_ldouble,
11697                     BUILT_IN_ATAN2L, BUILT_IN_NORMAL, "atan2l", NULL_TREE);
11698
11699   builtin_function ("__builtin_cosf", float_ftype_float,
11700                     BUILT_IN_COSF, BUILT_IN_NORMAL, "cosf", NULL_TREE);
11701   builtin_function ("__builtin_cos", double_ftype_double,
11702                     BUILT_IN_COS, BUILT_IN_NORMAL, "cos", NULL_TREE);
11703   builtin_function ("__builtin_cosl", ldouble_ftype_ldouble,
11704                     BUILT_IN_COSL, BUILT_IN_NORMAL, "cosl", NULL_TREE);
11705
11706   builtin_function ("__builtin_expf", float_ftype_float,
11707                     BUILT_IN_EXPF, BUILT_IN_NORMAL, "expf", NULL_TREE);
11708   builtin_function ("__builtin_exp", double_ftype_double,
11709                     BUILT_IN_EXP, BUILT_IN_NORMAL, "exp", NULL_TREE);
11710   builtin_function ("__builtin_expl", ldouble_ftype_ldouble,
11711                     BUILT_IN_EXPL, BUILT_IN_NORMAL, "expl", NULL_TREE);
11712
11713   builtin_function ("__builtin_floorf", float_ftype_float,
11714                     BUILT_IN_FLOORF, BUILT_IN_NORMAL, "floorf", NULL_TREE);
11715   builtin_function ("__builtin_floor", double_ftype_double,
11716                     BUILT_IN_FLOOR, BUILT_IN_NORMAL, "floor", NULL_TREE);
11717   builtin_function ("__builtin_floorl", ldouble_ftype_ldouble,
11718                     BUILT_IN_FLOORL, BUILT_IN_NORMAL, "floorl", NULL_TREE);
11719
11720   builtin_function ("__builtin_fmodf", float_ftype_float_float,
11721                     BUILT_IN_FMODF, BUILT_IN_NORMAL, "fmodf", NULL_TREE);
11722   builtin_function ("__builtin_fmod", double_ftype_double_double,
11723                     BUILT_IN_FMOD, BUILT_IN_NORMAL, "fmod", NULL_TREE);
11724   builtin_function ("__builtin_fmodl", ldouble_ftype_ldouble_ldouble,
11725                     BUILT_IN_FMODL, BUILT_IN_NORMAL, "fmodl", NULL_TREE);
11726
11727   builtin_function ("__builtin_logf", float_ftype_float,
11728                     BUILT_IN_LOGF, BUILT_IN_NORMAL, "logf", NULL_TREE);
11729   builtin_function ("__builtin_log", double_ftype_double,
11730                     BUILT_IN_LOG, BUILT_IN_NORMAL, "log", NULL_TREE);
11731   builtin_function ("__builtin_logl", ldouble_ftype_ldouble,
11732                     BUILT_IN_LOGL, BUILT_IN_NORMAL, "logl", NULL_TREE);
11733
11734   builtin_function ("__builtin_powf", float_ftype_float_float,
11735                     BUILT_IN_POWF, BUILT_IN_NORMAL, "powf", NULL_TREE);
11736   builtin_function ("__builtin_pow", double_ftype_double_double,
11737                     BUILT_IN_POW, BUILT_IN_NORMAL, "pow", NULL_TREE);
11738   builtin_function ("__builtin_powl", ldouble_ftype_ldouble_ldouble,
11739                     BUILT_IN_POWL, BUILT_IN_NORMAL, "powl", NULL_TREE);
11740
11741   builtin_function ("__builtin_sinf", float_ftype_float,
11742                     BUILT_IN_SINF, BUILT_IN_NORMAL, "sinf", NULL_TREE);
11743   builtin_function ("__builtin_sin", double_ftype_double,
11744                     BUILT_IN_SIN, BUILT_IN_NORMAL, "sin", NULL_TREE);
11745   builtin_function ("__builtin_sinl", ldouble_ftype_ldouble,
11746                     BUILT_IN_SINL, BUILT_IN_NORMAL, "sinl", NULL_TREE);
11747
11748   builtin_function ("__builtin_sqrtf", float_ftype_float,
11749                     BUILT_IN_SQRTF, BUILT_IN_NORMAL, "sqrtf", NULL_TREE);
11750   builtin_function ("__builtin_sqrt", double_ftype_double,
11751                     BUILT_IN_SQRT, BUILT_IN_NORMAL, "sqrt", NULL_TREE);
11752   builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble,
11753                     BUILT_IN_SQRTL, BUILT_IN_NORMAL, "sqrtl", NULL_TREE);
11754
11755   builtin_function ("__builtin_tanf", float_ftype_float,
11756                     BUILT_IN_TANF, BUILT_IN_NORMAL, "tanf", NULL_TREE);
11757   builtin_function ("__builtin_tan", double_ftype_double,
11758                     BUILT_IN_TAN, BUILT_IN_NORMAL, "tan", NULL_TREE);
11759   builtin_function ("__builtin_tanl", ldouble_ftype_ldouble,
11760                     BUILT_IN_TANL, BUILT_IN_NORMAL, "tanl", NULL_TREE);
11761
11762   pedantic_lvalues = FALSE;
11763
11764   ffecom_f2c_make_type_ (&ffecom_f2c_integer_type_node,
11765                          FFECOM_f2cINTEGER,
11766                          "integer");
11767   ffecom_f2c_make_type_ (&ffecom_f2c_address_type_node,
11768                          FFECOM_f2cADDRESS,
11769                          "address");
11770   ffecom_f2c_make_type_ (&ffecom_f2c_real_type_node,
11771                          FFECOM_f2cREAL,
11772                          "real");
11773   ffecom_f2c_make_type_ (&ffecom_f2c_doublereal_type_node,
11774                          FFECOM_f2cDOUBLEREAL,
11775                          "doublereal");
11776   ffecom_f2c_make_type_ (&ffecom_f2c_complex_type_node,
11777                          FFECOM_f2cCOMPLEX,
11778                          "complex");
11779   ffecom_f2c_make_type_ (&ffecom_f2c_doublecomplex_type_node,
11780                          FFECOM_f2cDOUBLECOMPLEX,
11781                          "doublecomplex");
11782   ffecom_f2c_make_type_ (&ffecom_f2c_longint_type_node,
11783                          FFECOM_f2cLONGINT,
11784                          "longint");
11785   ffecom_f2c_make_type_ (&ffecom_f2c_logical_type_node,
11786                          FFECOM_f2cLOGICAL,
11787                          "logical");
11788   ffecom_f2c_make_type_ (&ffecom_f2c_flag_type_node,
11789                          FFECOM_f2cFLAG,
11790                          "flag");
11791   ffecom_f2c_make_type_ (&ffecom_f2c_ftnlen_type_node,
11792                          FFECOM_f2cFTNLEN,
11793                          "ftnlen");
11794   ffecom_f2c_make_type_ (&ffecom_f2c_ftnint_type_node,
11795                          FFECOM_f2cFTNINT,
11796                          "ftnint");
11797
11798   ffecom_f2c_ftnlen_zero_node
11799     = convert (ffecom_f2c_ftnlen_type_node, integer_zero_node);
11800
11801   ffecom_f2c_ftnlen_one_node
11802     = convert (ffecom_f2c_ftnlen_type_node, integer_one_node);
11803
11804   ffecom_f2c_ftnlen_two_node = build_int_2 (2, 0);
11805   TREE_TYPE (ffecom_f2c_ftnlen_two_node) = ffecom_integer_type_node;
11806
11807   ffecom_f2c_ptr_to_ftnlen_type_node
11808     = build_pointer_type (ffecom_f2c_ftnlen_type_node);
11809
11810   ffecom_f2c_ptr_to_ftnint_type_node
11811     = build_pointer_type (ffecom_f2c_ftnint_type_node);
11812
11813   ffecom_f2c_ptr_to_integer_type_node
11814     = build_pointer_type (ffecom_f2c_integer_type_node);
11815
11816   ffecom_f2c_ptr_to_real_type_node
11817     = build_pointer_type (ffecom_f2c_real_type_node);
11818
11819   ffecom_float_zero_ = build_real (float_type_node, dconst0);
11820   ffecom_double_zero_ = build_real (double_type_node, dconst0);
11821   ffecom_float_half_ = build_real (float_type_node, dconsthalf);
11822   ffecom_double_half_ = build_real (double_type_node, dconsthalf);
11823
11824   /* Do "extern int xargc;".  */
11825
11826   ffecom_tree_xargc_ = build_decl (VAR_DECL,
11827                                    get_identifier ("f__xargc"),
11828                                    integer_type_node);
11829   DECL_EXTERNAL (ffecom_tree_xargc_) = 1;
11830   TREE_STATIC (ffecom_tree_xargc_) = 1;
11831   TREE_PUBLIC (ffecom_tree_xargc_) = 1;
11832   ffecom_tree_xargc_ = start_decl (ffecom_tree_xargc_, FALSE);
11833   finish_decl (ffecom_tree_xargc_, NULL_TREE, FALSE);
11834
11835 #if 0   /* This is being fixed, and seems to be working now. */
11836   if ((FLOAT_TYPE_SIZE != 32)
11837       || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))) != 32))
11838     {
11839       warning ("configuration: REAL, INTEGER, and LOGICAL are %d bits wide,",
11840                (int) FLOAT_TYPE_SIZE);
11841       warning ("and pointers are %d bits wide, but g77 doesn't yet work",
11842           (int) TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))));
11843       warning ("properly unless they all are 32 bits wide");
11844       warning ("Please keep this in mind before you report bugs.");
11845     }
11846 #endif
11847
11848 #if 0   /* Code in ste.c that would crash has been commented out. */
11849   if (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)
11850       < TYPE_PRECISION (string_type_node))
11851     /* I/O will probably crash.  */
11852     warning ("configuration: char * holds %d bits, but ftnlen only %d",
11853              TYPE_PRECISION (string_type_node),
11854              TYPE_PRECISION (ffecom_f2c_ftnlen_type_node));
11855 #endif
11856
11857 #if 0   /* ASSIGN-related stuff has been changed to accommodate this. */
11858   if (TYPE_PRECISION (ffecom_integer_type_node)
11859       < TYPE_PRECISION (string_type_node))
11860     /* ASSIGN 10 TO I will crash.  */
11861     warning ("configuration: char * holds %d bits, but INTEGER only %d --\n\
11862  ASSIGN statement might fail",
11863              TYPE_PRECISION (string_type_node),
11864              TYPE_PRECISION (ffecom_integer_type_node));
11865 #endif
11866 }
11867
11868 /* ffecom_init_2 -- Initialize
11869
11870    ffecom_init_2();  */
11871
11872 void
11873 ffecom_init_2 (void)
11874 {
11875   assert (ffecom_outer_function_decl_ == NULL_TREE);
11876   assert (current_function_decl == NULL_TREE);
11877   assert (ffecom_which_entrypoint_decl_ == NULL_TREE);
11878
11879   ffecom_master_arglist_ = NULL;
11880   ++ffecom_num_fns_;
11881   ffecom_primary_entry_ = NULL;
11882   ffecom_is_altreturning_ = FALSE;
11883   ffecom_func_result_ = NULL_TREE;
11884   ffecom_multi_retval_ = NULL_TREE;
11885 }
11886
11887 /* ffecom_list_expr -- Transform list of exprs into gcc tree
11888
11889    tree t;
11890    ffebld expr;  // FFE opITEM list.
11891    tree = ffecom_list_expr(expr);
11892
11893    List of actual args is transformed into corresponding gcc backend list.  */
11894
11895 tree
11896 ffecom_list_expr (ffebld expr)
11897 {
11898   tree list;
11899   tree *plist = &list;
11900   tree trail = NULL_TREE;       /* Append char length args here. */
11901   tree *ptrail = &trail;
11902   tree length;
11903
11904   while (expr != NULL)
11905     {
11906       tree texpr = ffecom_arg_expr (ffebld_head (expr), &length);
11907
11908       if (texpr == error_mark_node)
11909         return error_mark_node;
11910
11911       *plist = build_tree_list (NULL_TREE, texpr);
11912       plist = &TREE_CHAIN (*plist);
11913       expr = ffebld_trail (expr);
11914       if (length != NULL_TREE)
11915         {
11916           *ptrail = build_tree_list (NULL_TREE, length);
11917           ptrail = &TREE_CHAIN (*ptrail);
11918         }
11919     }
11920
11921   *plist = trail;
11922
11923   return list;
11924 }
11925
11926 /* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree
11927
11928    tree t;
11929    ffebld expr;  // FFE opITEM list.
11930    tree = ffecom_list_ptr_to_expr(expr);
11931
11932    List of actual args is transformed into corresponding gcc backend list for
11933    use in calling an external procedure (vs. a statement function).  */
11934
11935 tree
11936 ffecom_list_ptr_to_expr (ffebld expr)
11937 {
11938   tree list;
11939   tree *plist = &list;
11940   tree trail = NULL_TREE;       /* Append char length args here. */
11941   tree *ptrail = &trail;
11942   tree length;
11943
11944   while (expr != NULL)
11945     {
11946       tree texpr = ffecom_arg_ptr_to_expr (ffebld_head (expr), &length);
11947
11948       if (texpr == error_mark_node)
11949         return error_mark_node;
11950
11951       *plist = build_tree_list (NULL_TREE, texpr);
11952       plist = &TREE_CHAIN (*plist);
11953       expr = ffebld_trail (expr);
11954       if (length != NULL_TREE)
11955         {
11956           *ptrail = build_tree_list (NULL_TREE, length);
11957           ptrail = &TREE_CHAIN (*ptrail);
11958         }
11959     }
11960
11961   *plist = trail;
11962
11963   return list;
11964 }
11965
11966 /* Obtain gcc's LABEL_DECL tree for label.  */
11967
11968 tree
11969 ffecom_lookup_label (ffelab label)
11970 {
11971   tree glabel;
11972
11973   if (ffelab_hook (label) == NULL_TREE)
11974     {
11975       char labelname[16];
11976
11977       switch (ffelab_type (label))
11978         {
11979         case FFELAB_typeLOOPEND:
11980         case FFELAB_typeNOTLOOP:
11981         case FFELAB_typeENDIF:
11982           sprintf (labelname, "%" ffelabValue_f "u", ffelab_value (label));
11983           glabel = build_decl (LABEL_DECL, get_identifier (labelname),
11984                                void_type_node);
11985           DECL_CONTEXT (glabel) = current_function_decl;
11986           DECL_MODE (glabel) = VOIDmode;
11987           break;
11988
11989         case FFELAB_typeFORMAT:
11990           glabel = build_decl (VAR_DECL,
11991                                ffecom_get_invented_identifier
11992                                ("__g77_format_%d", (int) ffelab_value (label)),
11993                                build_type_variant (build_array_type
11994                                                    (char_type_node,
11995                                                     NULL_TREE),
11996                                                    1, 0));
11997           TREE_CONSTANT (glabel) = 1;
11998           TREE_STATIC (glabel) = 1;
11999           DECL_CONTEXT (glabel) = current_function_decl;
12000           DECL_INITIAL (glabel) = NULL;
12001           make_decl_rtl (glabel, NULL);
12002           expand_decl (glabel);
12003
12004           ffecom_save_tree_forever (glabel);
12005
12006           break;
12007
12008         case FFELAB_typeANY:
12009           glabel = error_mark_node;
12010           break;
12011
12012         default:
12013           assert ("bad label type" == NULL);
12014           glabel = NULL;
12015           break;
12016         }
12017       ffelab_set_hook (label, glabel);
12018     }
12019   else
12020     {
12021       glabel = ffelab_hook (label);
12022     }
12023
12024   return glabel;
12025 }
12026
12027 /* Stabilizes the arguments.  Don't use this if the lhs and rhs come from
12028    a single source specification (as in the fourth argument of MVBITS).
12029    If the type is NULL_TREE, the type of lhs is used to make the type of
12030    the MODIFY_EXPR.  */
12031
12032 tree
12033 ffecom_modify (tree newtype, tree lhs, tree rhs)
12034 {
12035   if (lhs == error_mark_node || rhs == error_mark_node)
12036     return error_mark_node;
12037
12038   if (newtype == NULL_TREE)
12039     newtype = TREE_TYPE (lhs);
12040
12041   if (TREE_SIDE_EFFECTS (lhs))
12042     lhs = stabilize_reference (lhs);
12043
12044   return ffecom_2s (MODIFY_EXPR, newtype, lhs, rhs);
12045 }
12046
12047 /* Register source file name.  */
12048
12049 void
12050 ffecom_file (const char *name)
12051 {
12052   ffecom_file_ (name);
12053 }
12054
12055 /* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed
12056
12057    ffestorag st;
12058    ffecom_notify_init_storage(st);
12059
12060    Gets called when all possible units in an aggregate storage area (a LOCAL
12061    with equivalences or a COMMON) have been initialized.  The initialization
12062    info either is in ffestorag_init or, if that is NULL,
12063    ffestorag_accretion:
12064
12065    ffestorag_init may contain an opCONTER or opARRTER.  opCONTER may occur
12066    even for an array if the array is one element in length!
12067
12068    ffestorag_accretion will contain an opACCTER.  It is much like an
12069    opARRTER except it has an ffebit object in it instead of just a size.
12070    The back end can use the info in the ffebit object, if it wants, to
12071    reduce the amount of actual initialization, but in any case it should
12072    kill the ffebit object when done.  Also, set accretion to NULL but
12073    init to a non-NULL value.
12074
12075    After performing initialization, DO NOT set init to NULL, because that'll
12076    tell the front end it is ok for more initialization to happen.  Instead,
12077    set init to an opANY expression or some such thing that you can use to
12078    tell that you've already initialized the object.
12079
12080    27-Oct-91  JCB  1.1
12081       Support two-pass FFE.  */
12082
12083 void
12084 ffecom_notify_init_storage (ffestorag st)
12085 {
12086   ffebld init;                  /* The initialization expression. */
12087
12088   if (ffestorag_init (st) == NULL)
12089     {
12090       init = ffestorag_accretion (st);
12091       assert (init != NULL);
12092       ffestorag_set_accretion (st, NULL);
12093       ffestorag_set_accretes (st, 0);
12094       ffestorag_set_init (st, init);
12095     }
12096 }
12097
12098 /* ffecom_notify_init_symbol -- A symbol is now fully init'ed
12099
12100    ffesymbol s;
12101    ffecom_notify_init_symbol(s);
12102
12103    Gets called when all possible units in a symbol (not placed in COMMON
12104    or involved in EQUIVALENCE, unless it as yet has no ffestorag object)
12105    have been initialized.  The initialization info either is in
12106    ffesymbol_init or, if that is NULL, ffesymbol_accretion:
12107
12108    ffesymbol_init may contain an opCONTER or opARRTER.  opCONTER may occur
12109    even for an array if the array is one element in length!
12110
12111    ffesymbol_accretion will contain an opACCTER.  It is much like an
12112    opARRTER except it has an ffebit object in it instead of just a size.
12113    The back end can use the info in the ffebit object, if it wants, to
12114    reduce the amount of actual initialization, but in any case it should
12115    kill the ffebit object when done.  Also, set accretion to NULL but
12116    init to a non-NULL value.
12117
12118    After performing initialization, DO NOT set init to NULL, because that'll
12119    tell the front end it is ok for more initialization to happen.  Instead,
12120    set init to an opANY expression or some such thing that you can use to
12121    tell that you've already initialized the object.
12122
12123    27-Oct-91  JCB  1.1
12124       Support two-pass FFE.  */
12125
12126 void
12127 ffecom_notify_init_symbol (ffesymbol s)
12128 {
12129   ffebld init;                  /* The initialization expression. */
12130
12131   if (ffesymbol_storage (s) == NULL)
12132     return;                     /* Do nothing until COMMON/EQUIVALENCE
12133                                    possibilities checked. */
12134
12135   if ((ffesymbol_init (s) == NULL)
12136       && ((init = ffesymbol_accretion (s)) != NULL))
12137     {
12138       ffesymbol_set_accretion (s, NULL);
12139       ffesymbol_set_accretes (s, 0);
12140       ffesymbol_set_init (s, init);
12141     }
12142 }
12143
12144 /* ffecom_notify_primary_entry -- Learn which is the primary entry point
12145
12146    ffesymbol s;
12147    ffecom_notify_primary_entry(s);
12148
12149    Gets called when implicit or explicit PROGRAM statement seen or when
12150    FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary
12151    global symbol that serves as the entry point.  */
12152
12153 void
12154 ffecom_notify_primary_entry (ffesymbol s)
12155 {
12156   ffecom_primary_entry_ = s;
12157   ffecom_primary_entry_kind_ = ffesymbol_kind (s);
12158
12159   if ((ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
12160       || (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE))
12161     ffecom_primary_entry_is_proc_ = TRUE;
12162   else
12163     ffecom_primary_entry_is_proc_ = FALSE;
12164
12165   if (!ffe_is_silent ())
12166     {
12167       if (ffecom_primary_entry_kind_ == FFEINFO_kindPROGRAM)
12168         fprintf (stderr, "%s:\n", ffesymbol_text (s));
12169       else
12170         fprintf (stderr, "  %s:\n", ffesymbol_text (s));
12171     }
12172
12173   if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
12174     {
12175       ffebld list;
12176       ffebld arg;
12177
12178       for (list = ffesymbol_dummyargs (s);
12179            list != NULL;
12180            list = ffebld_trail (list))
12181         {
12182           arg = ffebld_head (list);
12183           if (ffebld_op (arg) == FFEBLD_opSTAR)
12184             {
12185               ffecom_is_altreturning_ = TRUE;
12186               break;
12187             }
12188         }
12189     }
12190 }
12191
12192 FILE *
12193 ffecom_open_include (char *name, ffewhereLine l, ffewhereColumn c)
12194 {
12195   return ffecom_open_include_ (name, l, c);
12196 }
12197
12198 /* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front
12199
12200    tree t;
12201    ffebld expr;  // FFE expression.
12202    tree = ffecom_ptr_to_expr(expr);
12203
12204    Like ffecom_expr, but sticks address-of in front of most things.  */
12205
12206 tree
12207 ffecom_ptr_to_expr (ffebld expr)
12208 {
12209   tree item;
12210   ffeinfoBasictype bt;
12211   ffeinfoKindtype kt;
12212   ffesymbol s;
12213
12214   assert (expr != NULL);
12215
12216   switch (ffebld_op (expr))
12217     {
12218     case FFEBLD_opSYMTER:
12219       s = ffebld_symter (expr);
12220       if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
12221         {
12222           ffecomGfrt ix;
12223
12224           ix = ffeintrin_gfrt_indirect (ffebld_symter_implementation (expr));
12225           assert (ix != FFECOM_gfrt);
12226           if ((item = ffecom_gfrt_[ix]) == NULL_TREE)
12227             {
12228               ffecom_make_gfrt_ (ix);
12229               item = ffecom_gfrt_[ix];
12230             }
12231         }
12232       else
12233         {
12234           item = ffesymbol_hook (s).decl_tree;
12235           if (item == NULL_TREE)
12236             {
12237               s = ffecom_sym_transform_ (s);
12238               item = ffesymbol_hook (s).decl_tree;
12239             }
12240         }
12241       assert (item != NULL);
12242       if (item == error_mark_node)
12243         return item;
12244       if (!ffesymbol_hook (s).addr)
12245         item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12246                          item);
12247       return item;
12248
12249     case FFEBLD_opARRAYREF:
12250       return ffecom_arrayref_ (NULL_TREE, expr, 1);
12251
12252     case FFEBLD_opCONTER:
12253
12254       bt = ffeinfo_basictype (ffebld_info (expr));
12255       kt = ffeinfo_kindtype (ffebld_info (expr));
12256
12257       item = ffecom_constantunion (&ffebld_constant_union
12258                                    (ffebld_conter (expr)), bt, kt,
12259                                    ffecom_tree_type[bt][kt]);
12260       if (item == error_mark_node)
12261         return error_mark_node;
12262       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12263                        item);
12264       return item;
12265
12266     case FFEBLD_opANY:
12267       return error_mark_node;
12268
12269     default:
12270       bt = ffeinfo_basictype (ffebld_info (expr));
12271       kt = ffeinfo_kindtype (ffebld_info (expr));
12272
12273       item = ffecom_expr (expr);
12274       if (item == error_mark_node)
12275         return error_mark_node;
12276
12277       /* The back end currently optimizes a bit too zealously for us, in that
12278          we fail JCB001 if the following block of code is omitted.  It checks
12279          to see if the transformed expression is a symbol or array reference,
12280          and encloses it in a SAVE_EXPR if that is the case.  */
12281
12282       STRIP_NOPS (item);
12283       if ((TREE_CODE (item) == VAR_DECL)
12284           || (TREE_CODE (item) == PARM_DECL)
12285           || (TREE_CODE (item) == RESULT_DECL)
12286           || (TREE_CODE (item) == INDIRECT_REF)
12287           || (TREE_CODE (item) == ARRAY_REF)
12288           || (TREE_CODE (item) == COMPONENT_REF)
12289 #ifdef OFFSET_REF
12290           || (TREE_CODE (item) == OFFSET_REF)
12291 #endif
12292           || (TREE_CODE (item) == BUFFER_REF)
12293           || (TREE_CODE (item) == REALPART_EXPR)
12294           || (TREE_CODE (item) == IMAGPART_EXPR))
12295         {
12296           item = ffecom_save_tree (item);
12297         }
12298
12299       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12300                        item);
12301       return item;
12302     }
12303
12304   assert ("fall-through error" == NULL);
12305   return error_mark_node;
12306 }
12307
12308 /* Obtain a temp var with given data type.
12309
12310    size is FFETARGET_charactersizeNONE for a non-CHARACTER type
12311    or >= 0 for a CHARACTER type.
12312
12313    elements is -1 for a scalar or > 0 for an array of type.  */
12314
12315 tree
12316 ffecom_make_tempvar (const char *commentary, tree type,
12317                      ffetargetCharacterSize size, int elements)
12318 {
12319   tree t;
12320   static int mynumber;
12321
12322   assert (current_binding_level->prep_state < 2);
12323
12324   if (type == error_mark_node)
12325     return error_mark_node;
12326
12327   if (size != FFETARGET_charactersizeNONE)
12328     type = build_array_type (type,
12329                              build_range_type (ffecom_f2c_ftnlen_type_node,
12330                                                ffecom_f2c_ftnlen_one_node,
12331                                                build_int_2 (size, 0)));
12332   if (elements != -1)
12333     type = build_array_type (type,
12334                              build_range_type (integer_type_node,
12335                                                integer_zero_node,
12336                                                build_int_2 (elements - 1,
12337                                                             0)));
12338   t = build_decl (VAR_DECL,
12339                   ffecom_get_invented_identifier ("__g77_%s_%d",
12340                                                   commentary,
12341                                                   mynumber++),
12342                   type);
12343
12344   t = start_decl (t, FALSE);
12345   finish_decl (t, NULL_TREE, FALSE);
12346
12347   return t;
12348 }
12349
12350 /* Prepare argument pointer to expression.
12351
12352    Like ffecom_prepare_expr, except for expressions to be evaluated
12353    via ffecom_arg_ptr_to_expr.  */
12354
12355 void
12356 ffecom_prepare_arg_ptr_to_expr (ffebld expr)
12357 {
12358   /* ~~For now, it seems to be the same thing.  */
12359   ffecom_prepare_expr (expr);
12360   return;
12361 }
12362
12363 /* End of preparations.  */
12364
12365 bool
12366 ffecom_prepare_end (void)
12367 {
12368   int prep_state = current_binding_level->prep_state;
12369
12370   assert (prep_state < 2);
12371   current_binding_level->prep_state = 2;
12372
12373   return (prep_state == 1) ? TRUE : FALSE;
12374 }
12375
12376 /* Prepare expression.
12377
12378    This is called before any code is generated for the current block.
12379    It scans the expression, declares any temporaries that might be needed
12380    during evaluation of the expression, and stores those temporaries in
12381    the appropriate "hook" fields of the expression.  `dest', if not NULL,
12382    specifies the destination that ffecom_expr_ will see, in case that
12383    helps avoid generating unused temporaries.
12384
12385    ~~Improve to avoid allocating unused temporaries by taking `dest'
12386    into account vis-a-vis aliasing requirements of complex/character
12387    functions.  */
12388
12389 void
12390 ffecom_prepare_expr_ (ffebld expr, ffebld dest UNUSED)
12391 {
12392   ffeinfoBasictype bt;
12393   ffeinfoKindtype kt;
12394   ffetargetCharacterSize sz;
12395   tree tempvar = NULL_TREE;
12396
12397   assert (current_binding_level->prep_state < 2);
12398
12399   if (! expr)
12400     return;
12401
12402   bt = ffeinfo_basictype (ffebld_info (expr));
12403   kt = ffeinfo_kindtype (ffebld_info (expr));
12404   sz = ffeinfo_size (ffebld_info (expr));
12405
12406   /* Generate whatever temporaries are needed to represent the result
12407      of the expression.  */
12408
12409   if (bt == FFEINFO_basictypeCHARACTER)
12410     {
12411       while (ffebld_op (expr) == FFEBLD_opPAREN)
12412         expr = ffebld_left (expr);
12413     }
12414
12415   switch (ffebld_op (expr))
12416     {
12417     default:
12418       /* Don't make temps for SYMTER, CONTER, etc.  */
12419       if (ffebld_arity (expr) == 0)
12420         break;
12421
12422       switch (bt)
12423         {
12424         case FFEINFO_basictypeCOMPLEX:
12425           if (ffebld_op (expr) == FFEBLD_opFUNCREF)
12426             {
12427               ffesymbol s;
12428
12429               if (ffebld_op (ffebld_left (expr)) != FFEBLD_opSYMTER)
12430                 break;
12431
12432               s = ffebld_symter (ffebld_left (expr));
12433               if (ffesymbol_where (s) == FFEINFO_whereCONSTANT
12434                   || (ffesymbol_where (s) != FFEINFO_whereINTRINSIC
12435                       && ! ffesymbol_is_f2c (s))
12436                   || (ffesymbol_where (s) == FFEINFO_whereINTRINSIC
12437                       && ! ffe_is_f2c_library ()))
12438                 break;
12439             }
12440           else if (ffebld_op (expr) == FFEBLD_opPOWER)
12441             {
12442               /* Requires special treatment.  There's no POW_CC function
12443                  in libg2c, so POW_ZZ is used, which means we always
12444                  need a double-complex temp, not a single-complex.  */
12445               kt = FFEINFO_kindtypeREAL2;
12446             }
12447           else if (ffebld_op (expr) != FFEBLD_opDIVIDE)
12448             /* The other ops don't need temps for complex operands.  */
12449             break;
12450
12451           /* ~~~Avoid making temps for some intrinsics, such as AIMAG(C),
12452              REAL(C).  See 19990325-0.f, routine `check', for cases.  */
12453           tempvar = ffecom_make_tempvar ("complex",
12454                                          ffecom_tree_type
12455                                          [FFEINFO_basictypeCOMPLEX][kt],
12456                                          FFETARGET_charactersizeNONE,
12457                                          -1);
12458           break;
12459
12460         case FFEINFO_basictypeCHARACTER:
12461           if (ffebld_op (expr) != FFEBLD_opFUNCREF)
12462             break;
12463
12464           if (sz == FFETARGET_charactersizeNONE)
12465             /* ~~Kludge alert!  This should someday be fixed. */
12466             sz = 24;
12467
12468           tempvar = ffecom_make_tempvar ("char", char_type_node, sz, -1);
12469           break;
12470
12471         default:
12472           break;
12473         }
12474       break;
12475
12476     case FFEBLD_opCONCATENATE:
12477       {
12478         /* This gets special handling, because only one set of temps
12479            is needed for a tree of these -- the tree is treated as
12480            a flattened list of concatenations when generating code.  */
12481
12482         ffecomConcatList_ catlist;
12483         tree ltmp, itmp, result;
12484         int count;
12485         int i;
12486
12487         catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
12488         count = ffecom_concat_list_count_ (catlist);
12489
12490         if (count >= 2)
12491           {
12492             ltmp
12493               = ffecom_make_tempvar ("concat_len",
12494                                      ffecom_f2c_ftnlen_type_node,
12495                                      FFETARGET_charactersizeNONE, count);
12496             itmp
12497               = ffecom_make_tempvar ("concat_item",
12498                                      ffecom_f2c_address_type_node,
12499                                      FFETARGET_charactersizeNONE, count);
12500             result
12501               = ffecom_make_tempvar ("concat_res",
12502                                      char_type_node,
12503                                      ffecom_concat_list_maxlen_ (catlist),
12504                                      -1);
12505
12506             tempvar = make_tree_vec (3);
12507             TREE_VEC_ELT (tempvar, 0) = ltmp;
12508             TREE_VEC_ELT (tempvar, 1) = itmp;
12509             TREE_VEC_ELT (tempvar, 2) = result;
12510           }
12511
12512         for (i = 0; i < count; ++i)
12513           ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist,
12514                                                                     i));
12515
12516         ffecom_concat_list_kill_ (catlist);
12517
12518         if (tempvar)
12519           {
12520             ffebld_nonter_set_hook (expr, tempvar);
12521             current_binding_level->prep_state = 1;
12522           }
12523       }
12524       return;
12525
12526     case FFEBLD_opCONVERT:
12527       if (bt == FFEINFO_basictypeCHARACTER
12528           && ((ffebld_size_known (ffebld_left (expr))
12529                == FFETARGET_charactersizeNONE)
12530               || (ffebld_size_known (ffebld_left (expr)) >= sz)))
12531         tempvar = ffecom_make_tempvar ("convert", char_type_node, sz, -1);
12532       break;
12533     }
12534
12535   if (tempvar)
12536     {
12537       ffebld_nonter_set_hook (expr, tempvar);
12538       current_binding_level->prep_state = 1;
12539     }
12540
12541   /* Prepare subexpressions for this expr.  */
12542
12543   switch (ffebld_op (expr))
12544     {
12545     case FFEBLD_opPERCENT_LOC:
12546       ffecom_prepare_ptr_to_expr (ffebld_left (expr));
12547       break;
12548
12549     case FFEBLD_opPERCENT_VAL:
12550     case FFEBLD_opPERCENT_REF:
12551       ffecom_prepare_expr (ffebld_left (expr));
12552       break;
12553
12554     case FFEBLD_opPERCENT_DESCR:
12555       ffecom_prepare_arg_ptr_to_expr (ffebld_left (expr));
12556       break;
12557
12558     case FFEBLD_opITEM:
12559       {
12560         ffebld item;
12561
12562         for (item = expr;
12563              item != NULL;
12564              item = ffebld_trail (item))
12565           if (ffebld_head (item) != NULL)
12566             ffecom_prepare_expr (ffebld_head (item));
12567       }
12568       break;
12569
12570     default:
12571       /* Need to handle character conversion specially.  */
12572       switch (ffebld_arity (expr))
12573         {
12574         case 2:
12575           ffecom_prepare_expr (ffebld_left (expr));
12576           ffecom_prepare_expr (ffebld_right (expr));
12577           break;
12578
12579         case 1:
12580           ffecom_prepare_expr (ffebld_left (expr));
12581           break;
12582
12583         default:
12584           break;
12585         }
12586     }
12587
12588   return;
12589 }
12590
12591 /* Prepare expression for reading and writing.
12592
12593    Like ffecom_prepare_expr, except for expressions to be evaluated
12594    via ffecom_expr_rw.  */
12595
12596 void
12597 ffecom_prepare_expr_rw (tree type, ffebld expr)
12598 {
12599   /* This is all we support for now.  */
12600   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
12601
12602   /* ~~For now, it seems to be the same thing.  */
12603   ffecom_prepare_expr (expr);
12604   return;
12605 }
12606
12607 /* Prepare expression for writing.
12608
12609    Like ffecom_prepare_expr, except for expressions to be evaluated
12610    via ffecom_expr_w.  */
12611
12612 void
12613 ffecom_prepare_expr_w (tree type, ffebld expr)
12614 {
12615   /* This is all we support for now.  */
12616   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
12617
12618   /* ~~For now, it seems to be the same thing.  */
12619   ffecom_prepare_expr (expr);
12620   return;
12621 }
12622
12623 /* Prepare expression for returning.
12624
12625    Like ffecom_prepare_expr, except for expressions to be evaluated
12626    via ffecom_return_expr.  */
12627
12628 void
12629 ffecom_prepare_return_expr (ffebld expr)
12630 {
12631   assert (current_binding_level->prep_state < 2);
12632
12633   if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE
12634       && ffecom_is_altreturning_
12635       && expr != NULL)
12636     ffecom_prepare_expr (expr);
12637 }
12638
12639 /* Prepare pointer to expression.
12640
12641    Like ffecom_prepare_expr, except for expressions to be evaluated
12642    via ffecom_ptr_to_expr.  */
12643
12644 void
12645 ffecom_prepare_ptr_to_expr (ffebld expr)
12646 {
12647   /* ~~For now, it seems to be the same thing.  */
12648   ffecom_prepare_expr (expr);
12649   return;
12650 }
12651
12652 /* Transform expression into constant pointer-to-expression tree.
12653
12654    If the expression can be transformed into a pointer-to-expression tree
12655    that is constant, that is done, and the tree returned.  Else NULL_TREE
12656    is returned.
12657
12658    That way, a caller can attempt to provide compile-time initialization
12659    of a variable and, if that fails, *then* choose to start a new block
12660    and resort to using temporaries, as appropriate.  */
12661
12662 tree
12663 ffecom_ptr_to_const_expr (ffebld expr)
12664 {
12665   if (! expr)
12666     return integer_zero_node;
12667
12668   if (ffebld_op (expr) == FFEBLD_opANY)
12669     return error_mark_node;
12670
12671   if (ffebld_arity (expr) == 0
12672       && (ffebld_op (expr) != FFEBLD_opSYMTER
12673           || ffebld_where (expr) == FFEINFO_whereCOMMON
12674           || ffebld_where (expr) == FFEINFO_whereGLOBAL
12675           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
12676     {
12677       tree t;
12678
12679       t = ffecom_ptr_to_expr (expr);
12680       assert (TREE_CONSTANT (t));
12681       return t;
12682     }
12683
12684   return NULL_TREE;
12685 }
12686
12687 /* ffecom_return_expr -- Returns return-value expr given alt return expr
12688
12689    tree rtn;  // NULL_TREE means use expand_null_return()
12690    ffebld expr;  // NULL if no alt return expr to RETURN stmt
12691    rtn = ffecom_return_expr(expr);
12692
12693    Based on the program unit type and other info (like return function
12694    type, return master function type when alternate ENTRY points,
12695    whether subroutine has any alternate RETURN points, etc), returns the
12696    appropriate expression to be returned to the caller, or NULL_TREE
12697    meaning no return value or the caller expects it to be returned somewhere
12698    else (which is handled by other parts of this module).  */
12699
12700 tree
12701 ffecom_return_expr (ffebld expr)
12702 {
12703   tree rtn;
12704
12705   switch (ffecom_primary_entry_kind_)
12706     {
12707     case FFEINFO_kindPROGRAM:
12708     case FFEINFO_kindBLOCKDATA:
12709       rtn = NULL_TREE;
12710       break;
12711
12712     case FFEINFO_kindSUBROUTINE:
12713       if (!ffecom_is_altreturning_)
12714         rtn = NULL_TREE;        /* No alt returns, never an expr. */
12715       else if (expr == NULL)
12716         rtn = integer_zero_node;
12717       else
12718         rtn = ffecom_expr (expr);
12719       break;
12720
12721     case FFEINFO_kindFUNCTION:
12722       if ((ffecom_multi_retval_ != NULL_TREE)
12723           || (ffesymbol_basictype (ffecom_primary_entry_)
12724               == FFEINFO_basictypeCHARACTER)
12725           || ((ffesymbol_basictype (ffecom_primary_entry_)
12726                == FFEINFO_basictypeCOMPLEX)
12727               && (ffecom_num_entrypoints_ == 0)
12728               && ffesymbol_is_f2c (ffecom_primary_entry_)))
12729         {                       /* Value is returned by direct assignment
12730                                    into (implicit) dummy. */
12731           rtn = NULL_TREE;
12732           break;
12733         }
12734       rtn = ffecom_func_result_;
12735 #if 0
12736       /* Spurious error if RETURN happens before first reference!  So elide
12737          this code.  In particular, for debugging registry, rtn should always
12738          be non-null after all, but TREE_USED won't be set until we encounter
12739          a reference in the code.  Perfectly okay (but weird) code that,
12740          e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in
12741          this diagnostic for no reason.  Have people use -O -Wuninitialized
12742          and leave it to the back end to find obviously weird cases.  */
12743
12744       /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid
12745          situation; if the return value has never been referenced, it won't
12746          have a tree under 2pass mode. */
12747       if ((rtn == NULL_TREE)
12748           || !TREE_USED (rtn))
12749         {
12750           ffebad_start (FFEBAD_RETURN_VALUE_UNSET);
12751           ffebad_here (0, ffesymbol_where_line (ffecom_primary_entry_),
12752                        ffesymbol_where_column (ffecom_primary_entry_));
12753           ffebad_string (ffesymbol_text (ffesymbol_funcresult
12754                                          (ffecom_primary_entry_)));
12755           ffebad_finish ();
12756         }
12757 #endif
12758       break;
12759
12760     default:
12761       assert ("bad unit kind" == NULL);
12762     case FFEINFO_kindANY:
12763       rtn = error_mark_node;
12764       break;
12765     }
12766
12767   return rtn;
12768 }
12769
12770 /* Do save_expr only if tree is not error_mark_node.  */
12771
12772 tree
12773 ffecom_save_tree (tree t)
12774 {
12775   return save_expr (t);
12776 }
12777
12778 /* Start a compound statement (block).  */
12779
12780 void
12781 ffecom_start_compstmt (void)
12782 {
12783   bison_rule_pushlevel_ ();
12784 }
12785
12786 /* Public entry point for front end to access start_decl.  */
12787
12788 tree
12789 ffecom_start_decl (tree decl, bool is_initialized)
12790 {
12791   DECL_INITIAL (decl) = is_initialized ? error_mark_node : NULL_TREE;
12792   return start_decl (decl, FALSE);
12793 }
12794
12795 /* ffecom_sym_commit -- Symbol's state being committed to reality
12796
12797    ffesymbol s;
12798    ffecom_sym_commit(s);
12799
12800    Does whatever the backend needs when a symbol is committed after having
12801    been backtrackable for a period of time.  */
12802
12803 void
12804 ffecom_sym_commit (ffesymbol s UNUSED)
12805 {
12806   assert (!ffesymbol_retractable ());
12807 }
12808
12809 /* ffecom_sym_end_transition -- Perform end transition on all symbols
12810
12811    ffecom_sym_end_transition();
12812
12813    Does backend-specific stuff and also calls ffest_sym_end_transition
12814    to do the necessary FFE stuff.
12815
12816    Backtracking is never enabled when this fn is called, so don't worry
12817    about it.  */
12818
12819 ffesymbol
12820 ffecom_sym_end_transition (ffesymbol s)
12821 {
12822   ffestorag st;
12823
12824   assert (!ffesymbol_retractable ());
12825
12826   s = ffest_sym_end_transition (s);
12827
12828   if ((ffesymbol_kind (s) == FFEINFO_kindBLOCKDATA)
12829       && (ffesymbol_where (s) == FFEINFO_whereGLOBAL))
12830     {
12831       ffecom_list_blockdata_
12832         = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
12833                                               FFEINTRIN_specNONE,
12834                                               FFEINTRIN_impNONE),
12835                            ffecom_list_blockdata_);
12836     }
12837
12838   /* This is where we finally notice that a symbol has partial initialization
12839      and finalize it. */
12840
12841   if (ffesymbol_accretion (s) != NULL)
12842     {
12843       assert (ffesymbol_init (s) == NULL);
12844       ffecom_notify_init_symbol (s);
12845     }
12846   else if (((st = ffesymbol_storage (s)) != NULL)
12847            && ((st = ffestorag_parent (st)) != NULL)
12848            && (ffestorag_accretion (st) != NULL))
12849     {
12850       assert (ffestorag_init (st) == NULL);
12851       ffecom_notify_init_storage (st);
12852     }
12853
12854   if ((ffesymbol_kind (s) == FFEINFO_kindCOMMON)
12855       && (ffesymbol_where (s) == FFEINFO_whereLOCAL)
12856       && (ffesymbol_storage (s) != NULL))
12857     {
12858       ffecom_list_common_
12859         = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
12860                                               FFEINTRIN_specNONE,
12861                                               FFEINTRIN_impNONE),
12862                            ffecom_list_common_);
12863     }
12864
12865   return s;
12866 }
12867
12868 /* ffecom_sym_exec_transition -- Perform exec transition on all symbols
12869
12870    ffecom_sym_exec_transition();
12871
12872    Does backend-specific stuff and also calls ffest_sym_exec_transition
12873    to do the necessary FFE stuff.
12874
12875    See the long-winded description in ffecom_sym_learned for info
12876    on handling the situation where backtracking is inhibited.  */
12877
12878 ffesymbol
12879 ffecom_sym_exec_transition (ffesymbol s)
12880 {
12881   s = ffest_sym_exec_transition (s);
12882
12883   return s;
12884 }
12885
12886 /* ffecom_sym_learned -- Initial or more info gained on symbol after exec
12887
12888    ffesymbol s;
12889    s = ffecom_sym_learned(s);
12890
12891    Called when a new symbol is seen after the exec transition or when more
12892    info (perhaps) is gained for an UNCERTAIN symbol.  The symbol state when
12893    it arrives here is that all its latest info is updated already, so its
12894    state may be UNCERTAIN or UNDERSTOOD, it might already have the hook
12895    field filled in if its gone through here or exec_transition first, and
12896    so on.
12897
12898    The backend probably wants to check ffesymbol_retractable() to see if
12899    backtracking is in effect.  If so, the FFE's changes to the symbol may
12900    be retracted (undone) or committed (ratified), at which time the
12901    appropriate ffecom_sym_retract or _commit function will be called
12902    for that function.
12903
12904    If the backend has its own backtracking mechanism, great, use it so that
12905    committal is a simple operation.  Though it doesn't make much difference,
12906    I suppose: the reason for tentative symbol evolution in the FFE is to
12907    enable error detection in weird incorrect statements early and to disable
12908    incorrect error detection on a correct statement.  The backend is not
12909    likely to introduce any information that'll get involved in these
12910    considerations, so it is probably just fine that the implementation
12911    model for this fn and for _exec_transition is to not do anything
12912    (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE
12913    and instead wait until ffecom_sym_commit is called (which it never
12914    will be as long as we're using ambiguity-detecting statement analysis in
12915    the FFE, which we are initially to shake out the code, but don't depend
12916    on this), otherwise go ahead and do whatever is needed.
12917
12918    In essence, then, when this fn and _exec_transition get called while
12919    backtracking is enabled, a general mechanism would be to flag which (or
12920    both) of these were called (and in what order? neat question as to what
12921    might happen that I'm too lame to think through right now) and then when
12922    _commit is called reproduce the original calling sequence, if any, for
12923    the two fns (at which point backtracking will, of course, be disabled).  */
12924
12925 ffesymbol
12926 ffecom_sym_learned (ffesymbol s)
12927 {
12928   ffestorag_exec_layout (s);
12929
12930   return s;
12931 }
12932
12933 /* ffecom_sym_retract -- Symbol's state being retracted from reality
12934
12935    ffesymbol s;
12936    ffecom_sym_retract(s);
12937
12938    Does whatever the backend needs when a symbol is retracted after having
12939    been backtrackable for a period of time.  */
12940
12941 void
12942 ffecom_sym_retract (ffesymbol s UNUSED)
12943 {
12944   assert (!ffesymbol_retractable ());
12945
12946 #if 0                           /* GCC doesn't commit any backtrackable sins,
12947                                    so nothing needed here. */
12948   switch (ffesymbol_hook (s).state)
12949     {
12950     case 0:                     /* nothing happened yet. */
12951       break;
12952
12953     case 1:                     /* exec transition happened. */
12954       break;
12955
12956     case 2:                     /* learned happened. */
12957       break;
12958
12959     case 3:                     /* learned then exec. */
12960       break;
12961
12962     case 4:                     /* exec then learned. */
12963       break;
12964
12965     default:
12966       assert ("bad hook state" == NULL);
12967       break;
12968     }
12969 #endif
12970 }
12971
12972 /* Create temporary gcc label.  */
12973
12974 tree
12975 ffecom_temp_label (void)
12976 {
12977   tree glabel;
12978   static int mynumber = 0;
12979
12980   glabel = build_decl (LABEL_DECL,
12981                        ffecom_get_invented_identifier ("__g77_label_%d",
12982                                                        mynumber++),
12983                        void_type_node);
12984   DECL_CONTEXT (glabel) = current_function_decl;
12985   DECL_MODE (glabel) = VOIDmode;
12986
12987   return glabel;
12988 }
12989
12990 /* Return an expression that is usable as an arg in a conditional context
12991    (IF, DO WHILE, .NOT., and so on).
12992
12993    Use the one provided for the back end as of >2.6.0.  */
12994
12995 tree
12996 ffecom_truth_value (tree expr)
12997 {
12998   return ffe_truthvalue_conversion (expr);
12999 }
13000
13001 /* Return the inversion of a truth value (the inversion of what
13002    ffecom_truth_value builds).
13003
13004    Apparently invert_truthvalue, which is properly in the back end, is
13005    enough for now, so just use it.  */
13006
13007 tree
13008 ffecom_truth_value_invert (tree expr)
13009 {
13010   return invert_truthvalue (ffecom_truth_value (expr));
13011 }
13012
13013 /* Return the tree that is the type of the expression, as would be
13014    returned in TREE_TYPE(ffecom_expr(expr)), without otherwise
13015    transforming the expression, generating temporaries, etc.  */
13016
13017 tree
13018 ffecom_type_expr (ffebld expr)
13019 {
13020   ffeinfoBasictype bt;
13021   ffeinfoKindtype kt;
13022   tree tree_type;
13023
13024   assert (expr != NULL);
13025
13026   bt = ffeinfo_basictype (ffebld_info (expr));
13027   kt = ffeinfo_kindtype (ffebld_info (expr));
13028   tree_type = ffecom_tree_type[bt][kt];
13029
13030   switch (ffebld_op (expr))
13031     {
13032     case FFEBLD_opCONTER:
13033     case FFEBLD_opSYMTER:
13034     case FFEBLD_opARRAYREF:
13035     case FFEBLD_opUPLUS:
13036     case FFEBLD_opPAREN:
13037     case FFEBLD_opUMINUS:
13038     case FFEBLD_opADD:
13039     case FFEBLD_opSUBTRACT:
13040     case FFEBLD_opMULTIPLY:
13041     case FFEBLD_opDIVIDE:
13042     case FFEBLD_opPOWER:
13043     case FFEBLD_opNOT:
13044     case FFEBLD_opFUNCREF:
13045     case FFEBLD_opSUBRREF:
13046     case FFEBLD_opAND:
13047     case FFEBLD_opOR:
13048     case FFEBLD_opXOR:
13049     case FFEBLD_opNEQV:
13050     case FFEBLD_opEQV:
13051     case FFEBLD_opCONVERT:
13052     case FFEBLD_opLT:
13053     case FFEBLD_opLE:
13054     case FFEBLD_opEQ:
13055     case FFEBLD_opNE:
13056     case FFEBLD_opGT:
13057     case FFEBLD_opGE:
13058     case FFEBLD_opPERCENT_LOC:
13059       return tree_type;
13060
13061     case FFEBLD_opACCTER:
13062     case FFEBLD_opARRTER:
13063     case FFEBLD_opITEM:
13064     case FFEBLD_opSTAR:
13065     case FFEBLD_opBOUNDS:
13066     case FFEBLD_opREPEAT:
13067     case FFEBLD_opLABTER:
13068     case FFEBLD_opLABTOK:
13069     case FFEBLD_opIMPDO:
13070     case FFEBLD_opCONCATENATE:
13071     case FFEBLD_opSUBSTR:
13072     default:
13073       assert ("bad op for ffecom_type_expr" == NULL);
13074       /* Fall through. */
13075     case FFEBLD_opANY:
13076       return error_mark_node;
13077     }
13078 }
13079
13080 /* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points
13081
13082    If the PARM_DECL already exists, return it, else create it.  It's an
13083    integer_type_node argument for the master function that implements a
13084    subroutine or function with more than one entrypoint and is bound at
13085    run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for
13086    first ENTRY statement, and so on).  */
13087
13088 tree
13089 ffecom_which_entrypoint_decl (void)
13090 {
13091   assert (ffecom_which_entrypoint_decl_ != NULL_TREE);
13092
13093   return ffecom_which_entrypoint_decl_;
13094 }
13095 \f
13096 /* The following sections consists of private and public functions
13097    that have the same names and perform roughly the same functions
13098    as counterparts in the C front end.  Changes in the C front end
13099    might affect how things should be done here.  Only functions
13100    needed by the back end should be public here; the rest should
13101    be private (static in the C sense).  Functions needed by other
13102    g77 front-end modules should be accessed by them via public
13103    ffecom_* names, which should themselves call private versions
13104    in this section so the private versions are easy to recognize
13105    when upgrading to a new gcc and finding interesting changes
13106    in the front end.
13107
13108    Functions named after rule "foo:" in c-parse.y are named
13109    "bison_rule_foo_" so they are easy to find.  */
13110
13111 static void
13112 bison_rule_pushlevel_ (void)
13113 {
13114   emit_line_note (input_location);
13115   pushlevel (0);
13116   clear_last_expr ();
13117   expand_start_bindings (0);
13118 }
13119
13120 static tree
13121 bison_rule_compstmt_ (void)
13122 {
13123   tree t;
13124   int keep = kept_level_p ();
13125
13126   /* Make the temps go away.  */
13127   if (! keep)
13128     current_binding_level->names = NULL_TREE;
13129
13130   emit_line_note (input_location);
13131   expand_end_bindings (getdecls (), keep, 0);
13132   t = poplevel (keep, 1, 0);
13133
13134   return t;
13135 }
13136
13137 /* Return a definition for a builtin function named NAME and whose data type
13138    is TYPE.  TYPE should be a function type with argument types.
13139    FUNCTION_CODE tells later passes how to compile calls to this function.
13140    See tree.h for its possible values.
13141
13142    If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
13143    the name to be called if we can't opencode the function.  If
13144    ATTRS is nonzero, use that for the function's attribute list.  */
13145
13146 tree
13147 builtin_function (const char *name, tree type, int function_code,
13148                   enum built_in_class class, const char *library_name,
13149                   tree attrs ATTRIBUTE_UNUSED)
13150 {
13151   tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type);
13152   DECL_EXTERNAL (decl) = 1;
13153   TREE_PUBLIC (decl) = 1;
13154   if (library_name)
13155     SET_DECL_ASSEMBLER_NAME (decl, get_identifier (library_name));
13156   make_decl_rtl (decl, NULL);
13157   pushdecl (decl);
13158   DECL_BUILT_IN_CLASS (decl) = class;
13159   DECL_FUNCTION_CODE (decl) = function_code;
13160
13161   return decl;
13162 }
13163
13164 /* Handle when a new declaration NEWDECL
13165    has the same name as an old one OLDDECL
13166    in the same binding contour.
13167    Prints an error message if appropriate.
13168
13169    If safely possible, alter OLDDECL to look like NEWDECL, and return 1.
13170    Otherwise, return 0.  */
13171
13172 static int
13173 duplicate_decls (tree newdecl, tree olddecl)
13174 {
13175   int types_match = 1;
13176   int new_is_definition = (TREE_CODE (newdecl) == FUNCTION_DECL
13177                            && DECL_INITIAL (newdecl) != 0);
13178   tree oldtype = TREE_TYPE (olddecl);
13179   tree newtype = TREE_TYPE (newdecl);
13180
13181   if (olddecl == newdecl)
13182     return 1;
13183
13184   if (TREE_CODE (newtype) == ERROR_MARK
13185       || TREE_CODE (oldtype) == ERROR_MARK)
13186     types_match = 0;
13187
13188   /* New decl is completely inconsistent with the old one =>
13189      tell caller to replace the old one.
13190      This is always an error except in the case of shadowing a builtin.  */
13191   if (TREE_CODE (olddecl) != TREE_CODE (newdecl))
13192     return 0;
13193
13194   /* For real parm decl following a forward decl,
13195      return 1 so old decl will be reused.  */
13196   if (types_match && TREE_CODE (newdecl) == PARM_DECL
13197       && TREE_ASM_WRITTEN (olddecl) && ! TREE_ASM_WRITTEN (newdecl))
13198     return 1;
13199
13200   /* The new declaration is the same kind of object as the old one.
13201      The declarations may partially match.  Print warnings if they don't
13202      match enough.  Ultimately, copy most of the information from the new
13203      decl to the old one, and keep using the old one.  */
13204
13205   if (TREE_CODE (olddecl) == FUNCTION_DECL
13206       && DECL_BUILT_IN (olddecl))
13207     {
13208       /* A function declaration for a built-in function.  */
13209       if (!TREE_PUBLIC (newdecl))
13210         return 0;
13211       else if (!types_match)
13212         {
13213           /* Accept the return type of the new declaration if same modes.  */
13214           tree oldreturntype = TREE_TYPE (TREE_TYPE (olddecl));
13215           tree newreturntype = TREE_TYPE (TREE_TYPE (newdecl));
13216
13217           if (TYPE_MODE (oldreturntype) == TYPE_MODE (newreturntype))
13218             {
13219               /* Function types may be shared, so we can't just modify
13220                  the return type of olddecl's function type.  */
13221               tree newtype
13222                 = build_function_type (newreturntype,
13223                                        TYPE_ARG_TYPES (TREE_TYPE (olddecl)));
13224
13225               types_match = 1;
13226               if (types_match)
13227                 TREE_TYPE (olddecl) = newtype;
13228             }
13229         }
13230       if (!types_match)
13231         return 0;
13232     }
13233   else if (TREE_CODE (olddecl) == FUNCTION_DECL
13234            && DECL_SOURCE_LINE (olddecl) == 0)
13235     {
13236       /* A function declaration for a predeclared function
13237          that isn't actually built in.  */
13238       if (!TREE_PUBLIC (newdecl))
13239         return 0;
13240       else if (!types_match)
13241         {
13242           /* If the types don't match, preserve volatility indication.
13243              Later on, we will discard everything else about the
13244              default declaration.  */
13245           TREE_THIS_VOLATILE (newdecl) |= TREE_THIS_VOLATILE (olddecl);
13246         }
13247     }
13248
13249   /* Copy all the DECL_... slots specified in the new decl
13250      except for any that we copy here from the old type.
13251
13252      Past this point, we don't change OLDTYPE and NEWTYPE
13253      even if we change the types of NEWDECL and OLDDECL.  */
13254
13255   if (types_match)
13256     {
13257       /* Merge the data types specified in the two decls.  */
13258       if (TREE_CODE (newdecl) != FUNCTION_DECL || !DECL_BUILT_IN (olddecl))
13259         TREE_TYPE (newdecl)
13260           = TREE_TYPE (olddecl)
13261             = TREE_TYPE (newdecl);
13262
13263       /* Lay the type out, unless already done.  */
13264       if (oldtype != TREE_TYPE (newdecl))
13265         {
13266           if (TREE_TYPE (newdecl) != error_mark_node)
13267             layout_type (TREE_TYPE (newdecl));
13268           if (TREE_CODE (newdecl) != FUNCTION_DECL
13269               && TREE_CODE (newdecl) != TYPE_DECL
13270               && TREE_CODE (newdecl) != CONST_DECL)
13271             layout_decl (newdecl, 0);
13272         }
13273       else
13274         {
13275           /* Since the type is OLDDECL's, make OLDDECL's size go with.  */
13276           DECL_SIZE (newdecl) = DECL_SIZE (olddecl);
13277           DECL_SIZE_UNIT (newdecl) = DECL_SIZE_UNIT (olddecl);
13278           if (TREE_CODE (olddecl) != FUNCTION_DECL)
13279             if (DECL_ALIGN (olddecl) > DECL_ALIGN (newdecl))
13280               {
13281                 DECL_ALIGN (newdecl) = DECL_ALIGN (olddecl);
13282                 DECL_USER_ALIGN (newdecl) |= DECL_USER_ALIGN (olddecl);
13283               }
13284         }
13285
13286       /* Keep the old rtl since we can safely use it.  */
13287       COPY_DECL_RTL (olddecl, newdecl);
13288
13289       /* Merge the type qualifiers.  */
13290       if (TREE_READONLY (newdecl))
13291         TREE_READONLY (olddecl) = 1;
13292       if (TREE_THIS_VOLATILE (newdecl))
13293         {
13294           TREE_THIS_VOLATILE (olddecl) = 1;
13295           if (TREE_CODE (newdecl) == VAR_DECL)
13296             make_var_volatile (newdecl);
13297         }
13298
13299       /* Keep source location of definition rather than declaration.
13300          Likewise, keep decl at outer scope.  */
13301       if ((DECL_INITIAL (newdecl) == 0 && DECL_INITIAL (olddecl) != 0)
13302           || (DECL_CONTEXT (newdecl) != 0 && DECL_CONTEXT (olddecl) == 0))
13303         {
13304           DECL_SOURCE_LOCATION (newdecl) = DECL_SOURCE_LOCATION (olddecl);
13305
13306           if (DECL_CONTEXT (olddecl) == 0
13307               && TREE_CODE (newdecl) != FUNCTION_DECL)
13308             DECL_CONTEXT (newdecl) = 0;
13309         }
13310
13311       /* Merge the unused-warning information.  */
13312       if (DECL_IN_SYSTEM_HEADER (olddecl))
13313         DECL_IN_SYSTEM_HEADER (newdecl) = 1;
13314       else if (DECL_IN_SYSTEM_HEADER (newdecl))
13315         DECL_IN_SYSTEM_HEADER (olddecl) = 1;
13316
13317       /* Merge the initialization information.  */
13318       if (DECL_INITIAL (newdecl) == 0)
13319         DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13320
13321       /* Merge the section attribute.
13322          We want to issue an error if the sections conflict but that must be
13323          done later in decl_attributes since we are called before attributes
13324          are assigned.  */
13325       if (DECL_SECTION_NAME (newdecl) == NULL_TREE)
13326         DECL_SECTION_NAME (newdecl) = DECL_SECTION_NAME (olddecl);
13327
13328       /* Copy the assembler name.  */
13329       COPY_DECL_ASSEMBLER_NAME (olddecl, newdecl);
13330
13331       if (TREE_CODE (newdecl) == FUNCTION_DECL)
13332         {
13333           DECL_STATIC_CONSTRUCTOR(newdecl) |= DECL_STATIC_CONSTRUCTOR(olddecl);
13334           DECL_STATIC_DESTRUCTOR (newdecl) |= DECL_STATIC_DESTRUCTOR (olddecl);
13335           TREE_THIS_VOLATILE (newdecl) |= TREE_THIS_VOLATILE (olddecl);
13336           TREE_READONLY (newdecl) |= TREE_READONLY (olddecl);
13337           DECL_IS_MALLOC (newdecl) |= DECL_IS_MALLOC (olddecl);
13338           DECL_IS_PURE (newdecl) |= DECL_IS_PURE (olddecl);
13339         }
13340     }
13341   /* If cannot merge, then use the new type and qualifiers,
13342      and don't preserve the old rtl.  */
13343   else
13344     {
13345       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13346       TREE_READONLY (olddecl) = TREE_READONLY (newdecl);
13347       TREE_THIS_VOLATILE (olddecl) = TREE_THIS_VOLATILE (newdecl);
13348       TREE_SIDE_EFFECTS (olddecl) = TREE_SIDE_EFFECTS (newdecl);
13349     }
13350
13351   /* Merge the storage class information.  */
13352   /* For functions, static overrides non-static.  */
13353   if (TREE_CODE (newdecl) == FUNCTION_DECL)
13354     {
13355       TREE_PUBLIC (newdecl) &= TREE_PUBLIC (olddecl);
13356       /* This is since we don't automatically
13357          copy the attributes of NEWDECL into OLDDECL.  */
13358       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13359       /* If this clears `static', clear it in the identifier too.  */
13360       if (! TREE_PUBLIC (olddecl))
13361         TREE_PUBLIC (DECL_NAME (olddecl)) = 0;
13362     }
13363   if (DECL_EXTERNAL (newdecl))
13364     {
13365       TREE_STATIC (newdecl) = TREE_STATIC (olddecl);
13366       DECL_EXTERNAL (newdecl) = DECL_EXTERNAL (olddecl);
13367       /* An extern decl does not override previous storage class.  */
13368       TREE_PUBLIC (newdecl) = TREE_PUBLIC (olddecl);
13369     }
13370   else
13371     {
13372       TREE_STATIC (olddecl) = TREE_STATIC (newdecl);
13373       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13374     }
13375
13376   /* If either decl says `inline', this fn is inline,
13377      unless its definition was passed already.  */
13378   if (DECL_INLINE (newdecl) && DECL_INITIAL (olddecl) == 0)
13379     DECL_INLINE (olddecl) = 1;
13380   DECL_INLINE (newdecl) = DECL_INLINE (olddecl);
13381
13382   /* Get rid of any built-in function if new arg types don't match it
13383      or if we have a function definition.  */
13384   if (TREE_CODE (newdecl) == FUNCTION_DECL
13385       && DECL_BUILT_IN (olddecl)
13386       && (!types_match || new_is_definition))
13387     {
13388       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13389       DECL_BUILT_IN_CLASS (olddecl) = NOT_BUILT_IN;
13390     }
13391
13392   /* If redeclaring a builtin function, and not a definition,
13393      it stays built in.
13394      Also preserve various other info from the definition.  */
13395   if (TREE_CODE (newdecl) == FUNCTION_DECL && !new_is_definition)
13396     {
13397       if (DECL_BUILT_IN (olddecl))
13398         {
13399           DECL_BUILT_IN_CLASS (newdecl) = DECL_BUILT_IN_CLASS (olddecl);
13400           DECL_FUNCTION_CODE (newdecl) = DECL_FUNCTION_CODE (olddecl);
13401         }
13402
13403       DECL_RESULT (newdecl) = DECL_RESULT (olddecl);
13404       DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13405       DECL_SAVED_INSNS (newdecl) = DECL_SAVED_INSNS (olddecl);
13406       DECL_ARGUMENTS (newdecl) = DECL_ARGUMENTS (olddecl);
13407     }
13408
13409   /* Copy most of the decl-specific fields of NEWDECL into OLDDECL.
13410      But preserve olddecl's DECL_UID.  */
13411   {
13412     register unsigned olddecl_uid = DECL_UID (olddecl);
13413
13414     memcpy ((char *) olddecl + sizeof (struct tree_common),
13415             (char *) newdecl + sizeof (struct tree_common),
13416             sizeof (struct tree_decl) - sizeof (struct tree_common));
13417     DECL_UID (olddecl) = olddecl_uid;
13418   }
13419
13420   return 1;
13421 }
13422
13423 /* Finish processing of a declaration;
13424    install its initial value.
13425    If the length of an array type is not known before,
13426    it must be determined now, from the initial value, or it is an error.  */
13427
13428 static void
13429 finish_decl (tree decl, tree init, bool is_top_level)
13430 {
13431   register tree type = TREE_TYPE (decl);
13432   int was_incomplete = (DECL_SIZE (decl) == 0);
13433   bool at_top_level = (current_binding_level == global_binding_level);
13434   bool top_level = is_top_level || at_top_level;
13435
13436   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13437      level anyway.  */
13438   assert (!is_top_level || !at_top_level);
13439
13440   if (TREE_CODE (decl) == PARM_DECL)
13441     assert (init == NULL_TREE);
13442   /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it
13443      overlaps DECL_ARG_TYPE.  */
13444   else if (init == NULL_TREE)
13445     assert (DECL_INITIAL (decl) == NULL_TREE);
13446   else
13447     assert (DECL_INITIAL (decl) == error_mark_node);
13448
13449   if (init != NULL_TREE)
13450     {
13451       if (TREE_CODE (decl) != TYPE_DECL)
13452         DECL_INITIAL (decl) = init;
13453       else
13454         {
13455           /* typedef foo = bar; store the type of bar as the type of foo.  */
13456           TREE_TYPE (decl) = TREE_TYPE (init);
13457           DECL_INITIAL (decl) = init = 0;
13458         }
13459     }
13460
13461   /* Deduce size of array from initialization, if not already known */
13462
13463   if (TREE_CODE (type) == ARRAY_TYPE
13464       && TYPE_DOMAIN (type) == 0
13465       && TREE_CODE (decl) != TYPE_DECL)
13466     {
13467       assert (top_level);
13468       assert (was_incomplete);
13469
13470       layout_decl (decl, 0);
13471     }
13472
13473   if (TREE_CODE (decl) == VAR_DECL)
13474     {
13475       if (DECL_SIZE (decl) == NULL_TREE
13476           && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
13477         layout_decl (decl, 0);
13478
13479       if (DECL_SIZE (decl) == NULL_TREE
13480           && (TREE_STATIC (decl)
13481               ?
13482       /* A static variable with an incomplete type is an error if it is
13483          initialized. Also if it is not file scope. Otherwise, let it
13484          through, but if it is not `extern' then it may cause an error
13485          message later.  */
13486               (DECL_INITIAL (decl) != 0 || DECL_CONTEXT (decl) != 0)
13487               :
13488       /* An automatic variable with an incomplete type is an error.  */
13489               !DECL_EXTERNAL (decl)))
13490         {
13491           assert ("storage size not known" == NULL);
13492           abort ();
13493         }
13494
13495       if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl))
13496           && (DECL_SIZE (decl) != 0)
13497           && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST))
13498         {
13499           assert ("storage size not constant" == NULL);
13500           abort ();
13501         }
13502     }
13503
13504   /* Output the assembler code and/or RTL code for variables and functions,
13505      unless the type is an undefined structure or union. If not, it will get
13506      done when the type is completed.  */
13507
13508   if (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == FUNCTION_DECL)
13509     {
13510       rest_of_decl_compilation (decl, NULL,
13511                                 DECL_CONTEXT (decl) == 0,
13512                                 0);
13513
13514       if (DECL_CONTEXT (decl) != 0)
13515         {
13516           /* Recompute the RTL of a local array now if it used to be an
13517              incomplete type.  */
13518           if (was_incomplete
13519               && !TREE_STATIC (decl) && !DECL_EXTERNAL (decl))
13520             {
13521               /* If we used it already as memory, it must stay in memory.  */
13522               TREE_ADDRESSABLE (decl) = TREE_USED (decl);
13523               /* If it's still incomplete now, no init will save it.  */
13524               if (DECL_SIZE (decl) == 0)
13525                 DECL_INITIAL (decl) = 0;
13526               expand_decl (decl);
13527             }
13528           /* Compute and store the initial value.  */
13529           if (TREE_CODE (decl) != FUNCTION_DECL)
13530             expand_decl_init (decl);
13531         }
13532     }
13533   else if (TREE_CODE (decl) == TYPE_DECL)
13534     {
13535       rest_of_decl_compilation (decl, NULL,
13536                                 DECL_CONTEXT (decl) == 0,
13537                                 0);
13538     }
13539
13540   /* At the end of a declaration, throw away any variable type sizes of types
13541      defined inside that declaration.  There is no use computing them in the
13542      following function definition.  */
13543   if (current_binding_level == global_binding_level)
13544     get_pending_sizes ();
13545 }
13546
13547 /* Finish up a function declaration and compile that function
13548    all the way to assembler language output.  The free the storage
13549    for the function definition.
13550
13551    This is called after parsing the body of the function definition.
13552
13553    NESTED is nonzero if the function being finished is nested in another.  */
13554
13555 static void
13556 finish_function (int nested)
13557 {
13558   register tree fndecl = current_function_decl;
13559
13560   assert (fndecl != NULL_TREE);
13561   if (TREE_CODE (fndecl) != ERROR_MARK)
13562     {
13563       if (nested)
13564         assert (DECL_CONTEXT (fndecl) != NULL_TREE);
13565       else
13566         assert (DECL_CONTEXT (fndecl) == NULL_TREE);
13567     }
13568
13569 /*  TREE_READONLY (fndecl) = 1;
13570     This caused &foo to be of type ptr-to-const-function
13571     which then got a warning when stored in a ptr-to-function variable.  */
13572
13573   poplevel (1, 0, 1);
13574
13575   if (TREE_CODE (fndecl) != ERROR_MARK)
13576     {
13577       BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
13578
13579       /* Must mark the RESULT_DECL as being in this function.  */
13580
13581       DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl;
13582
13583       /* Obey `register' declarations if `setjmp' is called in this fn.  */
13584       /* Generate rtl for function exit.  */
13585       expand_function_end ();
13586
13587       /* If this is a nested function, protect the local variables in the stack
13588          above us from being collected while we're compiling this function.  */
13589       if (nested)
13590         ggc_push_context ();
13591
13592       /* Run the optimizers and output the assembler code for this function.  */
13593       rest_of_compilation (fndecl);
13594
13595       /* Undo the GC context switch.  */
13596       if (nested)
13597         ggc_pop_context ();
13598     }
13599
13600   if (TREE_CODE (fndecl) != ERROR_MARK
13601       && !nested
13602       && DECL_SAVED_INSNS (fndecl) == 0)
13603     {
13604       /* Stop pointing to the local nodes about to be freed.  */
13605       /* But DECL_INITIAL must remain nonzero so we know this was an actual
13606          function definition.  */
13607       /* For a nested function, this is done in pop_f_function_context.  */
13608       /* If rest_of_compilation set this to 0, leave it 0.  */
13609       if (DECL_INITIAL (fndecl) != 0)
13610         DECL_INITIAL (fndecl) = error_mark_node;
13611       DECL_ARGUMENTS (fndecl) = 0;
13612     }
13613
13614   if (!nested)
13615     {
13616       /* Let the error reporting routines know that we're outside a function.
13617          For a nested function, this value is used in pop_c_function_context
13618          and then reset via pop_function_context.  */
13619       ffecom_outer_function_decl_ = current_function_decl = NULL;
13620     }
13621 }
13622
13623 /* Plug-in replacement for identifying the name of a decl and, for a
13624    function, what we call it in diagnostics.  For now, "program unit"
13625    should suffice, since it's a bit of a hassle to figure out which
13626    of several kinds of things it is.  Note that it could conceivably
13627    be a statement function, which probably isn't really a program unit
13628    per se, but if that comes up, it should be easy to check (being a
13629    nested function and all).  */
13630
13631 static const char *
13632 ffe_printable_name (tree decl, int v)
13633 {
13634   /* Just to keep GCC quiet about the unused variable.
13635      In theory, differing values of V should produce different
13636      output.  */
13637   switch (v)
13638     {
13639     default:
13640       if (TREE_CODE (decl) == ERROR_MARK)
13641         return "erroneous code";
13642       return IDENTIFIER_POINTER (DECL_NAME (decl));
13643     }
13644 }
13645
13646 /* g77's function to print out name of current function that caused
13647    an error.  */
13648
13649 static void
13650 ffe_print_error_function (diagnostic_context *context __attribute__((unused)),
13651                           const char *file)
13652 {
13653   static ffeglobal last_g = NULL;
13654   static ffesymbol last_s = NULL;
13655   ffeglobal g;
13656   ffesymbol s;
13657   const char *kind;
13658
13659   if ((ffecom_primary_entry_ == NULL)
13660       || (ffesymbol_global (ffecom_primary_entry_) == NULL))
13661     {
13662       g = NULL;
13663       s = NULL;
13664       kind = NULL;
13665     }
13666   else
13667     {
13668       g = ffesymbol_global (ffecom_primary_entry_);
13669       if (ffecom_nested_entry_ == NULL)
13670         {
13671           s = ffecom_primary_entry_;
13672           kind = _(ffeinfo_kind_message (ffesymbol_kind (s)));
13673         }
13674       else
13675         {
13676           s = ffecom_nested_entry_;
13677           kind = _("In statement function");
13678         }
13679     }
13680
13681   if ((last_g != g) || (last_s != s))
13682     {
13683       if (file)
13684         fprintf (stderr, "%s: ", file);
13685
13686       if (s == NULL)
13687         fprintf (stderr, _("Outside of any program unit:\n"));
13688       else
13689         {
13690           const char *name = ffesymbol_text (s);
13691
13692           fprintf (stderr, "%s `%s':\n", kind, name);
13693         }
13694
13695       last_g = g;
13696       last_s = s;
13697     }
13698 }
13699
13700 /* Similar to `lookup_name' but look only at current binding level.  */
13701
13702 static tree
13703 lookup_name_current_level (tree name)
13704 {
13705   register tree t;
13706
13707   if (current_binding_level == global_binding_level)
13708     return IDENTIFIER_GLOBAL_VALUE (name);
13709
13710   if (IDENTIFIER_LOCAL_VALUE (name) == 0)
13711     return 0;
13712
13713   for (t = current_binding_level->names; t; t = TREE_CHAIN (t))
13714     if (DECL_NAME (t) == name)
13715       break;
13716
13717   return t;
13718 }
13719
13720 /* Create a new `struct f_binding_level'.  */
13721
13722 static struct f_binding_level *
13723 make_binding_level (void)
13724 {
13725   /* NOSTRICT */
13726   return ggc_alloc (sizeof (struct f_binding_level));
13727 }
13728
13729 /* Save and restore the variables in this file and elsewhere
13730    that keep track of the progress of compilation of the current function.
13731    Used for nested functions.  */
13732
13733 struct f_function
13734 {
13735   struct f_function *next;
13736   tree named_labels;
13737   tree shadowed_labels;
13738   struct f_binding_level *binding_level;
13739 };
13740
13741 struct f_function *f_function_chain;
13742
13743 /* Restore the variables used during compilation of a C function.  */
13744
13745 static void
13746 pop_f_function_context (void)
13747 {
13748   struct f_function *p = f_function_chain;
13749   tree link;
13750
13751   /* Bring back all the labels that were shadowed.  */
13752   for (link = shadowed_labels; link; link = TREE_CHAIN (link))
13753     if (DECL_NAME (TREE_VALUE (link)) != 0)
13754       IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link)))
13755         = TREE_VALUE (link);
13756
13757   if (current_function_decl != error_mark_node
13758       && DECL_SAVED_INSNS (current_function_decl) == 0)
13759     {
13760       /* Stop pointing to the local nodes about to be freed.  */
13761       /* But DECL_INITIAL must remain nonzero so we know this was an actual
13762          function definition.  */
13763       DECL_INITIAL (current_function_decl) = error_mark_node;
13764       DECL_ARGUMENTS (current_function_decl) = 0;
13765     }
13766
13767   pop_function_context ();
13768
13769   f_function_chain = p->next;
13770
13771   named_labels = p->named_labels;
13772   shadowed_labels = p->shadowed_labels;
13773   current_binding_level = p->binding_level;
13774
13775   free (p);
13776 }
13777
13778 /* Save and reinitialize the variables
13779    used during compilation of a C function.  */
13780
13781 static void
13782 push_f_function_context (void)
13783 {
13784   struct f_function *p = xmalloc (sizeof (struct f_function));
13785
13786   push_function_context ();
13787
13788   p->next = f_function_chain;
13789   f_function_chain = p;
13790
13791   p->named_labels = named_labels;
13792   p->shadowed_labels = shadowed_labels;
13793   p->binding_level = current_binding_level;
13794 }
13795
13796 static void
13797 push_parm_decl (tree parm)
13798 {
13799   int old_immediate_size_expand = immediate_size_expand;
13800
13801   /* Don't try computing parm sizes now -- wait till fn is called.  */
13802
13803   immediate_size_expand = 0;
13804
13805   /* Fill in arg stuff.  */
13806
13807   DECL_ARG_TYPE (parm) = TREE_TYPE (parm);
13808   DECL_ARG_TYPE_AS_WRITTEN (parm) = TREE_TYPE (parm);
13809   TREE_READONLY (parm) = 1;     /* All implementation args are read-only. */
13810
13811   parm = pushdecl (parm);
13812
13813   immediate_size_expand = old_immediate_size_expand;
13814
13815   finish_decl (parm, NULL_TREE, FALSE);
13816 }
13817
13818 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate.  */
13819
13820 static tree
13821 pushdecl_top_level (tree x)
13822 {
13823   register tree t;
13824   register struct f_binding_level *b = current_binding_level;
13825   register tree f = current_function_decl;
13826
13827   current_binding_level = global_binding_level;
13828   current_function_decl = NULL_TREE;
13829   t = pushdecl (x);
13830   current_binding_level = b;
13831   current_function_decl = f;
13832   return t;
13833 }
13834
13835 /* Store the list of declarations of the current level.
13836    This is done for the parameter declarations of a function being defined,
13837    after they are modified in the light of any missing parameters.  */
13838
13839 static tree
13840 storedecls (tree decls)
13841 {
13842   return current_binding_level->names = decls;
13843 }
13844
13845 /* Store the parameter declarations into the current function declaration.
13846    This is called after parsing the parameter declarations, before
13847    digesting the body of the function.
13848
13849    For an old-style definition, modify the function's type
13850    to specify at least the number of arguments.  */
13851
13852 static void
13853 store_parm_decls (int is_main_program UNUSED)
13854 {
13855   register tree fndecl = current_function_decl;
13856
13857   if (fndecl == error_mark_node)
13858     return;
13859
13860   /* This is a chain of PARM_DECLs from old-style parm declarations.  */
13861   DECL_ARGUMENTS (fndecl) = storedecls (nreverse (getdecls ()));
13862
13863   /* Initialize the RTL code for the function.  */
13864   init_function_start (fndecl);
13865
13866   /* Set up parameters and prepare for return, for the function.  */
13867   expand_function_start (fndecl, 0);
13868 }
13869
13870 static tree
13871 start_decl (tree decl, bool is_top_level)
13872 {
13873   register tree tem;
13874   bool at_top_level = (current_binding_level == global_binding_level);
13875   bool top_level = is_top_level || at_top_level;
13876
13877   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13878      level anyway.  */
13879   assert (!is_top_level || !at_top_level);
13880
13881   if (DECL_INITIAL (decl) != NULL_TREE)
13882     {
13883       assert (DECL_INITIAL (decl) == error_mark_node);
13884       assert (!DECL_EXTERNAL (decl));
13885     }
13886   else if (top_level)
13887     assert ((TREE_STATIC (decl) == 1) || DECL_EXTERNAL (decl) == 1);
13888
13889   /* For Fortran, we by default put things in .common when possible.  */
13890   DECL_COMMON (decl) = 1;
13891
13892   /* Add this decl to the current binding level. TEM may equal DECL or it may
13893      be a previous decl of the same name.  */
13894   if (is_top_level)
13895     tem = pushdecl_top_level (decl);
13896   else
13897     tem = pushdecl (decl);
13898
13899   /* For a local variable, define the RTL now.  */
13900   if (!top_level
13901   /* But not if this is a duplicate decl and we preserved the rtl from the
13902      previous one (which may or may not happen).  */
13903       && !DECL_RTL_SET_P (tem))
13904     {
13905       if (TYPE_SIZE (TREE_TYPE (tem)) != 0)
13906         expand_decl (tem);
13907       else if (TREE_CODE (TREE_TYPE (tem)) == ARRAY_TYPE
13908                && DECL_INITIAL (tem) != 0)
13909         expand_decl (tem);
13910     }
13911
13912   return tem;
13913 }
13914
13915 /* Create the FUNCTION_DECL for a function definition.
13916    DECLSPECS and DECLARATOR are the parts of the declaration;
13917    they describe the function's name and the type it returns,
13918    but twisted together in a fashion that parallels the syntax of C.
13919
13920    This function creates a binding context for the function body
13921    as well as setting up the FUNCTION_DECL in current_function_decl.
13922
13923    Returns 1 on success.  If the DECLARATOR is not suitable for a function
13924    (it defines a datum instead), we return 0, which tells
13925    ffe_parse_file to report a parse error.
13926
13927    NESTED is nonzero for a function nested within another function.  */
13928
13929 static void
13930 start_function (tree name, tree type, int nested, int public)
13931 {
13932   tree decl1;
13933   tree restype;
13934   int old_immediate_size_expand = immediate_size_expand;
13935
13936   named_labels = 0;
13937   shadowed_labels = 0;
13938
13939   /* Don't expand any sizes in the return type of the function.  */
13940   immediate_size_expand = 0;
13941
13942   if (nested)
13943     {
13944       assert (!public);
13945       assert (current_function_decl != NULL_TREE);
13946       assert (DECL_CONTEXT (current_function_decl) == NULL_TREE);
13947     }
13948   else
13949     {
13950       assert (current_function_decl == NULL_TREE);
13951     }
13952
13953   if (TREE_CODE (type) == ERROR_MARK)
13954     decl1 = current_function_decl = error_mark_node;
13955   else
13956     {
13957       decl1 = build_decl (FUNCTION_DECL,
13958                           name,
13959                           type);
13960       TREE_PUBLIC (decl1) = public ? 1 : 0;
13961       if (nested)
13962         DECL_INLINE (decl1) = 1;
13963       TREE_STATIC (decl1) = 1;
13964       DECL_EXTERNAL (decl1) = 0;
13965
13966       announce_function (decl1);
13967
13968       /* Make the init_value nonzero so pushdecl knows this is not tentative.
13969          error_mark_node is replaced below (in poplevel) with the BLOCK.  */
13970       DECL_INITIAL (decl1) = error_mark_node;
13971
13972       /* Record the decl so that the function name is defined. If we already have
13973          a decl for this name, and it is a FUNCTION_DECL, use the old decl.  */
13974
13975       current_function_decl = pushdecl (decl1);
13976     }
13977
13978   if (!nested)
13979     ffecom_outer_function_decl_ = current_function_decl;
13980
13981   pushlevel (0);
13982   current_binding_level->prep_state = 2;
13983
13984   if (TREE_CODE (current_function_decl) != ERROR_MARK)
13985     {
13986       make_decl_rtl (current_function_decl, NULL);
13987
13988       restype = TREE_TYPE (TREE_TYPE (current_function_decl));
13989       DECL_RESULT (current_function_decl)
13990         = build_decl (RESULT_DECL, NULL_TREE, restype);
13991     }
13992
13993   if (!nested && (TREE_CODE (current_function_decl) != ERROR_MARK))
13994     TREE_ADDRESSABLE (current_function_decl) = 1;
13995
13996   immediate_size_expand = old_immediate_size_expand;
13997 }
13998 \f
13999 /* Here are the public functions the GNU back end needs.  */
14000
14001 tree
14002 convert (tree type, tree expr)
14003 {
14004   register tree e = expr;
14005   register enum tree_code code = TREE_CODE (type);
14006
14007   if (type == TREE_TYPE (e)
14008       || TREE_CODE (e) == ERROR_MARK)
14009     return e;
14010   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
14011     return fold (build1 (NOP_EXPR, type, e));
14012   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
14013       || code == ERROR_MARK)
14014     return error_mark_node;
14015   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
14016     {
14017       assert ("void value not ignored as it ought to be" == NULL);
14018       return error_mark_node;
14019     }
14020   if (code == VOID_TYPE)
14021     return build1 (CONVERT_EXPR, type, e);
14022   if ((code != RECORD_TYPE)
14023       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
14024     e = ffecom_1 (REALPART_EXPR, TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e))),
14025                   e);
14026   if (code == INTEGER_TYPE || code == ENUMERAL_TYPE)
14027     return fold (convert_to_integer (type, e));
14028   if (code == POINTER_TYPE)
14029     return fold (convert_to_pointer (type, e));
14030   if (code == REAL_TYPE)
14031     return fold (convert_to_real (type, e));
14032   if (code == COMPLEX_TYPE)
14033     return fold (convert_to_complex (type, e));
14034   if (code == RECORD_TYPE)
14035     return fold (ffecom_convert_to_complex_ (type, e));
14036
14037   assert ("conversion to non-scalar type requested" == NULL);
14038   return error_mark_node;
14039 }
14040
14041 /* Return the list of declarations of the current level.
14042    Note that this list is in reverse order unless/until
14043    you nreverse it; and when you do nreverse it, you must
14044    store the result back using `storedecls' or you will lose.  */
14045
14046 tree
14047 getdecls (void)
14048 {
14049   return current_binding_level->names;
14050 }
14051
14052 /* Nonzero if we are currently in the global binding level.  */
14053
14054 int
14055 global_bindings_p (void)
14056 {
14057   return current_binding_level == global_binding_level;
14058 }
14059
14060 static void
14061 ffecom_init_decl_processing (void)
14062 {
14063   malloc_init ();
14064
14065   ffe_init_0 ();
14066 }
14067
14068 /* Delete the node BLOCK from the current binding level.
14069    This is used for the block inside a stmt expr ({...})
14070    so that the block can be reinserted where appropriate.  */
14071
14072 static void
14073 delete_block (tree block)
14074 {
14075   tree t;
14076   if (current_binding_level->blocks == block)
14077     current_binding_level->blocks = TREE_CHAIN (block);
14078   for (t = current_binding_level->blocks; t;)
14079     {
14080       if (TREE_CHAIN (t) == block)
14081         TREE_CHAIN (t) = TREE_CHAIN (block);
14082       else
14083         t = TREE_CHAIN (t);
14084     }
14085   TREE_CHAIN (block) = NULL;
14086   /* Clear TREE_USED which is always set by poplevel.
14087      The flag is set again if insert_block is called.  */
14088   TREE_USED (block) = 0;
14089 }
14090
14091 void
14092 insert_block (tree block)
14093 {
14094   TREE_USED (block) = 1;
14095   current_binding_level->blocks
14096     = chainon (current_binding_level->blocks, block);
14097 }
14098
14099 /* Each front end provides its own.  */
14100 static bool ffe_init (void);
14101 static void ffe_finish (void);
14102 static bool ffe_post_options (const char **);
14103 static void ffe_print_identifier (FILE *, tree, int);
14104
14105 struct language_function GTY(())
14106 {
14107   int unused;
14108 };
14109
14110 #undef  LANG_HOOKS_NAME
14111 #define LANG_HOOKS_NAME                 "GNU F77"
14112 #undef  LANG_HOOKS_INIT
14113 #define LANG_HOOKS_INIT                 ffe_init
14114 #undef  LANG_HOOKS_FINISH
14115 #define LANG_HOOKS_FINISH               ffe_finish
14116 #undef  LANG_HOOKS_INIT_OPTIONS
14117 #define LANG_HOOKS_INIT_OPTIONS         ffe_init_options
14118 #undef  LANG_HOOKS_HANDLE_OPTION
14119 #define LANG_HOOKS_HANDLE_OPTION        ffe_handle_option
14120 #undef  LANG_HOOKS_POST_OPTIONS
14121 #define LANG_HOOKS_POST_OPTIONS         ffe_post_options
14122 #undef  LANG_HOOKS_PARSE_FILE
14123 #define LANG_HOOKS_PARSE_FILE           ffe_parse_file
14124 #undef  LANG_HOOKS_MARK_ADDRESSABLE
14125 #define LANG_HOOKS_MARK_ADDRESSABLE     ffe_mark_addressable
14126 #undef  LANG_HOOKS_PRINT_IDENTIFIER
14127 #define LANG_HOOKS_PRINT_IDENTIFIER     ffe_print_identifier
14128 #undef  LANG_HOOKS_DECL_PRINTABLE_NAME
14129 #define LANG_HOOKS_DECL_PRINTABLE_NAME  ffe_printable_name
14130 #undef  LANG_HOOKS_PRINT_ERROR_FUNCTION
14131 #define LANG_HOOKS_PRINT_ERROR_FUNCTION ffe_print_error_function
14132 #undef  LANG_HOOKS_TRUTHVALUE_CONVERSION
14133 #define LANG_HOOKS_TRUTHVALUE_CONVERSION ffe_truthvalue_conversion
14134
14135 #undef  LANG_HOOKS_TYPE_FOR_MODE
14136 #define LANG_HOOKS_TYPE_FOR_MODE        ffe_type_for_mode
14137 #undef  LANG_HOOKS_TYPE_FOR_SIZE
14138 #define LANG_HOOKS_TYPE_FOR_SIZE        ffe_type_for_size
14139 #undef  LANG_HOOKS_SIGNED_TYPE
14140 #define LANG_HOOKS_SIGNED_TYPE          ffe_signed_type
14141 #undef  LANG_HOOKS_UNSIGNED_TYPE
14142 #define LANG_HOOKS_UNSIGNED_TYPE        ffe_unsigned_type
14143 #undef  LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE
14144 #define LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE ffe_signed_or_unsigned_type
14145
14146 /* We do not wish to use alias-set based aliasing at all.  Used in the
14147    extreme (every object with its own set, with equivalences recorded) it
14148    might be helpful, but there are problems when it comes to inlining.  We
14149    get on ok with flag_argument_noalias, and alias-set aliasing does
14150    currently limit how stack slots can be reused, which is a lose.  */
14151 #undef LANG_HOOKS_GET_ALIAS_SET
14152 #define LANG_HOOKS_GET_ALIAS_SET hook_get_alias_set_0
14153
14154 const struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER;
14155
14156 /* Table indexed by tree code giving a string containing a character
14157    classifying the tree code.  Possibilities are
14158    t, d, s, c, r, <, 1, 2 and e.  See tree.def for details.  */
14159
14160 #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) TYPE,
14161
14162 const char tree_code_type[] = {
14163 #include "tree.def"
14164 };
14165 #undef DEFTREECODE
14166
14167 /* Table indexed by tree code giving number of expression
14168    operands beyond the fixed part of the node structure.
14169    Not used for types or decls.  */
14170
14171 #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) LENGTH,
14172
14173 const unsigned char tree_code_length[] = {
14174 #include "tree.def"
14175 };
14176 #undef DEFTREECODE
14177
14178 /* Names of tree components.
14179    Used for printing out the tree and error messages.  */
14180 #define DEFTREECODE(SYM, NAME, TYPE, LEN) NAME,
14181
14182 const char *const tree_code_name[] = {
14183 #include "tree.def"
14184 };
14185 #undef DEFTREECODE
14186
14187 static bool
14188 ffe_post_options (const char **pfilename)
14189 {
14190   const char *filename = *pfilename;
14191
14192   /* Open input file.  */
14193   if (filename == 0 || !strcmp (filename, "-"))
14194     {
14195       finput = stdin;
14196       filename = "stdin";
14197     }
14198   else
14199     finput = fopen (filename, "r");
14200
14201   if (finput == 0)
14202     fatal_error ("can't open %s: %m", filename);
14203
14204   return false;
14205 }
14206
14207
14208 static bool
14209 ffe_init (void)
14210 {
14211 #ifdef IO_BUFFER_SIZE
14212   setvbuf (finput, xmalloc (IO_BUFFER_SIZE), _IOFBF, IO_BUFFER_SIZE);
14213 #endif
14214
14215   ffecom_init_decl_processing ();
14216
14217   /* If the file is output from cpp, it should contain a first line
14218      `# 1 "real-filename"', and the current design of gcc (toplev.c
14219      in particular and the way it sets up information relied on by
14220      INCLUDE) requires that we read this now, and store the
14221      "real-filename" info in master_input_filename.  Ask the lexer
14222      to try doing this.  */
14223   ffelex_hash_kludge (finput);
14224
14225   push_srcloc (input_filename, 0);
14226
14227   /* FIXME: The ffelex_hash_kludge code needs to be cleaned up to
14228      set the new file name.  Maybe in ffe_post_options.  */
14229   return true;
14230 }
14231
14232 static void
14233 ffe_finish (void)
14234 {
14235   ffe_terminate_0 ();
14236
14237   if (ffe_is_ffedebug ())
14238     malloc_pool_display (malloc_pool_image ());
14239
14240   fclose (finput);
14241 }
14242
14243 static bool
14244 ffe_mark_addressable (tree exp)
14245 {
14246   register tree x = exp;
14247   while (1)
14248     switch (TREE_CODE (x))
14249       {
14250       case ADDR_EXPR:
14251       case COMPONENT_REF:
14252       case ARRAY_REF:
14253         x = TREE_OPERAND (x, 0);
14254         break;
14255
14256       case CONSTRUCTOR:
14257         TREE_ADDRESSABLE (x) = 1;
14258         return true;
14259
14260       case VAR_DECL:
14261       case CONST_DECL:
14262       case PARM_DECL:
14263       case RESULT_DECL:
14264         if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x)
14265             && DECL_NONLOCAL (x))
14266           {
14267             if (TREE_PUBLIC (x))
14268               {
14269                 assert ("address of global register var requested" == NULL);
14270                 return false;
14271               }
14272             assert ("address of register variable requested" == NULL);
14273           }
14274         else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x))
14275           {
14276             if (TREE_PUBLIC (x))
14277               {
14278                 assert ("address of global register var requested" == NULL);
14279                 return false;
14280               }
14281             assert ("address of register var requested" == NULL);
14282           }
14283         put_var_into_stack (x, /*rescan=*/true);
14284
14285         /* drops in */
14286       case FUNCTION_DECL:
14287         TREE_ADDRESSABLE (x) = 1;
14288 #if 0                           /* poplevel deals with this now.  */
14289         if (DECL_CONTEXT (x) == 0)
14290           TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x)) = 1;
14291 #endif
14292
14293       default:
14294         return true;
14295       }
14296 }
14297
14298 /* Exit a binding level.
14299    Pop the level off, and restore the state of the identifier-decl mappings
14300    that were in effect when this level was entered.
14301
14302    If KEEP is nonzero, this level had explicit declarations, so
14303    and create a "block" (a BLOCK node) for the level
14304    to record its declarations and subblocks for symbol table output.
14305
14306    If FUNCTIONBODY is nonzero, this level is the body of a function,
14307    so create a block as if KEEP were set and also clear out all
14308    label names.
14309
14310    If REVERSE is nonzero, reverse the order of decls before putting
14311    them into the BLOCK.  */
14312
14313 tree
14314 poplevel (int keep, int reverse, int functionbody)
14315 {
14316   register tree link;
14317   /* The chain of decls was accumulated in reverse order.
14318      Put it into forward order, just for cleanliness.  */
14319   tree decls;
14320   tree subblocks = current_binding_level->blocks;
14321   tree block = 0;
14322   tree decl;
14323   int block_previously_created;
14324
14325   /* Get the decls in the order they were written.
14326      Usually current_binding_level->names is in reverse order.
14327      But parameter decls were previously put in forward order.  */
14328
14329   if (reverse)
14330     current_binding_level->names
14331       = decls = nreverse (current_binding_level->names);
14332   else
14333     decls = current_binding_level->names;
14334
14335   /* Output any nested inline functions within this block
14336      if they weren't already output.  */
14337
14338   for (decl = decls; decl; decl = TREE_CHAIN (decl))
14339     if (TREE_CODE (decl) == FUNCTION_DECL
14340         && ! TREE_ASM_WRITTEN (decl)
14341         && DECL_INITIAL (decl) != 0
14342         && TREE_ADDRESSABLE (decl))
14343       {
14344         /* If this decl was copied from a file-scope decl
14345            on account of a block-scope extern decl,
14346            propagate TREE_ADDRESSABLE to the file-scope decl.
14347
14348            DECL_ABSTRACT_ORIGIN can be set to itself if warn_return_type is
14349            true, since then the decl goes through save_for_inline_copying.  */
14350         if (DECL_ABSTRACT_ORIGIN (decl) != 0
14351             && DECL_ABSTRACT_ORIGIN (decl) != decl)
14352           TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl)) = 1;
14353         else if (DECL_SAVED_INSNS (decl) != 0)
14354           {
14355             push_function_context ();
14356             output_inline_function (decl);
14357             pop_function_context ();
14358           }
14359       }
14360
14361   /* If there were any declarations or structure tags in that level,
14362      or if this level is a function body,
14363      create a BLOCK to record them for the life of this function.  */
14364
14365   block = 0;
14366   block_previously_created = (current_binding_level->this_block != 0);
14367   if (block_previously_created)
14368     block = current_binding_level->this_block;
14369   else if (keep || functionbody)
14370     block = make_node (BLOCK);
14371   if (block != 0)
14372     {
14373       BLOCK_VARS (block) = decls;
14374       BLOCK_SUBBLOCKS (block) = subblocks;
14375     }
14376
14377   /* In each subblock, record that this is its superior.  */
14378
14379   for (link = subblocks; link; link = TREE_CHAIN (link))
14380     BLOCK_SUPERCONTEXT (link) = block;
14381
14382   /* Clear out the meanings of the local variables of this level.  */
14383
14384   for (link = decls; link; link = TREE_CHAIN (link))
14385     {
14386       if (DECL_NAME (link) != 0)
14387         {
14388           /* If the ident. was used or addressed via a local extern decl,
14389              don't forget that fact.  */
14390           if (DECL_EXTERNAL (link))
14391             {
14392               if (TREE_USED (link))
14393                 TREE_USED (DECL_NAME (link)) = 1;
14394               if (TREE_ADDRESSABLE (link))
14395                 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (link)) = 1;
14396             }
14397           IDENTIFIER_LOCAL_VALUE (DECL_NAME (link)) = 0;
14398         }
14399     }
14400
14401   /* If the level being exited is the top level of a function,
14402      check over all the labels, and clear out the current
14403      (function local) meanings of their names.  */
14404
14405   if (functionbody)
14406     {
14407       /* If this is the top level block of a function,
14408          the vars are the function's parameters.
14409          Don't leave them in the BLOCK because they are
14410          found in the FUNCTION_DECL instead.  */
14411
14412       BLOCK_VARS (block) = 0;
14413     }
14414
14415   /* Pop the current level, and free the structure for reuse.  */
14416
14417   {
14418     register struct f_binding_level *level = current_binding_level;
14419     current_binding_level = current_binding_level->level_chain;
14420
14421     level->level_chain = free_binding_level;
14422     free_binding_level = level;
14423   }
14424
14425   /* Dispose of the block that we just made inside some higher level.  */
14426   if (functionbody
14427       && current_function_decl != error_mark_node)
14428     DECL_INITIAL (current_function_decl) = block;
14429   else if (block)
14430     {
14431       if (!block_previously_created)
14432         current_binding_level->blocks
14433           = chainon (current_binding_level->blocks, block);
14434     }
14435   /* If we did not make a block for the level just exited,
14436      any blocks made for inner levels
14437      (since they cannot be recorded as subblocks in that level)
14438      must be carried forward so they will later become subblocks
14439      of something else.  */
14440   else if (subblocks)
14441     current_binding_level->blocks
14442       = chainon (current_binding_level->blocks, subblocks);
14443
14444   if (block)
14445     TREE_USED (block) = 1;
14446   return block;
14447 }
14448
14449 static void
14450 ffe_print_identifier (FILE *file, tree node, int indent)
14451 {
14452   print_node (file, "global", IDENTIFIER_GLOBAL_VALUE (node), indent + 4);
14453   print_node (file, "local", IDENTIFIER_LOCAL_VALUE (node), indent + 4);
14454 }
14455
14456 /* Record a decl-node X as belonging to the current lexical scope.
14457    Check for errors (such as an incompatible declaration for the same
14458    name already seen in the same scope).
14459
14460    Returns either X or an old decl for the same name.
14461    If an old decl is returned, it may have been smashed
14462    to agree with what X says.  */
14463
14464 tree
14465 pushdecl (tree x)
14466 {
14467   register tree t;
14468   register tree name = DECL_NAME (x);
14469   register struct f_binding_level *b = current_binding_level;
14470
14471   if ((TREE_CODE (x) == FUNCTION_DECL)
14472       && (DECL_INITIAL (x) == 0)
14473       && DECL_EXTERNAL (x))
14474     DECL_CONTEXT (x) = NULL_TREE;
14475   else
14476     DECL_CONTEXT (x) = current_function_decl;
14477
14478   if (name)
14479     {
14480       if (IDENTIFIER_INVENTED (name))
14481         {
14482           DECL_ARTIFICIAL (x) = 1;
14483           DECL_IN_SYSTEM_HEADER (x) = 1;
14484         }
14485
14486       t = lookup_name_current_level (name);
14487
14488       assert ((t == NULL_TREE) || (DECL_CONTEXT (x) == NULL_TREE));
14489
14490       /* Don't push non-parms onto list for parms until we understand
14491          why we're doing this and whether it works.  */
14492
14493       assert ((b == global_binding_level)
14494               || !ffecom_transform_only_dummies_
14495               || TREE_CODE (x) == PARM_DECL);
14496
14497       if ((t != NULL_TREE) && duplicate_decls (x, t))
14498         return t;
14499
14500       /* If we are processing a typedef statement, generate a whole new
14501          ..._TYPE node (which will be just an variant of the existing
14502          ..._TYPE node with identical properties) and then install the
14503          TYPE_DECL node generated to represent the typedef name as the
14504          TYPE_NAME of this brand new (duplicate) ..._TYPE node.
14505
14506          The whole point here is to end up with a situation where each and every
14507          ..._TYPE node the compiler creates will be uniquely associated with
14508          AT MOST one node representing a typedef name. This way, even though
14509          the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL
14510          (i.e. "typedef name") nodes very early on, later parts of the
14511          compiler can always do the reverse translation and get back the
14512          corresponding typedef name.  For example, given:
14513
14514          typedef struct S MY_TYPE; MY_TYPE object;
14515
14516          Later parts of the compiler might only know that `object' was of type
14517          `struct S' if it were not for code just below.  With this code
14518          however, later parts of the compiler see something like:
14519
14520          struct S' == struct S typedef struct S' MY_TYPE; struct S' object;
14521
14522          And they can then deduce (from the node for type struct S') that the
14523          original object declaration was:
14524
14525          MY_TYPE object;
14526
14527          Being able to do this is important for proper support of protoize, and
14528          also for generating precise symbolic debugging information which
14529          takes full account of the programmer's (typedef) vocabulary.
14530
14531          Obviously, we don't want to generate a duplicate ..._TYPE node if the
14532          TYPE_DECL node that we are now processing really represents a
14533          standard built-in type.
14534
14535          Since all standard types are effectively declared at line zero in the
14536          source file, we can easily check to see if we are working on a
14537          standard type by checking the current value of lineno.  */
14538
14539       if (TREE_CODE (x) == TYPE_DECL)
14540         {
14541           if (DECL_SOURCE_LINE (x) == 0)
14542             {
14543               if (TYPE_NAME (TREE_TYPE (x)) == 0)
14544                 TYPE_NAME (TREE_TYPE (x)) = x;
14545             }
14546           else if (TREE_TYPE (x) != error_mark_node)
14547             {
14548               tree tt = TREE_TYPE (x);
14549
14550               tt = build_type_copy (tt);
14551               TYPE_NAME (tt) = x;
14552               TREE_TYPE (x) = tt;
14553             }
14554         }
14555
14556       /* This name is new in its binding level. Install the new declaration
14557          and return it.  */
14558       if (b == global_binding_level)
14559         IDENTIFIER_GLOBAL_VALUE (name) = x;
14560       else
14561         IDENTIFIER_LOCAL_VALUE (name) = x;
14562     }
14563
14564   /* Put decls on list in reverse order. We will reverse them later if
14565      necessary.  */
14566   TREE_CHAIN (x) = b->names;
14567   b->names = x;
14568
14569   return x;
14570 }
14571
14572 /* Nonzero if the current level needs to have a BLOCK made.  */
14573
14574 static int
14575 kept_level_p (void)
14576 {
14577   tree decl;
14578
14579   for (decl = current_binding_level->names;
14580        decl;
14581        decl = TREE_CHAIN (decl))
14582     {
14583       if (TREE_USED (decl) || TREE_CODE (decl) != VAR_DECL
14584           || (DECL_NAME (decl) && ! DECL_ARTIFICIAL (decl)))
14585         /* Currently, there aren't supposed to be non-artificial names
14586            at other than the top block for a function -- they're
14587            believed to always be temps.  But it's wise to check anyway.  */
14588         return 1;
14589     }
14590   return 0;
14591 }
14592
14593 /* Enter a new binding level.
14594    If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
14595    not for that of tags.  */
14596
14597 void
14598 pushlevel (int tag_transparent)
14599 {
14600   register struct f_binding_level *newlevel = NULL_BINDING_LEVEL;
14601
14602   assert (! tag_transparent);
14603
14604   if (current_binding_level == global_binding_level)
14605     {
14606       named_labels = 0;
14607     }
14608
14609   /* Reuse or create a struct for this binding level.  */
14610
14611   if (free_binding_level)
14612     {
14613       newlevel = free_binding_level;
14614       free_binding_level = free_binding_level->level_chain;
14615     }
14616   else
14617     {
14618       newlevel = make_binding_level ();
14619     }
14620
14621   /* Add this level to the front of the chain (stack) of levels that
14622      are active.  */
14623
14624   *newlevel = clear_binding_level;
14625   newlevel->level_chain = current_binding_level;
14626   current_binding_level = newlevel;
14627 }
14628
14629 /* Set the BLOCK node for the innermost scope
14630    (the one we are currently in).  */
14631
14632 void
14633 set_block (tree block)
14634 {
14635   current_binding_level->this_block = block;
14636   current_binding_level->names = chainon (current_binding_level->names,
14637                                           BLOCK_VARS (block));
14638   current_binding_level->blocks = chainon (current_binding_level->blocks,
14639                                            BLOCK_SUBBLOCKS (block));
14640 }
14641
14642 static tree
14643 ffe_signed_or_unsigned_type (int unsignedp, tree type)
14644 {
14645   tree type2;
14646
14647   if (! INTEGRAL_TYPE_P (type))
14648     return type;
14649   if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node))
14650     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
14651   if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node))
14652     return unsignedp ? unsigned_type_node : integer_type_node;
14653   if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node))
14654     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
14655   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node))
14656     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
14657   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node))
14658     return (unsignedp ? long_long_unsigned_type_node
14659             : long_long_integer_type_node);
14660
14661   type2 = ffe_type_for_size (TYPE_PRECISION (type), unsignedp);
14662   if (type2 == NULL_TREE)
14663     return type;
14664
14665   return type2;
14666 }
14667
14668 static tree
14669 ffe_signed_type (tree type)
14670 {
14671   tree type1 = TYPE_MAIN_VARIANT (type);
14672   ffeinfoKindtype kt;
14673   tree type2;
14674
14675   if (type1 == unsigned_char_type_node || type1 == char_type_node)
14676     return signed_char_type_node;
14677   if (type1 == unsigned_type_node)
14678     return integer_type_node;
14679   if (type1 == short_unsigned_type_node)
14680     return short_integer_type_node;
14681   if (type1 == long_unsigned_type_node)
14682     return long_integer_type_node;
14683   if (type1 == long_long_unsigned_type_node)
14684     return long_long_integer_type_node;
14685 #if 0   /* gcc/c-* files only */
14686   if (type1 == unsigned_intDI_type_node)
14687     return intDI_type_node;
14688   if (type1 == unsigned_intSI_type_node)
14689     return intSI_type_node;
14690   if (type1 == unsigned_intHI_type_node)
14691     return intHI_type_node;
14692   if (type1 == unsigned_intQI_type_node)
14693     return intQI_type_node;
14694 #endif
14695
14696   type2 = ffe_type_for_size (TYPE_PRECISION (type1), 0);
14697   if (type2 != NULL_TREE)
14698     return type2;
14699
14700   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
14701     {
14702       type2 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
14703
14704       if (type1 == type2)
14705         return ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
14706     }
14707
14708   return type;
14709 }
14710
14711 /* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
14712    or validate its data type for an `if' or `while' statement or ?..: exp.
14713
14714    This preparation consists of taking the ordinary
14715    representation of an expression expr and producing a valid tree
14716    boolean expression describing whether expr is nonzero.  We could
14717    simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
14718    but we optimize comparisons, &&, ||, and !.
14719
14720    The resulting type should always be `integer_type_node'.  */
14721
14722 static tree
14723 ffe_truthvalue_conversion (tree expr)
14724 {
14725   if (TREE_CODE (expr) == ERROR_MARK)
14726     return expr;
14727
14728 #if 0 /* This appears to be wrong for C++.  */
14729   /* These really should return error_mark_node after 2.4 is stable.
14730      But not all callers handle ERROR_MARK properly.  */
14731   switch (TREE_CODE (TREE_TYPE (expr)))
14732     {
14733     case RECORD_TYPE:
14734       error ("struct type value used where scalar is required");
14735       return integer_zero_node;
14736
14737     case UNION_TYPE:
14738       error ("union type value used where scalar is required");
14739       return integer_zero_node;
14740
14741     case ARRAY_TYPE:
14742       error ("array type value used where scalar is required");
14743       return integer_zero_node;
14744
14745     default:
14746       break;
14747     }
14748 #endif /* 0 */
14749
14750   switch (TREE_CODE (expr))
14751     {
14752       /* It is simpler and generates better code to have only TRUTH_*_EXPR
14753          or comparison expressions as truth values at this level.  */
14754 #if 0
14755     case COMPONENT_REF:
14756       /* A one-bit unsigned bit-field is already acceptable.  */
14757       if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr, 1)))
14758           && TREE_UNSIGNED (TREE_OPERAND (expr, 1)))
14759         return expr;
14760       break;
14761 #endif
14762
14763     case EQ_EXPR:
14764       /* It is simpler and generates better code to have only TRUTH_*_EXPR
14765          or comparison expressions as truth values at this level.  */
14766 #if 0
14767       if (integer_zerop (TREE_OPERAND (expr, 1)))
14768         return build_unary_op (TRUTH_NOT_EXPR, TREE_OPERAND (expr, 0), 0);
14769 #endif
14770     case NE_EXPR: case LE_EXPR: case GE_EXPR: case LT_EXPR: case GT_EXPR:
14771     case TRUTH_ANDIF_EXPR:
14772     case TRUTH_ORIF_EXPR:
14773     case TRUTH_AND_EXPR:
14774     case TRUTH_OR_EXPR:
14775     case TRUTH_XOR_EXPR:
14776       TREE_TYPE (expr) = integer_type_node;
14777       return expr;
14778
14779     case ERROR_MARK:
14780       return expr;
14781
14782     case INTEGER_CST:
14783       return integer_zerop (expr) ? integer_zero_node : integer_one_node;
14784
14785     case REAL_CST:
14786       return real_zerop (expr) ? integer_zero_node : integer_one_node;
14787
14788     case ADDR_EXPR:
14789       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 0)))
14790         return build (COMPOUND_EXPR, integer_type_node,
14791                       TREE_OPERAND (expr, 0), integer_one_node);
14792       else
14793         return integer_one_node;
14794
14795     case COMPLEX_EXPR:
14796       return ffecom_2 ((TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1))
14797                         ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
14798                        integer_type_node,
14799                        ffe_truthvalue_conversion (TREE_OPERAND (expr, 0)),
14800                        ffe_truthvalue_conversion (TREE_OPERAND (expr, 1)));
14801
14802     case NEGATE_EXPR:
14803     case ABS_EXPR:
14804     case FLOAT_EXPR:
14805       /* These don't change whether an object is nonzero or zero.  */
14806       return ffe_truthvalue_conversion (TREE_OPERAND (expr, 0));
14807
14808     case LROTATE_EXPR:
14809     case RROTATE_EXPR:
14810       /* These don't change whether an object is zero or nonzero, but
14811          we can't ignore them if their second arg has side-effects.  */
14812       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1)))
14813         return build (COMPOUND_EXPR, integer_type_node, TREE_OPERAND (expr, 1),
14814                       ffe_truthvalue_conversion (TREE_OPERAND (expr, 0)));
14815       else
14816         return ffe_truthvalue_conversion (TREE_OPERAND (expr, 0));
14817
14818     case COND_EXPR:
14819       {
14820         /* Distribute the conversion into the arms of a COND_EXPR.  */
14821         tree arg1 = TREE_OPERAND (expr, 1);
14822         tree arg2 = TREE_OPERAND (expr, 2);
14823         if (! VOID_TYPE_P (TREE_TYPE (arg1)))
14824           arg1 = ffe_truthvalue_conversion (arg1);
14825         if (! VOID_TYPE_P (TREE_TYPE (arg2)))
14826           arg2 = ffe_truthvalue_conversion (arg2);
14827         return fold (build (COND_EXPR, integer_type_node,
14828                             TREE_OPERAND (expr, 0), arg1, arg2));
14829       }
14830
14831     case CONVERT_EXPR:
14832       /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
14833          since that affects how `default_conversion' will behave.  */
14834       if (TREE_CODE (TREE_TYPE (expr)) == REFERENCE_TYPE
14835           || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) == REFERENCE_TYPE)
14836         break;
14837       /* fall through... */
14838     case NOP_EXPR:
14839       /* If this is widening the argument, we can ignore it.  */
14840       if (TYPE_PRECISION (TREE_TYPE (expr))
14841           >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr, 0))))
14842         return ffe_truthvalue_conversion (TREE_OPERAND (expr, 0));
14843       break;
14844
14845     case MINUS_EXPR:
14846       /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize
14847          this case.  */
14848       if (TARGET_FLOAT_FORMAT == IEEE_FLOAT_FORMAT
14849           && TREE_CODE (TREE_TYPE (expr)) == REAL_TYPE)
14850         break;
14851       /* fall through... */
14852     case BIT_XOR_EXPR:
14853       /* This and MINUS_EXPR can be changed into a comparison of the
14854          two objects.  */
14855       if (TREE_TYPE (TREE_OPERAND (expr, 0))
14856           == TREE_TYPE (TREE_OPERAND (expr, 1)))
14857         return ffecom_2 (NE_EXPR, integer_type_node,
14858                          TREE_OPERAND (expr, 0),
14859                          TREE_OPERAND (expr, 1));
14860       return ffecom_2 (NE_EXPR, integer_type_node,
14861                        TREE_OPERAND (expr, 0),
14862                        fold (build1 (NOP_EXPR,
14863                                      TREE_TYPE (TREE_OPERAND (expr, 0)),
14864                                      TREE_OPERAND (expr, 1))));
14865
14866     case BIT_AND_EXPR:
14867       if (integer_onep (TREE_OPERAND (expr, 1)))
14868         return expr;
14869       break;
14870
14871     case MODIFY_EXPR:
14872 #if 0                           /* No such thing in Fortran. */
14873       if (warn_parentheses && C_EXP_ORIGINAL_CODE (expr) == MODIFY_EXPR)
14874         warning ("suggest parentheses around assignment used as truth value");
14875 #endif
14876       break;
14877
14878     default:
14879       break;
14880     }
14881
14882   if (TREE_CODE (TREE_TYPE (expr)) == COMPLEX_TYPE)
14883     return (ffecom_2
14884             ((TREE_SIDE_EFFECTS (expr)
14885               ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
14886              integer_type_node,
14887              ffe_truthvalue_conversion (ffecom_1 (REALPART_EXPR,
14888                                                   TREE_TYPE (TREE_TYPE (expr)),
14889                                                   expr)),
14890              ffe_truthvalue_conversion (ffecom_1 (IMAGPART_EXPR,
14891                                                   TREE_TYPE (TREE_TYPE (expr)),
14892                                                   expr))));
14893
14894   return ffecom_2 (NE_EXPR, integer_type_node,
14895                    expr,
14896                    convert (TREE_TYPE (expr), integer_zero_node));
14897 }
14898
14899 static tree
14900 ffe_type_for_mode (enum machine_mode mode, int unsignedp)
14901 {
14902   int i;
14903   int j;
14904   tree t;
14905
14906   if (mode == TYPE_MODE (integer_type_node))
14907     return unsignedp ? unsigned_type_node : integer_type_node;
14908
14909   if (mode == TYPE_MODE (signed_char_type_node))
14910     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
14911
14912   if (mode == TYPE_MODE (short_integer_type_node))
14913     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
14914
14915   if (mode == TYPE_MODE (long_integer_type_node))
14916     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
14917
14918   if (mode == TYPE_MODE (long_long_integer_type_node))
14919     return unsignedp ? long_long_unsigned_type_node : long_long_integer_type_node;
14920
14921 #if HOST_BITS_PER_WIDE_INT >= 64
14922   if (mode == TYPE_MODE (intTI_type_node))
14923     return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
14924 #endif
14925
14926   if (mode == TYPE_MODE (float_type_node))
14927     return float_type_node;
14928
14929   if (mode == TYPE_MODE (double_type_node))
14930     return double_type_node;
14931
14932   if (mode == TYPE_MODE (long_double_type_node))
14933     return long_double_type_node;
14934
14935  if (mode == TYPE_MODE (build_pointer_type (char_type_node)))
14936     return build_pointer_type (char_type_node);
14937
14938   if (mode == TYPE_MODE (build_pointer_type (integer_type_node)))
14939     return build_pointer_type (integer_type_node);
14940
14941   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
14942     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
14943       {
14944         if (((t = ffecom_tree_type[i][j]) != NULL_TREE)
14945             && (mode == TYPE_MODE (t)))
14946           {
14947             if ((i == FFEINFO_basictypeINTEGER) && unsignedp)
14948               return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][j];
14949             else
14950               return t;
14951           }
14952       }
14953
14954   return 0;
14955 }
14956
14957 static tree
14958 ffe_type_for_size (unsigned bits, int unsignedp)
14959 {
14960   ffeinfoKindtype kt;
14961   tree type_node;
14962
14963   if (bits == TYPE_PRECISION (integer_type_node))
14964     return unsignedp ? unsigned_type_node : integer_type_node;
14965
14966   if (bits == TYPE_PRECISION (signed_char_type_node))
14967     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
14968
14969   if (bits == TYPE_PRECISION (short_integer_type_node))
14970     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
14971
14972   if (bits == TYPE_PRECISION (long_integer_type_node))
14973     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
14974
14975   if (bits == TYPE_PRECISION (long_long_integer_type_node))
14976     return (unsignedp ? long_long_unsigned_type_node
14977             : long_long_integer_type_node);
14978
14979   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
14980     {
14981       type_node = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
14982
14983       if ((type_node != NULL_TREE) && (bits == TYPE_PRECISION (type_node)))
14984         return unsignedp ? ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]
14985           : type_node;
14986     }
14987
14988   return 0;
14989 }
14990
14991 static tree
14992 ffe_unsigned_type (tree type)
14993 {
14994   tree type1 = TYPE_MAIN_VARIANT (type);
14995   ffeinfoKindtype kt;
14996   tree type2;
14997
14998   if (type1 == signed_char_type_node || type1 == char_type_node)
14999     return unsigned_char_type_node;
15000   if (type1 == integer_type_node)
15001     return unsigned_type_node;
15002   if (type1 == short_integer_type_node)
15003     return short_unsigned_type_node;
15004   if (type1 == long_integer_type_node)
15005     return long_unsigned_type_node;
15006   if (type1 == long_long_integer_type_node)
15007     return long_long_unsigned_type_node;
15008 #if 0   /* gcc/c-* files only */
15009   if (type1 == intDI_type_node)
15010     return unsigned_intDI_type_node;
15011   if (type1 == intSI_type_node)
15012     return unsigned_intSI_type_node;
15013   if (type1 == intHI_type_node)
15014     return unsigned_intHI_type_node;
15015   if (type1 == intQI_type_node)
15016     return unsigned_intQI_type_node;
15017 #endif
15018
15019   type2 = ffe_type_for_size (TYPE_PRECISION (type1), 1);
15020   if (type2 != NULL_TREE)
15021     return type2;
15022
15023   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15024     {
15025       type2 = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15026
15027       if (type1 == type2)
15028         return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
15029     }
15030
15031   return type;
15032 }
15033 \f
15034 /* From gcc/cccp.c, the code to handle -I.  */
15035
15036 /* Skip leading "./" from a directory name.
15037    This may yield the empty string, which represents the current directory.  */
15038
15039 static const char *
15040 skip_redundant_dir_prefix (const char *dir)
15041 {
15042   while (dir[0] == '.' && dir[1] == '/')
15043     for (dir += 2; *dir == '/'; dir++)
15044       continue;
15045   if (dir[0] == '.' && !dir[1])
15046     dir++;
15047   return dir;
15048 }
15049
15050 /* The file_name_map structure holds a mapping of file names for a
15051    particular directory.  This mapping is read from the file named
15052    FILE_NAME_MAP_FILE in that directory.  Such a file can be used to
15053    map filenames on a file system with severe filename restrictions,
15054    such as DOS.  The format of the file name map file is just a series
15055    of lines with two tokens on each line.  The first token is the name
15056    to map, and the second token is the actual name to use.  */
15057
15058 struct file_name_map
15059 {
15060   struct file_name_map *map_next;
15061   char *map_from;
15062   char *map_to;
15063 };
15064
15065 #define FILE_NAME_MAP_FILE "header.gcc"
15066
15067 /* Current maximum length of directory names in the search path
15068    for include files.  (Altered as we get more of them.)  */
15069
15070 static int max_include_len = 0;
15071
15072 struct file_name_list
15073   {
15074     struct file_name_list *next;
15075     const char *fname;
15076     /* Mapping of file names for this directory.  */
15077     struct file_name_map *name_map;
15078     /* Nonzero if name_map is valid.  */
15079     int got_name_map;
15080   };
15081
15082 static struct file_name_list *include = NULL;   /* First dir to search */
15083 static struct file_name_list *last_include = NULL;      /* Last in chain */
15084
15085 /* I/O buffer structure.
15086    The `fname' field is nonzero for source files and #include files
15087    and for the dummy text used for -D and -U.
15088    It is zero for rescanning results of macro expansion
15089    and for expanding macro arguments.  */
15090 #define INPUT_STACK_MAX 400
15091 static struct file_buf {
15092   const char *fname;
15093   /* Filename specified with #line command.  */
15094   const char *nominal_fname;
15095   /* Record where in the search path this file was found.
15096      For #include_next.  */
15097   struct file_name_list *dir;
15098   ffewhereLine line;
15099   ffewhereColumn column;
15100 } instack[INPUT_STACK_MAX];
15101
15102 static int last_error_tick = 0;    /* Incremented each time we print it.  */
15103
15104 /* Current nesting level of input sources.
15105    `instack[indepth]' is the level currently being read.  */
15106 static int indepth = -1;
15107
15108 typedef struct file_buf FILE_BUF;
15109
15110 /* Nonzero means -I- has been seen,
15111    so don't look for #include "foo" the source-file directory.  */
15112 static int ignore_srcdir;
15113
15114 #ifndef INCLUDE_LEN_FUDGE
15115 #define INCLUDE_LEN_FUDGE 0
15116 #endif
15117
15118 static void append_include_chain (struct file_name_list *first,
15119                                   struct file_name_list *last);
15120 static FILE *open_include_file (char *filename,
15121                                 struct file_name_list *searchptr);
15122 static void print_containing_files (ffebadSeverity sev);
15123 static char *read_filename_string (int ch, FILE *f);
15124 static struct file_name_map *read_name_map (const char *dirname);
15125
15126 /* Append a chain of `struct file_name_list's
15127    to the end of the main include chain.
15128    FIRST is the beginning of the chain to append, and LAST is the end.  */
15129
15130 static void
15131 append_include_chain (struct file_name_list *first,
15132                       struct file_name_list *last)
15133 {
15134   struct file_name_list *dir;
15135
15136   if (!first || !last)
15137     return;
15138
15139   if (include == 0)
15140     include = first;
15141   else
15142     last_include->next = first;
15143
15144   for (dir = first; ; dir = dir->next) {
15145     int len = strlen (dir->fname) + INCLUDE_LEN_FUDGE;
15146     if (len > max_include_len)
15147       max_include_len = len;
15148     if (dir == last)
15149       break;
15150   }
15151
15152   last->next = NULL;
15153   last_include = last;
15154 }
15155
15156 /* Try to open include file FILENAME.  SEARCHPTR is the directory
15157    being tried from the include file search path.  This function maps
15158    filenames on file systems based on information read by
15159    read_name_map.  */
15160
15161 static FILE *
15162 open_include_file (char *filename, struct file_name_list *searchptr)
15163 {
15164   register struct file_name_map *map;
15165   register char *from;
15166   char *p, *dir;
15167
15168   if (searchptr && ! searchptr->got_name_map)
15169     {
15170       searchptr->name_map = read_name_map (searchptr->fname
15171                                            ? searchptr->fname : ".");
15172       searchptr->got_name_map = 1;
15173     }
15174
15175   /* First check the mapping for the directory we are using.  */
15176   if (searchptr && searchptr->name_map)
15177     {
15178       from = filename;
15179       if (searchptr->fname)
15180         from += strlen (searchptr->fname) + 1;
15181       for (map = searchptr->name_map; map; map = map->map_next)
15182         {
15183           if (! strcmp (map->map_from, from))
15184             {
15185               /* Found a match.  */
15186               return fopen (map->map_to, "r");
15187             }
15188         }
15189     }
15190
15191   /* Try to find a mapping file for the particular directory we are
15192      looking in.  Thus #include <sys/types.h> will look up sys/types.h
15193      in /usr/include/header.gcc and look up types.h in
15194      /usr/include/sys/header.gcc.  */
15195   p = strrchr (filename, '/');
15196 #ifdef DIR_SEPARATOR
15197   if (! p) p = strrchr (filename, DIR_SEPARATOR);
15198   else {
15199     char *tmp = strrchr (filename, DIR_SEPARATOR);
15200     if (tmp != NULL && tmp > p) p = tmp;
15201   }
15202 #endif
15203   if (! p)
15204     p = filename;
15205   if (searchptr
15206       && searchptr->fname
15207       && strlen (searchptr->fname) == (size_t) (p - filename)
15208       && ! strncmp (searchptr->fname, filename, (int) (p - filename)))
15209     {
15210       /* FILENAME is in SEARCHPTR, which we've already checked.  */
15211       return fopen (filename, "r");
15212     }
15213
15214   if (p == filename)
15215     {
15216       from = filename;
15217       map = read_name_map (".");
15218     }
15219   else
15220     {
15221       dir = xmalloc (p - filename + 1);
15222       memcpy (dir, filename, p - filename);
15223       dir[p - filename] = '\0';
15224       from = p + 1;
15225       map = read_name_map (dir);
15226       free (dir);
15227     }
15228   for (; map; map = map->map_next)
15229     if (! strcmp (map->map_from, from))
15230       return fopen (map->map_to, "r");
15231
15232   return fopen (filename, "r");
15233 }
15234
15235 /* Print the file names and line numbers of the #include
15236    commands which led to the current file.  */
15237
15238 static void
15239 print_containing_files (ffebadSeverity sev)
15240 {
15241   FILE_BUF *ip = NULL;
15242   int i;
15243   int first = 1;
15244   const char *str1;
15245   const char *str2;
15246
15247   /* If stack of files hasn't changed since we last printed
15248      this info, don't repeat it.  */
15249   if (last_error_tick == input_file_stack_tick)
15250     return;
15251
15252   for (i = indepth; i >= 0; i--)
15253     if (instack[i].fname != NULL) {
15254       ip = &instack[i];
15255       break;
15256     }
15257
15258   /* Give up if we don't find a source file.  */
15259   if (ip == NULL)
15260     return;
15261
15262   /* Find the other, outer source files.  */
15263   for (i--; i >= 0; i--)
15264     if (instack[i].fname != NULL)
15265       {
15266         ip = &instack[i];
15267         if (first)
15268           {
15269             first = 0;
15270             str1 = "In file included";
15271           }
15272         else
15273           {
15274             str1 = "...          ...";
15275           }
15276
15277         if (i == 1)
15278           str2 = ":";
15279         else
15280           str2 = "";
15281
15282         /* xgettext:no-c-format */
15283         ffebad_start_msg ("%A from %B at %0%C", sev);
15284         ffebad_here (0, ip->line, ip->column);
15285         ffebad_string (str1);
15286         ffebad_string (ip->nominal_fname);
15287         ffebad_string (str2);
15288         ffebad_finish ();
15289       }
15290
15291   /* Record we have printed the status as of this time.  */
15292   last_error_tick = input_file_stack_tick;
15293 }
15294
15295 /* Read a space delimited string of unlimited length from a stdio
15296    file.  */
15297
15298 static char *
15299 read_filename_string (int ch, FILE *f)
15300 {
15301   char *alloc, *set;
15302   int len;
15303
15304   len = 20;
15305   set = alloc = xmalloc (len + 1);
15306   if (! ISSPACE (ch))
15307     {
15308       *set++ = ch;
15309       while ((ch = getc (f)) != EOF && ! ISSPACE (ch))
15310         {
15311           if (set - alloc == len)
15312             {
15313               len *= 2;
15314               alloc = xrealloc (alloc, len + 1);
15315               set = alloc + len / 2;
15316             }
15317           *set++ = ch;
15318         }
15319     }
15320   *set = '\0';
15321   ungetc (ch, f);
15322   return alloc;
15323 }
15324
15325 /* Read the file name map file for DIRNAME.  */
15326
15327 static struct file_name_map *
15328 read_name_map (const char *dirname)
15329 {
15330   /* This structure holds a linked list of file name maps, one per
15331      directory.  */
15332   struct file_name_map_list
15333     {
15334       struct file_name_map_list *map_list_next;
15335       char *map_list_name;
15336       struct file_name_map *map_list_map;
15337     };
15338   static struct file_name_map_list *map_list;
15339   register struct file_name_map_list *map_list_ptr;
15340   char *name;
15341   FILE *f;
15342   size_t dirlen;
15343   int separator_needed;
15344
15345   dirname = skip_redundant_dir_prefix (dirname);
15346
15347   for (map_list_ptr = map_list; map_list_ptr;
15348        map_list_ptr = map_list_ptr->map_list_next)
15349     if (! strcmp (map_list_ptr->map_list_name, dirname))
15350       return map_list_ptr->map_list_map;
15351
15352   map_list_ptr = xmalloc (sizeof (struct file_name_map_list));
15353   map_list_ptr->map_list_name = xstrdup (dirname);
15354   map_list_ptr->map_list_map = NULL;
15355
15356   dirlen = strlen (dirname);
15357   separator_needed = dirlen != 0 && dirname[dirlen - 1] != '/';
15358   if (separator_needed)
15359     name = concat (dirname, "/", FILE_NAME_MAP_FILE, NULL);
15360   else
15361     name = concat (dirname, FILE_NAME_MAP_FILE, NULL);
15362   f = fopen (name, "r");
15363   free (name);
15364   if (!f)
15365     map_list_ptr->map_list_map = NULL;
15366   else
15367     {
15368       int ch;
15369
15370       while ((ch = getc (f)) != EOF)
15371         {
15372           char *from, *to;
15373           struct file_name_map *ptr;
15374
15375           if (ISSPACE (ch))
15376             continue;
15377           from = read_filename_string (ch, f);
15378           while ((ch = getc (f)) != EOF && ISSPACE (ch) && ch != '\n')
15379             ;
15380           to = read_filename_string (ch, f);
15381
15382           ptr = xmalloc (sizeof (struct file_name_map));
15383           ptr->map_from = from;
15384
15385           /* Make the real filename absolute.  */
15386           if (*to == '/')
15387             ptr->map_to = to;
15388           else
15389             {
15390               if (separator_needed)
15391                 ptr->map_to = concat (dirname, "/", to, NULL);
15392               else
15393                 ptr->map_to = concat (dirname, to, NULL);
15394               free (to);
15395             }
15396
15397           ptr->map_next = map_list_ptr->map_list_map;
15398           map_list_ptr->map_list_map = ptr;
15399
15400           while ((ch = getc (f)) != '\n')
15401             if (ch == EOF)
15402               break;
15403         }
15404       fclose (f);
15405     }
15406
15407   map_list_ptr->map_list_next = map_list;
15408   map_list = map_list_ptr;
15409
15410   return map_list_ptr->map_list_map;
15411 }
15412
15413 static void
15414 ffecom_file_ (const char *name)
15415 {
15416   FILE_BUF *fp;
15417
15418   /* Do partial setup of input buffer for the sake of generating
15419      early #line directives (when -g is in effect).  */
15420
15421   fp = &instack[++indepth];
15422   memset (fp, 0, sizeof (FILE_BUF));
15423   if (name == NULL)
15424     name = "";
15425   fp->nominal_fname = fp->fname = name;
15426 }
15427
15428 static void
15429 ffecom_close_include_ (FILE *f)
15430 {
15431   fclose (f);
15432
15433   indepth--;
15434   input_file_stack_tick++;
15435
15436   ffewhere_line_kill (instack[indepth].line);
15437   ffewhere_column_kill (instack[indepth].column);
15438 }
15439
15440 void
15441 ffecom_decode_include_option (const char *dir)
15442 {
15443   if (! ignore_srcdir && !strcmp (dir, "-"))
15444     ignore_srcdir = 1;
15445   else
15446     {
15447       struct file_name_list *dirtmp
15448         = xmalloc (sizeof (struct file_name_list));
15449       dirtmp->next = 0;         /* New one goes on the end */
15450       dirtmp->fname = dir;
15451       dirtmp->got_name_map = 0;
15452       append_include_chain (dirtmp, dirtmp);
15453     }
15454 }
15455
15456 /* Open INCLUDEd file.  */
15457
15458 static FILE *
15459 ffecom_open_include_ (char *name, ffewhereLine l, ffewhereColumn c)
15460 {
15461   char *fbeg = name;
15462   size_t flen = strlen (fbeg);
15463   struct file_name_list *search_start = include; /* Chain of dirs to search */
15464   struct file_name_list dsp[1]; /* First in chain, if #include "..." */
15465   struct file_name_list *searchptr = 0;
15466   char *fname;          /* Dynamically allocated fname buffer */
15467   FILE *f;
15468   FILE_BUF *fp;
15469
15470   if (flen == 0)
15471     return NULL;
15472
15473   dsp[0].fname = NULL;
15474
15475   /* If -I- was specified, don't search current dir, only spec'd ones. */
15476   if (!ignore_srcdir)
15477     {
15478       for (fp = &instack[indepth]; fp >= instack; fp--)
15479         {
15480           int n;
15481           char *ep;
15482           const char *nam;
15483
15484           if ((nam = fp->nominal_fname) != NULL)
15485             {
15486               /* Found a named file.  Figure out dir of the file,
15487                  and put it in front of the search list.  */
15488               dsp[0].next = search_start;
15489               search_start = dsp;
15490 #ifndef VMS
15491               ep = strrchr (nam, '/');
15492 #ifdef DIR_SEPARATOR
15493             if (ep == NULL) ep = strrchr (nam, DIR_SEPARATOR);
15494             else {
15495               char *tmp = strrchr (nam, DIR_SEPARATOR);
15496               if (tmp != NULL && tmp > ep) ep = tmp;
15497             }
15498 #endif
15499 #else                           /* VMS */
15500               ep = strrchr (nam, ']');
15501               if (ep == NULL) ep = strrchr (nam, '>');
15502               if (ep == NULL) ep = strrchr (nam, ':');
15503               if (ep != NULL) ep++;
15504 #endif                          /* VMS */
15505               if (ep != NULL)
15506                 {
15507                   n = ep - nam;
15508                   fname = xmalloc (n + 1);
15509                   strncpy (fname, nam, n);
15510                   fname[n] = '\0';
15511                   dsp[0].fname = fname;
15512                   if (n + INCLUDE_LEN_FUDGE > max_include_len)
15513                     max_include_len = n + INCLUDE_LEN_FUDGE;
15514                 }
15515               else
15516                 dsp[0].fname = NULL; /* Current directory */
15517               dsp[0].got_name_map = 0;
15518               break;
15519             }
15520         }
15521     }
15522
15523   /* Allocate this permanently, because it gets stored in the definitions
15524      of macros.  */
15525   fname = xmalloc (max_include_len + flen + 4);
15526   /* + 2 above for slash and terminating null.  */
15527   /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED
15528      for g77 yet).  */
15529
15530   /* If specified file name is absolute, just open it.  */
15531
15532   if (*fbeg == '/'
15533 #ifdef DIR_SEPARATOR
15534       || *fbeg == DIR_SEPARATOR
15535 #endif
15536       )
15537     {
15538       strncpy (fname, (char *) fbeg, flen);
15539       fname[flen] = 0;
15540       f = open_include_file (fname, NULL);
15541     }
15542   else
15543     {
15544       f = NULL;
15545
15546       /* Search directory path, trying to open the file.
15547          Copy each filename tried into FNAME.  */
15548
15549       for (searchptr = search_start; searchptr; searchptr = searchptr->next)
15550         {
15551           if (searchptr->fname)
15552             {
15553               /* The empty string in a search path is ignored.
15554                  This makes it possible to turn off entirely
15555                  a standard piece of the list.  */
15556               if (searchptr->fname[0] == 0)
15557                 continue;
15558               strcpy (fname, skip_redundant_dir_prefix (searchptr->fname));
15559               if (fname[0] && fname[strlen (fname) - 1] != '/')
15560                 strcat (fname, "/");
15561               fname[strlen (fname) + flen] = 0;
15562             }
15563           else
15564             fname[0] = 0;
15565
15566           strncat (fname, fbeg, flen);
15567 #ifdef VMS
15568           /* Change this 1/2 Unix 1/2 VMS file specification into a
15569              full VMS file specification */
15570           if (searchptr->fname && (searchptr->fname[0] != 0))
15571             {
15572               /* Fix up the filename */
15573               hack_vms_include_specification (fname);
15574             }
15575           else
15576             {
15577               /* This is a normal VMS filespec, so use it unchanged.  */
15578               strncpy (fname, (char *) fbeg, flen);
15579               fname[flen] = 0;
15580 #if 0   /* Not for g77.  */
15581               /* if it's '#include filename', add the missing .h */
15582               if (strchr (fname, '.') == NULL)
15583                 strcat (fname, ".h");
15584 #endif
15585             }
15586 #endif /* VMS */
15587           f = open_include_file (fname, searchptr);
15588 #ifdef EACCES
15589           if (f == NULL && errno == EACCES)
15590             {
15591               print_containing_files (FFEBAD_severityWARNING);
15592               /* xgettext:no-c-format */
15593               ffebad_start_msg ("At %0, INCLUDE file %A exists, but is not readable",
15594                                 FFEBAD_severityWARNING);
15595               ffebad_string (fname);
15596               ffebad_here (0, l, c);
15597               ffebad_finish ();
15598             }
15599 #endif
15600           if (f != NULL)
15601             break;
15602         }
15603     }
15604
15605   if (f == NULL)
15606     {
15607       /* A file that was not found.  */
15608
15609       strncpy (fname, (char *) fbeg, flen);
15610       fname[flen] = 0;
15611       print_containing_files (ffebad_severity (FFEBAD_OPEN_INCLUDE));
15612       ffebad_start (FFEBAD_OPEN_INCLUDE);
15613       ffebad_here (0, l, c);
15614       ffebad_string (fname);
15615       ffebad_finish ();
15616     }
15617
15618   if (dsp[0].fname != NULL)
15619     free ((char *) dsp[0].fname);
15620
15621   if (f == NULL)
15622     return NULL;
15623
15624   if (indepth >= (INPUT_STACK_MAX - 1))
15625     {
15626       print_containing_files (FFEBAD_severityFATAL);
15627       /* xgettext:no-c-format */
15628       ffebad_start_msg ("At %0, INCLUDE nesting too deep",
15629                         FFEBAD_severityFATAL);
15630       ffebad_string (fname);
15631       ffebad_here (0, l, c);
15632       ffebad_finish ();
15633       return NULL;
15634     }
15635
15636   instack[indepth].line = ffewhere_line_use (l);
15637   instack[indepth].column = ffewhere_column_use (c);
15638
15639   fp = &instack[indepth + 1];
15640   memset (fp, 0, sizeof (FILE_BUF));
15641   fp->nominal_fname = fp->fname = fname;
15642   fp->dir = searchptr;
15643
15644   indepth++;
15645   input_file_stack_tick++;
15646
15647   return f;
15648 }
15649
15650 /**INDENT* (Do not reformat this comment even with -fca option.)
15651    Data-gathering files: Given the source file listed below, compiled with
15652    f2c I obtained the output file listed after that, and from the output
15653    file I derived the above code.
15654
15655 -------- (begin input file to f2c)
15656         implicit none
15657         character*10 A1,A2
15658         complex C1,C2
15659         integer I1,I2
15660         real R1,R2
15661         double precision D1,D2
15662 C
15663         call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2)
15664 c /
15665         call fooI(I1/I2)
15666         call fooR(R1/I1)
15667         call fooD(D1/I1)
15668         call fooC(C1/I1)
15669         call fooR(R1/R2)
15670         call fooD(R1/D1)
15671         call fooD(D1/D2)
15672         call fooD(D1/R1)
15673         call fooC(C1/C2)
15674         call fooC(C1/R1)
15675         call fooZ(C1/D1)
15676 c **
15677         call fooI(I1**I2)
15678         call fooR(R1**I1)
15679         call fooD(D1**I1)
15680         call fooC(C1**I1)
15681         call fooR(R1**R2)
15682         call fooD(R1**D1)
15683         call fooD(D1**D2)
15684         call fooD(D1**R1)
15685         call fooC(C1**C2)
15686         call fooC(C1**R1)
15687         call fooZ(C1**D1)
15688 c FFEINTRIN_impABS
15689         call fooR(ABS(R1))
15690 c FFEINTRIN_impACOS
15691         call fooR(ACOS(R1))
15692 c FFEINTRIN_impAIMAG
15693         call fooR(AIMAG(C1))
15694 c FFEINTRIN_impAINT
15695         call fooR(AINT(R1))
15696 c FFEINTRIN_impALOG
15697         call fooR(ALOG(R1))
15698 c FFEINTRIN_impALOG10
15699         call fooR(ALOG10(R1))
15700 c FFEINTRIN_impAMAX0
15701         call fooR(AMAX0(I1,I2))
15702 c FFEINTRIN_impAMAX1
15703         call fooR(AMAX1(R1,R2))
15704 c FFEINTRIN_impAMIN0
15705         call fooR(AMIN0(I1,I2))
15706 c FFEINTRIN_impAMIN1
15707         call fooR(AMIN1(R1,R2))
15708 c FFEINTRIN_impAMOD
15709         call fooR(AMOD(R1,R2))
15710 c FFEINTRIN_impANINT
15711         call fooR(ANINT(R1))
15712 c FFEINTRIN_impASIN
15713         call fooR(ASIN(R1))
15714 c FFEINTRIN_impATAN
15715         call fooR(ATAN(R1))
15716 c FFEINTRIN_impATAN2
15717         call fooR(ATAN2(R1,R2))
15718 c FFEINTRIN_impCABS
15719         call fooR(CABS(C1))
15720 c FFEINTRIN_impCCOS
15721         call fooC(CCOS(C1))
15722 c FFEINTRIN_impCEXP
15723         call fooC(CEXP(C1))
15724 c FFEINTRIN_impCHAR
15725         call fooA(CHAR(I1))
15726 c FFEINTRIN_impCLOG
15727         call fooC(CLOG(C1))
15728 c FFEINTRIN_impCONJG
15729         call fooC(CONJG(C1))
15730 c FFEINTRIN_impCOS
15731         call fooR(COS(R1))
15732 c FFEINTRIN_impCOSH
15733         call fooR(COSH(R1))
15734 c FFEINTRIN_impCSIN
15735         call fooC(CSIN(C1))
15736 c FFEINTRIN_impCSQRT
15737         call fooC(CSQRT(C1))
15738 c FFEINTRIN_impDABS
15739         call fooD(DABS(D1))
15740 c FFEINTRIN_impDACOS
15741         call fooD(DACOS(D1))
15742 c FFEINTRIN_impDASIN
15743         call fooD(DASIN(D1))
15744 c FFEINTRIN_impDATAN
15745         call fooD(DATAN(D1))
15746 c FFEINTRIN_impDATAN2
15747         call fooD(DATAN2(D1,D2))
15748 c FFEINTRIN_impDCOS
15749         call fooD(DCOS(D1))
15750 c FFEINTRIN_impDCOSH
15751         call fooD(DCOSH(D1))
15752 c FFEINTRIN_impDDIM
15753         call fooD(DDIM(D1,D2))
15754 c FFEINTRIN_impDEXP
15755         call fooD(DEXP(D1))
15756 c FFEINTRIN_impDIM
15757         call fooR(DIM(R1,R2))
15758 c FFEINTRIN_impDINT
15759         call fooD(DINT(D1))
15760 c FFEINTRIN_impDLOG
15761         call fooD(DLOG(D1))
15762 c FFEINTRIN_impDLOG10
15763         call fooD(DLOG10(D1))
15764 c FFEINTRIN_impDMAX1
15765         call fooD(DMAX1(D1,D2))
15766 c FFEINTRIN_impDMIN1
15767         call fooD(DMIN1(D1,D2))
15768 c FFEINTRIN_impDMOD
15769         call fooD(DMOD(D1,D2))
15770 c FFEINTRIN_impDNINT
15771         call fooD(DNINT(D1))
15772 c FFEINTRIN_impDPROD
15773         call fooD(DPROD(R1,R2))
15774 c FFEINTRIN_impDSIGN
15775         call fooD(DSIGN(D1,D2))
15776 c FFEINTRIN_impDSIN
15777         call fooD(DSIN(D1))
15778 c FFEINTRIN_impDSINH
15779         call fooD(DSINH(D1))
15780 c FFEINTRIN_impDSQRT
15781         call fooD(DSQRT(D1))
15782 c FFEINTRIN_impDTAN
15783         call fooD(DTAN(D1))
15784 c FFEINTRIN_impDTANH
15785         call fooD(DTANH(D1))
15786 c FFEINTRIN_impEXP
15787         call fooR(EXP(R1))
15788 c FFEINTRIN_impIABS
15789         call fooI(IABS(I1))
15790 c FFEINTRIN_impICHAR
15791         call fooI(ICHAR(A1))
15792 c FFEINTRIN_impIDIM
15793         call fooI(IDIM(I1,I2))
15794 c FFEINTRIN_impIDNINT
15795         call fooI(IDNINT(D1))
15796 c FFEINTRIN_impINDEX
15797         call fooI(INDEX(A1,A2))
15798 c FFEINTRIN_impISIGN
15799         call fooI(ISIGN(I1,I2))
15800 c FFEINTRIN_impLEN
15801         call fooI(LEN(A1))
15802 c FFEINTRIN_impLGE
15803         call fooL(LGE(A1,A2))
15804 c FFEINTRIN_impLGT
15805         call fooL(LGT(A1,A2))
15806 c FFEINTRIN_impLLE
15807         call fooL(LLE(A1,A2))
15808 c FFEINTRIN_impLLT
15809         call fooL(LLT(A1,A2))
15810 c FFEINTRIN_impMAX0
15811         call fooI(MAX0(I1,I2))
15812 c FFEINTRIN_impMAX1
15813         call fooI(MAX1(R1,R2))
15814 c FFEINTRIN_impMIN0
15815         call fooI(MIN0(I1,I2))
15816 c FFEINTRIN_impMIN1
15817         call fooI(MIN1(R1,R2))
15818 c FFEINTRIN_impMOD
15819         call fooI(MOD(I1,I2))
15820 c FFEINTRIN_impNINT
15821         call fooI(NINT(R1))
15822 c FFEINTRIN_impSIGN
15823         call fooR(SIGN(R1,R2))
15824 c FFEINTRIN_impSIN
15825         call fooR(SIN(R1))
15826 c FFEINTRIN_impSINH
15827         call fooR(SINH(R1))
15828 c FFEINTRIN_impSQRT
15829         call fooR(SQRT(R1))
15830 c FFEINTRIN_impTAN
15831         call fooR(TAN(R1))
15832 c FFEINTRIN_impTANH
15833         call fooR(TANH(R1))
15834 c FFEINTRIN_imp_CMPLX_C
15835         call fooC(cmplx(C1,C2))
15836 c FFEINTRIN_imp_CMPLX_D
15837         call fooZ(cmplx(D1,D2))
15838 c FFEINTRIN_imp_CMPLX_I
15839         call fooC(cmplx(I1,I2))
15840 c FFEINTRIN_imp_CMPLX_R
15841         call fooC(cmplx(R1,R2))
15842 c FFEINTRIN_imp_DBLE_C
15843         call fooD(dble(C1))
15844 c FFEINTRIN_imp_DBLE_D
15845         call fooD(dble(D1))
15846 c FFEINTRIN_imp_DBLE_I
15847         call fooD(dble(I1))
15848 c FFEINTRIN_imp_DBLE_R
15849         call fooD(dble(R1))
15850 c FFEINTRIN_imp_INT_C
15851         call fooI(int(C1))
15852 c FFEINTRIN_imp_INT_D
15853         call fooI(int(D1))
15854 c FFEINTRIN_imp_INT_I
15855         call fooI(int(I1))
15856 c FFEINTRIN_imp_INT_R
15857         call fooI(int(R1))
15858 c FFEINTRIN_imp_REAL_C
15859         call fooR(real(C1))
15860 c FFEINTRIN_imp_REAL_D
15861         call fooR(real(D1))
15862 c FFEINTRIN_imp_REAL_I
15863         call fooR(real(I1))
15864 c FFEINTRIN_imp_REAL_R
15865         call fooR(real(R1))
15866 c
15867 c FFEINTRIN_imp_INT_D:
15868 c
15869 c FFEINTRIN_specIDINT
15870         call fooI(IDINT(D1))
15871 c
15872 c FFEINTRIN_imp_INT_R:
15873 c
15874 c FFEINTRIN_specIFIX
15875         call fooI(IFIX(R1))
15876 c FFEINTRIN_specINT
15877         call fooI(INT(R1))
15878 c
15879 c FFEINTRIN_imp_REAL_D:
15880 c
15881 c FFEINTRIN_specSNGL
15882         call fooR(SNGL(D1))
15883 c
15884 c FFEINTRIN_imp_REAL_I:
15885 c
15886 c FFEINTRIN_specFLOAT
15887         call fooR(FLOAT(I1))
15888 c FFEINTRIN_specREAL
15889         call fooR(REAL(I1))
15890 c
15891         end
15892 -------- (end input file to f2c)
15893
15894 -------- (begin output from providing above input file as input to:
15895 --------  `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
15896 --------     -e "s:^#.*$::g"')
15897
15898 //  -- translated by f2c (version 19950223).
15899    You must link the resulting object file with the libraries:
15900         -lf2c -lm   (in that order)
15901 //
15902
15903
15904 // f2c.h  --  Standard Fortran to C header file //
15905
15906 ///  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
15907
15908         - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
15909
15910
15911
15912
15913 // F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems //
15914 // we assume short, float are OK //
15915 typedef long int // long int // integer;
15916 typedef char *address;
15917 typedef short int shortint;
15918 typedef float real;
15919 typedef double doublereal;
15920 typedef struct { real r, i; } complex;
15921 typedef struct { doublereal r, i; } doublecomplex;
15922 typedef long int // long int // logical;
15923 typedef short int shortlogical;
15924 typedef char logical1;
15925 typedef char integer1;
15926 // typedef long long longint; // // system-dependent //
15927
15928
15929
15930
15931 // Extern is for use with -E //
15932
15933
15934
15935
15936 // I/O stuff //
15937
15938
15939
15940
15941
15942
15943
15944
15945 typedef long int // int or long int // flag;
15946 typedef long int // int or long int // ftnlen;
15947 typedef long int // int or long int // ftnint;
15948
15949
15950 //external read, write//
15951 typedef struct
15952 {       flag cierr;
15953         ftnint ciunit;
15954         flag ciend;
15955         char *cifmt;
15956         ftnint cirec;
15957 } cilist;
15958
15959 //internal read, write//
15960 typedef struct
15961 {       flag icierr;
15962         char *iciunit;
15963         flag iciend;
15964         char *icifmt;
15965         ftnint icirlen;
15966         ftnint icirnum;
15967 } icilist;
15968
15969 //open//
15970 typedef struct
15971 {       flag oerr;
15972         ftnint ounit;
15973         char *ofnm;
15974         ftnlen ofnmlen;
15975         char *osta;
15976         char *oacc;
15977         char *ofm;
15978         ftnint orl;
15979         char *oblnk;
15980 } olist;
15981
15982 //close//
15983 typedef struct
15984 {       flag cerr;
15985         ftnint cunit;
15986         char *csta;
15987 } cllist;
15988
15989 //rewind, backspace, endfile//
15990 typedef struct
15991 {       flag aerr;
15992         ftnint aunit;
15993 } alist;
15994
15995 // inquire //
15996 typedef struct
15997 {       flag inerr;
15998         ftnint inunit;
15999         char *infile;
16000         ftnlen infilen;
16001         ftnint  *inex;  //parameters in standard's order//
16002         ftnint  *inopen;
16003         ftnint  *innum;
16004         ftnint  *innamed;
16005         char    *inname;
16006         ftnlen  innamlen;
16007         char    *inacc;
16008         ftnlen  inacclen;
16009         char    *inseq;
16010         ftnlen  inseqlen;
16011         char    *indir;
16012         ftnlen  indirlen;
16013         char    *infmt;
16014         ftnlen  infmtlen;
16015         char    *inform;
16016         ftnint  informlen;
16017         char    *inunf;
16018         ftnlen  inunflen;
16019         ftnint  *inrecl;
16020         ftnint  *innrec;
16021         char    *inblank;
16022         ftnlen  inblanklen;
16023 } inlist;
16024
16025
16026
16027 union Multitype {       // for multiple entry points //
16028         integer1 g;
16029         shortint h;
16030         integer i;
16031         // longint j; //
16032         real r;
16033         doublereal d;
16034         complex c;
16035         doublecomplex z;
16036         };
16037
16038 typedef union Multitype Multitype;
16039
16040 typedef long Long;      // No longer used; formerly in Namelist //
16041
16042 struct Vardesc {        // for Namelist //
16043         char *name;
16044         char *addr;
16045         ftnlen *dims;
16046         int  type;
16047         };
16048 typedef struct Vardesc Vardesc;
16049
16050 struct Namelist {
16051         char *name;
16052         Vardesc **vars;
16053         int nvars;
16054         };
16055 typedef struct Namelist Namelist;
16056
16057
16058
16059
16060
16061
16062
16063
16064 // procedure parameter types for -A and -C++ //
16065
16066
16067
16068
16069 typedef int // Unknown procedure type // (*U_fp)();
16070 typedef shortint (*J_fp)();
16071 typedef integer (*I_fp)();
16072 typedef real (*R_fp)();
16073 typedef doublereal (*D_fp)(), (*E_fp)();
16074 typedef // Complex // void  (*C_fp)();
16075 typedef // Double Complex // void  (*Z_fp)();
16076 typedef logical (*L_fp)();
16077 typedef shortlogical (*K_fp)();
16078 typedef // Character // void  (*H_fp)();
16079 typedef // Subroutine // int (*S_fp)();
16080
16081 // E_fp is for real functions when -R is not specified //
16082 typedef void  C_f;      // complex function //
16083 typedef void  H_f;      // character function //
16084 typedef void  Z_f;      // double complex function //
16085 typedef doublereal E_f; // real function with -R not specified //
16086
16087 // undef any lower-case symbols that your C compiler predefines, e.g.: //
16088
16089
16090 // (No such symbols should be defined in a strict ANSI C compiler.
16091    We can avoid trouble with f2c-translated code by using
16092    gcc -ansi.) //
16093
16094
16095
16096
16097
16098
16099
16100
16101
16102
16103
16104
16105
16106
16107
16108
16109
16110
16111
16112
16113
16114
16115
16116 // Main program // MAIN__()
16117 {
16118     // System generated locals //
16119     integer i__1;
16120     real r__1, r__2;
16121     doublereal d__1, d__2;
16122     complex q__1;
16123     doublecomplex z__1, z__2, z__3;
16124     logical L__1;
16125     char ch__1[1];
16126
16127     // Builtin functions //
16128     void c_div();
16129     integer pow_ii();
16130     double pow_ri(), pow_di();
16131     void pow_ci();
16132     double pow_dd();
16133     void pow_zz();
16134     double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
16135             asin(), atan(), atan2(), c_abs();
16136     void c_cos(), c_exp(), c_log(), r_cnjg();
16137     double cos(), cosh();
16138     void c_sin(), c_sqrt();
16139     double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
16140             d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
16141     integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
16142     logical l_ge(), l_gt(), l_le(), l_lt();
16143     integer i_nint();
16144     double r_sign();
16145
16146     // Local variables //
16147     extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
16148             fool_(), fooz_(), getem_();
16149     static char a1[10], a2[10];
16150     static complex c1, c2;
16151     static doublereal d1, d2;
16152     static integer i1, i2;
16153     static real r1, r2;
16154
16155
16156     getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L);
16157 // / //
16158     i__1 = i1 / i2;
16159     fooi_(&i__1);
16160     r__1 = r1 / i1;
16161     foor_(&r__1);
16162     d__1 = d1 / i1;
16163     food_(&d__1);
16164     d__1 = (doublereal) i1;
16165     q__1.r = c1.r / d__1, q__1.i = c1.i / d__1;
16166     fooc_(&q__1);
16167     r__1 = r1 / r2;
16168     foor_(&r__1);
16169     d__1 = r1 / d1;
16170     food_(&d__1);
16171     d__1 = d1 / d2;
16172     food_(&d__1);
16173     d__1 = d1 / r1;
16174     food_(&d__1);
16175     c_div(&q__1, &c1, &c2);
16176     fooc_(&q__1);
16177     q__1.r = c1.r / r1, q__1.i = c1.i / r1;
16178     fooc_(&q__1);
16179     z__1.r = c1.r / d1, z__1.i = c1.i / d1;
16180     fooz_(&z__1);
16181 // ** //
16182     i__1 = pow_ii(&i1, &i2);
16183     fooi_(&i__1);
16184     r__1 = pow_ri(&r1, &i1);
16185     foor_(&r__1);
16186     d__1 = pow_di(&d1, &i1);
16187     food_(&d__1);
16188     pow_ci(&q__1, &c1, &i1);
16189     fooc_(&q__1);
16190     d__1 = (doublereal) r1;
16191     d__2 = (doublereal) r2;
16192     r__1 = pow_dd(&d__1, &d__2);
16193     foor_(&r__1);
16194     d__2 = (doublereal) r1;
16195     d__1 = pow_dd(&d__2, &d1);
16196     food_(&d__1);
16197     d__1 = pow_dd(&d1, &d2);
16198     food_(&d__1);
16199     d__2 = (doublereal) r1;
16200     d__1 = pow_dd(&d1, &d__2);
16201     food_(&d__1);
16202     z__2.r = c1.r, z__2.i = c1.i;
16203     z__3.r = c2.r, z__3.i = c2.i;
16204     pow_zz(&z__1, &z__2, &z__3);
16205     q__1.r = z__1.r, q__1.i = z__1.i;
16206     fooc_(&q__1);
16207     z__2.r = c1.r, z__2.i = c1.i;
16208     z__3.r = r1, z__3.i = 0.;
16209     pow_zz(&z__1, &z__2, &z__3);
16210     q__1.r = z__1.r, q__1.i = z__1.i;
16211     fooc_(&q__1);
16212     z__2.r = c1.r, z__2.i = c1.i;
16213     z__3.r = d1, z__3.i = 0.;
16214     pow_zz(&z__1, &z__2, &z__3);
16215     fooz_(&z__1);
16216 // FFEINTRIN_impABS //
16217     r__1 = (doublereal)((  r1  ) >= 0 ? (  r1  ) : -(  r1  ))  ;
16218     foor_(&r__1);
16219 // FFEINTRIN_impACOS //
16220     r__1 = acos(r1);
16221     foor_(&r__1);
16222 // FFEINTRIN_impAIMAG //
16223     r__1 = r_imag(&c1);
16224     foor_(&r__1);
16225 // FFEINTRIN_impAINT //
16226     r__1 = r_int(&r1);
16227     foor_(&r__1);
16228 // FFEINTRIN_impALOG //
16229     r__1 = log(r1);
16230     foor_(&r__1);
16231 // FFEINTRIN_impALOG10 //
16232     r__1 = r_lg10(&r1);
16233     foor_(&r__1);
16234 // FFEINTRIN_impAMAX0 //
16235     r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16236     foor_(&r__1);
16237 // FFEINTRIN_impAMAX1 //
16238     r__1 = (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16239     foor_(&r__1);
16240 // FFEINTRIN_impAMIN0 //
16241     r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16242     foor_(&r__1);
16243 // FFEINTRIN_impAMIN1 //
16244     r__1 = (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16245     foor_(&r__1);
16246 // FFEINTRIN_impAMOD //
16247     r__1 = r_mod(&r1, &r2);
16248     foor_(&r__1);
16249 // FFEINTRIN_impANINT //
16250     r__1 = r_nint(&r1);
16251     foor_(&r__1);
16252 // FFEINTRIN_impASIN //
16253     r__1 = asin(r1);
16254     foor_(&r__1);
16255 // FFEINTRIN_impATAN //
16256     r__1 = atan(r1);
16257     foor_(&r__1);
16258 // FFEINTRIN_impATAN2 //
16259     r__1 = atan2(r1, r2);
16260     foor_(&r__1);
16261 // FFEINTRIN_impCABS //
16262     r__1 = c_abs(&c1);
16263     foor_(&r__1);
16264 // FFEINTRIN_impCCOS //
16265     c_cos(&q__1, &c1);
16266     fooc_(&q__1);
16267 // FFEINTRIN_impCEXP //
16268     c_exp(&q__1, &c1);
16269     fooc_(&q__1);
16270 // FFEINTRIN_impCHAR //
16271     *(unsigned char *)&ch__1[0] = i1;
16272     fooa_(ch__1, 1L);
16273 // FFEINTRIN_impCLOG //
16274     c_log(&q__1, &c1);
16275     fooc_(&q__1);
16276 // FFEINTRIN_impCONJG //
16277     r_cnjg(&q__1, &c1);
16278     fooc_(&q__1);
16279 // FFEINTRIN_impCOS //
16280     r__1 = cos(r1);
16281     foor_(&r__1);
16282 // FFEINTRIN_impCOSH //
16283     r__1 = cosh(r1);
16284     foor_(&r__1);
16285 // FFEINTRIN_impCSIN //
16286     c_sin(&q__1, &c1);
16287     fooc_(&q__1);
16288 // FFEINTRIN_impCSQRT //
16289     c_sqrt(&q__1, &c1);
16290     fooc_(&q__1);
16291 // FFEINTRIN_impDABS //
16292     d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ;
16293     food_(&d__1);
16294 // FFEINTRIN_impDACOS //
16295     d__1 = acos(d1);
16296     food_(&d__1);
16297 // FFEINTRIN_impDASIN //
16298     d__1 = asin(d1);
16299     food_(&d__1);
16300 // FFEINTRIN_impDATAN //
16301     d__1 = atan(d1);
16302     food_(&d__1);
16303 // FFEINTRIN_impDATAN2 //
16304     d__1 = atan2(d1, d2);
16305     food_(&d__1);
16306 // FFEINTRIN_impDCOS //
16307     d__1 = cos(d1);
16308     food_(&d__1);
16309 // FFEINTRIN_impDCOSH //
16310     d__1 = cosh(d1);
16311     food_(&d__1);
16312 // FFEINTRIN_impDDIM //
16313     d__1 = d_dim(&d1, &d2);
16314     food_(&d__1);
16315 // FFEINTRIN_impDEXP //
16316     d__1 = exp(d1);
16317     food_(&d__1);
16318 // FFEINTRIN_impDIM //
16319     r__1 = r_dim(&r1, &r2);
16320     foor_(&r__1);
16321 // FFEINTRIN_impDINT //
16322     d__1 = d_int(&d1);
16323     food_(&d__1);
16324 // FFEINTRIN_impDLOG //
16325     d__1 = log(d1);
16326     food_(&d__1);
16327 // FFEINTRIN_impDLOG10 //
16328     d__1 = d_lg10(&d1);
16329     food_(&d__1);
16330 // FFEINTRIN_impDMAX1 //
16331     d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ;
16332     food_(&d__1);
16333 // FFEINTRIN_impDMIN1 //
16334     d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ;
16335     food_(&d__1);
16336 // FFEINTRIN_impDMOD //
16337     d__1 = d_mod(&d1, &d2);
16338     food_(&d__1);
16339 // FFEINTRIN_impDNINT //
16340     d__1 = d_nint(&d1);
16341     food_(&d__1);
16342 // FFEINTRIN_impDPROD //
16343     d__1 = (doublereal) r1 * r2;
16344     food_(&d__1);
16345 // FFEINTRIN_impDSIGN //
16346     d__1 = d_sign(&d1, &d2);
16347     food_(&d__1);
16348 // FFEINTRIN_impDSIN //
16349     d__1 = sin(d1);
16350     food_(&d__1);
16351 // FFEINTRIN_impDSINH //
16352     d__1 = sinh(d1);
16353     food_(&d__1);
16354 // FFEINTRIN_impDSQRT //
16355     d__1 = sqrt(d1);
16356     food_(&d__1);
16357 // FFEINTRIN_impDTAN //
16358     d__1 = tan(d1);
16359     food_(&d__1);
16360 // FFEINTRIN_impDTANH //
16361     d__1 = tanh(d1);
16362     food_(&d__1);
16363 // FFEINTRIN_impEXP //
16364     r__1 = exp(r1);
16365     foor_(&r__1);
16366 // FFEINTRIN_impIABS //
16367     i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ;
16368     fooi_(&i__1);
16369 // FFEINTRIN_impICHAR //
16370     i__1 = *(unsigned char *)a1;
16371     fooi_(&i__1);
16372 // FFEINTRIN_impIDIM //
16373     i__1 = i_dim(&i1, &i2);
16374     fooi_(&i__1);
16375 // FFEINTRIN_impIDNINT //
16376     i__1 = i_dnnt(&d1);
16377     fooi_(&i__1);
16378 // FFEINTRIN_impINDEX //
16379     i__1 = i_indx(a1, a2, 10L, 10L);
16380     fooi_(&i__1);
16381 // FFEINTRIN_impISIGN //
16382     i__1 = i_sign(&i1, &i2);
16383     fooi_(&i__1);
16384 // FFEINTRIN_impLEN //
16385     i__1 = i_len(a1, 10L);
16386     fooi_(&i__1);
16387 // FFEINTRIN_impLGE //
16388     L__1 = l_ge(a1, a2, 10L, 10L);
16389     fool_(&L__1);
16390 // FFEINTRIN_impLGT //
16391     L__1 = l_gt(a1, a2, 10L, 10L);
16392     fool_(&L__1);
16393 // FFEINTRIN_impLLE //
16394     L__1 = l_le(a1, a2, 10L, 10L);
16395     fool_(&L__1);
16396 // FFEINTRIN_impLLT //
16397     L__1 = l_lt(a1, a2, 10L, 10L);
16398     fool_(&L__1);
16399 // FFEINTRIN_impMAX0 //
16400     i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16401     fooi_(&i__1);
16402 // FFEINTRIN_impMAX1 //
16403     i__1 = (integer) (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16404     fooi_(&i__1);
16405 // FFEINTRIN_impMIN0 //
16406     i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16407     fooi_(&i__1);
16408 // FFEINTRIN_impMIN1 //
16409     i__1 = (integer) (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16410     fooi_(&i__1);
16411 // FFEINTRIN_impMOD //
16412     i__1 = i1 % i2;
16413     fooi_(&i__1);
16414 // FFEINTRIN_impNINT //
16415     i__1 = i_nint(&r1);
16416     fooi_(&i__1);
16417 // FFEINTRIN_impSIGN //
16418     r__1 = r_sign(&r1, &r2);
16419     foor_(&r__1);
16420 // FFEINTRIN_impSIN //
16421     r__1 = sin(r1);
16422     foor_(&r__1);
16423 // FFEINTRIN_impSINH //
16424     r__1 = sinh(r1);
16425     foor_(&r__1);
16426 // FFEINTRIN_impSQRT //
16427     r__1 = sqrt(r1);
16428     foor_(&r__1);
16429 // FFEINTRIN_impTAN //
16430     r__1 = tan(r1);
16431     foor_(&r__1);
16432 // FFEINTRIN_impTANH //
16433     r__1 = tanh(r1);
16434     foor_(&r__1);
16435 // FFEINTRIN_imp_CMPLX_C //
16436     r__1 = c1.r;
16437     r__2 = c2.r;
16438     q__1.r = r__1, q__1.i = r__2;
16439     fooc_(&q__1);
16440 // FFEINTRIN_imp_CMPLX_D //
16441     z__1.r = d1, z__1.i = d2;
16442     fooz_(&z__1);
16443 // FFEINTRIN_imp_CMPLX_I //
16444     r__1 = (real) i1;
16445     r__2 = (real) i2;
16446     q__1.r = r__1, q__1.i = r__2;
16447     fooc_(&q__1);
16448 // FFEINTRIN_imp_CMPLX_R //
16449     q__1.r = r1, q__1.i = r2;
16450     fooc_(&q__1);
16451 // FFEINTRIN_imp_DBLE_C //
16452     d__1 = (doublereal) c1.r;
16453     food_(&d__1);
16454 // FFEINTRIN_imp_DBLE_D //
16455     d__1 = d1;
16456     food_(&d__1);
16457 // FFEINTRIN_imp_DBLE_I //
16458     d__1 = (doublereal) i1;
16459     food_(&d__1);
16460 // FFEINTRIN_imp_DBLE_R //
16461     d__1 = (doublereal) r1;
16462     food_(&d__1);
16463 // FFEINTRIN_imp_INT_C //
16464     i__1 = (integer) c1.r;
16465     fooi_(&i__1);
16466 // FFEINTRIN_imp_INT_D //
16467     i__1 = (integer) d1;
16468     fooi_(&i__1);
16469 // FFEINTRIN_imp_INT_I //
16470     i__1 = i1;
16471     fooi_(&i__1);
16472 // FFEINTRIN_imp_INT_R //
16473     i__1 = (integer) r1;
16474     fooi_(&i__1);
16475 // FFEINTRIN_imp_REAL_C //
16476     r__1 = c1.r;
16477     foor_(&r__1);
16478 // FFEINTRIN_imp_REAL_D //
16479     r__1 = (real) d1;
16480     foor_(&r__1);
16481 // FFEINTRIN_imp_REAL_I //
16482     r__1 = (real) i1;
16483     foor_(&r__1);
16484 // FFEINTRIN_imp_REAL_R //
16485     r__1 = r1;
16486     foor_(&r__1);
16487
16488 // FFEINTRIN_imp_INT_D: //
16489
16490 // FFEINTRIN_specIDINT //
16491     i__1 = (integer) d1;
16492     fooi_(&i__1);
16493
16494 // FFEINTRIN_imp_INT_R: //
16495
16496 // FFEINTRIN_specIFIX //
16497     i__1 = (integer) r1;
16498     fooi_(&i__1);
16499 // FFEINTRIN_specINT //
16500     i__1 = (integer) r1;
16501     fooi_(&i__1);
16502
16503 // FFEINTRIN_imp_REAL_D: //
16504
16505 // FFEINTRIN_specSNGL //
16506     r__1 = (real) d1;
16507     foor_(&r__1);
16508
16509 // FFEINTRIN_imp_REAL_I: //
16510
16511 // FFEINTRIN_specFLOAT //
16512     r__1 = (real) i1;
16513     foor_(&r__1);
16514 // FFEINTRIN_specREAL //
16515     r__1 = (real) i1;
16516     foor_(&r__1);
16517
16518 } // MAIN__ //
16519
16520 -------- (end output file from f2c)
16521
16522 */
16523
16524 #include "gt-f-com.h"
16525 #include "gtype-f.h"