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 to be checked against.
 642    `element' is the subscript expression to check.
 643    `dim' is the dimension number (starting at 0).
 644    `total_dims' is the total number of dimensions (0 for CHARACTER substring).
 645 */
 646
 647 static tree
 648 ffecom_subscript_check_ (tree array, tree element, int dim, int total_dims,
 649                          const char *array_name)
 650 {
 651   tree low = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
 652   tree high = TYPE_MAX_VALUE (TYPE_DOMAIN (array));
 653   tree cond;
 654   tree die;
 655   tree args;
 656
 657   if (element == error_mark_node)
 658     return element;
 659
 660   if (TREE_TYPE (low) != TREE_TYPE (element))
 661     {
 662       if (TYPE_PRECISION (TREE_TYPE (low))
 663           > TYPE_PRECISION (TREE_TYPE (element)))
 664         element = convert (TREE_TYPE (low), element);
 665       else
 666         {
 667           low = convert (TREE_TYPE (element), low);
 668           if (high)
 669             high = convert (TREE_TYPE (element), high);
 670         }
 671     }
 672
 673   element = ffecom_save_tree (element);
 674   if (total_dims == 0)
 675     {
 676       /* Special handling for substring range checks.  Fortran allows the
 677          end subscript < begin subscript, which means that expressions like
 678        string(1:0) are valid (and yield a null string).  In view of this,
 679        enforce two simpler conditions:
 680           1) element<=high for end-substring;
 681           2) element>=low for start-substring.
 682        Run-time character movement will enforce remaining conditions.
 683
 684        More complicated checks would be better, but present structure only
 685        provides one index element at a time, so it is not possible to
 686        enforce a check of both i and j in string(i:j).  If it were, the
 687        complete set of rules would read,
 688          if ( ((j<i) && ((low<=i<=high) || (low<=j<=high))) ||
 689               ((low<=i<=high) && (low<=j<=high)) )
 690            ok ;
 691          else
 692            range error ;
 693       */
 694       if (dim)
 695         cond = ffecom_2 (LE_EXPR, integer_type_node, element, high);
 696       else
 697         cond = ffecom_2 (LE_EXPR, integer_type_node, low, element);
 698     }
 699   else
 700     {
 701       /* Array reference substring range checking.  */
 702
 703       cond = ffecom_2 (LE_EXPR, integer_type_node,
 704                      low,
 705                      element);
 706       if (high)
 707         {
 708           cond = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
 709                          cond,
 710                          ffecom_2 (LE_EXPR, integer_type_node,
 711                                    element,
 712                                    high));
 713         }
 714     }
 715
 716   {
 717     int len;
 718     char *proc;
 719     char *var;
 720     tree arg3;
 721     tree arg2;
 722     tree arg1;
 723     tree arg4;
 724
 725     switch (total_dims)
 726       {
 727       case 0:
 728         var = concat (array_name, "[", (dim ? "end" : "start"),
 729                       "-substring]", NULL);
 730         len = strlen (var) + 1;
 731         arg1 = build_string (len, var);
 732         free (var);
 733         break;
 734
 735       case 1:
 736         len = strlen (array_name) + 1;
 737         arg1 = build_string (len, array_name);
 738         break;
 739
 740       default:
 741         var = xmalloc (strlen (array_name) + 40);
 742         sprintf (var, "%s[subscript-%d-of-%d]",
 743                  array_name,
 744                  dim + 1, total_dims);
 745         len = strlen (var) + 1;
 746         arg1 = build_string (len, var);
 747         free (var);
 748         break;
 749       }
 750
 751     TREE_TYPE (arg1)
 752       = build_type_variant (build_array_type (char_type_node,
 753                                               build_range_type
 754                                               (integer_type_node,
 755                                                integer_one_node,
 756                                                build_int_2 (len, 0))),
 757                             1, 0);
 758     TREE_CONSTANT (arg1) = 1;
 759     TREE_STATIC (arg1) = 1;
 760     arg1 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg1)),
 761                      arg1);
 762
 763     /* s_rnge adds one to the element to print it, so bias against
 764        that -- want to print a faithful *subscript* value.  */
 765     arg2 = convert (ffecom_f2c_ftnint_type_node,
 766                     ffecom_2 (MINUS_EXPR,
 767                               TREE_TYPE (element),
 768                               element,
 769                               convert (TREE_TYPE (element),
 770                                        integer_one_node)));
 771
 772     proc = concat (input_filename, "/",
 773                    IDENTIFIER_POINTER (DECL_NAME (current_function_decl)),
 774                    NULL);
 775     len = strlen (proc) + 1;
 776     arg3 = build_string (len, proc);
 777
 778     free (proc);
 779
 780     TREE_TYPE (arg3)
 781       = build_type_variant (build_array_type (char_type_node,
 782                                               build_range_type
 783                                               (integer_type_node,
 784                                                integer_one_node,
 785                                                build_int_2 (len, 0))),
 786                             1, 0);
 787     TREE_CONSTANT (arg3) = 1;
 788     TREE_STATIC (arg3) = 1;
 789     arg3 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg3)),
 790                      arg3);
 791
 792     arg4 = convert (ffecom_f2c_ftnint_type_node,
 793                     build_int_2 (input_line, 0));
 794
 795     arg1 = build_tree_list (NULL_TREE, arg1);
 796     arg2 = build_tree_list (NULL_TREE, arg2);
 797     arg3 = build_tree_list (NULL_TREE, arg3);
 798     arg4 = build_tree_list (NULL_TREE, arg4);
 799     TREE_CHAIN (arg3) = arg4;
 800     TREE_CHAIN (arg2) = arg3;
 801     TREE_CHAIN (arg1) = arg2;
 802
 803     args = arg1;
 804   }
 805   die = ffecom_call_gfrt (FFECOM_gfrtRANGE,
 806                           args, NULL_TREE);
 807   TREE_SIDE_EFFECTS (die) = 1;
 808   die = convert (void_type_node, die);
 809
 810   element = ffecom_3 (COND_EXPR,
 811                       TREE_TYPE (element),
 812                       cond,
 813                       element,
 814                       die);
 815
 816   return element;
 817 }
 818
 819 /* Return the computed element of an array reference.
 820
 821    `item' is NULL_TREE, or the transformed pointer to the array.
 822    `expr' is the original opARRAYREF expression, which is transformed
 823      if `item' is NULL_TREE.
 824    `want_ptr' is nonzero if a pointer to the element, instead of
 825      the element itself, is to be returned.  */
 826
 827 static tree
 828 ffecom_arrayref_ (tree item, ffebld expr, int want_ptr)
 829 {
 830   ffebld dims[FFECOM_dimensionsMAX];
 831   int i;
 832   int total_dims;
 833   int flatten = ffe_is_flatten_arrays ();
 834   int need_ptr;
 835   tree array;
 836   tree element;
 837   tree tree_type;
 838   tree tree_type_x;
 839   const char *array_name;
 840   ffetype type;
 841   ffebld list;
 842
 843   if (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER)
 844     array_name = ffesymbol_text (ffebld_symter (ffebld_left (expr)));
 845   else
 846     array_name = "[expr?]";
 847
 848   /* Build up ARRAY_REFs in reverse order (since we're column major
 849      here in Fortran land). */
 850
 851   for (i = 0, list = ffebld_right (expr);
 852        list != NULL;
 853        ++i, list = ffebld_trail (list))
 854     {
 855       dims[i] = ffebld_head (list);
 856       type = ffeinfo_type (ffebld_basictype (dims[i]),
 857                            ffebld_kindtype (dims[i]));
 858       if (! flatten
 859           && ffecom_typesize_pointer_ > ffecom_typesize_integer1_
 860           && ffetype_size (type) > ffecom_typesize_integer1_)
 861         /* E.g. ARRAY(INDEX), given INTEGER*8 INDEX, on a system with 64-bit
 862            pointers and 32-bit integers.  Do the full 64-bit pointer
 863            arithmetic, for codes using arrays for nonstandard heap-like
 864            work.  */
 865         flatten = 1;
 866     }
 867
 868   total_dims = i;
 869
 870   need_ptr = want_ptr || flatten;
 871
 872   if (! item)
 873     {
 874       if (need_ptr)
 875         item = ffecom_ptr_to_expr (ffebld_left (expr));
 876       else
 877         item = ffecom_expr (ffebld_left (expr));
 878
 879       if (item == error_mark_node)
 880         return item;
 881
 882       if (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereFLEETING
 883           && ! ffe_mark_addressable (item))
 884         return error_mark_node;
 885     }
 886
 887   if (item == error_mark_node)
 888     return item;
 889
 890   if (need_ptr)
 891     {
 892       tree min;
 893
 894       for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
 895            i >= 0;
 896            --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array)))
 897         {
 898           min = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
 899           element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
 900           if (flag_bounds_check)
 901             element = ffecom_subscript_check_ (array, element, i, total_dims,
 902                                                array_name);
 903           if (element == error_mark_node)
 904             return element;
 905
 906           /* Widen integral arithmetic as desired while preserving
 907              signedness.  */
 908           tree_type = TREE_TYPE (element);
 909           tree_type_x = tree_type;
 910           if (tree_type
 911               && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
 912               && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
 913             tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
 914
 915           if (TREE_TYPE (min) != tree_type_x)
 916             min = convert (tree_type_x, min);
 917           if (TREE_TYPE (element) != tree_type_x)
 918             element = convert (tree_type_x, element);
 919
 920           item = ffecom_2 (PLUS_EXPR,
 921                            build_pointer_type (TREE_TYPE (array)),
 922                            item,
 923                            size_binop (MULT_EXPR,
 924                                        size_in_bytes (TREE_TYPE (array)),
 925                                        convert (sizetype,
 926                                                 fold (build (MINUS_EXPR,
 927                                                              tree_type_x,
 928                                                              element, min)))));
 929         }
 930       if (! want_ptr)
 931         {
 932           item = ffecom_1 (INDIRECT_REF,
 933                            TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
 934                            item);
 935         }
 936     }
 937   else
 938     {
 939       for (--i;
 940            i >= 0;
 941            --i)
 942         {
 943           array = TYPE_MAIN_VARIANT (TREE_TYPE (item));
 944
 945           element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
 946           if (flag_bounds_check)
 947             element = ffecom_subscript_check_ (array, element, i, total_dims,
 948                                                array_name);
 949           if (element == error_mark_node)
 950             return element;
 951
 952           /* Widen integral arithmetic as desired while preserving
 953              signedness.  */
 954           tree_type = TREE_TYPE (element);
 955           tree_type_x = tree_type;
 956           if (tree_type
 957               && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
 958               && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
 959             tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
 960
 961           element = convert (tree_type_x, element);
 962
 963           item = ffecom_2 (ARRAY_REF,
 964                            TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
 965                            item,
 966                            element);
 967         }
 968     }
 969
 970   return item;
 971 }
 972
 973 /* This is like gcc's stabilize_reference -- in fact, most of the code
 974    comes from that -- but it handles the situation where the reference
 975    is going to have its subparts picked at, and it shouldn't change
 976    (or trigger extra invocations of functions in the subtrees) due to
 977    this.  save_expr is a bit overzealous, because we don't need the
 978    entire thing calculated and saved like a temp.  So, for DECLs, no
 979    change is needed, because these are stable aggregates, and ARRAY_REF
 980    and such might well be stable too, but for things like calculations,
 981    we do need to calculate a snapshot of a value before picking at it.  */
 982
 983 static tree
 984 ffecom_stabilize_aggregate_ (tree ref)
 985 {
 986   tree result;
 987   enum tree_code code = TREE_CODE (ref);
 988
 989   switch (code)
 990     {
 991     case VAR_DECL:
 992     case PARM_DECL:
 993     case RESULT_DECL:
 994       /* No action is needed in this case.  */
 995       return ref;
 996
 997     case NOP_EXPR:
 998     case CONVERT_EXPR:
 999     case FLOAT_EXPR:
1000     case FIX_TRUNC_EXPR:
1001     case FIX_FLOOR_EXPR:
1002     case FIX_ROUND_EXPR:
1003     case FIX_CEIL_EXPR:
1004       result = build_nt (code, stabilize_reference (TREE_OPERAND (ref, 0)));
1005       break;
1006
1007     case INDIRECT_REF:
1008       result = build_nt (INDIRECT_REF,
1009                          stabilize_reference_1 (TREE_OPERAND (ref, 0)));
1010       break;
1011
1012     case COMPONENT_REF:
1013       result = build_nt (COMPONENT_REF,
1014                          stabilize_reference (TREE_OPERAND (ref, 0)),
1015                          TREE_OPERAND (ref, 1));
1016       break;
1017
1018     case BIT_FIELD_REF:
1019       result = build_nt (BIT_FIELD_REF,
1020                          stabilize_reference (TREE_OPERAND (ref, 0)),
1021                          stabilize_reference_1 (TREE_OPERAND (ref, 1)),
1022                          stabilize_reference_1 (TREE_OPERAND (ref, 2)));
1023       break;
1024
1025     case ARRAY_REF:
1026       result = build_nt (ARRAY_REF,
1027                          stabilize_reference (TREE_OPERAND (ref, 0)),
1028                          stabilize_reference_1 (TREE_OPERAND (ref, 1)));
1029       break;
1030
1031     case COMPOUND_EXPR:
1032       result = build_nt (COMPOUND_EXPR,
1033                          stabilize_reference_1 (TREE_OPERAND (ref, 0)),
1034                          stabilize_reference (TREE_OPERAND (ref, 1)));
1035       break;
1036
1037     case RTL_EXPR:
1038       abort ();
1039
1040
1041     default:
1042       return save_expr (ref);
1043
1044     case ERROR_MARK:
1045       return error_mark_node;
1046     }
1047
1048   TREE_TYPE (result) = TREE_TYPE (ref);
1049   TREE_READONLY (result) = TREE_READONLY (ref);
1050   TREE_SIDE_EFFECTS (result) = TREE_SIDE_EFFECTS (ref);
1051   TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref);
1052
1053   return result;
1054 }
1055
1056 /* A rip-off of gcc's convert.c convert_to_complex function,
1057    reworked to handle complex implemented as C structures
1058    (RECORD_TYPE with two fields, real and imaginary `r' and `i').  */
1059
1060 static tree
1061 ffecom_convert_to_complex_ (tree type, tree expr)
1062 {
1063   register enum tree_code form = TREE_CODE (TREE_TYPE (expr));
1064   tree subtype;
1065
1066   assert (TREE_CODE (type) == RECORD_TYPE);
1067
1068   subtype = TREE_TYPE (TYPE_FIELDS (type));
1069
1070   if (form == REAL_TYPE || form == INTEGER_TYPE || form == ENUMERAL_TYPE)
1071     {
1072       expr = convert (subtype, expr);
1073       return ffecom_2 (COMPLEX_EXPR, type, expr,
1074                        convert (subtype, integer_zero_node));
1075     }
1076
1077   if (form == RECORD_TYPE)
1078     {
1079       tree elt_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr)));
1080       if (TYPE_MAIN_VARIANT (elt_type) == TYPE_MAIN_VARIANT (subtype))
1081         return expr;
1082       else
1083         {
1084           expr = save_expr (expr);
1085           return ffecom_2 (COMPLEX_EXPR,
1086                            type,
1087                            convert (subtype,
1088                                     ffecom_1 (REALPART_EXPR,
1089                                               TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1090                                               expr)),
1091                            convert (subtype,
1092                                     ffecom_1 (IMAGPART_EXPR,
1093                                               TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1094                                               expr)));
1095         }
1096     }
1097
1098   if (form == POINTER_TYPE || form == REFERENCE_TYPE)
1099     error ("pointer value used where a complex was expected");
1100   else
1101     error ("aggregate value used where a complex was expected");
1102
1103   return ffecom_2 (COMPLEX_EXPR, type,
1104                    convert (subtype, integer_zero_node),
1105                    convert (subtype, integer_zero_node));
1106 }
1107
1108 /* Like gcc's convert(), but crashes if widening might happen.  */
1109
1110 static tree
1111 ffecom_convert_narrow_ (tree type, tree expr)
1112 {
1113   register tree e = expr;
1114   register enum tree_code code = TREE_CODE (type);
1115
1116   if (type == TREE_TYPE (e)
1117       || TREE_CODE (e) == ERROR_MARK)
1118     return e;
1119   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1120     return fold (build1 (NOP_EXPR, type, e));
1121   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1122       || code == ERROR_MARK)
1123     return error_mark_node;
1124   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1125     {
1126       assert ("void value not ignored as it ought to be" == NULL);
1127       return error_mark_node;
1128     }
1129   assert (code != VOID_TYPE);
1130   if ((code != RECORD_TYPE)
1131       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1132     assert ("converting COMPLEX to REAL" == NULL);
1133   assert (code != ENUMERAL_TYPE);
1134   if (code == INTEGER_TYPE)
1135     {
1136       assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1137                && TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)))
1138               || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1139                   && (TYPE_PRECISION (type)
1140                       == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1141       return fold (convert_to_integer (type, e));
1142     }
1143   if (code == POINTER_TYPE)
1144     {
1145       assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1146       return fold (convert_to_pointer (type, e));
1147     }
1148   if (code == REAL_TYPE)
1149     {
1150       assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1151       assert (TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)));
1152       return fold (convert_to_real (type, e));
1153     }
1154   if (code == COMPLEX_TYPE)
1155     {
1156       assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1157       assert (TYPE_PRECISION (TREE_TYPE (type)) <= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1158       return fold (convert_to_complex (type, e));
1159     }
1160   if (code == RECORD_TYPE)
1161     {
1162       assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1163       /* Check that at least the first field name agrees.  */
1164       assert (DECL_NAME (TYPE_FIELDS (type))
1165               == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1166       assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1167               <= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1168       if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1169           == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1170         return e;
1171       return fold (ffecom_convert_to_complex_ (type, e));
1172     }
1173
1174   assert ("conversion to non-scalar type requested" == NULL);
1175   return error_mark_node;
1176 }
1177
1178 /* Like gcc's convert(), but crashes if narrowing might happen.  */
1179
1180 static tree
1181 ffecom_convert_widen_ (tree type, tree expr)
1182 {
1183   register tree e = expr;
1184   register enum tree_code code = TREE_CODE (type);
1185
1186   if (type == TREE_TYPE (e)
1187       || TREE_CODE (e) == ERROR_MARK)
1188     return e;
1189   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1190     return fold (build1 (NOP_EXPR, type, e));
1191   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1192       || code == ERROR_MARK)
1193     return error_mark_node;
1194   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1195     {
1196       assert ("void value not ignored as it ought to be" == NULL);
1197       return error_mark_node;
1198     }
1199   assert (code != VOID_TYPE);
1200   if ((code != RECORD_TYPE)
1201       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1202     assert ("narrowing COMPLEX to REAL" == NULL);
1203   assert (code != ENUMERAL_TYPE);
1204   if (code == INTEGER_TYPE)
1205     {
1206       assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1207                && TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)))
1208               || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1209                   && (TYPE_PRECISION (type)
1210                       == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1211       return fold (convert_to_integer (type, e));
1212     }
1213   if (code == POINTER_TYPE)
1214     {
1215       assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1216       return fold (convert_to_pointer (type, e));
1217     }
1218   if (code == REAL_TYPE)
1219     {
1220       assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1221       assert (TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)));
1222       return fold (convert_to_real (type, e));
1223     }
1224   if (code == COMPLEX_TYPE)
1225     {
1226       assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1227       assert (TYPE_PRECISION (TREE_TYPE (type)) >= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1228       return fold (convert_to_complex (type, e));
1229     }
1230   if (code == RECORD_TYPE)
1231     {
1232       assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1233       /* Check that at least the first field name agrees.  */
1234       assert (DECL_NAME (TYPE_FIELDS (type))
1235               == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1236       assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1237               >= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1238       if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1239           == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1240         return e;
1241       return fold (ffecom_convert_to_complex_ (type, e));
1242     }
1243
1244   assert ("conversion to non-scalar type requested" == NULL);
1245   return error_mark_node;
1246 }
1247
1248 /* Handles making a COMPLEX type, either the standard
1249    (but buggy?) gbe way, or the safer (but less elegant?)
1250    f2c way.  */
1251
1252 static tree
1253 ffecom_make_complex_type_ (tree subtype)
1254 {
1255   tree type;
1256   tree realfield;
1257   tree imagfield;
1258
1259   if (ffe_is_emulate_complex ())
1260     {
1261       type = make_node (RECORD_TYPE);
1262       realfield = ffecom_decl_field (type, NULL_TREE, "r", subtype);
1263       imagfield = ffecom_decl_field (type, realfield, "i", subtype);
1264       TYPE_FIELDS (type) = realfield;
1265       layout_type (type);
1266     }
1267   else
1268     {
1269       type = make_node (COMPLEX_TYPE);
1270       TREE_TYPE (type) = subtype;
1271       layout_type (type);
1272     }
1273
1274   return type;
1275 }
1276
1277 /* Chooses either the gbe or the f2c way to build a
1278    complex constant.  */
1279
1280 static tree
1281 ffecom_build_complex_constant_ (tree type, tree realpart, tree imagpart)
1282 {
1283   tree bothparts;
1284
1285   if (ffe_is_emulate_complex ())
1286     {
1287       bothparts = build_tree_list (TYPE_FIELDS (type), realpart);
1288       TREE_CHAIN (bothparts) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), imagpart);
1289       bothparts = build_constructor (type, bothparts);
1290     }
1291   else
1292     {
1293       bothparts = build_complex (type, realpart, imagpart);
1294     }
1295
1296   return bothparts;
1297 }
1298
1299 static tree
1300 ffecom_arglist_expr_ (const char *c, ffebld expr)
1301 {
1302   tree list;
1303   tree *plist = &list;
1304   tree trail = NULL_TREE;       /* Append char length args here. */
1305   tree *ptrail = &trail;
1306   tree length;
1307   ffebld exprh;
1308   tree item;
1309   bool ptr = FALSE;
1310   tree wanted = NULL_TREE;
1311   static const char zed[] = "0";
1312
1313   if (c == NULL)
1314     c = &zed[0];
1315
1316   while (expr != NULL)
1317     {
1318       if (*c != '\0')
1319         {
1320           ptr = FALSE;
1321           if (*c == '&')
1322             {
1323               ptr = TRUE;
1324               ++c;
1325             }
1326           switch (*(c++))
1327             {
1328             case '\0':
1329               ptr = TRUE;
1330               wanted = NULL_TREE;
1331               break;
1332
1333             case 'a':
1334               assert (ptr);
1335               wanted = NULL_TREE;
1336               break;
1337
1338             case 'c':
1339               wanted = ffecom_f2c_complex_type_node;
1340               break;
1341
1342             case 'd':
1343               wanted = ffecom_f2c_doublereal_type_node;
1344               break;
1345
1346             case 'e':
1347               wanted = ffecom_f2c_doublecomplex_type_node;
1348               break;
1349
1350             case 'f':
1351               wanted = ffecom_f2c_real_type_node;
1352               break;
1353
1354             case 'i':
1355               wanted = ffecom_f2c_integer_type_node;
1356               break;
1357
1358             case 'j':
1359               wanted = ffecom_f2c_longint_type_node;
1360               break;
1361
1362             default:
1363               assert ("bad argstring code" == NULL);
1364               wanted = NULL_TREE;
1365               break;
1366             }
1367         }
1368
1369       exprh = ffebld_head (expr);
1370       if (exprh == NULL)
1371         wanted = NULL_TREE;
1372
1373       if ((wanted == NULL_TREE)
1374           || (ptr
1375               && (TYPE_MODE
1376                   (ffecom_tree_type[ffeinfo_basictype (ffebld_info (exprh))]
1377                    [ffeinfo_kindtype (ffebld_info (exprh))])
1378                    == TYPE_MODE (wanted))))
1379         *plist
1380           = build_tree_list (NULL_TREE,
1381                              ffecom_arg_ptr_to_expr (exprh,
1382                                                      &length));
1383       else
1384         {
1385           item = ffecom_arg_expr (exprh, &length);
1386           item = ffecom_convert_widen_ (wanted, item);
1387           if (ptr)
1388             {
1389               item = ffecom_1 (ADDR_EXPR,
1390                                build_pointer_type (TREE_TYPE (item)),
1391                                item);
1392             }
1393           *plist
1394             = build_tree_list (NULL_TREE,
1395                                item);
1396         }
1397
1398       plist = &TREE_CHAIN (*plist);
1399       expr = ffebld_trail (expr);
1400       if (length != NULL_TREE)
1401         {
1402           *ptrail = build_tree_list (NULL_TREE, length);
1403           ptrail = &TREE_CHAIN (*ptrail);
1404         }
1405     }
1406
1407   /* We've run out of args in the call; if the implementation expects
1408      more, supply null pointers for them, which the implementation can
1409      check to see if an arg was omitted. */
1410
1411   while (*c != '\0' && *c != '0')
1412     {
1413       if (*c == '&')
1414         ++c;
1415       else
1416         assert ("missing arg to run-time routine!" == NULL);
1417
1418       switch (*(c++))
1419         {
1420         case '\0':
1421         case 'a':
1422         case 'c':
1423         case 'd':
1424         case 'e':
1425         case 'f':
1426         case 'i':
1427         case 'j':
1428           break;
1429
1430         default:
1431           assert ("bad arg string code" == NULL);
1432           break;
1433         }
1434       *plist
1435         = build_tree_list (NULL_TREE,
1436                            null_pointer_node);
1437       plist = &TREE_CHAIN (*plist);
1438     }
1439
1440   *plist = trail;
1441
1442   return list;
1443 }
1444
1445 static tree
1446 ffecom_widest_expr_type_ (ffebld list)
1447 {
1448   ffebld item;
1449   ffebld widest = NULL;
1450   ffetype type;
1451   ffetype widest_type = NULL;
1452   tree t;
1453
1454   for (; list != NULL; list = ffebld_trail (list))
1455     {
1456       item = ffebld_head (list);
1457       if (item == NULL)
1458         continue;
1459       if ((widest != NULL)
1460           && (ffeinfo_basictype (ffebld_info (item))
1461               != ffeinfo_basictype (ffebld_info (widest))))
1462         continue;
1463       type = ffeinfo_type (ffeinfo_basictype (ffebld_info (item)),
1464                            ffeinfo_kindtype (ffebld_info (item)));
1465       if ((widest == FFEINFO_kindtypeNONE)
1466           || (ffetype_size (type)
1467               > ffetype_size (widest_type)))
1468         {
1469           widest = item;
1470           widest_type = type;
1471         }
1472     }
1473
1474   assert (widest != NULL);
1475   t = ffecom_tree_type[ffeinfo_basictype (ffebld_info (widest))]
1476     [ffeinfo_kindtype (ffebld_info (widest))];
1477   assert (t != NULL_TREE);
1478   return t;
1479 }
1480
1481 /* Check whether a partial overlap between two expressions is possible.
1482
1483    Can *starting* to write a portion of expr1 change the value
1484    computed (perhaps already, *partially*) by expr2?
1485
1486    Currently, this is a concern only for a COMPLEX expr1.  But if it
1487    isn't in COMMON or local EQUIVALENCE, since we don't support
1488    aliasing of arguments, it isn't a concern.  */
1489
1490 static bool
1491 ffecom_possible_partial_overlap_ (ffebld expr1, ffebld expr2 ATTRIBUTE_UNUSED)
1492 {
1493   ffesymbol sym;
1494   ffestorag st;
1495
1496   switch (ffebld_op (expr1))
1497     {
1498     case FFEBLD_opSYMTER:
1499       sym = ffebld_symter (expr1);
1500       break;
1501
1502     case FFEBLD_opARRAYREF:
1503       if (ffebld_op (ffebld_left (expr1)) != FFEBLD_opSYMTER)
1504         return FALSE;
1505       sym = ffebld_symter (ffebld_left (expr1));
1506       break;
1507
1508     default:
1509       return FALSE;
1510     }
1511
1512   if (ffesymbol_where (sym) != FFEINFO_whereCOMMON
1513       && (ffesymbol_where (sym) != FFEINFO_whereLOCAL
1514           || ! (st = ffesymbol_storage (sym))
1515           || ! ffestorag_parent (st)))
1516     return FALSE;
1517
1518   /* It's in COMMON or local EQUIVALENCE.  */
1519
1520   return TRUE;
1521 }
1522
1523 /* Check whether dest and source might overlap.  ffebld versions of these
1524    might or might not be passed, will be NULL if not.
1525
1526    The test is really whether source_tree is modifiable and, if modified,
1527    might overlap destination such that the value(s) in the destination might
1528    change before it is finally modified.  dest_* are the canonized
1529    destination itself.  */
1530
1531 static bool
1532 ffecom_overlap_ (tree dest_decl, tree dest_offset, tree dest_size,
1533                  tree source_tree, ffebld source UNUSED, bool scalar_arg)
1534 {
1535   tree source_decl;
1536   tree source_offset;
1537   tree source_size;
1538   tree t;
1539
1540   if (source_tree == NULL_TREE)
1541     return FALSE;
1542
1543   switch (TREE_CODE (source_tree))
1544     {
1545     case ERROR_MARK:
1546     case IDENTIFIER_NODE:
1547     case INTEGER_CST:
1548     case REAL_CST:
1549     case COMPLEX_CST:
1550     case STRING_CST:
1551     case CONST_DECL:
1552     case VAR_DECL:
1553     case RESULT_DECL:
1554     case FIELD_DECL:
1555     case MINUS_EXPR:
1556     case MULT_EXPR:
1557     case TRUNC_DIV_EXPR:
1558     case CEIL_DIV_EXPR:
1559     case FLOOR_DIV_EXPR:
1560     case ROUND_DIV_EXPR:
1561     case TRUNC_MOD_EXPR:
1562     case CEIL_MOD_EXPR:
1563     case FLOOR_MOD_EXPR:
1564     case ROUND_MOD_EXPR:
1565     case RDIV_EXPR:
1566     case EXACT_DIV_EXPR:
1567     case FIX_TRUNC_EXPR:
1568     case FIX_CEIL_EXPR:
1569     case FIX_FLOOR_EXPR:
1570     case FIX_ROUND_EXPR:
1571     case FLOAT_EXPR:
1572     case NEGATE_EXPR:
1573     case MIN_EXPR:
1574     case MAX_EXPR:
1575     case ABS_EXPR:
1576     case FFS_EXPR:
1577     case LSHIFT_EXPR:
1578     case RSHIFT_EXPR:
1579     case LROTATE_EXPR:
1580     case RROTATE_EXPR:
1581     case BIT_IOR_EXPR:
1582     case BIT_XOR_EXPR:
1583     case BIT_AND_EXPR:
1584     case BIT_ANDTC_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);
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);
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);
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
7925                 cst = ffestorag_parent (st);
7926                 assert (cst == ffesymbol_storage (cs));
7927
7928                 offset = ffestorag_modulo (cst)
7929                   + ffestorag_offset (st)
7930                   - ffestorag_offset (cst);
7931
7932                 ffecom_debug_kludge_ (ct, "COMMON", s, type, offset);
7933
7934                 /* (t_type *) (((char *) &ct) + offset) */
7935
7936                 t = convert (string_type_node,  /* (char *) */
7937                              ffecom_1 (ADDR_EXPR,
7938                                        build_pointer_type (TREE_TYPE (ct)),
7939                                        ct));
7940                 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
7941                               t,
7942                               build_int_2 (offset, 0));
7943                 t = convert (build_pointer_type (type),
7944                              t);
7945                 TREE_CONSTANT (t) = 1;
7946
7947                 addr = TRUE;
7948               }
7949           }
7950           break;
7951
7952         case FFEINFO_whereIMMEDIATE:
7953         case FFEINFO_whereGLOBAL:
7954         case FFEINFO_whereFLEETING:
7955         case FFEINFO_whereFLEETING_CADDR:
7956         case FFEINFO_whereFLEETING_IADDR:
7957         case FFEINFO_whereINTRINSIC:
7958         case FFEINFO_whereCONSTANT_SUBOBJECT:
7959         default:
7960           assert ("ENTITY where unheard of" == NULL);
7961           /* Fall through. */
7962         case FFEINFO_whereANY:
7963           t = error_mark_node;
7964           break;
7965         }
7966       break;
7967
7968     case FFEINFO_kindFUNCTION:
7969       switch (ffeinfo_where (ffesymbol_info (s)))
7970         {
7971         case FFEINFO_whereLOCAL:        /* Me. */
7972           assert (!ffecom_transform_only_dummies_);
7973           t = current_function_decl;
7974           break;
7975
7976         case FFEINFO_whereGLOBAL:
7977           assert (!ffecom_transform_only_dummies_);
7978
7979           if (((g = ffesymbol_global (s)) != NULL)
7980               && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7981                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
7982               && (ffeglobal_hook (g) != NULL_TREE)
7983               && ffe_is_globals ())
7984             {
7985               t = ffeglobal_hook (g);
7986               break;
7987             }
7988
7989           if (ffesymbol_is_f2c (s)
7990               && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
7991             t = ffecom_tree_fun_type[bt][kt];
7992           else
7993             t = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
7994
7995           t = build_decl (FUNCTION_DECL,
7996                           ffecom_get_external_identifier_ (s),
7997                           t);
7998           DECL_EXTERNAL (t) = 1;
7999           TREE_PUBLIC (t) = 1;
8000
8001           t = start_decl (t, FALSE);
8002           finish_decl (t, NULL_TREE, FALSE);
8003
8004           if ((g != NULL)
8005               && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8006                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8007             ffeglobal_set_hook (g, t);
8008
8009           ffecom_save_tree_forever (t);
8010
8011           break;
8012
8013         case FFEINFO_whereDUMMY:
8014           assert (ffecom_transform_only_dummies_);
8015
8016           if (ffesymbol_is_f2c (s)
8017               && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8018             t = ffecom_tree_ptr_to_fun_type[bt][kt];
8019           else
8020             t = build_pointer_type
8021               (build_function_type (ffecom_tree_type[bt][kt], NULL_TREE));
8022
8023           t = build_decl (PARM_DECL,
8024                           ffecom_get_identifier_ (ffesymbol_text (s)),
8025                           t);
8026           DECL_ARTIFICIAL (t) = 1;
8027           addr = TRUE;
8028           break;
8029
8030         case FFEINFO_whereCONSTANT:     /* Statement function. */
8031           assert (!ffecom_transform_only_dummies_);
8032           t = ffecom_gen_sfuncdef_ (s, bt, kt);
8033           break;
8034
8035         case FFEINFO_whereINTRINSIC:
8036           assert (!ffecom_transform_only_dummies_);
8037           break;                /* Let actual references generate their
8038                                    decls. */
8039
8040         default:
8041           assert ("FUNCTION where unheard of" == NULL);
8042           /* Fall through. */
8043         case FFEINFO_whereANY:
8044           t = error_mark_node;
8045           break;
8046         }
8047       break;
8048
8049     case FFEINFO_kindSUBROUTINE:
8050       switch (ffeinfo_where (ffesymbol_info (s)))
8051         {
8052         case FFEINFO_whereLOCAL:        /* Me. */
8053           assert (!ffecom_transform_only_dummies_);
8054           t = current_function_decl;
8055           break;
8056
8057         case FFEINFO_whereGLOBAL:
8058           assert (!ffecom_transform_only_dummies_);
8059
8060           if (((g = ffesymbol_global (s)) != NULL)
8061               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8062                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8063               && (ffeglobal_hook (g) != NULL_TREE)
8064               && ffe_is_globals ())
8065             {
8066               t = ffeglobal_hook (g);
8067               break;
8068             }
8069
8070           t = build_decl (FUNCTION_DECL,
8071                           ffecom_get_external_identifier_ (s),
8072                           ffecom_tree_subr_type);
8073           DECL_EXTERNAL (t) = 1;
8074           TREE_PUBLIC (t) = 1;
8075
8076           t = start_decl (t, ffe_is_globals ());
8077           finish_decl (t, NULL_TREE, ffe_is_globals ());
8078
8079           if ((g != NULL)
8080               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8081                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8082             ffeglobal_set_hook (g, t);
8083
8084           ffecom_save_tree_forever (t);
8085
8086           break;
8087
8088         case FFEINFO_whereDUMMY:
8089           assert (ffecom_transform_only_dummies_);
8090
8091           t = build_decl (PARM_DECL,
8092                           ffecom_get_identifier_ (ffesymbol_text (s)),
8093                           ffecom_tree_ptr_to_subr_type);
8094           DECL_ARTIFICIAL (t) = 1;
8095           addr = TRUE;
8096           break;
8097
8098         case FFEINFO_whereINTRINSIC:
8099           assert (!ffecom_transform_only_dummies_);
8100           break;                /* Let actual references generate their
8101                                    decls. */
8102
8103         default:
8104           assert ("SUBROUTINE where unheard of" == NULL);
8105           /* Fall through. */
8106         case FFEINFO_whereANY:
8107           t = error_mark_node;
8108           break;
8109         }
8110       break;
8111
8112     case FFEINFO_kindPROGRAM:
8113       switch (ffeinfo_where (ffesymbol_info (s)))
8114         {
8115         case FFEINFO_whereLOCAL:        /* Me. */
8116           assert (!ffecom_transform_only_dummies_);
8117           t = current_function_decl;
8118           break;
8119
8120         case FFEINFO_whereCOMMON:
8121         case FFEINFO_whereDUMMY:
8122         case FFEINFO_whereGLOBAL:
8123         case FFEINFO_whereRESULT:
8124         case FFEINFO_whereFLEETING:
8125         case FFEINFO_whereFLEETING_CADDR:
8126         case FFEINFO_whereFLEETING_IADDR:
8127         case FFEINFO_whereIMMEDIATE:
8128         case FFEINFO_whereINTRINSIC:
8129         case FFEINFO_whereCONSTANT:
8130         case FFEINFO_whereCONSTANT_SUBOBJECT:
8131         default:
8132           assert ("PROGRAM where unheard of" == NULL);
8133           /* Fall through. */
8134         case FFEINFO_whereANY:
8135           t = error_mark_node;
8136           break;
8137         }
8138       break;
8139
8140     case FFEINFO_kindBLOCKDATA:
8141       switch (ffeinfo_where (ffesymbol_info (s)))
8142         {
8143         case FFEINFO_whereLOCAL:        /* Me. */
8144           assert (!ffecom_transform_only_dummies_);
8145           t = current_function_decl;
8146           break;
8147
8148         case FFEINFO_whereGLOBAL:
8149           assert (!ffecom_transform_only_dummies_);
8150
8151           t = build_decl (FUNCTION_DECL,
8152                           ffecom_get_external_identifier_ (s),
8153                           ffecom_tree_blockdata_type);
8154           DECL_EXTERNAL (t) = 1;
8155           TREE_PUBLIC (t) = 1;
8156
8157           t = start_decl (t, FALSE);
8158           finish_decl (t, NULL_TREE, FALSE);
8159
8160           ffecom_save_tree_forever (t);
8161
8162           break;
8163
8164         case FFEINFO_whereCOMMON:
8165         case FFEINFO_whereDUMMY:
8166         case FFEINFO_whereRESULT:
8167         case FFEINFO_whereFLEETING:
8168         case FFEINFO_whereFLEETING_CADDR:
8169         case FFEINFO_whereFLEETING_IADDR:
8170         case FFEINFO_whereIMMEDIATE:
8171         case FFEINFO_whereINTRINSIC:
8172         case FFEINFO_whereCONSTANT:
8173         case FFEINFO_whereCONSTANT_SUBOBJECT:
8174         default:
8175           assert ("BLOCKDATA where unheard of" == NULL);
8176           /* Fall through. */
8177         case FFEINFO_whereANY:
8178           t = error_mark_node;
8179           break;
8180         }
8181       break;
8182
8183     case FFEINFO_kindCOMMON:
8184       switch (ffeinfo_where (ffesymbol_info (s)))
8185         {
8186         case FFEINFO_whereLOCAL:
8187           assert (!ffecom_transform_only_dummies_);
8188           ffecom_transform_common_ (s);
8189           break;
8190
8191         case FFEINFO_whereNONE:
8192         case FFEINFO_whereCOMMON:
8193         case FFEINFO_whereDUMMY:
8194         case FFEINFO_whereGLOBAL:
8195         case FFEINFO_whereRESULT:
8196         case FFEINFO_whereFLEETING:
8197         case FFEINFO_whereFLEETING_CADDR:
8198         case FFEINFO_whereFLEETING_IADDR:
8199         case FFEINFO_whereIMMEDIATE:
8200         case FFEINFO_whereINTRINSIC:
8201         case FFEINFO_whereCONSTANT:
8202         case FFEINFO_whereCONSTANT_SUBOBJECT:
8203         default:
8204           assert ("COMMON where unheard of" == NULL);
8205           /* Fall through. */
8206         case FFEINFO_whereANY:
8207           t = error_mark_node;
8208           break;
8209         }
8210       break;
8211
8212     case FFEINFO_kindCONSTRUCT:
8213       switch (ffeinfo_where (ffesymbol_info (s)))
8214         {
8215         case FFEINFO_whereLOCAL:
8216           assert (!ffecom_transform_only_dummies_);
8217           break;
8218
8219         case FFEINFO_whereNONE:
8220         case FFEINFO_whereCOMMON:
8221         case FFEINFO_whereDUMMY:
8222         case FFEINFO_whereGLOBAL:
8223         case FFEINFO_whereRESULT:
8224         case FFEINFO_whereFLEETING:
8225         case FFEINFO_whereFLEETING_CADDR:
8226         case FFEINFO_whereFLEETING_IADDR:
8227         case FFEINFO_whereIMMEDIATE:
8228         case FFEINFO_whereINTRINSIC:
8229         case FFEINFO_whereCONSTANT:
8230         case FFEINFO_whereCONSTANT_SUBOBJECT:
8231         default:
8232           assert ("CONSTRUCT where unheard of" == NULL);
8233           /* Fall through. */
8234         case FFEINFO_whereANY:
8235           t = error_mark_node;
8236           break;
8237         }
8238       break;
8239
8240     case FFEINFO_kindNAMELIST:
8241       switch (ffeinfo_where (ffesymbol_info (s)))
8242         {
8243         case FFEINFO_whereLOCAL:
8244           assert (!ffecom_transform_only_dummies_);
8245           t = ffecom_transform_namelist_ (s);
8246           break;
8247
8248         case FFEINFO_whereNONE:
8249         case FFEINFO_whereCOMMON:
8250         case FFEINFO_whereDUMMY:
8251         case FFEINFO_whereGLOBAL:
8252         case FFEINFO_whereRESULT:
8253         case FFEINFO_whereFLEETING:
8254         case FFEINFO_whereFLEETING_CADDR:
8255         case FFEINFO_whereFLEETING_IADDR:
8256         case FFEINFO_whereIMMEDIATE:
8257         case FFEINFO_whereINTRINSIC:
8258         case FFEINFO_whereCONSTANT:
8259         case FFEINFO_whereCONSTANT_SUBOBJECT:
8260         default:
8261           assert ("NAMELIST where unheard of" == NULL);
8262           /* Fall through. */
8263         case FFEINFO_whereANY:
8264           t = error_mark_node;
8265           break;
8266         }
8267       break;
8268
8269     default:
8270       assert ("kind unheard of" == NULL);
8271       /* Fall through. */
8272     case FFEINFO_kindANY:
8273       t = error_mark_node;
8274       break;
8275     }
8276
8277   ffesymbol_hook (s).decl_tree = t;
8278   ffesymbol_hook (s).length_tree = tlen;
8279   ffesymbol_hook (s).addr = addr;
8280
8281   input_location = old_loc;
8282
8283   return s;
8284 }
8285
8286 /* Transform into ASSIGNable symbol.
8287
8288    Symbol has already been transformed, but for whatever reason, the
8289    resulting decl_tree has been deemed not usable for an ASSIGN target.
8290    (E.g. it isn't wide enough to hold a pointer.)  So, here we invent
8291    another local symbol of type void * and stuff that in the assign_tree
8292    argument.  The F77/F90 standards allow this implementation.  */
8293
8294 static ffesymbol
8295 ffecom_sym_transform_assign_ (ffesymbol s)
8296 {
8297   tree t;                       /* Transformed thingy. */
8298   location_t old_loc = input_location;
8299
8300   if (ffesymbol_sfdummyparent (s) == NULL)
8301     {
8302       input_filename = ffesymbol_where_filename (s);
8303       input_line = ffesymbol_where_filelinenum (s);
8304     }
8305   else
8306     {
8307       ffesymbol sf = ffesymbol_sfdummyparent (s);
8308
8309       input_filename = ffesymbol_where_filename (sf);
8310       input_line = ffesymbol_where_filelinenum (sf);
8311     }
8312
8313   assert (!ffecom_transform_only_dummies_);
8314
8315   t = build_decl (VAR_DECL,
8316                   ffecom_get_invented_identifier ("__g77_ASSIGN_%s",
8317                                                    ffesymbol_text (s)),
8318                   TREE_TYPE (null_pointer_node));
8319
8320   switch (ffesymbol_where (s))
8321     {
8322     case FFEINFO_whereLOCAL:
8323       /* Unlike for regular vars, SAVE status is easy to determine for
8324          ASSIGNed vars, since there's no initialization, there's no
8325          effective storage association (so "SAVE J" does not apply to
8326          K even given "EQUIVALENCE (J,K)"), there's no size issue
8327          to worry about, etc.  */
8328       if ((ffesymbol_is_save (s) || ffe_is_saveall ())
8329           && (ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8330           && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA))
8331         TREE_STATIC (t) = 1;    /* SAVEd in proc, make static. */
8332       else
8333         TREE_STATIC (t) = 0;    /* No need to make static. */
8334       break;
8335
8336     case FFEINFO_whereCOMMON:
8337       TREE_STATIC (t) = 1;      /* Assume COMMONs always SAVEd. */
8338       break;
8339
8340     case FFEINFO_whereDUMMY:
8341       /* Note that twinning a DUMMY means the caller won't see
8342          the ASSIGNed value.  But both F77 and F90 allow implementations
8343          to do this, i.e. disallow Fortran code that would try and
8344          take advantage of actually putting a label into a variable
8345          via a dummy argument (or any other storage association, for
8346          that matter).  */
8347       TREE_STATIC (t) = 0;
8348       break;
8349
8350     default:
8351       TREE_STATIC (t) = 0;
8352       break;
8353     }
8354
8355   t = start_decl (t, FALSE);
8356   finish_decl (t, NULL_TREE, FALSE);
8357
8358   ffesymbol_hook (s).assign_tree = t;
8359
8360   input_location = old_loc;
8361
8362   return s;
8363 }
8364
8365 /* Implement COMMON area in back end.
8366
8367    Because COMMON-based variables can be referenced in the dimension
8368    expressions of dummy (adjustable) arrays, and because dummies
8369    (in the gcc back end) need to be put in the outer binding level
8370    of a function (which has two binding levels, the outer holding
8371    the dummies and the inner holding the other vars), special care
8372    must be taken to handle COMMON areas.
8373
8374    The current strategy is basically to always tell the back end about
8375    the COMMON area as a top-level external reference to just a block
8376    of storage of the master type of that area (e.g. integer, real,
8377    character, whatever -- not a structure).  As a distinct action,
8378    if initial values are provided, tell the back end about the area
8379    as a top-level non-external (initialized) area and remember not to
8380    allow further initialization or expansion of the area.  Meanwhile,
8381    if no initialization happens at all, tell the back end about
8382    the largest size we've seen declared so the space does get reserved.
8383    (This function doesn't handle all that stuff, but it does some
8384    of the important things.)
8385
8386    Meanwhile, for COMMON variables themselves, just keep creating
8387    references like *((float *) (&common_area + offset)) each time
8388    we reference the variable.  In other words, don't make a VAR_DECL
8389    or any kind of component reference (like we used to do before 0.4),
8390    though we might do that as well just for debugging purposes (and
8391    stuff the rtl with the appropriate offset expression).  */
8392
8393 static void
8394 ffecom_transform_common_ (ffesymbol s)
8395 {
8396   ffestorag st = ffesymbol_storage (s);
8397   ffeglobal g = ffesymbol_global (s);
8398   tree cbt;
8399   tree cbtype;
8400   tree init;
8401   tree high;
8402   bool is_init = ffestorag_is_init (st);
8403
8404   assert (st != NULL);
8405
8406   if ((g == NULL)
8407       || (ffeglobal_type (g) != FFEGLOBAL_typeCOMMON))
8408     return;
8409
8410   /* First update the size of the area in global terms.  */
8411
8412   ffeglobal_size_common (s, ffestorag_size (st));
8413
8414   if (!ffeglobal_common_init (g))
8415     is_init = FALSE;    /* No explicit init, don't let erroneous joins init. */
8416
8417   cbt = ffeglobal_hook (g);
8418
8419   /* If we already have declared this common block for a previous program
8420      unit, and either we already initialized it or we don't have new
8421      initialization for it, just return what we have without changing it.  */
8422
8423   if ((cbt != NULL_TREE)
8424       && (!is_init
8425           || !DECL_EXTERNAL (cbt)))
8426     {
8427       if (st->hook == NULL) ffestorag_set_hook (st, cbt);
8428       return;
8429     }
8430
8431   /* Process inits.  */
8432
8433   if (is_init)
8434     {
8435       if (ffestorag_init (st) != NULL)
8436         {
8437           ffebld sexp;
8438
8439           /* Set the padding for the expression, so ffecom_expr
8440              knows to insert that many zeros.  */
8441           switch (ffebld_op (sexp = ffestorag_init (st)))
8442             {
8443             case FFEBLD_opCONTER:
8444               ffebld_conter_set_pad (sexp, ffestorag_modulo (st));
8445               break;
8446
8447             case FFEBLD_opARRTER:
8448               ffebld_arrter_set_pad (sexp, ffestorag_modulo (st));
8449               break;
8450
8451             case FFEBLD_opACCTER:
8452               ffebld_accter_set_pad (sexp, ffestorag_modulo (st));
8453               break;
8454
8455             default:
8456               assert ("bad op for cmn init (pad)" == NULL);
8457               break;
8458             }
8459
8460           init = ffecom_expr (sexp);
8461           if (init == error_mark_node)
8462             {                   /* Hopefully the back end complained! */
8463               init = NULL_TREE;
8464               if (cbt != NULL_TREE)
8465                 return;
8466             }
8467         }
8468       else
8469         init = error_mark_node;
8470     }
8471   else
8472     init = NULL_TREE;
8473
8474   /* cbtype must be permanently allocated!  */
8475
8476   /* Allocate the MAX of the areas so far, seen filewide.  */
8477   high = build_int_2 ((ffeglobal_common_size (g)
8478                        + ffeglobal_common_pad (g)) - 1, 0);
8479   TREE_TYPE (high) = ffecom_integer_type_node;
8480
8481   if (init)
8482     cbtype = build_array_type (char_type_node,
8483                                build_range_type (integer_type_node,
8484                                                  integer_zero_node,
8485                                                  high));
8486   else
8487     cbtype = build_array_type (char_type_node, NULL_TREE);
8488
8489   if (cbt == NULL_TREE)
8490     {
8491       cbt
8492         = build_decl (VAR_DECL,
8493                       ffecom_get_external_identifier_ (s),
8494                       cbtype);
8495       TREE_STATIC (cbt) = 1;
8496       TREE_PUBLIC (cbt) = 1;
8497     }
8498   else
8499     {
8500       assert (is_init);
8501       TREE_TYPE (cbt) = cbtype;
8502     }
8503   DECL_EXTERNAL (cbt) = init ? 0 : 1;
8504   DECL_INITIAL (cbt) = init ? error_mark_node : NULL_TREE;
8505
8506   cbt = start_decl (cbt, TRUE);
8507   if (ffeglobal_hook (g) != NULL)
8508     assert (cbt == ffeglobal_hook (g));
8509
8510   assert (!init || !DECL_EXTERNAL (cbt));
8511
8512   /* Make sure that any type can live in COMMON and be referenced
8513      without getting a bus error.  We could pick the most restrictive
8514      alignment of all entities actually placed in the COMMON, but
8515      this seems easy enough.  */
8516
8517   DECL_ALIGN (cbt) = BIGGEST_ALIGNMENT;
8518   DECL_USER_ALIGN (cbt) = 0;
8519
8520   if (is_init && (ffestorag_init (st) == NULL))
8521     init = ffecom_init_zero_ (cbt);
8522
8523   finish_decl (cbt, init, TRUE);
8524
8525   if (is_init)
8526     ffestorag_set_init (st, ffebld_new_any ());
8527
8528   if (init)
8529     {
8530       assert (DECL_SIZE_UNIT (cbt) != NULL_TREE);
8531       assert (TREE_CODE (DECL_SIZE_UNIT (cbt)) == INTEGER_CST);
8532       assert (0 == compare_tree_int (DECL_SIZE_UNIT (cbt),
8533                                      (ffeglobal_common_size (g)
8534                                       + ffeglobal_common_pad (g))));
8535     }
8536
8537   ffeglobal_set_hook (g, cbt);
8538
8539   ffestorag_set_hook (st, cbt);
8540
8541   ffecom_save_tree_forever (cbt);
8542 }
8543
8544 /* Make master area for local EQUIVALENCE.  */
8545
8546 static void
8547 ffecom_transform_equiv_ (ffestorag eqst)
8548 {
8549   tree eqt;
8550   tree eqtype;
8551   tree init;
8552   tree high;
8553   bool is_init = ffestorag_is_init (eqst);
8554
8555   assert (eqst != NULL);
8556
8557   eqt = ffestorag_hook (eqst);
8558
8559   if (eqt != NULL_TREE)
8560     return;
8561
8562   /* Process inits.  */
8563
8564   if (is_init)
8565     {
8566       if (ffestorag_init (eqst) != NULL)
8567         {
8568           ffebld sexp;
8569
8570           /* Set the padding for the expression, so ffecom_expr
8571              knows to insert that many zeros.  */
8572           switch (ffebld_op (sexp = ffestorag_init (eqst)))
8573             {
8574             case FFEBLD_opCONTER:
8575               ffebld_conter_set_pad (sexp, ffestorag_modulo (eqst));
8576               break;
8577
8578             case FFEBLD_opARRTER:
8579               ffebld_arrter_set_pad (sexp, ffestorag_modulo (eqst));
8580               break;
8581
8582             case FFEBLD_opACCTER:
8583               ffebld_accter_set_pad (sexp, ffestorag_modulo (eqst));
8584               break;
8585
8586             default:
8587               assert ("bad op for eqv init (pad)" == NULL);
8588               break;
8589             }
8590
8591           init = ffecom_expr (sexp);
8592           if (init == error_mark_node)
8593             init = NULL_TREE;   /* Hopefully the back end complained! */
8594         }
8595       else
8596         init = error_mark_node;
8597     }
8598   else if (ffe_is_init_local_zero ())
8599     init = error_mark_node;
8600   else
8601     init = NULL_TREE;
8602
8603   ffecom_member_namelisted_ = FALSE;
8604   ffestorag_drive (ffestorag_list_equivs (eqst),
8605                    &ffecom_member_phase1_,
8606                    eqst);
8607
8608   high = build_int_2 ((ffestorag_size (eqst)
8609                        + ffestorag_modulo (eqst)) - 1, 0);
8610   TREE_TYPE (high) = ffecom_integer_type_node;
8611
8612   eqtype = build_array_type (char_type_node,
8613                              build_range_type (ffecom_integer_type_node,
8614                                                ffecom_integer_zero_node,
8615                                                high));
8616
8617   eqt = build_decl (VAR_DECL,
8618                     ffecom_get_invented_identifier ("__g77_equiv_%s",
8619                                                     ffesymbol_text
8620                                                     (ffestorag_symbol (eqst))),
8621                     eqtype);
8622   DECL_EXTERNAL (eqt) = 0;
8623   if (is_init
8624       || ffecom_member_namelisted_
8625 #ifdef FFECOM_sizeMAXSTACKITEM
8626       || (ffestorag_size (eqst) > FFECOM_sizeMAXSTACKITEM)
8627 #endif
8628       || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8629           && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
8630           && (ffestorag_is_save (eqst) || ffe_is_saveall ())))
8631     TREE_STATIC (eqt) = 1;
8632   else
8633     TREE_STATIC (eqt) = 0;
8634   TREE_PUBLIC (eqt) = 0;
8635   TREE_ADDRESSABLE (eqt) = 1;  /* Ensure non-register allocation */
8636   DECL_CONTEXT (eqt) = current_function_decl;
8637   if (init)
8638     DECL_INITIAL (eqt) = error_mark_node;
8639   else
8640     DECL_INITIAL (eqt) = NULL_TREE;
8641
8642   eqt = start_decl (eqt, FALSE);
8643
8644   /* Make sure that any type can live in EQUIVALENCE and be referenced
8645      without getting a bus error.  We could pick the most restrictive
8646      alignment of all entities actually placed in the EQUIVALENCE, but
8647      this seems easy enough.  */
8648
8649   DECL_ALIGN (eqt) = BIGGEST_ALIGNMENT;
8650   DECL_USER_ALIGN (eqt) = 0;
8651
8652   if ((!is_init && ffe_is_init_local_zero ())
8653       || (is_init && (ffestorag_init (eqst) == NULL)))
8654     init = ffecom_init_zero_ (eqt);
8655
8656   finish_decl (eqt, init, FALSE);
8657
8658   if (is_init)
8659     ffestorag_set_init (eqst, ffebld_new_any ());
8660
8661   {
8662     assert (TREE_CODE (DECL_SIZE_UNIT (eqt)) == INTEGER_CST);
8663     assert (0 == compare_tree_int (DECL_SIZE_UNIT (eqt),
8664                                    (ffestorag_size (eqst)
8665                                     + ffestorag_modulo (eqst))));
8666   }
8667
8668   ffestorag_set_hook (eqst, eqt);
8669
8670   ffestorag_drive (ffestorag_list_equivs (eqst),
8671                    &ffecom_member_phase2_,
8672                    eqst);
8673 }
8674
8675 /* Implement NAMELIST in back end.  See f2c/format.c for more info.  */
8676
8677 static tree
8678 ffecom_transform_namelist_ (ffesymbol s)
8679 {
8680   tree nmlt;
8681   tree nmltype = ffecom_type_namelist_ ();
8682   tree nmlinits;
8683   tree nameinit;
8684   tree varsinit;
8685   tree nvarsinit;
8686   tree field;
8687   tree high;
8688   int i;
8689   static int mynumber = 0;
8690
8691   nmlt = build_decl (VAR_DECL,
8692                      ffecom_get_invented_identifier ("__g77_namelist_%d",
8693                                                      mynumber++),
8694                      nmltype);
8695   TREE_STATIC (nmlt) = 1;
8696   DECL_INITIAL (nmlt) = error_mark_node;
8697
8698   nmlt = start_decl (nmlt, FALSE);
8699
8700   /* Process inits.  */
8701
8702   i = strlen (ffesymbol_text (s));
8703
8704   high = build_int_2 (i, 0);
8705   TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
8706
8707   nameinit = ffecom_build_f2c_string_ (i + 1,
8708                                        ffesymbol_text (s));
8709   TREE_TYPE (nameinit)
8710     = build_type_variant
8711     (build_array_type
8712      (char_type_node,
8713       build_range_type (ffecom_f2c_ftnlen_type_node,
8714                         ffecom_f2c_ftnlen_one_node,
8715                         high)),
8716      1, 0);
8717   TREE_CONSTANT (nameinit) = 1;
8718   TREE_STATIC (nameinit) = 1;
8719   nameinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (nameinit)),
8720                        nameinit);
8721
8722   varsinit = ffecom_vardesc_array_ (s);
8723   varsinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (varsinit)),
8724                        varsinit);
8725   TREE_CONSTANT (varsinit) = 1;
8726   TREE_STATIC (varsinit) = 1;
8727
8728   {
8729     ffebld b;
8730
8731     for (i = 0, b = ffesymbol_namelist (s); b != NULL; b = ffebld_trail (b))
8732       ++i;
8733   }
8734   nvarsinit = build_int_2 (i, 0);
8735   TREE_TYPE (nvarsinit) = integer_type_node;
8736   TREE_CONSTANT (nvarsinit) = 1;
8737   TREE_STATIC (nvarsinit) = 1;
8738
8739   nmlinits = build_tree_list ((field = TYPE_FIELDS (nmltype)), nameinit);
8740   TREE_CHAIN (nmlinits) = build_tree_list ((field = TREE_CHAIN (field)),
8741                                            varsinit);
8742   TREE_CHAIN (TREE_CHAIN (nmlinits))
8743     = build_tree_list ((field = TREE_CHAIN (field)), nvarsinit);
8744
8745   nmlinits = build_constructor (nmltype, nmlinits);
8746   TREE_CONSTANT (nmlinits) = 1;
8747   TREE_STATIC (nmlinits) = 1;
8748
8749   finish_decl (nmlt, nmlinits, FALSE);
8750
8751   nmlt = ffecom_1 (ADDR_EXPR, build_pointer_type (nmltype), nmlt);
8752
8753   return nmlt;
8754 }
8755
8756 /* A subroutine of ffecom_tree_canonize_ref_.  The incoming tree is
8757    analyzed on the assumption it is calculating a pointer to be
8758    indirected through.  It must return the proper decl and offset,
8759    taking into account different units of measurements for offsets.  */
8760
8761 static void
8762 ffecom_tree_canonize_ptr_ (tree *decl, tree *offset, tree t)
8763 {
8764   switch (TREE_CODE (t))
8765     {
8766     case NOP_EXPR:
8767     case CONVERT_EXPR:
8768     case NON_LVALUE_EXPR:
8769       ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
8770       break;
8771
8772     case PLUS_EXPR:
8773       ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
8774       if ((*decl == NULL_TREE)
8775           || (*decl == error_mark_node))
8776         break;
8777
8778       if (TREE_CODE (TREE_OPERAND (t, 1)) == INTEGER_CST)
8779         {
8780           /* An offset into COMMON.  */
8781           *offset = fold (build (PLUS_EXPR, TREE_TYPE (*offset),
8782                                  *offset, TREE_OPERAND (t, 1)));
8783           /* Convert offset (presumably in bytes) into canonical units
8784              (presumably bits).  */
8785           *offset = size_binop (MULT_EXPR,
8786                                 convert (bitsizetype, *offset),
8787                                 TYPE_SIZE (TREE_TYPE (TREE_TYPE (t))));
8788           break;
8789         }
8790       /* Not a COMMON reference, so an unrecognized pattern.  */
8791       *decl = error_mark_node;
8792       break;
8793
8794     case PARM_DECL:
8795       *decl = t;
8796       *offset = bitsize_zero_node;
8797       break;
8798
8799     case ADDR_EXPR:
8800       if (TREE_CODE (TREE_OPERAND (t, 0)) == VAR_DECL)
8801         {
8802           /* A reference to COMMON.  */
8803           *decl = TREE_OPERAND (t, 0);
8804           *offset = bitsize_zero_node;
8805           break;
8806         }
8807       /* Fall through.  */
8808     default:
8809       /* Not a COMMON reference, so an unrecognized pattern.  */
8810       *decl = error_mark_node;
8811       break;
8812     }
8813 }
8814
8815 /* Given a tree that is possibly intended for use as an lvalue, return
8816    information representing a canonical view of that tree as a decl, an
8817    offset into that decl, and a size for the lvalue.
8818
8819    If there's no applicable decl, NULL_TREE is returned for the decl,
8820    and the other fields are left undefined.
8821
8822    If the tree doesn't fit the recognizable forms, an ERROR_MARK node
8823    is returned for the decl, and the other fields are left undefined.
8824
8825    Otherwise, the decl returned currently is either a VAR_DECL or a
8826    PARM_DECL.
8827
8828    The offset returned is always valid, but of course not necessarily
8829    a constant, and not necessarily converted into the appropriate
8830    type, leaving that up to the caller (so as to avoid that overhead
8831    if the decls being looked at are different anyway).
8832
8833    If the size cannot be determined (e.g. an adjustable array),
8834    an ERROR_MARK node is returned for the size.  Otherwise, the
8835    size returned is valid, not necessarily a constant, and not
8836    necessarily converted into the appropriate type as with the
8837    offset.
8838
8839    Note that the offset and size expressions are expressed in the
8840    base storage units (usually bits) rather than in the units of
8841    the type of the decl, because two decls with different types
8842    might overlap but with apparently non-overlapping array offsets,
8843    whereas converting the array offsets to consistant offsets will
8844    reveal the overlap.  */
8845
8846 static void
8847 ffecom_tree_canonize_ref_ (tree *decl, tree *offset, tree *size, tree t)
8848 {
8849   /* The default path is to report a nonexistant decl.  */
8850   *decl = NULL_TREE;
8851
8852   if (t == NULL_TREE)
8853     return;
8854
8855   switch (TREE_CODE (t))
8856     {
8857     case ERROR_MARK:
8858     case IDENTIFIER_NODE:
8859     case INTEGER_CST:
8860     case REAL_CST:
8861     case COMPLEX_CST:
8862     case STRING_CST:
8863     case CONST_DECL:
8864     case PLUS_EXPR:
8865     case MINUS_EXPR:
8866     case MULT_EXPR:
8867     case TRUNC_DIV_EXPR:
8868     case CEIL_DIV_EXPR:
8869     case FLOOR_DIV_EXPR:
8870     case ROUND_DIV_EXPR:
8871     case TRUNC_MOD_EXPR:
8872     case CEIL_MOD_EXPR:
8873     case FLOOR_MOD_EXPR:
8874     case ROUND_MOD_EXPR:
8875     case RDIV_EXPR:
8876     case EXACT_DIV_EXPR:
8877     case FIX_TRUNC_EXPR:
8878     case FIX_CEIL_EXPR:
8879     case FIX_FLOOR_EXPR:
8880     case FIX_ROUND_EXPR:
8881     case FLOAT_EXPR:
8882     case NEGATE_EXPR:
8883     case MIN_EXPR:
8884     case MAX_EXPR:
8885     case ABS_EXPR:
8886     case FFS_EXPR:
8887     case LSHIFT_EXPR:
8888     case RSHIFT_EXPR:
8889     case LROTATE_EXPR:
8890     case RROTATE_EXPR:
8891     case BIT_IOR_EXPR:
8892     case BIT_XOR_EXPR:
8893     case BIT_AND_EXPR:
8894     case BIT_ANDTC_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   {
11822     REAL_VALUE_TYPE point_5;
11823
11824     REAL_ARITHMETIC (point_5, RDIV_EXPR, dconst1, dconst2);
11825     ffecom_float_half_ = build_real (float_type_node, point_5);
11826     ffecom_double_half_ = build_real (double_type_node, point_5);
11827   }
11828
11829   /* Do "extern int xargc;".  */
11830
11831   ffecom_tree_xargc_ = build_decl (VAR_DECL,
11832                                    get_identifier ("f__xargc"),
11833                                    integer_type_node);
11834   DECL_EXTERNAL (ffecom_tree_xargc_) = 1;
11835   TREE_STATIC (ffecom_tree_xargc_) = 1;
11836   TREE_PUBLIC (ffecom_tree_xargc_) = 1;
11837   ffecom_tree_xargc_ = start_decl (ffecom_tree_xargc_, FALSE);
11838   finish_decl (ffecom_tree_xargc_, NULL_TREE, FALSE);
11839
11840 #if 0   /* This is being fixed, and seems to be working now. */
11841   if ((FLOAT_TYPE_SIZE != 32)
11842       || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))) != 32))
11843     {
11844       warning ("configuration: REAL, INTEGER, and LOGICAL are %d bits wide,",
11845                (int) FLOAT_TYPE_SIZE);
11846       warning ("and pointers are %d bits wide, but g77 doesn't yet work",
11847           (int) TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))));
11848       warning ("properly unless they all are 32 bits wide");
11849       warning ("Please keep this in mind before you report bugs.");
11850     }
11851 #endif
11852
11853 #if 0   /* Code in ste.c that would crash has been commented out. */
11854   if (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)
11855       < TYPE_PRECISION (string_type_node))
11856     /* I/O will probably crash.  */
11857     warning ("configuration: char * holds %d bits, but ftnlen only %d",
11858              TYPE_PRECISION (string_type_node),
11859              TYPE_PRECISION (ffecom_f2c_ftnlen_type_node));
11860 #endif
11861
11862 #if 0   /* ASSIGN-related stuff has been changed to accommodate this. */
11863   if (TYPE_PRECISION (ffecom_integer_type_node)
11864       < TYPE_PRECISION (string_type_node))
11865     /* ASSIGN 10 TO I will crash.  */
11866     warning ("configuration: char * holds %d bits, but INTEGER only %d --\n\
11867  ASSIGN statement might fail",
11868              TYPE_PRECISION (string_type_node),
11869              TYPE_PRECISION (ffecom_integer_type_node));
11870 #endif
11871 }
11872
11873 /* ffecom_init_2 -- Initialize
11874
11875    ffecom_init_2();  */
11876
11877 void
11878 ffecom_init_2 (void)
11879 {
11880   assert (ffecom_outer_function_decl_ == NULL_TREE);
11881   assert (current_function_decl == NULL_TREE);
11882   assert (ffecom_which_entrypoint_decl_ == NULL_TREE);
11883
11884   ffecom_master_arglist_ = NULL;
11885   ++ffecom_num_fns_;
11886   ffecom_primary_entry_ = NULL;
11887   ffecom_is_altreturning_ = FALSE;
11888   ffecom_func_result_ = NULL_TREE;
11889   ffecom_multi_retval_ = NULL_TREE;
11890 }
11891
11892 /* ffecom_list_expr -- Transform list of exprs into gcc tree
11893
11894    tree t;
11895    ffebld expr;  // FFE opITEM list.
11896    tree = ffecom_list_expr(expr);
11897
11898    List of actual args is transformed into corresponding gcc backend list.  */
11899
11900 tree
11901 ffecom_list_expr (ffebld expr)
11902 {
11903   tree list;
11904   tree *plist = &list;
11905   tree trail = NULL_TREE;       /* Append char length args here. */
11906   tree *ptrail = &trail;
11907   tree length;
11908
11909   while (expr != NULL)
11910     {
11911       tree texpr = ffecom_arg_expr (ffebld_head (expr), &length);
11912
11913       if (texpr == error_mark_node)
11914         return error_mark_node;
11915
11916       *plist = build_tree_list (NULL_TREE, texpr);
11917       plist = &TREE_CHAIN (*plist);
11918       expr = ffebld_trail (expr);
11919       if (length != NULL_TREE)
11920         {
11921           *ptrail = build_tree_list (NULL_TREE, length);
11922           ptrail = &TREE_CHAIN (*ptrail);
11923         }
11924     }
11925
11926   *plist = trail;
11927
11928   return list;
11929 }
11930
11931 /* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree
11932
11933    tree t;
11934    ffebld expr;  // FFE opITEM list.
11935    tree = ffecom_list_ptr_to_expr(expr);
11936
11937    List of actual args is transformed into corresponding gcc backend list for
11938    use in calling an external procedure (vs. a statement function).  */
11939
11940 tree
11941 ffecom_list_ptr_to_expr (ffebld expr)
11942 {
11943   tree list;
11944   tree *plist = &list;
11945   tree trail = NULL_TREE;       /* Append char length args here. */
11946   tree *ptrail = &trail;
11947   tree length;
11948
11949   while (expr != NULL)
11950     {
11951       tree texpr = ffecom_arg_ptr_to_expr (ffebld_head (expr), &length);
11952
11953       if (texpr == error_mark_node)
11954         return error_mark_node;
11955
11956       *plist = build_tree_list (NULL_TREE, texpr);
11957       plist = &TREE_CHAIN (*plist);
11958       expr = ffebld_trail (expr);
11959       if (length != NULL_TREE)
11960         {
11961           *ptrail = build_tree_list (NULL_TREE, length);
11962           ptrail = &TREE_CHAIN (*ptrail);
11963         }
11964     }
11965
11966   *plist = trail;
11967
11968   return list;
11969 }
11970
11971 /* Obtain gcc's LABEL_DECL tree for label.  */
11972
11973 tree
11974 ffecom_lookup_label (ffelab label)
11975 {
11976   tree glabel;
11977
11978   if (ffelab_hook (label) == NULL_TREE)
11979     {
11980       char labelname[16];
11981
11982       switch (ffelab_type (label))
11983         {
11984         case FFELAB_typeLOOPEND:
11985         case FFELAB_typeNOTLOOP:
11986         case FFELAB_typeENDIF:
11987           sprintf (labelname, "%" ffelabValue_f "u", ffelab_value (label));
11988           glabel = build_decl (LABEL_DECL, get_identifier (labelname),
11989                                void_type_node);
11990           DECL_CONTEXT (glabel) = current_function_decl;
11991           DECL_MODE (glabel) = VOIDmode;
11992           break;
11993
11994         case FFELAB_typeFORMAT:
11995           glabel = build_decl (VAR_DECL,
11996                                ffecom_get_invented_identifier
11997                                ("__g77_format_%d", (int) ffelab_value (label)),
11998                                build_type_variant (build_array_type
11999                                                    (char_type_node,
12000                                                     NULL_TREE),
12001                                                    1, 0));
12002           TREE_CONSTANT (glabel) = 1;
12003           TREE_STATIC (glabel) = 1;
12004           DECL_CONTEXT (glabel) = current_function_decl;
12005           DECL_INITIAL (glabel) = NULL;
12006           make_decl_rtl (glabel, NULL);
12007           expand_decl (glabel);
12008
12009           ffecom_save_tree_forever (glabel);
12010
12011           break;
12012
12013         case FFELAB_typeANY:
12014           glabel = error_mark_node;
12015           break;
12016
12017         default:
12018           assert ("bad label type" == NULL);
12019           glabel = NULL;
12020           break;
12021         }
12022       ffelab_set_hook (label, glabel);
12023     }
12024   else
12025     {
12026       glabel = ffelab_hook (label);
12027     }
12028
12029   return glabel;
12030 }
12031
12032 /* Stabilizes the arguments.  Don't use this if the lhs and rhs come from
12033    a single source specification (as in the fourth argument of MVBITS).
12034    If the type is NULL_TREE, the type of lhs is used to make the type of
12035    the MODIFY_EXPR.  */
12036
12037 tree
12038 ffecom_modify (tree newtype, tree lhs, tree rhs)
12039 {
12040   if (lhs == error_mark_node || rhs == error_mark_node)
12041     return error_mark_node;
12042
12043   if (newtype == NULL_TREE)
12044     newtype = TREE_TYPE (lhs);
12045
12046   if (TREE_SIDE_EFFECTS (lhs))
12047     lhs = stabilize_reference (lhs);
12048
12049   return ffecom_2s (MODIFY_EXPR, newtype, lhs, rhs);
12050 }
12051
12052 /* Register source file name.  */
12053
12054 void
12055 ffecom_file (const char *name)
12056 {
12057   ffecom_file_ (name);
12058 }
12059
12060 /* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed
12061
12062    ffestorag st;
12063    ffecom_notify_init_storage(st);
12064
12065    Gets called when all possible units in an aggregate storage area (a LOCAL
12066    with equivalences or a COMMON) have been initialized.  The initialization
12067    info either is in ffestorag_init or, if that is NULL,
12068    ffestorag_accretion:
12069
12070    ffestorag_init may contain an opCONTER or opARRTER.  opCONTER may occur
12071    even for an array if the array is one element in length!
12072
12073    ffestorag_accretion will contain an opACCTER.  It is much like an
12074    opARRTER except it has an ffebit object in it instead of just a size.
12075    The back end can use the info in the ffebit object, if it wants, to
12076    reduce the amount of actual initialization, but in any case it should
12077    kill the ffebit object when done.  Also, set accretion to NULL but
12078    init to a non-NULL value.
12079
12080    After performing initialization, DO NOT set init to NULL, because that'll
12081    tell the front end it is ok for more initialization to happen.  Instead,
12082    set init to an opANY expression or some such thing that you can use to
12083    tell that you've already initialized the object.
12084
12085    27-Oct-91  JCB  1.1
12086       Support two-pass FFE.  */
12087
12088 void
12089 ffecom_notify_init_storage (ffestorag st)
12090 {
12091   ffebld init;                  /* The initialization expression. */
12092
12093   if (ffestorag_init (st) == NULL)
12094     {
12095       init = ffestorag_accretion (st);
12096       assert (init != NULL);
12097       ffestorag_set_accretion (st, NULL);
12098       ffestorag_set_accretes (st, 0);
12099       ffestorag_set_init (st, init);
12100     }
12101 }
12102
12103 /* ffecom_notify_init_symbol -- A symbol is now fully init'ed
12104
12105    ffesymbol s;
12106    ffecom_notify_init_symbol(s);
12107
12108    Gets called when all possible units in a symbol (not placed in COMMON
12109    or involved in EQUIVALENCE, unless it as yet has no ffestorag object)
12110    have been initialized.  The initialization info either is in
12111    ffesymbol_init or, if that is NULL, ffesymbol_accretion:
12112
12113    ffesymbol_init may contain an opCONTER or opARRTER.  opCONTER may occur
12114    even for an array if the array is one element in length!
12115
12116    ffesymbol_accretion will contain an opACCTER.  It is much like an
12117    opARRTER except it has an ffebit object in it instead of just a size.
12118    The back end can use the info in the ffebit object, if it wants, to
12119    reduce the amount of actual initialization, but in any case it should
12120    kill the ffebit object when done.  Also, set accretion to NULL but
12121    init to a non-NULL value.
12122
12123    After performing initialization, DO NOT set init to NULL, because that'll
12124    tell the front end it is ok for more initialization to happen.  Instead,
12125    set init to an opANY expression or some such thing that you can use to
12126    tell that you've already initialized the object.
12127
12128    27-Oct-91  JCB  1.1
12129       Support two-pass FFE.  */
12130
12131 void
12132 ffecom_notify_init_symbol (ffesymbol s)
12133 {
12134   ffebld init;                  /* The initialization expression. */
12135
12136   if (ffesymbol_storage (s) == NULL)
12137     return;                     /* Do nothing until COMMON/EQUIVALENCE
12138                                    possibilities checked. */
12139
12140   if ((ffesymbol_init (s) == NULL)
12141       && ((init = ffesymbol_accretion (s)) != NULL))
12142     {
12143       ffesymbol_set_accretion (s, NULL);
12144       ffesymbol_set_accretes (s, 0);
12145       ffesymbol_set_init (s, init);
12146     }
12147 }
12148
12149 /* ffecom_notify_primary_entry -- Learn which is the primary entry point
12150
12151    ffesymbol s;
12152    ffecom_notify_primary_entry(s);
12153
12154    Gets called when implicit or explicit PROGRAM statement seen or when
12155    FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary
12156    global symbol that serves as the entry point.  */
12157
12158 void
12159 ffecom_notify_primary_entry (ffesymbol s)
12160 {
12161   ffecom_primary_entry_ = s;
12162   ffecom_primary_entry_kind_ = ffesymbol_kind (s);
12163
12164   if ((ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
12165       || (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE))
12166     ffecom_primary_entry_is_proc_ = TRUE;
12167   else
12168     ffecom_primary_entry_is_proc_ = FALSE;
12169
12170   if (!ffe_is_silent ())
12171     {
12172       if (ffecom_primary_entry_kind_ == FFEINFO_kindPROGRAM)
12173         fprintf (stderr, "%s:\n", ffesymbol_text (s));
12174       else
12175         fprintf (stderr, "  %s:\n", ffesymbol_text (s));
12176     }
12177
12178   if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
12179     {
12180       ffebld list;
12181       ffebld arg;
12182
12183       for (list = ffesymbol_dummyargs (s);
12184            list != NULL;
12185            list = ffebld_trail (list))
12186         {
12187           arg = ffebld_head (list);
12188           if (ffebld_op (arg) == FFEBLD_opSTAR)
12189             {
12190               ffecom_is_altreturning_ = TRUE;
12191               break;
12192             }
12193         }
12194     }
12195 }
12196
12197 FILE *
12198 ffecom_open_include (char *name, ffewhereLine l, ffewhereColumn c)
12199 {
12200   return ffecom_open_include_ (name, l, c);
12201 }
12202
12203 /* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front
12204
12205    tree t;
12206    ffebld expr;  // FFE expression.
12207    tree = ffecom_ptr_to_expr(expr);
12208
12209    Like ffecom_expr, but sticks address-of in front of most things.  */
12210
12211 tree
12212 ffecom_ptr_to_expr (ffebld expr)
12213 {
12214   tree item;
12215   ffeinfoBasictype bt;
12216   ffeinfoKindtype kt;
12217   ffesymbol s;
12218
12219   assert (expr != NULL);
12220
12221   switch (ffebld_op (expr))
12222     {
12223     case FFEBLD_opSYMTER:
12224       s = ffebld_symter (expr);
12225       if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
12226         {
12227           ffecomGfrt ix;
12228
12229           ix = ffeintrin_gfrt_indirect (ffebld_symter_implementation (expr));
12230           assert (ix != FFECOM_gfrt);
12231           if ((item = ffecom_gfrt_[ix]) == NULL_TREE)
12232             {
12233               ffecom_make_gfrt_ (ix);
12234               item = ffecom_gfrt_[ix];
12235             }
12236         }
12237       else
12238         {
12239           item = ffesymbol_hook (s).decl_tree;
12240           if (item == NULL_TREE)
12241             {
12242               s = ffecom_sym_transform_ (s);
12243               item = ffesymbol_hook (s).decl_tree;
12244             }
12245         }
12246       assert (item != NULL);
12247       if (item == error_mark_node)
12248         return item;
12249       if (!ffesymbol_hook (s).addr)
12250         item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12251                          item);
12252       return item;
12253
12254     case FFEBLD_opARRAYREF:
12255       return ffecom_arrayref_ (NULL_TREE, expr, 1);
12256
12257     case FFEBLD_opCONTER:
12258
12259       bt = ffeinfo_basictype (ffebld_info (expr));
12260       kt = ffeinfo_kindtype (ffebld_info (expr));
12261
12262       item = ffecom_constantunion (&ffebld_constant_union
12263                                    (ffebld_conter (expr)), bt, kt,
12264                                    ffecom_tree_type[bt][kt]);
12265       if (item == error_mark_node)
12266         return error_mark_node;
12267       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12268                        item);
12269       return item;
12270
12271     case FFEBLD_opANY:
12272       return error_mark_node;
12273
12274     default:
12275       bt = ffeinfo_basictype (ffebld_info (expr));
12276       kt = ffeinfo_kindtype (ffebld_info (expr));
12277
12278       item = ffecom_expr (expr);
12279       if (item == error_mark_node)
12280         return error_mark_node;
12281
12282       /* The back end currently optimizes a bit too zealously for us, in that
12283          we fail JCB001 if the following block of code is omitted.  It checks
12284          to see if the transformed expression is a symbol or array reference,
12285          and encloses it in a SAVE_EXPR if that is the case.  */
12286
12287       STRIP_NOPS (item);
12288       if ((TREE_CODE (item) == VAR_DECL)
12289           || (TREE_CODE (item) == PARM_DECL)
12290           || (TREE_CODE (item) == RESULT_DECL)
12291           || (TREE_CODE (item) == INDIRECT_REF)
12292           || (TREE_CODE (item) == ARRAY_REF)
12293           || (TREE_CODE (item) == COMPONENT_REF)
12294 #ifdef OFFSET_REF
12295           || (TREE_CODE (item) == OFFSET_REF)
12296 #endif
12297           || (TREE_CODE (item) == BUFFER_REF)
12298           || (TREE_CODE (item) == REALPART_EXPR)
12299           || (TREE_CODE (item) == IMAGPART_EXPR))
12300         {
12301           item = ffecom_save_tree (item);
12302         }
12303
12304       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12305                        item);
12306       return item;
12307     }
12308
12309   assert ("fall-through error" == NULL);
12310   return error_mark_node;
12311 }
12312
12313 /* Obtain a temp var with given data type.
12314
12315    size is FFETARGET_charactersizeNONE for a non-CHARACTER type
12316    or >= 0 for a CHARACTER type.
12317
12318    elements is -1 for a scalar or > 0 for an array of type.  */
12319
12320 tree
12321 ffecom_make_tempvar (const char *commentary, tree type,
12322                      ffetargetCharacterSize size, int elements)
12323 {
12324   tree t;
12325   static int mynumber;
12326
12327   assert (current_binding_level->prep_state < 2);
12328
12329   if (type == error_mark_node)
12330     return error_mark_node;
12331
12332   if (size != FFETARGET_charactersizeNONE)
12333     type = build_array_type (type,
12334                              build_range_type (ffecom_f2c_ftnlen_type_node,
12335                                                ffecom_f2c_ftnlen_one_node,
12336                                                build_int_2 (size, 0)));
12337   if (elements != -1)
12338     type = build_array_type (type,
12339                              build_range_type (integer_type_node,
12340                                                integer_zero_node,
12341                                                build_int_2 (elements - 1,
12342                                                             0)));
12343   t = build_decl (VAR_DECL,
12344                   ffecom_get_invented_identifier ("__g77_%s_%d",
12345                                                   commentary,
12346                                                   mynumber++),
12347                   type);
12348
12349   t = start_decl (t, FALSE);
12350   finish_decl (t, NULL_TREE, FALSE);
12351
12352   return t;
12353 }
12354
12355 /* Prepare argument pointer to expression.
12356
12357    Like ffecom_prepare_expr, except for expressions to be evaluated
12358    via ffecom_arg_ptr_to_expr.  */
12359
12360 void
12361 ffecom_prepare_arg_ptr_to_expr (ffebld expr)
12362 {
12363   /* ~~For now, it seems to be the same thing.  */
12364   ffecom_prepare_expr (expr);
12365   return;
12366 }
12367
12368 /* End of preparations.  */
12369
12370 bool
12371 ffecom_prepare_end (void)
12372 {
12373   int prep_state = current_binding_level->prep_state;
12374
12375   assert (prep_state < 2);
12376   current_binding_level->prep_state = 2;
12377
12378   return (prep_state == 1) ? TRUE : FALSE;
12379 }
12380
12381 /* Prepare expression.
12382
12383    This is called before any code is generated for the current block.
12384    It scans the expression, declares any temporaries that might be needed
12385    during evaluation of the expression, and stores those temporaries in
12386    the appropriate "hook" fields of the expression.  `dest', if not NULL,
12387    specifies the destination that ffecom_expr_ will see, in case that
12388    helps avoid generating unused temporaries.
12389
12390    ~~Improve to avoid allocating unused temporaries by taking `dest'
12391    into account vis-a-vis aliasing requirements of complex/character
12392    functions.  */
12393
12394 void
12395 ffecom_prepare_expr_ (ffebld expr, ffebld dest UNUSED)
12396 {
12397   ffeinfoBasictype bt;
12398   ffeinfoKindtype kt;
12399   ffetargetCharacterSize sz;
12400   tree tempvar = NULL_TREE;
12401
12402   assert (current_binding_level->prep_state < 2);
12403
12404   if (! expr)
12405     return;
12406
12407   bt = ffeinfo_basictype (ffebld_info (expr));
12408   kt = ffeinfo_kindtype (ffebld_info (expr));
12409   sz = ffeinfo_size (ffebld_info (expr));
12410
12411   /* Generate whatever temporaries are needed to represent the result
12412      of the expression.  */
12413
12414   if (bt == FFEINFO_basictypeCHARACTER)
12415     {
12416       while (ffebld_op (expr) == FFEBLD_opPAREN)
12417         expr = ffebld_left (expr);
12418     }
12419
12420   switch (ffebld_op (expr))
12421     {
12422     default:
12423       /* Don't make temps for SYMTER, CONTER, etc.  */
12424       if (ffebld_arity (expr) == 0)
12425         break;
12426
12427       switch (bt)
12428         {
12429         case FFEINFO_basictypeCOMPLEX:
12430           if (ffebld_op (expr) == FFEBLD_opFUNCREF)
12431             {
12432               ffesymbol s;
12433
12434               if (ffebld_op (ffebld_left (expr)) != FFEBLD_opSYMTER)
12435                 break;
12436
12437               s = ffebld_symter (ffebld_left (expr));
12438               if (ffesymbol_where (s) == FFEINFO_whereCONSTANT
12439                   || (ffesymbol_where (s) != FFEINFO_whereINTRINSIC
12440                       && ! ffesymbol_is_f2c (s))
12441                   || (ffesymbol_where (s) == FFEINFO_whereINTRINSIC
12442                       && ! ffe_is_f2c_library ()))
12443                 break;
12444             }
12445           else if (ffebld_op (expr) == FFEBLD_opPOWER)
12446             {
12447               /* Requires special treatment.  There's no POW_CC function
12448                  in libg2c, so POW_ZZ is used, which means we always
12449                  need a double-complex temp, not a single-complex.  */
12450               kt = FFEINFO_kindtypeREAL2;
12451             }
12452           else if (ffebld_op (expr) != FFEBLD_opDIVIDE)
12453             /* The other ops don't need temps for complex operands.  */
12454             break;
12455
12456           /* ~~~Avoid making temps for some intrinsics, such as AIMAG(C),
12457              REAL(C).  See 19990325-0.f, routine `check', for cases.  */
12458           tempvar = ffecom_make_tempvar ("complex",
12459                                          ffecom_tree_type
12460                                          [FFEINFO_basictypeCOMPLEX][kt],
12461                                          FFETARGET_charactersizeNONE,
12462                                          -1);
12463           break;
12464
12465         case FFEINFO_basictypeCHARACTER:
12466           if (ffebld_op (expr) != FFEBLD_opFUNCREF)
12467             break;
12468
12469           if (sz == FFETARGET_charactersizeNONE)
12470             /* ~~Kludge alert!  This should someday be fixed. */
12471             sz = 24;
12472
12473           tempvar = ffecom_make_tempvar ("char", char_type_node, sz, -1);
12474           break;
12475
12476         default:
12477           break;
12478         }
12479       break;
12480
12481     case FFEBLD_opCONCATENATE:
12482       {
12483         /* This gets special handling, because only one set of temps
12484            is needed for a tree of these -- the tree is treated as
12485            a flattened list of concatenations when generating code.  */
12486
12487         ffecomConcatList_ catlist;
12488         tree ltmp, itmp, result;
12489         int count;
12490         int i;
12491
12492         catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
12493         count = ffecom_concat_list_count_ (catlist);
12494
12495         if (count >= 2)
12496           {
12497             ltmp
12498               = ffecom_make_tempvar ("concat_len",
12499                                      ffecom_f2c_ftnlen_type_node,
12500                                      FFETARGET_charactersizeNONE, count);
12501             itmp
12502               = ffecom_make_tempvar ("concat_item",
12503                                      ffecom_f2c_address_type_node,
12504                                      FFETARGET_charactersizeNONE, count);
12505             result
12506               = ffecom_make_tempvar ("concat_res",
12507                                      char_type_node,
12508                                      ffecom_concat_list_maxlen_ (catlist),
12509                                      -1);
12510
12511             tempvar = make_tree_vec (3);
12512             TREE_VEC_ELT (tempvar, 0) = ltmp;
12513             TREE_VEC_ELT (tempvar, 1) = itmp;
12514             TREE_VEC_ELT (tempvar, 2) = result;
12515           }
12516
12517         for (i = 0; i < count; ++i)
12518           ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist,
12519                                                                     i));
12520
12521         ffecom_concat_list_kill_ (catlist);
12522
12523         if (tempvar)
12524           {
12525             ffebld_nonter_set_hook (expr, tempvar);
12526             current_binding_level->prep_state = 1;
12527           }
12528       }
12529       return;
12530
12531     case FFEBLD_opCONVERT:
12532       if (bt == FFEINFO_basictypeCHARACTER
12533           && ((ffebld_size_known (ffebld_left (expr))
12534                == FFETARGET_charactersizeNONE)
12535               || (ffebld_size_known (ffebld_left (expr)) >= sz)))
12536         tempvar = ffecom_make_tempvar ("convert", char_type_node, sz, -1);
12537       break;
12538     }
12539
12540   if (tempvar)
12541     {
12542       ffebld_nonter_set_hook (expr, tempvar);
12543       current_binding_level->prep_state = 1;
12544     }
12545
12546   /* Prepare subexpressions for this expr.  */
12547
12548   switch (ffebld_op (expr))
12549     {
12550     case FFEBLD_opPERCENT_LOC:
12551       ffecom_prepare_ptr_to_expr (ffebld_left (expr));
12552       break;
12553
12554     case FFEBLD_opPERCENT_VAL:
12555     case FFEBLD_opPERCENT_REF:
12556       ffecom_prepare_expr (ffebld_left (expr));
12557       break;
12558
12559     case FFEBLD_opPERCENT_DESCR:
12560       ffecom_prepare_arg_ptr_to_expr (ffebld_left (expr));
12561       break;
12562
12563     case FFEBLD_opITEM:
12564       {
12565         ffebld item;
12566
12567         for (item = expr;
12568              item != NULL;
12569              item = ffebld_trail (item))
12570           if (ffebld_head (item) != NULL)
12571             ffecom_prepare_expr (ffebld_head (item));
12572       }
12573       break;
12574
12575     default:
12576       /* Need to handle character conversion specially.  */
12577       switch (ffebld_arity (expr))
12578         {
12579         case 2:
12580           ffecom_prepare_expr (ffebld_left (expr));
12581           ffecom_prepare_expr (ffebld_right (expr));
12582           break;
12583
12584         case 1:
12585           ffecom_prepare_expr (ffebld_left (expr));
12586           break;
12587
12588         default:
12589           break;
12590         }
12591     }
12592
12593   return;
12594 }
12595
12596 /* Prepare expression for reading and writing.
12597
12598    Like ffecom_prepare_expr, except for expressions to be evaluated
12599    via ffecom_expr_rw.  */
12600
12601 void
12602 ffecom_prepare_expr_rw (tree type, ffebld expr)
12603 {
12604   /* This is all we support for now.  */
12605   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
12606
12607   /* ~~For now, it seems to be the same thing.  */
12608   ffecom_prepare_expr (expr);
12609   return;
12610 }
12611
12612 /* Prepare expression for writing.
12613
12614    Like ffecom_prepare_expr, except for expressions to be evaluated
12615    via ffecom_expr_w.  */
12616
12617 void
12618 ffecom_prepare_expr_w (tree type, ffebld expr)
12619 {
12620   /* This is all we support for now.  */
12621   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
12622
12623   /* ~~For now, it seems to be the same thing.  */
12624   ffecom_prepare_expr (expr);
12625   return;
12626 }
12627
12628 /* Prepare expression for returning.
12629
12630    Like ffecom_prepare_expr, except for expressions to be evaluated
12631    via ffecom_return_expr.  */
12632
12633 void
12634 ffecom_prepare_return_expr (ffebld expr)
12635 {
12636   assert (current_binding_level->prep_state < 2);
12637
12638   if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE
12639       && ffecom_is_altreturning_
12640       && expr != NULL)
12641     ffecom_prepare_expr (expr);
12642 }
12643
12644 /* Prepare pointer to expression.
12645
12646    Like ffecom_prepare_expr, except for expressions to be evaluated
12647    via ffecom_ptr_to_expr.  */
12648
12649 void
12650 ffecom_prepare_ptr_to_expr (ffebld expr)
12651 {
12652   /* ~~For now, it seems to be the same thing.  */
12653   ffecom_prepare_expr (expr);
12654   return;
12655 }
12656
12657 /* Transform expression into constant pointer-to-expression tree.
12658
12659    If the expression can be transformed into a pointer-to-expression tree
12660    that is constant, that is done, and the tree returned.  Else NULL_TREE
12661    is returned.
12662
12663    That way, a caller can attempt to provide compile-time initialization
12664    of a variable and, if that fails, *then* choose to start a new block
12665    and resort to using temporaries, as appropriate.  */
12666
12667 tree
12668 ffecom_ptr_to_const_expr (ffebld expr)
12669 {
12670   if (! expr)
12671     return integer_zero_node;
12672
12673   if (ffebld_op (expr) == FFEBLD_opANY)
12674     return error_mark_node;
12675
12676   if (ffebld_arity (expr) == 0
12677       && (ffebld_op (expr) != FFEBLD_opSYMTER
12678           || ffebld_where (expr) == FFEINFO_whereCOMMON
12679           || ffebld_where (expr) == FFEINFO_whereGLOBAL
12680           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
12681     {
12682       tree t;
12683
12684       t = ffecom_ptr_to_expr (expr);
12685       assert (TREE_CONSTANT (t));
12686       return t;
12687     }
12688
12689   return NULL_TREE;
12690 }
12691
12692 /* ffecom_return_expr -- Returns return-value expr given alt return expr
12693
12694    tree rtn;  // NULL_TREE means use expand_null_return()
12695    ffebld expr;  // NULL if no alt return expr to RETURN stmt
12696    rtn = ffecom_return_expr(expr);
12697
12698    Based on the program unit type and other info (like return function
12699    type, return master function type when alternate ENTRY points,
12700    whether subroutine has any alternate RETURN points, etc), returns the
12701    appropriate expression to be returned to the caller, or NULL_TREE
12702    meaning no return value or the caller expects it to be returned somewhere
12703    else (which is handled by other parts of this module).  */
12704
12705 tree
12706 ffecom_return_expr (ffebld expr)
12707 {
12708   tree rtn;
12709
12710   switch (ffecom_primary_entry_kind_)
12711     {
12712     case FFEINFO_kindPROGRAM:
12713     case FFEINFO_kindBLOCKDATA:
12714       rtn = NULL_TREE;
12715       break;
12716
12717     case FFEINFO_kindSUBROUTINE:
12718       if (!ffecom_is_altreturning_)
12719         rtn = NULL_TREE;        /* No alt returns, never an expr. */
12720       else if (expr == NULL)
12721         rtn = integer_zero_node;
12722       else
12723         rtn = ffecom_expr (expr);
12724       break;
12725
12726     case FFEINFO_kindFUNCTION:
12727       if ((ffecom_multi_retval_ != NULL_TREE)
12728           || (ffesymbol_basictype (ffecom_primary_entry_)
12729               == FFEINFO_basictypeCHARACTER)
12730           || ((ffesymbol_basictype (ffecom_primary_entry_)
12731                == FFEINFO_basictypeCOMPLEX)
12732               && (ffecom_num_entrypoints_ == 0)
12733               && ffesymbol_is_f2c (ffecom_primary_entry_)))
12734         {                       /* Value is returned by direct assignment
12735                                    into (implicit) dummy. */
12736           rtn = NULL_TREE;
12737           break;
12738         }
12739       rtn = ffecom_func_result_;
12740 #if 0
12741       /* Spurious error if RETURN happens before first reference!  So elide
12742          this code.  In particular, for debugging registry, rtn should always
12743          be non-null after all, but TREE_USED won't be set until we encounter
12744          a reference in the code.  Perfectly okay (but weird) code that,
12745          e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in
12746          this diagnostic for no reason.  Have people use -O -Wuninitialized
12747          and leave it to the back end to find obviously weird cases.  */
12748
12749       /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid
12750          situation; if the return value has never been referenced, it won't
12751          have a tree under 2pass mode. */
12752       if ((rtn == NULL_TREE)
12753           || !TREE_USED (rtn))
12754         {
12755           ffebad_start (FFEBAD_RETURN_VALUE_UNSET);
12756           ffebad_here (0, ffesymbol_where_line (ffecom_primary_entry_),
12757                        ffesymbol_where_column (ffecom_primary_entry_));
12758           ffebad_string (ffesymbol_text (ffesymbol_funcresult
12759                                          (ffecom_primary_entry_)));
12760           ffebad_finish ();
12761         }
12762 #endif
12763       break;
12764
12765     default:
12766       assert ("bad unit kind" == NULL);
12767     case FFEINFO_kindANY:
12768       rtn = error_mark_node;
12769       break;
12770     }
12771
12772   return rtn;
12773 }
12774
12775 /* Do save_expr only if tree is not error_mark_node.  */
12776
12777 tree
12778 ffecom_save_tree (tree t)
12779 {
12780   return save_expr (t);
12781 }
12782
12783 /* Start a compound statement (block).  */
12784
12785 void
12786 ffecom_start_compstmt (void)
12787 {
12788   bison_rule_pushlevel_ ();
12789 }
12790
12791 /* Public entry point for front end to access start_decl.  */
12792
12793 tree
12794 ffecom_start_decl (tree decl, bool is_initialized)
12795 {
12796   DECL_INITIAL (decl) = is_initialized ? error_mark_node : NULL_TREE;
12797   return start_decl (decl, FALSE);
12798 }
12799
12800 /* ffecom_sym_commit -- Symbol's state being committed to reality
12801
12802    ffesymbol s;
12803    ffecom_sym_commit(s);
12804
12805    Does whatever the backend needs when a symbol is committed after having
12806    been backtrackable for a period of time.  */
12807
12808 void
12809 ffecom_sym_commit (ffesymbol s UNUSED)
12810 {
12811   assert (!ffesymbol_retractable ());
12812 }
12813
12814 /* ffecom_sym_end_transition -- Perform end transition on all symbols
12815
12816    ffecom_sym_end_transition();
12817
12818    Does backend-specific stuff and also calls ffest_sym_end_transition
12819    to do the necessary FFE stuff.
12820
12821    Backtracking is never enabled when this fn is called, so don't worry
12822    about it.  */
12823
12824 ffesymbol
12825 ffecom_sym_end_transition (ffesymbol s)
12826 {
12827   ffestorag st;
12828
12829   assert (!ffesymbol_retractable ());
12830
12831   s = ffest_sym_end_transition (s);
12832
12833   if ((ffesymbol_kind (s) == FFEINFO_kindBLOCKDATA)
12834       && (ffesymbol_where (s) == FFEINFO_whereGLOBAL))
12835     {
12836       ffecom_list_blockdata_
12837         = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
12838                                               FFEINTRIN_specNONE,
12839                                               FFEINTRIN_impNONE),
12840                            ffecom_list_blockdata_);
12841     }
12842
12843   /* This is where we finally notice that a symbol has partial initialization
12844      and finalize it. */
12845
12846   if (ffesymbol_accretion (s) != NULL)
12847     {
12848       assert (ffesymbol_init (s) == NULL);
12849       ffecom_notify_init_symbol (s);
12850     }
12851   else if (((st = ffesymbol_storage (s)) != NULL)
12852            && ((st = ffestorag_parent (st)) != NULL)
12853            && (ffestorag_accretion (st) != NULL))
12854     {
12855       assert (ffestorag_init (st) == NULL);
12856       ffecom_notify_init_storage (st);
12857     }
12858
12859   if ((ffesymbol_kind (s) == FFEINFO_kindCOMMON)
12860       && (ffesymbol_where (s) == FFEINFO_whereLOCAL)
12861       && (ffesymbol_storage (s) != NULL))
12862     {
12863       ffecom_list_common_
12864         = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
12865                                               FFEINTRIN_specNONE,
12866                                               FFEINTRIN_impNONE),
12867                            ffecom_list_common_);
12868     }
12869
12870   return s;
12871 }
12872
12873 /* ffecom_sym_exec_transition -- Perform exec transition on all symbols
12874
12875    ffecom_sym_exec_transition();
12876
12877    Does backend-specific stuff and also calls ffest_sym_exec_transition
12878    to do the necessary FFE stuff.
12879
12880    See the long-winded description in ffecom_sym_learned for info
12881    on handling the situation where backtracking is inhibited.  */
12882
12883 ffesymbol
12884 ffecom_sym_exec_transition (ffesymbol s)
12885 {
12886   s = ffest_sym_exec_transition (s);
12887
12888   return s;
12889 }
12890
12891 /* ffecom_sym_learned -- Initial or more info gained on symbol after exec
12892
12893    ffesymbol s;
12894    s = ffecom_sym_learned(s);
12895
12896    Called when a new symbol is seen after the exec transition or when more
12897    info (perhaps) is gained for an UNCERTAIN symbol.  The symbol state when
12898    it arrives here is that all its latest info is updated already, so its
12899    state may be UNCERTAIN or UNDERSTOOD, it might already have the hook
12900    field filled in if its gone through here or exec_transition first, and
12901    so on.
12902
12903    The backend probably wants to check ffesymbol_retractable() to see if
12904    backtracking is in effect.  If so, the FFE's changes to the symbol may
12905    be retracted (undone) or committed (ratified), at which time the
12906    appropriate ffecom_sym_retract or _commit function will be called
12907    for that function.
12908
12909    If the backend has its own backtracking mechanism, great, use it so that
12910    committal is a simple operation.  Though it doesn't make much difference,
12911    I suppose: the reason for tentative symbol evolution in the FFE is to
12912    enable error detection in weird incorrect statements early and to disable
12913    incorrect error detection on a correct statement.  The backend is not
12914    likely to introduce any information that'll get involved in these
12915    considerations, so it is probably just fine that the implementation
12916    model for this fn and for _exec_transition is to not do anything
12917    (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE
12918    and instead wait until ffecom_sym_commit is called (which it never
12919    will be as long as we're using ambiguity-detecting statement analysis in
12920    the FFE, which we are initially to shake out the code, but don't depend
12921    on this), otherwise go ahead and do whatever is needed.
12922
12923    In essence, then, when this fn and _exec_transition get called while
12924    backtracking is enabled, a general mechanism would be to flag which (or
12925    both) of these were called (and in what order? neat question as to what
12926    might happen that I'm too lame to think through right now) and then when
12927    _commit is called reproduce the original calling sequence, if any, for
12928    the two fns (at which point backtracking will, of course, be disabled).  */
12929
12930 ffesymbol
12931 ffecom_sym_learned (ffesymbol s)
12932 {
12933   ffestorag_exec_layout (s);
12934
12935   return s;
12936 }
12937
12938 /* ffecom_sym_retract -- Symbol's state being retracted from reality
12939
12940    ffesymbol s;
12941    ffecom_sym_retract(s);
12942
12943    Does whatever the backend needs when a symbol is retracted after having
12944    been backtrackable for a period of time.  */
12945
12946 void
12947 ffecom_sym_retract (ffesymbol s UNUSED)
12948 {
12949   assert (!ffesymbol_retractable ());
12950
12951 #if 0                           /* GCC doesn't commit any backtrackable sins,
12952                                    so nothing needed here. */
12953   switch (ffesymbol_hook (s).state)
12954     {
12955     case 0:                     /* nothing happened yet. */
12956       break;
12957
12958     case 1:                     /* exec transition happened. */
12959       break;
12960
12961     case 2:                     /* learned happened. */
12962       break;
12963
12964     case 3:                     /* learned then exec. */
12965       break;
12966
12967     case 4:                     /* exec then learned. */
12968       break;
12969
12970     default:
12971       assert ("bad hook state" == NULL);
12972       break;
12973     }
12974 #endif
12975 }
12976
12977 /* Create temporary gcc label.  */
12978
12979 tree
12980 ffecom_temp_label (void)
12981 {
12982   tree glabel;
12983   static int mynumber = 0;
12984
12985   glabel = build_decl (LABEL_DECL,
12986                        ffecom_get_invented_identifier ("__g77_label_%d",
12987                                                        mynumber++),
12988                        void_type_node);
12989   DECL_CONTEXT (glabel) = current_function_decl;
12990   DECL_MODE (glabel) = VOIDmode;
12991
12992   return glabel;
12993 }
12994
12995 /* Return an expression that is usable as an arg in a conditional context
12996    (IF, DO WHILE, .NOT., and so on).
12997
12998    Use the one provided for the back end as of >2.6.0.  */
12999
13000 tree
13001 ffecom_truth_value (tree expr)
13002 {
13003   return ffe_truthvalue_conversion (expr);
13004 }
13005
13006 /* Return the inversion of a truth value (the inversion of what
13007    ffecom_truth_value builds).
13008
13009    Apparently invert_truthvalue, which is properly in the back end, is
13010    enough for now, so just use it.  */
13011
13012 tree
13013 ffecom_truth_value_invert (tree expr)
13014 {
13015   return invert_truthvalue (ffecom_truth_value (expr));
13016 }
13017
13018 /* Return the tree that is the type of the expression, as would be
13019    returned in TREE_TYPE(ffecom_expr(expr)), without otherwise
13020    transforming the expression, generating temporaries, etc.  */
13021
13022 tree
13023 ffecom_type_expr (ffebld expr)
13024 {
13025   ffeinfoBasictype bt;
13026   ffeinfoKindtype kt;
13027   tree tree_type;
13028
13029   assert (expr != NULL);
13030
13031   bt = ffeinfo_basictype (ffebld_info (expr));
13032   kt = ffeinfo_kindtype (ffebld_info (expr));
13033   tree_type = ffecom_tree_type[bt][kt];
13034
13035   switch (ffebld_op (expr))
13036     {
13037     case FFEBLD_opCONTER:
13038     case FFEBLD_opSYMTER:
13039     case FFEBLD_opARRAYREF:
13040     case FFEBLD_opUPLUS:
13041     case FFEBLD_opPAREN:
13042     case FFEBLD_opUMINUS:
13043     case FFEBLD_opADD:
13044     case FFEBLD_opSUBTRACT:
13045     case FFEBLD_opMULTIPLY:
13046     case FFEBLD_opDIVIDE:
13047     case FFEBLD_opPOWER:
13048     case FFEBLD_opNOT:
13049     case FFEBLD_opFUNCREF:
13050     case FFEBLD_opSUBRREF:
13051     case FFEBLD_opAND:
13052     case FFEBLD_opOR:
13053     case FFEBLD_opXOR:
13054     case FFEBLD_opNEQV:
13055     case FFEBLD_opEQV:
13056     case FFEBLD_opCONVERT:
13057     case FFEBLD_opLT:
13058     case FFEBLD_opLE:
13059     case FFEBLD_opEQ:
13060     case FFEBLD_opNE:
13061     case FFEBLD_opGT:
13062     case FFEBLD_opGE:
13063     case FFEBLD_opPERCENT_LOC:
13064       return tree_type;
13065
13066     case FFEBLD_opACCTER:
13067     case FFEBLD_opARRTER:
13068     case FFEBLD_opITEM:
13069     case FFEBLD_opSTAR:
13070     case FFEBLD_opBOUNDS:
13071     case FFEBLD_opREPEAT:
13072     case FFEBLD_opLABTER:
13073     case FFEBLD_opLABTOK:
13074     case FFEBLD_opIMPDO:
13075     case FFEBLD_opCONCATENATE:
13076     case FFEBLD_opSUBSTR:
13077     default:
13078       assert ("bad op for ffecom_type_expr" == NULL);
13079       /* Fall through. */
13080     case FFEBLD_opANY:
13081       return error_mark_node;
13082     }
13083 }
13084
13085 /* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points
13086
13087    If the PARM_DECL already exists, return it, else create it.  It's an
13088    integer_type_node argument for the master function that implements a
13089    subroutine or function with more than one entrypoint and is bound at
13090    run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for
13091    first ENTRY statement, and so on).  */
13092
13093 tree
13094 ffecom_which_entrypoint_decl (void)
13095 {
13096   assert (ffecom_which_entrypoint_decl_ != NULL_TREE);
13097
13098   return ffecom_which_entrypoint_decl_;
13099 }
13100 \f
13101 /* The following sections consists of private and public functions
13102    that have the same names and perform roughly the same functions
13103    as counterparts in the C front end.  Changes in the C front end
13104    might affect how things should be done here.  Only functions
13105    needed by the back end should be public here; the rest should
13106    be private (static in the C sense).  Functions needed by other
13107    g77 front-end modules should be accessed by them via public
13108    ffecom_* names, which should themselves call private versions
13109    in this section so the private versions are easy to recognize
13110    when upgrading to a new gcc and finding interesting changes
13111    in the front end.
13112
13113    Functions named after rule "foo:" in c-parse.y are named
13114    "bison_rule_foo_" so they are easy to find.  */
13115
13116 static void
13117 bison_rule_pushlevel_ (void)
13118 {
13119   emit_line_note (input_location);
13120   pushlevel (0);
13121   clear_last_expr ();
13122   expand_start_bindings (0);
13123 }
13124
13125 static tree
13126 bison_rule_compstmt_ (void)
13127 {
13128   tree t;
13129   int keep = kept_level_p ();
13130
13131   /* Make the temps go away.  */
13132   if (! keep)
13133     current_binding_level->names = NULL_TREE;
13134
13135   emit_line_note (input_location);
13136   expand_end_bindings (getdecls (), keep, 0);
13137   t = poplevel (keep, 1, 0);
13138
13139   return t;
13140 }
13141
13142 /* Return a definition for a builtin function named NAME and whose data type
13143    is TYPE.  TYPE should be a function type with argument types.
13144    FUNCTION_CODE tells later passes how to compile calls to this function.
13145    See tree.h for its possible values.
13146
13147    If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
13148    the name to be called if we can't opencode the function.  If
13149    ATTRS is nonzero, use that for the function's attribute list.  */
13150
13151 tree
13152 builtin_function (const char *name, tree type, int function_code,
13153                   enum built_in_class class, const char *library_name,
13154                   tree attrs ATTRIBUTE_UNUSED)
13155 {
13156   tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type);
13157   DECL_EXTERNAL (decl) = 1;
13158   TREE_PUBLIC (decl) = 1;
13159   if (library_name)
13160     SET_DECL_ASSEMBLER_NAME (decl, get_identifier (library_name));
13161   make_decl_rtl (decl, NULL);
13162   pushdecl (decl);
13163   DECL_BUILT_IN_CLASS (decl) = class;
13164   DECL_FUNCTION_CODE (decl) = function_code;
13165
13166   return decl;
13167 }
13168
13169 /* Handle when a new declaration NEWDECL
13170    has the same name as an old one OLDDECL
13171    in the same binding contour.
13172    Prints an error message if appropriate.
13173
13174    If safely possible, alter OLDDECL to look like NEWDECL, and return 1.
13175    Otherwise, return 0.  */
13176
13177 static int
13178 duplicate_decls (tree newdecl, tree olddecl)
13179 {
13180   int types_match = 1;
13181   int new_is_definition = (TREE_CODE (newdecl) == FUNCTION_DECL
13182                            && DECL_INITIAL (newdecl) != 0);
13183   tree oldtype = TREE_TYPE (olddecl);
13184   tree newtype = TREE_TYPE (newdecl);
13185
13186   if (olddecl == newdecl)
13187     return 1;
13188
13189   if (TREE_CODE (newtype) == ERROR_MARK
13190       || TREE_CODE (oldtype) == ERROR_MARK)
13191     types_match = 0;
13192
13193   /* New decl is completely inconsistent with the old one =>
13194      tell caller to replace the old one.
13195      This is always an error except in the case of shadowing a builtin.  */
13196   if (TREE_CODE (olddecl) != TREE_CODE (newdecl))
13197     return 0;
13198
13199   /* For real parm decl following a forward decl,
13200      return 1 so old decl will be reused.  */
13201   if (types_match && TREE_CODE (newdecl) == PARM_DECL
13202       && TREE_ASM_WRITTEN (olddecl) && ! TREE_ASM_WRITTEN (newdecl))
13203     return 1;
13204
13205   /* The new declaration is the same kind of object as the old one.
13206      The declarations may partially match.  Print warnings if they don't
13207      match enough.  Ultimately, copy most of the information from the new
13208      decl to the old one, and keep using the old one.  */
13209
13210   if (TREE_CODE (olddecl) == FUNCTION_DECL
13211       && DECL_BUILT_IN (olddecl))
13212     {
13213       /* A function declaration for a built-in function.  */
13214       if (!TREE_PUBLIC (newdecl))
13215         return 0;
13216       else if (!types_match)
13217         {
13218           /* Accept the return type of the new declaration if same modes.  */
13219           tree oldreturntype = TREE_TYPE (TREE_TYPE (olddecl));
13220           tree newreturntype = TREE_TYPE (TREE_TYPE (newdecl));
13221
13222           if (TYPE_MODE (oldreturntype) == TYPE_MODE (newreturntype))
13223             {
13224               /* Function types may be shared, so we can't just modify
13225                  the return type of olddecl's function type.  */
13226               tree newtype
13227                 = build_function_type (newreturntype,
13228                                        TYPE_ARG_TYPES (TREE_TYPE (olddecl)));
13229
13230               types_match = 1;
13231               if (types_match)
13232                 TREE_TYPE (olddecl) = newtype;
13233             }
13234         }
13235       if (!types_match)
13236         return 0;
13237     }
13238   else if (TREE_CODE (olddecl) == FUNCTION_DECL
13239            && DECL_SOURCE_LINE (olddecl) == 0)
13240     {
13241       /* A function declaration for a predeclared function
13242          that isn't actually built in.  */
13243       if (!TREE_PUBLIC (newdecl))
13244         return 0;
13245       else if (!types_match)
13246         {
13247           /* If the types don't match, preserve volatility indication.
13248              Later on, we will discard everything else about the
13249              default declaration.  */
13250           TREE_THIS_VOLATILE (newdecl) |= TREE_THIS_VOLATILE (olddecl);
13251         }
13252     }
13253
13254   /* Copy all the DECL_... slots specified in the new decl
13255      except for any that we copy here from the old type.
13256
13257      Past this point, we don't change OLDTYPE and NEWTYPE
13258      even if we change the types of NEWDECL and OLDDECL.  */
13259
13260   if (types_match)
13261     {
13262       /* Merge the data types specified in the two decls.  */
13263       if (TREE_CODE (newdecl) != FUNCTION_DECL || !DECL_BUILT_IN (olddecl))
13264         TREE_TYPE (newdecl)
13265           = TREE_TYPE (olddecl)
13266             = TREE_TYPE (newdecl);
13267
13268       /* Lay the type out, unless already done.  */
13269       if (oldtype != TREE_TYPE (newdecl))
13270         {
13271           if (TREE_TYPE (newdecl) != error_mark_node)
13272             layout_type (TREE_TYPE (newdecl));
13273           if (TREE_CODE (newdecl) != FUNCTION_DECL
13274               && TREE_CODE (newdecl) != TYPE_DECL
13275               && TREE_CODE (newdecl) != CONST_DECL)
13276             layout_decl (newdecl, 0);
13277         }
13278       else
13279         {
13280           /* Since the type is OLDDECL's, make OLDDECL's size go with.  */
13281           DECL_SIZE (newdecl) = DECL_SIZE (olddecl);
13282           DECL_SIZE_UNIT (newdecl) = DECL_SIZE_UNIT (olddecl);
13283           if (TREE_CODE (olddecl) != FUNCTION_DECL)
13284             if (DECL_ALIGN (olddecl) > DECL_ALIGN (newdecl))
13285               {
13286                 DECL_ALIGN (newdecl) = DECL_ALIGN (olddecl);
13287                 DECL_USER_ALIGN (newdecl) |= DECL_USER_ALIGN (olddecl);
13288               }
13289         }
13290
13291       /* Keep the old rtl since we can safely use it.  */
13292       COPY_DECL_RTL (olddecl, newdecl);
13293
13294       /* Merge the type qualifiers.  */
13295       if (TREE_READONLY (newdecl))
13296         TREE_READONLY (olddecl) = 1;
13297       if (TREE_THIS_VOLATILE (newdecl))
13298         {
13299           TREE_THIS_VOLATILE (olddecl) = 1;
13300           if (TREE_CODE (newdecl) == VAR_DECL)
13301             make_var_volatile (newdecl);
13302         }
13303
13304       /* Keep source location of definition rather than declaration.
13305          Likewise, keep decl at outer scope.  */
13306       if ((DECL_INITIAL (newdecl) == 0 && DECL_INITIAL (olddecl) != 0)
13307           || (DECL_CONTEXT (newdecl) != 0 && DECL_CONTEXT (olddecl) == 0))
13308         {
13309           DECL_SOURCE_LINE (newdecl) = DECL_SOURCE_LINE (olddecl);
13310           DECL_SOURCE_FILE (newdecl) = DECL_SOURCE_FILE (olddecl);
13311
13312           if (DECL_CONTEXT (olddecl) == 0
13313               && TREE_CODE (newdecl) != FUNCTION_DECL)
13314             DECL_CONTEXT (newdecl) = 0;
13315         }
13316
13317       /* Merge the unused-warning information.  */
13318       if (DECL_IN_SYSTEM_HEADER (olddecl))
13319         DECL_IN_SYSTEM_HEADER (newdecl) = 1;
13320       else if (DECL_IN_SYSTEM_HEADER (newdecl))
13321         DECL_IN_SYSTEM_HEADER (olddecl) = 1;
13322
13323       /* Merge the initialization information.  */
13324       if (DECL_INITIAL (newdecl) == 0)
13325         DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13326
13327       /* Merge the section attribute.
13328          We want to issue an error if the sections conflict but that must be
13329          done later in decl_attributes since we are called before attributes
13330          are assigned.  */
13331       if (DECL_SECTION_NAME (newdecl) == NULL_TREE)
13332         DECL_SECTION_NAME (newdecl) = DECL_SECTION_NAME (olddecl);
13333
13334       /* Copy the assembler name.  */
13335       COPY_DECL_ASSEMBLER_NAME (olddecl, newdecl);
13336
13337       if (TREE_CODE (newdecl) == FUNCTION_DECL)
13338         {
13339           DECL_STATIC_CONSTRUCTOR(newdecl) |= DECL_STATIC_CONSTRUCTOR(olddecl);
13340           DECL_STATIC_DESTRUCTOR (newdecl) |= DECL_STATIC_DESTRUCTOR (olddecl);
13341           TREE_THIS_VOLATILE (newdecl) |= TREE_THIS_VOLATILE (olddecl);
13342           TREE_READONLY (newdecl) |= TREE_READONLY (olddecl);
13343           DECL_IS_MALLOC (newdecl) |= DECL_IS_MALLOC (olddecl);
13344           DECL_IS_PURE (newdecl) |= DECL_IS_PURE (olddecl);
13345         }
13346     }
13347   /* If cannot merge, then use the new type and qualifiers,
13348      and don't preserve the old rtl.  */
13349   else
13350     {
13351       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13352       TREE_READONLY (olddecl) = TREE_READONLY (newdecl);
13353       TREE_THIS_VOLATILE (olddecl) = TREE_THIS_VOLATILE (newdecl);
13354       TREE_SIDE_EFFECTS (olddecl) = TREE_SIDE_EFFECTS (newdecl);
13355     }
13356
13357   /* Merge the storage class information.  */
13358   /* For functions, static overrides non-static.  */
13359   if (TREE_CODE (newdecl) == FUNCTION_DECL)
13360     {
13361       TREE_PUBLIC (newdecl) &= TREE_PUBLIC (olddecl);
13362       /* This is since we don't automatically
13363          copy the attributes of NEWDECL into OLDDECL.  */
13364       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13365       /* If this clears `static', clear it in the identifier too.  */
13366       if (! TREE_PUBLIC (olddecl))
13367         TREE_PUBLIC (DECL_NAME (olddecl)) = 0;
13368     }
13369   if (DECL_EXTERNAL (newdecl))
13370     {
13371       TREE_STATIC (newdecl) = TREE_STATIC (olddecl);
13372       DECL_EXTERNAL (newdecl) = DECL_EXTERNAL (olddecl);
13373       /* An extern decl does not override previous storage class.  */
13374       TREE_PUBLIC (newdecl) = TREE_PUBLIC (olddecl);
13375     }
13376   else
13377     {
13378       TREE_STATIC (olddecl) = TREE_STATIC (newdecl);
13379       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13380     }
13381
13382   /* If either decl says `inline', this fn is inline,
13383      unless its definition was passed already.  */
13384   if (DECL_INLINE (newdecl) && DECL_INITIAL (olddecl) == 0)
13385     DECL_INLINE (olddecl) = 1;
13386   DECL_INLINE (newdecl) = DECL_INLINE (olddecl);
13387
13388   /* Get rid of any built-in function if new arg types don't match it
13389      or if we have a function definition.  */
13390   if (TREE_CODE (newdecl) == FUNCTION_DECL
13391       && DECL_BUILT_IN (olddecl)
13392       && (!types_match || new_is_definition))
13393     {
13394       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13395       DECL_BUILT_IN_CLASS (olddecl) = NOT_BUILT_IN;
13396     }
13397
13398   /* If redeclaring a builtin function, and not a definition,
13399      it stays built in.
13400      Also preserve various other info from the definition.  */
13401   if (TREE_CODE (newdecl) == FUNCTION_DECL && !new_is_definition)
13402     {
13403       if (DECL_BUILT_IN (olddecl))
13404         {
13405           DECL_BUILT_IN_CLASS (newdecl) = DECL_BUILT_IN_CLASS (olddecl);
13406           DECL_FUNCTION_CODE (newdecl) = DECL_FUNCTION_CODE (olddecl);
13407         }
13408
13409       DECL_RESULT (newdecl) = DECL_RESULT (olddecl);
13410       DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13411       DECL_SAVED_INSNS (newdecl) = DECL_SAVED_INSNS (olddecl);
13412       DECL_ARGUMENTS (newdecl) = DECL_ARGUMENTS (olddecl);
13413     }
13414
13415   /* Copy most of the decl-specific fields of NEWDECL into OLDDECL.
13416      But preserve olddecl's DECL_UID.  */
13417   {
13418     register unsigned olddecl_uid = DECL_UID (olddecl);
13419
13420     memcpy ((char *) olddecl + sizeof (struct tree_common),
13421             (char *) newdecl + sizeof (struct tree_common),
13422             sizeof (struct tree_decl) - sizeof (struct tree_common));
13423     DECL_UID (olddecl) = olddecl_uid;
13424   }
13425
13426   return 1;
13427 }
13428
13429 /* Finish processing of a declaration;
13430    install its initial value.
13431    If the length of an array type is not known before,
13432    it must be determined now, from the initial value, or it is an error.  */
13433
13434 static void
13435 finish_decl (tree decl, tree init, bool is_top_level)
13436 {
13437   register tree type = TREE_TYPE (decl);
13438   int was_incomplete = (DECL_SIZE (decl) == 0);
13439   bool at_top_level = (current_binding_level == global_binding_level);
13440   bool top_level = is_top_level || at_top_level;
13441
13442   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13443      level anyway.  */
13444   assert (!is_top_level || !at_top_level);
13445
13446   if (TREE_CODE (decl) == PARM_DECL)
13447     assert (init == NULL_TREE);
13448   /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it
13449      overlaps DECL_ARG_TYPE.  */
13450   else if (init == NULL_TREE)
13451     assert (DECL_INITIAL (decl) == NULL_TREE);
13452   else
13453     assert (DECL_INITIAL (decl) == error_mark_node);
13454
13455   if (init != NULL_TREE)
13456     {
13457       if (TREE_CODE (decl) != TYPE_DECL)
13458         DECL_INITIAL (decl) = init;
13459       else
13460         {
13461           /* typedef foo = bar; store the type of bar as the type of foo.  */
13462           TREE_TYPE (decl) = TREE_TYPE (init);
13463           DECL_INITIAL (decl) = init = 0;
13464         }
13465     }
13466
13467   /* Deduce size of array from initialization, if not already known */
13468
13469   if (TREE_CODE (type) == ARRAY_TYPE
13470       && TYPE_DOMAIN (type) == 0
13471       && TREE_CODE (decl) != TYPE_DECL)
13472     {
13473       assert (top_level);
13474       assert (was_incomplete);
13475
13476       layout_decl (decl, 0);
13477     }
13478
13479   if (TREE_CODE (decl) == VAR_DECL)
13480     {
13481       if (DECL_SIZE (decl) == NULL_TREE
13482           && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
13483         layout_decl (decl, 0);
13484
13485       if (DECL_SIZE (decl) == NULL_TREE
13486           && (TREE_STATIC (decl)
13487               ?
13488       /* A static variable with an incomplete type is an error if it is
13489          initialized. Also if it is not file scope. Otherwise, let it
13490          through, but if it is not `extern' then it may cause an error
13491          message later.  */
13492               (DECL_INITIAL (decl) != 0 || DECL_CONTEXT (decl) != 0)
13493               :
13494       /* An automatic variable with an incomplete type is an error.  */
13495               !DECL_EXTERNAL (decl)))
13496         {
13497           assert ("storage size not known" == NULL);
13498           abort ();
13499         }
13500
13501       if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl))
13502           && (DECL_SIZE (decl) != 0)
13503           && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST))
13504         {
13505           assert ("storage size not constant" == NULL);
13506           abort ();
13507         }
13508     }
13509
13510   /* Output the assembler code and/or RTL code for variables and functions,
13511      unless the type is an undefined structure or union. If not, it will get
13512      done when the type is completed.  */
13513
13514   if (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == FUNCTION_DECL)
13515     {
13516       rest_of_decl_compilation (decl, NULL,
13517                                 DECL_CONTEXT (decl) == 0,
13518                                 0);
13519
13520       if (DECL_CONTEXT (decl) != 0)
13521         {
13522           /* Recompute the RTL of a local array now if it used to be an
13523              incomplete type.  */
13524           if (was_incomplete
13525               && !TREE_STATIC (decl) && !DECL_EXTERNAL (decl))
13526             {
13527               /* If we used it already as memory, it must stay in memory.  */
13528               TREE_ADDRESSABLE (decl) = TREE_USED (decl);
13529               /* If it's still incomplete now, no init will save it.  */
13530               if (DECL_SIZE (decl) == 0)
13531                 DECL_INITIAL (decl) = 0;
13532               expand_decl (decl);
13533             }
13534           /* Compute and store the initial value.  */
13535           if (TREE_CODE (decl) != FUNCTION_DECL)
13536             expand_decl_init (decl);
13537         }
13538     }
13539   else if (TREE_CODE (decl) == TYPE_DECL)
13540     {
13541       rest_of_decl_compilation (decl, NULL,
13542                                 DECL_CONTEXT (decl) == 0,
13543                                 0);
13544     }
13545
13546   /* At the end of a declaration, throw away any variable type sizes of types
13547      defined inside that declaration.  There is no use computing them in the
13548      following function definition.  */
13549   if (current_binding_level == global_binding_level)
13550     get_pending_sizes ();
13551 }
13552
13553 /* Finish up a function declaration and compile that function
13554    all the way to assembler language output.  The free the storage
13555    for the function definition.
13556
13557    This is called after parsing the body of the function definition.
13558
13559    NESTED is nonzero if the function being finished is nested in another.  */
13560
13561 static void
13562 finish_function (int nested)
13563 {
13564   register tree fndecl = current_function_decl;
13565
13566   assert (fndecl != NULL_TREE);
13567   if (TREE_CODE (fndecl) != ERROR_MARK)
13568     {
13569       if (nested)
13570         assert (DECL_CONTEXT (fndecl) != NULL_TREE);
13571       else
13572         assert (DECL_CONTEXT (fndecl) == NULL_TREE);
13573     }
13574
13575 /*  TREE_READONLY (fndecl) = 1;
13576     This caused &foo to be of type ptr-to-const-function
13577     which then got a warning when stored in a ptr-to-function variable.  */
13578
13579   poplevel (1, 0, 1);
13580
13581   if (TREE_CODE (fndecl) != ERROR_MARK)
13582     {
13583       BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
13584
13585       /* Must mark the RESULT_DECL as being in this function.  */
13586
13587       DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl;
13588
13589       /* Obey `register' declarations if `setjmp' is called in this fn.  */
13590       /* Generate rtl for function exit.  */
13591       expand_function_end ();
13592
13593       /* If this is a nested function, protect the local variables in the stack
13594          above us from being collected while we're compiling this function.  */
13595       if (nested)
13596         ggc_push_context ();
13597
13598       /* Run the optimizers and output the assembler code for this function.  */
13599       rest_of_compilation (fndecl);
13600
13601       /* Undo the GC context switch.  */
13602       if (nested)
13603         ggc_pop_context ();
13604     }
13605
13606   if (TREE_CODE (fndecl) != ERROR_MARK
13607       && !nested
13608       && DECL_SAVED_INSNS (fndecl) == 0)
13609     {
13610       /* Stop pointing to the local nodes about to be freed.  */
13611       /* But DECL_INITIAL must remain nonzero so we know this was an actual
13612          function definition.  */
13613       /* For a nested function, this is done in pop_f_function_context.  */
13614       /* If rest_of_compilation set this to 0, leave it 0.  */
13615       if (DECL_INITIAL (fndecl) != 0)
13616         DECL_INITIAL (fndecl) = error_mark_node;
13617       DECL_ARGUMENTS (fndecl) = 0;
13618     }
13619
13620   if (!nested)
13621     {
13622       /* Let the error reporting routines know that we're outside a function.
13623          For a nested function, this value is used in pop_c_function_context
13624          and then reset via pop_function_context.  */
13625       ffecom_outer_function_decl_ = current_function_decl = NULL;
13626     }
13627 }
13628
13629 /* Plug-in replacement for identifying the name of a decl and, for a
13630    function, what we call it in diagnostics.  For now, "program unit"
13631    should suffice, since it's a bit of a hassle to figure out which
13632    of several kinds of things it is.  Note that it could conceivably
13633    be a statement function, which probably isn't really a program unit
13634    per se, but if that comes up, it should be easy to check (being a
13635    nested function and all).  */
13636
13637 static const char *
13638 ffe_printable_name (tree decl, int v)
13639 {
13640   /* Just to keep GCC quiet about the unused variable.
13641      In theory, differing values of V should produce different
13642      output.  */
13643   switch (v)
13644     {
13645     default:
13646       if (TREE_CODE (decl) == ERROR_MARK)
13647         return "erroneous code";
13648       return IDENTIFIER_POINTER (DECL_NAME (decl));
13649     }
13650 }
13651
13652 /* g77's function to print out name of current function that caused
13653    an error.  */
13654
13655 static void
13656 ffe_print_error_function (diagnostic_context *context __attribute__((unused)),
13657                           const char *file)
13658 {
13659   static ffeglobal last_g = NULL;
13660   static ffesymbol last_s = NULL;
13661   ffeglobal g;
13662   ffesymbol s;
13663   const char *kind;
13664
13665   if ((ffecom_primary_entry_ == NULL)
13666       || (ffesymbol_global (ffecom_primary_entry_) == NULL))
13667     {
13668       g = NULL;
13669       s = NULL;
13670       kind = NULL;
13671     }
13672   else
13673     {
13674       g = ffesymbol_global (ffecom_primary_entry_);
13675       if (ffecom_nested_entry_ == NULL)
13676         {
13677           s = ffecom_primary_entry_;
13678           kind = _(ffeinfo_kind_message (ffesymbol_kind (s)));
13679         }
13680       else
13681         {
13682           s = ffecom_nested_entry_;
13683           kind = _("In statement function");
13684         }
13685     }
13686
13687   if ((last_g != g) || (last_s != s))
13688     {
13689       if (file)
13690         fprintf (stderr, "%s: ", file);
13691
13692       if (s == NULL)
13693         fprintf (stderr, _("Outside of any program unit:\n"));
13694       else
13695         {
13696           const char *name = ffesymbol_text (s);
13697
13698           fprintf (stderr, "%s `%s':\n", kind, name);
13699         }
13700
13701       last_g = g;
13702       last_s = s;
13703     }
13704 }
13705
13706 /* Similar to `lookup_name' but look only at current binding level.  */
13707
13708 static tree
13709 lookup_name_current_level (tree name)
13710 {
13711   register tree t;
13712
13713   if (current_binding_level == global_binding_level)
13714     return IDENTIFIER_GLOBAL_VALUE (name);
13715
13716   if (IDENTIFIER_LOCAL_VALUE (name) == 0)
13717     return 0;
13718
13719   for (t = current_binding_level->names; t; t = TREE_CHAIN (t))
13720     if (DECL_NAME (t) == name)
13721       break;
13722
13723   return t;
13724 }
13725
13726 /* Create a new `struct f_binding_level'.  */
13727
13728 static struct f_binding_level *
13729 make_binding_level (void)
13730 {
13731   /* NOSTRICT */
13732   return ggc_alloc (sizeof (struct f_binding_level));
13733 }
13734
13735 /* Save and restore the variables in this file and elsewhere
13736    that keep track of the progress of compilation of the current function.
13737    Used for nested functions.  */
13738
13739 struct f_function
13740 {
13741   struct f_function *next;
13742   tree named_labels;
13743   tree shadowed_labels;
13744   struct f_binding_level *binding_level;
13745 };
13746
13747 struct f_function *f_function_chain;
13748
13749 /* Restore the variables used during compilation of a C function.  */
13750
13751 static void
13752 pop_f_function_context (void)
13753 {
13754   struct f_function *p = f_function_chain;
13755   tree link;
13756
13757   /* Bring back all the labels that were shadowed.  */
13758   for (link = shadowed_labels; link; link = TREE_CHAIN (link))
13759     if (DECL_NAME (TREE_VALUE (link)) != 0)
13760       IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link)))
13761         = TREE_VALUE (link);
13762
13763   if (current_function_decl != error_mark_node
13764       && DECL_SAVED_INSNS (current_function_decl) == 0)
13765     {
13766       /* Stop pointing to the local nodes about to be freed.  */
13767       /* But DECL_INITIAL must remain nonzero so we know this was an actual
13768          function definition.  */
13769       DECL_INITIAL (current_function_decl) = error_mark_node;
13770       DECL_ARGUMENTS (current_function_decl) = 0;
13771     }
13772
13773   pop_function_context ();
13774
13775   f_function_chain = p->next;
13776
13777   named_labels = p->named_labels;
13778   shadowed_labels = p->shadowed_labels;
13779   current_binding_level = p->binding_level;
13780
13781   free (p);
13782 }
13783
13784 /* Save and reinitialize the variables
13785    used during compilation of a C function.  */
13786
13787 static void
13788 push_f_function_context (void)
13789 {
13790   struct f_function *p
13791   = (struct f_function *) xmalloc (sizeof (struct f_function));
13792
13793   push_function_context ();
13794
13795   p->next = f_function_chain;
13796   f_function_chain = p;
13797
13798   p->named_labels = named_labels;
13799   p->shadowed_labels = shadowed_labels;
13800   p->binding_level = current_binding_level;
13801 }
13802
13803 static void
13804 push_parm_decl (tree parm)
13805 {
13806   int old_immediate_size_expand = immediate_size_expand;
13807
13808   /* Don't try computing parm sizes now -- wait till fn is called.  */
13809
13810   immediate_size_expand = 0;
13811
13812   /* Fill in arg stuff.  */
13813
13814   DECL_ARG_TYPE (parm) = TREE_TYPE (parm);
13815   DECL_ARG_TYPE_AS_WRITTEN (parm) = TREE_TYPE (parm);
13816   TREE_READONLY (parm) = 1;     /* All implementation args are read-only. */
13817
13818   parm = pushdecl (parm);
13819
13820   immediate_size_expand = old_immediate_size_expand;
13821
13822   finish_decl (parm, NULL_TREE, FALSE);
13823 }
13824
13825 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate.  */
13826
13827 static tree
13828 pushdecl_top_level (tree x)
13829 {
13830   register tree t;
13831   register struct f_binding_level *b = current_binding_level;
13832   register tree f = current_function_decl;
13833
13834   current_binding_level = global_binding_level;
13835   current_function_decl = NULL_TREE;
13836   t = pushdecl (x);
13837   current_binding_level = b;
13838   current_function_decl = f;
13839   return t;
13840 }
13841
13842 /* Store the list of declarations of the current level.
13843    This is done for the parameter declarations of a function being defined,
13844    after they are modified in the light of any missing parameters.  */
13845
13846 static tree
13847 storedecls (tree decls)
13848 {
13849   return current_binding_level->names = decls;
13850 }
13851
13852 /* Store the parameter declarations into the current function declaration.
13853    This is called after parsing the parameter declarations, before
13854    digesting the body of the function.
13855
13856    For an old-style definition, modify the function's type
13857    to specify at least the number of arguments.  */
13858
13859 static void
13860 store_parm_decls (int is_main_program UNUSED)
13861 {
13862   register tree fndecl = current_function_decl;
13863
13864   if (fndecl == error_mark_node)
13865     return;
13866
13867   /* This is a chain of PARM_DECLs from old-style parm declarations.  */
13868   DECL_ARGUMENTS (fndecl) = storedecls (nreverse (getdecls ()));
13869
13870   /* Initialize the RTL code for the function.  */
13871   init_function_start (fndecl);
13872
13873   /* Set up parameters and prepare for return, for the function.  */
13874   expand_function_start (fndecl, 0);
13875 }
13876
13877 static tree
13878 start_decl (tree decl, bool is_top_level)
13879 {
13880   register tree tem;
13881   bool at_top_level = (current_binding_level == global_binding_level);
13882   bool top_level = is_top_level || at_top_level;
13883
13884   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13885      level anyway.  */
13886   assert (!is_top_level || !at_top_level);
13887
13888   if (DECL_INITIAL (decl) != NULL_TREE)
13889     {
13890       assert (DECL_INITIAL (decl) == error_mark_node);
13891       assert (!DECL_EXTERNAL (decl));
13892     }
13893   else if (top_level)
13894     assert ((TREE_STATIC (decl) == 1) || DECL_EXTERNAL (decl) == 1);
13895
13896   /* For Fortran, we by default put things in .common when possible.  */
13897   DECL_COMMON (decl) = 1;
13898
13899   /* Add this decl to the current binding level. TEM may equal DECL or it may
13900      be a previous decl of the same name.  */
13901   if (is_top_level)
13902     tem = pushdecl_top_level (decl);
13903   else
13904     tem = pushdecl (decl);
13905
13906   /* For a local variable, define the RTL now.  */
13907   if (!top_level
13908   /* But not if this is a duplicate decl and we preserved the rtl from the
13909      previous one (which may or may not happen).  */
13910       && !DECL_RTL_SET_P (tem))
13911     {
13912       if (TYPE_SIZE (TREE_TYPE (tem)) != 0)
13913         expand_decl (tem);
13914       else if (TREE_CODE (TREE_TYPE (tem)) == ARRAY_TYPE
13915                && DECL_INITIAL (tem) != 0)
13916         expand_decl (tem);
13917     }
13918
13919   return tem;
13920 }
13921
13922 /* Create the FUNCTION_DECL for a function definition.
13923    DECLSPECS and DECLARATOR are the parts of the declaration;
13924    they describe the function's name and the type it returns,
13925    but twisted together in a fashion that parallels the syntax of C.
13926
13927    This function creates a binding context for the function body
13928    as well as setting up the FUNCTION_DECL in current_function_decl.
13929
13930    Returns 1 on success.  If the DECLARATOR is not suitable for a function
13931    (it defines a datum instead), we return 0, which tells
13932    ffe_parse_file to report a parse error.
13933
13934    NESTED is nonzero for a function nested within another function.  */
13935
13936 static void
13937 start_function (tree name, tree type, int nested, int public)
13938 {
13939   tree decl1;
13940   tree restype;
13941   int old_immediate_size_expand = immediate_size_expand;
13942
13943   named_labels = 0;
13944   shadowed_labels = 0;
13945
13946   /* Don't expand any sizes in the return type of the function.  */
13947   immediate_size_expand = 0;
13948
13949   if (nested)
13950     {
13951       assert (!public);
13952       assert (current_function_decl != NULL_TREE);
13953       assert (DECL_CONTEXT (current_function_decl) == NULL_TREE);
13954     }
13955   else
13956     {
13957       assert (current_function_decl == NULL_TREE);
13958     }
13959
13960   if (TREE_CODE (type) == ERROR_MARK)
13961     decl1 = current_function_decl = error_mark_node;
13962   else
13963     {
13964       decl1 = build_decl (FUNCTION_DECL,
13965                           name,
13966                           type);
13967       TREE_PUBLIC (decl1) = public ? 1 : 0;
13968       if (nested)
13969         DECL_INLINE (decl1) = 1;
13970       TREE_STATIC (decl1) = 1;
13971       DECL_EXTERNAL (decl1) = 0;
13972
13973       announce_function (decl1);
13974
13975       /* Make the init_value nonzero so pushdecl knows this is not tentative.
13976          error_mark_node is replaced below (in poplevel) with the BLOCK.  */
13977       DECL_INITIAL (decl1) = error_mark_node;
13978
13979       /* Record the decl so that the function name is defined. If we already have
13980          a decl for this name, and it is a FUNCTION_DECL, use the old decl.  */
13981
13982       current_function_decl = pushdecl (decl1);
13983     }
13984
13985   if (!nested)
13986     ffecom_outer_function_decl_ = current_function_decl;
13987
13988   pushlevel (0);
13989   current_binding_level->prep_state = 2;
13990
13991   if (TREE_CODE (current_function_decl) != ERROR_MARK)
13992     {
13993       make_decl_rtl (current_function_decl, NULL);
13994
13995       restype = TREE_TYPE (TREE_TYPE (current_function_decl));
13996       DECL_RESULT (current_function_decl)
13997         = build_decl (RESULT_DECL, NULL_TREE, restype);
13998     }
13999
14000   if (!nested && (TREE_CODE (current_function_decl) != ERROR_MARK))
14001     TREE_ADDRESSABLE (current_function_decl) = 1;
14002
14003   immediate_size_expand = old_immediate_size_expand;
14004 }
14005 \f
14006 /* Here are the public functions the GNU back end needs.  */
14007
14008 tree
14009 convert (tree type, tree expr)
14010 {
14011   register tree e = expr;
14012   register enum tree_code code = TREE_CODE (type);
14013
14014   if (type == TREE_TYPE (e)
14015       || TREE_CODE (e) == ERROR_MARK)
14016     return e;
14017   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
14018     return fold (build1 (NOP_EXPR, type, e));
14019   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
14020       || code == ERROR_MARK)
14021     return error_mark_node;
14022   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
14023     {
14024       assert ("void value not ignored as it ought to be" == NULL);
14025       return error_mark_node;
14026     }
14027   if (code == VOID_TYPE)
14028     return build1 (CONVERT_EXPR, type, e);
14029   if ((code != RECORD_TYPE)
14030       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
14031     e = ffecom_1 (REALPART_EXPR, TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e))),
14032                   e);
14033   if (code == INTEGER_TYPE || code == ENUMERAL_TYPE)
14034     return fold (convert_to_integer (type, e));
14035   if (code == POINTER_TYPE)
14036     return fold (convert_to_pointer (type, e));
14037   if (code == REAL_TYPE)
14038     return fold (convert_to_real (type, e));
14039   if (code == COMPLEX_TYPE)
14040     return fold (convert_to_complex (type, e));
14041   if (code == RECORD_TYPE)
14042     return fold (ffecom_convert_to_complex_ (type, e));
14043
14044   assert ("conversion to non-scalar type requested" == NULL);
14045   return error_mark_node;
14046 }
14047
14048 /* Return the list of declarations of the current level.
14049    Note that this list is in reverse order unless/until
14050    you nreverse it; and when you do nreverse it, you must
14051    store the result back using `storedecls' or you will lose.  */
14052
14053 tree
14054 getdecls (void)
14055 {
14056   return current_binding_level->names;
14057 }
14058
14059 /* Nonzero if we are currently in the global binding level.  */
14060
14061 int
14062 global_bindings_p (void)
14063 {
14064   return current_binding_level == global_binding_level;
14065 }
14066
14067 static void
14068 ffecom_init_decl_processing (void)
14069 {
14070   malloc_init ();
14071
14072   ffe_init_0 ();
14073 }
14074
14075 /* Delete the node BLOCK from the current binding level.
14076    This is used for the block inside a stmt expr ({...})
14077    so that the block can be reinserted where appropriate.  */
14078
14079 static void
14080 delete_block (tree block)
14081 {
14082   tree t;
14083   if (current_binding_level->blocks == block)
14084     current_binding_level->blocks = TREE_CHAIN (block);
14085   for (t = current_binding_level->blocks; t;)
14086     {
14087       if (TREE_CHAIN (t) == block)
14088         TREE_CHAIN (t) = TREE_CHAIN (block);
14089       else
14090         t = TREE_CHAIN (t);
14091     }
14092   TREE_CHAIN (block) = NULL;
14093   /* Clear TREE_USED which is always set by poplevel.
14094      The flag is set again if insert_block is called.  */
14095   TREE_USED (block) = 0;
14096 }
14097
14098 void
14099 insert_block (tree block)
14100 {
14101   TREE_USED (block) = 1;
14102   current_binding_level->blocks
14103     = chainon (current_binding_level->blocks, block);
14104 }
14105
14106 /* Each front end provides its own.  */
14107 static bool ffe_init (void);
14108 static void ffe_finish (void);
14109 static bool ffe_post_options (const char **);
14110 static void ffe_print_identifier (FILE *, tree, int);
14111
14112 struct language_function GTY(())
14113 {
14114   int unused;
14115 };
14116
14117 #undef  LANG_HOOKS_NAME
14118 #define LANG_HOOKS_NAME                 "GNU F77"
14119 #undef  LANG_HOOKS_INIT
14120 #define LANG_HOOKS_INIT                 ffe_init
14121 #undef  LANG_HOOKS_FINISH
14122 #define LANG_HOOKS_FINISH               ffe_finish
14123 #undef  LANG_HOOKS_INIT_OPTIONS
14124 #define LANG_HOOKS_INIT_OPTIONS         ffe_init_options
14125 #undef  LANG_HOOKS_HANDLE_OPTION
14126 #define LANG_HOOKS_HANDLE_OPTION        ffe_handle_option
14127 #undef  LANG_HOOKS_POST_OPTIONS
14128 #define LANG_HOOKS_POST_OPTIONS         ffe_post_options
14129 #undef  LANG_HOOKS_PARSE_FILE
14130 #define LANG_HOOKS_PARSE_FILE           ffe_parse_file
14131 #undef  LANG_HOOKS_MARK_ADDRESSABLE
14132 #define LANG_HOOKS_MARK_ADDRESSABLE     ffe_mark_addressable
14133 #undef  LANG_HOOKS_PRINT_IDENTIFIER
14134 #define LANG_HOOKS_PRINT_IDENTIFIER     ffe_print_identifier
14135 #undef  LANG_HOOKS_DECL_PRINTABLE_NAME
14136 #define LANG_HOOKS_DECL_PRINTABLE_NAME  ffe_printable_name
14137 #undef  LANG_HOOKS_PRINT_ERROR_FUNCTION
14138 #define LANG_HOOKS_PRINT_ERROR_FUNCTION ffe_print_error_function
14139 #undef  LANG_HOOKS_TRUTHVALUE_CONVERSION
14140 #define LANG_HOOKS_TRUTHVALUE_CONVERSION ffe_truthvalue_conversion
14141
14142 #undef  LANG_HOOKS_TYPE_FOR_MODE
14143 #define LANG_HOOKS_TYPE_FOR_MODE        ffe_type_for_mode
14144 #undef  LANG_HOOKS_TYPE_FOR_SIZE
14145 #define LANG_HOOKS_TYPE_FOR_SIZE        ffe_type_for_size
14146 #undef  LANG_HOOKS_SIGNED_TYPE
14147 #define LANG_HOOKS_SIGNED_TYPE          ffe_signed_type
14148 #undef  LANG_HOOKS_UNSIGNED_TYPE
14149 #define LANG_HOOKS_UNSIGNED_TYPE        ffe_unsigned_type
14150 #undef  LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE
14151 #define LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE ffe_signed_or_unsigned_type
14152
14153 /* We do not wish to use alias-set based aliasing at all.  Used in the
14154    extreme (every object with its own set, with equivalences recorded) it
14155    might be helpful, but there are problems when it comes to inlining.  We
14156    get on ok with flag_argument_noalias, and alias-set aliasing does
14157    currently limit how stack slots can be reused, which is a lose.  */
14158 #undef LANG_HOOKS_GET_ALIAS_SET
14159 #define LANG_HOOKS_GET_ALIAS_SET hook_get_alias_set_0
14160
14161 const struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER;
14162
14163 /* Table indexed by tree code giving a string containing a character
14164    classifying the tree code.  Possibilities are
14165    t, d, s, c, r, <, 1, 2 and e.  See tree.def for details.  */
14166
14167 #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) TYPE,
14168
14169 const char tree_code_type[] = {
14170 #include "tree.def"
14171 };
14172 #undef DEFTREECODE
14173
14174 /* Table indexed by tree code giving number of expression
14175    operands beyond the fixed part of the node structure.
14176    Not used for types or decls.  */
14177
14178 #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) LENGTH,
14179
14180 const unsigned char tree_code_length[] = {
14181 #include "tree.def"
14182 };
14183 #undef DEFTREECODE
14184
14185 /* Names of tree components.
14186    Used for printing out the tree and error messages.  */
14187 #define DEFTREECODE(SYM, NAME, TYPE, LEN) NAME,
14188
14189 const char *const tree_code_name[] = {
14190 #include "tree.def"
14191 };
14192 #undef DEFTREECODE
14193
14194 static bool
14195 ffe_post_options (const char **pfilename)
14196 {
14197   const char *filename = *pfilename;
14198
14199   /* Open input file.  */
14200   if (filename == 0 || !strcmp (filename, "-"))
14201     {
14202       finput = stdin;
14203       filename = "stdin";
14204     }
14205   else
14206     finput = fopen (filename, "r");
14207
14208   if (finput == 0)
14209     fatal_error ("can't open %s: %m", filename);
14210
14211   return false;
14212 }
14213
14214
14215 static bool
14216 ffe_init (void)
14217 {
14218 #ifdef IO_BUFFER_SIZE
14219   setvbuf (finput, (char *) xmalloc (IO_BUFFER_SIZE), _IOFBF, IO_BUFFER_SIZE);
14220 #endif
14221
14222   ffecom_init_decl_processing ();
14223
14224   /* If the file is output from cpp, it should contain a first line
14225      `# 1 "real-filename"', and the current design of gcc (toplev.c
14226      in particular and the way it sets up information relied on by
14227      INCLUDE) requires that we read this now, and store the
14228      "real-filename" info in master_input_filename.  Ask the lexer
14229      to try doing this.  */
14230   ffelex_hash_kludge (finput);
14231
14232   push_srcloc (input_filename, 0);
14233
14234   /* FIXME: The ffelex_hash_kludge code needs to be cleaned up to
14235      set the new file name.  Maybe in ffe_post_options.  */
14236   return true;
14237 }
14238
14239 static void
14240 ffe_finish (void)
14241 {
14242   ffe_terminate_0 ();
14243
14244   if (ffe_is_ffedebug ())
14245     malloc_pool_display (malloc_pool_image ());
14246
14247   fclose (finput);
14248 }
14249
14250 static bool
14251 ffe_mark_addressable (tree exp)
14252 {
14253   register tree x = exp;
14254   while (1)
14255     switch (TREE_CODE (x))
14256       {
14257       case ADDR_EXPR:
14258       case COMPONENT_REF:
14259       case ARRAY_REF:
14260         x = TREE_OPERAND (x, 0);
14261         break;
14262
14263       case CONSTRUCTOR:
14264         TREE_ADDRESSABLE (x) = 1;
14265         return true;
14266
14267       case VAR_DECL:
14268       case CONST_DECL:
14269       case PARM_DECL:
14270       case RESULT_DECL:
14271         if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x)
14272             && DECL_NONLOCAL (x))
14273           {
14274             if (TREE_PUBLIC (x))
14275               {
14276                 assert ("address of global register var requested" == NULL);
14277                 return false;
14278               }
14279             assert ("address of register variable requested" == NULL);
14280           }
14281         else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x))
14282           {
14283             if (TREE_PUBLIC (x))
14284               {
14285                 assert ("address of global register var requested" == NULL);
14286                 return false;
14287               }
14288             assert ("address of register var requested" == NULL);
14289           }
14290         put_var_into_stack (x, /*rescan=*/true);
14291
14292         /* drops in */
14293       case FUNCTION_DECL:
14294         TREE_ADDRESSABLE (x) = 1;
14295 #if 0                           /* poplevel deals with this now.  */
14296         if (DECL_CONTEXT (x) == 0)
14297           TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x)) = 1;
14298 #endif
14299
14300       default:
14301         return true;
14302       }
14303 }
14304
14305 /* Exit a binding level.
14306    Pop the level off, and restore the state of the identifier-decl mappings
14307    that were in effect when this level was entered.
14308
14309    If KEEP is nonzero, this level had explicit declarations, so
14310    and create a "block" (a BLOCK node) for the level
14311    to record its declarations and subblocks for symbol table output.
14312
14313    If FUNCTIONBODY is nonzero, this level is the body of a function,
14314    so create a block as if KEEP were set and also clear out all
14315    label names.
14316
14317    If REVERSE is nonzero, reverse the order of decls before putting
14318    them into the BLOCK.  */
14319
14320 tree
14321 poplevel (int keep, int reverse, int functionbody)
14322 {
14323   register tree link;
14324   /* The chain of decls was accumulated in reverse order.
14325      Put it into forward order, just for cleanliness.  */
14326   tree decls;
14327   tree subblocks = current_binding_level->blocks;
14328   tree block = 0;
14329   tree decl;
14330   int block_previously_created;
14331
14332   /* Get the decls in the order they were written.
14333      Usually current_binding_level->names is in reverse order.
14334      But parameter decls were previously put in forward order.  */
14335
14336   if (reverse)
14337     current_binding_level->names
14338       = decls = nreverse (current_binding_level->names);
14339   else
14340     decls = current_binding_level->names;
14341
14342   /* Output any nested inline functions within this block
14343      if they weren't already output.  */
14344
14345   for (decl = decls; decl; decl = TREE_CHAIN (decl))
14346     if (TREE_CODE (decl) == FUNCTION_DECL
14347         && ! TREE_ASM_WRITTEN (decl)
14348         && DECL_INITIAL (decl) != 0
14349         && TREE_ADDRESSABLE (decl))
14350       {
14351         /* If this decl was copied from a file-scope decl
14352            on account of a block-scope extern decl,
14353            propagate TREE_ADDRESSABLE to the file-scope decl.
14354
14355            DECL_ABSTRACT_ORIGIN can be set to itself if warn_return_type is
14356            true, since then the decl goes through save_for_inline_copying.  */
14357         if (DECL_ABSTRACT_ORIGIN (decl) != 0
14358             && DECL_ABSTRACT_ORIGIN (decl) != decl)
14359           TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl)) = 1;
14360         else if (DECL_SAVED_INSNS (decl) != 0)
14361           {
14362             push_function_context ();
14363             output_inline_function (decl);
14364             pop_function_context ();
14365           }
14366       }
14367
14368   /* If there were any declarations or structure tags in that level,
14369      or if this level is a function body,
14370      create a BLOCK to record them for the life of this function.  */
14371
14372   block = 0;
14373   block_previously_created = (current_binding_level->this_block != 0);
14374   if (block_previously_created)
14375     block = current_binding_level->this_block;
14376   else if (keep || functionbody)
14377     block = make_node (BLOCK);
14378   if (block != 0)
14379     {
14380       BLOCK_VARS (block) = decls;
14381       BLOCK_SUBBLOCKS (block) = subblocks;
14382     }
14383
14384   /* In each subblock, record that this is its superior.  */
14385
14386   for (link = subblocks; link; link = TREE_CHAIN (link))
14387     BLOCK_SUPERCONTEXT (link) = block;
14388
14389   /* Clear out the meanings of the local variables of this level.  */
14390
14391   for (link = decls; link; link = TREE_CHAIN (link))
14392     {
14393       if (DECL_NAME (link) != 0)
14394         {
14395           /* If the ident. was used or addressed via a local extern decl,
14396              don't forget that fact.  */
14397           if (DECL_EXTERNAL (link))
14398             {
14399               if (TREE_USED (link))
14400                 TREE_USED (DECL_NAME (link)) = 1;
14401               if (TREE_ADDRESSABLE (link))
14402                 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (link)) = 1;
14403             }
14404           IDENTIFIER_LOCAL_VALUE (DECL_NAME (link)) = 0;
14405         }
14406     }
14407
14408   /* If the level being exited is the top level of a function,
14409      check over all the labels, and clear out the current
14410      (function local) meanings of their names.  */
14411
14412   if (functionbody)
14413     {
14414       /* If this is the top level block of a function,
14415          the vars are the function's parameters.
14416          Don't leave them in the BLOCK because they are
14417          found in the FUNCTION_DECL instead.  */
14418
14419       BLOCK_VARS (block) = 0;
14420     }
14421
14422   /* Pop the current level, and free the structure for reuse.  */
14423
14424   {
14425     register struct f_binding_level *level = current_binding_level;
14426     current_binding_level = current_binding_level->level_chain;
14427
14428     level->level_chain = free_binding_level;
14429     free_binding_level = level;
14430   }
14431
14432   /* Dispose of the block that we just made inside some higher level.  */
14433   if (functionbody
14434       && current_function_decl != error_mark_node)
14435     DECL_INITIAL (current_function_decl) = block;
14436   else if (block)
14437     {
14438       if (!block_previously_created)
14439         current_binding_level->blocks
14440           = chainon (current_binding_level->blocks, block);
14441     }
14442   /* If we did not make a block for the level just exited,
14443      any blocks made for inner levels
14444      (since they cannot be recorded as subblocks in that level)
14445      must be carried forward so they will later become subblocks
14446      of something else.  */
14447   else if (subblocks)
14448     current_binding_level->blocks
14449       = chainon (current_binding_level->blocks, subblocks);
14450
14451   if (block)
14452     TREE_USED (block) = 1;
14453   return block;
14454 }
14455
14456 static void
14457 ffe_print_identifier (FILE *file, tree node, int indent)
14458 {
14459   print_node (file, "global", IDENTIFIER_GLOBAL_VALUE (node), indent + 4);
14460   print_node (file, "local", IDENTIFIER_LOCAL_VALUE (node), indent + 4);
14461 }
14462
14463 /* Record a decl-node X as belonging to the current lexical scope.
14464    Check for errors (such as an incompatible declaration for the same
14465    name already seen in the same scope).
14466
14467    Returns either X or an old decl for the same name.
14468    If an old decl is returned, it may have been smashed
14469    to agree with what X says.  */
14470
14471 tree
14472 pushdecl (tree x)
14473 {
14474   register tree t;
14475   register tree name = DECL_NAME (x);
14476   register struct f_binding_level *b = current_binding_level;
14477
14478   if ((TREE_CODE (x) == FUNCTION_DECL)
14479       && (DECL_INITIAL (x) == 0)
14480       && DECL_EXTERNAL (x))
14481     DECL_CONTEXT (x) = NULL_TREE;
14482   else
14483     DECL_CONTEXT (x) = current_function_decl;
14484
14485   if (name)
14486     {
14487       if (IDENTIFIER_INVENTED (name))
14488         {
14489           DECL_ARTIFICIAL (x) = 1;
14490           DECL_IN_SYSTEM_HEADER (x) = 1;
14491         }
14492
14493       t = lookup_name_current_level (name);
14494
14495       assert ((t == NULL_TREE) || (DECL_CONTEXT (x) == NULL_TREE));
14496
14497       /* Don't push non-parms onto list for parms until we understand
14498          why we're doing this and whether it works.  */
14499
14500       assert ((b == global_binding_level)
14501               || !ffecom_transform_only_dummies_
14502               || TREE_CODE (x) == PARM_DECL);
14503
14504       if ((t != NULL_TREE) && duplicate_decls (x, t))
14505         return t;
14506
14507       /* If we are processing a typedef statement, generate a whole new
14508          ..._TYPE node (which will be just an variant of the existing
14509          ..._TYPE node with identical properties) and then install the
14510          TYPE_DECL node generated to represent the typedef name as the
14511          TYPE_NAME of this brand new (duplicate) ..._TYPE node.
14512
14513          The whole point here is to end up with a situation where each and every
14514          ..._TYPE node the compiler creates will be uniquely associated with
14515          AT MOST one node representing a typedef name. This way, even though
14516          the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL
14517          (i.e. "typedef name") nodes very early on, later parts of the
14518          compiler can always do the reverse translation and get back the
14519          corresponding typedef name.  For example, given:
14520
14521          typedef struct S MY_TYPE; MY_TYPE object;
14522
14523          Later parts of the compiler might only know that `object' was of type
14524          `struct S' if it were not for code just below.  With this code
14525          however, later parts of the compiler see something like:
14526
14527          struct S' == struct S typedef struct S' MY_TYPE; struct S' object;
14528
14529          And they can then deduce (from the node for type struct S') that the
14530          original object declaration was:
14531
14532          MY_TYPE object;
14533
14534          Being able to do this is important for proper support of protoize, and
14535          also for generating precise symbolic debugging information which
14536          takes full account of the programmer's (typedef) vocabulary.
14537
14538          Obviously, we don't want to generate a duplicate ..._TYPE node if the
14539          TYPE_DECL node that we are now processing really represents a
14540          standard built-in type.
14541
14542          Since all standard types are effectively declared at line zero in the
14543          source file, we can easily check to see if we are working on a
14544          standard type by checking the current value of lineno.  */
14545
14546       if (TREE_CODE (x) == TYPE_DECL)
14547         {
14548           if (DECL_SOURCE_LINE (x) == 0)
14549             {
14550               if (TYPE_NAME (TREE_TYPE (x)) == 0)
14551                 TYPE_NAME (TREE_TYPE (x)) = x;
14552             }
14553           else if (TREE_TYPE (x) != error_mark_node)
14554             {
14555               tree tt = TREE_TYPE (x);
14556
14557               tt = build_type_copy (tt);
14558               TYPE_NAME (tt) = x;
14559               TREE_TYPE (x) = tt;
14560             }
14561         }
14562
14563       /* This name is new in its binding level. Install the new declaration
14564          and return it.  */
14565       if (b == global_binding_level)
14566         IDENTIFIER_GLOBAL_VALUE (name) = x;
14567       else
14568         IDENTIFIER_LOCAL_VALUE (name) = x;
14569     }
14570
14571   /* Put decls on list in reverse order. We will reverse them later if
14572      necessary.  */
14573   TREE_CHAIN (x) = b->names;
14574   b->names = x;
14575
14576   return x;
14577 }
14578
14579 /* Nonzero if the current level needs to have a BLOCK made.  */
14580
14581 static int
14582 kept_level_p (void)
14583 {
14584   tree decl;
14585
14586   for (decl = current_binding_level->names;
14587        decl;
14588        decl = TREE_CHAIN (decl))
14589     {
14590       if (TREE_USED (decl) || TREE_CODE (decl) != VAR_DECL
14591           || (DECL_NAME (decl) && ! DECL_ARTIFICIAL (decl)))
14592         /* Currently, there aren't supposed to be non-artificial names
14593            at other than the top block for a function -- they're
14594            believed to always be temps.  But it's wise to check anyway.  */
14595         return 1;
14596     }
14597   return 0;
14598 }
14599
14600 /* Enter a new binding level.
14601    If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
14602    not for that of tags.  */
14603
14604 void
14605 pushlevel (int tag_transparent)
14606 {
14607   register struct f_binding_level *newlevel = NULL_BINDING_LEVEL;
14608
14609   assert (! tag_transparent);
14610
14611   if (current_binding_level == global_binding_level)
14612     {
14613       named_labels = 0;
14614     }
14615
14616   /* Reuse or create a struct for this binding level.  */
14617
14618   if (free_binding_level)
14619     {
14620       newlevel = free_binding_level;
14621       free_binding_level = free_binding_level->level_chain;
14622     }
14623   else
14624     {
14625       newlevel = make_binding_level ();
14626     }
14627
14628   /* Add this level to the front of the chain (stack) of levels that
14629      are active.  */
14630
14631   *newlevel = clear_binding_level;
14632   newlevel->level_chain = current_binding_level;
14633   current_binding_level = newlevel;
14634 }
14635
14636 /* Set the BLOCK node for the innermost scope
14637    (the one we are currently in).  */
14638
14639 void
14640 set_block (tree block)
14641 {
14642   current_binding_level->this_block = block;
14643   current_binding_level->names = chainon (current_binding_level->names,
14644                                           BLOCK_VARS (block));
14645   current_binding_level->blocks = chainon (current_binding_level->blocks,
14646                                            BLOCK_SUBBLOCKS (block));
14647 }
14648
14649 static tree
14650 ffe_signed_or_unsigned_type (int unsignedp, tree type)
14651 {
14652   tree type2;
14653
14654   if (! INTEGRAL_TYPE_P (type))
14655     return type;
14656   if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node))
14657     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
14658   if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node))
14659     return unsignedp ? unsigned_type_node : integer_type_node;
14660   if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node))
14661     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
14662   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node))
14663     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
14664   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node))
14665     return (unsignedp ? long_long_unsigned_type_node
14666             : long_long_integer_type_node);
14667
14668   type2 = ffe_type_for_size (TYPE_PRECISION (type), unsignedp);
14669   if (type2 == NULL_TREE)
14670     return type;
14671
14672   return type2;
14673 }
14674
14675 static tree
14676 ffe_signed_type (tree type)
14677 {
14678   tree type1 = TYPE_MAIN_VARIANT (type);
14679   ffeinfoKindtype kt;
14680   tree type2;
14681
14682   if (type1 == unsigned_char_type_node || type1 == char_type_node)
14683     return signed_char_type_node;
14684   if (type1 == unsigned_type_node)
14685     return integer_type_node;
14686   if (type1 == short_unsigned_type_node)
14687     return short_integer_type_node;
14688   if (type1 == long_unsigned_type_node)
14689     return long_integer_type_node;
14690   if (type1 == long_long_unsigned_type_node)
14691     return long_long_integer_type_node;
14692 #if 0   /* gcc/c-* files only */
14693   if (type1 == unsigned_intDI_type_node)
14694     return intDI_type_node;
14695   if (type1 == unsigned_intSI_type_node)
14696     return intSI_type_node;
14697   if (type1 == unsigned_intHI_type_node)
14698     return intHI_type_node;
14699   if (type1 == unsigned_intQI_type_node)
14700     return intQI_type_node;
14701 #endif
14702
14703   type2 = ffe_type_for_size (TYPE_PRECISION (type1), 0);
14704   if (type2 != NULL_TREE)
14705     return type2;
14706
14707   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
14708     {
14709       type2 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
14710
14711       if (type1 == type2)
14712         return ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
14713     }
14714
14715   return type;
14716 }
14717
14718 /* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
14719    or validate its data type for an `if' or `while' statement or ?..: exp.
14720
14721    This preparation consists of taking the ordinary
14722    representation of an expression expr and producing a valid tree
14723    boolean expression describing whether expr is nonzero.  We could
14724    simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
14725    but we optimize comparisons, &&, ||, and !.
14726
14727    The resulting type should always be `integer_type_node'.  */
14728
14729 static tree
14730 ffe_truthvalue_conversion (tree expr)
14731 {
14732   if (TREE_CODE (expr) == ERROR_MARK)
14733     return expr;
14734
14735 #if 0 /* This appears to be wrong for C++.  */
14736   /* These really should return error_mark_node after 2.4 is stable.
14737      But not all callers handle ERROR_MARK properly.  */
14738   switch (TREE_CODE (TREE_TYPE (expr)))
14739     {
14740     case RECORD_TYPE:
14741       error ("struct type value used where scalar is required");
14742       return integer_zero_node;
14743
14744     case UNION_TYPE:
14745       error ("union type value used where scalar is required");
14746       return integer_zero_node;
14747
14748     case ARRAY_TYPE:
14749       error ("array type value used where scalar is required");
14750       return integer_zero_node;
14751
14752     default:
14753       break;
14754     }
14755 #endif /* 0 */
14756
14757   switch (TREE_CODE (expr))
14758     {
14759       /* It is simpler and generates better code to have only TRUTH_*_EXPR
14760          or comparison expressions as truth values at this level.  */
14761 #if 0
14762     case COMPONENT_REF:
14763       /* A one-bit unsigned bit-field is already acceptable.  */
14764       if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr, 1)))
14765           && TREE_UNSIGNED (TREE_OPERAND (expr, 1)))
14766         return expr;
14767       break;
14768 #endif
14769
14770     case EQ_EXPR:
14771       /* It is simpler and generates better code to have only TRUTH_*_EXPR
14772          or comparison expressions as truth values at this level.  */
14773 #if 0
14774       if (integer_zerop (TREE_OPERAND (expr, 1)))
14775         return build_unary_op (TRUTH_NOT_EXPR, TREE_OPERAND (expr, 0), 0);
14776 #endif
14777     case NE_EXPR: case LE_EXPR: case GE_EXPR: case LT_EXPR: case GT_EXPR:
14778     case TRUTH_ANDIF_EXPR:
14779     case TRUTH_ORIF_EXPR:
14780     case TRUTH_AND_EXPR:
14781     case TRUTH_OR_EXPR:
14782     case TRUTH_XOR_EXPR:
14783       TREE_TYPE (expr) = integer_type_node;
14784       return expr;
14785
14786     case ERROR_MARK:
14787       return expr;
14788
14789     case INTEGER_CST:
14790       return integer_zerop (expr) ? integer_zero_node : integer_one_node;
14791
14792     case REAL_CST:
14793       return real_zerop (expr) ? integer_zero_node : integer_one_node;
14794
14795     case ADDR_EXPR:
14796       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 0)))
14797         return build (COMPOUND_EXPR, integer_type_node,
14798                       TREE_OPERAND (expr, 0), integer_one_node);
14799       else
14800         return integer_one_node;
14801
14802     case COMPLEX_EXPR:
14803       return ffecom_2 ((TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1))
14804                         ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
14805                        integer_type_node,
14806                        ffe_truthvalue_conversion (TREE_OPERAND (expr, 0)),
14807                        ffe_truthvalue_conversion (TREE_OPERAND (expr, 1)));
14808
14809     case NEGATE_EXPR:
14810     case ABS_EXPR:
14811     case FLOAT_EXPR:
14812     case FFS_EXPR:
14813       /* These don't change whether an object is nonzero or zero.  */
14814       return ffe_truthvalue_conversion (TREE_OPERAND (expr, 0));
14815
14816     case LROTATE_EXPR:
14817     case RROTATE_EXPR:
14818       /* These don't change whether an object is zero or nonzero, but
14819          we can't ignore them if their second arg has side-effects.  */
14820       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1)))
14821         return build (COMPOUND_EXPR, integer_type_node, TREE_OPERAND (expr, 1),
14822                       ffe_truthvalue_conversion (TREE_OPERAND (expr, 0)));
14823       else
14824         return ffe_truthvalue_conversion (TREE_OPERAND (expr, 0));
14825
14826     case COND_EXPR:
14827       {
14828         /* Distribute the conversion into the arms of a COND_EXPR.  */
14829         tree arg1 = TREE_OPERAND (expr, 1);
14830         tree arg2 = TREE_OPERAND (expr, 2);
14831         if (! VOID_TYPE_P (TREE_TYPE (arg1)))
14832           arg1 = ffe_truthvalue_conversion (arg1);
14833         if (! VOID_TYPE_P (TREE_TYPE (arg2)))
14834           arg2 = ffe_truthvalue_conversion (arg2);
14835         return fold (build (COND_EXPR, integer_type_node,
14836                             TREE_OPERAND (expr, 0), arg1, arg2));
14837       }
14838
14839     case CONVERT_EXPR:
14840       /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
14841          since that affects how `default_conversion' will behave.  */
14842       if (TREE_CODE (TREE_TYPE (expr)) == REFERENCE_TYPE
14843           || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) == REFERENCE_TYPE)
14844         break;
14845       /* fall through... */
14846     case NOP_EXPR:
14847       /* If this is widening the argument, we can ignore it.  */
14848       if (TYPE_PRECISION (TREE_TYPE (expr))
14849           >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr, 0))))
14850         return ffe_truthvalue_conversion (TREE_OPERAND (expr, 0));
14851       break;
14852
14853     case MINUS_EXPR:
14854       /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize
14855          this case.  */
14856       if (TARGET_FLOAT_FORMAT == IEEE_FLOAT_FORMAT
14857           && TREE_CODE (TREE_TYPE (expr)) == REAL_TYPE)
14858         break;
14859       /* fall through... */
14860     case BIT_XOR_EXPR:
14861       /* This and MINUS_EXPR can be changed into a comparison of the
14862          two objects.  */
14863       if (TREE_TYPE (TREE_OPERAND (expr, 0))
14864           == TREE_TYPE (TREE_OPERAND (expr, 1)))
14865         return ffecom_2 (NE_EXPR, integer_type_node,
14866                          TREE_OPERAND (expr, 0),
14867                          TREE_OPERAND (expr, 1));
14868       return ffecom_2 (NE_EXPR, integer_type_node,
14869                        TREE_OPERAND (expr, 0),
14870                        fold (build1 (NOP_EXPR,
14871                                      TREE_TYPE (TREE_OPERAND (expr, 0)),
14872                                      TREE_OPERAND (expr, 1))));
14873
14874     case BIT_AND_EXPR:
14875       if (integer_onep (TREE_OPERAND (expr, 1)))
14876         return expr;
14877       break;
14878
14879     case MODIFY_EXPR:
14880 #if 0                           /* No such thing in Fortran. */
14881       if (warn_parentheses && C_EXP_ORIGINAL_CODE (expr) == MODIFY_EXPR)
14882         warning ("suggest parentheses around assignment used as truth value");
14883 #endif
14884       break;
14885
14886     default:
14887       break;
14888     }
14889
14890   if (TREE_CODE (TREE_TYPE (expr)) == COMPLEX_TYPE)
14891     return (ffecom_2
14892             ((TREE_SIDE_EFFECTS (expr)
14893               ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
14894              integer_type_node,
14895              ffe_truthvalue_conversion (ffecom_1 (REALPART_EXPR,
14896                                                   TREE_TYPE (TREE_TYPE (expr)),
14897                                                   expr)),
14898              ffe_truthvalue_conversion (ffecom_1 (IMAGPART_EXPR,
14899                                                   TREE_TYPE (TREE_TYPE (expr)),
14900                                                   expr))));
14901
14902   return ffecom_2 (NE_EXPR, integer_type_node,
14903                    expr,
14904                    convert (TREE_TYPE (expr), integer_zero_node));
14905 }
14906
14907 static tree
14908 ffe_type_for_mode (enum machine_mode mode, int unsignedp)
14909 {
14910   int i;
14911   int j;
14912   tree t;
14913
14914   if (mode == TYPE_MODE (integer_type_node))
14915     return unsignedp ? unsigned_type_node : integer_type_node;
14916
14917   if (mode == TYPE_MODE (signed_char_type_node))
14918     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
14919
14920   if (mode == TYPE_MODE (short_integer_type_node))
14921     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
14922
14923   if (mode == TYPE_MODE (long_integer_type_node))
14924     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
14925
14926   if (mode == TYPE_MODE (long_long_integer_type_node))
14927     return unsignedp ? long_long_unsigned_type_node : long_long_integer_type_node;
14928
14929 #if HOST_BITS_PER_WIDE_INT >= 64
14930   if (mode == TYPE_MODE (intTI_type_node))
14931     return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
14932 #endif
14933
14934   if (mode == TYPE_MODE (float_type_node))
14935     return float_type_node;
14936
14937   if (mode == TYPE_MODE (double_type_node))
14938     return double_type_node;
14939
14940   if (mode == TYPE_MODE (long_double_type_node))
14941     return long_double_type_node;
14942
14943  if (mode == TYPE_MODE (build_pointer_type (char_type_node)))
14944     return build_pointer_type (char_type_node);
14945
14946   if (mode == TYPE_MODE (build_pointer_type (integer_type_node)))
14947     return build_pointer_type (integer_type_node);
14948
14949   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
14950     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
14951       {
14952         if (((t = ffecom_tree_type[i][j]) != NULL_TREE)
14953             && (mode == TYPE_MODE (t)))
14954           {
14955             if ((i == FFEINFO_basictypeINTEGER) && unsignedp)
14956               return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][j];
14957             else
14958               return t;
14959           }
14960       }
14961
14962   return 0;
14963 }
14964
14965 static tree
14966 ffe_type_for_size (unsigned bits, int unsignedp)
14967 {
14968   ffeinfoKindtype kt;
14969   tree type_node;
14970
14971   if (bits == TYPE_PRECISION (integer_type_node))
14972     return unsignedp ? unsigned_type_node : integer_type_node;
14973
14974   if (bits == TYPE_PRECISION (signed_char_type_node))
14975     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
14976
14977   if (bits == TYPE_PRECISION (short_integer_type_node))
14978     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
14979
14980   if (bits == TYPE_PRECISION (long_integer_type_node))
14981     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
14982
14983   if (bits == TYPE_PRECISION (long_long_integer_type_node))
14984     return (unsignedp ? long_long_unsigned_type_node
14985             : long_long_integer_type_node);
14986
14987   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
14988     {
14989       type_node = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
14990
14991       if ((type_node != NULL_TREE) && (bits == TYPE_PRECISION (type_node)))
14992         return unsignedp ? ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]
14993           : type_node;
14994     }
14995
14996   return 0;
14997 }
14998
14999 static tree
15000 ffe_unsigned_type (tree type)
15001 {
15002   tree type1 = TYPE_MAIN_VARIANT (type);
15003   ffeinfoKindtype kt;
15004   tree type2;
15005
15006   if (type1 == signed_char_type_node || type1 == char_type_node)
15007     return unsigned_char_type_node;
15008   if (type1 == integer_type_node)
15009     return unsigned_type_node;
15010   if (type1 == short_integer_type_node)
15011     return short_unsigned_type_node;
15012   if (type1 == long_integer_type_node)
15013     return long_unsigned_type_node;
15014   if (type1 == long_long_integer_type_node)
15015     return long_long_unsigned_type_node;
15016 #if 0   /* gcc/c-* files only */
15017   if (type1 == intDI_type_node)
15018     return unsigned_intDI_type_node;
15019   if (type1 == intSI_type_node)
15020     return unsigned_intSI_type_node;
15021   if (type1 == intHI_type_node)
15022     return unsigned_intHI_type_node;
15023   if (type1 == intQI_type_node)
15024     return unsigned_intQI_type_node;
15025 #endif
15026
15027   type2 = ffe_type_for_size (TYPE_PRECISION (type1), 1);
15028   if (type2 != NULL_TREE)
15029     return type2;
15030
15031   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15032     {
15033       type2 = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15034
15035       if (type1 == type2)
15036         return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
15037     }
15038
15039   return type;
15040 }
15041 \f
15042 /* From gcc/cccp.c, the code to handle -I.  */
15043
15044 /* Skip leading "./" from a directory name.
15045    This may yield the empty string, which represents the current directory.  */
15046
15047 static const char *
15048 skip_redundant_dir_prefix (const char *dir)
15049 {
15050   while (dir[0] == '.' && dir[1] == '/')
15051     for (dir += 2; *dir == '/'; dir++)
15052       continue;
15053   if (dir[0] == '.' && !dir[1])
15054     dir++;
15055   return dir;
15056 }
15057
15058 /* The file_name_map structure holds a mapping of file names for a
15059    particular directory.  This mapping is read from the file named
15060    FILE_NAME_MAP_FILE in that directory.  Such a file can be used to
15061    map filenames on a file system with severe filename restrictions,
15062    such as DOS.  The format of the file name map file is just a series
15063    of lines with two tokens on each line.  The first token is the name
15064    to map, and the second token is the actual name to use.  */
15065
15066 struct file_name_map
15067 {
15068   struct file_name_map *map_next;
15069   char *map_from;
15070   char *map_to;
15071 };
15072
15073 #define FILE_NAME_MAP_FILE "header.gcc"
15074
15075 /* Current maximum length of directory names in the search path
15076    for include files.  (Altered as we get more of them.)  */
15077
15078 static int max_include_len = 0;
15079
15080 struct file_name_list
15081   {
15082     struct file_name_list *next;
15083     const char *fname;
15084     /* Mapping of file names for this directory.  */
15085     struct file_name_map *name_map;
15086     /* Nonzero if name_map is valid.  */
15087     int got_name_map;
15088   };
15089
15090 static struct file_name_list *include = NULL;   /* First dir to search */
15091 static struct file_name_list *last_include = NULL;      /* Last in chain */
15092
15093 /* I/O buffer structure.
15094    The `fname' field is nonzero for source files and #include files
15095    and for the dummy text used for -D and -U.
15096    It is zero for rescanning results of macro expansion
15097    and for expanding macro arguments.  */
15098 #define INPUT_STACK_MAX 400
15099 static struct file_buf {
15100   const char *fname;
15101   /* Filename specified with #line command.  */
15102   const char *nominal_fname;
15103   /* Record where in the search path this file was found.
15104      For #include_next.  */
15105   struct file_name_list *dir;
15106   ffewhereLine line;
15107   ffewhereColumn column;
15108 } instack[INPUT_STACK_MAX];
15109
15110 static int last_error_tick = 0;    /* Incremented each time we print it.  */
15111
15112 /* Current nesting level of input sources.
15113    `instack[indepth]' is the level currently being read.  */
15114 static int indepth = -1;
15115
15116 typedef struct file_buf FILE_BUF;
15117
15118 /* Nonzero means -I- has been seen,
15119    so don't look for #include "foo" the source-file directory.  */
15120 static int ignore_srcdir;
15121
15122 #ifndef INCLUDE_LEN_FUDGE
15123 #define INCLUDE_LEN_FUDGE 0
15124 #endif
15125
15126 static void append_include_chain (struct file_name_list *first,
15127                                   struct file_name_list *last);
15128 static FILE *open_include_file (char *filename,
15129                                 struct file_name_list *searchptr);
15130 static void print_containing_files (ffebadSeverity sev);
15131 static char *read_filename_string (int ch, FILE *f);
15132 static struct file_name_map *read_name_map (const char *dirname);
15133
15134 /* Append a chain of `struct file_name_list's
15135    to the end of the main include chain.
15136    FIRST is the beginning of the chain to append, and LAST is the end.  */
15137
15138 static void
15139 append_include_chain (struct file_name_list *first,
15140                       struct file_name_list *last)
15141 {
15142   struct file_name_list *dir;
15143
15144   if (!first || !last)
15145     return;
15146
15147   if (include == 0)
15148     include = first;
15149   else
15150     last_include->next = first;
15151
15152   for (dir = first; ; dir = dir->next) {
15153     int len = strlen (dir->fname) + INCLUDE_LEN_FUDGE;
15154     if (len > max_include_len)
15155       max_include_len = len;
15156     if (dir == last)
15157       break;
15158   }
15159
15160   last->next = NULL;
15161   last_include = last;
15162 }
15163
15164 /* Try to open include file FILENAME.  SEARCHPTR is the directory
15165    being tried from the include file search path.  This function maps
15166    filenames on file systems based on information read by
15167    read_name_map.  */
15168
15169 static FILE *
15170 open_include_file (char *filename, struct file_name_list *searchptr)
15171 {
15172   register struct file_name_map *map;
15173   register char *from;
15174   char *p, *dir;
15175
15176   if (searchptr && ! searchptr->got_name_map)
15177     {
15178       searchptr->name_map = read_name_map (searchptr->fname
15179                                            ? searchptr->fname : ".");
15180       searchptr->got_name_map = 1;
15181     }
15182
15183   /* First check the mapping for the directory we are using.  */
15184   if (searchptr && searchptr->name_map)
15185     {
15186       from = filename;
15187       if (searchptr->fname)
15188         from += strlen (searchptr->fname) + 1;
15189       for (map = searchptr->name_map; map; map = map->map_next)
15190         {
15191           if (! strcmp (map->map_from, from))
15192             {
15193               /* Found a match.  */
15194               return fopen (map->map_to, "r");
15195             }
15196         }
15197     }
15198
15199   /* Try to find a mapping file for the particular directory we are
15200      looking in.  Thus #include <sys/types.h> will look up sys/types.h
15201      in /usr/include/header.gcc and look up types.h in
15202      /usr/include/sys/header.gcc.  */
15203   p = strrchr (filename, '/');
15204 #ifdef DIR_SEPARATOR
15205   if (! p) p = strrchr (filename, DIR_SEPARATOR);
15206   else {
15207     char *tmp = strrchr (filename, DIR_SEPARATOR);
15208     if (tmp != NULL && tmp > p) p = tmp;
15209   }
15210 #endif
15211   if (! p)
15212     p = filename;
15213   if (searchptr
15214       && searchptr->fname
15215       && strlen (searchptr->fname) == (size_t) (p - filename)
15216       && ! strncmp (searchptr->fname, filename, (int) (p - filename)))
15217     {
15218       /* FILENAME is in SEARCHPTR, which we've already checked.  */
15219       return fopen (filename, "r");
15220     }
15221
15222   if (p == filename)
15223     {
15224       from = filename;
15225       map = read_name_map (".");
15226     }
15227   else
15228     {
15229       dir = (char *) xmalloc (p - filename + 1);
15230       memcpy (dir, filename, p - filename);
15231       dir[p - filename] = '\0';
15232       from = p + 1;
15233       map = read_name_map (dir);
15234       free (dir);
15235     }
15236   for (; map; map = map->map_next)
15237     if (! strcmp (map->map_from, from))
15238       return fopen (map->map_to, "r");
15239
15240   return fopen (filename, "r");
15241 }
15242
15243 /* Print the file names and line numbers of the #include
15244    commands which led to the current file.  */
15245
15246 static void
15247 print_containing_files (ffebadSeverity sev)
15248 {
15249   FILE_BUF *ip = NULL;
15250   int i;
15251   int first = 1;
15252   const char *str1;
15253   const char *str2;
15254
15255   /* If stack of files hasn't changed since we last printed
15256      this info, don't repeat it.  */
15257   if (last_error_tick == input_file_stack_tick)
15258     return;
15259
15260   for (i = indepth; i >= 0; i--)
15261     if (instack[i].fname != NULL) {
15262       ip = &instack[i];
15263       break;
15264     }
15265
15266   /* Give up if we don't find a source file.  */
15267   if (ip == NULL)
15268     return;
15269
15270   /* Find the other, outer source files.  */
15271   for (i--; i >= 0; i--)
15272     if (instack[i].fname != NULL)
15273       {
15274         ip = &instack[i];
15275         if (first)
15276           {
15277             first = 0;
15278             str1 = "In file included";
15279           }
15280         else
15281           {
15282             str1 = "...          ...";
15283           }
15284
15285         if (i == 1)
15286           str2 = ":";
15287         else
15288           str2 = "";
15289
15290         /* xgettext:no-c-format */
15291         ffebad_start_msg ("%A from %B at %0%C", sev);
15292         ffebad_here (0, ip->line, ip->column);
15293         ffebad_string (str1);
15294         ffebad_string (ip->nominal_fname);
15295         ffebad_string (str2);
15296         ffebad_finish ();
15297       }
15298
15299   /* Record we have printed the status as of this time.  */
15300   last_error_tick = input_file_stack_tick;
15301 }
15302
15303 /* Read a space delimited string of unlimited length from a stdio
15304    file.  */
15305
15306 static char *
15307 read_filename_string (int ch, FILE *f)
15308 {
15309   char *alloc, *set;
15310   int len;
15311
15312   len = 20;
15313   set = alloc = xmalloc (len + 1);
15314   if (! ISSPACE (ch))
15315     {
15316       *set++ = ch;
15317       while ((ch = getc (f)) != EOF && ! ISSPACE (ch))
15318         {
15319           if (set - alloc == len)
15320             {
15321               len *= 2;
15322               alloc = xrealloc (alloc, len + 1);
15323               set = alloc + len / 2;
15324             }
15325           *set++ = ch;
15326         }
15327     }
15328   *set = '\0';
15329   ungetc (ch, f);
15330   return alloc;
15331 }
15332
15333 /* Read the file name map file for DIRNAME.  */
15334
15335 static struct file_name_map *
15336 read_name_map (const char *dirname)
15337 {
15338   /* This structure holds a linked list of file name maps, one per
15339      directory.  */
15340   struct file_name_map_list
15341     {
15342       struct file_name_map_list *map_list_next;
15343       char *map_list_name;
15344       struct file_name_map *map_list_map;
15345     };
15346   static struct file_name_map_list *map_list;
15347   register struct file_name_map_list *map_list_ptr;
15348   char *name;
15349   FILE *f;
15350   size_t dirlen;
15351   int separator_needed;
15352
15353   dirname = skip_redundant_dir_prefix (dirname);
15354
15355   for (map_list_ptr = map_list; map_list_ptr;
15356        map_list_ptr = map_list_ptr->map_list_next)
15357     if (! strcmp (map_list_ptr->map_list_name, dirname))
15358       return map_list_ptr->map_list_map;
15359
15360   map_list_ptr = ((struct file_name_map_list *)
15361                   xmalloc (sizeof (struct file_name_map_list)));
15362   map_list_ptr->map_list_name = xstrdup (dirname);
15363   map_list_ptr->map_list_map = NULL;
15364
15365   dirlen = strlen (dirname);
15366   separator_needed = dirlen != 0 && dirname[dirlen - 1] != '/';
15367   if (separator_needed)
15368     name = concat (dirname, "/", FILE_NAME_MAP_FILE, NULL);
15369   else
15370     name = concat (dirname, FILE_NAME_MAP_FILE, NULL);
15371   f = fopen (name, "r");
15372   free (name);
15373   if (!f)
15374     map_list_ptr->map_list_map = NULL;
15375   else
15376     {
15377       int ch;
15378
15379       while ((ch = getc (f)) != EOF)
15380         {
15381           char *from, *to;
15382           struct file_name_map *ptr;
15383
15384           if (ISSPACE (ch))
15385             continue;
15386           from = read_filename_string (ch, f);
15387           while ((ch = getc (f)) != EOF && ISSPACE (ch) && ch != '\n')
15388             ;
15389           to = read_filename_string (ch, f);
15390
15391           ptr = ((struct file_name_map *)
15392                  xmalloc (sizeof (struct file_name_map)));
15393           ptr->map_from = from;
15394
15395           /* Make the real filename absolute.  */
15396           if (*to == '/')
15397             ptr->map_to = to;
15398           else
15399             {
15400               if (separator_needed)
15401                 ptr->map_to = concat (dirname, "/", to, NULL);
15402               else
15403                 ptr->map_to = concat (dirname, to, NULL);
15404               free (to);
15405             }
15406
15407           ptr->map_next = map_list_ptr->map_list_map;
15408           map_list_ptr->map_list_map = ptr;
15409
15410           while ((ch = getc (f)) != '\n')
15411             if (ch == EOF)
15412               break;
15413         }
15414       fclose (f);
15415     }
15416
15417   map_list_ptr->map_list_next = map_list;
15418   map_list = map_list_ptr;
15419
15420   return map_list_ptr->map_list_map;
15421 }
15422
15423 static void
15424 ffecom_file_ (const char *name)
15425 {
15426   FILE_BUF *fp;
15427
15428   /* Do partial setup of input buffer for the sake of generating
15429      early #line directives (when -g is in effect).  */
15430
15431   fp = &instack[++indepth];
15432   memset ((char *) fp, 0, sizeof (FILE_BUF));
15433   if (name == NULL)
15434     name = "";
15435   fp->nominal_fname = fp->fname = name;
15436 }
15437
15438 static void
15439 ffecom_close_include_ (FILE *f)
15440 {
15441   fclose (f);
15442
15443   indepth--;
15444   input_file_stack_tick++;
15445
15446   ffewhere_line_kill (instack[indepth].line);
15447   ffewhere_column_kill (instack[indepth].column);
15448 }
15449
15450 void
15451 ffecom_decode_include_option (const char *dir)
15452 {
15453   if (! ignore_srcdir && !strcmp (dir, "-"))
15454     ignore_srcdir = 1;
15455   else
15456     {
15457       struct file_name_list *dirtmp = (struct file_name_list *)
15458         xmalloc (sizeof (struct file_name_list));
15459       dirtmp->next = 0;         /* New one goes on the end */
15460       dirtmp->fname = dir;
15461       dirtmp->got_name_map = 0;
15462       append_include_chain (dirtmp, dirtmp);
15463     }
15464 }
15465
15466 /* Open INCLUDEd file.  */
15467
15468 static FILE *
15469 ffecom_open_include_ (char *name, ffewhereLine l, ffewhereColumn c)
15470 {
15471   char *fbeg = name;
15472   size_t flen = strlen (fbeg);
15473   struct file_name_list *search_start = include; /* Chain of dirs to search */
15474   struct file_name_list dsp[1]; /* First in chain, if #include "..." */
15475   struct file_name_list *searchptr = 0;
15476   char *fname;          /* Dynamically allocated fname buffer */
15477   FILE *f;
15478   FILE_BUF *fp;
15479
15480   if (flen == 0)
15481     return NULL;
15482
15483   dsp[0].fname = NULL;
15484
15485   /* If -I- was specified, don't search current dir, only spec'd ones. */
15486   if (!ignore_srcdir)
15487     {
15488       for (fp = &instack[indepth]; fp >= instack; fp--)
15489         {
15490           int n;
15491           char *ep;
15492           const char *nam;
15493
15494           if ((nam = fp->nominal_fname) != NULL)
15495             {
15496               /* Found a named file.  Figure out dir of the file,
15497                  and put it in front of the search list.  */
15498               dsp[0].next = search_start;
15499               search_start = dsp;
15500 #ifndef VMS
15501               ep = strrchr (nam, '/');
15502 #ifdef DIR_SEPARATOR
15503             if (ep == NULL) ep = strrchr (nam, DIR_SEPARATOR);
15504             else {
15505               char *tmp = strrchr (nam, DIR_SEPARATOR);
15506               if (tmp != NULL && tmp > ep) ep = tmp;
15507             }
15508 #endif
15509 #else                           /* VMS */
15510               ep = strrchr (nam, ']');
15511               if (ep == NULL) ep = strrchr (nam, '>');
15512               if (ep == NULL) ep = strrchr (nam, ':');
15513               if (ep != NULL) ep++;
15514 #endif                          /* VMS */
15515               if (ep != NULL)
15516                 {
15517                   n = ep - nam;
15518                   fname = xmalloc (n + 1);
15519                   strncpy (fname, nam, n);
15520                   fname[n] = '\0';
15521                   dsp[0].fname = fname;
15522                   if (n + INCLUDE_LEN_FUDGE > max_include_len)
15523                     max_include_len = n + INCLUDE_LEN_FUDGE;
15524                 }
15525               else
15526                 dsp[0].fname = NULL; /* Current directory */
15527               dsp[0].got_name_map = 0;
15528               break;
15529             }
15530         }
15531     }
15532
15533   /* Allocate this permanently, because it gets stored in the definitions
15534      of macros.  */
15535   fname = xmalloc (max_include_len + flen + 4);
15536   /* + 2 above for slash and terminating null.  */
15537   /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED
15538      for g77 yet).  */
15539
15540   /* If specified file name is absolute, just open it.  */
15541
15542   if (*fbeg == '/'
15543 #ifdef DIR_SEPARATOR
15544       || *fbeg == DIR_SEPARATOR
15545 #endif
15546       )
15547     {
15548       strncpy (fname, (char *) fbeg, flen);
15549       fname[flen] = 0;
15550       f = open_include_file (fname, NULL);
15551     }
15552   else
15553     {
15554       f = NULL;
15555
15556       /* Search directory path, trying to open the file.
15557          Copy each filename tried into FNAME.  */
15558
15559       for (searchptr = search_start; searchptr; searchptr = searchptr->next)
15560         {
15561           if (searchptr->fname)
15562             {
15563               /* The empty string in a search path is ignored.
15564                  This makes it possible to turn off entirely
15565                  a standard piece of the list.  */
15566               if (searchptr->fname[0] == 0)
15567                 continue;
15568               strcpy (fname, skip_redundant_dir_prefix (searchptr->fname));
15569               if (fname[0] && fname[strlen (fname) - 1] != '/')
15570                 strcat (fname, "/");
15571               fname[strlen (fname) + flen] = 0;
15572             }
15573           else
15574             fname[0] = 0;
15575
15576           strncat (fname, fbeg, flen);
15577 #ifdef VMS
15578           /* Change this 1/2 Unix 1/2 VMS file specification into a
15579              full VMS file specification */
15580           if (searchptr->fname && (searchptr->fname[0] != 0))
15581             {
15582               /* Fix up the filename */
15583               hack_vms_include_specification (fname);
15584             }
15585           else
15586             {
15587               /* This is a normal VMS filespec, so use it unchanged.  */
15588               strncpy (fname, (char *) fbeg, flen);
15589               fname[flen] = 0;
15590 #if 0   /* Not for g77.  */
15591               /* if it's '#include filename', add the missing .h */
15592               if (strchr (fname, '.') == NULL)
15593                 strcat (fname, ".h");
15594 #endif
15595             }
15596 #endif /* VMS */
15597           f = open_include_file (fname, searchptr);
15598 #ifdef EACCES
15599           if (f == NULL && errno == EACCES)
15600             {
15601               print_containing_files (FFEBAD_severityWARNING);
15602               /* xgettext:no-c-format */
15603               ffebad_start_msg ("At %0, INCLUDE file %A exists, but is not readable",
15604                                 FFEBAD_severityWARNING);
15605               ffebad_string (fname);
15606               ffebad_here (0, l, c);
15607               ffebad_finish ();
15608             }
15609 #endif
15610           if (f != NULL)
15611             break;
15612         }
15613     }
15614
15615   if (f == NULL)
15616     {
15617       /* A file that was not found.  */
15618
15619       strncpy (fname, (char *) fbeg, flen);
15620       fname[flen] = 0;
15621       print_containing_files (ffebad_severity (FFEBAD_OPEN_INCLUDE));
15622       ffebad_start (FFEBAD_OPEN_INCLUDE);
15623       ffebad_here (0, l, c);
15624       ffebad_string (fname);
15625       ffebad_finish ();
15626     }
15627
15628   if (dsp[0].fname != NULL)
15629     free ((char *) dsp[0].fname);
15630
15631   if (f == NULL)
15632     return NULL;
15633
15634   if (indepth >= (INPUT_STACK_MAX - 1))
15635     {
15636       print_containing_files (FFEBAD_severityFATAL);
15637       /* xgettext:no-c-format */
15638       ffebad_start_msg ("At %0, INCLUDE nesting too deep",
15639                         FFEBAD_severityFATAL);
15640       ffebad_string (fname);
15641       ffebad_here (0, l, c);
15642       ffebad_finish ();
15643       return NULL;
15644     }
15645
15646   instack[indepth].line = ffewhere_line_use (l);
15647   instack[indepth].column = ffewhere_column_use (c);
15648
15649   fp = &instack[indepth + 1];
15650   memset ((char *) fp, 0, sizeof (FILE_BUF));
15651   fp->nominal_fname = fp->fname = fname;
15652   fp->dir = searchptr;
15653
15654   indepth++;
15655   input_file_stack_tick++;
15656
15657   return f;
15658 }
15659
15660 /**INDENT* (Do not reformat this comment even with -fca option.)
15661    Data-gathering files: Given the source file listed below, compiled with
15662    f2c I obtained the output file listed after that, and from the output
15663    file I derived the above code.
15664
15665 -------- (begin input file to f2c)
15666         implicit none
15667         character*10 A1,A2
15668         complex C1,C2
15669         integer I1,I2
15670         real R1,R2
15671         double precision D1,D2
15672 C
15673         call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2)
15674 c /
15675         call fooI(I1/I2)
15676         call fooR(R1/I1)
15677         call fooD(D1/I1)
15678         call fooC(C1/I1)
15679         call fooR(R1/R2)
15680         call fooD(R1/D1)
15681         call fooD(D1/D2)
15682         call fooD(D1/R1)
15683         call fooC(C1/C2)
15684         call fooC(C1/R1)
15685         call fooZ(C1/D1)
15686 c **
15687         call fooI(I1**I2)
15688         call fooR(R1**I1)
15689         call fooD(D1**I1)
15690         call fooC(C1**I1)
15691         call fooR(R1**R2)
15692         call fooD(R1**D1)
15693         call fooD(D1**D2)
15694         call fooD(D1**R1)
15695         call fooC(C1**C2)
15696         call fooC(C1**R1)
15697         call fooZ(C1**D1)
15698 c FFEINTRIN_impABS
15699         call fooR(ABS(R1))
15700 c FFEINTRIN_impACOS
15701         call fooR(ACOS(R1))
15702 c FFEINTRIN_impAIMAG
15703         call fooR(AIMAG(C1))
15704 c FFEINTRIN_impAINT
15705         call fooR(AINT(R1))
15706 c FFEINTRIN_impALOG
15707         call fooR(ALOG(R1))
15708 c FFEINTRIN_impALOG10
15709         call fooR(ALOG10(R1))
15710 c FFEINTRIN_impAMAX0
15711         call fooR(AMAX0(I1,I2))
15712 c FFEINTRIN_impAMAX1
15713         call fooR(AMAX1(R1,R2))
15714 c FFEINTRIN_impAMIN0
15715         call fooR(AMIN0(I1,I2))
15716 c FFEINTRIN_impAMIN1
15717         call fooR(AMIN1(R1,R2))
15718 c FFEINTRIN_impAMOD
15719         call fooR(AMOD(R1,R2))
15720 c FFEINTRIN_impANINT
15721         call fooR(ANINT(R1))
15722 c FFEINTRIN_impASIN
15723         call fooR(ASIN(R1))
15724 c FFEINTRIN_impATAN
15725         call fooR(ATAN(R1))
15726 c FFEINTRIN_impATAN2
15727         call fooR(ATAN2(R1,R2))
15728 c FFEINTRIN_impCABS
15729         call fooR(CABS(C1))
15730 c FFEINTRIN_impCCOS
15731         call fooC(CCOS(C1))
15732 c FFEINTRIN_impCEXP
15733         call fooC(CEXP(C1))
15734 c FFEINTRIN_impCHAR
15735         call fooA(CHAR(I1))
15736 c FFEINTRIN_impCLOG
15737         call fooC(CLOG(C1))
15738 c FFEINTRIN_impCONJG
15739         call fooC(CONJG(C1))
15740 c FFEINTRIN_impCOS
15741         call fooR(COS(R1))
15742 c FFEINTRIN_impCOSH
15743         call fooR(COSH(R1))
15744 c FFEINTRIN_impCSIN
15745         call fooC(CSIN(C1))
15746 c FFEINTRIN_impCSQRT
15747         call fooC(CSQRT(C1))
15748 c FFEINTRIN_impDABS
15749         call fooD(DABS(D1))
15750 c FFEINTRIN_impDACOS
15751         call fooD(DACOS(D1))
15752 c FFEINTRIN_impDASIN
15753         call fooD(DASIN(D1))
15754 c FFEINTRIN_impDATAN
15755         call fooD(DATAN(D1))
15756 c FFEINTRIN_impDATAN2
15757         call fooD(DATAN2(D1,D2))
15758 c FFEINTRIN_impDCOS
15759         call fooD(DCOS(D1))
15760 c FFEINTRIN_impDCOSH
15761         call fooD(DCOSH(D1))
15762 c FFEINTRIN_impDDIM
15763         call fooD(DDIM(D1,D2))
15764 c FFEINTRIN_impDEXP
15765         call fooD(DEXP(D1))
15766 c FFEINTRIN_impDIM
15767         call fooR(DIM(R1,R2))
15768 c FFEINTRIN_impDINT
15769         call fooD(DINT(D1))
15770 c FFEINTRIN_impDLOG
15771         call fooD(DLOG(D1))
15772 c FFEINTRIN_impDLOG10
15773         call fooD(DLOG10(D1))
15774 c FFEINTRIN_impDMAX1
15775         call fooD(DMAX1(D1,D2))
15776 c FFEINTRIN_impDMIN1
15777         call fooD(DMIN1(D1,D2))
15778 c FFEINTRIN_impDMOD
15779         call fooD(DMOD(D1,D2))
15780 c FFEINTRIN_impDNINT
15781         call fooD(DNINT(D1))
15782 c FFEINTRIN_impDPROD
15783         call fooD(DPROD(R1,R2))
15784 c FFEINTRIN_impDSIGN
15785         call fooD(DSIGN(D1,D2))
15786 c FFEINTRIN_impDSIN
15787         call fooD(DSIN(D1))
15788 c FFEINTRIN_impDSINH
15789         call fooD(DSINH(D1))
15790 c FFEINTRIN_impDSQRT
15791         call fooD(DSQRT(D1))
15792 c FFEINTRIN_impDTAN
15793         call fooD(DTAN(D1))
15794 c FFEINTRIN_impDTANH
15795         call fooD(DTANH(D1))
15796 c FFEINTRIN_impEXP
15797         call fooR(EXP(R1))
15798 c FFEINTRIN_impIABS
15799         call fooI(IABS(I1))
15800 c FFEINTRIN_impICHAR
15801         call fooI(ICHAR(A1))
15802 c FFEINTRIN_impIDIM
15803         call fooI(IDIM(I1,I2))
15804 c FFEINTRIN_impIDNINT
15805         call fooI(IDNINT(D1))
15806 c FFEINTRIN_impINDEX
15807         call fooI(INDEX(A1,A2))
15808 c FFEINTRIN_impISIGN
15809         call fooI(ISIGN(I1,I2))
15810 c FFEINTRIN_impLEN
15811         call fooI(LEN(A1))
15812 c FFEINTRIN_impLGE
15813         call fooL(LGE(A1,A2))
15814 c FFEINTRIN_impLGT
15815         call fooL(LGT(A1,A2))
15816 c FFEINTRIN_impLLE
15817         call fooL(LLE(A1,A2))
15818 c FFEINTRIN_impLLT
15819         call fooL(LLT(A1,A2))
15820 c FFEINTRIN_impMAX0
15821         call fooI(MAX0(I1,I2))
15822 c FFEINTRIN_impMAX1
15823         call fooI(MAX1(R1,R2))
15824 c FFEINTRIN_impMIN0
15825         call fooI(MIN0(I1,I2))
15826 c FFEINTRIN_impMIN1
15827         call fooI(MIN1(R1,R2))
15828 c FFEINTRIN_impMOD
15829         call fooI(MOD(I1,I2))
15830 c FFEINTRIN_impNINT
15831         call fooI(NINT(R1))
15832 c FFEINTRIN_impSIGN
15833         call fooR(SIGN(R1,R2))
15834 c FFEINTRIN_impSIN
15835         call fooR(SIN(R1))
15836 c FFEINTRIN_impSINH
15837         call fooR(SINH(R1))
15838 c FFEINTRIN_impSQRT
15839         call fooR(SQRT(R1))
15840 c FFEINTRIN_impTAN
15841         call fooR(TAN(R1))
15842 c FFEINTRIN_impTANH
15843         call fooR(TANH(R1))
15844 c FFEINTRIN_imp_CMPLX_C
15845         call fooC(cmplx(C1,C2))
15846 c FFEINTRIN_imp_CMPLX_D
15847         call fooZ(cmplx(D1,D2))
15848 c FFEINTRIN_imp_CMPLX_I
15849         call fooC(cmplx(I1,I2))
15850 c FFEINTRIN_imp_CMPLX_R
15851         call fooC(cmplx(R1,R2))
15852 c FFEINTRIN_imp_DBLE_C
15853         call fooD(dble(C1))
15854 c FFEINTRIN_imp_DBLE_D
15855         call fooD(dble(D1))
15856 c FFEINTRIN_imp_DBLE_I
15857         call fooD(dble(I1))
15858 c FFEINTRIN_imp_DBLE_R
15859         call fooD(dble(R1))
15860 c FFEINTRIN_imp_INT_C
15861         call fooI(int(C1))
15862 c FFEINTRIN_imp_INT_D
15863         call fooI(int(D1))
15864 c FFEINTRIN_imp_INT_I
15865         call fooI(int(I1))
15866 c FFEINTRIN_imp_INT_R
15867         call fooI(int(R1))
15868 c FFEINTRIN_imp_REAL_C
15869         call fooR(real(C1))
15870 c FFEINTRIN_imp_REAL_D
15871         call fooR(real(D1))
15872 c FFEINTRIN_imp_REAL_I
15873         call fooR(real(I1))
15874 c FFEINTRIN_imp_REAL_R
15875         call fooR(real(R1))
15876 c
15877 c FFEINTRIN_imp_INT_D:
15878 c
15879 c FFEINTRIN_specIDINT
15880         call fooI(IDINT(D1))
15881 c
15882 c FFEINTRIN_imp_INT_R:
15883 c
15884 c FFEINTRIN_specIFIX
15885         call fooI(IFIX(R1))
15886 c FFEINTRIN_specINT
15887         call fooI(INT(R1))
15888 c
15889 c FFEINTRIN_imp_REAL_D:
15890 c
15891 c FFEINTRIN_specSNGL
15892         call fooR(SNGL(D1))
15893 c
15894 c FFEINTRIN_imp_REAL_I:
15895 c
15896 c FFEINTRIN_specFLOAT
15897         call fooR(FLOAT(I1))
15898 c FFEINTRIN_specREAL
15899         call fooR(REAL(I1))
15900 c
15901         end
15902 -------- (end input file to f2c)
15903
15904 -------- (begin output from providing above input file as input to:
15905 --------  `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
15906 --------     -e "s:^#.*$::g"')
15907
15908 //  -- translated by f2c (version 19950223).
15909    You must link the resulting object file with the libraries:
15910         -lf2c -lm   (in that order)
15911 //
15912
15913
15914 // f2c.h  --  Standard Fortran to C header file //
15915
15916 ///  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
15917
15918         - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
15919
15920
15921
15922
15923 // F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems //
15924 // we assume short, float are OK //
15925 typedef long int // long int // integer;
15926 typedef char *address;
15927 typedef short int shortint;
15928 typedef float real;
15929 typedef double doublereal;
15930 typedef struct { real r, i; } complex;
15931 typedef struct { doublereal r, i; } doublecomplex;
15932 typedef long int // long int // logical;
15933 typedef short int shortlogical;
15934 typedef char logical1;
15935 typedef char integer1;
15936 // typedef long long longint; // // system-dependent //
15937
15938
15939
15940
15941 // Extern is for use with -E //
15942
15943
15944
15945
15946 // I/O stuff //
15947
15948
15949
15950
15951
15952
15953
15954
15955 typedef long int // int or long int // flag;
15956 typedef long int // int or long int // ftnlen;
15957 typedef long int // int or long int // ftnint;
15958
15959
15960 //external read, write//
15961 typedef struct
15962 {       flag cierr;
15963         ftnint ciunit;
15964         flag ciend;
15965         char *cifmt;
15966         ftnint cirec;
15967 } cilist;
15968
15969 //internal read, write//
15970 typedef struct
15971 {       flag icierr;
15972         char *iciunit;
15973         flag iciend;
15974         char *icifmt;
15975         ftnint icirlen;
15976         ftnint icirnum;
15977 } icilist;
15978
15979 //open//
15980 typedef struct
15981 {       flag oerr;
15982         ftnint ounit;
15983         char *ofnm;
15984         ftnlen ofnmlen;
15985         char *osta;
15986         char *oacc;
15987         char *ofm;
15988         ftnint orl;
15989         char *oblnk;
15990 } olist;
15991
15992 //close//
15993 typedef struct
15994 {       flag cerr;
15995         ftnint cunit;
15996         char *csta;
15997 } cllist;
15998
15999 //rewind, backspace, endfile//
16000 typedef struct
16001 {       flag aerr;
16002         ftnint aunit;
16003 } alist;
16004
16005 // inquire //
16006 typedef struct
16007 {       flag inerr;
16008         ftnint inunit;
16009         char *infile;
16010         ftnlen infilen;
16011         ftnint  *inex;  //parameters in standard's order//
16012         ftnint  *inopen;
16013         ftnint  *innum;
16014         ftnint  *innamed;
16015         char    *inname;
16016         ftnlen  innamlen;
16017         char    *inacc;
16018         ftnlen  inacclen;
16019         char    *inseq;
16020         ftnlen  inseqlen;
16021         char    *indir;
16022         ftnlen  indirlen;
16023         char    *infmt;
16024         ftnlen  infmtlen;
16025         char    *inform;
16026         ftnint  informlen;
16027         char    *inunf;
16028         ftnlen  inunflen;
16029         ftnint  *inrecl;
16030         ftnint  *innrec;
16031         char    *inblank;
16032         ftnlen  inblanklen;
16033 } inlist;
16034
16035
16036
16037 union Multitype {       // for multiple entry points //
16038         integer1 g;
16039         shortint h;
16040         integer i;
16041         // longint j; //
16042         real r;
16043         doublereal d;
16044         complex c;
16045         doublecomplex z;
16046         };
16047
16048 typedef union Multitype Multitype;
16049
16050 typedef long Long;      // No longer used; formerly in Namelist //
16051
16052 struct Vardesc {        // for Namelist //
16053         char *name;
16054         char *addr;
16055         ftnlen *dims;
16056         int  type;
16057         };
16058 typedef struct Vardesc Vardesc;
16059
16060 struct Namelist {
16061         char *name;
16062         Vardesc **vars;
16063         int nvars;
16064         };
16065 typedef struct Namelist Namelist;
16066
16067
16068
16069
16070
16071
16072
16073
16074 // procedure parameter types for -A and -C++ //
16075
16076
16077
16078
16079 typedef int // Unknown procedure type // (*U_fp)();
16080 typedef shortint (*J_fp)();
16081 typedef integer (*I_fp)();
16082 typedef real (*R_fp)();
16083 typedef doublereal (*D_fp)(), (*E_fp)();
16084 typedef // Complex // void  (*C_fp)();
16085 typedef // Double Complex // void  (*Z_fp)();
16086 typedef logical (*L_fp)();
16087 typedef shortlogical (*K_fp)();
16088 typedef // Character // void  (*H_fp)();
16089 typedef // Subroutine // int (*S_fp)();
16090
16091 // E_fp is for real functions when -R is not specified //
16092 typedef void  C_f;      // complex function //
16093 typedef void  H_f;      // character function //
16094 typedef void  Z_f;      // double complex function //
16095 typedef doublereal E_f; // real function with -R not specified //
16096
16097 // undef any lower-case symbols that your C compiler predefines, e.g.: //
16098
16099
16100 // (No such symbols should be defined in a strict ANSI C compiler.
16101    We can avoid trouble with f2c-translated code by using
16102    gcc -ansi.) //
16103
16104
16105
16106
16107
16108
16109
16110
16111
16112
16113
16114
16115
16116
16117
16118
16119
16120
16121
16122
16123
16124
16125
16126 // Main program // MAIN__()
16127 {
16128     // System generated locals //
16129     integer i__1;
16130     real r__1, r__2;
16131     doublereal d__1, d__2;
16132     complex q__1;
16133     doublecomplex z__1, z__2, z__3;
16134     logical L__1;
16135     char ch__1[1];
16136
16137     // Builtin functions //
16138     void c_div();
16139     integer pow_ii();
16140     double pow_ri(), pow_di();
16141     void pow_ci();
16142     double pow_dd();
16143     void pow_zz();
16144     double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
16145             asin(), atan(), atan2(), c_abs();
16146     void c_cos(), c_exp(), c_log(), r_cnjg();
16147     double cos(), cosh();
16148     void c_sin(), c_sqrt();
16149     double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
16150             d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
16151     integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
16152     logical l_ge(), l_gt(), l_le(), l_lt();
16153     integer i_nint();
16154     double r_sign();
16155
16156     // Local variables //
16157     extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
16158             fool_(), fooz_(), getem_();
16159     static char a1[10], a2[10];
16160     static complex c1, c2;
16161     static doublereal d1, d2;
16162     static integer i1, i2;
16163     static real r1, r2;
16164
16165
16166     getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L);
16167 // / //
16168     i__1 = i1 / i2;
16169     fooi_(&i__1);
16170     r__1 = r1 / i1;
16171     foor_(&r__1);
16172     d__1 = d1 / i1;
16173     food_(&d__1);
16174     d__1 = (doublereal) i1;
16175     q__1.r = c1.r / d__1, q__1.i = c1.i / d__1;
16176     fooc_(&q__1);
16177     r__1 = r1 / r2;
16178     foor_(&r__1);
16179     d__1 = r1 / d1;
16180     food_(&d__1);
16181     d__1 = d1 / d2;
16182     food_(&d__1);
16183     d__1 = d1 / r1;
16184     food_(&d__1);
16185     c_div(&q__1, &c1, &c2);
16186     fooc_(&q__1);
16187     q__1.r = c1.r / r1, q__1.i = c1.i / r1;
16188     fooc_(&q__1);
16189     z__1.r = c1.r / d1, z__1.i = c1.i / d1;
16190     fooz_(&z__1);
16191 // ** //
16192     i__1 = pow_ii(&i1, &i2);
16193     fooi_(&i__1);
16194     r__1 = pow_ri(&r1, &i1);
16195     foor_(&r__1);
16196     d__1 = pow_di(&d1, &i1);
16197     food_(&d__1);
16198     pow_ci(&q__1, &c1, &i1);
16199     fooc_(&q__1);
16200     d__1 = (doublereal) r1;
16201     d__2 = (doublereal) r2;
16202     r__1 = pow_dd(&d__1, &d__2);
16203     foor_(&r__1);
16204     d__2 = (doublereal) r1;
16205     d__1 = pow_dd(&d__2, &d1);
16206     food_(&d__1);
16207     d__1 = pow_dd(&d1, &d2);
16208     food_(&d__1);
16209     d__2 = (doublereal) r1;
16210     d__1 = pow_dd(&d1, &d__2);
16211     food_(&d__1);
16212     z__2.r = c1.r, z__2.i = c1.i;
16213     z__3.r = c2.r, z__3.i = c2.i;
16214     pow_zz(&z__1, &z__2, &z__3);
16215     q__1.r = z__1.r, q__1.i = z__1.i;
16216     fooc_(&q__1);
16217     z__2.r = c1.r, z__2.i = c1.i;
16218     z__3.r = r1, z__3.i = 0.;
16219     pow_zz(&z__1, &z__2, &z__3);
16220     q__1.r = z__1.r, q__1.i = z__1.i;
16221     fooc_(&q__1);
16222     z__2.r = c1.r, z__2.i = c1.i;
16223     z__3.r = d1, z__3.i = 0.;
16224     pow_zz(&z__1, &z__2, &z__3);
16225     fooz_(&z__1);
16226 // FFEINTRIN_impABS //
16227     r__1 = (doublereal)((  r1  ) >= 0 ? (  r1  ) : -(  r1  ))  ;
16228     foor_(&r__1);
16229 // FFEINTRIN_impACOS //
16230     r__1 = acos(r1);
16231     foor_(&r__1);
16232 // FFEINTRIN_impAIMAG //
16233     r__1 = r_imag(&c1);
16234     foor_(&r__1);
16235 // FFEINTRIN_impAINT //
16236     r__1 = r_int(&r1);
16237     foor_(&r__1);
16238 // FFEINTRIN_impALOG //
16239     r__1 = log(r1);
16240     foor_(&r__1);
16241 // FFEINTRIN_impALOG10 //
16242     r__1 = r_lg10(&r1);
16243     foor_(&r__1);
16244 // FFEINTRIN_impAMAX0 //
16245     r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16246     foor_(&r__1);
16247 // FFEINTRIN_impAMAX1 //
16248     r__1 = (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16249     foor_(&r__1);
16250 // FFEINTRIN_impAMIN0 //
16251     r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16252     foor_(&r__1);
16253 // FFEINTRIN_impAMIN1 //
16254     r__1 = (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16255     foor_(&r__1);
16256 // FFEINTRIN_impAMOD //
16257     r__1 = r_mod(&r1, &r2);
16258     foor_(&r__1);
16259 // FFEINTRIN_impANINT //
16260     r__1 = r_nint(&r1);
16261     foor_(&r__1);
16262 // FFEINTRIN_impASIN //
16263     r__1 = asin(r1);
16264     foor_(&r__1);
16265 // FFEINTRIN_impATAN //
16266     r__1 = atan(r1);
16267     foor_(&r__1);
16268 // FFEINTRIN_impATAN2 //
16269     r__1 = atan2(r1, r2);
16270     foor_(&r__1);
16271 // FFEINTRIN_impCABS //
16272     r__1 = c_abs(&c1);
16273     foor_(&r__1);
16274 // FFEINTRIN_impCCOS //
16275     c_cos(&q__1, &c1);
16276     fooc_(&q__1);
16277 // FFEINTRIN_impCEXP //
16278     c_exp(&q__1, &c1);
16279     fooc_(&q__1);
16280 // FFEINTRIN_impCHAR //
16281     *(unsigned char *)&ch__1[0] = i1;
16282     fooa_(ch__1, 1L);
16283 // FFEINTRIN_impCLOG //
16284     c_log(&q__1, &c1);
16285     fooc_(&q__1);
16286 // FFEINTRIN_impCONJG //
16287     r_cnjg(&q__1, &c1);
16288     fooc_(&q__1);
16289 // FFEINTRIN_impCOS //
16290     r__1 = cos(r1);
16291     foor_(&r__1);
16292 // FFEINTRIN_impCOSH //
16293     r__1 = cosh(r1);
16294     foor_(&r__1);
16295 // FFEINTRIN_impCSIN //
16296     c_sin(&q__1, &c1);
16297     fooc_(&q__1);
16298 // FFEINTRIN_impCSQRT //
16299     c_sqrt(&q__1, &c1);
16300     fooc_(&q__1);
16301 // FFEINTRIN_impDABS //
16302     d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ;
16303     food_(&d__1);
16304 // FFEINTRIN_impDACOS //
16305     d__1 = acos(d1);
16306     food_(&d__1);
16307 // FFEINTRIN_impDASIN //
16308     d__1 = asin(d1);
16309     food_(&d__1);
16310 // FFEINTRIN_impDATAN //
16311     d__1 = atan(d1);
16312     food_(&d__1);
16313 // FFEINTRIN_impDATAN2 //
16314     d__1 = atan2(d1, d2);
16315     food_(&d__1);
16316 // FFEINTRIN_impDCOS //
16317     d__1 = cos(d1);
16318     food_(&d__1);
16319 // FFEINTRIN_impDCOSH //
16320     d__1 = cosh(d1);
16321     food_(&d__1);
16322 // FFEINTRIN_impDDIM //
16323     d__1 = d_dim(&d1, &d2);
16324     food_(&d__1);
16325 // FFEINTRIN_impDEXP //
16326     d__1 = exp(d1);
16327     food_(&d__1);
16328 // FFEINTRIN_impDIM //
16329     r__1 = r_dim(&r1, &r2);
16330     foor_(&r__1);
16331 // FFEINTRIN_impDINT //
16332     d__1 = d_int(&d1);
16333     food_(&d__1);
16334 // FFEINTRIN_impDLOG //
16335     d__1 = log(d1);
16336     food_(&d__1);
16337 // FFEINTRIN_impDLOG10 //
16338     d__1 = d_lg10(&d1);
16339     food_(&d__1);
16340 // FFEINTRIN_impDMAX1 //
16341     d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ;
16342     food_(&d__1);
16343 // FFEINTRIN_impDMIN1 //
16344     d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ;
16345     food_(&d__1);
16346 // FFEINTRIN_impDMOD //
16347     d__1 = d_mod(&d1, &d2);
16348     food_(&d__1);
16349 // FFEINTRIN_impDNINT //
16350     d__1 = d_nint(&d1);
16351     food_(&d__1);
16352 // FFEINTRIN_impDPROD //
16353     d__1 = (doublereal) r1 * r2;
16354     food_(&d__1);
16355 // FFEINTRIN_impDSIGN //
16356     d__1 = d_sign(&d1, &d2);
16357     food_(&d__1);
16358 // FFEINTRIN_impDSIN //
16359     d__1 = sin(d1);
16360     food_(&d__1);
16361 // FFEINTRIN_impDSINH //
16362     d__1 = sinh(d1);
16363     food_(&d__1);
16364 // FFEINTRIN_impDSQRT //
16365     d__1 = sqrt(d1);
16366     food_(&d__1);
16367 // FFEINTRIN_impDTAN //
16368     d__1 = tan(d1);
16369     food_(&d__1);
16370 // FFEINTRIN_impDTANH //
16371     d__1 = tanh(d1);
16372     food_(&d__1);
16373 // FFEINTRIN_impEXP //
16374     r__1 = exp(r1);
16375     foor_(&r__1);
16376 // FFEINTRIN_impIABS //
16377     i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ;
16378     fooi_(&i__1);
16379 // FFEINTRIN_impICHAR //
16380     i__1 = *(unsigned char *)a1;
16381     fooi_(&i__1);
16382 // FFEINTRIN_impIDIM //
16383     i__1 = i_dim(&i1, &i2);
16384     fooi_(&i__1);
16385 // FFEINTRIN_impIDNINT //
16386     i__1 = i_dnnt(&d1);
16387     fooi_(&i__1);
16388 // FFEINTRIN_impINDEX //
16389     i__1 = i_indx(a1, a2, 10L, 10L);
16390     fooi_(&i__1);
16391 // FFEINTRIN_impISIGN //
16392     i__1 = i_sign(&i1, &i2);
16393     fooi_(&i__1);
16394 // FFEINTRIN_impLEN //
16395     i__1 = i_len(a1, 10L);
16396     fooi_(&i__1);
16397 // FFEINTRIN_impLGE //
16398     L__1 = l_ge(a1, a2, 10L, 10L);
16399     fool_(&L__1);
16400 // FFEINTRIN_impLGT //
16401     L__1 = l_gt(a1, a2, 10L, 10L);
16402     fool_(&L__1);
16403 // FFEINTRIN_impLLE //
16404     L__1 = l_le(a1, a2, 10L, 10L);
16405     fool_(&L__1);
16406 // FFEINTRIN_impLLT //
16407     L__1 = l_lt(a1, a2, 10L, 10L);
16408     fool_(&L__1);
16409 // FFEINTRIN_impMAX0 //
16410     i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16411     fooi_(&i__1);
16412 // FFEINTRIN_impMAX1 //
16413     i__1 = (integer) (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16414     fooi_(&i__1);
16415 // FFEINTRIN_impMIN0 //
16416     i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16417     fooi_(&i__1);
16418 // FFEINTRIN_impMIN1 //
16419     i__1 = (integer) (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16420     fooi_(&i__1);
16421 // FFEINTRIN_impMOD //
16422     i__1 = i1 % i2;
16423     fooi_(&i__1);
16424 // FFEINTRIN_impNINT //
16425     i__1 = i_nint(&r1);
16426     fooi_(&i__1);
16427 // FFEINTRIN_impSIGN //
16428     r__1 = r_sign(&r1, &r2);
16429     foor_(&r__1);
16430 // FFEINTRIN_impSIN //
16431     r__1 = sin(r1);
16432     foor_(&r__1);
16433 // FFEINTRIN_impSINH //
16434     r__1 = sinh(r1);
16435     foor_(&r__1);
16436 // FFEINTRIN_impSQRT //
16437     r__1 = sqrt(r1);
16438     foor_(&r__1);
16439 // FFEINTRIN_impTAN //
16440     r__1 = tan(r1);
16441     foor_(&r__1);
16442 // FFEINTRIN_impTANH //
16443     r__1 = tanh(r1);
16444     foor_(&r__1);
16445 // FFEINTRIN_imp_CMPLX_C //
16446     r__1 = c1.r;
16447     r__2 = c2.r;
16448     q__1.r = r__1, q__1.i = r__2;
16449     fooc_(&q__1);
16450 // FFEINTRIN_imp_CMPLX_D //
16451     z__1.r = d1, z__1.i = d2;
16452     fooz_(&z__1);
16453 // FFEINTRIN_imp_CMPLX_I //
16454     r__1 = (real) i1;
16455     r__2 = (real) i2;
16456     q__1.r = r__1, q__1.i = r__2;
16457     fooc_(&q__1);
16458 // FFEINTRIN_imp_CMPLX_R //
16459     q__1.r = r1, q__1.i = r2;
16460     fooc_(&q__1);
16461 // FFEINTRIN_imp_DBLE_C //
16462     d__1 = (doublereal) c1.r;
16463     food_(&d__1);
16464 // FFEINTRIN_imp_DBLE_D //
16465     d__1 = d1;
16466     food_(&d__1);
16467 // FFEINTRIN_imp_DBLE_I //
16468     d__1 = (doublereal) i1;
16469     food_(&d__1);
16470 // FFEINTRIN_imp_DBLE_R //
16471     d__1 = (doublereal) r1;
16472     food_(&d__1);
16473 // FFEINTRIN_imp_INT_C //
16474     i__1 = (integer) c1.r;
16475     fooi_(&i__1);
16476 // FFEINTRIN_imp_INT_D //
16477     i__1 = (integer) d1;
16478     fooi_(&i__1);
16479 // FFEINTRIN_imp_INT_I //
16480     i__1 = i1;
16481     fooi_(&i__1);
16482 // FFEINTRIN_imp_INT_R //
16483     i__1 = (integer) r1;
16484     fooi_(&i__1);
16485 // FFEINTRIN_imp_REAL_C //
16486     r__1 = c1.r;
16487     foor_(&r__1);
16488 // FFEINTRIN_imp_REAL_D //
16489     r__1 = (real) d1;
16490     foor_(&r__1);
16491 // FFEINTRIN_imp_REAL_I //
16492     r__1 = (real) i1;
16493     foor_(&r__1);
16494 // FFEINTRIN_imp_REAL_R //
16495     r__1 = r1;
16496     foor_(&r__1);
16497
16498 // FFEINTRIN_imp_INT_D: //
16499
16500 // FFEINTRIN_specIDINT //
16501     i__1 = (integer) d1;
16502     fooi_(&i__1);
16503
16504 // FFEINTRIN_imp_INT_R: //
16505
16506 // FFEINTRIN_specIFIX //
16507     i__1 = (integer) r1;
16508     fooi_(&i__1);
16509 // FFEINTRIN_specINT //
16510     i__1 = (integer) r1;
16511     fooi_(&i__1);
16512
16513 // FFEINTRIN_imp_REAL_D: //
16514
16515 // FFEINTRIN_specSNGL //
16516     r__1 = (real) d1;
16517     foor_(&r__1);
16518
16519 // FFEINTRIN_imp_REAL_I: //
16520
16521 // FFEINTRIN_specFLOAT //
16522     r__1 = (real) i1;
16523     foor_(&r__1);
16524 // FFEINTRIN_specREAL //
16525     r__1 = (real) i1;
16526     foor_(&r__1);
16527
16528 } // MAIN__ //
16529
16530 -------- (end output file from f2c)
16531
16532 */
16533
16534 #include "gt-f-com.h"
16535 #include "gtype-f.h"