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
   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
  97 /* VMS-specific definitions */
  98 #ifdef VMS
  99 #include <descrip.h>
 100 #define O_RDONLY        0       /* Open arg for Read/Only  */
 101 #define O_WRONLY        1       /* Open arg for Write/Only */
 102 #define read(fd,buf,size)       VMS_read (fd,buf,size)
 103 #define write(fd,buf,size)      VMS_write (fd,buf,size)
 104 #define open(fname,mode,prot)   VMS_open (fname,mode,prot)
 105 #define fopen(fname,mode)       VMS_fopen (fname,mode)
 106 #define freopen(fname,mode,ofile) VMS_freopen (fname,mode,ofile)
 107 #define strncat(dst,src,cnt) VMS_strncat (dst,src,cnt)
 108 #define fstat(fd,stbuf)         VMS_fstat (fd,stbuf)
 109 static int VMS_fstat (), VMS_stat ();
 110 static char * VMS_strncat ();
 111 static int VMS_read ();
 112 static int VMS_write ();
 113 static int VMS_open ();
 114 static FILE * VMS_fopen ();
 115 static FILE * VMS_freopen ();
 116 static void hack_vms_include_specification ();
 117 typedef struct { unsigned :16, :16, :16; } vms_ino_t;
 118 #define ino_t vms_ino_t
 119 #define INCLUDE_LEN_FUDGE 10    /* leave room for VMS syntax conversion */
 120 #endif /* VMS */
 121
 122 #define FFECOM_DETERMINE_TYPES 1 /* for com.h */
 123 #include "com.h"
 124 #include "bad.h"
 125 #include "bld.h"
 126 #include "equiv.h"
 127 #include "expr.h"
 128 #include "implic.h"
 129 #include "info.h"
 130 #include "malloc.h"
 131 #include "src.h"
 132 #include "st.h"
 133 #include "storag.h"
 134 #include "symbol.h"
 135 #include "target.h"
 136 #include "top.h"
 137 #include "type.h"
 138
 139 /* Externals defined here.  */
 140
 141 /* Stream for reading from the input file.  */
 142 FILE *finput;
 143
 144 /* These definitions parallel those in c-decl.c so that code from that
 145    module can be used pretty much as is.  Much of these defs aren't
 146    otherwise used, i.e. by g77 code per se, except some of them are used
 147    to build some of them that are.  The ones that are global (i.e. not
 148    "static") are those that ste.c and such might use (directly
 149    or by using com macros that reference them in their definitions).  */
 150
 151 tree string_type_node;
 152
 153 /* The rest of these are inventions for g77, though there might be
 154    similar things in the C front end.  As they are found, these
 155    inventions should be renamed to be canonical.  Note that only
 156    the ones currently required to be global are so.  */
 157
 158 static tree ffecom_tree_fun_type_void;
 159
 160 tree ffecom_integer_type_node;  /* Abbrev for _tree_type[blah][blah]. */
 161 tree ffecom_integer_zero_node;  /* Like *_*_* with g77's integer type. */
 162 tree ffecom_integer_one_node;   /* " */
 163 tree ffecom_tree_type[FFEINFO_basictype][FFEINFO_kindtype];
 164
 165 /* _fun_type things are the f2c-specific versions.  For -fno-f2c,
 166    just use build_function_type and build_pointer_type on the
 167    appropriate _tree_type array element.  */
 168
 169 static tree ffecom_tree_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
 170 static tree ffecom_tree_ptr_to_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
 171 static tree ffecom_tree_subr_type;
 172 static tree ffecom_tree_ptr_to_subr_type;
 173 static tree ffecom_tree_blockdata_type;
 174
 175 static tree ffecom_tree_xargc_;
 176
 177 ffecomSymbol ffecom_symbol_null_
 178 =
 179 {
 180   NULL_TREE,
 181   NULL_TREE,
 182   NULL_TREE,
 183   NULL_TREE,
 184   false
 185 };
 186 ffeinfoKindtype ffecom_pointer_kind_ = FFEINFO_basictypeNONE;
 187 ffeinfoKindtype ffecom_label_kind_ = FFEINFO_basictypeNONE;
 188
 189 int ffecom_f2c_typecode_[FFEINFO_basictype][FFEINFO_kindtype];
 190 tree ffecom_f2c_integer_type_node;
 191 tree ffecom_f2c_ptr_to_integer_type_node;
 192 tree ffecom_f2c_address_type_node;
 193 tree ffecom_f2c_real_type_node;
 194 tree ffecom_f2c_ptr_to_real_type_node;
 195 tree ffecom_f2c_doublereal_type_node;
 196 tree ffecom_f2c_complex_type_node;
 197 tree ffecom_f2c_doublecomplex_type_node;
 198 tree ffecom_f2c_longint_type_node;
 199 tree ffecom_f2c_logical_type_node;
 200 tree ffecom_f2c_flag_type_node;
 201 tree ffecom_f2c_ftnlen_type_node;
 202 tree ffecom_f2c_ftnlen_zero_node;
 203 tree ffecom_f2c_ftnlen_one_node;
 204 tree ffecom_f2c_ftnlen_two_node;
 205 tree ffecom_f2c_ptr_to_ftnlen_type_node;
 206 tree ffecom_f2c_ftnint_type_node;
 207 tree ffecom_f2c_ptr_to_ftnint_type_node;
 208
 209 /* Simple definitions and enumerations. */
 210
 211 #ifndef FFECOM_sizeMAXSTACKITEM
 212 #define FFECOM_sizeMAXSTACKITEM 32*1024 /* Keep user-declared things
 213                                            larger than this # bytes
 214                                            off stack if possible. */
 215 #endif
 216
 217 /* For systems that have large enough stacks, they should define
 218    this to 0, and here, for ease of use later on, we just undefine
 219    it if it is 0.  */
 220
 221 #if FFECOM_sizeMAXSTACKITEM == 0
 222 #undef FFECOM_sizeMAXSTACKITEM
 223 #endif
 224
 225 typedef enum
 226   {
 227     FFECOM_rttypeVOID_,
 228     FFECOM_rttypeVOIDSTAR_,     /* C's `void *' type. */
 229     FFECOM_rttypeFTNINT_,       /* f2c's `ftnint' type. */
 230     FFECOM_rttypeINTEGER_,      /* f2c's `integer' type. */
 231     FFECOM_rttypeLONGINT_,      /* f2c's `longint' type. */
 232     FFECOM_rttypeLOGICAL_,      /* f2c's `logical' type. */
 233     FFECOM_rttypeREAL_F2C_,     /* f2c's `real' returned as `double'. */
 234     FFECOM_rttypeREAL_GNU_,     /* `real' returned as such. */
 235     FFECOM_rttypeCOMPLEX_F2C_,  /* f2c's `complex' returned via 1st arg. */
 236     FFECOM_rttypeCOMPLEX_GNU_,  /* f2c's `complex' returned directly. */
 237     FFECOM_rttypeDOUBLE_,       /* C's `double' type. */
 238     FFECOM_rttypeDOUBLEREAL_,   /* f2c's `doublereal' type. */
 239     FFECOM_rttypeDBLCMPLX_F2C_, /* f2c's `doublecomplex' returned via 1st arg. */
 240     FFECOM_rttypeDBLCMPLX_GNU_, /* f2c's `doublecomplex' returned directly. */
 241     FFECOM_rttypeCHARACTER_,    /* f2c `char *'/`ftnlen' pair. */
 242     FFECOM_rttype_
 243   } ffecomRttype_;
 244
 245 /* Internal typedefs. */
 246
 247 typedef struct _ffecom_concat_list_ ffecomConcatList_;
 248
 249 /* Private include files. */
 250
 251
 252 /* Internal structure definitions. */
 253
 254 struct _ffecom_concat_list_
 255   {
 256     ffebld *exprs;
 257     int count;
 258     int max;
 259     ffetargetCharacterSize minlen;
 260     ffetargetCharacterSize maxlen;
 261   };
 262
 263 /* Static functions (internal). */
 264
 265 static tree ffe_type_for_mode PARAMS ((enum machine_mode, int));
 266 static tree ffe_type_for_size PARAMS ((unsigned int, int));
 267 static tree ffe_unsigned_type PARAMS ((tree));
 268 static tree ffe_signed_type PARAMS ((tree));
 269 static tree ffe_signed_or_unsigned_type PARAMS ((int, tree));
 270 static bool ffe_mark_addressable PARAMS ((tree));
 271 static tree ffe_truthvalue_conversion PARAMS ((tree));
 272 static void ffecom_init_decl_processing PARAMS ((void));
 273 static tree ffecom_arglist_expr_ (const char *argstring, ffebld args);
 274 static tree ffecom_widest_expr_type_ (ffebld list);
 275 static bool ffecom_overlap_ (tree dest_decl, tree dest_offset,
 276                              tree dest_size, tree source_tree,
 277                              ffebld source, bool scalar_arg);
 278 static bool ffecom_args_overlapping_ (tree dest_tree, ffebld dest,
 279                                       tree args, tree callee_commons,
 280                                       bool scalar_args);
 281 static tree ffecom_build_f2c_string_ (int i, const char *s);
 282 static tree ffecom_call_ (tree fn, ffeinfoKindtype kt,
 283                           bool is_f2c_complex, tree type,
 284                           tree args, tree dest_tree,
 285                           ffebld dest, bool *dest_used,
 286                           tree callee_commons, bool scalar_args, tree hook);
 287 static tree ffecom_call_binop_ (tree fn, ffeinfoKindtype kt,
 288                                 bool is_f2c_complex, tree type,
 289                                 ffebld left, ffebld right,
 290                                 tree dest_tree, ffebld dest,
 291                                 bool *dest_used, tree callee_commons,
 292                                 bool scalar_args, bool ref, tree hook);
 293 static void ffecom_char_args_x_ (tree *xitem, tree *length,
 294                                  ffebld expr, bool with_null);
 295 static tree ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy);
 296 static tree ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s);
 297 static ffecomConcatList_
 298   ffecom_concat_list_gather_ (ffecomConcatList_ catlist,
 299                               ffebld expr,
 300                               ffetargetCharacterSize max);
 301 static void ffecom_concat_list_kill_ (ffecomConcatList_ catlist);
 302 static ffecomConcatList_ ffecom_concat_list_new_ (ffebld expr,
 303                                                 ffetargetCharacterSize max);
 304 static void ffecom_debug_kludge_ (tree aggr, const char *aggr_type,
 305                                   ffesymbol member, tree member_type,
 306                                   ffetargetOffset offset);
 307 static void ffecom_do_entry_ (ffesymbol fn, int entrynum);
 308 static tree ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
 309                           bool *dest_used, bool assignp, bool widenp);
 310 static tree ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
 311                                     ffebld dest, bool *dest_used);
 312 static tree ffecom_expr_power_integer_ (ffebld expr);
 313 static void ffecom_expr_transform_ (ffebld expr);
 314 static void ffecom_f2c_make_type_ (tree *type, int tcode, const char *name);
 315 static void ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
 316                                       int code);
 317 static ffeglobal ffecom_finish_global_ (ffeglobal global);
 318 static ffesymbol ffecom_finish_symbol_transform_ (ffesymbol s);
 319 static tree ffecom_get_appended_identifier_ (char us, const char *text);
 320 static tree ffecom_get_external_identifier_ (ffesymbol s);
 321 static tree ffecom_get_identifier_ (const char *text);
 322 static tree ffecom_gen_sfuncdef_ (ffesymbol s,
 323                                   ffeinfoBasictype bt,
 324                                   ffeinfoKindtype kt);
 325 static const char *ffecom_gfrt_args_ (ffecomGfrt ix);
 326 static tree ffecom_gfrt_tree_ (ffecomGfrt ix);
 327 static tree ffecom_init_zero_ (tree decl);
 328 static tree ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
 329                                      tree *maybe_tree);
 330 static tree ffecom_intrinsic_len_ (ffebld expr);
 331 static void ffecom_let_char_ (tree dest_tree,
 332                               tree dest_length,
 333                               ffetargetCharacterSize dest_size,
 334                               ffebld source);
 335 static void ffecom_make_gfrt_ (ffecomGfrt ix);
 336 static void ffecom_member_phase1_ (ffestorag mst, ffestorag st);
 337 static void ffecom_member_phase2_ (ffestorag mst, ffestorag st);
 338 static void ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size,
 339                                       ffebld source);
 340 static void ffecom_push_dummy_decls_ (ffebld dumlist,
 341                                       bool stmtfunc);
 342 static void ffecom_start_progunit_ (void);
 343 static ffesymbol ffecom_sym_transform_ (ffesymbol s);
 344 static ffesymbol ffecom_sym_transform_assign_ (ffesymbol s);
 345 static void ffecom_transform_common_ (ffesymbol s);
 346 static void ffecom_transform_equiv_ (ffestorag st);
 347 static tree ffecom_transform_namelist_ (ffesymbol s);
 348 static void ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
 349                                        tree t);
 350 static void ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
 351                                        tree *size, tree tree);
 352 static tree ffecom_tree_divide_ (tree tree_type, tree left, tree right,
 353                                  tree dest_tree, ffebld dest,
 354                                  bool *dest_used, tree hook);
 355 static tree ffecom_type_localvar_ (ffesymbol s,
 356                                    ffeinfoBasictype bt,
 357                                    ffeinfoKindtype kt);
 358 static tree ffecom_type_namelist_ (void);
 359 static tree ffecom_type_vardesc_ (void);
 360 static tree ffecom_vardesc_ (ffebld expr);
 361 static tree ffecom_vardesc_array_ (ffesymbol s);
 362 static tree ffecom_vardesc_dims_ (ffesymbol s);
 363 static tree ffecom_convert_narrow_ (tree type, tree expr);
 364 static tree ffecom_convert_widen_ (tree type, tree expr);
 365
 366 /* These are static functions that parallel those found in the C front
 367    end and thus have the same names.  */
 368
 369 static tree bison_rule_compstmt_ (void);
 370 static void bison_rule_pushlevel_ (void);
 371 static void delete_block (tree block);
 372 static int duplicate_decls (tree newdecl, tree olddecl);
 373 static void finish_decl (tree decl, tree init, bool is_top_level);
 374 static void finish_function (int nested);
 375 static const char *ffe_printable_name (tree decl, int v);
 376 static void ffe_print_error_function (diagnostic_context *, const char *);
 377 static tree lookup_name_current_level (tree name);
 378 static struct binding_level *make_binding_level (void);
 379 static void pop_f_function_context (void);
 380 static void push_f_function_context (void);
 381 static void push_parm_decl (tree parm);
 382 static tree pushdecl_top_level (tree decl);
 383 static int kept_level_p (void);
 384 static tree storedecls (tree decls);
 385 static void store_parm_decls (int is_main_program);
 386 static tree start_decl (tree decl, bool is_top_level);
 387 static void start_function (tree name, tree type, int nested, int public);
 388 static void ffecom_file_ (const char *name);
 389 static void ffecom_close_include_ (FILE *f);
 390 static int ffecom_decode_include_option_ (char *spec);
 391 static FILE *ffecom_open_include_ (char *name, ffewhereLine l,
 392                                    ffewhereColumn c);
 393
 394 /* Static objects accessed by functions in this module. */
 395
 396 static ffesymbol ffecom_primary_entry_ = NULL;
 397 static ffesymbol ffecom_nested_entry_ = NULL;
 398 static ffeinfoKind ffecom_primary_entry_kind_;
 399 static bool ffecom_primary_entry_is_proc_;
 400 static tree ffecom_outer_function_decl_;
 401 static tree ffecom_previous_function_decl_;
 402 static tree ffecom_which_entrypoint_decl_;
 403 static tree ffecom_float_zero_ = NULL_TREE;
 404 static tree ffecom_float_half_ = NULL_TREE;
 405 static tree ffecom_double_zero_ = NULL_TREE;
 406 static tree ffecom_double_half_ = NULL_TREE;
 407 static tree ffecom_func_result_;/* For functions. */
 408 static tree ffecom_func_length_;/* For CHARACTER fns. */
 409 static ffebld ffecom_list_blockdata_;
 410 static ffebld ffecom_list_common_;
 411 static ffebld ffecom_master_arglist_;
 412 static ffeinfoBasictype ffecom_master_bt_;
 413 static ffeinfoKindtype ffecom_master_kt_;
 414 static ffetargetCharacterSize ffecom_master_size_;
 415 static int ffecom_num_fns_ = 0;
 416 static int ffecom_num_entrypoints_ = 0;
 417 static bool ffecom_is_altreturning_ = FALSE;
 418 static tree ffecom_multi_type_node_;
 419 static tree ffecom_multi_retval_;
 420 static tree
 421   ffecom_multi_fields_[FFEINFO_basictype][FFEINFO_kindtype];
 422 static bool ffecom_member_namelisted_;  /* _member_phase1_ namelisted? */
 423 static bool ffecom_doing_entry_ = FALSE;
 424 static bool ffecom_transform_only_dummies_ = FALSE;
 425 static int ffecom_typesize_pointer_;
 426 static int ffecom_typesize_integer1_;
 427
 428 /* Holds pointer-to-function expressions.  */
 429
 430 static tree ffecom_gfrt_[FFECOM_gfrt]
 431 =
 432 {
 433 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NULL_TREE,
 434 #include "com-rt.def"
 435 #undef DEFGFRT
 436 };
 437
 438 /* Holds the external names of the functions.  */
 439
 440 static const char *const ffecom_gfrt_name_[FFECOM_gfrt]
 441 =
 442 {
 443 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NAME,
 444 #include "com-rt.def"
 445 #undef DEFGFRT
 446 };
 447
 448 /* Whether the function returns.  */
 449
 450 static const bool ffecom_gfrt_volatile_[FFECOM_gfrt]
 451 =
 452 {
 453 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) VOLATILE,
 454 #include "com-rt.def"
 455 #undef DEFGFRT
 456 };
 457
 458 /* Whether the function returns type complex.  */
 459
 460 static const bool ffecom_gfrt_complex_[FFECOM_gfrt]
 461 =
 462 {
 463 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) COMPLEX,
 464 #include "com-rt.def"
 465 #undef DEFGFRT
 466 };
 467
 468 /* Whether the function is const
 469    (i.e., has no side effects and only depends on its arguments).  */
 470
 471 static const bool ffecom_gfrt_const_[FFECOM_gfrt]
 472 =
 473 {
 474 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) CONST,
 475 #include "com-rt.def"
 476 #undef DEFGFRT
 477 };
 478
 479 /* Type code for the function return value.  */
 480
 481 static const ffecomRttype_ ffecom_gfrt_type_[FFECOM_gfrt]
 482 =
 483 {
 484 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) TYPE,
 485 #include "com-rt.def"
 486 #undef DEFGFRT
 487 };
 488
 489 /* String of codes for the function's arguments.  */
 490
 491 static const char *const ffecom_gfrt_argstring_[FFECOM_gfrt]
 492 =
 493 {
 494 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) ARGS,
 495 #include "com-rt.def"
 496 #undef DEFGFRT
 497 };
 498
 499 /* Internal macros. */
 500
 501 /* We let tm.h override the types used here, to handle trivial differences
 502    such as the choice of unsigned int or long unsigned int for size_t.
 503    When machines start needing nontrivial differences in the size type,
 504    it would be best to do something here to figure out automatically
 505    from other information what type to use.  */
 506
 507 #ifndef SIZE_TYPE
 508 #define SIZE_TYPE "long unsigned int"
 509 #endif
 510
 511 #define ffecom_concat_list_count_(catlist) ((catlist).count)
 512 #define ffecom_concat_list_expr_(catlist,i) ((catlist).exprs[(i)])
 513 #define ffecom_concat_list_maxlen_(catlist) ((catlist).maxlen)
 514 #define ffecom_concat_list_minlen_(catlist) ((catlist).minlen)
 515
 516 #define ffecom_char_args_(i,l,e) ffecom_char_args_x_((i),(l),(e),FALSE)
 517 #define ffecom_char_args_with_null_(i,l,e) ffecom_char_args_x_((i),(l),(e),TRUE)
 518
 519 /* For each binding contour we allocate a binding_level structure
 520  * which records the names defined in that contour.
 521  * Contours include:
 522  *  0) the global one
 523  *  1) one for each function definition,
 524  *     where internal declarations of the parameters appear.
 525  *
 526  * The current meaning of a name can be found by searching the levels from
 527  * the current one out to the global one.
 528  */
 529
 530 /* Note that the information in the `names' component of the global contour
 531    is duplicated in the IDENTIFIER_GLOBAL_VALUEs of all identifiers.  */
 532
 533 struct binding_level
 534   {
 535     /* A chain of _DECL nodes for all variables, constants, functions,
 536        and typedef types.  These are in the reverse of the order supplied.
 537      */
 538     tree names;
 539
 540     /* For each level (except not the global one),
 541        a chain of BLOCK nodes for all the levels
 542        that were entered and exited one level down.  */
 543     tree blocks;
 544
 545     /* The BLOCK node for this level, if one has been preallocated.
 546        If 0, the BLOCK is allocated (if needed) when the level is popped.  */
 547     tree this_block;
 548
 549     /* The binding level which this one is contained in (inherits from).  */
 550     struct binding_level *level_chain;
 551
 552     /* 0: no ffecom_prepare_* functions called at this level yet;
 553        1: ffecom_prepare* functions called, except not ffecom_prepare_end;
 554        2: ffecom_prepare_end called.  */
 555     int prep_state;
 556   };
 557
 558 #define NULL_BINDING_LEVEL (struct binding_level *) NULL
 559
 560 /* The binding level currently in effect.  */
 561
 562 static struct binding_level *current_binding_level;
 563
 564 /* A chain of binding_level structures awaiting reuse.  */
 565
 566 static struct binding_level *free_binding_level;
 567
 568 /* The outermost binding level, for names of file scope.
 569    This is created when the compiler is started and exists
 570    through the entire run.  */
 571
 572 static struct binding_level *global_binding_level;
 573
 574 /* Binding level structures are initialized by copying this one.  */
 575
 576 static const struct binding_level clear_binding_level
 577 =
 578 {NULL, NULL, NULL, NULL_BINDING_LEVEL, 0};
 579
 580 /* Language-dependent contents of an identifier.  */
 581
 582 struct lang_identifier
 583   {
 584     struct tree_identifier ignore;
 585     tree global_value, local_value, label_value;
 586     bool invented;
 587   };
 588
 589 /* Macros for access to language-specific slots in an identifier.  */
 590 /* Each of these slots contains a DECL node or null.  */
 591
 592 /* This represents the value which the identifier has in the
 593    file-scope namespace.  */
 594 #define IDENTIFIER_GLOBAL_VALUE(NODE)   \
 595   (((struct lang_identifier *)(NODE))->global_value)
 596 /* This represents the value which the identifier has in the current
 597    scope.  */
 598 #define IDENTIFIER_LOCAL_VALUE(NODE)    \
 599   (((struct lang_identifier *)(NODE))->local_value)
 600 /* This represents the value which the identifier has as a label in
 601    the current label scope.  */
 602 #define IDENTIFIER_LABEL_VALUE(NODE)    \
 603   (((struct lang_identifier *)(NODE))->label_value)
 604 /* This is nonzero if the identifier was "made up" by g77 code.  */
 605 #define IDENTIFIER_INVENTED(NODE)       \
 606   (((struct lang_identifier *)(NODE))->invented)
 607
 608 /* In identifiers, C uses the following fields in a special way:
 609    TREE_PUBLIC        to record that there was a previous local extern decl.
 610    TREE_USED          to record that such a decl was used.
 611    TREE_ADDRESSABLE   to record that the address of such a decl was used.  */
 612
 613 /* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function
 614    that have names.  Here so we can clear out their names' definitions
 615    at the end of the function.  */
 616
 617 static tree named_labels;
 618
 619 /* A list of LABEL_DECLs from outer contexts that are currently shadowed.  */
 620
 621 static tree shadowed_labels;
 622 \f
 623 /* Return the subscript expression, modified to do range-checking.
 624
 625    `array' is the array to be checked against.
 626    `element' is the subscript expression to check.
 627    `dim' is the dimension number (starting at 0).
 628    `total_dims' is the total number of dimensions (0 for CHARACTER substring).
 629 */
 630
 631 static tree
 632 ffecom_subscript_check_ (tree array, tree element, int dim, int total_dims,
 633                          const char *array_name)
 634 {
 635   tree low = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
 636   tree high = TYPE_MAX_VALUE (TYPE_DOMAIN (array));
 637   tree cond;
 638   tree die;
 639   tree args;
 640
 641   if (element == error_mark_node)
 642     return element;
 643
 644   if (TREE_TYPE (low) != TREE_TYPE (element))
 645     {
 646       if (TYPE_PRECISION (TREE_TYPE (low))
 647           > TYPE_PRECISION (TREE_TYPE (element)))
 648         element = convert (TREE_TYPE (low), element);
 649       else
 650         {
 651           low = convert (TREE_TYPE (element), low);
 652           if (high)
 653             high = convert (TREE_TYPE (element), high);
 654         }
 655     }
 656
 657   element = ffecom_save_tree (element);
 658   if (total_dims == 0)
 659     {
 660       /* Special handling for substring range checks.  Fortran allows the
 661          end subscript < begin subscript, which means that expressions like
 662        string(1:0) are valid (and yield a null string).  In view of this,
 663        enforce two simpler conditions:
 664           1) element<=high for end-substring;
 665           2) element>=low for start-substring.
 666        Run-time character movement will enforce remaining conditions.
 667
 668        More complicated checks would be better, but present structure only
 669        provides one index element at a time, so it is not possible to
 670        enforce a check of both i and j in string(i:j).  If it were, the
 671        complete set of rules would read,
 672          if ( ((j<i) && ((low<=i<=high) || (low<=j<=high))) ||
 673               ((low<=i<=high) && (low<=j<=high)) )
 674            ok ;
 675          else
 676            range error ;
 677       */
 678       if (dim)
 679         cond = ffecom_2 (LE_EXPR, integer_type_node, element, high);
 680       else
 681         cond = ffecom_2 (LE_EXPR, integer_type_node, low, element);
 682     }
 683   else
 684     {
 685       /* Array reference substring range checking.  */
 686
 687       cond = ffecom_2 (LE_EXPR, integer_type_node,
 688                      low,
 689                      element);
 690       if (high)
 691         {
 692           cond = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
 693                          cond,
 694                          ffecom_2 (LE_EXPR, integer_type_node,
 695                                    element,
 696                                    high));
 697         }
 698     }
 699
 700   {
 701     int len;
 702     char *proc;
 703     char *var;
 704     tree arg3;
 705     tree arg2;
 706     tree arg1;
 707     tree arg4;
 708
 709     switch (total_dims)
 710       {
 711       case 0:
 712         var = concat (array_name, "[", (dim ? "end" : "start"),
 713                       "-substring]", NULL);
 714         len = strlen (var) + 1;
 715         arg1 = build_string (len, var);
 716         free (var);
 717         break;
 718
 719       case 1:
 720         len = strlen (array_name) + 1;
 721         arg1 = build_string (len, array_name);
 722         break;
 723
 724       default:
 725         var = xmalloc (strlen (array_name) + 40);
 726         sprintf (var, "%s[subscript-%d-of-%d]",
 727                  array_name,
 728                  dim + 1, total_dims);
 729         len = strlen (var) + 1;
 730         arg1 = build_string (len, var);
 731         free (var);
 732         break;
 733       }
 734
 735     TREE_TYPE (arg1)
 736       = build_type_variant (build_array_type (char_type_node,
 737                                               build_range_type
 738                                               (integer_type_node,
 739                                                integer_one_node,
 740                                                build_int_2 (len, 0))),
 741                             1, 0);
 742     TREE_CONSTANT (arg1) = 1;
 743     TREE_STATIC (arg1) = 1;
 744     arg1 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg1)),
 745                      arg1);
 746
 747     /* s_rnge adds one to the element to print it, so bias against
 748        that -- want to print a faithful *subscript* value.  */
 749     arg2 = convert (ffecom_f2c_ftnint_type_node,
 750                     ffecom_2 (MINUS_EXPR,
 751                               TREE_TYPE (element),
 752                               element,
 753                               convert (TREE_TYPE (element),
 754                                        integer_one_node)));
 755
 756     proc = concat (input_filename, "/",
 757                    IDENTIFIER_POINTER (DECL_NAME (current_function_decl)),
 758                    NULL);
 759     len = strlen (proc) + 1;
 760     arg3 = build_string (len, proc);
 761
 762     free (proc);
 763
 764     TREE_TYPE (arg3)
 765       = build_type_variant (build_array_type (char_type_node,
 766                                               build_range_type
 767                                               (integer_type_node,
 768                                                integer_one_node,
 769                                                build_int_2 (len, 0))),
 770                             1, 0);
 771     TREE_CONSTANT (arg3) = 1;
 772     TREE_STATIC (arg3) = 1;
 773     arg3 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg3)),
 774                      arg3);
 775
 776     arg4 = convert (ffecom_f2c_ftnint_type_node,
 777                     build_int_2 (lineno, 0));
 778
 779     arg1 = build_tree_list (NULL_TREE, arg1);
 780     arg2 = build_tree_list (NULL_TREE, arg2);
 781     arg3 = build_tree_list (NULL_TREE, arg3);
 782     arg4 = build_tree_list (NULL_TREE, arg4);
 783     TREE_CHAIN (arg3) = arg4;
 784     TREE_CHAIN (arg2) = arg3;
 785     TREE_CHAIN (arg1) = arg2;
 786
 787     args = arg1;
 788   }
 789   die = ffecom_call_gfrt (FFECOM_gfrtRANGE,
 790                           args, NULL_TREE);
 791   TREE_SIDE_EFFECTS (die) = 1;
 792
 793   element = ffecom_3 (COND_EXPR,
 794                       TREE_TYPE (element),
 795                       cond,
 796                       element,
 797                       die);
 798
 799   return element;
 800 }
 801
 802 /* Return the computed element of an array reference.
 803
 804    `item' is NULL_TREE, or the transformed pointer to the array.
 805    `expr' is the original opARRAYREF expression, which is transformed
 806      if `item' is NULL_TREE.
 807    `want_ptr' is non-zero if a pointer to the element, instead of
 808      the element itself, is to be returned.  */
 809
 810 static tree
 811 ffecom_arrayref_ (tree item, ffebld expr, int want_ptr)
 812 {
 813   ffebld dims[FFECOM_dimensionsMAX];
 814   int i;
 815   int total_dims;
 816   int flatten = ffe_is_flatten_arrays ();
 817   int need_ptr;
 818   tree array;
 819   tree element;
 820   tree tree_type;
 821   tree tree_type_x;
 822   const char *array_name;
 823   ffetype type;
 824   ffebld list;
 825
 826   if (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER)
 827     array_name = ffesymbol_text (ffebld_symter (ffebld_left (expr)));
 828   else
 829     array_name = "[expr?]";
 830
 831   /* Build up ARRAY_REFs in reverse order (since we're column major
 832      here in Fortran land). */
 833
 834   for (i = 0, list = ffebld_right (expr);
 835        list != NULL;
 836        ++i, list = ffebld_trail (list))
 837     {
 838       dims[i] = ffebld_head (list);
 839       type = ffeinfo_type (ffebld_basictype (dims[i]),
 840                            ffebld_kindtype (dims[i]));
 841       if (! flatten
 842           && ffecom_typesize_pointer_ > ffecom_typesize_integer1_
 843           && ffetype_size (type) > ffecom_typesize_integer1_)
 844         /* E.g. ARRAY(INDEX), given INTEGER*8 INDEX, on a system with 64-bit
 845            pointers and 32-bit integers.  Do the full 64-bit pointer
 846            arithmetic, for codes using arrays for nonstandard heap-like
 847            work.  */
 848         flatten = 1;
 849     }
 850
 851   total_dims = i;
 852
 853   need_ptr = want_ptr || flatten;
 854
 855   if (! item)
 856     {
 857       if (need_ptr)
 858         item = ffecom_ptr_to_expr (ffebld_left (expr));
 859       else
 860         item = ffecom_expr (ffebld_left (expr));
 861
 862       if (item == error_mark_node)
 863         return item;
 864
 865       if (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereFLEETING
 866           && ! ffe_mark_addressable (item))
 867         return error_mark_node;
 868     }
 869
 870   if (item == error_mark_node)
 871     return item;
 872
 873   if (need_ptr)
 874     {
 875       tree min;
 876
 877       for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
 878            i >= 0;
 879            --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array)))
 880         {
 881           min = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
 882           element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
 883           if (flag_bounds_check)
 884             element = ffecom_subscript_check_ (array, element, i, total_dims,
 885                                                array_name);
 886           if (element == error_mark_node)
 887             return element;
 888
 889           /* Widen integral arithmetic as desired while preserving
 890              signedness.  */
 891           tree_type = TREE_TYPE (element);
 892           tree_type_x = tree_type;
 893           if (tree_type
 894               && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
 895               && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
 896             tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
 897
 898           if (TREE_TYPE (min) != tree_type_x)
 899             min = convert (tree_type_x, min);
 900           if (TREE_TYPE (element) != tree_type_x)
 901             element = convert (tree_type_x, element);
 902
 903           item = ffecom_2 (PLUS_EXPR,
 904                            build_pointer_type (TREE_TYPE (array)),
 905                            item,
 906                            size_binop (MULT_EXPR,
 907                                        size_in_bytes (TREE_TYPE (array)),
 908                                        convert (sizetype,
 909                                                 fold (build (MINUS_EXPR,
 910                                                              tree_type_x,
 911                                                              element, min)))));
 912         }
 913       if (! want_ptr)
 914         {
 915           item = ffecom_1 (INDIRECT_REF,
 916                            TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
 917                            item);
 918         }
 919     }
 920   else
 921     {
 922       for (--i;
 923            i >= 0;
 924            --i)
 925         {
 926           array = TYPE_MAIN_VARIANT (TREE_TYPE (item));
 927
 928           element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
 929           if (flag_bounds_check)
 930             element = ffecom_subscript_check_ (array, element, i, total_dims,
 931                                                array_name);
 932           if (element == error_mark_node)
 933             return element;
 934
 935           /* Widen integral arithmetic as desired while preserving
 936              signedness.  */
 937           tree_type = TREE_TYPE (element);
 938           tree_type_x = tree_type;
 939           if (tree_type
 940               && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
 941               && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
 942             tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
 943
 944           element = convert (tree_type_x, element);
 945
 946           item = ffecom_2 (ARRAY_REF,
 947                            TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
 948                            item,
 949                            element);
 950         }
 951     }
 952
 953   return item;
 954 }
 955
 956 /* This is like gcc's stabilize_reference -- in fact, most of the code
 957    comes from that -- but it handles the situation where the reference
 958    is going to have its subparts picked at, and it shouldn't change
 959    (or trigger extra invocations of functions in the subtrees) due to
 960    this.  save_expr is a bit overzealous, because we don't need the
 961    entire thing calculated and saved like a temp.  So, for DECLs, no
 962    change is needed, because these are stable aggregates, and ARRAY_REF
 963    and such might well be stable too, but for things like calculations,
 964    we do need to calculate a snapshot of a value before picking at it.  */
 965
 966 static tree
 967 ffecom_stabilize_aggregate_ (tree ref)
 968 {
 969   tree result;
 970   enum tree_code code = TREE_CODE (ref);
 971
 972   switch (code)
 973     {
 974     case VAR_DECL:
 975     case PARM_DECL:
 976     case RESULT_DECL:
 977       /* No action is needed in this case.  */
 978       return ref;
 979
 980     case NOP_EXPR:
 981     case CONVERT_EXPR:
 982     case FLOAT_EXPR:
 983     case FIX_TRUNC_EXPR:
 984     case FIX_FLOOR_EXPR:
 985     case FIX_ROUND_EXPR:
 986     case FIX_CEIL_EXPR:
 987       result = build_nt (code, stabilize_reference (TREE_OPERAND (ref, 0)));
 988       break;
 989
 990     case INDIRECT_REF:
 991       result = build_nt (INDIRECT_REF,
 992                          stabilize_reference_1 (TREE_OPERAND (ref, 0)));
 993       break;
 994
 995     case COMPONENT_REF:
 996       result = build_nt (COMPONENT_REF,
 997                          stabilize_reference (TREE_OPERAND (ref, 0)),
 998                          TREE_OPERAND (ref, 1));
 999       break;
1000
1001     case BIT_FIELD_REF:
1002       result = build_nt (BIT_FIELD_REF,
1003                          stabilize_reference (TREE_OPERAND (ref, 0)),
1004                          stabilize_reference_1 (TREE_OPERAND (ref, 1)),
1005                          stabilize_reference_1 (TREE_OPERAND (ref, 2)));
1006       break;
1007
1008     case ARRAY_REF:
1009       result = build_nt (ARRAY_REF,
1010                          stabilize_reference (TREE_OPERAND (ref, 0)),
1011                          stabilize_reference_1 (TREE_OPERAND (ref, 1)));
1012       break;
1013
1014     case COMPOUND_EXPR:
1015       result = build_nt (COMPOUND_EXPR,
1016                          stabilize_reference_1 (TREE_OPERAND (ref, 0)),
1017                          stabilize_reference (TREE_OPERAND (ref, 1)));
1018       break;
1019
1020     case RTL_EXPR:
1021       abort ();
1022
1023
1024     default:
1025       return save_expr (ref);
1026
1027     case ERROR_MARK:
1028       return error_mark_node;
1029     }
1030
1031   TREE_TYPE (result) = TREE_TYPE (ref);
1032   TREE_READONLY (result) = TREE_READONLY (ref);
1033   TREE_SIDE_EFFECTS (result) = TREE_SIDE_EFFECTS (ref);
1034   TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref);
1035
1036   return result;
1037 }
1038
1039 /* A rip-off of gcc's convert.c convert_to_complex function,
1040    reworked to handle complex implemented as C structures
1041    (RECORD_TYPE with two fields, real and imaginary `r' and `i').  */
1042
1043 static tree
1044 ffecom_convert_to_complex_ (tree type, tree expr)
1045 {
1046   register enum tree_code form = TREE_CODE (TREE_TYPE (expr));
1047   tree subtype;
1048
1049   assert (TREE_CODE (type) == RECORD_TYPE);
1050
1051   subtype = TREE_TYPE (TYPE_FIELDS (type));
1052
1053   if (form == REAL_TYPE || form == INTEGER_TYPE || form == ENUMERAL_TYPE)
1054     {
1055       expr = convert (subtype, expr);
1056       return ffecom_2 (COMPLEX_EXPR, type, expr,
1057                        convert (subtype, integer_zero_node));
1058     }
1059
1060   if (form == RECORD_TYPE)
1061     {
1062       tree elt_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr)));
1063       if (TYPE_MAIN_VARIANT (elt_type) == TYPE_MAIN_VARIANT (subtype))
1064         return expr;
1065       else
1066         {
1067           expr = save_expr (expr);
1068           return ffecom_2 (COMPLEX_EXPR,
1069                            type,
1070                            convert (subtype,
1071                                     ffecom_1 (REALPART_EXPR,
1072                                               TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1073                                               expr)),
1074                            convert (subtype,
1075                                     ffecom_1 (IMAGPART_EXPR,
1076                                               TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1077                                               expr)));
1078         }
1079     }
1080
1081   if (form == POINTER_TYPE || form == REFERENCE_TYPE)
1082     error ("pointer value used where a complex was expected");
1083   else
1084     error ("aggregate value used where a complex was expected");
1085
1086   return ffecom_2 (COMPLEX_EXPR, type,
1087                    convert (subtype, integer_zero_node),
1088                    convert (subtype, integer_zero_node));
1089 }
1090
1091 /* Like gcc's convert(), but crashes if widening might happen.  */
1092
1093 static tree
1094 ffecom_convert_narrow_ (type, expr)
1095      tree type, expr;
1096 {
1097   register tree e = expr;
1098   register enum tree_code code = TREE_CODE (type);
1099
1100   if (type == TREE_TYPE (e)
1101       || TREE_CODE (e) == ERROR_MARK)
1102     return e;
1103   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1104     return fold (build1 (NOP_EXPR, type, e));
1105   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1106       || code == ERROR_MARK)
1107     return error_mark_node;
1108   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1109     {
1110       assert ("void value not ignored as it ought to be" == NULL);
1111       return error_mark_node;
1112     }
1113   assert (code != VOID_TYPE);
1114   if ((code != RECORD_TYPE)
1115       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1116     assert ("converting COMPLEX to REAL" == NULL);
1117   assert (code != ENUMERAL_TYPE);
1118   if (code == INTEGER_TYPE)
1119     {
1120       assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1121                && TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)))
1122               || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1123                   && (TYPE_PRECISION (type)
1124                       == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1125       return fold (convert_to_integer (type, e));
1126     }
1127   if (code == POINTER_TYPE)
1128     {
1129       assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1130       return fold (convert_to_pointer (type, e));
1131     }
1132   if (code == REAL_TYPE)
1133     {
1134       assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1135       assert (TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)));
1136       return fold (convert_to_real (type, e));
1137     }
1138   if (code == COMPLEX_TYPE)
1139     {
1140       assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1141       assert (TYPE_PRECISION (TREE_TYPE (type)) <= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1142       return fold (convert_to_complex (type, e));
1143     }
1144   if (code == RECORD_TYPE)
1145     {
1146       assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1147       /* Check that at least the first field name agrees.  */
1148       assert (DECL_NAME (TYPE_FIELDS (type))
1149               == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1150       assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1151               <= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1152       if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1153           == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1154         return e;
1155       return fold (ffecom_convert_to_complex_ (type, e));
1156     }
1157
1158   assert ("conversion to non-scalar type requested" == NULL);
1159   return error_mark_node;
1160 }
1161
1162 /* Like gcc's convert(), but crashes if narrowing might happen.  */
1163
1164 static tree
1165 ffecom_convert_widen_ (type, expr)
1166      tree type, expr;
1167 {
1168   register tree e = expr;
1169   register enum tree_code code = TREE_CODE (type);
1170
1171   if (type == TREE_TYPE (e)
1172       || TREE_CODE (e) == ERROR_MARK)
1173     return e;
1174   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1175     return fold (build1 (NOP_EXPR, type, e));
1176   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1177       || code == ERROR_MARK)
1178     return error_mark_node;
1179   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1180     {
1181       assert ("void value not ignored as it ought to be" == NULL);
1182       return error_mark_node;
1183     }
1184   assert (code != VOID_TYPE);
1185   if ((code != RECORD_TYPE)
1186       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1187     assert ("narrowing COMPLEX to REAL" == NULL);
1188   assert (code != ENUMERAL_TYPE);
1189   if (code == INTEGER_TYPE)
1190     {
1191       assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1192                && TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)))
1193               || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1194                   && (TYPE_PRECISION (type)
1195                       == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1196       return fold (convert_to_integer (type, e));
1197     }
1198   if (code == POINTER_TYPE)
1199     {
1200       assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1201       return fold (convert_to_pointer (type, e));
1202     }
1203   if (code == REAL_TYPE)
1204     {
1205       assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1206       assert (TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)));
1207       return fold (convert_to_real (type, e));
1208     }
1209   if (code == COMPLEX_TYPE)
1210     {
1211       assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1212       assert (TYPE_PRECISION (TREE_TYPE (type)) >= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1213       return fold (convert_to_complex (type, e));
1214     }
1215   if (code == RECORD_TYPE)
1216     {
1217       assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1218       /* Check that at least the first field name agrees.  */
1219       assert (DECL_NAME (TYPE_FIELDS (type))
1220               == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1221       assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1222               >= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1223       if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1224           == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1225         return e;
1226       return fold (ffecom_convert_to_complex_ (type, e));
1227     }
1228
1229   assert ("conversion to non-scalar type requested" == NULL);
1230   return error_mark_node;
1231 }
1232
1233 /* Handles making a COMPLEX type, either the standard
1234    (but buggy?) gbe way, or the safer (but less elegant?)
1235    f2c way.  */
1236
1237 static tree
1238 ffecom_make_complex_type_ (tree subtype)
1239 {
1240   tree type;
1241   tree realfield;
1242   tree imagfield;
1243
1244   if (ffe_is_emulate_complex ())
1245     {
1246       type = make_node (RECORD_TYPE);
1247       realfield = ffecom_decl_field (type, NULL_TREE, "r", subtype);
1248       imagfield = ffecom_decl_field (type, realfield, "i", subtype);
1249       TYPE_FIELDS (type) = realfield;
1250       layout_type (type);
1251     }
1252   else
1253     {
1254       type = make_node (COMPLEX_TYPE);
1255       TREE_TYPE (type) = subtype;
1256       layout_type (type);
1257     }
1258
1259   return type;
1260 }
1261
1262 /* Chooses either the gbe or the f2c way to build a
1263    complex constant.  */
1264
1265 static tree
1266 ffecom_build_complex_constant_ (tree type, tree realpart, tree imagpart)
1267 {
1268   tree bothparts;
1269
1270   if (ffe_is_emulate_complex ())
1271     {
1272       bothparts = build_tree_list (TYPE_FIELDS (type), realpart);
1273       TREE_CHAIN (bothparts) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), imagpart);
1274       bothparts = build (CONSTRUCTOR, type, NULL_TREE, bothparts);
1275     }
1276   else
1277     {
1278       bothparts = build_complex (type, realpart, imagpart);
1279     }
1280
1281   return bothparts;
1282 }
1283
1284 static tree
1285 ffecom_arglist_expr_ (const char *c, ffebld expr)
1286 {
1287   tree list;
1288   tree *plist = &list;
1289   tree trail = NULL_TREE;       /* Append char length args here. */
1290   tree *ptrail = &trail;
1291   tree length;
1292   ffebld exprh;
1293   tree item;
1294   bool ptr = FALSE;
1295   tree wanted = NULL_TREE;
1296   static const char zed[] = "0";
1297
1298   if (c == NULL)
1299     c = &zed[0];
1300
1301   while (expr != NULL)
1302     {
1303       if (*c != '\0')
1304         {
1305           ptr = FALSE;
1306           if (*c == '&')
1307             {
1308               ptr = TRUE;
1309               ++c;
1310             }
1311           switch (*(c++))
1312             {
1313             case '\0':
1314               ptr = TRUE;
1315               wanted = NULL_TREE;
1316               break;
1317
1318             case 'a':
1319               assert (ptr);
1320               wanted = NULL_TREE;
1321               break;
1322
1323             case 'c':
1324               wanted = ffecom_f2c_complex_type_node;
1325               break;
1326
1327             case 'd':
1328               wanted = ffecom_f2c_doublereal_type_node;
1329               break;
1330
1331             case 'e':
1332               wanted = ffecom_f2c_doublecomplex_type_node;
1333               break;
1334
1335             case 'f':
1336               wanted = ffecom_f2c_real_type_node;
1337               break;
1338
1339             case 'i':
1340               wanted = ffecom_f2c_integer_type_node;
1341               break;
1342
1343             case 'j':
1344               wanted = ffecom_f2c_longint_type_node;
1345               break;
1346
1347             default:
1348               assert ("bad argstring code" == NULL);
1349               wanted = NULL_TREE;
1350               break;
1351             }
1352         }
1353
1354       exprh = ffebld_head (expr);
1355       if (exprh == NULL)
1356         wanted = NULL_TREE;
1357
1358       if ((wanted == NULL_TREE)
1359           || (ptr
1360               && (TYPE_MODE
1361                   (ffecom_tree_type[ffeinfo_basictype (ffebld_info (exprh))]
1362                    [ffeinfo_kindtype (ffebld_info (exprh))])
1363                    == TYPE_MODE (wanted))))
1364         *plist
1365           = build_tree_list (NULL_TREE,
1366                              ffecom_arg_ptr_to_expr (exprh,
1367                                                      &length));
1368       else
1369         {
1370           item = ffecom_arg_expr (exprh, &length);
1371           item = ffecom_convert_widen_ (wanted, item);
1372           if (ptr)
1373             {
1374               item = ffecom_1 (ADDR_EXPR,
1375                                build_pointer_type (TREE_TYPE (item)),
1376                                item);
1377             }
1378           *plist
1379             = build_tree_list (NULL_TREE,
1380                                item);
1381         }
1382
1383       plist = &TREE_CHAIN (*plist);
1384       expr = ffebld_trail (expr);
1385       if (length != NULL_TREE)
1386         {
1387           *ptrail = build_tree_list (NULL_TREE, length);
1388           ptrail = &TREE_CHAIN (*ptrail);
1389         }
1390     }
1391
1392   /* We've run out of args in the call; if the implementation expects
1393      more, supply null pointers for them, which the implementation can
1394      check to see if an arg was omitted. */
1395
1396   while (*c != '\0' && *c != '0')
1397     {
1398       if (*c == '&')
1399         ++c;
1400       else
1401         assert ("missing arg to run-time routine!" == NULL);
1402
1403       switch (*(c++))
1404         {
1405         case '\0':
1406         case 'a':
1407         case 'c':
1408         case 'd':
1409         case 'e':
1410         case 'f':
1411         case 'i':
1412         case 'j':
1413           break;
1414
1415         default:
1416           assert ("bad arg string code" == NULL);
1417           break;
1418         }
1419       *plist
1420         = build_tree_list (NULL_TREE,
1421                            null_pointer_node);
1422       plist = &TREE_CHAIN (*plist);
1423     }
1424
1425   *plist = trail;
1426
1427   return list;
1428 }
1429
1430 static tree
1431 ffecom_widest_expr_type_ (ffebld list)
1432 {
1433   ffebld item;
1434   ffebld widest = NULL;
1435   ffetype type;
1436   ffetype widest_type = NULL;
1437   tree t;
1438
1439   for (; list != NULL; list = ffebld_trail (list))
1440     {
1441       item = ffebld_head (list);
1442       if (item == NULL)
1443         continue;
1444       if ((widest != NULL)
1445           && (ffeinfo_basictype (ffebld_info (item))
1446               != ffeinfo_basictype (ffebld_info (widest))))
1447         continue;
1448       type = ffeinfo_type (ffeinfo_basictype (ffebld_info (item)),
1449                            ffeinfo_kindtype (ffebld_info (item)));
1450       if ((widest == FFEINFO_kindtypeNONE)
1451           || (ffetype_size (type)
1452               > ffetype_size (widest_type)))
1453         {
1454           widest = item;
1455           widest_type = type;
1456         }
1457     }
1458
1459   assert (widest != NULL);
1460   t = ffecom_tree_type[ffeinfo_basictype (ffebld_info (widest))]
1461     [ffeinfo_kindtype (ffebld_info (widest))];
1462   assert (t != NULL_TREE);
1463   return t;
1464 }
1465
1466 /* Check whether a partial overlap between two expressions is possible.
1467
1468    Can *starting* to write a portion of expr1 change the value
1469    computed (perhaps already, *partially*) by expr2?
1470
1471    Currently, this is a concern only for a COMPLEX expr1.  But if it
1472    isn't in COMMON or local EQUIVALENCE, since we don't support
1473    aliasing of arguments, it isn't a concern.  */
1474
1475 static bool
1476 ffecom_possible_partial_overlap_ (ffebld expr1, ffebld expr2 ATTRIBUTE_UNUSED)
1477 {
1478   ffesymbol sym;
1479   ffestorag st;
1480
1481   switch (ffebld_op (expr1))
1482     {
1483     case FFEBLD_opSYMTER:
1484       sym = ffebld_symter (expr1);
1485       break;
1486
1487     case FFEBLD_opARRAYREF:
1488       if (ffebld_op (ffebld_left (expr1)) != FFEBLD_opSYMTER)
1489         return FALSE;
1490       sym = ffebld_symter (ffebld_left (expr1));
1491       break;
1492
1493     default:
1494       return FALSE;
1495     }
1496
1497   if (ffesymbol_where (sym) != FFEINFO_whereCOMMON
1498       && (ffesymbol_where (sym) != FFEINFO_whereLOCAL
1499           || ! (st = ffesymbol_storage (sym))
1500           || ! ffestorag_parent (st)))
1501     return FALSE;
1502
1503   /* It's in COMMON or local EQUIVALENCE.  */
1504
1505   return TRUE;
1506 }
1507
1508 /* Check whether dest and source might overlap.  ffebld versions of these
1509    might or might not be passed, will be NULL if not.
1510
1511    The test is really whether source_tree is modifiable and, if modified,
1512    might overlap destination such that the value(s) in the destination might
1513    change before it is finally modified.  dest_* are the canonized
1514    destination itself.  */
1515
1516 static bool
1517 ffecom_overlap_ (tree dest_decl, tree dest_offset, tree dest_size,
1518                  tree source_tree, ffebld source UNUSED,
1519                  bool scalar_arg)
1520 {
1521   tree source_decl;
1522   tree source_offset;
1523   tree source_size;
1524   tree t;
1525
1526   if (source_tree == NULL_TREE)
1527     return FALSE;
1528
1529   switch (TREE_CODE (source_tree))
1530     {
1531     case ERROR_MARK:
1532     case IDENTIFIER_NODE:
1533     case INTEGER_CST:
1534     case REAL_CST:
1535     case COMPLEX_CST:
1536     case STRING_CST:
1537     case CONST_DECL:
1538     case VAR_DECL:
1539     case RESULT_DECL:
1540     case FIELD_DECL:
1541     case MINUS_EXPR:
1542     case MULT_EXPR:
1543     case TRUNC_DIV_EXPR:
1544     case CEIL_DIV_EXPR:
1545     case FLOOR_DIV_EXPR:
1546     case ROUND_DIV_EXPR:
1547     case TRUNC_MOD_EXPR:
1548     case CEIL_MOD_EXPR:
1549     case FLOOR_MOD_EXPR:
1550     case ROUND_MOD_EXPR:
1551     case RDIV_EXPR:
1552     case EXACT_DIV_EXPR:
1553     case FIX_TRUNC_EXPR:
1554     case FIX_CEIL_EXPR:
1555     case FIX_FLOOR_EXPR:
1556     case FIX_ROUND_EXPR:
1557     case FLOAT_EXPR:
1558     case NEGATE_EXPR:
1559     case MIN_EXPR:
1560     case MAX_EXPR:
1561     case ABS_EXPR:
1562     case FFS_EXPR:
1563     case LSHIFT_EXPR:
1564     case RSHIFT_EXPR:
1565     case LROTATE_EXPR:
1566     case RROTATE_EXPR:
1567     case BIT_IOR_EXPR:
1568     case BIT_XOR_EXPR:
1569     case BIT_AND_EXPR:
1570     case BIT_ANDTC_EXPR:
1571     case BIT_NOT_EXPR:
1572     case TRUTH_ANDIF_EXPR:
1573     case TRUTH_ORIF_EXPR:
1574     case TRUTH_AND_EXPR:
1575     case TRUTH_OR_EXPR:
1576     case TRUTH_XOR_EXPR:
1577     case TRUTH_NOT_EXPR:
1578     case LT_EXPR:
1579     case LE_EXPR:
1580     case GT_EXPR:
1581     case GE_EXPR:
1582     case EQ_EXPR:
1583     case NE_EXPR:
1584     case COMPLEX_EXPR:
1585     case CONJ_EXPR:
1586     case REALPART_EXPR:
1587     case IMAGPART_EXPR:
1588     case LABEL_EXPR:
1589     case COMPONENT_REF:
1590       return FALSE;
1591
1592     case COMPOUND_EXPR:
1593       return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1594                               TREE_OPERAND (source_tree, 1), NULL,
1595                               scalar_arg);
1596
1597     case MODIFY_EXPR:
1598       return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1599                               TREE_OPERAND (source_tree, 0), NULL,
1600                               scalar_arg);
1601
1602     case CONVERT_EXPR:
1603     case NOP_EXPR:
1604     case NON_LVALUE_EXPR:
1605     case PLUS_EXPR:
1606       if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1607         return TRUE;
1608
1609       ffecom_tree_canonize_ptr_ (&source_decl, &source_offset,
1610                                  source_tree);
1611       source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1612       break;
1613
1614     case COND_EXPR:
1615       return
1616         ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1617                          TREE_OPERAND (source_tree, 1), NULL,
1618                          scalar_arg)
1619           || ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1620                               TREE_OPERAND (source_tree, 2), NULL,
1621                               scalar_arg);
1622
1623
1624     case ADDR_EXPR:
1625       ffecom_tree_canonize_ref_ (&source_decl, &source_offset,
1626                                  &source_size,
1627                                  TREE_OPERAND (source_tree, 0));
1628       break;
1629
1630     case PARM_DECL:
1631       if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1632         return TRUE;
1633
1634       source_decl = source_tree;
1635       source_offset = bitsize_zero_node;
1636       source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1637       break;
1638
1639     case SAVE_EXPR:
1640     case REFERENCE_EXPR:
1641     case PREDECREMENT_EXPR:
1642     case PREINCREMENT_EXPR:
1643     case POSTDECREMENT_EXPR:
1644     case POSTINCREMENT_EXPR:
1645     case INDIRECT_REF:
1646     case ARRAY_REF:
1647     case CALL_EXPR:
1648     default:
1649       return TRUE;
1650     }
1651
1652   /* Come here when source_decl, source_offset, and source_size filled
1653      in appropriately.  */
1654
1655   if (source_decl == NULL_TREE)
1656     return FALSE;               /* No decl involved, so no overlap. */
1657
1658   if (source_decl != dest_decl)
1659     return FALSE;               /* Different decl, no overlap. */
1660
1661   if (TREE_CODE (dest_size) == ERROR_MARK)
1662     return TRUE;                /* Assignment into entire assumed-size
1663                                    array?  Shouldn't happen.... */
1664
1665   t = ffecom_2 (LE_EXPR, integer_type_node,
1666                 ffecom_2 (PLUS_EXPR, TREE_TYPE (dest_offset),
1667                           dest_offset,
1668                           convert (TREE_TYPE (dest_offset),
1669                                    dest_size)),
1670                 convert (TREE_TYPE (dest_offset),
1671                          source_offset));
1672
1673   if (integer_onep (t))
1674     return FALSE;               /* Destination precedes source. */
1675
1676   if (!scalar_arg
1677       || (source_size == NULL_TREE)
1678       || (TREE_CODE (source_size) == ERROR_MARK)
1679       || integer_zerop (source_size))
1680     return TRUE;                /* No way to tell if dest follows source. */
1681
1682   t = ffecom_2 (LE_EXPR, integer_type_node,
1683                 ffecom_2 (PLUS_EXPR, TREE_TYPE (source_offset),
1684                           source_offset,
1685                           convert (TREE_TYPE (source_offset),
1686                                    source_size)),
1687                 convert (TREE_TYPE (source_offset),
1688                          dest_offset));
1689
1690   if (integer_onep (t))
1691     return FALSE;               /* Destination follows source. */
1692
1693   return TRUE;          /* Destination and source overlap. */
1694 }
1695
1696 /* Check whether dest might overlap any of a list of arguments or is
1697    in a COMMON area the callee might know about (and thus modify).  */
1698
1699 static bool
1700 ffecom_args_overlapping_ (tree dest_tree, ffebld dest UNUSED,
1701                           tree args, tree callee_commons,
1702                           bool scalar_args)
1703 {
1704   tree arg;
1705   tree dest_decl;
1706   tree dest_offset;
1707   tree dest_size;
1708
1709   ffecom_tree_canonize_ref_ (&dest_decl, &dest_offset, &dest_size,
1710                              dest_tree);
1711
1712   if (dest_decl == NULL_TREE)
1713     return FALSE;               /* Seems unlikely! */
1714
1715   /* If the decl cannot be determined reliably, or if its in COMMON
1716      and the callee isn't known to not futz with COMMON via other
1717      means, overlap might happen.  */
1718
1719   if ((TREE_CODE (dest_decl) == ERROR_MARK)
1720       || ((callee_commons != NULL_TREE)
1721           && TREE_PUBLIC (dest_decl)))
1722     return TRUE;
1723
1724   for (; args != NULL_TREE; args = TREE_CHAIN (args))
1725     {
1726       if (((arg = TREE_VALUE (args)) != NULL_TREE)
1727           && ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1728                               arg, NULL, scalar_args))
1729         return TRUE;
1730     }
1731
1732   return FALSE;
1733 }
1734
1735 /* Build a string for a variable name as used by NAMELIST.  This means that
1736    if we're using the f2c library, we build an uppercase string, since
1737    f2c does this.  */
1738
1739 static tree
1740 ffecom_build_f2c_string_ (int i, const char *s)
1741 {
1742   if (!ffe_is_f2c_library ())
1743     return build_string (i, s);
1744
1745   {
1746     char *tmp;
1747     const char *p;
1748     char *q;
1749     char space[34];
1750     tree t;
1751
1752     if (((size_t) i) > ARRAY_SIZE (space))
1753       tmp = malloc_new_ks (malloc_pool_image (), "f2c_string", i);
1754     else
1755       tmp = &space[0];
1756
1757     for (p = s, q = tmp; *p != '\0'; ++p, ++q)
1758       *q = TOUPPER (*p);
1759     *q = '\0';
1760
1761     t = build_string (i, tmp);
1762
1763     if (((size_t) i) > ARRAY_SIZE (space))
1764       malloc_kill_ks (malloc_pool_image (), tmp, i);
1765
1766     return t;
1767   }
1768 }
1769
1770 /* Returns CALL_EXPR or equivalent with given type (pass NULL_TREE for
1771    type to just get whatever the function returns), handling the
1772    f2c value-returning convention, if required, by prepending
1773    to the arglist a pointer to a temporary to receive the return value.  */
1774
1775 static tree
1776 ffecom_call_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1777               tree type, tree args, tree dest_tree,
1778               ffebld dest, bool *dest_used, tree callee_commons,
1779               bool scalar_args, tree hook)
1780 {
1781   tree item;
1782   tree tempvar;
1783
1784   if (dest_used != NULL)
1785     *dest_used = FALSE;
1786
1787   if (is_f2c_complex)
1788     {
1789       if ((dest_used == NULL)
1790           || (dest == NULL)
1791           || (ffeinfo_basictype (ffebld_info (dest))
1792               != FFEINFO_basictypeCOMPLEX)
1793           || (ffeinfo_kindtype (ffebld_info (dest)) != kt)
1794           || ((type != NULL_TREE) && (TREE_TYPE (dest_tree) != type))
1795           || ffecom_args_overlapping_ (dest_tree, dest, args,
1796                                        callee_commons,
1797                                        scalar_args))
1798         {
1799 #ifdef HOHO
1800           tempvar = ffecom_make_tempvar (ffecom_tree_type
1801                                          [FFEINFO_basictypeCOMPLEX][kt],
1802                                          FFETARGET_charactersizeNONE,
1803                                          -1);
1804 #else
1805           tempvar = hook;
1806           assert (tempvar);
1807 #endif
1808         }
1809       else
1810         {
1811           *dest_used = TRUE;
1812           tempvar = dest_tree;
1813           type = NULL_TREE;
1814         }
1815
1816       item
1817         = build_tree_list (NULL_TREE,
1818                            ffecom_1 (ADDR_EXPR,
1819                                      build_pointer_type (TREE_TYPE (tempvar)),
1820                                      tempvar));
1821       TREE_CHAIN (item) = args;
1822
1823       item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1824                         item, NULL_TREE);
1825
1826       if (tempvar != dest_tree)
1827         item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item, tempvar);
1828     }
1829   else
1830     item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1831                       args, NULL_TREE);
1832
1833   if ((type != NULL_TREE) && (TREE_TYPE (item) != type))
1834     item = ffecom_convert_narrow_ (type, item);
1835
1836   return item;
1837 }
1838
1839 /* Given two arguments, transform them and make a call to the given
1840    function via ffecom_call_.  */
1841
1842 static tree
1843 ffecom_call_binop_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1844                     tree type, ffebld left, ffebld right,
1845                     tree dest_tree, ffebld dest, bool *dest_used,
1846                     tree callee_commons, bool scalar_args, bool ref, tree hook)
1847 {
1848   tree left_tree;
1849   tree right_tree;
1850   tree left_length;
1851   tree right_length;
1852
1853   if (ref)
1854     {
1855       /* Pass arguments by reference.  */
1856       left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
1857       right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
1858     }
1859   else
1860     {
1861       /* Pass arguments by value.  */
1862       left_tree = ffecom_arg_expr (left, &left_length);
1863       right_tree = ffecom_arg_expr (right, &right_length);
1864     }
1865
1866
1867   left_tree = build_tree_list (NULL_TREE, left_tree);
1868   right_tree = build_tree_list (NULL_TREE, right_tree);
1869   TREE_CHAIN (left_tree) = right_tree;
1870
1871   if (left_length != NULL_TREE)
1872     {
1873       left_length = build_tree_list (NULL_TREE, left_length);
1874       TREE_CHAIN (right_tree) = left_length;
1875     }
1876
1877   if (right_length != NULL_TREE)
1878     {
1879       right_length = build_tree_list (NULL_TREE, right_length);
1880       if (left_length != NULL_TREE)
1881         TREE_CHAIN (left_length) = right_length;
1882       else
1883         TREE_CHAIN (right_tree) = right_length;
1884     }
1885
1886   return ffecom_call_ (fn, kt, is_f2c_complex, type, left_tree,
1887                        dest_tree, dest, dest_used, callee_commons,
1888                        scalar_args, hook);
1889 }
1890
1891 /* Return ptr/length args for char subexpression
1892
1893    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
1894    subexpressions by constructing the appropriate trees for the ptr-to-
1895    character-text and length-of-character-text arguments in a calling
1896    sequence.
1897
1898    Note that if with_null is TRUE, and the expression is an opCONTER,
1899    a null byte is appended to the string.  */
1900
1901 static void
1902 ffecom_char_args_x_ (tree *xitem, tree *length, ffebld expr, bool with_null)
1903 {
1904   tree item;
1905   tree high;
1906   ffetargetCharacter1 val;
1907   ffetargetCharacterSize newlen;
1908
1909   switch (ffebld_op (expr))
1910     {
1911     case FFEBLD_opCONTER:
1912       val = ffebld_constant_character1 (ffebld_conter (expr));
1913       newlen = ffetarget_length_character1 (val);
1914       if (with_null)
1915         {
1916           /* Begin FFETARGET-NULL-KLUDGE.  */
1917           if (newlen != 0)
1918             ++newlen;
1919         }
1920       *length = build_int_2 (newlen, 0);
1921       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
1922       high = build_int_2 (newlen, 0);
1923       TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
1924       item = build_string (newlen,
1925                            ffetarget_text_character1 (val));
1926       /* End FFETARGET-NULL-KLUDGE.  */
1927       TREE_TYPE (item)
1928         = build_type_variant
1929           (build_array_type
1930            (char_type_node,
1931             build_range_type
1932             (ffecom_f2c_ftnlen_type_node,
1933              ffecom_f2c_ftnlen_one_node,
1934              high)),
1935            1, 0);
1936       TREE_CONSTANT (item) = 1;
1937       TREE_STATIC (item) = 1;
1938       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
1939                        item);
1940       break;
1941
1942     case FFEBLD_opSYMTER:
1943       {
1944         ffesymbol s = ffebld_symter (expr);
1945
1946         item = ffesymbol_hook (s).decl_tree;
1947         if (item == NULL_TREE)
1948           {
1949             s = ffecom_sym_transform_ (s);
1950             item = ffesymbol_hook (s).decl_tree;
1951           }
1952         if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
1953           {
1954             if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
1955               *length = ffesymbol_hook (s).length_tree;
1956             else
1957               {
1958                 *length = build_int_2 (ffesymbol_size (s), 0);
1959                 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
1960               }
1961           }
1962         else if (item == error_mark_node)
1963           *length = error_mark_node;
1964         else
1965           /* FFEINFO_kindFUNCTION.  */
1966           *length = NULL_TREE;
1967         if (!ffesymbol_hook (s).addr
1968             && (item != error_mark_node))
1969           item = ffecom_1 (ADDR_EXPR,
1970                            build_pointer_type (TREE_TYPE (item)),
1971                            item);
1972       }
1973       break;
1974
1975     case FFEBLD_opARRAYREF:
1976       {
1977         ffecom_char_args_ (&item, length, ffebld_left (expr));
1978
1979         if (item == error_mark_node || *length == error_mark_node)
1980           {
1981             item = *length = error_mark_node;
1982             break;
1983           }
1984
1985         item = ffecom_arrayref_ (item, expr, 1);
1986       }
1987       break;
1988
1989     case FFEBLD_opSUBSTR:
1990       {
1991         ffebld start;
1992         ffebld end;
1993         ffebld thing = ffebld_right (expr);
1994         tree start_tree;
1995         tree end_tree;
1996         const char *char_name;
1997         ffebld left_symter;
1998         tree array;
1999
2000         assert (ffebld_op (thing) == FFEBLD_opITEM);
2001         start = ffebld_head (thing);
2002         thing = ffebld_trail (thing);
2003         assert (ffebld_trail (thing) == NULL);
2004         end = ffebld_head (thing);
2005
2006         /* Determine name for pretty-printing range-check errors.  */
2007         for (left_symter = ffebld_left (expr);
2008              left_symter && ffebld_op (left_symter) == FFEBLD_opARRAYREF;
2009              left_symter = ffebld_left (left_symter))
2010           ;
2011         if (ffebld_op (left_symter) == FFEBLD_opSYMTER)
2012           char_name = ffesymbol_text (ffebld_symter (left_symter));
2013         else
2014           char_name = "[expr?]";
2015
2016         ffecom_char_args_ (&item, length, ffebld_left (expr));
2017
2018         if (item == error_mark_node || *length == error_mark_node)
2019           {
2020             item = *length = error_mark_node;
2021             break;
2022           }
2023
2024         array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
2025
2026         /* ~~~~Handle INTEGER*8 start/end, a la FFEBLD_opARRAYREF.  */
2027
2028         if (start == NULL)
2029           {
2030             if (end == NULL)
2031               ;
2032             else
2033               {
2034                 end_tree = ffecom_expr (end);
2035                 if (flag_bounds_check)
2036                   end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2037                                                       char_name);
2038                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2039                                     end_tree);
2040
2041                 if (end_tree == error_mark_node)
2042                   {
2043                     item = *length = error_mark_node;
2044                     break;
2045                   }
2046
2047                 *length = end_tree;
2048               }
2049           }
2050         else
2051           {
2052             start_tree = ffecom_expr (start);
2053             if (flag_bounds_check)
2054               start_tree = ffecom_subscript_check_ (array, start_tree, 0, 0,
2055                                                     char_name);
2056             start_tree = convert (ffecom_f2c_ftnlen_type_node,
2057                                   start_tree);
2058
2059             if (start_tree == error_mark_node)
2060               {
2061                 item = *length = error_mark_node;
2062                 break;
2063               }
2064
2065             start_tree = ffecom_save_tree (start_tree);
2066
2067             item = ffecom_2 (PLUS_EXPR, TREE_TYPE (item),
2068                              item,
2069                              ffecom_2 (MINUS_EXPR,
2070                                        TREE_TYPE (start_tree),
2071                                        start_tree,
2072                                        ffecom_f2c_ftnlen_one_node));
2073
2074             if (end == NULL)
2075               {
2076                 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2077                                     ffecom_f2c_ftnlen_one_node,
2078                                     ffecom_2 (MINUS_EXPR,
2079                                               ffecom_f2c_ftnlen_type_node,
2080                                               *length,
2081                                               start_tree));
2082               }
2083             else
2084               {
2085                 end_tree = ffecom_expr (end);
2086                 if (flag_bounds_check)
2087                   end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2088                                                       char_name);
2089                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2090                                     end_tree);
2091
2092                 if (end_tree == error_mark_node)
2093                   {
2094                     item = *length = error_mark_node;
2095                     break;
2096                   }
2097
2098                 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2099                                     ffecom_f2c_ftnlen_one_node,
2100                                     ffecom_2 (MINUS_EXPR,
2101                                               ffecom_f2c_ftnlen_type_node,
2102                                               end_tree, start_tree));
2103               }
2104           }
2105       }
2106       break;
2107
2108     case FFEBLD_opFUNCREF:
2109       {
2110         ffesymbol s = ffebld_symter (ffebld_left (expr));
2111         tree tempvar;
2112         tree args;
2113         ffetargetCharacterSize size = ffeinfo_size (ffebld_info (expr));
2114         ffecomGfrt ix;
2115
2116         if (size == FFETARGET_charactersizeNONE)
2117           /* ~~Kludge alert!  This should someday be fixed. */
2118           size = 24;
2119
2120         *length = build_int_2 (size, 0);
2121         TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2122
2123         if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
2124             == FFEINFO_whereINTRINSIC)
2125           {
2126             if (size == 1)
2127               {
2128                 /* Invocation of an intrinsic returning CHARACTER*1.  */
2129                 item = ffecom_expr_intrinsic_ (expr, NULL_TREE,
2130                                                NULL, NULL);
2131                 break;
2132               }
2133             ix = ffeintrin_gfrt_direct (ffebld_symter_implementation (ffebld_left (expr)));
2134             assert (ix != FFECOM_gfrt);
2135             item = ffecom_gfrt_tree_ (ix);
2136           }
2137         else
2138           {
2139             ix = FFECOM_gfrt;
2140             item = ffesymbol_hook (s).decl_tree;
2141             if (item == NULL_TREE)
2142               {
2143                 s = ffecom_sym_transform_ (s);
2144                 item = ffesymbol_hook (s).decl_tree;
2145               }
2146             if (item == error_mark_node)
2147               {
2148                 item = *length = error_mark_node;
2149                 break;
2150               }
2151
2152             if (!ffesymbol_hook (s).addr)
2153               item = ffecom_1_fn (item);
2154           }
2155
2156 #ifdef HOHO
2157         tempvar = ffecom_push_tempvar (char_type_node, size, -1, TRUE);
2158 #else
2159         tempvar = ffebld_nonter_hook (expr);
2160         assert (tempvar);
2161 #endif
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 #ifdef HOHO
2214           tempvar = ffecom_make_tempvar (char_type_node,
2215                                          ffebld_size (expr), -1);
2216 #else
2217           tempvar = ffebld_nonter_hook (expr);
2218           assert (tempvar);
2219 #endif
2220           tempvar = ffecom_1 (ADDR_EXPR,
2221                               build_pointer_type (TREE_TYPE (tempvar)),
2222                               tempvar);
2223
2224           newlen = build_int_2 (ffebld_size (expr), 0);
2225           TREE_TYPE (newlen) = ffecom_f2c_ftnlen_type_node;
2226
2227           args = build_tree_list (NULL_TREE, tempvar);
2228           TREE_CHAIN (args) = build_tree_list (NULL_TREE, item);
2229           TREE_CHAIN (TREE_CHAIN (args)) = build_tree_list (NULL_TREE, newlen);
2230           TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (args)))
2231             = build_tree_list (NULL_TREE, *length);
2232
2233           item = ffecom_call_gfrt (FFECOM_gfrtCOPY, args, NULL_TREE);
2234           TREE_SIDE_EFFECTS (item) = 1;
2235           item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), fold (item),
2236                            tempvar);
2237           *length = newlen;
2238         }
2239       else
2240         {                       /* Just truncate the length. */
2241           *length = build_int_2 (ffebld_size (expr), 0);
2242           TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2243         }
2244       break;
2245
2246     default:
2247       assert ("bad op for single char arg expr" == NULL);
2248       item = NULL_TREE;
2249       break;
2250     }
2251
2252   *xitem = item;
2253 }
2254
2255 /* Check the size of the type to be sure it doesn't overflow the
2256    "portable" capacities of the compiler back end.  `dummy' types
2257    can generally overflow the normal sizes as long as the computations
2258    themselves don't overflow.  A particular target of the back end
2259    must still enforce its size requirements, though, and the back
2260    end takes care of this in stor-layout.c.  */
2261
2262 static tree
2263 ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy)
2264 {
2265   if (TREE_CODE (type) == ERROR_MARK)
2266     return type;
2267
2268   if (TYPE_SIZE (type) == NULL_TREE)
2269     return type;
2270
2271   if (TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST)
2272     return type;
2273
2274   /* An array is too large if size is negative or the type_size overflows
2275      or its "upper half" is larger than 3 (which would make the signed
2276      byte size and offset computations overflow).  */
2277
2278   if ((tree_int_cst_sgn (TYPE_SIZE (type)) < 0)
2279       || (!dummy && (TREE_INT_CST_HIGH (TYPE_SIZE (type)) > 3
2280                      || TREE_OVERFLOW (TYPE_SIZE (type)))))
2281     {
2282       ffebad_start (FFEBAD_ARRAY_LARGE);
2283       ffebad_string (ffesymbol_text (s));
2284       ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s));
2285       ffebad_finish ();
2286
2287       return error_mark_node;
2288     }
2289
2290   return type;
2291 }
2292
2293 /* Builds a length argument (PARM_DECL).  Also wraps type in an array type
2294    where the dimension info is (1:size) where <size> is ffesymbol_size(s) if
2295    known, length_arg if not known (FFETARGET_charactersizeNONE).  */
2296
2297 static tree
2298 ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s)
2299 {
2300   ffetargetCharacterSize sz = ffesymbol_size (s);
2301   tree highval;
2302   tree tlen;
2303   tree type = *xtype;
2304
2305   if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
2306     tlen = NULL_TREE;           /* A statement function, no length passed. */
2307   else
2308     {
2309       if (ffesymbol_where (s) == FFEINFO_whereDUMMY)
2310         tlen = ffecom_get_invented_identifier ("__g77_length_%s",
2311                                                ffesymbol_text (s));
2312       else
2313         tlen = ffecom_get_invented_identifier ("__g77_%s", "length");
2314       tlen = build_decl (PARM_DECL, tlen, ffecom_f2c_ftnlen_type_node);
2315       DECL_ARTIFICIAL (tlen) = 1;
2316     }
2317
2318   if (sz == FFETARGET_charactersizeNONE)
2319     {
2320       assert (tlen != NULL_TREE);
2321       highval = variable_size (tlen);
2322     }
2323   else
2324     {
2325       highval = build_int_2 (sz, 0);
2326       TREE_TYPE (highval) = ffecom_f2c_ftnlen_type_node;
2327     }
2328
2329   type = build_array_type (type,
2330                            build_range_type (ffecom_f2c_ftnlen_type_node,
2331                                              ffecom_f2c_ftnlen_one_node,
2332                                              highval));
2333
2334   *xtype = type;
2335   return tlen;
2336 }
2337
2338 /* ffecom_concat_list_gather_ -- Gather list of concatenated string exprs
2339
2340    ffecomConcatList_ catlist;
2341    ffebld expr;  // expr of CHARACTER basictype.
2342    ffetargetCharacterSize max;  // max chars to gather or _...NONE if no max
2343    catlist = ffecom_concat_list_gather_(catlist,expr,max);
2344
2345    Scans expr for character subexpressions, updates and returns catlist
2346    accordingly.  */
2347
2348 static ffecomConcatList_
2349 ffecom_concat_list_gather_ (ffecomConcatList_ catlist, ffebld expr,
2350                             ffetargetCharacterSize max)
2351 {
2352   ffetargetCharacterSize sz;
2353
2354  recurse:
2355
2356   if (expr == NULL)
2357     return catlist;
2358
2359   if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen >= max))
2360     return catlist;             /* Don't append any more items. */
2361
2362   switch (ffebld_op (expr))
2363     {
2364     case FFEBLD_opCONTER:
2365     case FFEBLD_opSYMTER:
2366     case FFEBLD_opARRAYREF:
2367     case FFEBLD_opFUNCREF:
2368     case FFEBLD_opSUBSTR:
2369     case FFEBLD_opCONVERT:      /* Callers should strip this off beforehand
2370                                    if they don't need to preserve it. */
2371       if (catlist.count == catlist.max)
2372         {                       /* Make a (larger) list. */
2373           ffebld *newx;
2374           int newmax;
2375
2376           newmax = (catlist.max == 0) ? 8 : catlist.max * 2;
2377           newx = malloc_new_ks (malloc_pool_image (), "catlist",
2378                                 newmax * sizeof (newx[0]));
2379           if (catlist.max != 0)
2380             {
2381               memcpy (newx, catlist.exprs, catlist.max * sizeof (newx[0]));
2382               malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2383                               catlist.max * sizeof (newx[0]));
2384             }
2385           catlist.max = newmax;
2386           catlist.exprs = newx;
2387         }
2388       if ((sz = ffebld_size_known (expr)) != FFETARGET_charactersizeNONE)
2389         catlist.minlen += sz;
2390       else
2391         ++catlist.minlen;       /* Not true for F90; can be 0 length. */
2392       if ((sz = ffebld_size_max (expr)) == FFETARGET_charactersizeNONE)
2393         catlist.maxlen = sz;
2394       else
2395         catlist.maxlen += sz;
2396       if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen > max))
2397         {                       /* This item overlaps (or is beyond) the end
2398                                    of the destination. */
2399           switch (ffebld_op (expr))
2400             {
2401             case FFEBLD_opCONTER:
2402             case FFEBLD_opSYMTER:
2403             case FFEBLD_opARRAYREF:
2404             case FFEBLD_opFUNCREF:
2405             case FFEBLD_opSUBSTR:
2406               /* ~~Do useful truncations here. */
2407               break;
2408
2409             default:
2410               assert ("op changed or inconsistent switches!" == NULL);
2411               break;
2412             }
2413         }
2414       catlist.exprs[catlist.count++] = expr;
2415       return catlist;
2416
2417     case FFEBLD_opPAREN:
2418       expr = ffebld_left (expr);
2419       goto recurse;             /* :::::::::::::::::::: */
2420
2421     case FFEBLD_opCONCATENATE:
2422       catlist = ffecom_concat_list_gather_ (catlist, ffebld_left (expr), max);
2423       expr = ffebld_right (expr);
2424       goto recurse;             /* :::::::::::::::::::: */
2425
2426 #if 0                           /* Breaks passing small actual arg to larger
2427                                    dummy arg of sfunc */
2428     case FFEBLD_opCONVERT:
2429       expr = ffebld_left (expr);
2430       {
2431         ffetargetCharacterSize cmax;
2432
2433         cmax = catlist.len + ffebld_size_known (expr);
2434
2435         if ((max == FFETARGET_charactersizeNONE) || (max > cmax))
2436           max = cmax;
2437       }
2438       goto recurse;             /* :::::::::::::::::::: */
2439 #endif
2440
2441     case FFEBLD_opANY:
2442       return catlist;
2443
2444     default:
2445       assert ("bad op in _gather_" == NULL);
2446       return catlist;
2447     }
2448 }
2449
2450 /* ffecom_concat_list_kill_ -- Kill list of concatenated string exprs
2451
2452    ffecomConcatList_ catlist;
2453    ffecom_concat_list_kill_(catlist);
2454
2455    Anything allocated within the list info is deallocated.  */
2456
2457 static void
2458 ffecom_concat_list_kill_ (ffecomConcatList_ catlist)
2459 {
2460   if (catlist.max != 0)
2461     malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2462                     catlist.max * sizeof (catlist.exprs[0]));
2463 }
2464
2465 /* Make list of concatenated string exprs.
2466
2467    Returns a flattened list of concatenated subexpressions given a
2468    tree of such expressions.  */
2469
2470 static ffecomConcatList_
2471 ffecom_concat_list_new_ (ffebld expr, ffetargetCharacterSize max)
2472 {
2473   ffecomConcatList_ catlist;
2474
2475   catlist.maxlen = catlist.minlen = catlist.max = catlist.count = 0;
2476   return ffecom_concat_list_gather_ (catlist, expr, max);
2477 }
2478
2479 /* Provide some kind of useful info on member of aggregate area,
2480    since current g77/gcc technology does not provide debug info
2481    on these members.  */
2482
2483 static void
2484 ffecom_debug_kludge_ (tree aggr, const char *aggr_type, ffesymbol member,
2485                       tree member_type UNUSED, ffetargetOffset offset)
2486 {
2487   tree value;
2488   tree decl;
2489   int len;
2490   char *buff;
2491   char space[120];
2492 #if 0
2493   tree type_id;
2494
2495   for (type_id = member_type;
2496        TREE_CODE (type_id) != IDENTIFIER_NODE;
2497        )
2498     {
2499       switch (TREE_CODE (type_id))
2500         {
2501         case INTEGER_TYPE:
2502         case REAL_TYPE:
2503           type_id = TYPE_NAME (type_id);
2504           break;
2505
2506         case ARRAY_TYPE:
2507         case COMPLEX_TYPE:
2508           type_id = TREE_TYPE (type_id);
2509           break;
2510
2511         default:
2512           assert ("no IDENTIFIER_NODE for type!" == NULL);
2513           type_id = error_mark_node;
2514           break;
2515         }
2516     }
2517 #endif
2518
2519   if (ffecom_transform_only_dummies_
2520       || !ffe_is_debug_kludge ())
2521     return;     /* Can't do this yet, maybe later. */
2522
2523   len = 60
2524     + strlen (aggr_type)
2525     + IDENTIFIER_LENGTH (DECL_NAME (aggr));
2526 #if 0
2527     + IDENTIFIER_LENGTH (type_id);
2528 #endif
2529
2530   if (((size_t) len) >= ARRAY_SIZE (space))
2531     buff = malloc_new_ks (malloc_pool_image (), "debug_kludge", len + 1);
2532   else
2533     buff = &space[0];
2534
2535   sprintf (&buff[0], "At (%s) `%s' plus %ld bytes",
2536            aggr_type,
2537            IDENTIFIER_POINTER (DECL_NAME (aggr)),
2538            (long int) offset);
2539
2540   value = build_string (len, buff);
2541   TREE_TYPE (value)
2542     = build_type_variant (build_array_type (char_type_node,
2543                                             build_range_type
2544                                             (integer_type_node,
2545                                              integer_one_node,
2546                                              build_int_2 (strlen (buff), 0))),
2547                           1, 0);
2548   decl = build_decl (VAR_DECL,
2549                      ffecom_get_identifier_ (ffesymbol_text (member)),
2550                      TREE_TYPE (value));
2551   TREE_CONSTANT (decl) = 1;
2552   TREE_STATIC (decl) = 1;
2553   DECL_INITIAL (decl) = error_mark_node;
2554   DECL_IN_SYSTEM_HEADER (decl) = 1;     /* Don't let -Wunused complain. */
2555   decl = start_decl (decl, FALSE);
2556   finish_decl (decl, value, FALSE);
2557
2558   if (buff != &space[0])
2559     malloc_kill_ks (malloc_pool_image (), buff, len + 1);
2560 }
2561
2562 /* ffecom_do_entry_ -- Do compilation of a particular entrypoint
2563
2564    ffesymbol fn;  // the SUBROUTINE, FUNCTION, or ENTRY symbol itself
2565    int i;  // entry# for this entrypoint (used by master fn)
2566    ffecom_do_entrypoint_(s,i);
2567
2568    Makes a public entry point that calls our private master fn (already
2569    compiled).  */
2570
2571 static void
2572 ffecom_do_entry_ (ffesymbol fn, int entrynum)
2573 {
2574   ffebld item;
2575   tree type;                    /* Type of function. */
2576   tree multi_retval;            /* Var holding return value (union). */
2577   tree result;                  /* Var holding result. */
2578   ffeinfoBasictype bt;
2579   ffeinfoKindtype kt;
2580   ffeglobal g;
2581   ffeglobalType gt;
2582   bool charfunc;                /* All entry points return same type
2583                                    CHARACTER. */
2584   bool cmplxfunc;               /* Use f2c way of returning COMPLEX. */
2585   bool multi;                   /* Master fn has multiple return types. */
2586   bool altreturning = FALSE;    /* This entry point has alternate returns. */
2587   int old_lineno = lineno;
2588   const char *old_input_filename = input_filename;
2589
2590   input_filename = ffesymbol_where_filename (fn);
2591   lineno = ffesymbol_where_filelinenum (fn);
2592
2593   ffecom_doing_entry_ = TRUE;   /* Don't bother with array dimensions. */
2594
2595   switch (ffecom_primary_entry_kind_)
2596     {
2597     case FFEINFO_kindFUNCTION:
2598
2599       /* Determine actual return type for function. */
2600
2601       gt = FFEGLOBAL_typeFUNC;
2602       bt = ffesymbol_basictype (fn);
2603       kt = ffesymbol_kindtype (fn);
2604       if (bt == FFEINFO_basictypeNONE)
2605         {
2606           ffeimplic_establish_symbol (fn);
2607           if (ffesymbol_funcresult (fn) != NULL)
2608             ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
2609           bt = ffesymbol_basictype (fn);
2610           kt = ffesymbol_kindtype (fn);
2611         }
2612
2613       if (bt == FFEINFO_basictypeCHARACTER)
2614         charfunc = TRUE, cmplxfunc = FALSE;
2615       else if ((bt == FFEINFO_basictypeCOMPLEX)
2616                && ffesymbol_is_f2c (fn))
2617         charfunc = FALSE, cmplxfunc = TRUE;
2618       else
2619         charfunc = cmplxfunc = FALSE;
2620
2621       if (charfunc)
2622         type = ffecom_tree_fun_type_void;
2623       else if (ffesymbol_is_f2c (fn))
2624         type = ffecom_tree_fun_type[bt][kt];
2625       else
2626         type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
2627
2628       if ((type == NULL_TREE)
2629           || (TREE_TYPE (type) == NULL_TREE))
2630         type = ffecom_tree_fun_type_void;       /* _sym_exec_transition. */
2631
2632       multi = (ffecom_master_bt_ == FFEINFO_basictypeNONE);
2633       break;
2634
2635     case FFEINFO_kindSUBROUTINE:
2636       gt = FFEGLOBAL_typeSUBR;
2637       bt = FFEINFO_basictypeNONE;
2638       kt = FFEINFO_kindtypeNONE;
2639       if (ffecom_is_altreturning_)
2640         {                       /* Am _I_ altreturning? */
2641           for (item = ffesymbol_dummyargs (fn);
2642                item != NULL;
2643                item = ffebld_trail (item))
2644             {
2645               if (ffebld_op (ffebld_head (item)) == FFEBLD_opSTAR)
2646                 {
2647                   altreturning = TRUE;
2648                   break;
2649                 }
2650             }
2651           if (altreturning)
2652             type = ffecom_tree_subr_type;
2653           else
2654             type = ffecom_tree_fun_type_void;
2655         }
2656       else
2657         type = ffecom_tree_fun_type_void;
2658       charfunc = FALSE;
2659       cmplxfunc = FALSE;
2660       multi = FALSE;
2661       break;
2662
2663     default:
2664       assert ("say what??" == NULL);
2665       /* Fall through. */
2666     case FFEINFO_kindANY:
2667       gt = FFEGLOBAL_typeANY;
2668       bt = FFEINFO_basictypeNONE;
2669       kt = FFEINFO_kindtypeNONE;
2670       type = error_mark_node;
2671       charfunc = FALSE;
2672       cmplxfunc = FALSE;
2673       multi = FALSE;
2674       break;
2675     }
2676
2677   /* build_decl uses the current lineno and input_filename to set the decl
2678      source info.  So, I've putzed with ffestd and ffeste code to update that
2679      source info to point to the appropriate statement just before calling
2680      ffecom_do_entrypoint (which calls this fn).  */
2681
2682   start_function (ffecom_get_external_identifier_ (fn),
2683                   type,
2684                   0,            /* nested/inline */
2685                   1);           /* TREE_PUBLIC */
2686
2687   if (((g = ffesymbol_global (fn)) != NULL)
2688       && ((ffeglobal_type (g) == gt)
2689           || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
2690     {
2691       ffeglobal_set_hook (g, current_function_decl);
2692     }
2693
2694   /* Reset args in master arg list so they get retransitioned. */
2695
2696   for (item = ffecom_master_arglist_;
2697        item != NULL;
2698        item = ffebld_trail (item))
2699     {
2700       ffebld arg;
2701       ffesymbol s;
2702
2703       arg = ffebld_head (item);
2704       if (ffebld_op (arg) != FFEBLD_opSYMTER)
2705         continue;               /* Alternate return or some such thing. */
2706       s = ffebld_symter (arg);
2707       ffesymbol_hook (s).decl_tree = NULL_TREE;
2708       ffesymbol_hook (s).length_tree = NULL_TREE;
2709     }
2710
2711   /* Build dummy arg list for this entry point. */
2712
2713   if (charfunc || cmplxfunc)
2714     {                           /* Prepend arg for where result goes. */
2715       tree type;
2716       tree length;
2717
2718       if (charfunc)
2719         type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
2720       else
2721         type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
2722
2723       result = ffecom_get_invented_identifier ("__g77_%s", "result");
2724
2725       /* Make length arg _and_ enhance type info for CHAR arg itself.  */
2726
2727       if (charfunc)
2728         length = ffecom_char_enhance_arg_ (&type, fn);
2729       else
2730         length = NULL_TREE;     /* Not ref'd if !charfunc. */
2731
2732       type = build_pointer_type (type);
2733       result = build_decl (PARM_DECL, result, type);
2734
2735       push_parm_decl (result);
2736       ffecom_func_result_ = result;
2737
2738       if (charfunc)
2739         {
2740           push_parm_decl (length);
2741           ffecom_func_length_ = length;
2742         }
2743     }
2744   else
2745     result = DECL_RESULT (current_function_decl);
2746
2747   ffecom_push_dummy_decls_ (ffesymbol_dummyargs (fn), FALSE);
2748
2749   store_parm_decls (0);
2750
2751   ffecom_start_compstmt ();
2752   /* Disallow temp vars at this level.  */
2753   current_binding_level->prep_state = 2;
2754
2755   /* Make local var to hold return type for multi-type master fn. */
2756
2757   if (multi)
2758     {
2759       multi_retval = ffecom_get_invented_identifier ("__g77_%s",
2760                                                      "multi_retval");
2761       multi_retval = build_decl (VAR_DECL, multi_retval,
2762                                  ffecom_multi_type_node_);
2763       multi_retval = start_decl (multi_retval, FALSE);
2764       finish_decl (multi_retval, NULL_TREE, FALSE);
2765     }
2766   else
2767     multi_retval = NULL_TREE;   /* Not actually ref'd if !multi. */
2768
2769   /* Here we emit the actual code for the entry point. */
2770
2771   {
2772     ffebld list;
2773     ffebld arg;
2774     ffesymbol s;
2775     tree arglist = NULL_TREE;
2776     tree *plist = &arglist;
2777     tree prepend;
2778     tree call;
2779     tree actarg;
2780     tree master_fn;
2781
2782     /* Prepare actual arg list based on master arg list. */
2783
2784     for (list = ffecom_master_arglist_;
2785          list != NULL;
2786          list = ffebld_trail (list))
2787       {
2788         arg = ffebld_head (list);
2789         if (ffebld_op (arg) != FFEBLD_opSYMTER)
2790           continue;
2791         s = ffebld_symter (arg);
2792         if (ffesymbol_hook (s).decl_tree == NULL_TREE
2793             || ffesymbol_hook (s).decl_tree == error_mark_node)
2794           actarg = null_pointer_node;   /* We don't have this arg. */
2795         else
2796           actarg = ffesymbol_hook (s).decl_tree;
2797         *plist = build_tree_list (NULL_TREE, actarg);
2798         plist = &TREE_CHAIN (*plist);
2799       }
2800
2801     /* This code appends the length arguments for character
2802        variables/arrays.  */
2803
2804     for (list = ffecom_master_arglist_;
2805          list != NULL;
2806          list = ffebld_trail (list))
2807       {
2808         arg = ffebld_head (list);
2809         if (ffebld_op (arg) != FFEBLD_opSYMTER)
2810           continue;
2811         s = ffebld_symter (arg);
2812         if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
2813           continue;             /* Only looking for CHARACTER arguments. */
2814         if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
2815           continue;             /* Only looking for variables and arrays. */
2816         if (ffesymbol_hook (s).length_tree == NULL_TREE
2817             || ffesymbol_hook (s).length_tree == error_mark_node)
2818           actarg = ffecom_f2c_ftnlen_zero_node; /* We don't have this arg. */
2819         else
2820           actarg = ffesymbol_hook (s).length_tree;
2821         *plist = build_tree_list (NULL_TREE, actarg);
2822         plist = &TREE_CHAIN (*plist);
2823       }
2824
2825     /* Prepend character-value return info to actual arg list. */
2826
2827     if (charfunc)
2828       {
2829         prepend = build_tree_list (NULL_TREE, ffecom_func_result_);
2830         TREE_CHAIN (prepend)
2831           = build_tree_list (NULL_TREE, ffecom_func_length_);
2832         TREE_CHAIN (TREE_CHAIN (prepend)) = arglist;
2833         arglist = prepend;
2834       }
2835
2836     /* Prepend multi-type return value to actual arg list. */
2837
2838     if (multi)
2839       {
2840         prepend
2841           = build_tree_list (NULL_TREE,
2842                              ffecom_1 (ADDR_EXPR,
2843                               build_pointer_type (TREE_TYPE (multi_retval)),
2844                                        multi_retval));
2845         TREE_CHAIN (prepend) = arglist;
2846         arglist = prepend;
2847       }
2848
2849     /* Prepend my entry-point number to the actual arg list. */
2850
2851     prepend = build_tree_list (NULL_TREE, build_int_2 (entrynum, 0));
2852     TREE_CHAIN (prepend) = arglist;
2853     arglist = prepend;
2854
2855     /* Build the call to the master function. */
2856
2857     master_fn = ffecom_1_fn (ffecom_previous_function_decl_);
2858     call = ffecom_3s (CALL_EXPR,
2859                       TREE_TYPE (TREE_TYPE (TREE_TYPE (master_fn))),
2860                       master_fn, arglist, NULL_TREE);
2861
2862     /* Decide whether the master function is a function or subroutine, and
2863        handle the return value for my entry point. */
2864
2865     if (charfunc || ((ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
2866                      && !altreturning))
2867       {
2868         expand_expr_stmt (call);
2869         expand_null_return ();
2870       }
2871     else if (multi && cmplxfunc)
2872       {
2873         expand_expr_stmt (call);
2874         result
2875           = ffecom_1 (INDIRECT_REF,
2876                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
2877                       result);
2878         result = ffecom_modify (NULL_TREE, result,
2879                                 ffecom_2 (COMPONENT_REF, TREE_TYPE (result),
2880                                           multi_retval,
2881                                           ffecom_multi_fields_[bt][kt]));
2882         expand_expr_stmt (result);
2883         expand_null_return ();
2884       }
2885     else if (multi)
2886       {
2887         expand_expr_stmt (call);
2888         result
2889           = ffecom_modify (NULL_TREE, result,
2890                            convert (TREE_TYPE (result),
2891                                     ffecom_2 (COMPONENT_REF,
2892                                               ffecom_tree_type[bt][kt],
2893                                               multi_retval,
2894                                               ffecom_multi_fields_[bt][kt])));
2895         expand_return (result);
2896       }
2897     else if (cmplxfunc)
2898       {
2899         result
2900           = ffecom_1 (INDIRECT_REF,
2901                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
2902                       result);
2903         result = ffecom_modify (NULL_TREE, result, call);
2904         expand_expr_stmt (result);
2905         expand_null_return ();
2906       }
2907     else
2908       {
2909         result = ffecom_modify (NULL_TREE,
2910                                 result,
2911                                 convert (TREE_TYPE (result),
2912                                          call));
2913         expand_return (result);
2914       }
2915   }
2916
2917   ffecom_end_compstmt ();
2918
2919   finish_function (0);
2920
2921   lineno = old_lineno;
2922   input_filename = old_input_filename;
2923
2924   ffecom_doing_entry_ = FALSE;
2925 }
2926
2927 /* Transform expr into gcc tree with possible destination
2928
2929    Recursive descent on expr while making corresponding tree nodes and
2930    attaching type info and such.  If destination supplied and compatible
2931    with temporary that would be made in certain cases, temporary isn't
2932    made, destination used instead, and dest_used flag set TRUE.  */
2933
2934 static tree
2935 ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
2936               bool *dest_used, bool assignp, bool widenp)
2937 {
2938   tree item;
2939   tree list;
2940   tree args;
2941   ffeinfoBasictype bt;
2942   ffeinfoKindtype kt;
2943   tree t;
2944   tree dt;                      /* decl_tree for an ffesymbol. */
2945   tree tree_type, tree_type_x;
2946   tree left, right;
2947   ffesymbol s;
2948   enum tree_code code;
2949
2950   assert (expr != NULL);
2951
2952   if (dest_used != NULL)
2953     *dest_used = FALSE;
2954
2955   bt = ffeinfo_basictype (ffebld_info (expr));
2956   kt = ffeinfo_kindtype (ffebld_info (expr));
2957   tree_type = ffecom_tree_type[bt][kt];
2958
2959   /* Widen integral arithmetic as desired while preserving signedness.  */
2960   tree_type_x = NULL_TREE;
2961   if (widenp && tree_type
2962       && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
2963       && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
2964     tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
2965
2966   switch (ffebld_op (expr))
2967     {
2968     case FFEBLD_opACCTER:
2969       {
2970         ffebitCount i;
2971         ffebit bits = ffebld_accter_bits (expr);
2972         ffetargetOffset source_offset = 0;
2973         ffetargetOffset dest_offset = ffebld_accter_pad (expr);
2974         tree purpose;
2975
2976         assert (dest_offset == 0
2977                 || (bt == FFEINFO_basictypeCHARACTER
2978                     && kt == FFEINFO_kindtypeCHARACTER1));
2979
2980         list = item = NULL;
2981         for (;;)
2982           {
2983             ffebldConstantUnion cu;
2984             ffebitCount length;
2985             bool value;
2986             ffebldConstantArray ca = ffebld_accter (expr);
2987
2988             ffebit_test (bits, source_offset, &value, &length);
2989             if (length == 0)
2990               break;
2991
2992             if (value)
2993               {
2994                 for (i = 0; i < length; ++i)
2995                   {
2996                     cu = ffebld_constantarray_get (ca, bt, kt,
2997                                                    source_offset + i);
2998
2999                     t = ffecom_constantunion (&cu, bt, kt, tree_type);
3000
3001                     if (i == 0
3002                         && dest_offset != 0)
3003                       purpose = build_int_2 (dest_offset, 0);
3004                     else
3005                       purpose = NULL_TREE;
3006
3007                     if (list == NULL_TREE)
3008                       list = item = build_tree_list (purpose, t);
3009                     else
3010                       {
3011                         TREE_CHAIN (item) = build_tree_list (purpose, t);
3012                         item = TREE_CHAIN (item);
3013                       }
3014                   }
3015               }
3016             source_offset += length;
3017             dest_offset += length;
3018           }
3019       }
3020
3021       item = build_int_2 ((ffebld_accter_size (expr)
3022                            + ffebld_accter_pad (expr)) - 1, 0);
3023       ffebit_kill (ffebld_accter_bits (expr));
3024       TREE_TYPE (item) = ffecom_integer_type_node;
3025       item
3026         = build_array_type
3027           (tree_type,
3028            build_range_type (ffecom_integer_type_node,
3029                              ffecom_integer_zero_node,
3030                              item));
3031       list = build (CONSTRUCTOR, item, NULL_TREE, list);
3032       TREE_CONSTANT (list) = 1;
3033       TREE_STATIC (list) = 1;
3034       return list;
3035
3036     case FFEBLD_opARRTER:
3037       {
3038         ffetargetOffset i;
3039
3040         list = NULL_TREE;
3041         if (ffebld_arrter_pad (expr) == 0)
3042           item = NULL_TREE;
3043         else
3044           {
3045             assert (bt == FFEINFO_basictypeCHARACTER
3046                     && kt == FFEINFO_kindtypeCHARACTER1);
3047
3048             /* Becomes PURPOSE first time through loop.  */
3049             item = build_int_2 (ffebld_arrter_pad (expr), 0);
3050           }
3051
3052         for (i = 0; i < ffebld_arrter_size (expr); ++i)
3053           {
3054             ffebldConstantUnion cu
3055             = ffebld_constantarray_get (ffebld_arrter (expr), bt, kt, i);
3056
3057             t = ffecom_constantunion (&cu, bt, kt, tree_type);
3058
3059             if (list == NULL_TREE)
3060               /* Assume item is PURPOSE first time through loop.  */
3061               list = item = build_tree_list (item, t);
3062             else
3063               {
3064                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
3065                 item = TREE_CHAIN (item);
3066               }
3067           }
3068       }
3069
3070       item = build_int_2 ((ffebld_arrter_size (expr)
3071                           + ffebld_arrter_pad (expr)) - 1, 0);
3072       TREE_TYPE (item) = ffecom_integer_type_node;
3073       item
3074         = build_array_type
3075           (tree_type,
3076            build_range_type (ffecom_integer_type_node,
3077                              ffecom_integer_zero_node,
3078                              item));
3079       list = build (CONSTRUCTOR, item, NULL_TREE, list);
3080       TREE_CONSTANT (list) = 1;
3081       TREE_STATIC (list) = 1;
3082       return list;
3083
3084     case FFEBLD_opCONTER:
3085       assert (ffebld_conter_pad (expr) == 0);
3086       item
3087         = ffecom_constantunion (&ffebld_constant_union (ffebld_conter (expr)),
3088                                 bt, kt, tree_type);
3089       return item;
3090
3091     case FFEBLD_opSYMTER:
3092       if ((ffebld_symter_generic (expr) != FFEINTRIN_genNONE)
3093           || (ffebld_symter_specific (expr) != FFEINTRIN_specNONE))
3094         return ffecom_ptr_to_expr (expr);       /* Same as %REF(intrinsic). */
3095       s = ffebld_symter (expr);
3096       t = ffesymbol_hook (s).decl_tree;
3097
3098       if (assignp)
3099         {                       /* ASSIGN'ed-label expr. */
3100           if (ffe_is_ugly_assign ())
3101             {
3102               /* User explicitly wants ASSIGN'ed variables to be at the same
3103                  memory address as the variables when used in non-ASSIGN
3104                  contexts.  That can make old, arcane, non-standard code
3105                  work, but don't try to do it when a pointer wouldn't fit
3106                  in the normal variable (take other approach, and warn,
3107                  instead).  */
3108
3109               if (t == NULL_TREE)
3110                 {
3111                   s = ffecom_sym_transform_ (s);
3112                   t = ffesymbol_hook (s).decl_tree;
3113                   assert (t != NULL_TREE);
3114                 }
3115
3116               if (t == error_mark_node)
3117                 return t;
3118
3119               if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t)))
3120                   >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
3121                 {
3122                   if (ffesymbol_hook (s).addr)
3123                     t = ffecom_1 (INDIRECT_REF,
3124                                   TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3125                   return t;
3126                 }
3127
3128               if (ffesymbol_hook (s).assign_tree == NULL_TREE)
3129                 {
3130                   /* xgettext:no-c-format */
3131                   ffebad_start_msg ("ASSIGN'ed label cannot fit into `%A' at %0 -- using wider sibling",
3132                                     FFEBAD_severityWARNING);
3133                   ffebad_string (ffesymbol_text (s));
3134                   ffebad_here (0, ffesymbol_where_line (s),
3135                                ffesymbol_where_column (s));
3136                   ffebad_finish ();
3137                 }
3138             }
3139
3140           /* Don't use the normal variable's tree for ASSIGN, though mark
3141              it as in the system header (housekeeping).  Use an explicit,
3142              specially created sibling that is known to be wide enough
3143              to hold pointers to labels.  */
3144
3145           if (t != NULL_TREE
3146               && TREE_CODE (t) == VAR_DECL)
3147             DECL_IN_SYSTEM_HEADER (t) = 1;      /* Don't let -Wunused complain. */
3148
3149           t = ffesymbol_hook (s).assign_tree;
3150           if (t == NULL_TREE)
3151             {
3152               s = ffecom_sym_transform_assign_ (s);
3153               t = ffesymbol_hook (s).assign_tree;
3154               assert (t != NULL_TREE);
3155             }
3156         }
3157       else
3158         {
3159           if (t == NULL_TREE)
3160             {
3161               s = ffecom_sym_transform_ (s);
3162               t = ffesymbol_hook (s).decl_tree;
3163               assert (t != NULL_TREE);
3164             }
3165           if (ffesymbol_hook (s).addr)
3166             t = ffecom_1 (INDIRECT_REF,
3167                           TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3168         }
3169       return t;
3170
3171     case FFEBLD_opARRAYREF:
3172       return ffecom_arrayref_ (NULL_TREE, expr, 0);
3173
3174     case FFEBLD_opUPLUS:
3175       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3176       return ffecom_1 (NOP_EXPR, tree_type, left);
3177
3178     case FFEBLD_opPAREN:
3179       /* ~~~Make sure Fortran rules respected here */
3180       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3181       return ffecom_1 (NOP_EXPR, tree_type, left);
3182
3183     case FFEBLD_opUMINUS:
3184       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3185       if (tree_type_x)
3186         {
3187           tree_type = tree_type_x;
3188           left = convert (tree_type, left);
3189         }
3190       return ffecom_1 (NEGATE_EXPR, tree_type, left);
3191
3192     case FFEBLD_opADD:
3193       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3194       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3195       if (tree_type_x)
3196         {
3197           tree_type = tree_type_x;
3198           left = convert (tree_type, left);
3199           right = convert (tree_type, right);
3200         }
3201       return ffecom_2 (PLUS_EXPR, tree_type, left, right);
3202
3203     case FFEBLD_opSUBTRACT:
3204       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3205       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3206       if (tree_type_x)
3207         {
3208           tree_type = tree_type_x;
3209           left = convert (tree_type, left);
3210           right = convert (tree_type, right);
3211         }
3212       return ffecom_2 (MINUS_EXPR, tree_type, left, right);
3213
3214     case FFEBLD_opMULTIPLY:
3215       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3216       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3217       if (tree_type_x)
3218         {
3219           tree_type = tree_type_x;
3220           left = convert (tree_type, left);
3221           right = convert (tree_type, right);
3222         }
3223       return ffecom_2 (MULT_EXPR, tree_type, left, right);
3224
3225     case FFEBLD_opDIVIDE:
3226       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3227       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3228       if (tree_type_x)
3229         {
3230           tree_type = tree_type_x;
3231           left = convert (tree_type, left);
3232           right = convert (tree_type, right);
3233         }
3234       return ffecom_tree_divide_ (tree_type, left, right,
3235                                   dest_tree, dest, dest_used,
3236                                   ffebld_nonter_hook (expr));
3237
3238     case FFEBLD_opPOWER:
3239       {
3240         ffebld left = ffebld_left (expr);
3241         ffebld right = ffebld_right (expr);
3242         ffecomGfrt code;
3243         ffeinfoKindtype rtkt;
3244         ffeinfoKindtype ltkt;
3245         bool ref = TRUE;
3246
3247         switch (ffeinfo_basictype (ffebld_info (right)))
3248           {
3249
3250           case FFEINFO_basictypeINTEGER:
3251             if (1 || optimize)
3252               {
3253                 item = ffecom_expr_power_integer_ (expr);
3254                 if (item != NULL_TREE)
3255                   return item;
3256               }
3257
3258             rtkt = FFEINFO_kindtypeINTEGER1;
3259             switch (ffeinfo_basictype (ffebld_info (left)))
3260               {
3261               case FFEINFO_basictypeINTEGER:
3262                 if ((ffeinfo_kindtype (ffebld_info (left))
3263                     == FFEINFO_kindtypeINTEGER4)
3264                     || (ffeinfo_kindtype (ffebld_info (right))
3265                         == FFEINFO_kindtypeINTEGER4))
3266                   {
3267                     code = FFECOM_gfrtPOW_QQ;
3268                     ltkt = FFEINFO_kindtypeINTEGER4;
3269                     rtkt = FFEINFO_kindtypeINTEGER4;
3270                   }
3271                 else
3272                   {
3273                     code = FFECOM_gfrtPOW_II;
3274                     ltkt = FFEINFO_kindtypeINTEGER1;
3275                   }
3276                 break;
3277
3278               case FFEINFO_basictypeREAL:
3279                 if (ffeinfo_kindtype (ffebld_info (left))
3280                     == FFEINFO_kindtypeREAL1)
3281                   {
3282                     code = FFECOM_gfrtPOW_RI;
3283                     ltkt = FFEINFO_kindtypeREAL1;
3284                   }
3285                 else
3286                   {
3287                     code = FFECOM_gfrtPOW_DI;
3288                     ltkt = FFEINFO_kindtypeREAL2;
3289                   }
3290                 break;
3291
3292               case FFEINFO_basictypeCOMPLEX:
3293                 if (ffeinfo_kindtype (ffebld_info (left))
3294                     == FFEINFO_kindtypeREAL1)
3295                   {
3296                     code = FFECOM_gfrtPOW_CI;   /* Overlapping result okay. */
3297                     ltkt = FFEINFO_kindtypeREAL1;
3298                   }
3299                 else
3300                   {
3301                     code = FFECOM_gfrtPOW_ZI;   /* Overlapping result okay. */
3302                     ltkt = FFEINFO_kindtypeREAL2;
3303                   }
3304                 break;
3305
3306               default:
3307                 assert ("bad pow_*i" == NULL);
3308                 code = FFECOM_gfrtPOW_CI;       /* Overlapping result okay. */
3309                 ltkt = FFEINFO_kindtypeREAL1;
3310                 break;
3311               }
3312             if (ffeinfo_kindtype (ffebld_info (left)) != ltkt)
3313               left = ffeexpr_convert (left, NULL, NULL,
3314                                       ffeinfo_basictype (ffebld_info (left)),
3315                                       ltkt, 0,
3316                                       FFETARGET_charactersizeNONE,
3317                                       FFEEXPR_contextLET);
3318             if (ffeinfo_kindtype (ffebld_info (right)) != rtkt)
3319               right = ffeexpr_convert (right, NULL, NULL,
3320                                        FFEINFO_basictypeINTEGER,
3321                                        rtkt, 0,
3322                                        FFETARGET_charactersizeNONE,
3323                                        FFEEXPR_contextLET);
3324             break;
3325
3326           case FFEINFO_basictypeREAL:
3327             if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3328               left = ffeexpr_convert (left, NULL, NULL, FFEINFO_basictypeREAL,
3329                                       FFEINFO_kindtypeREALDOUBLE, 0,
3330                                       FFETARGET_charactersizeNONE,
3331                                       FFEEXPR_contextLET);
3332             if (ffeinfo_kindtype (ffebld_info (right))
3333                 == FFEINFO_kindtypeREAL1)
3334               right = ffeexpr_convert (right, NULL, NULL,
3335                                        FFEINFO_basictypeREAL,
3336                                        FFEINFO_kindtypeREALDOUBLE, 0,
3337                                        FFETARGET_charactersizeNONE,
3338                                        FFEEXPR_contextLET);
3339             /* We used to call FFECOM_gfrtPOW_DD here,
3340                which passes arguments by reference.  */
3341             code = FFECOM_gfrtL_POW;
3342             /* Pass arguments by value. */
3343             ref  = FALSE;
3344             break;
3345
3346           case FFEINFO_basictypeCOMPLEX:
3347             if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3348               left = ffeexpr_convert (left, NULL, NULL,
3349                                       FFEINFO_basictypeCOMPLEX,
3350                                       FFEINFO_kindtypeREALDOUBLE, 0,
3351                                       FFETARGET_charactersizeNONE,
3352                                       FFEEXPR_contextLET);
3353             if (ffeinfo_kindtype (ffebld_info (right))
3354                 == FFEINFO_kindtypeREAL1)
3355               right = ffeexpr_convert (right, NULL, NULL,
3356                                        FFEINFO_basictypeCOMPLEX,
3357                                        FFEINFO_kindtypeREALDOUBLE, 0,
3358                                        FFETARGET_charactersizeNONE,
3359                                        FFEEXPR_contextLET);
3360             code = FFECOM_gfrtPOW_ZZ;   /* Overlapping result okay. */
3361             ref = TRUE;                 /* Pass arguments by reference. */
3362             break;
3363
3364           default:
3365             assert ("bad pow_x*" == NULL);
3366             code = FFECOM_gfrtPOW_II;
3367             break;
3368           }
3369         return ffecom_call_binop_ (ffecom_gfrt_tree_ (code),
3370                                    ffecom_gfrt_kindtype (code),
3371                                    (ffe_is_f2c_library ()
3372                                     && ffecom_gfrt_complex_[code]),
3373                                    tree_type, left, right,
3374                                    dest_tree, dest, dest_used,
3375                                    NULL_TREE, FALSE, ref,
3376                                    ffebld_nonter_hook (expr));
3377       }
3378
3379     case FFEBLD_opNOT:
3380       switch (bt)
3381         {
3382         case FFEINFO_basictypeLOGICAL:
3383           item = ffecom_truth_value_invert (ffecom_expr (ffebld_left (expr)));
3384           return convert (tree_type, item);
3385
3386         case FFEINFO_basictypeINTEGER:
3387           return ffecom_1 (BIT_NOT_EXPR, tree_type,
3388                            ffecom_expr (ffebld_left (expr)));
3389
3390         default:
3391           assert ("NOT bad basictype" == NULL);
3392           /* Fall through. */
3393         case FFEINFO_basictypeANY:
3394           return error_mark_node;
3395         }
3396       break;
3397
3398     case FFEBLD_opFUNCREF:
3399       assert (ffeinfo_basictype (ffebld_info (expr))
3400               != FFEINFO_basictypeCHARACTER);
3401       /* Fall through.   */
3402     case FFEBLD_opSUBRREF:
3403       if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
3404           == FFEINFO_whereINTRINSIC)
3405         {                       /* Invocation of an intrinsic. */
3406           item = ffecom_expr_intrinsic_ (expr, dest_tree, dest,
3407                                          dest_used);
3408           return item;
3409         }
3410       s = ffebld_symter (ffebld_left (expr));
3411       dt = ffesymbol_hook (s).decl_tree;
3412       if (dt == NULL_TREE)
3413         {
3414           s = ffecom_sym_transform_ (s);
3415           dt = ffesymbol_hook (s).decl_tree;
3416         }
3417       if (dt == error_mark_node)
3418         return dt;
3419
3420       if (ffesymbol_hook (s).addr)
3421         item = dt;
3422       else
3423         item = ffecom_1_fn (dt);
3424
3425       if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
3426         args = ffecom_list_expr (ffebld_right (expr));
3427       else
3428         args = ffecom_list_ptr_to_expr (ffebld_right (expr));
3429
3430       if (args == error_mark_node)
3431         return error_mark_node;
3432
3433       item = ffecom_call_ (item, kt,
3434                            ffesymbol_is_f2c (s)
3435                            && (bt == FFEINFO_basictypeCOMPLEX)
3436                            && (ffesymbol_where (s)
3437                                != FFEINFO_whereCONSTANT),
3438                            tree_type,
3439                            args,
3440                            dest_tree, dest, dest_used,
3441                            error_mark_node, FALSE,
3442                            ffebld_nonter_hook (expr));
3443       TREE_SIDE_EFFECTS (item) = 1;
3444       return item;
3445
3446     case FFEBLD_opAND:
3447       switch (bt)
3448         {
3449         case FFEINFO_basictypeLOGICAL:
3450           item
3451             = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3452                        ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3453                      ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3454           return convert (tree_type, item);
3455
3456         case FFEINFO_basictypeINTEGER:
3457           return ffecom_2 (BIT_AND_EXPR, tree_type,
3458                            ffecom_expr (ffebld_left (expr)),
3459                            ffecom_expr (ffebld_right (expr)));
3460
3461         default:
3462           assert ("AND bad basictype" == NULL);
3463           /* Fall through. */
3464         case FFEINFO_basictypeANY:
3465           return error_mark_node;
3466         }
3467       break;
3468
3469     case FFEBLD_opOR:
3470       switch (bt)
3471         {
3472         case FFEINFO_basictypeLOGICAL:
3473           item
3474             = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
3475                        ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3476                      ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3477           return convert (tree_type, item);
3478
3479         case FFEINFO_basictypeINTEGER:
3480           return ffecom_2 (BIT_IOR_EXPR, tree_type,
3481                            ffecom_expr (ffebld_left (expr)),
3482                            ffecom_expr (ffebld_right (expr)));
3483
3484         default:
3485           assert ("OR bad basictype" == NULL);
3486           /* Fall through. */
3487         case FFEINFO_basictypeANY:
3488           return error_mark_node;
3489         }
3490       break;
3491
3492     case FFEBLD_opXOR:
3493     case FFEBLD_opNEQV:
3494       switch (bt)
3495         {
3496         case FFEINFO_basictypeLOGICAL:
3497           item
3498             = ffecom_2 (NE_EXPR, integer_type_node,
3499                         ffecom_expr (ffebld_left (expr)),
3500                         ffecom_expr (ffebld_right (expr)));
3501           return convert (tree_type, ffecom_truth_value (item));
3502
3503         case FFEINFO_basictypeINTEGER:
3504           return ffecom_2 (BIT_XOR_EXPR, tree_type,
3505                            ffecom_expr (ffebld_left (expr)),
3506                            ffecom_expr (ffebld_right (expr)));
3507
3508         default:
3509           assert ("XOR/NEQV bad basictype" == NULL);
3510           /* Fall through. */
3511         case FFEINFO_basictypeANY:
3512           return error_mark_node;
3513         }
3514       break;
3515
3516     case FFEBLD_opEQV:
3517       switch (bt)
3518         {
3519         case FFEINFO_basictypeLOGICAL:
3520           item
3521             = ffecom_2 (EQ_EXPR, integer_type_node,
3522                         ffecom_expr (ffebld_left (expr)),
3523                         ffecom_expr (ffebld_right (expr)));
3524           return convert (tree_type, ffecom_truth_value (item));
3525
3526         case FFEINFO_basictypeINTEGER:
3527           return
3528             ffecom_1 (BIT_NOT_EXPR, tree_type,
3529                       ffecom_2 (BIT_XOR_EXPR, tree_type,
3530                                 ffecom_expr (ffebld_left (expr)),
3531                                 ffecom_expr (ffebld_right (expr))));
3532
3533         default:
3534           assert ("EQV bad basictype" == NULL);
3535           /* Fall through. */
3536         case FFEINFO_basictypeANY:
3537           return error_mark_node;
3538         }
3539       break;
3540
3541     case FFEBLD_opCONVERT:
3542       if (ffebld_op (ffebld_left (expr)) == FFEBLD_opANY)
3543         return error_mark_node;
3544
3545       switch (bt)
3546         {
3547         case FFEINFO_basictypeLOGICAL:
3548         case FFEINFO_basictypeINTEGER:
3549         case FFEINFO_basictypeREAL:
3550           return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3551
3552         case FFEINFO_basictypeCOMPLEX:
3553           switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3554             {
3555             case FFEINFO_basictypeINTEGER:
3556             case FFEINFO_basictypeLOGICAL:
3557             case FFEINFO_basictypeREAL:
3558               item = ffecom_expr (ffebld_left (expr));
3559               if (item == error_mark_node)
3560                 return error_mark_node;
3561               /* convert() takes care of converting to the subtype first,
3562                  at least in gcc-2.7.2. */
3563               item = convert (tree_type, item);
3564               return item;
3565
3566             case FFEINFO_basictypeCOMPLEX:
3567               return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3568
3569             default:
3570               assert ("CONVERT COMPLEX bad basictype" == NULL);
3571               /* Fall through. */
3572             case FFEINFO_basictypeANY:
3573               return error_mark_node;
3574             }
3575           break;
3576
3577         default:
3578           assert ("CONVERT bad basictype" == NULL);
3579           /* Fall through. */
3580         case FFEINFO_basictypeANY:
3581           return error_mark_node;
3582         }
3583       break;
3584
3585     case FFEBLD_opLT:
3586       code = LT_EXPR;
3587       goto relational;          /* :::::::::::::::::::: */
3588
3589     case FFEBLD_opLE:
3590       code = LE_EXPR;
3591       goto relational;          /* :::::::::::::::::::: */
3592
3593     case FFEBLD_opEQ:
3594       code = EQ_EXPR;
3595       goto relational;          /* :::::::::::::::::::: */
3596
3597     case FFEBLD_opNE:
3598       code = NE_EXPR;
3599       goto relational;          /* :::::::::::::::::::: */
3600
3601     case FFEBLD_opGT:
3602       code = GT_EXPR;
3603       goto relational;          /* :::::::::::::::::::: */
3604
3605     case FFEBLD_opGE:
3606       code = GE_EXPR;
3607
3608     relational:         /* :::::::::::::::::::: */
3609       switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3610         {
3611         case FFEINFO_basictypeLOGICAL:
3612         case FFEINFO_basictypeINTEGER:
3613         case FFEINFO_basictypeREAL:
3614           item = ffecom_2 (code, integer_type_node,
3615                            ffecom_expr (ffebld_left (expr)),
3616                            ffecom_expr (ffebld_right (expr)));
3617           return convert (tree_type, item);
3618
3619         case FFEINFO_basictypeCOMPLEX:
3620           assert (code == EQ_EXPR || code == NE_EXPR);
3621           {
3622             tree real_type;
3623             tree arg1 = ffecom_expr (ffebld_left (expr));
3624             tree arg2 = ffecom_expr (ffebld_right (expr));
3625
3626             if (arg1 == error_mark_node || arg2 == error_mark_node)
3627               return error_mark_node;
3628
3629             arg1 = ffecom_save_tree (arg1);
3630             arg2 = ffecom_save_tree (arg2);
3631
3632             if (TREE_CODE (TREE_TYPE (arg1)) == COMPLEX_TYPE)
3633               {
3634                 real_type = TREE_TYPE (TREE_TYPE (arg1));
3635                 assert (real_type == TREE_TYPE (TREE_TYPE (arg2)));
3636               }
3637             else
3638               {
3639                 real_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg1)));
3640                 assert (real_type == TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg2))));
3641               }
3642
3643             item
3644               = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3645                           ffecom_2 (EQ_EXPR, integer_type_node,
3646                                   ffecom_1 (REALPART_EXPR, real_type, arg1),
3647                                  ffecom_1 (REALPART_EXPR, real_type, arg2)),
3648                           ffecom_2 (EQ_EXPR, integer_type_node,
3649                                   ffecom_1 (IMAGPART_EXPR, real_type, arg1),
3650                                     ffecom_1 (IMAGPART_EXPR, real_type,
3651                                               arg2)));
3652             if (code == EQ_EXPR)
3653               item = ffecom_truth_value (item);
3654             else
3655               item = ffecom_truth_value_invert (item);
3656             return convert (tree_type, item);
3657           }
3658
3659         case FFEINFO_basictypeCHARACTER:
3660           {
3661             ffebld left = ffebld_left (expr);
3662             ffebld right = ffebld_right (expr);
3663             tree left_tree;
3664             tree right_tree;
3665             tree left_length;
3666             tree right_length;
3667
3668             /* f2c run-time functions do the implicit blank-padding for us,
3669                so we don't usually have to implement blank-padding ourselves.
3670                (The exception is when we pass an argument to a separately
3671                compiled statement function -- if we know the arg is not the
3672                same length as the dummy, we must truncate or extend it.  If
3673                we "inline" statement functions, that necessity goes away as
3674                well.)
3675
3676                Strip off the CONVERT operators that blank-pad.  (Truncation by
3677                CONVERT shouldn't happen here, but it can happen in
3678                assignments.) */
3679
3680             while (ffebld_op (left) == FFEBLD_opCONVERT)
3681               left = ffebld_left (left);
3682             while (ffebld_op (right) == FFEBLD_opCONVERT)
3683               right = ffebld_left (right);
3684
3685             left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
3686             right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
3687
3688             if (left_tree == error_mark_node || left_length == error_mark_node
3689                 || right_tree == error_mark_node
3690                 || right_length == error_mark_node)
3691               return error_mark_node;
3692
3693             if ((ffebld_size_known (left) == 1)
3694                 && (ffebld_size_known (right) == 1))
3695               {
3696                 left_tree
3697                   = ffecom_1 (INDIRECT_REF,
3698                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3699                               left_tree);
3700                 right_tree
3701                   = ffecom_1 (INDIRECT_REF,
3702                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3703                               right_tree);
3704
3705                 item
3706                   = ffecom_2 (code, integer_type_node,
3707                               ffecom_2 (ARRAY_REF,
3708                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3709                                         left_tree,
3710                                         integer_one_node),
3711                               ffecom_2 (ARRAY_REF,
3712                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3713                                         right_tree,
3714                                         integer_one_node));
3715               }
3716             else
3717               {
3718                 item = build_tree_list (NULL_TREE, left_tree);
3719                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, right_tree);
3720                 TREE_CHAIN (TREE_CHAIN (item)) = build_tree_list (NULL_TREE,
3721                                                                left_length);
3722                 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
3723                   = build_tree_list (NULL_TREE, right_length);
3724                 item = ffecom_call_gfrt (FFECOM_gfrtCMP, item, NULL_TREE);
3725                 item = ffecom_2 (code, integer_type_node,
3726                                  item,
3727                                  convert (TREE_TYPE (item),
3728                                           integer_zero_node));
3729               }
3730             item = convert (tree_type, item);
3731           }
3732
3733           return item;
3734
3735         default:
3736           assert ("relational bad basictype" == NULL);
3737           /* Fall through. */
3738         case FFEINFO_basictypeANY:
3739           return error_mark_node;
3740         }
3741       break;
3742
3743     case FFEBLD_opPERCENT_LOC:
3744       item = ffecom_arg_ptr_to_expr (ffebld_left (expr), &list);
3745       return convert (tree_type, item);
3746
3747     case FFEBLD_opPERCENT_VAL:
3748       item = ffecom_arg_expr (ffebld_left (expr), &list);
3749       return convert (tree_type, item);
3750
3751     case FFEBLD_opITEM:
3752     case FFEBLD_opSTAR:
3753     case FFEBLD_opBOUNDS:
3754     case FFEBLD_opREPEAT:
3755     case FFEBLD_opLABTER:
3756     case FFEBLD_opLABTOK:
3757     case FFEBLD_opIMPDO:
3758     case FFEBLD_opCONCATENATE:
3759     case FFEBLD_opSUBSTR:
3760     default:
3761       assert ("bad op" == NULL);
3762       /* Fall through. */
3763     case FFEBLD_opANY:
3764       return error_mark_node;
3765     }
3766
3767 #if 1
3768   assert ("didn't think anything got here anymore!!" == NULL);
3769 #else
3770   switch (ffebld_arity (expr))
3771     {
3772     case 2:
3773       TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3774       TREE_OPERAND (item, 1) = ffecom_expr (ffebld_right (expr));
3775       if (TREE_OPERAND (item, 0) == error_mark_node
3776           || TREE_OPERAND (item, 1) == error_mark_node)
3777         return error_mark_node;
3778       break;
3779
3780     case 1:
3781       TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3782       if (TREE_OPERAND (item, 0) == error_mark_node)
3783         return error_mark_node;
3784       break;
3785
3786     default:
3787       break;
3788     }
3789
3790   return fold (item);
3791 #endif
3792 }
3793
3794 /* Returns the tree that does the intrinsic invocation.
3795
3796    Note: this function applies only to intrinsics returning
3797    CHARACTER*1 or non-CHARACTER results, and to intrinsic
3798    subroutines.  */
3799
3800 static tree
3801 ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
3802                         ffebld dest, bool *dest_used)
3803 {
3804   tree expr_tree;
3805   tree saved_expr1;             /* For those who need it. */
3806   tree saved_expr2;             /* For those who need it. */
3807   ffeinfoBasictype bt;
3808   ffeinfoKindtype kt;
3809   tree tree_type;
3810   tree arg1_type;
3811   tree real_type;               /* REAL type corresponding to COMPLEX. */
3812   tree tempvar;
3813   ffebld list = ffebld_right (expr);    /* List of (some) args. */
3814   ffebld arg1;                  /* For handy reference. */
3815   ffebld arg2;
3816   ffebld arg3;
3817   ffeintrinImp codegen_imp;
3818   ffecomGfrt gfrt;
3819
3820   assert (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER);
3821
3822   if (dest_used != NULL)
3823     *dest_used = FALSE;
3824
3825   bt = ffeinfo_basictype (ffebld_info (expr));
3826   kt = ffeinfo_kindtype (ffebld_info (expr));
3827   tree_type = ffecom_tree_type[bt][kt];
3828
3829   if (list != NULL)
3830     {
3831       arg1 = ffebld_head (list);
3832       if (arg1 != NULL && ffebld_op (arg1) == FFEBLD_opANY)
3833         return error_mark_node;
3834       if ((list = ffebld_trail (list)) != NULL)
3835         {
3836           arg2 = ffebld_head (list);
3837           if (arg2 != NULL && ffebld_op (arg2) == FFEBLD_opANY)
3838             return error_mark_node;
3839           if ((list = ffebld_trail (list)) != NULL)
3840             {
3841               arg3 = ffebld_head (list);
3842               if (arg3 != NULL && ffebld_op (arg3) == FFEBLD_opANY)
3843                 return error_mark_node;
3844             }
3845           else
3846             arg3 = NULL;
3847         }
3848       else
3849         arg2 = arg3 = NULL;
3850     }
3851   else
3852     arg1 = arg2 = arg3 = NULL;
3853
3854   /* <list> ends up at the opITEM of the 3rd arg, or NULL if there are < 3
3855      args.  This is used by the MAX/MIN expansions. */
3856
3857   if (arg1 != NULL)
3858     arg1_type = ffecom_tree_type
3859       [ffeinfo_basictype (ffebld_info (arg1))]
3860       [ffeinfo_kindtype (ffebld_info (arg1))];
3861   else
3862     arg1_type = NULL_TREE;      /* Really not needed, but might catch bugs
3863                                    here. */
3864
3865   /* There are several ways for each of the cases in the following switch
3866      statements to exit (from simplest to use to most complicated):
3867
3868      break;  (when expr_tree == NULL)
3869
3870      A standard call is made to the specific intrinsic just as if it had been
3871      passed in as a dummy procedure and called as any old procedure.  This
3872      method can produce slower code but in some cases it's the easiest way for
3873      now.  However, if a (presumably faster) direct call is available,
3874      that is used, so this is the easiest way in many more cases now.
3875
3876      gfrt = FFECOM_gfrtWHATEVER;
3877      break;
3878
3879      gfrt contains the gfrt index of a library function to call, passing the
3880      argument(s) by value rather than by reference.  Used when a more
3881      careful choice of library function is needed than that provided
3882      by the vanilla `break;'.
3883
3884      return expr_tree;
3885
3886      The expr_tree has been completely set up and is ready to be returned
3887      as is.  No further actions are taken.  Use this when the tree is not
3888      in the simple form for one of the arity_n labels.   */
3889
3890   /* For info on how the switch statement cases were written, see the files
3891      enclosed in comments below the switch statement. */
3892
3893   codegen_imp = ffebld_symter_implementation (ffebld_left (expr));
3894   gfrt = ffeintrin_gfrt_direct (codegen_imp);
3895   if (gfrt == FFECOM_gfrt)
3896     gfrt = ffeintrin_gfrt_indirect (codegen_imp);
3897
3898   switch (codegen_imp)
3899     {
3900     case FFEINTRIN_impABS:
3901     case FFEINTRIN_impCABS:
3902     case FFEINTRIN_impCDABS:
3903     case FFEINTRIN_impDABS:
3904     case FFEINTRIN_impIABS:
3905       if (ffeinfo_basictype (ffebld_info (arg1))
3906           == FFEINFO_basictypeCOMPLEX)
3907         {
3908           if (kt == FFEINFO_kindtypeREAL1)
3909             gfrt = FFECOM_gfrtCABS;
3910           else if (kt == FFEINFO_kindtypeREAL2)
3911             gfrt = FFECOM_gfrtCDABS;
3912           break;
3913         }
3914       return ffecom_1 (ABS_EXPR, tree_type,
3915                        convert (tree_type, ffecom_expr (arg1)));
3916
3917     case FFEINTRIN_impACOS:
3918     case FFEINTRIN_impDACOS:
3919       break;
3920
3921     case FFEINTRIN_impAIMAG:
3922     case FFEINTRIN_impDIMAG:
3923     case FFEINTRIN_impIMAGPART:
3924       if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
3925         arg1_type = TREE_TYPE (arg1_type);
3926       else
3927         arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
3928
3929       return
3930         convert (tree_type,
3931                  ffecom_1 (IMAGPART_EXPR, arg1_type,
3932                            ffecom_expr (arg1)));
3933
3934     case FFEINTRIN_impAINT:
3935     case FFEINTRIN_impDINT:
3936 #if 0
3937       /* ~~Someday implement FIX_TRUNC_EXPR yielding same type as arg.  */
3938       return ffecom_1 (FIX_TRUNC_EXPR, tree_type, ffecom_expr (arg1));
3939 #else /* in the meantime, must use floor to avoid range problems with ints */
3940       /* r__1 = r1 >= 0 ? floor(r1) : -floor(-r1); */
3941       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
3942       return
3943         convert (tree_type,
3944                  ffecom_3 (COND_EXPR, double_type_node,
3945                            ffecom_truth_value
3946                            (ffecom_2 (GE_EXPR, integer_type_node,
3947                                       saved_expr1,
3948                                       convert (arg1_type,
3949                                                ffecom_float_zero_))),
3950                            ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
3951                                              build_tree_list (NULL_TREE,
3952                                                   convert (double_type_node,
3953                                                            saved_expr1)),
3954                                              NULL_TREE),
3955                            ffecom_1 (NEGATE_EXPR, double_type_node,
3956                                      ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
3957                                                  build_tree_list (NULL_TREE,
3958                                                   convert (double_type_node,
3959                                                       ffecom_1 (NEGATE_EXPR,
3960                                                                 arg1_type,
3961                                                                saved_expr1))),
3962                                                        NULL_TREE)
3963                                      ))
3964                  );
3965 #endif
3966
3967     case FFEINTRIN_impANINT:
3968     case FFEINTRIN_impDNINT:
3969 #if 0                           /* This way of doing it won't handle real
3970                                    numbers of large magnitudes. */
3971       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
3972       expr_tree = convert (tree_type,
3973                            convert (integer_type_node,
3974                                     ffecom_3 (COND_EXPR, tree_type,
3975                                               ffecom_truth_value
3976                                               (ffecom_2 (GE_EXPR,
3977                                                          integer_type_node,
3978                                                          saved_expr1,
3979                                                        ffecom_float_zero_)),
3980                                               ffecom_2 (PLUS_EXPR,
3981                                                         tree_type,
3982                                                         saved_expr1,
3983                                                         ffecom_float_half_),
3984                                               ffecom_2 (MINUS_EXPR,
3985                                                         tree_type,
3986                                                         saved_expr1,
3987                                                      ffecom_float_half_))));
3988       return expr_tree;
3989 #else /* So we instead call floor. */
3990       /* r__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1) */
3991       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
3992       return
3993         convert (tree_type,
3994                  ffecom_3 (COND_EXPR, double_type_node,
3995                            ffecom_truth_value
3996                            (ffecom_2 (GE_EXPR, integer_type_node,
3997                                       saved_expr1,
3998                                       convert (arg1_type,
3999                                                ffecom_float_zero_))),
4000                            ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4001                                              build_tree_list (NULL_TREE,
4002                                                   convert (double_type_node,
4003                                                            ffecom_2 (PLUS_EXPR,
4004                                                                      arg1_type,
4005                                                                      saved_expr1,
4006                                                                      convert (arg1_type,
4007                                                                               ffecom_float_half_)))),
4008                                              NULL_TREE),
4009                            ffecom_1 (NEGATE_EXPR, double_type_node,
4010                                      ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4011                                                        build_tree_list (NULL_TREE,
4012                                                                         convert (double_type_node,
4013                                                                                  ffecom_2 (MINUS_EXPR,
4014                                                                                            arg1_type,
4015                                                                                            convert (arg1_type,
4016                                                                                                     ffecom_float_half_),
4017                                                                                            saved_expr1))),
4018                                                        NULL_TREE))
4019                            )
4020                  );
4021 #endif
4022
4023     case FFEINTRIN_impASIN:
4024     case FFEINTRIN_impDASIN:
4025     case FFEINTRIN_impATAN:
4026     case FFEINTRIN_impDATAN:
4027     case FFEINTRIN_impATAN2:
4028     case FFEINTRIN_impDATAN2:
4029       break;
4030
4031     case FFEINTRIN_impCHAR:
4032     case FFEINTRIN_impACHAR:
4033 #ifdef HOHO
4034       tempvar = ffecom_make_tempvar (char_type_node, 1, -1);
4035 #else
4036       tempvar = ffebld_nonter_hook (expr);
4037       assert (tempvar);
4038 #endif
4039       {
4040         tree tmv = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (tempvar)));
4041
4042         expr_tree = ffecom_modify (tmv,
4043                                    ffecom_2 (ARRAY_REF, tmv, tempvar,
4044                                              integer_one_node),
4045                                    convert (tmv, ffecom_expr (arg1)));
4046       }
4047       expr_tree = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar),
4048                             expr_tree,
4049                             tempvar);
4050       expr_tree = ffecom_1 (ADDR_EXPR,
4051                             build_pointer_type (TREE_TYPE (expr_tree)),
4052                             expr_tree);
4053       return expr_tree;
4054
4055     case FFEINTRIN_impCMPLX:
4056     case FFEINTRIN_impDCMPLX:
4057       if (arg2 == NULL)
4058         return
4059           convert (tree_type, ffecom_expr (arg1));
4060
4061       real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4062       return
4063         ffecom_2 (COMPLEX_EXPR, tree_type,
4064                   convert (real_type, ffecom_expr (arg1)),
4065                   convert (real_type,
4066                            ffecom_expr (arg2)));
4067
4068     case FFEINTRIN_impCOMPLEX:
4069       return
4070         ffecom_2 (COMPLEX_EXPR, tree_type,
4071                   ffecom_expr (arg1),
4072                   ffecom_expr (arg2));
4073
4074     case FFEINTRIN_impCONJG:
4075     case FFEINTRIN_impDCONJG:
4076       {
4077         tree arg1_tree;
4078
4079         real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4080         arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4081         return
4082           ffecom_2 (COMPLEX_EXPR, tree_type,
4083                     ffecom_1 (REALPART_EXPR, real_type, arg1_tree),
4084                     ffecom_1 (NEGATE_EXPR, real_type,
4085                               ffecom_1 (IMAGPART_EXPR, real_type, arg1_tree)));
4086       }
4087
4088     case FFEINTRIN_impCOS:
4089     case FFEINTRIN_impCCOS:
4090     case FFEINTRIN_impCDCOS:
4091     case FFEINTRIN_impDCOS:
4092       if (bt == FFEINFO_basictypeCOMPLEX)
4093         {
4094           if (kt == FFEINFO_kindtypeREAL1)
4095             gfrt = FFECOM_gfrtCCOS;     /* Overlapping result okay. */
4096           else if (kt == FFEINFO_kindtypeREAL2)
4097             gfrt = FFECOM_gfrtCDCOS;    /* Overlapping result okay. */
4098         }
4099       break;
4100
4101     case FFEINTRIN_impCOSH:
4102     case FFEINTRIN_impDCOSH:
4103       break;
4104
4105     case FFEINTRIN_impDBLE:
4106     case FFEINTRIN_impDFLOAT:
4107     case FFEINTRIN_impDREAL:
4108     case FFEINTRIN_impFLOAT:
4109     case FFEINTRIN_impIDINT:
4110     case FFEINTRIN_impIFIX:
4111     case FFEINTRIN_impINT2:
4112     case FFEINTRIN_impINT8:
4113     case FFEINTRIN_impINT:
4114     case FFEINTRIN_impLONG:
4115     case FFEINTRIN_impREAL:
4116     case FFEINTRIN_impSHORT:
4117     case FFEINTRIN_impSNGL:
4118       return convert (tree_type, ffecom_expr (arg1));
4119
4120     case FFEINTRIN_impDIM:
4121     case FFEINTRIN_impDDIM:
4122     case FFEINTRIN_impIDIM:
4123       saved_expr1 = ffecom_save_tree (convert (tree_type,
4124                                                ffecom_expr (arg1)));
4125       saved_expr2 = ffecom_save_tree (convert (tree_type,
4126                                                ffecom_expr (arg2)));
4127       return
4128         ffecom_3 (COND_EXPR, tree_type,
4129                   ffecom_truth_value
4130                   (ffecom_2 (GT_EXPR, integer_type_node,
4131                              saved_expr1,
4132                              saved_expr2)),
4133                   ffecom_2 (MINUS_EXPR, tree_type,
4134                             saved_expr1,
4135                             saved_expr2),
4136                   convert (tree_type, ffecom_float_zero_));
4137
4138     case FFEINTRIN_impDPROD:
4139       return
4140         ffecom_2 (MULT_EXPR, tree_type,
4141                   convert (tree_type, ffecom_expr (arg1)),
4142                   convert (tree_type, ffecom_expr (arg2)));
4143
4144     case FFEINTRIN_impEXP:
4145     case FFEINTRIN_impCDEXP:
4146     case FFEINTRIN_impCEXP:
4147     case FFEINTRIN_impDEXP:
4148       if (bt == FFEINFO_basictypeCOMPLEX)
4149         {
4150           if (kt == FFEINFO_kindtypeREAL1)
4151             gfrt = FFECOM_gfrtCEXP;     /* Overlapping result okay. */
4152           else if (kt == FFEINFO_kindtypeREAL2)
4153             gfrt = FFECOM_gfrtCDEXP;    /* Overlapping result okay. */
4154         }
4155       break;
4156
4157     case FFEINTRIN_impICHAR:
4158     case FFEINTRIN_impIACHAR:
4159 #if 0                           /* The simple approach. */
4160       ffecom_char_args_ (&expr_tree, &saved_expr1 /* Ignored */ , arg1);
4161       expr_tree
4162         = ffecom_1 (INDIRECT_REF,
4163                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4164                     expr_tree);
4165       expr_tree
4166         = ffecom_2 (ARRAY_REF,
4167                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4168                     expr_tree,
4169                     integer_one_node);
4170       return convert (tree_type, expr_tree);
4171 #else /* The more interesting (and more optimal) approach. */
4172       expr_tree = ffecom_intrinsic_ichar_ (tree_type, arg1, &saved_expr1);
4173       expr_tree = ffecom_3 (COND_EXPR, tree_type,
4174                             saved_expr1,
4175                             expr_tree,
4176                             convert (tree_type, integer_zero_node));
4177       return expr_tree;
4178 #endif
4179
4180     case FFEINTRIN_impINDEX:
4181       break;
4182
4183     case FFEINTRIN_impLEN:
4184 #if 0
4185       break;                                    /* The simple approach. */
4186 #else
4187       return ffecom_intrinsic_len_ (arg1);      /* The more optimal approach. */
4188 #endif
4189
4190     case FFEINTRIN_impLGE:
4191     case FFEINTRIN_impLGT:
4192     case FFEINTRIN_impLLE:
4193     case FFEINTRIN_impLLT:
4194       break;
4195
4196     case FFEINTRIN_impLOG:
4197     case FFEINTRIN_impALOG:
4198     case FFEINTRIN_impCDLOG:
4199     case FFEINTRIN_impCLOG:
4200     case FFEINTRIN_impDLOG:
4201       if (bt == FFEINFO_basictypeCOMPLEX)
4202         {
4203           if (kt == FFEINFO_kindtypeREAL1)
4204             gfrt = FFECOM_gfrtCLOG;     /* Overlapping result okay. */
4205           else if (kt == FFEINFO_kindtypeREAL2)
4206             gfrt = FFECOM_gfrtCDLOG;    /* Overlapping result okay. */
4207         }
4208       break;
4209
4210     case FFEINTRIN_impLOG10:
4211     case FFEINTRIN_impALOG10:
4212     case FFEINTRIN_impDLOG10:
4213       if (gfrt != FFECOM_gfrt)
4214         break;  /* Already picked one, stick with it. */
4215
4216       if (kt == FFEINFO_kindtypeREAL1)
4217         /* We used to call FFECOM_gfrtALOG10 here.  */
4218         gfrt = FFECOM_gfrtL_LOG10;
4219       else if (kt == FFEINFO_kindtypeREAL2)
4220         /* We used to call FFECOM_gfrtDLOG10 here.  */
4221         gfrt = FFECOM_gfrtL_LOG10;
4222       break;
4223
4224     case FFEINTRIN_impMAX:
4225     case FFEINTRIN_impAMAX0:
4226     case FFEINTRIN_impAMAX1:
4227     case FFEINTRIN_impDMAX1:
4228     case FFEINTRIN_impMAX0:
4229     case FFEINTRIN_impMAX1:
4230       if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4231         arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4232       else
4233         arg1_type = tree_type;
4234       expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4235                             convert (arg1_type, ffecom_expr (arg1)),
4236                             convert (arg1_type, ffecom_expr (arg2)));
4237       for (; list != NULL; list = ffebld_trail (list))
4238         {
4239           if ((ffebld_head (list) == NULL)
4240               || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4241             continue;
4242           expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4243                                 expr_tree,
4244                                 convert (arg1_type,
4245                                          ffecom_expr (ffebld_head (list))));
4246         }
4247       return convert (tree_type, expr_tree);
4248
4249     case FFEINTRIN_impMIN:
4250     case FFEINTRIN_impAMIN0:
4251     case FFEINTRIN_impAMIN1:
4252     case FFEINTRIN_impDMIN1:
4253     case FFEINTRIN_impMIN0:
4254     case FFEINTRIN_impMIN1:
4255       if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4256         arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4257       else
4258         arg1_type = tree_type;
4259       expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4260                             convert (arg1_type, ffecom_expr (arg1)),
4261                             convert (arg1_type, ffecom_expr (arg2)));
4262       for (; list != NULL; list = ffebld_trail (list))
4263         {
4264           if ((ffebld_head (list) == NULL)
4265               || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4266             continue;
4267           expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4268                                 expr_tree,
4269                                 convert (arg1_type,
4270                                          ffecom_expr (ffebld_head (list))));
4271         }
4272       return convert (tree_type, expr_tree);
4273
4274     case FFEINTRIN_impMOD:
4275     case FFEINTRIN_impAMOD:
4276     case FFEINTRIN_impDMOD:
4277       if (bt != FFEINFO_basictypeREAL)
4278         return ffecom_2 (TRUNC_MOD_EXPR, tree_type,
4279                          convert (tree_type, ffecom_expr (arg1)),
4280                          convert (tree_type, ffecom_expr (arg2)));
4281
4282       if (kt == FFEINFO_kindtypeREAL1)
4283         /* We used to call FFECOM_gfrtAMOD here.  */
4284         gfrt = FFECOM_gfrtL_FMOD;
4285       else if (kt == FFEINFO_kindtypeREAL2)
4286         /* We used to call FFECOM_gfrtDMOD here.  */
4287         gfrt = FFECOM_gfrtL_FMOD;
4288       break;
4289
4290     case FFEINTRIN_impNINT:
4291     case FFEINTRIN_impIDNINT:
4292 #if 0
4293       /* ~~Ideally FIX_ROUND_EXPR would be implemented, but it ain't yet.  */
4294       return ffecom_1 (FIX_ROUND_EXPR, tree_type, ffecom_expr (arg1));
4295 #else
4296       /* i__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1); */
4297       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4298       return
4299         convert (ffecom_integer_type_node,
4300                  ffecom_3 (COND_EXPR, arg1_type,
4301                            ffecom_truth_value
4302                            (ffecom_2 (GE_EXPR, integer_type_node,
4303                                       saved_expr1,
4304                                       convert (arg1_type,
4305                                                ffecom_float_zero_))),
4306                            ffecom_2 (PLUS_EXPR, arg1_type,
4307                                      saved_expr1,
4308                                      convert (arg1_type,
4309                                               ffecom_float_half_)),
4310                            ffecom_2 (MINUS_EXPR, arg1_type,
4311                                      saved_expr1,
4312                                      convert (arg1_type,
4313                                               ffecom_float_half_))));
4314 #endif
4315
4316     case FFEINTRIN_impSIGN:
4317     case FFEINTRIN_impDSIGN:
4318     case FFEINTRIN_impISIGN:
4319       {
4320         tree arg2_tree = ffecom_expr (arg2);
4321
4322         saved_expr1
4323           = ffecom_save_tree
4324           (ffecom_1 (ABS_EXPR, tree_type,
4325                      convert (tree_type,
4326                               ffecom_expr (arg1))));
4327         expr_tree
4328           = ffecom_3 (COND_EXPR, tree_type,
4329                       ffecom_truth_value
4330                       (ffecom_2 (GE_EXPR, integer_type_node,
4331                                  arg2_tree,
4332                                  convert (TREE_TYPE (arg2_tree),
4333                                           integer_zero_node))),
4334                       saved_expr1,
4335                       ffecom_1 (NEGATE_EXPR, tree_type, saved_expr1));
4336         /* Make sure SAVE_EXPRs get referenced early enough. */
4337         expr_tree
4338           = ffecom_2 (COMPOUND_EXPR, tree_type,
4339                       convert (void_type_node, saved_expr1),
4340                       expr_tree);
4341       }
4342       return expr_tree;
4343
4344     case FFEINTRIN_impSIN:
4345     case FFEINTRIN_impCDSIN:
4346     case FFEINTRIN_impCSIN:
4347     case FFEINTRIN_impDSIN:
4348       if (bt == FFEINFO_basictypeCOMPLEX)
4349         {
4350           if (kt == FFEINFO_kindtypeREAL1)
4351             gfrt = FFECOM_gfrtCSIN;     /* Overlapping result okay. */
4352           else if (kt == FFEINFO_kindtypeREAL2)
4353             gfrt = FFECOM_gfrtCDSIN;    /* Overlapping result okay. */
4354         }
4355       break;
4356
4357     case FFEINTRIN_impSINH:
4358     case FFEINTRIN_impDSINH:
4359       break;
4360
4361     case FFEINTRIN_impSQRT:
4362     case FFEINTRIN_impCDSQRT:
4363     case FFEINTRIN_impCSQRT:
4364     case FFEINTRIN_impDSQRT:
4365       if (bt == FFEINFO_basictypeCOMPLEX)
4366         {
4367           if (kt == FFEINFO_kindtypeREAL1)
4368             gfrt = FFECOM_gfrtCSQRT;    /* Overlapping result okay. */
4369           else if (kt == FFEINFO_kindtypeREAL2)
4370             gfrt = FFECOM_gfrtCDSQRT;   /* Overlapping result okay. */
4371         }
4372       break;
4373
4374     case FFEINTRIN_impTAN:
4375     case FFEINTRIN_impDTAN:
4376     case FFEINTRIN_impTANH:
4377     case FFEINTRIN_impDTANH:
4378       break;
4379
4380     case FFEINTRIN_impREALPART:
4381       if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
4382         arg1_type = TREE_TYPE (arg1_type);
4383       else
4384         arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
4385
4386       return
4387         convert (tree_type,
4388                  ffecom_1 (REALPART_EXPR, arg1_type,
4389                            ffecom_expr (arg1)));
4390
4391     case FFEINTRIN_impIAND:
4392     case FFEINTRIN_impAND:
4393       return ffecom_2 (BIT_AND_EXPR, tree_type,
4394                        convert (tree_type,
4395                                 ffecom_expr (arg1)),
4396                        convert (tree_type,
4397                                 ffecom_expr (arg2)));
4398
4399     case FFEINTRIN_impIOR:
4400     case FFEINTRIN_impOR:
4401       return ffecom_2 (BIT_IOR_EXPR, tree_type,
4402                        convert (tree_type,
4403                                 ffecom_expr (arg1)),
4404                        convert (tree_type,
4405                                 ffecom_expr (arg2)));
4406
4407     case FFEINTRIN_impIEOR:
4408     case FFEINTRIN_impXOR:
4409       return ffecom_2 (BIT_XOR_EXPR, tree_type,
4410                        convert (tree_type,
4411                                 ffecom_expr (arg1)),
4412                        convert (tree_type,
4413                                 ffecom_expr (arg2)));
4414
4415     case FFEINTRIN_impLSHIFT:
4416       return ffecom_2 (LSHIFT_EXPR, tree_type,
4417                        ffecom_expr (arg1),
4418                        convert (integer_type_node,
4419                                 ffecom_expr (arg2)));
4420
4421     case FFEINTRIN_impRSHIFT:
4422       return ffecom_2 (RSHIFT_EXPR, tree_type,
4423                        ffecom_expr (arg1),
4424                        convert (integer_type_node,
4425                                 ffecom_expr (arg2)));
4426
4427     case FFEINTRIN_impNOT:
4428       return ffecom_1 (BIT_NOT_EXPR, tree_type, ffecom_expr (arg1));
4429
4430     case FFEINTRIN_impBIT_SIZE:
4431       return convert (tree_type, TYPE_SIZE (arg1_type));
4432
4433     case FFEINTRIN_impBTEST:
4434       {
4435         ffetargetLogical1 target_true;
4436         ffetargetLogical1 target_false;
4437         tree true_tree;
4438         tree false_tree;
4439
4440         ffetarget_logical1 (&target_true, TRUE);
4441         ffetarget_logical1 (&target_false, FALSE);
4442         if (target_true == 1)
4443           true_tree = convert (tree_type, integer_one_node);
4444         else
4445           true_tree = convert (tree_type, build_int_2 (target_true, 0));
4446         if (target_false == 0)
4447           false_tree = convert (tree_type, integer_zero_node);
4448         else
4449           false_tree = convert (tree_type, build_int_2 (target_false, 0));
4450
4451         return
4452           ffecom_3 (COND_EXPR, tree_type,
4453                     ffecom_truth_value
4454                     (ffecom_2 (EQ_EXPR, integer_type_node,
4455                                ffecom_2 (BIT_AND_EXPR, arg1_type,
4456                                          ffecom_expr (arg1),
4457                                          ffecom_2 (LSHIFT_EXPR, arg1_type,
4458                                                    convert (arg1_type,
4459                                                           integer_one_node),
4460                                                    convert (integer_type_node,
4461                                                             ffecom_expr (arg2)))),
4462                                convert (arg1_type,
4463                                         integer_zero_node))),
4464                     false_tree,
4465                     true_tree);
4466       }
4467
4468     case FFEINTRIN_impIBCLR:
4469       return
4470         ffecom_2 (BIT_AND_EXPR, tree_type,
4471                   ffecom_expr (arg1),
4472                   ffecom_1 (BIT_NOT_EXPR, tree_type,
4473                             ffecom_2 (LSHIFT_EXPR, tree_type,
4474                                       convert (tree_type,
4475                                                integer_one_node),
4476                                       convert (integer_type_node,
4477                                                ffecom_expr (arg2)))));
4478
4479     case FFEINTRIN_impIBITS:
4480       {
4481         tree arg3_tree = ffecom_save_tree (convert (integer_type_node,
4482                                                     ffecom_expr (arg3)));
4483         tree uns_type
4484         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4485
4486         expr_tree
4487           = ffecom_2 (BIT_AND_EXPR, tree_type,
4488                       ffecom_2 (RSHIFT_EXPR, tree_type,
4489                                 ffecom_expr (arg1),
4490                                 convert (integer_type_node,
4491                                          ffecom_expr (arg2))),
4492                       convert (tree_type,
4493                                ffecom_2 (RSHIFT_EXPR, uns_type,
4494                                          ffecom_1 (BIT_NOT_EXPR,
4495                                                    uns_type,
4496                                                    convert (uns_type,
4497                                                         integer_zero_node)),
4498                                          ffecom_2 (MINUS_EXPR,
4499                                                    integer_type_node,
4500                                                    TYPE_SIZE (uns_type),
4501                                                    arg3_tree))));
4502         /* Fix up, because the RSHIFT_EXPR above can't shift over TYPE_SIZE.  */
4503         expr_tree
4504           = ffecom_3 (COND_EXPR, tree_type,
4505                       ffecom_truth_value
4506                       (ffecom_2 (NE_EXPR, integer_type_node,
4507                                  arg3_tree,
4508                                  integer_zero_node)),
4509                       expr_tree,
4510                       convert (tree_type, integer_zero_node));
4511       }
4512       return expr_tree;
4513
4514     case FFEINTRIN_impIBSET:
4515       return
4516         ffecom_2 (BIT_IOR_EXPR, tree_type,
4517                   ffecom_expr (arg1),
4518                   ffecom_2 (LSHIFT_EXPR, tree_type,
4519                             convert (tree_type, integer_one_node),
4520                             convert (integer_type_node,
4521                                      ffecom_expr (arg2))));
4522
4523     case FFEINTRIN_impISHFT:
4524       {
4525         tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4526         tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4527                                                     ffecom_expr (arg2)));
4528         tree uns_type
4529         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4530
4531         expr_tree
4532           = ffecom_3 (COND_EXPR, tree_type,
4533                       ffecom_truth_value
4534                       (ffecom_2 (GE_EXPR, integer_type_node,
4535                                  arg2_tree,
4536                                  integer_zero_node)),
4537                       ffecom_2 (LSHIFT_EXPR, tree_type,
4538                                 arg1_tree,
4539                                 arg2_tree),
4540                       convert (tree_type,
4541                                ffecom_2 (RSHIFT_EXPR, uns_type,
4542                                          convert (uns_type, arg1_tree),
4543                                          ffecom_1 (NEGATE_EXPR,
4544                                                    integer_type_node,
4545                                                    arg2_tree))));
4546         /* Fix up, because {L|R}SHIFT_EXPR don't go over TYPE_SIZE bounds.  */
4547         expr_tree
4548           = ffecom_3 (COND_EXPR, tree_type,
4549                       ffecom_truth_value
4550                       (ffecom_2 (NE_EXPR, integer_type_node,
4551                                  ffecom_1 (ABS_EXPR,
4552                                            integer_type_node,
4553                                            arg2_tree),
4554                                  TYPE_SIZE (uns_type))),
4555                       expr_tree,
4556                       convert (tree_type, integer_zero_node));
4557         /* Make sure SAVE_EXPRs get referenced early enough. */
4558         expr_tree
4559           = ffecom_2 (COMPOUND_EXPR, tree_type,
4560                       convert (void_type_node, arg1_tree),
4561                       ffecom_2 (COMPOUND_EXPR, tree_type,
4562                                 convert (void_type_node, arg2_tree),
4563                                 expr_tree));
4564       }
4565       return expr_tree;
4566
4567     case FFEINTRIN_impISHFTC:
4568       {
4569         tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4570         tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4571                                                     ffecom_expr (arg2)));
4572         tree arg3_tree = (arg3 == NULL) ? TYPE_SIZE (tree_type)
4573         : ffecom_save_tree (convert (integer_type_node, ffecom_expr (arg3)));
4574         tree shift_neg;
4575         tree shift_pos;
4576         tree mask_arg1;
4577         tree masked_arg1;
4578         tree uns_type
4579         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4580
4581         mask_arg1
4582           = ffecom_2 (LSHIFT_EXPR, tree_type,
4583                       ffecom_1 (BIT_NOT_EXPR, tree_type,
4584                                 convert (tree_type, integer_zero_node)),
4585                       arg3_tree);
4586         /* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE.  */
4587         mask_arg1
4588           = ffecom_3 (COND_EXPR, tree_type,
4589                       ffecom_truth_value
4590                       (ffecom_2 (NE_EXPR, integer_type_node,
4591                                  arg3_tree,
4592                                  TYPE_SIZE (uns_type))),
4593                       mask_arg1,
4594                       convert (tree_type, integer_zero_node));
4595         mask_arg1 = ffecom_save_tree (mask_arg1);
4596         masked_arg1
4597           = ffecom_2 (BIT_AND_EXPR, tree_type,
4598                       arg1_tree,
4599                       ffecom_1 (BIT_NOT_EXPR, tree_type,
4600                                 mask_arg1));
4601         masked_arg1 = ffecom_save_tree (masked_arg1);
4602         shift_neg
4603           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4604                       convert (tree_type,
4605                                ffecom_2 (RSHIFT_EXPR, uns_type,
4606                                          convert (uns_type, masked_arg1),
4607                                          ffecom_1 (NEGATE_EXPR,
4608                                                    integer_type_node,
4609                                                    arg2_tree))),
4610                       ffecom_2 (LSHIFT_EXPR, tree_type,
4611                                 arg1_tree,
4612                                 ffecom_2 (PLUS_EXPR, integer_type_node,
4613                                           arg2_tree,
4614                                           arg3_tree)));
4615         shift_pos
4616           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4617                       ffecom_2 (LSHIFT_EXPR, tree_type,
4618                                 arg1_tree,
4619                                 arg2_tree),
4620                       convert (tree_type,
4621                                ffecom_2 (RSHIFT_EXPR, uns_type,
4622                                          convert (uns_type, masked_arg1),
4623                                          ffecom_2 (MINUS_EXPR,
4624                                                    integer_type_node,
4625                                                    arg3_tree,
4626                                                    arg2_tree))));
4627         expr_tree
4628           = ffecom_3 (COND_EXPR, tree_type,
4629                       ffecom_truth_value
4630                       (ffecom_2 (LT_EXPR, integer_type_node,
4631                                  arg2_tree,
4632                                  integer_zero_node)),
4633                       shift_neg,
4634                       shift_pos);
4635         expr_tree
4636           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4637                       ffecom_2 (BIT_AND_EXPR, tree_type,
4638                                 mask_arg1,
4639                                 arg1_tree),
4640                       ffecom_2 (BIT_AND_EXPR, tree_type,
4641                                 ffecom_1 (BIT_NOT_EXPR, tree_type,
4642                                           mask_arg1),
4643                                 expr_tree));
4644         expr_tree
4645           = ffecom_3 (COND_EXPR, tree_type,
4646                       ffecom_truth_value
4647                       (ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
4648                                  ffecom_2 (EQ_EXPR, integer_type_node,
4649                                            ffecom_1 (ABS_EXPR,
4650                                                      integer_type_node,
4651                                                      arg2_tree),
4652                                            arg3_tree),
4653                                  ffecom_2 (EQ_EXPR, integer_type_node,
4654                                            arg2_tree,
4655                                            integer_zero_node))),
4656                       arg1_tree,
4657                       expr_tree);
4658         /* Make sure SAVE_EXPRs get referenced early enough. */
4659         expr_tree
4660           = ffecom_2 (COMPOUND_EXPR, tree_type,
4661                       convert (void_type_node, arg1_tree),
4662                       ffecom_2 (COMPOUND_EXPR, tree_type,
4663                                 convert (void_type_node, arg2_tree),
4664                                 ffecom_2 (COMPOUND_EXPR, tree_type,
4665                                           convert (void_type_node,
4666                                                    mask_arg1),
4667                                           ffecom_2 (COMPOUND_EXPR, tree_type,
4668                                                     convert (void_type_node,
4669                                                              masked_arg1),
4670                                                     expr_tree))));
4671         expr_tree
4672           = ffecom_2 (COMPOUND_EXPR, tree_type,
4673                       convert (void_type_node,
4674                                arg3_tree),
4675                       expr_tree);
4676       }
4677       return expr_tree;
4678
4679     case FFEINTRIN_impLOC:
4680       {
4681         tree arg1_tree = ffecom_expr (arg1);
4682
4683         expr_tree
4684           = convert (tree_type,
4685                      ffecom_1 (ADDR_EXPR,
4686                                build_pointer_type (TREE_TYPE (arg1_tree)),
4687                                arg1_tree));
4688       }
4689       return expr_tree;
4690
4691     case FFEINTRIN_impMVBITS:
4692       {
4693         tree arg1_tree;
4694         tree arg2_tree;
4695         tree arg3_tree;
4696         ffebld arg4 = ffebld_head (ffebld_trail (list));
4697         tree arg4_tree;
4698         tree arg4_type;
4699         ffebld arg5 = ffebld_head (ffebld_trail (ffebld_trail (list)));
4700         tree arg5_tree;
4701         tree prep_arg1;
4702         tree prep_arg4;
4703         tree arg5_plus_arg3;
4704
4705         arg2_tree = convert (integer_type_node,
4706                              ffecom_expr (arg2));
4707         arg3_tree = ffecom_save_tree (convert (integer_type_node,
4708                                                ffecom_expr (arg3)));
4709         arg4_tree = ffecom_expr_rw (NULL_TREE, arg4);
4710         arg4_type = TREE_TYPE (arg4_tree);
4711
4712         arg1_tree = ffecom_save_tree (convert (arg4_type,
4713                                                ffecom_expr (arg1)));
4714
4715         arg5_tree = ffecom_save_tree (convert (integer_type_node,
4716                                                ffecom_expr (arg5)));
4717
4718         prep_arg1
4719           = ffecom_2 (LSHIFT_EXPR, arg4_type,
4720                       ffecom_2 (BIT_AND_EXPR, arg4_type,
4721                                 ffecom_2 (RSHIFT_EXPR, arg4_type,
4722                                           arg1_tree,
4723                                           arg2_tree),
4724                                 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4725                                           ffecom_2 (LSHIFT_EXPR, arg4_type,
4726                                                     ffecom_1 (BIT_NOT_EXPR,
4727                                                               arg4_type,
4728                                                               convert
4729                                                               (arg4_type,
4730                                                         integer_zero_node)),
4731                                                     arg3_tree))),
4732                       arg5_tree);
4733         arg5_plus_arg3
4734           = ffecom_save_tree (ffecom_2 (PLUS_EXPR, arg4_type,
4735                                         arg5_tree,
4736                                         arg3_tree));
4737         prep_arg4
4738           = ffecom_2 (LSHIFT_EXPR, arg4_type,
4739                       ffecom_1 (BIT_NOT_EXPR, arg4_type,
4740                                 convert (arg4_type,
4741                                          integer_zero_node)),
4742                       arg5_plus_arg3);
4743         /* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE.  */
4744         prep_arg4
4745           = ffecom_3 (COND_EXPR, arg4_type,
4746                       ffecom_truth_value
4747                       (ffecom_2 (NE_EXPR, integer_type_node,
4748                                  arg5_plus_arg3,
4749                                  convert (TREE_TYPE (arg5_plus_arg3),
4750                                           TYPE_SIZE (arg4_type)))),
4751                       prep_arg4,
4752                       convert (arg4_type, integer_zero_node));
4753         prep_arg4
4754           = ffecom_2 (BIT_AND_EXPR, arg4_type,
4755                       arg4_tree,
4756                       ffecom_2 (BIT_IOR_EXPR, arg4_type,
4757                                 prep_arg4,
4758                                 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4759                                           ffecom_2 (LSHIFT_EXPR, arg4_type,
4760                                                     ffecom_1 (BIT_NOT_EXPR,
4761                                                               arg4_type,
4762                                                               convert
4763                                                               (arg4_type,
4764                                                         integer_zero_node)),
4765                                                     arg5_tree))));
4766         prep_arg1
4767           = ffecom_2 (BIT_IOR_EXPR, arg4_type,
4768                       prep_arg1,
4769                       prep_arg4);
4770         /* Fix up (twice), because LSHIFT_EXPR above
4771            can't shift over TYPE_SIZE.  */
4772         prep_arg1
4773           = ffecom_3 (COND_EXPR, arg4_type,
4774                       ffecom_truth_value
4775                       (ffecom_2 (NE_EXPR, integer_type_node,
4776                                  arg3_tree,
4777                                  convert (TREE_TYPE (arg3_tree),
4778                                           integer_zero_node))),
4779                       prep_arg1,
4780                       arg4_tree);
4781         prep_arg1
4782           = ffecom_3 (COND_EXPR, arg4_type,
4783                       ffecom_truth_value
4784                       (ffecom_2 (NE_EXPR, integer_type_node,
4785                                  arg3_tree,
4786                                  convert (TREE_TYPE (arg3_tree),
4787                                           TYPE_SIZE (arg4_type)))),
4788                       prep_arg1,
4789                       arg1_tree);
4790         expr_tree
4791           = ffecom_2s (MODIFY_EXPR, void_type_node,
4792                        arg4_tree,
4793                        prep_arg1);
4794         /* Make sure SAVE_EXPRs get referenced early enough. */
4795         expr_tree
4796           = ffecom_2 (COMPOUND_EXPR, void_type_node,
4797                       arg1_tree,
4798                       ffecom_2 (COMPOUND_EXPR, void_type_node,
4799                                 arg3_tree,
4800                                 ffecom_2 (COMPOUND_EXPR, void_type_node,
4801                                           arg5_tree,
4802                                           ffecom_2 (COMPOUND_EXPR, void_type_node,
4803                                                     arg5_plus_arg3,
4804                                                     expr_tree))));
4805         expr_tree
4806           = ffecom_2 (COMPOUND_EXPR, void_type_node,
4807                       arg4_tree,
4808                       expr_tree);
4809
4810       }
4811       return expr_tree;
4812
4813     case FFEINTRIN_impDERF:
4814     case FFEINTRIN_impERF:
4815     case FFEINTRIN_impDERFC:
4816     case FFEINTRIN_impERFC:
4817       break;
4818
4819     case FFEINTRIN_impIARGC:
4820       /* extern int xargc; i__1 = xargc - 1; */
4821       expr_tree = ffecom_2 (MINUS_EXPR, TREE_TYPE (ffecom_tree_xargc_),
4822                             ffecom_tree_xargc_,
4823                             convert (TREE_TYPE (ffecom_tree_xargc_),
4824                                      integer_one_node));
4825       return expr_tree;
4826
4827     case FFEINTRIN_impSIGNAL_func:
4828     case FFEINTRIN_impSIGNAL_subr:
4829       {
4830         tree arg1_tree;
4831         tree arg2_tree;
4832         tree arg3_tree;
4833
4834         arg1_tree = convert (ffecom_f2c_integer_type_node,
4835                              ffecom_expr (arg1));
4836         arg1_tree = ffecom_1 (ADDR_EXPR,
4837                               build_pointer_type (TREE_TYPE (arg1_tree)),
4838                               arg1_tree);
4839
4840         /* Pass procedure as a pointer to it, anything else by value.  */
4841         if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
4842           arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
4843         else
4844           arg2_tree = ffecom_ptr_to_expr (arg2);
4845         arg2_tree = convert (TREE_TYPE (null_pointer_node),
4846                              arg2_tree);
4847
4848         if (arg3 != NULL)
4849           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
4850         else
4851           arg3_tree = NULL_TREE;
4852
4853         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4854         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4855         TREE_CHAIN (arg1_tree) = arg2_tree;
4856
4857         expr_tree
4858           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4859                           ffecom_gfrt_kindtype (gfrt),
4860                           FALSE,
4861                           ((codegen_imp == FFEINTRIN_impSIGNAL_subr) ?
4862                            NULL_TREE :
4863                            tree_type),
4864                           arg1_tree,
4865                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4866                           ffebld_nonter_hook (expr));
4867
4868         if (arg3_tree != NULL_TREE)
4869           expr_tree
4870             = ffecom_modify (NULL_TREE, arg3_tree,
4871                              convert (TREE_TYPE (arg3_tree),
4872                                       expr_tree));
4873       }
4874       return expr_tree;
4875
4876     case FFEINTRIN_impALARM:
4877       {
4878         tree arg1_tree;
4879         tree arg2_tree;
4880         tree arg3_tree;
4881
4882         arg1_tree = convert (ffecom_f2c_integer_type_node,
4883                              ffecom_expr (arg1));
4884         arg1_tree = ffecom_1 (ADDR_EXPR,
4885                               build_pointer_type (TREE_TYPE (arg1_tree)),
4886                               arg1_tree);
4887
4888         /* Pass procedure as a pointer to it, anything else by value.  */
4889         if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
4890           arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
4891         else
4892           arg2_tree = ffecom_ptr_to_expr (arg2);
4893         arg2_tree = convert (TREE_TYPE (null_pointer_node),
4894                              arg2_tree);
4895
4896         if (arg3 != NULL)
4897           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
4898         else
4899           arg3_tree = NULL_TREE;
4900
4901         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4902         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4903         TREE_CHAIN (arg1_tree) = arg2_tree;
4904
4905         expr_tree
4906           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4907                           ffecom_gfrt_kindtype (gfrt),
4908                           FALSE,
4909                           NULL_TREE,
4910                           arg1_tree,
4911                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4912                           ffebld_nonter_hook (expr));
4913
4914         if (arg3_tree != NULL_TREE)
4915           expr_tree
4916             = ffecom_modify (NULL_TREE, arg3_tree,
4917                              convert (TREE_TYPE (arg3_tree),
4918                                       expr_tree));
4919       }
4920       return expr_tree;
4921
4922     case FFEINTRIN_impCHDIR_subr:
4923     case FFEINTRIN_impFDATE_subr:
4924     case FFEINTRIN_impFGET_subr:
4925     case FFEINTRIN_impFPUT_subr:
4926     case FFEINTRIN_impGETCWD_subr:
4927     case FFEINTRIN_impHOSTNM_subr:
4928     case FFEINTRIN_impSYSTEM_subr:
4929     case FFEINTRIN_impUNLINK_subr:
4930       {
4931         tree arg1_len = integer_zero_node;
4932         tree arg1_tree;
4933         tree arg2_tree;
4934
4935         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
4936
4937         if (arg2 != NULL)
4938           arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
4939         else
4940           arg2_tree = NULL_TREE;
4941
4942         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4943         arg1_len = build_tree_list (NULL_TREE, arg1_len);
4944         TREE_CHAIN (arg1_tree) = arg1_len;
4945
4946         expr_tree
4947           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4948                           ffecom_gfrt_kindtype (gfrt),
4949                           FALSE,
4950                           NULL_TREE,
4951                           arg1_tree,
4952                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4953                           ffebld_nonter_hook (expr));
4954
4955         if (arg2_tree != NULL_TREE)
4956           expr_tree
4957             = ffecom_modify (NULL_TREE, arg2_tree,
4958                              convert (TREE_TYPE (arg2_tree),
4959                                       expr_tree));
4960       }
4961       return expr_tree;
4962
4963     case FFEINTRIN_impEXIT:
4964       if (arg1 != NULL)
4965         break;
4966
4967       expr_tree = build_tree_list (NULL_TREE,
4968                                    ffecom_1 (ADDR_EXPR,
4969                                              build_pointer_type
4970                                              (ffecom_integer_type_node),
4971                                              integer_zero_node));
4972
4973       return
4974         ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4975                       ffecom_gfrt_kindtype (gfrt),
4976                       FALSE,
4977                       void_type_node,
4978                       expr_tree,
4979                       NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4980                       ffebld_nonter_hook (expr));
4981
4982     case FFEINTRIN_impFLUSH:
4983       if (arg1 == NULL)
4984         gfrt = FFECOM_gfrtFLUSH;
4985       else
4986         gfrt = FFECOM_gfrtFLUSH1;
4987       break;
4988
4989     case FFEINTRIN_impCHMOD_subr:
4990     case FFEINTRIN_impLINK_subr:
4991     case FFEINTRIN_impRENAME_subr:
4992     case FFEINTRIN_impSYMLNK_subr:
4993       {
4994         tree arg1_len = integer_zero_node;
4995         tree arg1_tree;
4996         tree arg2_len = integer_zero_node;
4997         tree arg2_tree;
4998         tree arg3_tree;
4999
5000         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5001         arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
5002         if (arg3 != NULL)
5003           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5004         else
5005           arg3_tree = NULL_TREE;
5006
5007         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5008         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5009         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5010         arg2_len = build_tree_list (NULL_TREE, arg2_len);
5011         TREE_CHAIN (arg1_tree) = arg2_tree;
5012         TREE_CHAIN (arg2_tree) = arg1_len;
5013         TREE_CHAIN (arg1_len) = arg2_len;
5014         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5015                                   ffecom_gfrt_kindtype (gfrt),
5016                                   FALSE,
5017                                   NULL_TREE,
5018                                   arg1_tree,
5019                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5020                                   ffebld_nonter_hook (expr));
5021         if (arg3_tree != NULL_TREE)
5022           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5023                                      convert (TREE_TYPE (arg3_tree),
5024                                               expr_tree));
5025       }
5026       return expr_tree;
5027
5028     case FFEINTRIN_impLSTAT_subr:
5029     case FFEINTRIN_impSTAT_subr:
5030       {
5031         tree arg1_len = integer_zero_node;
5032         tree arg1_tree;
5033         tree arg2_tree;
5034         tree arg3_tree;
5035
5036         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5037
5038         arg2_tree = ffecom_ptr_to_expr (arg2);
5039
5040         if (arg3 != NULL)
5041           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5042         else
5043           arg3_tree = NULL_TREE;
5044
5045         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5046         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5047         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5048         TREE_CHAIN (arg1_tree) = arg2_tree;
5049         TREE_CHAIN (arg2_tree) = arg1_len;
5050         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5051                                   ffecom_gfrt_kindtype (gfrt),
5052                                   FALSE,
5053                                   NULL_TREE,
5054                                   arg1_tree,
5055                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5056                                   ffebld_nonter_hook (expr));
5057         if (arg3_tree != NULL_TREE)
5058           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5059                                      convert (TREE_TYPE (arg3_tree),
5060                                               expr_tree));
5061       }
5062       return expr_tree;
5063
5064     case FFEINTRIN_impFGETC_subr:
5065     case FFEINTRIN_impFPUTC_subr:
5066       {
5067         tree arg1_tree;
5068         tree arg2_tree;
5069         tree arg2_len = integer_zero_node;
5070         tree arg3_tree;
5071
5072         arg1_tree = convert (ffecom_f2c_integer_type_node,
5073                              ffecom_expr (arg1));
5074         arg1_tree = ffecom_1 (ADDR_EXPR,
5075                               build_pointer_type (TREE_TYPE (arg1_tree)),
5076                               arg1_tree);
5077
5078         arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
5079         if (arg3 != NULL)
5080           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5081         else
5082           arg3_tree = NULL_TREE;
5083
5084         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5085         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5086         arg2_len = build_tree_list (NULL_TREE, arg2_len);
5087         TREE_CHAIN (arg1_tree) = arg2_tree;
5088         TREE_CHAIN (arg2_tree) = arg2_len;
5089
5090         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5091                                   ffecom_gfrt_kindtype (gfrt),
5092                                   FALSE,
5093                                   NULL_TREE,
5094                                   arg1_tree,
5095                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5096                                   ffebld_nonter_hook (expr));
5097         if (arg3_tree != NULL_TREE)
5098           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5099                                      convert (TREE_TYPE (arg3_tree),
5100                                               expr_tree));
5101       }
5102       return expr_tree;
5103
5104     case FFEINTRIN_impFSTAT_subr:
5105       {
5106         tree arg1_tree;
5107         tree arg2_tree;
5108         tree arg3_tree;
5109
5110         arg1_tree = convert (ffecom_f2c_integer_type_node,
5111                              ffecom_expr (arg1));
5112         arg1_tree = ffecom_1 (ADDR_EXPR,
5113                               build_pointer_type (TREE_TYPE (arg1_tree)),
5114                               arg1_tree);
5115
5116         arg2_tree = convert (ffecom_f2c_ptr_to_integer_type_node,
5117                              ffecom_ptr_to_expr (arg2));
5118
5119         if (arg3 == NULL)
5120           arg3_tree = NULL_TREE;
5121         else
5122           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5123
5124         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5125         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5126         TREE_CHAIN (arg1_tree) = arg2_tree;
5127         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5128                                   ffecom_gfrt_kindtype (gfrt),
5129                                   FALSE,
5130                                   NULL_TREE,
5131                                   arg1_tree,
5132                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5133                                   ffebld_nonter_hook (expr));
5134         if (arg3_tree != NULL_TREE) {
5135           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5136                                      convert (TREE_TYPE (arg3_tree),
5137                                               expr_tree));
5138         }
5139       }
5140       return expr_tree;
5141
5142     case FFEINTRIN_impKILL_subr:
5143       {
5144         tree arg1_tree;
5145         tree arg2_tree;
5146         tree arg3_tree;
5147
5148         arg1_tree = convert (ffecom_f2c_integer_type_node,
5149                              ffecom_expr (arg1));
5150         arg1_tree = ffecom_1 (ADDR_EXPR,
5151                               build_pointer_type (TREE_TYPE (arg1_tree)),
5152                               arg1_tree);
5153
5154         arg2_tree = convert (ffecom_f2c_integer_type_node,
5155                              ffecom_expr (arg2));
5156         arg2_tree = ffecom_1 (ADDR_EXPR,
5157                               build_pointer_type (TREE_TYPE (arg2_tree)),
5158                               arg2_tree);
5159
5160         if (arg3 == NULL)
5161           arg3_tree = NULL_TREE;
5162         else
5163           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5164
5165         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5166         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5167         TREE_CHAIN (arg1_tree) = arg2_tree;
5168         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5169                                   ffecom_gfrt_kindtype (gfrt),
5170                                   FALSE,
5171                                   NULL_TREE,
5172                                   arg1_tree,
5173                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5174                                   ffebld_nonter_hook (expr));
5175         if (arg3_tree != NULL_TREE) {
5176           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5177                                      convert (TREE_TYPE (arg3_tree),
5178                                               expr_tree));
5179         }
5180       }
5181       return expr_tree;
5182
5183     case FFEINTRIN_impCTIME_subr:
5184     case FFEINTRIN_impTTYNAM_subr:
5185       {
5186         tree arg1_len = integer_zero_node;
5187         tree arg1_tree;
5188         tree arg2_tree;
5189
5190         arg1_tree = ffecom_arg_ptr_to_expr (arg2, &arg1_len);
5191
5192         arg2_tree = convert (((codegen_imp == FFEINTRIN_impCTIME_subr) ?
5193                               ffecom_f2c_longint_type_node :
5194                               ffecom_f2c_integer_type_node),
5195                              ffecom_expr (arg1));
5196         arg2_tree = ffecom_1 (ADDR_EXPR,
5197                               build_pointer_type (TREE_TYPE (arg2_tree)),
5198                               arg2_tree);
5199
5200         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5201         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5202         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5203         TREE_CHAIN (arg1_len) = arg2_tree;
5204         TREE_CHAIN (arg1_tree) = arg1_len;
5205
5206         expr_tree
5207           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5208                           ffecom_gfrt_kindtype (gfrt),
5209                           FALSE,
5210                           NULL_TREE,
5211                           arg1_tree,
5212                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5213                           ffebld_nonter_hook (expr));
5214         TREE_SIDE_EFFECTS (expr_tree) = 1;
5215       }
5216       return expr_tree;
5217
5218     case FFEINTRIN_impIRAND:
5219     case FFEINTRIN_impRAND:
5220       /* Arg defaults to 0 (normal random case) */
5221       {
5222         tree arg1_tree;
5223
5224         if (arg1 == NULL)
5225           arg1_tree = ffecom_integer_zero_node;
5226         else
5227           arg1_tree = ffecom_expr (arg1);
5228         arg1_tree = convert (ffecom_f2c_integer_type_node,
5229                              arg1_tree);
5230         arg1_tree = ffecom_1 (ADDR_EXPR,
5231                               build_pointer_type (TREE_TYPE (arg1_tree)),
5232                               arg1_tree);
5233         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5234
5235         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5236                                   ffecom_gfrt_kindtype (gfrt),
5237                                   FALSE,
5238                                   ((codegen_imp == FFEINTRIN_impIRAND) ?
5239                                    ffecom_f2c_integer_type_node :
5240                                    ffecom_f2c_real_type_node),
5241                                   arg1_tree,
5242                                   dest_tree, dest, dest_used,
5243                                   NULL_TREE, TRUE,
5244                                   ffebld_nonter_hook (expr));
5245       }
5246       return expr_tree;
5247
5248     case FFEINTRIN_impFTELL_subr:
5249     case FFEINTRIN_impUMASK_subr:
5250       {
5251         tree arg1_tree;
5252         tree arg2_tree;
5253
5254         arg1_tree = convert (ffecom_f2c_integer_type_node,
5255                              ffecom_expr (arg1));
5256         arg1_tree = ffecom_1 (ADDR_EXPR,
5257                               build_pointer_type (TREE_TYPE (arg1_tree)),
5258                               arg1_tree);
5259
5260         if (arg2 == NULL)
5261           arg2_tree = NULL_TREE;
5262         else
5263           arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
5264
5265         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5266                                   ffecom_gfrt_kindtype (gfrt),
5267                                   FALSE,
5268                                   NULL_TREE,
5269                                   build_tree_list (NULL_TREE, arg1_tree),
5270                                   NULL_TREE, NULL, NULL, NULL_TREE,
5271                                   TRUE,
5272                                   ffebld_nonter_hook (expr));
5273         if (arg2_tree != NULL_TREE) {
5274           expr_tree = ffecom_modify (NULL_TREE, arg2_tree,
5275                                      convert (TREE_TYPE (arg2_tree),
5276                                               expr_tree));
5277         }
5278       }
5279       return expr_tree;
5280
5281     case FFEINTRIN_impCPU_TIME:
5282     case FFEINTRIN_impSECOND_subr:
5283       {
5284         tree arg1_tree;
5285
5286         arg1_tree = ffecom_expr_w (NULL_TREE, arg1);
5287
5288         expr_tree
5289           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5290                           ffecom_gfrt_kindtype (gfrt),
5291                           FALSE,
5292                           NULL_TREE,
5293                           NULL_TREE,
5294                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5295                           ffebld_nonter_hook (expr));
5296
5297         expr_tree
5298           = ffecom_modify (NULL_TREE, arg1_tree,
5299                            convert (TREE_TYPE (arg1_tree),
5300                                     expr_tree));
5301       }
5302       return expr_tree;
5303
5304     case FFEINTRIN_impDTIME_subr:
5305     case FFEINTRIN_impETIME_subr:
5306       {
5307         tree arg1_tree;
5308         tree result_tree;
5309
5310         result_tree = ffecom_expr_w (NULL_TREE, arg2);
5311
5312         arg1_tree = ffecom_ptr_to_expr (arg1);
5313
5314         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5315                                   ffecom_gfrt_kindtype (gfrt),
5316                                   FALSE,
5317                                   NULL_TREE,
5318                                   build_tree_list (NULL_TREE, arg1_tree),
5319                                   NULL_TREE, NULL, NULL, NULL_TREE,
5320                                   TRUE,
5321                                   ffebld_nonter_hook (expr));
5322         expr_tree = ffecom_modify (NULL_TREE, result_tree,
5323                                    convert (TREE_TYPE (result_tree),
5324                                             expr_tree));
5325       }
5326       return expr_tree;
5327
5328       /* Straightforward calls of libf2c routines: */
5329     case FFEINTRIN_impABORT:
5330     case FFEINTRIN_impACCESS:
5331     case FFEINTRIN_impBESJ0:
5332     case FFEINTRIN_impBESJ1:
5333     case FFEINTRIN_impBESJN:
5334     case FFEINTRIN_impBESY0:
5335     case FFEINTRIN_impBESY1:
5336     case FFEINTRIN_impBESYN:
5337     case FFEINTRIN_impCHDIR_func:
5338     case FFEINTRIN_impCHMOD_func:
5339     case FFEINTRIN_impDATE:
5340     case FFEINTRIN_impDATE_AND_TIME:
5341     case FFEINTRIN_impDBESJ0:
5342     case FFEINTRIN_impDBESJ1:
5343     case FFEINTRIN_impDBESJN:
5344     case FFEINTRIN_impDBESY0:
5345     case FFEINTRIN_impDBESY1:
5346     case FFEINTRIN_impDBESYN:
5347     case FFEINTRIN_impDTIME_func:
5348     case FFEINTRIN_impETIME_func:
5349     case FFEINTRIN_impFGETC_func:
5350     case FFEINTRIN_impFGET_func:
5351     case FFEINTRIN_impFNUM:
5352     case FFEINTRIN_impFPUTC_func:
5353     case FFEINTRIN_impFPUT_func:
5354     case FFEINTRIN_impFSEEK:
5355     case FFEINTRIN_impFSTAT_func:
5356     case FFEINTRIN_impFTELL_func:
5357     case FFEINTRIN_impGERROR:
5358     case FFEINTRIN_impGETARG:
5359     case FFEINTRIN_impGETCWD_func:
5360     case FFEINTRIN_impGETENV:
5361     case FFEINTRIN_impGETGID:
5362     case FFEINTRIN_impGETLOG:
5363     case FFEINTRIN_impGETPID:
5364     case FFEINTRIN_impGETUID:
5365     case FFEINTRIN_impGMTIME:
5366     case FFEINTRIN_impHOSTNM_func:
5367     case FFEINTRIN_impIDATE_unix:
5368     case FFEINTRIN_impIDATE_vxt:
5369     case FFEINTRIN_impIERRNO:
5370     case FFEINTRIN_impISATTY:
5371     case FFEINTRIN_impITIME:
5372     case FFEINTRIN_impKILL_func:
5373     case FFEINTRIN_impLINK_func:
5374     case FFEINTRIN_impLNBLNK:
5375     case FFEINTRIN_impLSTAT_func:
5376     case FFEINTRIN_impLTIME:
5377     case FFEINTRIN_impMCLOCK8:
5378     case FFEINTRIN_impMCLOCK:
5379     case FFEINTRIN_impPERROR:
5380     case FFEINTRIN_impRENAME_func:
5381     case FFEINTRIN_impSECNDS:
5382     case FFEINTRIN_impSECOND_func:
5383     case FFEINTRIN_impSLEEP:
5384     case FFEINTRIN_impSRAND:
5385     case FFEINTRIN_impSTAT_func:
5386     case FFEINTRIN_impSYMLNK_func:
5387     case FFEINTRIN_impSYSTEM_CLOCK:
5388     case FFEINTRIN_impSYSTEM_func:
5389     case FFEINTRIN_impTIME8:
5390     case FFEINTRIN_impTIME_unix:
5391     case FFEINTRIN_impTIME_vxt:
5392     case FFEINTRIN_impUMASK_func:
5393     case FFEINTRIN_impUNLINK_func:
5394       break;
5395
5396     case FFEINTRIN_impCTIME_func:       /* CHARACTER functions not handled here. */
5397     case FFEINTRIN_impFDATE_func:       /* CHARACTER functions not handled here. */
5398     case FFEINTRIN_impTTYNAM_func:      /* CHARACTER functions not handled here. */
5399     case FFEINTRIN_impNONE:
5400     case FFEINTRIN_imp:         /* Hush up gcc warning. */
5401       fprintf (stderr, "No %s implementation.\n",
5402                ffeintrin_name_implementation (ffebld_symter_implementation (ffebld_left (expr))));
5403       assert ("unimplemented intrinsic" == NULL);
5404       return error_mark_node;
5405     }
5406
5407   assert (gfrt != FFECOM_gfrt); /* Must have an implementation! */
5408
5409   expr_tree = ffecom_arglist_expr_ (ffecom_gfrt_args_ (gfrt),
5410                                     ffebld_right (expr));
5411
5412   return ffecom_call_ (ffecom_gfrt_tree_ (gfrt), ffecom_gfrt_kindtype (gfrt),
5413                        (ffe_is_f2c_library () && ffecom_gfrt_complex_[gfrt]),
5414                        tree_type,
5415                        expr_tree, dest_tree, dest, dest_used,
5416                        NULL_TREE, TRUE,
5417                        ffebld_nonter_hook (expr));
5418
5419   /* See bottom of this file for f2c transforms used to determine
5420      many of the above implementations.  The info seems to confuse
5421      Emacs's C mode indentation, which is why it's been moved to
5422      the bottom of this source file.  */
5423 }
5424
5425 /* For power (exponentiation) where right-hand operand is type INTEGER,
5426    generate in-line code to do it the fast way (which, if the operand
5427    is a constant, might just mean a series of multiplies).  */
5428
5429 static tree
5430 ffecom_expr_power_integer_ (ffebld expr)
5431 {
5432   tree l = ffecom_expr (ffebld_left (expr));
5433   tree r = ffecom_expr (ffebld_right (expr));
5434   tree ltype = TREE_TYPE (l);
5435   tree rtype = TREE_TYPE (r);
5436   tree result = NULL_TREE;
5437
5438   if (l == error_mark_node
5439       || r == error_mark_node)
5440     return error_mark_node;
5441
5442   if (TREE_CODE (r) == INTEGER_CST)
5443     {
5444       int sgn = tree_int_cst_sgn (r);
5445
5446       if (sgn == 0)
5447         return convert (ltype, integer_one_node);
5448
5449       if ((TREE_CODE (ltype) == INTEGER_TYPE)
5450           && (sgn < 0))
5451         {
5452           /* Reciprocal of integer is either 0, -1, or 1, so after
5453              calculating that (which we leave to the back end to do
5454              or not do optimally), don't bother with any multiplying.  */
5455
5456           result = ffecom_tree_divide_ (ltype,
5457                                         convert (ltype, integer_one_node),
5458                                         l,
5459                                         NULL_TREE, NULL, NULL, NULL_TREE);
5460           r = ffecom_1 (NEGATE_EXPR,
5461                         rtype,
5462                         r);
5463           if ((TREE_INT_CST_LOW (r) & 1) == 0)
5464             result = ffecom_1 (ABS_EXPR, rtype,
5465                                result);
5466         }
5467
5468       /* Generate appropriate series of multiplies, preceded
5469          by divide if the exponent is negative.  */
5470
5471       l = save_expr (l);
5472
5473       if (sgn < 0)
5474         {
5475           l = ffecom_tree_divide_ (ltype,
5476                                    convert (ltype, integer_one_node),
5477                                    l,
5478                                    NULL_TREE, NULL, NULL,
5479                                    ffebld_nonter_hook (expr));
5480           r = ffecom_1 (NEGATE_EXPR, rtype, r);
5481           assert (TREE_CODE (r) == INTEGER_CST);
5482
5483           if (tree_int_cst_sgn (r) < 0)
5484             {                   /* The "most negative" number.  */
5485               r = ffecom_1 (NEGATE_EXPR, rtype,
5486                             ffecom_2 (RSHIFT_EXPR, rtype,
5487                                       r,
5488                                       integer_one_node));
5489               l = save_expr (l);
5490               l = ffecom_2 (MULT_EXPR, ltype,
5491                             l,
5492                             l);
5493             }
5494         }
5495
5496       for (;;)
5497         {
5498           if (TREE_INT_CST_LOW (r) & 1)
5499             {
5500               if (result == NULL_TREE)
5501                 result = l;
5502               else
5503                 result = ffecom_2 (MULT_EXPR, ltype,
5504                                    result,
5505                                    l);
5506             }
5507
5508           r = ffecom_2 (RSHIFT_EXPR, rtype,
5509                         r,
5510                         integer_one_node);
5511           if (integer_zerop (r))
5512             break;
5513           assert (TREE_CODE (r) == INTEGER_CST);
5514
5515           l = save_expr (l);
5516           l = ffecom_2 (MULT_EXPR, ltype,
5517                         l,
5518                         l);
5519         }
5520       return result;
5521     }
5522
5523   /* Though rhs isn't a constant, in-line code cannot be expanded
5524      while transforming dummies
5525      because the back end cannot be easily convinced to generate
5526      stores (MODIFY_EXPR), handle temporaries, and so on before
5527      all the appropriate rtx's have been generated for things like
5528      dummy args referenced in rhs -- which doesn't happen until
5529      store_parm_decls() is called (expand_function_start, I believe,
5530      does the actual rtx-stuffing of PARM_DECLs).
5531
5532      So, in this case, let the caller generate the call to the
5533      run-time-library function to evaluate the power for us.  */
5534
5535   if (ffecom_transform_only_dummies_)
5536     return NULL_TREE;
5537
5538   /* Right-hand operand not a constant, expand in-line code to figure
5539      out how to do the multiplies, &c.
5540
5541      The returned expression is expressed this way in GNU C, where l and
5542      r are the "inputs":
5543
5544      ({ typeof (r) rtmp = r;
5545         typeof (l) ltmp = l;
5546         typeof (l) result;
5547
5548         if (rtmp == 0)
5549           result = 1;
5550         else
5551           {
5552             if ((basetypeof (l) == basetypeof (int))
5553                 && (rtmp < 0))
5554               {
5555                 result = ((typeof (l)) 1) / ltmp;
5556                 if ((ltmp < 0) && (((-rtmp) & 1) == 0))
5557                   result = -result;
5558               }
5559             else
5560               {
5561                 result = 1;
5562                 if ((basetypeof (l) != basetypeof (int))
5563                     && (rtmp < 0))
5564                   {
5565                     ltmp = ((typeof (l)) 1) / ltmp;
5566                     rtmp = -rtmp;
5567                     if (rtmp < 0)
5568                       {
5569                         rtmp = -(rtmp >> 1);
5570                         ltmp *= ltmp;
5571                       }
5572                   }
5573                 for (;;)
5574                   {
5575                     if (rtmp & 1)
5576                       result *= ltmp;
5577                     if ((rtmp >>= 1) == 0)
5578                       break;
5579                     ltmp *= ltmp;
5580                   }
5581               }
5582           }
5583         result;
5584      })
5585
5586      Note that some of the above is compile-time collapsable, such as
5587      the first part of the if statements that checks the base type of
5588      l against int.  The if statements are phrased that way to suggest
5589      an easy way to generate the if/else constructs here, knowing that
5590      the back end should (and probably does) eliminate the resulting
5591      dead code (either the int case or the non-int case), something
5592      it couldn't do without the redundant phrasing, requiring explicit
5593      dead-code elimination here, which would be kind of difficult to
5594      read.  */
5595
5596   {
5597     tree rtmp;
5598     tree ltmp;
5599     tree divide;
5600     tree basetypeof_l_is_int;
5601     tree se;
5602     tree t;
5603
5604     basetypeof_l_is_int
5605       = build_int_2 ((TREE_CODE (ltype) == INTEGER_TYPE), 0);
5606
5607     se = expand_start_stmt_expr (/*has_scope=*/1);
5608
5609     ffecom_start_compstmt ();
5610
5611 #ifndef HAHA
5612     rtmp = ffecom_make_tempvar ("power_r", rtype,
5613                                 FFETARGET_charactersizeNONE, -1);
5614     ltmp = ffecom_make_tempvar ("power_l", ltype,
5615                                 FFETARGET_charactersizeNONE, -1);
5616     result = ffecom_make_tempvar ("power_res", ltype,
5617                                   FFETARGET_charactersizeNONE, -1);
5618     if (TREE_CODE (ltype) == COMPLEX_TYPE
5619         || TREE_CODE (ltype) == RECORD_TYPE)
5620       divide = ffecom_make_tempvar ("power_div", ltype,
5621                                     FFETARGET_charactersizeNONE, -1);
5622     else
5623       divide = NULL_TREE;
5624 #else  /* HAHA */
5625     {
5626       tree hook;
5627
5628       hook = ffebld_nonter_hook (expr);
5629       assert (hook);
5630       assert (TREE_CODE (hook) == TREE_VEC);
5631       assert (TREE_VEC_LENGTH (hook) == 4);
5632       rtmp = TREE_VEC_ELT (hook, 0);
5633       ltmp = TREE_VEC_ELT (hook, 1);
5634       result = TREE_VEC_ELT (hook, 2);
5635       divide = TREE_VEC_ELT (hook, 3);
5636       if (TREE_CODE (ltype) == COMPLEX_TYPE
5637           || TREE_CODE (ltype) == RECORD_TYPE)
5638         assert (divide);
5639       else
5640         assert (! divide);
5641     }
5642 #endif  /* HAHA */
5643
5644     expand_expr_stmt (ffecom_modify (void_type_node,
5645                                      rtmp,
5646                                      r));
5647     expand_expr_stmt (ffecom_modify (void_type_node,
5648                                      ltmp,
5649                                      l));
5650     expand_start_cond (ffecom_truth_value
5651                        (ffecom_2 (EQ_EXPR, integer_type_node,
5652                                   rtmp,
5653                                   convert (rtype, integer_zero_node))),
5654                        0);
5655     expand_expr_stmt (ffecom_modify (void_type_node,
5656                                      result,
5657                                      convert (ltype, integer_one_node)));
5658     expand_start_else ();
5659     if (! integer_zerop (basetypeof_l_is_int))
5660       {
5661         expand_start_cond (ffecom_2 (LT_EXPR, integer_type_node,
5662                                      rtmp,
5663                                      convert (rtype,
5664                                               integer_zero_node)),
5665                            0);
5666         expand_expr_stmt (ffecom_modify (void_type_node,
5667                                          result,
5668                                          ffecom_tree_divide_
5669                                          (ltype,
5670                                           convert (ltype, integer_one_node),
5671                                           ltmp,
5672                                           NULL_TREE, NULL, NULL,
5673                                           divide)));
5674         expand_start_cond (ffecom_truth_value
5675                            (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5676                                       ffecom_2 (LT_EXPR, integer_type_node,
5677                                                 ltmp,
5678                                                 convert (ltype,
5679                                                          integer_zero_node)),
5680                                       ffecom_2 (EQ_EXPR, integer_type_node,
5681                                                 ffecom_2 (BIT_AND_EXPR,
5682                                                           rtype,
5683                                                           ffecom_1 (NEGATE_EXPR,
5684                                                                     rtype,
5685                                                                     rtmp),
5686                                                           convert (rtype,
5687                                                                    integer_one_node)),
5688                                                 convert (rtype,
5689                                                          integer_zero_node)))),
5690                            0);
5691         expand_expr_stmt (ffecom_modify (void_type_node,
5692                                          result,
5693                                          ffecom_1 (NEGATE_EXPR,
5694                                                    ltype,
5695                                                    result)));
5696         expand_end_cond ();
5697         expand_start_else ();
5698       }
5699     expand_expr_stmt (ffecom_modify (void_type_node,
5700                                      result,
5701                                      convert (ltype, integer_one_node)));
5702     expand_start_cond (ffecom_truth_value
5703                        (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5704                                   ffecom_truth_value_invert
5705                                   (basetypeof_l_is_int),
5706                                   ffecom_2 (LT_EXPR, integer_type_node,
5707                                             rtmp,
5708                                             convert (rtype,
5709                                                      integer_zero_node)))),
5710                        0);
5711     expand_expr_stmt (ffecom_modify (void_type_node,
5712                                      ltmp,
5713                                      ffecom_tree_divide_
5714                                      (ltype,
5715                                       convert (ltype, integer_one_node),
5716                                       ltmp,
5717                                       NULL_TREE, NULL, NULL,
5718                                       divide)));
5719     expand_expr_stmt (ffecom_modify (void_type_node,
5720                                      rtmp,
5721                                      ffecom_1 (NEGATE_EXPR, rtype,
5722                                                rtmp)));
5723     expand_start_cond (ffecom_truth_value
5724                        (ffecom_2 (LT_EXPR, integer_type_node,
5725                                   rtmp,
5726                                   convert (rtype, integer_zero_node))),
5727                        0);
5728     expand_expr_stmt (ffecom_modify (void_type_node,
5729                                      rtmp,
5730                                      ffecom_1 (NEGATE_EXPR, rtype,
5731                                                ffecom_2 (RSHIFT_EXPR,
5732                                                          rtype,
5733                                                          rtmp,
5734                                                          integer_one_node))));
5735     expand_expr_stmt (ffecom_modify (void_type_node,
5736                                      ltmp,
5737                                      ffecom_2 (MULT_EXPR, ltype,
5738                                                ltmp,
5739                                                ltmp)));
5740     expand_end_cond ();
5741     expand_end_cond ();
5742     expand_start_loop (1);
5743     expand_start_cond (ffecom_truth_value
5744                        (ffecom_2 (BIT_AND_EXPR, rtype,
5745                                   rtmp,
5746                                   convert (rtype, integer_one_node))),
5747                        0);
5748     expand_expr_stmt (ffecom_modify (void_type_node,
5749                                      result,
5750                                      ffecom_2 (MULT_EXPR, ltype,
5751                                                result,
5752                                                ltmp)));
5753     expand_end_cond ();
5754     expand_exit_loop_if_false (NULL,
5755                                ffecom_truth_value
5756                                (ffecom_modify (rtype,
5757                                                rtmp,
5758                                                ffecom_2 (RSHIFT_EXPR,
5759                                                          rtype,
5760                                                          rtmp,
5761                                                          integer_one_node))));
5762     expand_expr_stmt (ffecom_modify (void_type_node,
5763                                      ltmp,
5764                                      ffecom_2 (MULT_EXPR, ltype,
5765                                                ltmp,
5766                                                ltmp)));
5767     expand_end_loop ();
5768     expand_end_cond ();
5769     if (!integer_zerop (basetypeof_l_is_int))
5770       expand_end_cond ();
5771     expand_expr_stmt (result);
5772
5773     t = ffecom_end_compstmt ();
5774
5775     result = expand_end_stmt_expr (se);
5776
5777     /* This code comes from c-parse.in, after its expand_end_stmt_expr.  */
5778
5779     if (TREE_CODE (t) == BLOCK)
5780       {
5781         /* Make a BIND_EXPR for the BLOCK already made.  */
5782         result = build (BIND_EXPR, TREE_TYPE (result),
5783                         NULL_TREE, result, t);
5784         /* Remove the block from the tree at this point.
5785            It gets put back at the proper place
5786            when the BIND_EXPR is expanded.  */
5787         delete_block (t);
5788       }
5789     else
5790       result = t;
5791   }
5792
5793   return result;
5794 }
5795
5796 /* ffecom_expr_transform_ -- Transform symbols in expr
5797
5798    ffebld expr;  // FFE expression.
5799    ffecom_expr_transform_ (expr);
5800
5801    Recursive descent on expr while transforming any untransformed SYMTERs.  */
5802
5803 static void
5804 ffecom_expr_transform_ (ffebld expr)
5805 {
5806   tree t;
5807   ffesymbol s;
5808
5809  tail_recurse:
5810
5811   if (expr == NULL)
5812     return;
5813
5814   switch (ffebld_op (expr))
5815     {
5816     case FFEBLD_opSYMTER:
5817       s = ffebld_symter (expr);
5818       t = ffesymbol_hook (s).decl_tree;
5819       if ((t == NULL_TREE)
5820           && ((ffesymbol_kind (s) != FFEINFO_kindNONE)
5821               || ((ffesymbol_where (s) != FFEINFO_whereNONE)
5822                   && (ffesymbol_where (s) != FFEINFO_whereINTRINSIC))))
5823         {
5824           s = ffecom_sym_transform_ (s);
5825           t = ffesymbol_hook (s).decl_tree;     /* Sfunc expr non-dummy,
5826                                                    DIMENSION expr? */
5827         }
5828       break;                    /* Ok if (t == NULL) here. */
5829
5830     case FFEBLD_opITEM:
5831       ffecom_expr_transform_ (ffebld_head (expr));
5832       expr = ffebld_trail (expr);
5833       goto tail_recurse;        /* :::::::::::::::::::: */
5834
5835     default:
5836       break;
5837     }
5838
5839   switch (ffebld_arity (expr))
5840     {
5841     case 2:
5842       ffecom_expr_transform_ (ffebld_left (expr));
5843       expr = ffebld_right (expr);
5844       goto tail_recurse;        /* :::::::::::::::::::: */
5845
5846     case 1:
5847       expr = ffebld_left (expr);
5848       goto tail_recurse;        /* :::::::::::::::::::: */
5849
5850     default:
5851       break;
5852     }
5853
5854   return;
5855 }
5856
5857 /* Make a type based on info in live f2c.h file.  */
5858
5859 static void
5860 ffecom_f2c_make_type_ (tree *type, int tcode, const char *name)
5861 {
5862   switch (tcode)
5863     {
5864     case FFECOM_f2ccodeCHAR:
5865       *type = make_signed_type (CHAR_TYPE_SIZE);
5866       break;
5867
5868     case FFECOM_f2ccodeSHORT:
5869       *type = make_signed_type (SHORT_TYPE_SIZE);
5870       break;
5871
5872     case FFECOM_f2ccodeINT:
5873       *type = make_signed_type (INT_TYPE_SIZE);
5874       break;
5875
5876     case FFECOM_f2ccodeLONG:
5877       *type = make_signed_type (LONG_TYPE_SIZE);
5878       break;
5879
5880     case FFECOM_f2ccodeLONGLONG:
5881       *type = make_signed_type (LONG_LONG_TYPE_SIZE);
5882       break;
5883
5884     case FFECOM_f2ccodeCHARPTR:
5885       *type = build_pointer_type (DEFAULT_SIGNED_CHAR
5886                                   ? signed_char_type_node
5887                                   : unsigned_char_type_node);
5888       break;
5889
5890     case FFECOM_f2ccodeFLOAT:
5891       *type = make_node (REAL_TYPE);
5892       TYPE_PRECISION (*type) = FLOAT_TYPE_SIZE;
5893       layout_type (*type);
5894       break;
5895
5896     case FFECOM_f2ccodeDOUBLE:
5897       *type = make_node (REAL_TYPE);
5898       TYPE_PRECISION (*type) = DOUBLE_TYPE_SIZE;
5899       layout_type (*type);
5900       break;
5901
5902     case FFECOM_f2ccodeLONGDOUBLE:
5903       *type = make_node (REAL_TYPE);
5904       TYPE_PRECISION (*type) = LONG_DOUBLE_TYPE_SIZE;
5905       layout_type (*type);
5906       break;
5907
5908     case FFECOM_f2ccodeTWOREALS:
5909       *type = ffecom_make_complex_type_ (ffecom_f2c_real_type_node);
5910       break;
5911
5912     case FFECOM_f2ccodeTWODOUBLEREALS:
5913       *type = ffecom_make_complex_type_ (ffecom_f2c_doublereal_type_node);
5914       break;
5915
5916     default:
5917       assert ("unexpected FFECOM_f2ccodeXYZZY!" == NULL);
5918       *type = error_mark_node;
5919       return;
5920     }
5921
5922   pushdecl (build_decl (TYPE_DECL,
5923                         ffecom_get_invented_identifier ("__g77_f2c_%s", name),
5924                         *type));
5925 }
5926
5927 /* Set the f2c list-directed-I/O code for whatever (integral) type has the
5928    given size.  */
5929
5930 static void
5931 ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
5932                           int code)
5933 {
5934   int j;
5935   tree t;
5936
5937   for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
5938     if ((t = ffecom_tree_type[bt][j]) != NULL_TREE
5939         && compare_tree_int (TYPE_SIZE (t), size) == 0)
5940       {
5941         assert (code != -1);
5942         ffecom_f2c_typecode_[bt][j] = code;
5943         code = -1;
5944       }
5945 }
5946
5947 /* Finish up globals after doing all program units in file
5948
5949    Need to handle only uninitialized COMMON areas.  */
5950
5951 static ffeglobal
5952 ffecom_finish_global_ (ffeglobal global)
5953 {
5954   tree cbtype;
5955   tree cbt;
5956   tree size;
5957
5958   if (ffeglobal_type (global) != FFEGLOBAL_typeCOMMON)
5959       return global;
5960
5961   if (ffeglobal_common_init (global))
5962       return global;
5963
5964   cbt = ffeglobal_hook (global);
5965   if ((cbt == NULL_TREE)
5966       || !ffeglobal_common_have_size (global))
5967     return global;              /* No need to make common, never ref'd. */
5968
5969   DECL_EXTERNAL (cbt) = 0;
5970
5971   /* Give the array a size now.  */
5972
5973   size = build_int_2 ((ffeglobal_common_size (global)
5974                       + ffeglobal_common_pad (global)) - 1,
5975                       0);
5976
5977   cbtype = TREE_TYPE (cbt);
5978   TYPE_DOMAIN (cbtype) = build_range_type (integer_type_node,
5979                                            integer_zero_node,
5980                                            size);
5981   if (!TREE_TYPE (size))
5982     TREE_TYPE (size) = TYPE_DOMAIN (cbtype);
5983   layout_type (cbtype);
5984
5985   cbt = start_decl (cbt, FALSE);
5986   assert (cbt == ffeglobal_hook (global));
5987
5988   finish_decl (cbt, NULL_TREE, FALSE);
5989
5990   return global;
5991 }
5992
5993 /* Finish up any untransformed symbols.  */
5994
5995 static ffesymbol
5996 ffecom_finish_symbol_transform_ (ffesymbol s)
5997 {
5998   if ((s == NULL) || (TREE_CODE (current_function_decl) == ERROR_MARK))
5999     return s;
6000
6001   /* It's easy to know to transform an untransformed symbol, to make sure
6002      we put out debugging info for it.  But COMMON variables, unlike
6003      EQUIVALENCE ones, aren't given declarations in addition to the
6004      tree expressions that specify offsets, because COMMON variables
6005      can be referenced in the outer scope where only dummy arguments
6006      (PARM_DECLs) should really be seen.  To be safe, just don't do any
6007      VAR_DECLs for COMMON variables when we transform them for real
6008      use, and therefore we do all the VAR_DECL creating here.  */
6009
6010   if (ffesymbol_hook (s).decl_tree == NULL_TREE)
6011     {
6012       if (ffesymbol_kind (s) != FFEINFO_kindNONE
6013           || (ffesymbol_where (s) != FFEINFO_whereNONE
6014               && ffesymbol_where (s) != FFEINFO_whereINTRINSIC
6015               && ffesymbol_where (s) != FFEINFO_whereDUMMY))
6016         /* Not transformed, and not CHARACTER*(*), and not a dummy
6017            argument, which can happen only if the entry point names
6018            it "rides in on" are all invalidated for other reasons.  */
6019         s = ffecom_sym_transform_ (s);
6020     }
6021
6022   if ((ffesymbol_where (s) == FFEINFO_whereCOMMON)
6023       && (ffesymbol_hook (s).decl_tree != error_mark_node))
6024     {
6025       /* This isn't working, at least for dbxout.  The .s file looks
6026          okay to me (burley), but in gdb 4.9 at least, the variables
6027          appear to reside somewhere outside of the common area, so
6028          it doesn't make sense to mislead anyone by generating the info
6029          on those variables until this is fixed.  NOTE: Same problem
6030          with EQUIVALENCE, sadly...see similar #if later.  */
6031       ffecom_member_phase2_ (ffesymbol_storage (ffesymbol_common (s)),
6032                              ffesymbol_storage (s));
6033     }
6034
6035   return s;
6036 }
6037
6038 /* Append underscore(s) to name before calling get_identifier.  "us"
6039    is nonzero if the name already contains an underscore and thus
6040    needs two underscores appended.  */
6041
6042 static tree
6043 ffecom_get_appended_identifier_ (char us, const char *name)
6044 {
6045   int i;
6046   char *newname;
6047   tree id;
6048
6049   newname = xmalloc ((i = strlen (name)) + 1
6050                      + ffe_is_underscoring ()
6051                      + us);
6052   memcpy (newname, name, i);
6053   newname[i] = '_';
6054   newname[i + us] = '_';
6055   newname[i + 1 + us] = '\0';
6056   id = get_identifier (newname);
6057
6058   free (newname);
6059
6060   return id;
6061 }
6062
6063 /* Decide whether to append underscore to name before calling
6064    get_identifier.  */
6065
6066 static tree
6067 ffecom_get_external_identifier_ (ffesymbol s)
6068 {
6069   char us;
6070   const char *name = ffesymbol_text (s);
6071
6072   /* If name is a built-in name, just return it as is.  */
6073
6074   if (!ffe_is_underscoring ()
6075       || (strcmp (name, FFETARGET_nameBLANK_COMMON) == 0)
6076 #if FFETARGET_isENFORCED_MAIN_NAME
6077       || (strcmp (name, FFETARGET_nameENFORCED_NAME) == 0)
6078 #else
6079       || (strcmp (name, FFETARGET_nameUNNAMED_MAIN) == 0)
6080 #endif
6081       || (strcmp (name, FFETARGET_nameUNNAMED_BLOCK_DATA) == 0))
6082     return get_identifier (name);
6083
6084   us = ffe_is_second_underscore ()
6085     ? (strchr (name, '_') != NULL)
6086       : 0;
6087
6088   return ffecom_get_appended_identifier_ (us, name);
6089 }
6090
6091 /* Decide whether to append underscore to internal name before calling
6092    get_identifier.
6093
6094    This is for non-external, top-function-context names only.  Transform
6095    identifier so it doesn't conflict with the transformed result
6096    of using a _different_ external name.  E.g. if "CALL FOO" is
6097    transformed into "FOO_();", then the variable in "FOO_ = 3"
6098    must be transformed into something that does not conflict, since
6099    these two things should be independent.
6100
6101    The transformation is as follows.  If the name does not contain
6102    an underscore, there is no possible conflict, so just return.
6103    If the name does contain an underscore, then transform it just
6104    like we transform an external identifier.  */
6105
6106 static tree
6107 ffecom_get_identifier_ (const char *name)
6108 {
6109   /* If name does not contain an underscore, just return it as is.  */
6110
6111   if (!ffe_is_underscoring ()
6112       || (strchr (name, '_') == NULL))
6113     return get_identifier (name);
6114
6115   return ffecom_get_appended_identifier_ (ffe_is_second_underscore (),
6116                                           name);
6117 }
6118
6119 /* ffecom_gen_sfuncdef_ -- Generate definition of statement function
6120
6121    tree t;
6122    ffesymbol s;  // kindFUNCTION, whereIMMEDIATE.
6123    t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s),
6124          ffesymbol_kindtype(s));
6125
6126    Call after setting up containing function and getting trees for all
6127    other symbols.  */
6128
6129 static tree
6130 ffecom_gen_sfuncdef_ (ffesymbol s, ffeinfoBasictype bt, ffeinfoKindtype kt)
6131 {
6132   ffebld expr = ffesymbol_sfexpr (s);
6133   tree type;
6134   tree func;
6135   tree result;
6136   bool charfunc = (bt == FFEINFO_basictypeCHARACTER);
6137   static bool recurse = FALSE;
6138   int old_lineno = lineno;
6139   const char *old_input_filename = input_filename;
6140
6141   ffecom_nested_entry_ = s;
6142
6143   /* For now, we don't have a handy pointer to where the sfunc is actually
6144      defined, though that should be easy to add to an ffesymbol. (The
6145      token/where info available might well point to the place where the type
6146      of the sfunc is declared, especially if that precedes the place where
6147      the sfunc itself is defined, which is typically the case.)  We should
6148      put out a null pointer rather than point somewhere wrong, but I want to
6149      see how it works at this point.  */
6150
6151   input_filename = ffesymbol_where_filename (s);
6152   lineno = ffesymbol_where_filelinenum (s);
6153
6154   /* Pretransform the expression so any newly discovered things belong to the
6155      outer program unit, not to the statement function. */
6156
6157   ffecom_expr_transform_ (expr);
6158
6159   /* Make sure no recursive invocation of this fn (a specific case of failing
6160      to pretransform an sfunc's expression, i.e. where its expression
6161      references another untransformed sfunc) happens. */
6162
6163   assert (!recurse);
6164   recurse = TRUE;
6165
6166   push_f_function_context ();
6167
6168   if (charfunc)
6169     type = void_type_node;
6170   else
6171     {
6172       type = ffecom_tree_type[bt][kt];
6173       if (type == NULL_TREE)
6174         type = integer_type_node;       /* _sym_exec_transition reports
6175                                            error. */
6176     }
6177
6178   start_function (ffecom_get_identifier_ (ffesymbol_text (s)),
6179                   build_function_type (type, NULL_TREE),
6180                   1,            /* nested/inline */
6181                   0);           /* TREE_PUBLIC */
6182
6183   /* We don't worry about COMPLEX return values here, because this is
6184      entirely internal to our code, and gcc has the ability to return COMPLEX
6185      directly as a value.  */
6186
6187   if (charfunc)
6188     {                           /* Prepend arg for where result goes. */
6189       tree type;
6190
6191       type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
6192
6193       result = ffecom_get_invented_identifier ("__g77_%s", "result");
6194
6195       ffecom_char_enhance_arg_ (&type, s);      /* Ignore returned length. */
6196
6197       type = build_pointer_type (type);
6198       result = build_decl (PARM_DECL, result, type);
6199
6200       push_parm_decl (result);
6201     }
6202   else
6203     result = NULL_TREE;         /* Not ref'd if !charfunc. */
6204
6205   ffecom_push_dummy_decls_ (ffesymbol_dummyargs (s), TRUE);
6206
6207   store_parm_decls (0);
6208
6209   ffecom_start_compstmt ();
6210
6211   if (expr != NULL)
6212     {
6213       if (charfunc)
6214         {
6215           ffetargetCharacterSize sz = ffesymbol_size (s);
6216           tree result_length;
6217
6218           result_length = build_int_2 (sz, 0);
6219           TREE_TYPE (result_length) = ffecom_f2c_ftnlen_type_node;
6220
6221           ffecom_prepare_let_char_ (sz, expr);
6222
6223           ffecom_prepare_end ();
6224
6225           ffecom_let_char_ (result, result_length, sz, expr);
6226           expand_null_return ();
6227         }
6228       else
6229         {
6230           ffecom_prepare_expr (expr);
6231
6232           ffecom_prepare_end ();
6233
6234           expand_return (ffecom_modify (NULL_TREE,
6235                                         DECL_RESULT (current_function_decl),
6236                                         ffecom_expr (expr)));
6237         }
6238     }
6239
6240   ffecom_end_compstmt ();
6241
6242   func = current_function_decl;
6243   finish_function (1);
6244
6245   pop_f_function_context ();
6246
6247   recurse = FALSE;
6248
6249   lineno = old_lineno;
6250   input_filename = old_input_filename;
6251
6252   ffecom_nested_entry_ = NULL;
6253
6254   return func;
6255 }
6256
6257 static const char *
6258 ffecom_gfrt_args_ (ffecomGfrt ix)
6259 {
6260   return ffecom_gfrt_argstring_[ix];
6261 }
6262
6263 static tree
6264 ffecom_gfrt_tree_ (ffecomGfrt ix)
6265 {
6266   if (ffecom_gfrt_[ix] == NULL_TREE)
6267     ffecom_make_gfrt_ (ix);
6268
6269   return ffecom_1 (ADDR_EXPR,
6270                    build_pointer_type (TREE_TYPE (ffecom_gfrt_[ix])),
6271                    ffecom_gfrt_[ix]);
6272 }
6273
6274 /* Return initialize-to-zero expression for this VAR_DECL.  */
6275
6276 /* A somewhat evil way to prevent the garbage collector
6277    from collecting 'tree' structures.  */
6278 #define NUM_TRACKED_CHUNK 63
6279 static struct tree_ggc_tracker
6280 {
6281   struct tree_ggc_tracker *next;
6282   tree trees[NUM_TRACKED_CHUNK];
6283 } *tracker_head = NULL;
6284
6285 static void
6286 mark_tracker_head (void *arg)
6287 {
6288   struct tree_ggc_tracker *head;
6289   int i;
6290
6291   for (head = * (struct tree_ggc_tracker **) arg;
6292        head != NULL;
6293        head = head->next)
6294   {
6295     ggc_mark (head);
6296     for (i = 0; i < NUM_TRACKED_CHUNK; i++)
6297       ggc_mark_tree (head->trees[i]);
6298   }
6299 }
6300
6301 void
6302 ffecom_save_tree_forever (tree t)
6303 {
6304   int i;
6305   if (tracker_head != NULL)
6306     for (i = 0; i < NUM_TRACKED_CHUNK; i++)
6307       if (tracker_head->trees[i] == NULL)
6308         {
6309           tracker_head->trees[i] = t;
6310           return;
6311         }
6312
6313   {
6314     /* Need to allocate a new block.  */
6315     struct tree_ggc_tracker *old_head = tracker_head;
6316
6317     tracker_head = ggc_alloc (sizeof (*tracker_head));
6318     tracker_head->next = old_head;
6319     tracker_head->trees[0] = t;
6320     for (i = 1; i < NUM_TRACKED_CHUNK; i++)
6321       tracker_head->trees[i] = NULL;
6322   }
6323 }
6324
6325 static tree
6326 ffecom_init_zero_ (tree decl)
6327 {
6328   tree init;
6329   int incremental = TREE_STATIC (decl);
6330   tree type = TREE_TYPE (decl);
6331
6332   if (incremental)
6333     {
6334       make_decl_rtl (decl, NULL);
6335       assemble_variable (decl, TREE_PUBLIC (decl) ? 1 : 0, 0, 1);
6336     }
6337
6338   if ((TREE_CODE (type) != ARRAY_TYPE)
6339       && (TREE_CODE (type) != RECORD_TYPE)
6340       && (TREE_CODE (type) != UNION_TYPE)
6341       && !incremental)
6342     init = convert (type, integer_zero_node);
6343   else if (!incremental)
6344     {
6345       init = build (CONSTRUCTOR, type, NULL_TREE, NULL_TREE);
6346       TREE_CONSTANT (init) = 1;
6347       TREE_STATIC (init) = 1;
6348     }
6349   else
6350     {
6351       assemble_zeros (int_size_in_bytes (type));
6352       init = error_mark_node;
6353     }
6354
6355   return init;
6356 }
6357
6358 static tree
6359 ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
6360                          tree *maybe_tree)
6361 {
6362   tree expr_tree;
6363   tree length_tree;
6364
6365   switch (ffebld_op (arg))
6366     {
6367     case FFEBLD_opCONTER:       /* For F90, check 0-length. */
6368       if (ffetarget_length_character1
6369           (ffebld_constant_character1
6370            (ffebld_conter (arg))) == 0)
6371         {
6372           *maybe_tree = integer_zero_node;
6373           return convert (tree_type, integer_zero_node);
6374         }
6375
6376       *maybe_tree = integer_one_node;
6377       expr_tree = build_int_2 (*ffetarget_text_character1
6378                                (ffebld_constant_character1
6379                                 (ffebld_conter (arg))),
6380                                0);
6381       TREE_TYPE (expr_tree) = tree_type;
6382       return expr_tree;
6383
6384     case FFEBLD_opSYMTER:
6385     case FFEBLD_opARRAYREF:
6386     case FFEBLD_opFUNCREF:
6387     case FFEBLD_opSUBSTR:
6388       ffecom_char_args_ (&expr_tree, &length_tree, arg);
6389
6390       if ((expr_tree == error_mark_node)
6391           || (length_tree == error_mark_node))
6392         {
6393           *maybe_tree = error_mark_node;
6394           return error_mark_node;
6395         }
6396
6397       if (integer_zerop (length_tree))
6398         {
6399           *maybe_tree = integer_zero_node;
6400           return convert (tree_type, integer_zero_node);
6401         }
6402
6403       expr_tree
6404         = ffecom_1 (INDIRECT_REF,
6405                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6406                     expr_tree);
6407       expr_tree
6408         = ffecom_2 (ARRAY_REF,
6409                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6410                     expr_tree,
6411                     integer_one_node);
6412       expr_tree = convert (tree_type, expr_tree);
6413
6414       if (TREE_CODE (length_tree) == INTEGER_CST)
6415         *maybe_tree = integer_one_node;
6416       else                      /* Must check length at run time.  */
6417         *maybe_tree
6418           = ffecom_truth_value
6419             (ffecom_2 (GT_EXPR, integer_type_node,
6420                        length_tree,
6421                        ffecom_f2c_ftnlen_zero_node));
6422       return expr_tree;
6423
6424     case FFEBLD_opPAREN:
6425     case FFEBLD_opCONVERT:
6426       if (ffeinfo_size (ffebld_info (arg)) == 0)
6427         {
6428           *maybe_tree = integer_zero_node;
6429           return convert (tree_type, integer_zero_node);
6430         }
6431       return ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6432                                       maybe_tree);
6433
6434     case FFEBLD_opCONCATENATE:
6435       {
6436         tree maybe_left;
6437         tree maybe_right;
6438         tree expr_left;
6439         tree expr_right;
6440
6441         expr_left = ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6442                                              &maybe_left);
6443         expr_right = ffecom_intrinsic_ichar_ (tree_type, ffebld_right (arg),
6444                                               &maybe_right);
6445         *maybe_tree = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
6446                                 maybe_left,
6447                                 maybe_right);
6448         expr_tree = ffecom_3 (COND_EXPR, tree_type,
6449                               maybe_left,
6450                               expr_left,
6451                               expr_right);
6452         return expr_tree;
6453       }
6454
6455     default:
6456       assert ("bad op in ICHAR" == NULL);
6457       return error_mark_node;
6458     }
6459 }
6460
6461 /* ffecom_intrinsic_len_ -- Return length info for char arg (LEN())
6462
6463    tree length_arg;
6464    ffebld expr;
6465    length_arg = ffecom_intrinsic_len_ (expr);
6466
6467    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
6468    subexpressions by constructing the appropriate tree for the
6469    length-of-character-text argument in a calling sequence.  */
6470
6471 static tree
6472 ffecom_intrinsic_len_ (ffebld expr)
6473 {
6474   ffetargetCharacter1 val;
6475   tree length;
6476
6477   switch (ffebld_op (expr))
6478     {
6479     case FFEBLD_opCONTER:
6480       val = ffebld_constant_character1 (ffebld_conter (expr));
6481       length = build_int_2 (ffetarget_length_character1 (val), 0);
6482       TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6483       break;
6484
6485     case FFEBLD_opSYMTER:
6486       {
6487         ffesymbol s = ffebld_symter (expr);
6488         tree item;
6489
6490         item = ffesymbol_hook (s).decl_tree;
6491         if (item == NULL_TREE)
6492           {
6493             s = ffecom_sym_transform_ (s);
6494             item = ffesymbol_hook (s).decl_tree;
6495           }
6496         if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
6497           {
6498             if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
6499               length = ffesymbol_hook (s).length_tree;
6500             else
6501               {
6502                 length = build_int_2 (ffesymbol_size (s), 0);
6503                 TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6504               }
6505           }
6506         else if (item == error_mark_node)
6507           length = error_mark_node;
6508         else                    /* FFEINFO_kindFUNCTION: */
6509           length = NULL_TREE;
6510       }
6511       break;
6512
6513     case FFEBLD_opARRAYREF:
6514       length = ffecom_intrinsic_len_ (ffebld_left (expr));
6515       break;
6516
6517     case FFEBLD_opSUBSTR:
6518       {
6519         ffebld start;
6520         ffebld end;
6521         ffebld thing = ffebld_right (expr);
6522         tree start_tree;
6523         tree end_tree;
6524
6525         assert (ffebld_op (thing) == FFEBLD_opITEM);
6526         start = ffebld_head (thing);
6527         thing = ffebld_trail (thing);
6528         assert (ffebld_trail (thing) == NULL);
6529         end = ffebld_head (thing);
6530
6531         length = ffecom_intrinsic_len_ (ffebld_left (expr));
6532
6533         if (length == error_mark_node)
6534           break;
6535
6536         if (start == NULL)
6537           {
6538             if (end == NULL)
6539               ;
6540             else
6541               {
6542                 length = convert (ffecom_f2c_ftnlen_type_node,
6543                                   ffecom_expr (end));
6544               }
6545           }
6546         else
6547           {
6548             start_tree = convert (ffecom_f2c_ftnlen_type_node,
6549                                   ffecom_expr (start));
6550
6551             if (start_tree == error_mark_node)
6552               {
6553                 length = error_mark_node;
6554                 break;
6555               }
6556
6557             if (end == NULL)
6558               {
6559                 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6560                                    ffecom_f2c_ftnlen_one_node,
6561                                    ffecom_2 (MINUS_EXPR,
6562                                              ffecom_f2c_ftnlen_type_node,
6563                                              length,
6564                                              start_tree));
6565               }
6566             else
6567               {
6568                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
6569                                     ffecom_expr (end));
6570
6571                 if (end_tree == error_mark_node)
6572                   {
6573                     length = error_mark_node;
6574                     break;
6575                   }
6576
6577                 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6578                                    ffecom_f2c_ftnlen_one_node,
6579                                    ffecom_2 (MINUS_EXPR,
6580                                              ffecom_f2c_ftnlen_type_node,
6581                                              end_tree, start_tree));
6582               }
6583           }
6584       }
6585       break;
6586
6587     case FFEBLD_opCONCATENATE:
6588       length
6589         = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6590                     ffecom_intrinsic_len_ (ffebld_left (expr)),
6591                     ffecom_intrinsic_len_ (ffebld_right (expr)));
6592       break;
6593
6594     case FFEBLD_opFUNCREF:
6595     case FFEBLD_opCONVERT:
6596       length = build_int_2 (ffebld_size (expr), 0);
6597       TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6598       break;
6599
6600     default:
6601       assert ("bad op for single char arg expr" == NULL);
6602       length = ffecom_f2c_ftnlen_zero_node;
6603       break;
6604     }
6605
6606   assert (length != NULL_TREE);
6607
6608   return length;
6609 }
6610
6611 /* Handle CHARACTER assignments.
6612
6613    Generates code to do the assignment.  Used by ordinary assignment
6614    statement handler ffecom_let_stmt and by statement-function
6615    handler to generate code for a statement function.  */
6616
6617 static void
6618 ffecom_let_char_ (tree dest_tree, tree dest_length,
6619                   ffetargetCharacterSize dest_size, ffebld source)
6620 {
6621   ffecomConcatList_ catlist;
6622   tree source_length;
6623   tree source_tree;
6624   tree expr_tree;
6625
6626   if ((dest_tree == error_mark_node)
6627       || (dest_length == error_mark_node))
6628     return;
6629
6630   assert (dest_tree != NULL_TREE);
6631   assert (dest_length != NULL_TREE);
6632
6633   /* Source might be an opCONVERT, which just means it is a different size
6634      than the destination.  Since the underlying implementation here handles
6635      that (directly or via the s_copy or s_cat run-time-library functions),
6636      we don't need the "convenience" of an opCONVERT that tells us to
6637      truncate or blank-pad, particularly since the resulting implementation
6638      would probably be slower than otherwise. */
6639
6640   while (ffebld_op (source) == FFEBLD_opCONVERT)
6641     source = ffebld_left (source);
6642
6643   catlist = ffecom_concat_list_new_ (source, dest_size);
6644   switch (ffecom_concat_list_count_ (catlist))
6645     {
6646     case 0:                     /* Shouldn't happen, but in case it does... */
6647       ffecom_concat_list_kill_ (catlist);
6648       source_tree = null_pointer_node;
6649       source_length = ffecom_f2c_ftnlen_zero_node;
6650       expr_tree = build_tree_list (NULL_TREE, dest_tree);
6651       TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6652       TREE_CHAIN (TREE_CHAIN (expr_tree))
6653         = build_tree_list (NULL_TREE, dest_length);
6654       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6655         = build_tree_list (NULL_TREE, source_length);
6656
6657       expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6658       TREE_SIDE_EFFECTS (expr_tree) = 1;
6659
6660       expand_expr_stmt (expr_tree);
6661
6662       return;
6663
6664     case 1:                     /* The (fairly) easy case. */
6665       ffecom_char_args_ (&source_tree, &source_length,
6666                          ffecom_concat_list_expr_ (catlist, 0));
6667       ffecom_concat_list_kill_ (catlist);
6668       assert (source_tree != NULL_TREE);
6669       assert (source_length != NULL_TREE);
6670
6671       if ((source_tree == error_mark_node)
6672           || (source_length == error_mark_node))
6673         return;
6674
6675       if (dest_size == 1)
6676         {
6677           dest_tree
6678             = ffecom_1 (INDIRECT_REF,
6679                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6680                                                       (dest_tree))),
6681                         dest_tree);
6682           dest_tree
6683             = ffecom_2 (ARRAY_REF,
6684                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6685                                                       (dest_tree))),
6686                         dest_tree,
6687                         integer_one_node);
6688           source_tree
6689             = ffecom_1 (INDIRECT_REF,
6690                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6691                                                       (source_tree))),
6692                         source_tree);
6693           source_tree
6694             = ffecom_2 (ARRAY_REF,
6695                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6696                                                       (source_tree))),
6697                         source_tree,
6698                         integer_one_node);
6699
6700           expr_tree = ffecom_modify (void_type_node, dest_tree, source_tree);
6701
6702           expand_expr_stmt (expr_tree);
6703
6704           return;
6705         }
6706
6707       expr_tree = build_tree_list (NULL_TREE, dest_tree);
6708       TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6709       TREE_CHAIN (TREE_CHAIN (expr_tree))
6710         = build_tree_list (NULL_TREE, dest_length);
6711       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6712         = build_tree_list (NULL_TREE, source_length);
6713
6714       expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6715       TREE_SIDE_EFFECTS (expr_tree) = 1;
6716
6717       expand_expr_stmt (expr_tree);
6718
6719       return;
6720
6721     default:                    /* Must actually concatenate things. */
6722       break;
6723     }
6724
6725   /* Heavy-duty concatenation. */
6726
6727   {
6728     int count = ffecom_concat_list_count_ (catlist);
6729     int i;
6730     tree lengths;
6731     tree items;
6732     tree length_array;
6733     tree item_array;
6734     tree citem;
6735     tree clength;
6736
6737 #ifdef HOHO
6738     length_array
6739       = lengths
6740       = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
6741                              FFETARGET_charactersizeNONE, count, TRUE);
6742     item_array = items = ffecom_push_tempvar (ffecom_f2c_address_type_node,
6743                                               FFETARGET_charactersizeNONE,
6744                                               count, TRUE);
6745 #else
6746     {
6747       tree hook;
6748
6749       hook = ffebld_nonter_hook (source);
6750       assert (hook);
6751       assert (TREE_CODE (hook) == TREE_VEC);
6752       assert (TREE_VEC_LENGTH (hook) == 2);
6753       length_array = lengths = TREE_VEC_ELT (hook, 0);
6754       item_array = items = TREE_VEC_ELT (hook, 1);
6755     }
6756 #endif
6757
6758     for (i = 0; i < count; ++i)
6759       {
6760         ffecom_char_args_ (&citem, &clength,
6761                            ffecom_concat_list_expr_ (catlist, i));
6762         if ((citem == error_mark_node)
6763             || (clength == error_mark_node))
6764           {
6765             ffecom_concat_list_kill_ (catlist);
6766             return;
6767           }
6768
6769         items
6770           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
6771                       ffecom_modify (void_type_node,
6772                                      ffecom_2 (ARRAY_REF,
6773                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
6774                                                item_array,
6775                                                build_int_2 (i, 0)),
6776                                      citem),
6777                       items);
6778         lengths
6779           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
6780                       ffecom_modify (void_type_node,
6781                                      ffecom_2 (ARRAY_REF,
6782                    TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
6783                                                length_array,
6784                                                build_int_2 (i, 0)),
6785                                      clength),
6786                       lengths);
6787       }
6788
6789     expr_tree = build_tree_list (NULL_TREE, dest_tree);
6790     TREE_CHAIN (expr_tree)
6791       = build_tree_list (NULL_TREE,
6792                          ffecom_1 (ADDR_EXPR,
6793                                    build_pointer_type (TREE_TYPE (items)),
6794                                    items));
6795     TREE_CHAIN (TREE_CHAIN (expr_tree))
6796       = build_tree_list (NULL_TREE,
6797                          ffecom_1 (ADDR_EXPR,
6798                                    build_pointer_type (TREE_TYPE (lengths)),
6799                                    lengths));
6800     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6801       = build_tree_list
6802         (NULL_TREE,
6803          ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
6804                    convert (ffecom_f2c_ftnlen_type_node,
6805                             build_int_2 (count, 0))));
6806     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree))))
6807       = build_tree_list (NULL_TREE, dest_length);
6808
6809     expr_tree = ffecom_call_gfrt (FFECOM_gfrtCAT, expr_tree, NULL_TREE);
6810     TREE_SIDE_EFFECTS (expr_tree) = 1;
6811
6812     expand_expr_stmt (expr_tree);
6813   }
6814
6815   ffecom_concat_list_kill_ (catlist);
6816 }
6817
6818 /* ffecom_make_gfrt_ -- Make initial info for run-time routine
6819
6820    ffecomGfrt ix;
6821    ffecom_make_gfrt_(ix);
6822
6823    Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL
6824    for the indicated run-time routine (ix).  */
6825
6826 static void
6827 ffecom_make_gfrt_ (ffecomGfrt ix)
6828 {
6829   tree t;
6830   tree ttype;
6831
6832   switch (ffecom_gfrt_type_[ix])
6833     {
6834     case FFECOM_rttypeVOID_:
6835       ttype = void_type_node;
6836       break;
6837
6838     case FFECOM_rttypeVOIDSTAR_:
6839       ttype = TREE_TYPE (null_pointer_node);    /* `void *'. */
6840       break;
6841
6842     case FFECOM_rttypeFTNINT_:
6843       ttype = ffecom_f2c_ftnint_type_node;
6844       break;
6845
6846     case FFECOM_rttypeINTEGER_:
6847       ttype = ffecom_f2c_integer_type_node;
6848       break;
6849
6850     case FFECOM_rttypeLONGINT_:
6851       ttype = ffecom_f2c_longint_type_node;
6852       break;
6853
6854     case FFECOM_rttypeLOGICAL_:
6855       ttype = ffecom_f2c_logical_type_node;
6856       break;
6857
6858     case FFECOM_rttypeREAL_F2C_:
6859       ttype = double_type_node;
6860       break;
6861
6862     case FFECOM_rttypeREAL_GNU_:
6863       ttype = float_type_node;
6864       break;
6865
6866     case FFECOM_rttypeCOMPLEX_F2C_:
6867       ttype = void_type_node;
6868       break;
6869
6870     case FFECOM_rttypeCOMPLEX_GNU_:
6871       ttype = ffecom_f2c_complex_type_node;
6872       break;
6873
6874     case FFECOM_rttypeDOUBLE_:
6875       ttype = double_type_node;
6876       break;
6877
6878     case FFECOM_rttypeDOUBLEREAL_:
6879       ttype = ffecom_f2c_doublereal_type_node;
6880       break;
6881
6882     case FFECOM_rttypeDBLCMPLX_F2C_:
6883       ttype = void_type_node;
6884       break;
6885
6886     case FFECOM_rttypeDBLCMPLX_GNU_:
6887       ttype = ffecom_f2c_doublecomplex_type_node;
6888       break;
6889
6890     case FFECOM_rttypeCHARACTER_:
6891       ttype = void_type_node;
6892       break;
6893
6894     default:
6895       ttype = NULL;
6896       assert ("bad rttype" == NULL);
6897       break;
6898     }
6899
6900   ttype = build_function_type (ttype, NULL_TREE);
6901   t = build_decl (FUNCTION_DECL,
6902                   get_identifier (ffecom_gfrt_name_[ix]),
6903                   ttype);
6904   DECL_EXTERNAL (t) = 1;
6905   TREE_READONLY (t) = ffecom_gfrt_const_[ix] ? 1 : 0;
6906   TREE_PUBLIC (t) = 1;
6907   TREE_THIS_VOLATILE (t) = ffecom_gfrt_volatile_[ix] ? 1 : 0;
6908
6909   /* Sanity check:  A function that's const cannot be volatile.  */
6910
6911   assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_volatile_[ix] : 1);
6912
6913   /* Sanity check: A function that's const cannot return complex.  */
6914
6915   assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_complex_[ix] : 1);
6916
6917   t = start_decl (t, TRUE);
6918
6919   finish_decl (t, NULL_TREE, TRUE);
6920
6921   ffecom_gfrt_[ix] = t;
6922 }
6923
6924 /* Phase 1 pass over each member of a COMMON/EQUIVALENCE group.  */
6925
6926 static void
6927 ffecom_member_phase1_ (ffestorag mst UNUSED, ffestorag st)
6928 {
6929   ffesymbol s = ffestorag_symbol (st);
6930
6931   if (ffesymbol_namelisted (s))
6932     ffecom_member_namelisted_ = TRUE;
6933 }
6934
6935 /* Phase 2 pass over each member of a COMMON/EQUIVALENCE group.  Declare
6936    the member so debugger will see it.  Otherwise nobody should be
6937    referencing the member.  */
6938
6939 static void
6940 ffecom_member_phase2_ (ffestorag mst, ffestorag st)
6941 {
6942   ffesymbol s;
6943   tree t;
6944   tree mt;
6945   tree type;
6946
6947   if ((mst == NULL)
6948       || ((mt = ffestorag_hook (mst)) == NULL)
6949       || (mt == error_mark_node))
6950     return;
6951
6952   if ((st == NULL)
6953       || ((s = ffestorag_symbol (st)) == NULL))
6954     return;
6955
6956   type = ffecom_type_localvar_ (s,
6957                                 ffesymbol_basictype (s),
6958                                 ffesymbol_kindtype (s));
6959   if (type == error_mark_node)
6960     return;
6961
6962   t = build_decl (VAR_DECL,
6963                   ffecom_get_identifier_ (ffesymbol_text (s)),
6964                   type);
6965
6966   TREE_STATIC (t) = TREE_STATIC (mt);
6967   DECL_INITIAL (t) = NULL_TREE;
6968   TREE_ASM_WRITTEN (t) = 1;
6969   TREE_USED (t) = 1;
6970
6971   SET_DECL_RTL (t,
6972                 gen_rtx (MEM, TYPE_MODE (type),
6973                          plus_constant (XEXP (DECL_RTL (mt), 0),
6974                                         ffestorag_modulo (mst)
6975                                         + ffestorag_offset (st)
6976                                         - ffestorag_offset (mst))));
6977
6978   t = start_decl (t, FALSE);
6979
6980   finish_decl (t, NULL_TREE, FALSE);
6981 }
6982
6983 /* Prepare source expression for assignment into a destination perhaps known
6984    to be of a specific size.  */
6985
6986 static void
6987 ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size, ffebld source)
6988 {
6989   ffecomConcatList_ catlist;
6990   int count;
6991   int i;
6992   tree ltmp;
6993   tree itmp;
6994   tree tempvar = NULL_TREE;
6995
6996   while (ffebld_op (source) == FFEBLD_opCONVERT)
6997     source = ffebld_left (source);
6998
6999   catlist = ffecom_concat_list_new_ (source, dest_size);
7000   count = ffecom_concat_list_count_ (catlist);
7001
7002   if (count >= 2)
7003     {
7004       ltmp
7005         = ffecom_make_tempvar ("let_char_len", ffecom_f2c_ftnlen_type_node,
7006                                FFETARGET_charactersizeNONE, count);
7007       itmp
7008         = ffecom_make_tempvar ("let_char_item", ffecom_f2c_address_type_node,
7009                                FFETARGET_charactersizeNONE, count);
7010
7011       tempvar = make_tree_vec (2);
7012       TREE_VEC_ELT (tempvar, 0) = ltmp;
7013       TREE_VEC_ELT (tempvar, 1) = itmp;
7014     }
7015
7016   for (i = 0; i < count; ++i)
7017     ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist, i));
7018
7019   ffecom_concat_list_kill_ (catlist);
7020
7021   if (tempvar)
7022     {
7023       ffebld_nonter_set_hook (source, tempvar);
7024       current_binding_level->prep_state = 1;
7025     }
7026 }
7027
7028 /* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order
7029
7030    Ignores STAR (alternate-return) dummies.  All other get exec-transitioned
7031    (which generates their trees) and then their trees get push_parm_decl'd.
7032
7033    The second arg is TRUE if the dummies are for a statement function, in
7034    which case lengths are not pushed for character arguments (since they are
7035    always known by both the caller and the callee, though the code allows
7036    for someday permitting CHAR*(*) stmtfunc dummies).  */
7037
7038 static void
7039 ffecom_push_dummy_decls_ (ffebld dummy_list, bool stmtfunc)
7040 {
7041   ffebld dummy;
7042   ffebld dumlist;
7043   ffesymbol s;
7044   tree parm;
7045
7046   ffecom_transform_only_dummies_ = TRUE;
7047
7048   /* First push the parms corresponding to actual dummy "contents".  */
7049
7050   for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7051     {
7052       dummy = ffebld_head (dumlist);
7053       switch (ffebld_op (dummy))
7054         {
7055         case FFEBLD_opSTAR:
7056         case FFEBLD_opANY:
7057           continue;             /* Forget alternate returns. */
7058
7059         default:
7060           break;
7061         }
7062       assert (ffebld_op (dummy) == FFEBLD_opSYMTER);
7063       s = ffebld_symter (dummy);
7064       parm = ffesymbol_hook (s).decl_tree;
7065       if (parm == NULL_TREE)
7066         {
7067           s = ffecom_sym_transform_ (s);
7068           parm = ffesymbol_hook (s).decl_tree;
7069           assert (parm != NULL_TREE);
7070         }
7071       if (parm != error_mark_node)
7072         push_parm_decl (parm);
7073     }
7074
7075   /* Then, for CHARACTER dummies, push the parms giving their lengths.  */
7076
7077   for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7078     {
7079       dummy = ffebld_head (dumlist);
7080       switch (ffebld_op (dummy))
7081         {
7082         case FFEBLD_opSTAR:
7083         case FFEBLD_opANY:
7084           continue;             /* Forget alternate returns, they mean
7085                                    NOTHING! */
7086
7087         default:
7088           break;
7089         }
7090       s = ffebld_symter (dummy);
7091       if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
7092         continue;               /* Only looking for CHARACTER arguments. */
7093       if (stmtfunc && (ffesymbol_size (s) != FFETARGET_charactersizeNONE))
7094         continue;               /* Stmtfunc arg with known size needs no
7095                                    length param. */
7096       if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
7097         continue;               /* Only looking for variables and arrays. */
7098       parm = ffesymbol_hook (s).length_tree;
7099       assert (parm != NULL_TREE);
7100       if (parm != error_mark_node)
7101         push_parm_decl (parm);
7102     }
7103
7104   ffecom_transform_only_dummies_ = FALSE;
7105 }
7106
7107 /* ffecom_start_progunit_ -- Beginning of program unit
7108
7109    Does GNU back end stuff necessary to teach it about the start of its
7110    equivalent of a Fortran program unit.  */
7111
7112 static void
7113 ffecom_start_progunit_ ()
7114 {
7115   ffesymbol fn = ffecom_primary_entry_;
7116   ffebld arglist;
7117   tree id;                      /* Identifier (name) of function. */
7118   tree type;                    /* Type of function. */
7119   tree result;                  /* Result of function. */
7120   ffeinfoBasictype bt;
7121   ffeinfoKindtype kt;
7122   ffeglobal g;
7123   ffeglobalType gt;
7124   ffeglobalType egt = FFEGLOBAL_type;
7125   bool charfunc;
7126   bool cmplxfunc;
7127   bool altentries = (ffecom_num_entrypoints_ != 0);
7128   bool multi
7129   = altentries
7130   && (ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
7131   && (ffecom_master_bt_ == FFEINFO_basictypeNONE);
7132   bool main_program = FALSE;
7133   int old_lineno = lineno;
7134   const char *old_input_filename = input_filename;
7135
7136   assert (fn != NULL);
7137   assert (ffesymbol_hook (fn).decl_tree == NULL_TREE);
7138
7139   input_filename = ffesymbol_where_filename (fn);
7140   lineno = ffesymbol_where_filelinenum (fn);
7141
7142   switch (ffecom_primary_entry_kind_)
7143     {
7144     case FFEINFO_kindPROGRAM:
7145       main_program = TRUE;
7146       gt = FFEGLOBAL_typeMAIN;
7147       bt = FFEINFO_basictypeNONE;
7148       kt = FFEINFO_kindtypeNONE;
7149       type = ffecom_tree_fun_type_void;
7150       charfunc = FALSE;
7151       cmplxfunc = FALSE;
7152       break;
7153
7154     case FFEINFO_kindBLOCKDATA:
7155       gt = FFEGLOBAL_typeBDATA;
7156       bt = FFEINFO_basictypeNONE;
7157       kt = FFEINFO_kindtypeNONE;
7158       type = ffecom_tree_fun_type_void;
7159       charfunc = FALSE;
7160       cmplxfunc = FALSE;
7161       break;
7162
7163     case FFEINFO_kindFUNCTION:
7164       gt = FFEGLOBAL_typeFUNC;
7165       egt = FFEGLOBAL_typeEXT;
7166       bt = ffesymbol_basictype (fn);
7167       kt = ffesymbol_kindtype (fn);
7168       if (bt == FFEINFO_basictypeNONE)
7169         {
7170           ffeimplic_establish_symbol (fn);
7171           if (ffesymbol_funcresult (fn) != NULL)
7172             ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
7173           bt = ffesymbol_basictype (fn);
7174           kt = ffesymbol_kindtype (fn);
7175         }
7176
7177       if (multi)
7178         charfunc = cmplxfunc = FALSE;
7179       else if (bt == FFEINFO_basictypeCHARACTER)
7180         charfunc = TRUE, cmplxfunc = FALSE;
7181       else if ((bt == FFEINFO_basictypeCOMPLEX)
7182                && ffesymbol_is_f2c (fn)
7183                && !altentries)
7184         charfunc = FALSE, cmplxfunc = TRUE;
7185       else
7186         charfunc = cmplxfunc = FALSE;
7187
7188       if (multi || charfunc)
7189         type = ffecom_tree_fun_type_void;
7190       else if (ffesymbol_is_f2c (fn) && !altentries)
7191         type = ffecom_tree_fun_type[bt][kt];
7192       else
7193         type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
7194
7195       if ((type == NULL_TREE)
7196           || (TREE_TYPE (type) == NULL_TREE))
7197         type = ffecom_tree_fun_type_void;       /* _sym_exec_transition. */
7198       break;
7199
7200     case FFEINFO_kindSUBROUTINE:
7201       gt = FFEGLOBAL_typeSUBR;
7202       egt = FFEGLOBAL_typeEXT;
7203       bt = FFEINFO_basictypeNONE;
7204       kt = FFEINFO_kindtypeNONE;
7205       if (ffecom_is_altreturning_)
7206         type = ffecom_tree_subr_type;
7207       else
7208         type = ffecom_tree_fun_type_void;
7209       charfunc = FALSE;
7210       cmplxfunc = FALSE;
7211       break;
7212
7213     default:
7214       assert ("say what??" == NULL);
7215       /* Fall through. */
7216     case FFEINFO_kindANY:
7217       gt = FFEGLOBAL_typeANY;
7218       bt = FFEINFO_basictypeNONE;
7219       kt = FFEINFO_kindtypeNONE;
7220       type = error_mark_node;
7221       charfunc = FALSE;
7222       cmplxfunc = FALSE;
7223       break;
7224     }
7225
7226   if (altentries)
7227     {
7228       id = ffecom_get_invented_identifier ("__g77_masterfun_%s",
7229                                            ffesymbol_text (fn));
7230     }
7231 #if FFETARGET_isENFORCED_MAIN
7232   else if (main_program)
7233     id = get_identifier (FFETARGET_nameENFORCED_MAIN_NAME);
7234 #endif
7235   else
7236     id = ffecom_get_external_identifier_ (fn);
7237
7238   start_function (id,
7239                   type,
7240                   0,            /* nested/inline */
7241                   !altentries); /* TREE_PUBLIC */
7242
7243   TREE_USED (current_function_decl) = 1;        /* Avoid spurious warning if altentries. */
7244
7245   if (!altentries
7246       && ((g = ffesymbol_global (fn)) != NULL)
7247       && ((ffeglobal_type (g) == gt)
7248           || (ffeglobal_type (g) == egt)))
7249     {
7250       ffeglobal_set_hook (g, current_function_decl);
7251     }
7252
7253   /* Arg handling needs exec-transitioned ffesymbols to work with.  But
7254      exec-transitioning needs current_function_decl to be filled in.  So we
7255      do these things in two phases. */
7256
7257   if (altentries)
7258     {                           /* 1st arg identifies which entrypoint. */
7259       ffecom_which_entrypoint_decl_
7260         = build_decl (PARM_DECL,
7261                       ffecom_get_invented_identifier ("__g77_%s",
7262                                                       "which_entrypoint"),
7263                       integer_type_node);
7264       push_parm_decl (ffecom_which_entrypoint_decl_);
7265     }
7266
7267   if (charfunc
7268       || cmplxfunc
7269       || multi)
7270     {                           /* Arg for result (return value). */
7271       tree type;
7272       tree length;
7273
7274       if (charfunc)
7275         type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
7276       else if (cmplxfunc)
7277         type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
7278       else
7279         type = ffecom_multi_type_node_;
7280
7281       result = ffecom_get_invented_identifier ("__g77_%s", "result");
7282
7283       /* Make length arg _and_ enhance type info for CHAR arg itself.  */
7284
7285       if (charfunc)
7286         length = ffecom_char_enhance_arg_ (&type, fn);
7287       else
7288         length = NULL_TREE;     /* Not ref'd if !charfunc. */
7289
7290       type = build_pointer_type (type);
7291       result = build_decl (PARM_DECL, result, type);
7292
7293       push_parm_decl (result);
7294       if (multi)
7295         ffecom_multi_retval_ = result;
7296       else
7297         ffecom_func_result_ = result;
7298
7299       if (charfunc)
7300         {
7301           push_parm_decl (length);
7302           ffecom_func_length_ = length;
7303         }
7304     }
7305
7306   if (ffecom_primary_entry_is_proc_)
7307     {
7308       if (altentries)
7309         arglist = ffecom_master_arglist_;
7310       else
7311         arglist = ffesymbol_dummyargs (fn);
7312       ffecom_push_dummy_decls_ (arglist, FALSE);
7313     }
7314
7315   if (TREE_CODE (current_function_decl) != ERROR_MARK)
7316     store_parm_decls (main_program ? 1 : 0);
7317
7318   ffecom_start_compstmt ();
7319   /* Disallow temp vars at this level.  */
7320   current_binding_level->prep_state = 2;
7321
7322   lineno = old_lineno;
7323   input_filename = old_input_filename;
7324
7325   /* This handles any symbols still untransformed, in case -g specified.
7326      This used to be done in ffecom_finish_progunit, but it turns out to
7327      be necessary to do it here so that statement functions are
7328      expanded before code.  But don't bother for BLOCK DATA.  */
7329
7330   if (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
7331     ffesymbol_drive (ffecom_finish_symbol_transform_);
7332 }
7333
7334 /* ffecom_sym_transform_ -- Transform FFE sym into backend sym
7335
7336    ffesymbol s;
7337    ffecom_sym_transform_(s);
7338
7339    The ffesymbol_hook info for s is updated with appropriate backend info
7340    on the symbol.  */
7341
7342 static ffesymbol
7343 ffecom_sym_transform_ (ffesymbol s)
7344 {
7345   tree t;                       /* Transformed thingy. */
7346   tree tlen;                    /* Length if CHAR*(*). */
7347   bool addr;                    /* Is t the address of the thingy? */
7348   ffeinfoBasictype bt;
7349   ffeinfoKindtype kt;
7350   ffeglobal g;
7351   int old_lineno = lineno;
7352   const char *old_input_filename = input_filename;
7353
7354   /* Must ensure special ASSIGN variables are declared at top of outermost
7355      block, else they'll end up in the innermost block when their first
7356      ASSIGN is seen, which leaves them out of scope when they're the
7357      subject of a GOTO or I/O statement.
7358
7359      We make this variable even if -fugly-assign.  Just let it go unused,
7360      in case it turns out there are cases where we really want to use this
7361      variable anyway (e.g. ASSIGN to INTEGER*2 variable).  */
7362
7363   if (! ffecom_transform_only_dummies_
7364       && ffesymbol_assigned (s)
7365       && ! ffesymbol_hook (s).assign_tree)
7366     s = ffecom_sym_transform_assign_ (s);
7367
7368   if (ffesymbol_sfdummyparent (s) == NULL)
7369     {
7370       input_filename = ffesymbol_where_filename (s);
7371       lineno = ffesymbol_where_filelinenum (s);
7372     }
7373   else
7374     {
7375       ffesymbol sf = ffesymbol_sfdummyparent (s);
7376
7377       input_filename = ffesymbol_where_filename (sf);
7378       lineno = ffesymbol_where_filelinenum (sf);
7379     }
7380
7381   bt = ffeinfo_basictype (ffebld_info (s));
7382   kt = ffeinfo_kindtype (ffebld_info (s));
7383
7384   t = NULL_TREE;
7385   tlen = NULL_TREE;
7386   addr = FALSE;
7387
7388   switch (ffesymbol_kind (s))
7389     {
7390     case FFEINFO_kindNONE:
7391       switch (ffesymbol_where (s))
7392         {
7393         case FFEINFO_whereDUMMY:        /* Subroutine or function. */
7394           assert (ffecom_transform_only_dummies_);
7395
7396           /* Before 0.4, this could be ENTITY/DUMMY, but see
7397              ffestu_sym_end_transition -- no longer true (in particular, if
7398              it could be an ENTITY, it _will_ be made one, so that
7399              possibility won't come through here).  So we never make length
7400              arg for CHARACTER type.  */
7401
7402           t = build_decl (PARM_DECL,
7403                           ffecom_get_identifier_ (ffesymbol_text (s)),
7404                           ffecom_tree_ptr_to_subr_type);
7405           DECL_ARTIFICIAL (t) = 1;
7406           addr = TRUE;
7407           break;
7408
7409         case FFEINFO_whereGLOBAL:       /* Subroutine or function. */
7410           assert (!ffecom_transform_only_dummies_);
7411
7412           if (((g = ffesymbol_global (s)) != NULL)
7413               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7414                   || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7415                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
7416               && (ffeglobal_hook (g) != NULL_TREE)
7417               && ffe_is_globals ())
7418             {
7419               t = ffeglobal_hook (g);
7420               break;
7421             }
7422
7423           t = build_decl (FUNCTION_DECL,
7424                           ffecom_get_external_identifier_ (s),
7425                           ffecom_tree_subr_type);       /* Assume subr. */
7426           DECL_EXTERNAL (t) = 1;
7427           TREE_PUBLIC (t) = 1;
7428
7429           t = start_decl (t, FALSE);
7430           finish_decl (t, NULL_TREE, FALSE);
7431
7432           if ((g != NULL)
7433               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7434                   || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7435                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
7436             ffeglobal_set_hook (g, t);
7437
7438           ffecom_save_tree_forever (t);
7439
7440           break;
7441
7442         default:
7443           assert ("NONE where unexpected" == NULL);
7444           /* Fall through. */
7445         case FFEINFO_whereANY:
7446           break;
7447         }
7448       break;
7449
7450     case FFEINFO_kindENTITY:
7451       switch (ffeinfo_where (ffesymbol_info (s)))
7452         {
7453
7454         case FFEINFO_whereCONSTANT:
7455           /* ~~Debugging info needed? */
7456           assert (!ffecom_transform_only_dummies_);
7457           t = error_mark_node;  /* Shouldn't ever see this in expr. */
7458           break;
7459
7460         case FFEINFO_whereLOCAL:
7461           assert (!ffecom_transform_only_dummies_);
7462
7463           {
7464             ffestorag st = ffesymbol_storage (s);
7465             tree type;
7466
7467             if ((st != NULL)
7468                 && (ffestorag_size (st) == 0))
7469               {
7470                 t = error_mark_node;
7471                 break;
7472               }
7473
7474             type = ffecom_type_localvar_ (s, bt, kt);
7475
7476             if (type == error_mark_node)
7477               {
7478                 t = error_mark_node;
7479                 break;
7480               }
7481
7482             if ((st != NULL)
7483                 && (ffestorag_parent (st) != NULL))
7484               {                 /* Child of EQUIVALENCE parent. */
7485                 ffestorag est;
7486                 tree et;
7487                 ffetargetOffset offset;
7488
7489                 est = ffestorag_parent (st);
7490                 ffecom_transform_equiv_ (est);
7491
7492                 et = ffestorag_hook (est);
7493                 assert (et != NULL_TREE);
7494
7495                 if (! TREE_STATIC (et))
7496                   put_var_into_stack (et);
7497
7498                 offset = ffestorag_modulo (est)
7499                   + ffestorag_offset (ffesymbol_storage (s))
7500                   - ffestorag_offset (est);
7501
7502                 ffecom_debug_kludge_ (et, "EQUIVALENCE", s, type, offset);
7503
7504                 /* (t_type *) (((char *) &et) + offset) */
7505
7506                 t = convert (string_type_node,  /* (char *) */
7507                              ffecom_1 (ADDR_EXPR,
7508                                        build_pointer_type (TREE_TYPE (et)),
7509                                        et));
7510                 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
7511                               t,
7512                               build_int_2 (offset, 0));
7513                 t = convert (build_pointer_type (type),
7514                              t);
7515                 TREE_CONSTANT (t) = staticp (et);
7516
7517                 addr = TRUE;
7518               }
7519             else
7520               {
7521                 tree initexpr;
7522                 bool init = ffesymbol_is_init (s);
7523
7524                 t = build_decl (VAR_DECL,
7525                                 ffecom_get_identifier_ (ffesymbol_text (s)),
7526                                 type);
7527
7528                 if (init
7529                     || ffesymbol_namelisted (s)
7530 #ifdef FFECOM_sizeMAXSTACKITEM
7531                     || ((st != NULL)
7532                         && (ffestorag_size (st) > FFECOM_sizeMAXSTACKITEM))
7533 #endif
7534                     || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
7535                         && (ffecom_primary_entry_kind_
7536                             != FFEINFO_kindBLOCKDATA)
7537                         && (ffesymbol_is_save (s) || ffe_is_saveall ())))
7538                   TREE_STATIC (t) = !ffesymbol_attr (s, FFESYMBOL_attrADJUSTABLE);
7539                 else
7540                   TREE_STATIC (t) = 0;  /* No need to make static. */
7541
7542                 if (init || ffe_is_init_local_zero ())
7543                   DECL_INITIAL (t) = error_mark_node;
7544
7545                 /* Keep -Wunused from complaining about var if it
7546                    is used as sfunc arg or DATA implied-DO.  */
7547                 if (ffesymbol_attrs (s) & FFESYMBOL_attrsSFARG)
7548                   DECL_IN_SYSTEM_HEADER (t) = 1;
7549
7550                 t = start_decl (t, FALSE);
7551
7552                 if (init)
7553                   {
7554                     if (ffesymbol_init (s) != NULL)
7555                       initexpr = ffecom_expr (ffesymbol_init (s));
7556                     else
7557                       initexpr = ffecom_init_zero_ (t);
7558                   }
7559                 else if (ffe_is_init_local_zero ())
7560                   initexpr = ffecom_init_zero_ (t);
7561                 else
7562                   initexpr = NULL_TREE; /* Not ref'd if !init. */
7563
7564                 finish_decl (t, initexpr, FALSE);
7565
7566                 if (st != NULL && DECL_SIZE (t) != error_mark_node)
7567                   {
7568                     assert (TREE_CODE (DECL_SIZE_UNIT (t)) == INTEGER_CST);
7569                     assert (0 == compare_tree_int (DECL_SIZE_UNIT (t),
7570                                                    ffestorag_size (st)));
7571                   }
7572               }
7573           }
7574           break;
7575
7576         case FFEINFO_whereRESULT:
7577           assert (!ffecom_transform_only_dummies_);
7578
7579           if (bt == FFEINFO_basictypeCHARACTER)
7580             {                   /* Result is already in list of dummies, use
7581                                    it (& length). */
7582               t = ffecom_func_result_;
7583               tlen = ffecom_func_length_;
7584               addr = TRUE;
7585               break;
7586             }
7587           if ((ffecom_num_entrypoints_ == 0)
7588               && (bt == FFEINFO_basictypeCOMPLEX)
7589               && (ffesymbol_is_f2c (ffecom_primary_entry_)))
7590             {                   /* Result is already in list of dummies, use
7591                                    it. */
7592               t = ffecom_func_result_;
7593               addr = TRUE;
7594               break;
7595             }
7596           if (ffecom_func_result_ != NULL_TREE)
7597             {
7598               t = ffecom_func_result_;
7599               break;
7600             }
7601           if ((ffecom_num_entrypoints_ != 0)
7602               && (ffecom_master_bt_ == FFEINFO_basictypeNONE))
7603             {
7604               assert (ffecom_multi_retval_ != NULL_TREE);
7605               t = ffecom_1 (INDIRECT_REF, ffecom_multi_type_node_,
7606                             ffecom_multi_retval_);
7607               t = ffecom_2 (COMPONENT_REF, ffecom_tree_type[bt][kt],
7608                             t, ffecom_multi_fields_[bt][kt]);
7609
7610               break;
7611             }
7612
7613           t = build_decl (VAR_DECL,
7614                           ffecom_get_identifier_ (ffesymbol_text (s)),
7615                           ffecom_tree_type[bt][kt]);
7616           TREE_STATIC (t) = 0;  /* Put result on stack. */
7617           t = start_decl (t, FALSE);
7618           finish_decl (t, NULL_TREE, FALSE);
7619
7620           ffecom_func_result_ = t;
7621
7622           break;
7623
7624         case FFEINFO_whereDUMMY:
7625           {
7626             tree type;
7627             ffebld dl;
7628             ffebld dim;
7629             tree low;
7630             tree high;
7631             tree old_sizes;
7632             bool adjustable = FALSE;    /* Conditionally adjustable? */
7633
7634             type = ffecom_tree_type[bt][kt];
7635             if (ffesymbol_sfdummyparent (s) != NULL)
7636               {
7637                 if (current_function_decl == ffecom_outer_function_decl_)
7638                   {                     /* Exec transition before sfunc
7639                                            context; get it later. */
7640                     break;
7641                   }
7642                 t = ffecom_get_identifier_ (ffesymbol_text
7643                                             (ffesymbol_sfdummyparent (s)));
7644               }
7645             else
7646               t = ffecom_get_identifier_ (ffesymbol_text (s));
7647
7648             assert (ffecom_transform_only_dummies_);
7649
7650             old_sizes = get_pending_sizes ();
7651             put_pending_sizes (old_sizes);
7652
7653             if (bt == FFEINFO_basictypeCHARACTER)
7654               tlen = ffecom_char_enhance_arg_ (&type, s);
7655             type = ffecom_check_size_overflow_ (s, type, TRUE);
7656
7657             for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
7658               {
7659                 if (type == error_mark_node)
7660                   break;
7661
7662                 dim = ffebld_head (dl);
7663                 assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
7664                 if ((ffebld_left (dim) == NULL) || ffecom_doing_entry_)
7665                   low = ffecom_integer_one_node;
7666                 else
7667                   low = ffecom_expr (ffebld_left (dim));
7668                 assert (ffebld_right (dim) != NULL);
7669                 if ((ffebld_op (ffebld_right (dim)) == FFEBLD_opSTAR)
7670                     || ffecom_doing_entry_)
7671                   {
7672                     /* Used to just do high=low.  But for ffecom_tree_
7673                        canonize_ref_, it probably is important to correctly
7674                        assess the size.  E.g. given COMPLEX C(*),CFUNC and
7675                        C(2)=CFUNC(C), overlap can happen, while it can't
7676                        for, say, C(1)=CFUNC(C(2)).  */
7677                     /* Even more recently used to set to INT_MAX, but that
7678                        broke when some overflow checking went into the back
7679                        end.  Now we just leave the upper bound unspecified.  */
7680                     high = NULL;
7681                   }
7682                 else
7683                   high = ffecom_expr (ffebld_right (dim));
7684
7685                 /* Determine whether array is conditionally adjustable,
7686                    to decide whether back-end magic is needed.
7687
7688                    Normally the front end uses the back-end function
7689                    variable_size to wrap SAVE_EXPR's around expressions
7690                    affecting the size/shape of an array so that the
7691                    size/shape info doesn't change during execution
7692                    of the compiled code even though variables and
7693                    functions referenced in those expressions might.
7694
7695                    variable_size also makes sure those saved expressions
7696                    get evaluated immediately upon entry to the
7697                    compiled procedure -- the front end normally doesn't
7698                    have to worry about that.
7699
7700                    However, there is a problem with this that affects
7701                    g77's implementation of entry points, and that is
7702                    that it is _not_ true that each invocation of the
7703                    compiled procedure is permitted to evaluate
7704                    array size/shape info -- because it is possible
7705                    that, for some invocations, that info is invalid (in
7706                    which case it is "promised" -- i.e. a violation of
7707                    the Fortran standard -- that the compiled code
7708                    won't reference the array or its size/shape
7709                    during that particular invocation).
7710
7711                    To phrase this in C terms, consider this gcc function:
7712
7713                      void foo (int *n, float (*a)[*n])
7714                      {
7715                        // a is "pointer to array ...", fyi.
7716                      }
7717
7718                    Suppose that, for some invocations, it is permitted
7719                    for a caller of foo to do this:
7720
7721                        foo (NULL, NULL);
7722
7723                    Now the _written_ code for foo can take such a call
7724                    into account by either testing explicitly for whether
7725                    (a == NULL) || (n == NULL) -- presumably it is
7726                    not permitted to reference *a in various fashions
7727                    if (n == NULL) I suppose -- or it can avoid it by
7728                    looking at other info (other arguments, static/global
7729                    data, etc.).
7730
7731                    However, this won't work in gcc 2.5.8 because it'll
7732                    automatically emit the code to save the "*n"
7733                    expression, which'll yield a NULL dereference for
7734                    the "foo (NULL, NULL)" call, something the code
7735                    for foo cannot prevent.
7736
7737                    g77 definitely needs to avoid executing such
7738                    code anytime the pointer to the adjustable array
7739                    is NULL, because even if its bounds expressions
7740                    don't have any references to possible "absent"
7741                    variables like "*n" -- say all variable references
7742                    are to COMMON variables, i.e. global (though in C,
7743                    local static could actually make sense) -- the
7744                    expressions could yield other run-time problems
7745                    for allowably "dead" values in those variables.
7746
7747                    For example, let's consider a more complicated
7748                    version of foo:
7749
7750                      extern int i;
7751                      extern int j;
7752
7753                      void foo (float (*a)[i/j])
7754                      {
7755                        ...
7756                      }
7757
7758                    The above is (essentially) quite valid for Fortran
7759                    but, again, for a call like "foo (NULL);", it is
7760                    permitted for i and j to be undefined when the
7761                    call is made.  If j happened to be zero, for
7762                    example, emitting the code to evaluate "i/j"
7763                    could result in a run-time error.
7764
7765                    Offhand, though I don't have my F77 or F90
7766                    standards handy, it might even be valid for a
7767                    bounds expression to contain a function reference,
7768                    in which case I doubt it is permitted for an
7769                    implementation to invoke that function in the
7770                    Fortran case involved here (invocation of an
7771                    alternate ENTRY point that doesn't have the adjustable
7772                    array as one of its arguments).
7773
7774                    So, the code that the compiler would normally emit
7775                    to preevaluate the size/shape info for an
7776                    adjustable array _must not_ be executed at run time
7777                    in certain cases.  Specifically, for Fortran,
7778                    the case is when the pointer to the adjustable
7779                    array == NULL.  (For gnu-ish C, it might be nice
7780                    for the source code itself to specify an expression
7781                    that, if TRUE, inhibits execution of the code.  Or
7782                    reverse the sense for elegance.)
7783
7784                    (Note that g77 could use a different test than NULL,
7785                    actually, since it happens to always pass an
7786                    integer to the called function that specifies which
7787                    entry point is being invoked.  Hmm, this might
7788                    solve the next problem.)
7789
7790                    One way a user could, I suppose, write "foo" so
7791                    it works is to insert COND_EXPR's for the
7792                    size/shape info so the dangerous stuff isn't
7793                    actually done, as in:
7794
7795                      void foo (int *n, float (*a)[(a == NULL) ? 0 : *n])
7796                      {
7797                        ...
7798                      }
7799
7800                    The next problem is that the front end needs to
7801                    be able to tell the back end about the array's
7802                    decl _before_ it tells it about the conditional
7803                    expression to inhibit evaluation of size/shape info,
7804                    as shown above.
7805
7806                    To solve this, the front end needs to be able
7807                    to give the back end the expression to inhibit
7808                    generation of the preevaluation code _after_
7809                    it makes the decl for the adjustable array.
7810
7811                    Until then, the above example using the COND_EXPR
7812                    doesn't pass muster with gcc because the "(a == NULL)"
7813                    part has a reference to "a", which is still
7814                    undefined at that point.
7815
7816                    g77 will therefore use a different mechanism in the
7817                    meantime.  */
7818
7819                 if (!adjustable
7820                     && ((TREE_CODE (low) != INTEGER_CST)
7821                         || (high && TREE_CODE (high) != INTEGER_CST)))
7822                   adjustable = TRUE;
7823
7824 #if 0                           /* Old approach -- see below. */
7825                 if (TREE_CODE (low) != INTEGER_CST)
7826                   low = ffecom_3 (COND_EXPR, integer_type_node,
7827                                   ffecom_adjarray_passed_ (s),
7828                                   low,
7829                                   ffecom_integer_zero_node);
7830
7831                 if (high && TREE_CODE (high) != INTEGER_CST)
7832                   high = ffecom_3 (COND_EXPR, integer_type_node,
7833                                    ffecom_adjarray_passed_ (s),
7834                                    high,
7835                                    ffecom_integer_zero_node);
7836 #endif
7837
7838                 /* ~~~gcc/stor-layout.c (layout_type) should do this,
7839                    probably.  Fixes 950302-1.f.  */
7840
7841                 if (TREE_CODE (low) != INTEGER_CST)
7842                   low = variable_size (low);
7843
7844                 /* ~~~Similarly, this fixes dumb0.f.  The C front end
7845                    does this, which is why dumb0.c would work.  */
7846
7847                 if (high && TREE_CODE (high) != INTEGER_CST)
7848                   high = variable_size (high);
7849
7850                 type
7851                   = build_array_type
7852                     (type,
7853                      build_range_type (ffecom_integer_type_node,
7854                                        low, high));
7855                 type = ffecom_check_size_overflow_ (s, type, TRUE);
7856               }
7857
7858             if (type == error_mark_node)
7859               {
7860                 t = error_mark_node;
7861                 break;
7862               }
7863
7864             if ((ffesymbol_sfdummyparent (s) == NULL)
7865                  || (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER))
7866               {
7867                 type = build_pointer_type (type);
7868                 addr = TRUE;
7869               }
7870
7871             t = build_decl (PARM_DECL, t, type);
7872             DECL_ARTIFICIAL (t) = 1;
7873
7874             /* If this arg is present in every entry point's list of
7875                dummy args, then we're done.  */
7876
7877             if (ffesymbol_numentries (s)
7878                 == (ffecom_num_entrypoints_ + 1))
7879               break;
7880
7881 #if 1
7882
7883             /* If variable_size in stor-layout has been called during
7884                the above, then get_pending_sizes should have the
7885                yet-to-be-evaluated saved expressions pending.
7886                Make the whole lot of them get emitted, conditionally
7887                on whether the array decl ("t" above) is not NULL.  */
7888
7889             {
7890               tree sizes = get_pending_sizes ();
7891               tree tem;
7892
7893               for (tem = sizes;
7894                    tem != old_sizes;
7895                    tem = TREE_CHAIN (tem))
7896                 {
7897                   tree temv = TREE_VALUE (tem);
7898
7899                   if (sizes == tem)
7900                     sizes = temv;
7901                   else
7902                     sizes
7903                       = ffecom_2 (COMPOUND_EXPR,
7904                                   TREE_TYPE (sizes),
7905                                   temv,
7906                                   sizes);
7907                 }
7908
7909               if (sizes != tem)
7910                 {
7911                   sizes
7912                     = ffecom_3 (COND_EXPR,
7913                                 TREE_TYPE (sizes),
7914                                 ffecom_2 (NE_EXPR,
7915                                           integer_type_node,
7916                                           t,
7917                                           null_pointer_node),
7918                                 sizes,
7919                                 convert (TREE_TYPE (sizes),
7920                                          integer_zero_node));
7921                   sizes = ffecom_save_tree (sizes);
7922
7923                   sizes
7924                     = tree_cons (NULL_TREE, sizes, tem);
7925                 }
7926
7927               if (sizes)
7928                 put_pending_sizes (sizes);
7929             }
7930
7931 #else
7932 #if 0
7933             if (adjustable
7934                 && (ffesymbol_numentries (s)
7935                     != ffecom_num_entrypoints_ + 1))
7936               DECL_SOMETHING (t)
7937                 = ffecom_2 (NE_EXPR, integer_type_node,
7938                             t,
7939                             null_pointer_node);
7940 #else
7941 #if 0
7942             if (adjustable
7943                 && (ffesymbol_numentries (s)
7944                     != ffecom_num_entrypoints_ + 1))
7945               {
7946                 ffebad_start (FFEBAD_MISSING_ADJARRAY_UNSUPPORTED);
7947                 ffebad_here (0, ffesymbol_where_line (s),
7948                              ffesymbol_where_column (s));
7949                 ffebad_string (ffesymbol_text (s));
7950                 ffebad_finish ();
7951               }
7952 #endif
7953 #endif
7954 #endif
7955           }
7956           break;
7957
7958         case FFEINFO_whereCOMMON:
7959           {
7960             ffesymbol cs;
7961             ffeglobal cg;
7962             tree ct;
7963             ffestorag st = ffesymbol_storage (s);
7964             tree type;
7965
7966             cs = ffesymbol_common (s);  /* The COMMON area itself.  */
7967             if (st != NULL)     /* Else not laid out. */
7968               {
7969                 ffecom_transform_common_ (cs);
7970                 st = ffesymbol_storage (s);
7971               }
7972
7973             type = ffecom_type_localvar_ (s, bt, kt);
7974
7975             cg = ffesymbol_global (cs); /* The global COMMON info.  */
7976             if ((cg == NULL)
7977                 || (ffeglobal_type (cg) != FFEGLOBAL_typeCOMMON))
7978               ct = NULL_TREE;
7979             else
7980               ct = ffeglobal_hook (cg); /* The common area's tree.  */
7981
7982             if ((ct == NULL_TREE)
7983                 || (st == NULL)
7984                 || (type == error_mark_node))
7985               t = error_mark_node;
7986             else
7987               {
7988                 ffetargetOffset offset;
7989                 ffestorag cst;
7990
7991                 cst = ffestorag_parent (st);
7992                 assert (cst == ffesymbol_storage (cs));
7993
7994                 offset = ffestorag_modulo (cst)
7995                   + ffestorag_offset (st)
7996                   - ffestorag_offset (cst);
7997
7998                 ffecom_debug_kludge_ (ct, "COMMON", s, type, offset);
7999
8000                 /* (t_type *) (((char *) &ct) + offset) */
8001
8002                 t = convert (string_type_node,  /* (char *) */
8003                              ffecom_1 (ADDR_EXPR,
8004                                        build_pointer_type (TREE_TYPE (ct)),
8005                                        ct));
8006                 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
8007                               t,
8008                               build_int_2 (offset, 0));
8009                 t = convert (build_pointer_type (type),
8010                              t);
8011                 TREE_CONSTANT (t) = 1;
8012
8013                 addr = TRUE;
8014               }
8015           }
8016           break;
8017
8018         case FFEINFO_whereIMMEDIATE:
8019         case FFEINFO_whereGLOBAL:
8020         case FFEINFO_whereFLEETING:
8021         case FFEINFO_whereFLEETING_CADDR:
8022         case FFEINFO_whereFLEETING_IADDR:
8023         case FFEINFO_whereINTRINSIC:
8024         case FFEINFO_whereCONSTANT_SUBOBJECT:
8025         default:
8026           assert ("ENTITY where unheard of" == NULL);
8027           /* Fall through. */
8028         case FFEINFO_whereANY:
8029           t = error_mark_node;
8030           break;
8031         }
8032       break;
8033
8034     case FFEINFO_kindFUNCTION:
8035       switch (ffeinfo_where (ffesymbol_info (s)))
8036         {
8037         case FFEINFO_whereLOCAL:        /* Me. */
8038           assert (!ffecom_transform_only_dummies_);
8039           t = current_function_decl;
8040           break;
8041
8042         case FFEINFO_whereGLOBAL:
8043           assert (!ffecom_transform_only_dummies_);
8044
8045           if (((g = ffesymbol_global (s)) != NULL)
8046               && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8047                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8048               && (ffeglobal_hook (g) != NULL_TREE)
8049               && ffe_is_globals ())
8050             {
8051               t = ffeglobal_hook (g);
8052               break;
8053             }
8054
8055           if (ffesymbol_is_f2c (s)
8056               && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8057             t = ffecom_tree_fun_type[bt][kt];
8058           else
8059             t = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
8060
8061           t = build_decl (FUNCTION_DECL,
8062                           ffecom_get_external_identifier_ (s),
8063                           t);
8064           DECL_EXTERNAL (t) = 1;
8065           TREE_PUBLIC (t) = 1;
8066
8067           t = start_decl (t, FALSE);
8068           finish_decl (t, NULL_TREE, FALSE);
8069
8070           if ((g != NULL)
8071               && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8072                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8073             ffeglobal_set_hook (g, t);
8074
8075           ffecom_save_tree_forever (t);
8076
8077           break;
8078
8079         case FFEINFO_whereDUMMY:
8080           assert (ffecom_transform_only_dummies_);
8081
8082           if (ffesymbol_is_f2c (s)
8083               && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8084             t = ffecom_tree_ptr_to_fun_type[bt][kt];
8085           else
8086             t = build_pointer_type
8087               (build_function_type (ffecom_tree_type[bt][kt], NULL_TREE));
8088
8089           t = build_decl (PARM_DECL,
8090                           ffecom_get_identifier_ (ffesymbol_text (s)),
8091                           t);
8092           DECL_ARTIFICIAL (t) = 1;
8093           addr = TRUE;
8094           break;
8095
8096         case FFEINFO_whereCONSTANT:     /* Statement function. */
8097           assert (!ffecom_transform_only_dummies_);
8098           t = ffecom_gen_sfuncdef_ (s, bt, kt);
8099           break;
8100
8101         case FFEINFO_whereINTRINSIC:
8102           assert (!ffecom_transform_only_dummies_);
8103           break;                /* Let actual references generate their
8104                                    decls. */
8105
8106         default:
8107           assert ("FUNCTION where unheard of" == NULL);
8108           /* Fall through. */
8109         case FFEINFO_whereANY:
8110           t = error_mark_node;
8111           break;
8112         }
8113       break;
8114
8115     case FFEINFO_kindSUBROUTINE:
8116       switch (ffeinfo_where (ffesymbol_info (s)))
8117         {
8118         case FFEINFO_whereLOCAL:        /* Me. */
8119           assert (!ffecom_transform_only_dummies_);
8120           t = current_function_decl;
8121           break;
8122
8123         case FFEINFO_whereGLOBAL:
8124           assert (!ffecom_transform_only_dummies_);
8125
8126           if (((g = ffesymbol_global (s)) != NULL)
8127               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8128                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8129               && (ffeglobal_hook (g) != NULL_TREE)
8130               && ffe_is_globals ())
8131             {
8132               t = ffeglobal_hook (g);
8133               break;
8134             }
8135
8136           t = build_decl (FUNCTION_DECL,
8137                           ffecom_get_external_identifier_ (s),
8138                           ffecom_tree_subr_type);
8139           DECL_EXTERNAL (t) = 1;
8140           TREE_PUBLIC (t) = 1;
8141
8142           t = start_decl (t, FALSE);
8143           finish_decl (t, NULL_TREE, FALSE);
8144
8145           if ((g != NULL)
8146               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8147                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8148             ffeglobal_set_hook (g, t);
8149
8150           ffecom_save_tree_forever (t);
8151
8152           break;
8153
8154         case FFEINFO_whereDUMMY:
8155           assert (ffecom_transform_only_dummies_);
8156
8157           t = build_decl (PARM_DECL,
8158                           ffecom_get_identifier_ (ffesymbol_text (s)),
8159                           ffecom_tree_ptr_to_subr_type);
8160           DECL_ARTIFICIAL (t) = 1;
8161           addr = TRUE;
8162           break;
8163
8164         case FFEINFO_whereINTRINSIC:
8165           assert (!ffecom_transform_only_dummies_);
8166           break;                /* Let actual references generate their
8167                                    decls. */
8168
8169         default:
8170           assert ("SUBROUTINE where unheard of" == NULL);
8171           /* Fall through. */
8172         case FFEINFO_whereANY:
8173           t = error_mark_node;
8174           break;
8175         }
8176       break;
8177
8178     case FFEINFO_kindPROGRAM:
8179       switch (ffeinfo_where (ffesymbol_info (s)))
8180         {
8181         case FFEINFO_whereLOCAL:        /* Me. */
8182           assert (!ffecom_transform_only_dummies_);
8183           t = current_function_decl;
8184           break;
8185
8186         case FFEINFO_whereCOMMON:
8187         case FFEINFO_whereDUMMY:
8188         case FFEINFO_whereGLOBAL:
8189         case FFEINFO_whereRESULT:
8190         case FFEINFO_whereFLEETING:
8191         case FFEINFO_whereFLEETING_CADDR:
8192         case FFEINFO_whereFLEETING_IADDR:
8193         case FFEINFO_whereIMMEDIATE:
8194         case FFEINFO_whereINTRINSIC:
8195         case FFEINFO_whereCONSTANT:
8196         case FFEINFO_whereCONSTANT_SUBOBJECT:
8197         default:
8198           assert ("PROGRAM where unheard of" == NULL);
8199           /* Fall through. */
8200         case FFEINFO_whereANY:
8201           t = error_mark_node;
8202           break;
8203         }
8204       break;
8205
8206     case FFEINFO_kindBLOCKDATA:
8207       switch (ffeinfo_where (ffesymbol_info (s)))
8208         {
8209         case FFEINFO_whereLOCAL:        /* Me. */
8210           assert (!ffecom_transform_only_dummies_);
8211           t = current_function_decl;
8212           break;
8213
8214         case FFEINFO_whereGLOBAL:
8215           assert (!ffecom_transform_only_dummies_);
8216
8217           t = build_decl (FUNCTION_DECL,
8218                           ffecom_get_external_identifier_ (s),
8219                           ffecom_tree_blockdata_type);
8220           DECL_EXTERNAL (t) = 1;
8221           TREE_PUBLIC (t) = 1;
8222
8223           t = start_decl (t, FALSE);
8224           finish_decl (t, NULL_TREE, FALSE);
8225
8226           ffecom_save_tree_forever (t);
8227
8228           break;
8229
8230         case FFEINFO_whereCOMMON:
8231         case FFEINFO_whereDUMMY:
8232         case FFEINFO_whereRESULT:
8233         case FFEINFO_whereFLEETING:
8234         case FFEINFO_whereFLEETING_CADDR:
8235         case FFEINFO_whereFLEETING_IADDR:
8236         case FFEINFO_whereIMMEDIATE:
8237         case FFEINFO_whereINTRINSIC:
8238         case FFEINFO_whereCONSTANT:
8239         case FFEINFO_whereCONSTANT_SUBOBJECT:
8240         default:
8241           assert ("BLOCKDATA where unheard of" == NULL);
8242           /* Fall through. */
8243         case FFEINFO_whereANY:
8244           t = error_mark_node;
8245           break;
8246         }
8247       break;
8248
8249     case FFEINFO_kindCOMMON:
8250       switch (ffeinfo_where (ffesymbol_info (s)))
8251         {
8252         case FFEINFO_whereLOCAL:
8253           assert (!ffecom_transform_only_dummies_);
8254           ffecom_transform_common_ (s);
8255           break;
8256
8257         case FFEINFO_whereNONE:
8258         case FFEINFO_whereCOMMON:
8259         case FFEINFO_whereDUMMY:
8260         case FFEINFO_whereGLOBAL:
8261         case FFEINFO_whereRESULT:
8262         case FFEINFO_whereFLEETING:
8263         case FFEINFO_whereFLEETING_CADDR:
8264         case FFEINFO_whereFLEETING_IADDR:
8265         case FFEINFO_whereIMMEDIATE:
8266         case FFEINFO_whereINTRINSIC:
8267         case FFEINFO_whereCONSTANT:
8268         case FFEINFO_whereCONSTANT_SUBOBJECT:
8269         default:
8270           assert ("COMMON where unheard of" == NULL);
8271           /* Fall through. */
8272         case FFEINFO_whereANY:
8273           t = error_mark_node;
8274           break;
8275         }
8276       break;
8277
8278     case FFEINFO_kindCONSTRUCT:
8279       switch (ffeinfo_where (ffesymbol_info (s)))
8280         {
8281         case FFEINFO_whereLOCAL:
8282           assert (!ffecom_transform_only_dummies_);
8283           break;
8284
8285         case FFEINFO_whereNONE:
8286         case FFEINFO_whereCOMMON:
8287         case FFEINFO_whereDUMMY:
8288         case FFEINFO_whereGLOBAL:
8289         case FFEINFO_whereRESULT:
8290         case FFEINFO_whereFLEETING:
8291         case FFEINFO_whereFLEETING_CADDR:
8292         case FFEINFO_whereFLEETING_IADDR:
8293         case FFEINFO_whereIMMEDIATE:
8294         case FFEINFO_whereINTRINSIC:
8295         case FFEINFO_whereCONSTANT:
8296         case FFEINFO_whereCONSTANT_SUBOBJECT:
8297         default:
8298           assert ("CONSTRUCT where unheard of" == NULL);
8299           /* Fall through. */
8300         case FFEINFO_whereANY:
8301           t = error_mark_node;
8302           break;
8303         }
8304       break;
8305
8306     case FFEINFO_kindNAMELIST:
8307       switch (ffeinfo_where (ffesymbol_info (s)))
8308         {
8309         case FFEINFO_whereLOCAL:
8310           assert (!ffecom_transform_only_dummies_);
8311           t = ffecom_transform_namelist_ (s);
8312           break;
8313
8314         case FFEINFO_whereNONE:
8315         case FFEINFO_whereCOMMON:
8316         case FFEINFO_whereDUMMY:
8317         case FFEINFO_whereGLOBAL:
8318         case FFEINFO_whereRESULT:
8319         case FFEINFO_whereFLEETING:
8320         case FFEINFO_whereFLEETING_CADDR:
8321         case FFEINFO_whereFLEETING_IADDR:
8322         case FFEINFO_whereIMMEDIATE:
8323         case FFEINFO_whereINTRINSIC:
8324         case FFEINFO_whereCONSTANT:
8325         case FFEINFO_whereCONSTANT_SUBOBJECT:
8326         default:
8327           assert ("NAMELIST where unheard of" == NULL);
8328           /* Fall through. */
8329         case FFEINFO_whereANY:
8330           t = error_mark_node;
8331           break;
8332         }
8333       break;
8334
8335     default:
8336       assert ("kind unheard of" == NULL);
8337       /* Fall through. */
8338     case FFEINFO_kindANY:
8339       t = error_mark_node;
8340       break;
8341     }
8342
8343   ffesymbol_hook (s).decl_tree = t;
8344   ffesymbol_hook (s).length_tree = tlen;
8345   ffesymbol_hook (s).addr = addr;
8346
8347   lineno = old_lineno;
8348   input_filename = old_input_filename;
8349
8350   return s;
8351 }
8352
8353 /* Transform into ASSIGNable symbol.
8354
8355    Symbol has already been transformed, but for whatever reason, the
8356    resulting decl_tree has been deemed not usable for an ASSIGN target.
8357    (E.g. it isn't wide enough to hold a pointer.)  So, here we invent
8358    another local symbol of type void * and stuff that in the assign_tree
8359    argument.  The F77/F90 standards allow this implementation.  */
8360
8361 static ffesymbol
8362 ffecom_sym_transform_assign_ (ffesymbol s)
8363 {
8364   tree t;                       /* Transformed thingy. */
8365   int old_lineno = lineno;
8366   const char *old_input_filename = input_filename;
8367
8368   if (ffesymbol_sfdummyparent (s) == NULL)
8369     {
8370       input_filename = ffesymbol_where_filename (s);
8371       lineno = ffesymbol_where_filelinenum (s);
8372     }
8373   else
8374     {
8375       ffesymbol sf = ffesymbol_sfdummyparent (s);
8376
8377       input_filename = ffesymbol_where_filename (sf);
8378       lineno = ffesymbol_where_filelinenum (sf);
8379     }
8380
8381   assert (!ffecom_transform_only_dummies_);
8382
8383   t = build_decl (VAR_DECL,
8384                   ffecom_get_invented_identifier ("__g77_ASSIGN_%s",
8385                                                    ffesymbol_text (s)),
8386                   TREE_TYPE (null_pointer_node));
8387
8388   switch (ffesymbol_where (s))
8389     {
8390     case FFEINFO_whereLOCAL:
8391       /* Unlike for regular vars, SAVE status is easy to determine for
8392          ASSIGNed vars, since there's no initialization, there's no
8393          effective storage association (so "SAVE J" does not apply to
8394          K even given "EQUIVALENCE (J,K)"), there's no size issue
8395          to worry about, etc.  */
8396       if ((ffesymbol_is_save (s) || ffe_is_saveall ())
8397           && (ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8398           && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA))
8399         TREE_STATIC (t) = 1;    /* SAVEd in proc, make static. */
8400       else
8401         TREE_STATIC (t) = 0;    /* No need to make static. */
8402       break;
8403
8404     case FFEINFO_whereCOMMON:
8405       TREE_STATIC (t) = 1;      /* Assume COMMONs always SAVEd. */
8406       break;
8407
8408     case FFEINFO_whereDUMMY:
8409       /* Note that twinning a DUMMY means the caller won't see
8410          the ASSIGNed value.  But both F77 and F90 allow implementations
8411          to do this, i.e. disallow Fortran code that would try and
8412          take advantage of actually putting a label into a variable
8413          via a dummy argument (or any other storage association, for
8414          that matter).  */
8415       TREE_STATIC (t) = 0;
8416       break;
8417
8418     default:
8419       TREE_STATIC (t) = 0;
8420       break;
8421     }
8422
8423   t = start_decl (t, FALSE);
8424   finish_decl (t, NULL_TREE, FALSE);
8425
8426   ffesymbol_hook (s).assign_tree = t;
8427
8428   lineno = old_lineno;
8429   input_filename = old_input_filename;
8430
8431   return s;
8432 }
8433
8434 /* Implement COMMON area in back end.
8435
8436    Because COMMON-based variables can be referenced in the dimension
8437    expressions of dummy (adjustable) arrays, and because dummies
8438    (in the gcc back end) need to be put in the outer binding level
8439    of a function (which has two binding levels, the outer holding
8440    the dummies and the inner holding the other vars), special care
8441    must be taken to handle COMMON areas.
8442
8443    The current strategy is basically to always tell the back end about
8444    the COMMON area as a top-level external reference to just a block
8445    of storage of the master type of that area (e.g. integer, real,
8446    character, whatever -- not a structure).  As a distinct action,
8447    if initial values are provided, tell the back end about the area
8448    as a top-level non-external (initialized) area and remember not to
8449    allow further initialization or expansion of the area.  Meanwhile,
8450    if no initialization happens at all, tell the back end about
8451    the largest size we've seen declared so the space does get reserved.
8452    (This function doesn't handle all that stuff, but it does some
8453    of the important things.)
8454
8455    Meanwhile, for COMMON variables themselves, just keep creating
8456    references like *((float *) (&common_area + offset)) each time
8457    we reference the variable.  In other words, don't make a VAR_DECL
8458    or any kind of component reference (like we used to do before 0.4),
8459    though we might do that as well just for debugging purposes (and
8460    stuff the rtl with the appropriate offset expression).  */
8461
8462 static void
8463 ffecom_transform_common_ (ffesymbol s)
8464 {
8465   ffestorag st = ffesymbol_storage (s);
8466   ffeglobal g = ffesymbol_global (s);
8467   tree cbt;
8468   tree cbtype;
8469   tree init;
8470   tree high;
8471   bool is_init = ffestorag_is_init (st);
8472
8473   assert (st != NULL);
8474
8475   if ((g == NULL)
8476       || (ffeglobal_type (g) != FFEGLOBAL_typeCOMMON))
8477     return;
8478
8479   /* First update the size of the area in global terms.  */
8480
8481   ffeglobal_size_common (s, ffestorag_size (st));
8482
8483   if (!ffeglobal_common_init (g))
8484     is_init = FALSE;    /* No explicit init, don't let erroneous joins init. */
8485
8486   cbt = ffeglobal_hook (g);
8487
8488   /* If we already have declared this common block for a previous program
8489      unit, and either we already initialized it or we don't have new
8490      initialization for it, just return what we have without changing it.  */
8491
8492   if ((cbt != NULL_TREE)
8493       && (!is_init
8494           || !DECL_EXTERNAL (cbt)))
8495     {
8496       if (st->hook == NULL) ffestorag_set_hook (st, cbt);
8497       return;
8498     }
8499
8500   /* Process inits.  */
8501
8502   if (is_init)
8503     {
8504       if (ffestorag_init (st) != NULL)
8505         {
8506           ffebld sexp;
8507
8508           /* Set the padding for the expression, so ffecom_expr
8509              knows to insert that many zeros.  */
8510           switch (ffebld_op (sexp = ffestorag_init (st)))
8511             {
8512             case FFEBLD_opCONTER:
8513               ffebld_conter_set_pad (sexp, ffestorag_modulo (st));
8514               break;
8515
8516             case FFEBLD_opARRTER:
8517               ffebld_arrter_set_pad (sexp, ffestorag_modulo (st));
8518               break;
8519
8520             case FFEBLD_opACCTER:
8521               ffebld_accter_set_pad (sexp, ffestorag_modulo (st));
8522               break;
8523
8524             default:
8525               assert ("bad op for cmn init (pad)" == NULL);
8526               break;
8527             }
8528
8529           init = ffecom_expr (sexp);
8530           if (init == error_mark_node)
8531             {                   /* Hopefully the back end complained! */
8532               init = NULL_TREE;
8533               if (cbt != NULL_TREE)
8534                 return;
8535             }
8536         }
8537       else
8538         init = error_mark_node;
8539     }
8540   else
8541     init = NULL_TREE;
8542
8543   /* cbtype must be permanently allocated!  */
8544
8545   /* Allocate the MAX of the areas so far, seen filewide.  */
8546   high = build_int_2 ((ffeglobal_common_size (g)
8547                        + ffeglobal_common_pad (g)) - 1, 0);
8548   TREE_TYPE (high) = ffecom_integer_type_node;
8549
8550   if (init)
8551     cbtype = build_array_type (char_type_node,
8552                                build_range_type (integer_type_node,
8553                                                  integer_zero_node,
8554                                                  high));
8555   else
8556     cbtype = build_array_type (char_type_node, NULL_TREE);
8557
8558   if (cbt == NULL_TREE)
8559     {
8560       cbt
8561         = build_decl (VAR_DECL,
8562                       ffecom_get_external_identifier_ (s),
8563                       cbtype);
8564       TREE_STATIC (cbt) = 1;
8565       TREE_PUBLIC (cbt) = 1;
8566     }
8567   else
8568     {
8569       assert (is_init);
8570       TREE_TYPE (cbt) = cbtype;
8571     }
8572   DECL_EXTERNAL (cbt) = init ? 0 : 1;
8573   DECL_INITIAL (cbt) = init ? error_mark_node : NULL_TREE;
8574
8575   cbt = start_decl (cbt, TRUE);
8576   if (ffeglobal_hook (g) != NULL)
8577     assert (cbt == ffeglobal_hook (g));
8578
8579   assert (!init || !DECL_EXTERNAL (cbt));
8580
8581   /* Make sure that any type can live in COMMON and be referenced
8582      without getting a bus error.  We could pick the most restrictive
8583      alignment of all entities actually placed in the COMMON, but
8584      this seems easy enough.  */
8585
8586   DECL_ALIGN (cbt) = BIGGEST_ALIGNMENT;
8587   DECL_USER_ALIGN (cbt) = 0;
8588
8589   if (is_init && (ffestorag_init (st) == NULL))
8590     init = ffecom_init_zero_ (cbt);
8591
8592   finish_decl (cbt, init, TRUE);
8593
8594   if (is_init)
8595     ffestorag_set_init (st, ffebld_new_any ());
8596
8597   if (init)
8598     {
8599       assert (DECL_SIZE_UNIT (cbt) != NULL_TREE);
8600       assert (TREE_CODE (DECL_SIZE_UNIT (cbt)) == INTEGER_CST);
8601       assert (0 == compare_tree_int (DECL_SIZE_UNIT (cbt),
8602                                      (ffeglobal_common_size (g)
8603                                       + ffeglobal_common_pad (g))));
8604     }
8605
8606   ffeglobal_set_hook (g, cbt);
8607
8608   ffestorag_set_hook (st, cbt);
8609
8610   ffecom_save_tree_forever (cbt);
8611 }
8612
8613 /* Make master area for local EQUIVALENCE.  */
8614
8615 static void
8616 ffecom_transform_equiv_ (ffestorag eqst)
8617 {
8618   tree eqt;
8619   tree eqtype;
8620   tree init;
8621   tree high;
8622   bool is_init = ffestorag_is_init (eqst);
8623
8624   assert (eqst != NULL);
8625
8626   eqt = ffestorag_hook (eqst);
8627
8628   if (eqt != NULL_TREE)
8629     return;
8630
8631   /* Process inits.  */
8632
8633   if (is_init)
8634     {
8635       if (ffestorag_init (eqst) != NULL)
8636         {
8637           ffebld sexp;
8638
8639           /* Set the padding for the expression, so ffecom_expr
8640              knows to insert that many zeros.  */
8641           switch (ffebld_op (sexp = ffestorag_init (eqst)))
8642             {
8643             case FFEBLD_opCONTER:
8644               ffebld_conter_set_pad (sexp, ffestorag_modulo (eqst));
8645               break;
8646
8647             case FFEBLD_opARRTER:
8648               ffebld_arrter_set_pad (sexp, ffestorag_modulo (eqst));
8649               break;
8650
8651             case FFEBLD_opACCTER:
8652               ffebld_accter_set_pad (sexp, ffestorag_modulo (eqst));
8653               break;
8654
8655             default:
8656               assert ("bad op for eqv init (pad)" == NULL);
8657               break;
8658             }
8659
8660           init = ffecom_expr (sexp);
8661           if (init == error_mark_node)
8662             init = NULL_TREE;   /* Hopefully the back end complained! */
8663         }
8664       else
8665         init = error_mark_node;
8666     }
8667   else if (ffe_is_init_local_zero ())
8668     init = error_mark_node;
8669   else
8670     init = NULL_TREE;
8671
8672   ffecom_member_namelisted_ = FALSE;
8673   ffestorag_drive (ffestorag_list_equivs (eqst),
8674                    &ffecom_member_phase1_,
8675                    eqst);
8676
8677   high = build_int_2 ((ffestorag_size (eqst)
8678                        + ffestorag_modulo (eqst)) - 1, 0);
8679   TREE_TYPE (high) = ffecom_integer_type_node;
8680
8681   eqtype = build_array_type (char_type_node,
8682                              build_range_type (ffecom_integer_type_node,
8683                                                ffecom_integer_zero_node,
8684                                                high));
8685
8686   eqt = build_decl (VAR_DECL,
8687                     ffecom_get_invented_identifier ("__g77_equiv_%s",
8688                                                     ffesymbol_text
8689                                                     (ffestorag_symbol (eqst))),
8690                     eqtype);
8691   DECL_EXTERNAL (eqt) = 0;
8692   if (is_init
8693       || ffecom_member_namelisted_
8694 #ifdef FFECOM_sizeMAXSTACKITEM
8695       || (ffestorag_size (eqst) > FFECOM_sizeMAXSTACKITEM)
8696 #endif
8697       || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8698           && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
8699           && (ffestorag_is_save (eqst) || ffe_is_saveall ())))
8700     TREE_STATIC (eqt) = 1;
8701   else
8702     TREE_STATIC (eqt) = 0;
8703   TREE_PUBLIC (eqt) = 0;
8704   TREE_ADDRESSABLE (eqt) = 1;  /* Ensure non-register allocation */
8705   DECL_CONTEXT (eqt) = current_function_decl;
8706   if (init)
8707     DECL_INITIAL (eqt) = error_mark_node;
8708   else
8709     DECL_INITIAL (eqt) = NULL_TREE;
8710
8711   eqt = start_decl (eqt, FALSE);
8712
8713   /* Make sure that any type can live in EQUIVALENCE and be referenced
8714      without getting a bus error.  We could pick the most restrictive
8715      alignment of all entities actually placed in the EQUIVALENCE, but
8716      this seems easy enough.  */
8717
8718   DECL_ALIGN (eqt) = BIGGEST_ALIGNMENT;
8719   DECL_USER_ALIGN (eqt) = 0;
8720
8721   if ((!is_init && ffe_is_init_local_zero ())
8722       || (is_init && (ffestorag_init (eqst) == NULL)))
8723     init = ffecom_init_zero_ (eqt);
8724
8725   finish_decl (eqt, init, FALSE);
8726
8727   if (is_init)
8728     ffestorag_set_init (eqst, ffebld_new_any ());
8729
8730   {
8731     assert (TREE_CODE (DECL_SIZE_UNIT (eqt)) == INTEGER_CST);
8732     assert (0 == compare_tree_int (DECL_SIZE_UNIT (eqt),
8733                                    (ffestorag_size (eqst)
8734                                     + ffestorag_modulo (eqst))));
8735   }
8736
8737   ffestorag_set_hook (eqst, eqt);
8738
8739   ffestorag_drive (ffestorag_list_equivs (eqst),
8740                    &ffecom_member_phase2_,
8741                    eqst);
8742 }
8743
8744 /* Implement NAMELIST in back end.  See f2c/format.c for more info.  */
8745
8746 static tree
8747 ffecom_transform_namelist_ (ffesymbol s)
8748 {
8749   tree nmlt;
8750   tree nmltype = ffecom_type_namelist_ ();
8751   tree nmlinits;
8752   tree nameinit;
8753   tree varsinit;
8754   tree nvarsinit;
8755   tree field;
8756   tree high;
8757   int i;
8758   static int mynumber = 0;
8759
8760   nmlt = build_decl (VAR_DECL,
8761                      ffecom_get_invented_identifier ("__g77_namelist_%d",
8762                                                      mynumber++),
8763                      nmltype);
8764   TREE_STATIC (nmlt) = 1;
8765   DECL_INITIAL (nmlt) = error_mark_node;
8766
8767   nmlt = start_decl (nmlt, FALSE);
8768
8769   /* Process inits.  */
8770
8771   i = strlen (ffesymbol_text (s));
8772
8773   high = build_int_2 (i, 0);
8774   TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
8775
8776   nameinit = ffecom_build_f2c_string_ (i + 1,
8777                                        ffesymbol_text (s));
8778   TREE_TYPE (nameinit)
8779     = build_type_variant
8780     (build_array_type
8781      (char_type_node,
8782       build_range_type (ffecom_f2c_ftnlen_type_node,
8783                         ffecom_f2c_ftnlen_one_node,
8784                         high)),
8785      1, 0);
8786   TREE_CONSTANT (nameinit) = 1;
8787   TREE_STATIC (nameinit) = 1;
8788   nameinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (nameinit)),
8789                        nameinit);
8790
8791   varsinit = ffecom_vardesc_array_ (s);
8792   varsinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (varsinit)),
8793                        varsinit);
8794   TREE_CONSTANT (varsinit) = 1;
8795   TREE_STATIC (varsinit) = 1;
8796
8797   {
8798     ffebld b;
8799
8800     for (i = 0, b = ffesymbol_namelist (s); b != NULL; b = ffebld_trail (b))
8801       ++i;
8802   }
8803   nvarsinit = build_int_2 (i, 0);
8804   TREE_TYPE (nvarsinit) = integer_type_node;
8805   TREE_CONSTANT (nvarsinit) = 1;
8806   TREE_STATIC (nvarsinit) = 1;
8807
8808   nmlinits = build_tree_list ((field = TYPE_FIELDS (nmltype)), nameinit);
8809   TREE_CHAIN (nmlinits) = build_tree_list ((field = TREE_CHAIN (field)),
8810                                            varsinit);
8811   TREE_CHAIN (TREE_CHAIN (nmlinits))
8812     = build_tree_list ((field = TREE_CHAIN (field)), nvarsinit);
8813
8814   nmlinits = build (CONSTRUCTOR, nmltype, NULL_TREE, nmlinits);
8815   TREE_CONSTANT (nmlinits) = 1;
8816   TREE_STATIC (nmlinits) = 1;
8817
8818   finish_decl (nmlt, nmlinits, FALSE);
8819
8820   nmlt = ffecom_1 (ADDR_EXPR, build_pointer_type (nmltype), nmlt);
8821
8822   return nmlt;
8823 }
8824
8825 /* A subroutine of ffecom_tree_canonize_ref_.  The incoming tree is
8826    analyzed on the assumption it is calculating a pointer to be
8827    indirected through.  It must return the proper decl and offset,
8828    taking into account different units of measurements for offsets.  */
8829
8830 static void
8831 ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
8832                            tree t)
8833 {
8834   switch (TREE_CODE (t))
8835     {
8836     case NOP_EXPR:
8837     case CONVERT_EXPR:
8838     case NON_LVALUE_EXPR:
8839       ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
8840       break;
8841
8842     case PLUS_EXPR:
8843       ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
8844       if ((*decl == NULL_TREE)
8845           || (*decl == error_mark_node))
8846         break;
8847
8848       if (TREE_CODE (TREE_OPERAND (t, 1)) == INTEGER_CST)
8849         {
8850           /* An offset into COMMON.  */
8851           *offset = fold (build (PLUS_EXPR, TREE_TYPE (*offset),
8852                                  *offset, TREE_OPERAND (t, 1)));
8853           /* Convert offset (presumably in bytes) into canonical units
8854              (presumably bits).  */
8855           *offset = size_binop (MULT_EXPR,
8856                                 convert (bitsizetype, *offset),
8857                                 TYPE_SIZE (TREE_TYPE (TREE_TYPE (t))));
8858           break;
8859         }
8860       /* Not a COMMON reference, so an unrecognized pattern.  */
8861       *decl = error_mark_node;
8862       break;
8863
8864     case PARM_DECL:
8865       *decl = t;
8866       *offset = bitsize_zero_node;
8867       break;
8868
8869     case ADDR_EXPR:
8870       if (TREE_CODE (TREE_OPERAND (t, 0)) == VAR_DECL)
8871         {
8872           /* A reference to COMMON.  */
8873           *decl = TREE_OPERAND (t, 0);
8874           *offset = bitsize_zero_node;
8875           break;
8876         }
8877       /* Fall through.  */
8878     default:
8879       /* Not a COMMON reference, so an unrecognized pattern.  */
8880       *decl = error_mark_node;
8881       break;
8882     }
8883 }
8884
8885 /* Given a tree that is possibly intended for use as an lvalue, return
8886    information representing a canonical view of that tree as a decl, an
8887    offset into that decl, and a size for the lvalue.
8888
8889    If there's no applicable decl, NULL_TREE is returned for the decl,
8890    and the other fields are left undefined.
8891
8892    If the tree doesn't fit the recognizable forms, an ERROR_MARK node
8893    is returned for the decl, and the other fields are left undefined.
8894
8895    Otherwise, the decl returned currently is either a VAR_DECL or a
8896    PARM_DECL.
8897
8898    The offset returned is always valid, but of course not necessarily
8899    a constant, and not necessarily converted into the appropriate
8900    type, leaving that up to the caller (so as to avoid that overhead
8901    if the decls being looked at are different anyway).
8902
8903    If the size cannot be determined (e.g. an adjustable array),
8904    an ERROR_MARK node is returned for the size.  Otherwise, the
8905    size returned is valid, not necessarily a constant, and not
8906    necessarily converted into the appropriate type as with the
8907    offset.
8908
8909    Note that the offset and size expressions are expressed in the
8910    base storage units (usually bits) rather than in the units of
8911    the type of the decl, because two decls with different types
8912    might overlap but with apparently non-overlapping array offsets,
8913    whereas converting the array offsets to consistant offsets will
8914    reveal the overlap.  */
8915
8916 static void
8917 ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
8918                            tree *size, tree t)
8919 {
8920   /* The default path is to report a nonexistant decl.  */
8921   *decl = NULL_TREE;
8922
8923   if (t == NULL_TREE)
8924     return;
8925
8926   switch (TREE_CODE (t))
8927     {
8928     case ERROR_MARK:
8929     case IDENTIFIER_NODE:
8930     case INTEGER_CST:
8931     case REAL_CST:
8932     case COMPLEX_CST:
8933     case STRING_CST:
8934     case CONST_DECL:
8935     case PLUS_EXPR:
8936     case MINUS_EXPR:
8937     case MULT_EXPR:
8938     case TRUNC_DIV_EXPR:
8939     case CEIL_DIV_EXPR:
8940     case FLOOR_DIV_EXPR:
8941     case ROUND_DIV_EXPR:
8942     case TRUNC_MOD_EXPR:
8943     case CEIL_MOD_EXPR:
8944     case FLOOR_MOD_EXPR:
8945     case ROUND_MOD_EXPR:
8946     case RDIV_EXPR:
8947     case EXACT_DIV_EXPR:
8948     case FIX_TRUNC_EXPR:
8949     case FIX_CEIL_EXPR:
8950     case FIX_FLOOR_EXPR:
8951     case FIX_ROUND_EXPR:
8952     case FLOAT_EXPR:
8953     case NEGATE_EXPR:
8954     case MIN_EXPR:
8955     case MAX_EXPR:
8956     case ABS_EXPR:
8957     case FFS_EXPR:
8958     case LSHIFT_EXPR:
8959     case RSHIFT_EXPR:
8960     case LROTATE_EXPR:
8961     case RROTATE_EXPR:
8962     case BIT_IOR_EXPR:
8963     case BIT_XOR_EXPR:
8964     case BIT_AND_EXPR:
8965     case BIT_ANDTC_EXPR:
8966     case BIT_NOT_EXPR:
8967     case TRUTH_ANDIF_EXPR:
8968     case TRUTH_ORIF_EXPR:
8969     case TRUTH_AND_EXPR:
8970     case TRUTH_OR_EXPR:
8971     case TRUTH_XOR_EXPR:
8972     case TRUTH_NOT_EXPR:
8973     case LT_EXPR:
8974     case LE_EXPR:
8975     case GT_EXPR:
8976     case GE_EXPR:
8977     case EQ_EXPR:
8978     case NE_EXPR:
8979     case COMPLEX_EXPR:
8980     case CONJ_EXPR:
8981     case REALPART_EXPR:
8982     case IMAGPART_EXPR:
8983     case LABEL_EXPR:
8984     case COMPONENT_REF:
8985     case COMPOUND_EXPR:
8986     case ADDR_EXPR:
8987       return;
8988
8989     case VAR_DECL:
8990     case PARM_DECL:
8991       *decl = t;
8992       *offset = bitsize_zero_node;
8993       *size = TYPE_SIZE (TREE_TYPE (t));
8994       return;
8995
8996     case ARRAY_REF:
8997       {
8998         tree array = TREE_OPERAND (t, 0);
8999         tree element = TREE_OPERAND (t, 1);
9000         tree init_offset;
9001
9002         if ((array == NULL_TREE)
9003             || (element == NULL_TREE))
9004           {
9005             *decl = error_mark_node;
9006             return;
9007           }
9008
9009         ffecom_tree_canonize_ref_ (decl, &init_offset, size,
9010                                    array);
9011         if ((*decl == NULL_TREE)
9012             || (*decl == error_mark_node))
9013           return;
9014
9015         /* Calculate ((element - base) * NBBY) + init_offset.  */
9016         *offset = fold (build (MINUS_EXPR, TREE_TYPE (element),
9017                                element,
9018                                TYPE_MIN_VALUE (TYPE_DOMAIN
9019                                                (TREE_TYPE (array)))));
9020
9021         *offset = size_binop (MULT_EXPR,
9022                               convert (bitsizetype, *offset),
9023                               TYPE_SIZE (TREE_TYPE (TREE_TYPE (array))));
9024
9025         *offset = size_binop (PLUS_EXPR, init_offset, *offset);
9026
9027         *size = TYPE_SIZE (TREE_TYPE (t));
9028         return;
9029       }
9030
9031     case INDIRECT_REF:
9032
9033       /* Most of this code is to handle references to COMMON.  And so
9034          far that is useful only for calling library functions, since
9035          external (user) functions might reference common areas.  But
9036          even calling an external function, it's worthwhile to decode
9037          COMMON references because if not storing into COMMON, we don't
9038          want COMMON-based arguments to gratuitously force use of a
9039          temporary.  */
9040
9041       *size = TYPE_SIZE (TREE_TYPE (t));
9042
9043       ffecom_tree_canonize_ptr_ (decl, offset,
9044                                  TREE_OPERAND (t, 0));
9045
9046       return;
9047
9048     case CONVERT_EXPR:
9049     case NOP_EXPR:
9050     case MODIFY_EXPR:
9051     case NON_LVALUE_EXPR:
9052     case RESULT_DECL:
9053     case FIELD_DECL:
9054     case COND_EXPR:             /* More cases than we can handle. */
9055     case SAVE_EXPR:
9056     case REFERENCE_EXPR:
9057     case PREDECREMENT_EXPR:
9058     case PREINCREMENT_EXPR:
9059     case POSTDECREMENT_EXPR:
9060     case POSTINCREMENT_EXPR:
9061     case CALL_EXPR:
9062     default:
9063       *decl = error_mark_node;
9064       return;
9065     }
9066 }
9067
9068 /* Do divide operation appropriate to type of operands.  */
9069
9070 static tree
9071 ffecom_tree_divide_ (tree tree_type, tree left, tree right,
9072                      tree dest_tree, ffebld dest, bool *dest_used,
9073                      tree hook)
9074 {
9075   if ((left == error_mark_node)
9076       || (right == error_mark_node))
9077     return error_mark_node;
9078
9079   switch (TREE_CODE (tree_type))
9080     {
9081     case INTEGER_TYPE:
9082       return ffecom_2 (TRUNC_DIV_EXPR, tree_type,
9083                        left,
9084                        right);
9085
9086     case COMPLEX_TYPE:
9087       if (! optimize_size)
9088         return ffecom_2 (RDIV_EXPR, tree_type,
9089                          left,
9090                          right);
9091       {
9092         ffecomGfrt ix;
9093
9094         if (TREE_TYPE (tree_type)
9095             == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9096           ix = FFECOM_gfrtDIV_CC;       /* Overlapping result okay. */
9097         else
9098           ix = FFECOM_gfrtDIV_ZZ;       /* Overlapping result okay. */
9099
9100         left = ffecom_1 (ADDR_EXPR,
9101                          build_pointer_type (TREE_TYPE (left)),
9102                          left);
9103         left = build_tree_list (NULL_TREE, left);
9104         right = ffecom_1 (ADDR_EXPR,
9105                           build_pointer_type (TREE_TYPE (right)),
9106                           right);
9107         right = build_tree_list (NULL_TREE, right);
9108         TREE_CHAIN (left) = right;
9109
9110         return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9111                              ffecom_gfrt_kindtype (ix),
9112                              ffe_is_f2c_library (),
9113                              tree_type,
9114                              left,
9115                              dest_tree, dest, dest_used,
9116                              NULL_TREE, TRUE, hook);
9117       }
9118       break;
9119
9120     case RECORD_TYPE:
9121       {
9122         ffecomGfrt ix;
9123
9124         if (TREE_TYPE (TYPE_FIELDS (tree_type))
9125             == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9126           ix = FFECOM_gfrtDIV_CC;       /* Overlapping result okay. */
9127         else
9128           ix = FFECOM_gfrtDIV_ZZ;       /* Overlapping result okay. */
9129
9130         left = ffecom_1 (ADDR_EXPR,
9131                          build_pointer_type (TREE_TYPE (left)),
9132                          left);
9133         left = build_tree_list (NULL_TREE, left);
9134         right = ffecom_1 (ADDR_EXPR,
9135                           build_pointer_type (TREE_TYPE (right)),
9136                           right);
9137         right = build_tree_list (NULL_TREE, right);
9138         TREE_CHAIN (left) = right;
9139
9140         return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9141                              ffecom_gfrt_kindtype (ix),
9142                              ffe_is_f2c_library (),
9143                              tree_type,
9144                              left,
9145                              dest_tree, dest, dest_used,
9146                              NULL_TREE, TRUE, hook);
9147       }
9148       break;
9149
9150     default:
9151       return ffecom_2 (RDIV_EXPR, tree_type,
9152                        left,
9153                        right);
9154     }
9155 }
9156
9157 /* Build type info for non-dummy variable.  */
9158
9159 static tree
9160 ffecom_type_localvar_ (ffesymbol s, ffeinfoBasictype bt,
9161                        ffeinfoKindtype kt)
9162 {
9163   tree type;
9164   ffebld dl;
9165   ffebld dim;
9166   tree lowt;
9167   tree hight;
9168
9169   type = ffecom_tree_type[bt][kt];
9170   if (bt == FFEINFO_basictypeCHARACTER)
9171     {
9172       hight = build_int_2 (ffesymbol_size (s), 0);
9173       TREE_TYPE (hight) = ffecom_f2c_ftnlen_type_node;
9174
9175       type
9176         = build_array_type
9177           (type,
9178            build_range_type (ffecom_f2c_ftnlen_type_node,
9179                              ffecom_f2c_ftnlen_one_node,
9180                              hight));
9181       type = ffecom_check_size_overflow_ (s, type, FALSE);
9182     }
9183
9184   for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
9185     {
9186       if (type == error_mark_node)
9187         break;
9188
9189       dim = ffebld_head (dl);
9190       assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
9191
9192       if (ffebld_left (dim) == NULL)
9193         lowt = integer_one_node;
9194       else
9195         lowt = ffecom_expr (ffebld_left (dim));
9196
9197       if (TREE_CODE (lowt) != INTEGER_CST)
9198         lowt = variable_size (lowt);
9199
9200       assert (ffebld_right (dim) != NULL);
9201       hight = ffecom_expr (ffebld_right (dim));
9202
9203       if (TREE_CODE (hight) != INTEGER_CST)
9204         hight = variable_size (hight);
9205
9206       type = build_array_type (type,
9207                                build_range_type (ffecom_integer_type_node,
9208                                                  lowt, hight));
9209       type = ffecom_check_size_overflow_ (s, type, FALSE);
9210     }
9211
9212   return type;
9213 }
9214
9215 /* Build Namelist type.  */
9216
9217 static tree
9218 ffecom_type_namelist_ ()
9219 {
9220   static tree type = NULL_TREE;
9221
9222   if (type == NULL_TREE)
9223     {
9224       static tree namefield, varsfield, nvarsfield;
9225       tree vardesctype;
9226
9227       vardesctype = ffecom_type_vardesc_ ();
9228
9229       type = make_node (RECORD_TYPE);
9230
9231       vardesctype = build_pointer_type (build_pointer_type (vardesctype));
9232
9233       namefield = ffecom_decl_field (type, NULL_TREE, "name",
9234                                      string_type_node);
9235       varsfield = ffecom_decl_field (type, namefield, "vars", vardesctype);
9236       nvarsfield = ffecom_decl_field (type, varsfield, "nvars",
9237                                       integer_type_node);
9238
9239       TYPE_FIELDS (type) = namefield;
9240       layout_type (type);
9241
9242       ggc_add_tree_root (&type, 1);
9243     }
9244
9245   return type;
9246 }
9247
9248 /* Build Vardesc type.  */
9249
9250 static tree
9251 ffecom_type_vardesc_ ()
9252 {
9253   static tree type = NULL_TREE;
9254   static tree namefield, addrfield, dimsfield, typefield;
9255
9256   if (type == NULL_TREE)
9257     {
9258       type = make_node (RECORD_TYPE);
9259
9260       namefield = ffecom_decl_field (type, NULL_TREE, "name",
9261                                      string_type_node);
9262       addrfield = ffecom_decl_field (type, namefield, "addr",
9263                                      string_type_node);
9264       dimsfield = ffecom_decl_field (type, addrfield, "dims",
9265                                      ffecom_f2c_ptr_to_ftnlen_type_node);
9266       typefield = ffecom_decl_field (type, dimsfield, "type",
9267                                      integer_type_node);
9268
9269       TYPE_FIELDS (type) = namefield;
9270       layout_type (type);
9271
9272       ggc_add_tree_root (&type, 1);
9273     }
9274
9275   return type;
9276 }
9277
9278 static tree
9279 ffecom_vardesc_ (ffebld expr)
9280 {
9281   ffesymbol s;
9282
9283   assert (ffebld_op (expr) == FFEBLD_opSYMTER);
9284   s = ffebld_symter (expr);
9285
9286   if (ffesymbol_hook (s).vardesc_tree == NULL_TREE)
9287     {
9288       int i;
9289       tree vardesctype = ffecom_type_vardesc_ ();
9290       tree var;
9291       tree nameinit;
9292       tree dimsinit;
9293       tree addrinit;
9294       tree typeinit;
9295       tree field;
9296       tree varinits;
9297       static int mynumber = 0;
9298
9299       var = build_decl (VAR_DECL,
9300                         ffecom_get_invented_identifier ("__g77_vardesc_%d",
9301                                                         mynumber++),
9302                         vardesctype);
9303       TREE_STATIC (var) = 1;
9304       DECL_INITIAL (var) = error_mark_node;
9305
9306       var = start_decl (var, FALSE);
9307
9308       /* Process inits.  */
9309
9310       nameinit = ffecom_build_f2c_string_ ((i = strlen (ffesymbol_text (s)))
9311                                            + 1,
9312                                            ffesymbol_text (s));
9313       TREE_TYPE (nameinit)
9314         = build_type_variant
9315         (build_array_type
9316          (char_type_node,
9317           build_range_type (integer_type_node,
9318                             integer_one_node,
9319                             build_int_2 (i, 0))),
9320          1, 0);
9321       TREE_CONSTANT (nameinit) = 1;
9322       TREE_STATIC (nameinit) = 1;
9323       nameinit = ffecom_1 (ADDR_EXPR,
9324                            build_pointer_type (TREE_TYPE (nameinit)),
9325                            nameinit);
9326
9327       addrinit = ffecom_arg_ptr_to_expr (expr, &typeinit);
9328
9329       dimsinit = ffecom_vardesc_dims_ (s);
9330
9331       if (typeinit == NULL_TREE)
9332         {
9333           ffeinfoBasictype bt = ffesymbol_basictype (s);
9334           ffeinfoKindtype kt = ffesymbol_kindtype (s);
9335           int tc = ffecom_f2c_typecode (bt, kt);
9336
9337           assert (tc != -1);
9338           typeinit = build_int_2 (tc, (tc < 0) ? -1 : 0);
9339         }
9340       else
9341         typeinit = ffecom_1 (NEGATE_EXPR, TREE_TYPE (typeinit), typeinit);
9342
9343       varinits = build_tree_list ((field = TYPE_FIELDS (vardesctype)),
9344                                   nameinit);
9345       TREE_CHAIN (varinits) = build_tree_list ((field = TREE_CHAIN (field)),
9346                                                addrinit);
9347       TREE_CHAIN (TREE_CHAIN (varinits))
9348         = build_tree_list ((field = TREE_CHAIN (field)), dimsinit);
9349       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (varinits)))
9350         = build_tree_list ((field = TREE_CHAIN (field)), typeinit);
9351
9352       varinits = build (CONSTRUCTOR, vardesctype, NULL_TREE, varinits);
9353       TREE_CONSTANT (varinits) = 1;
9354       TREE_STATIC (varinits) = 1;
9355
9356       finish_decl (var, varinits, FALSE);
9357
9358       var = ffecom_1 (ADDR_EXPR, build_pointer_type (vardesctype), var);
9359
9360       ffesymbol_hook (s).vardesc_tree = var;
9361     }
9362
9363   return ffesymbol_hook (s).vardesc_tree;
9364 }
9365
9366 static tree
9367 ffecom_vardesc_array_ (ffesymbol s)
9368 {
9369   ffebld b;
9370   tree list;
9371   tree item = NULL_TREE;
9372   tree var;
9373   int i;
9374   static int mynumber = 0;
9375
9376   for (i = 0, list = NULL_TREE, b = ffesymbol_namelist (s);
9377        b != NULL;
9378        b = ffebld_trail (b), ++i)
9379     {
9380       tree t;
9381
9382       t = ffecom_vardesc_ (ffebld_head (b));
9383
9384       if (list == NULL_TREE)
9385         list = item = build_tree_list (NULL_TREE, t);
9386       else
9387         {
9388           TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9389           item = TREE_CHAIN (item);
9390         }
9391     }
9392
9393   item = build_array_type (build_pointer_type (ffecom_type_vardesc_ ()),
9394                            build_range_type (integer_type_node,
9395                                              integer_one_node,
9396                                              build_int_2 (i, 0)));
9397   list = build (CONSTRUCTOR, item, NULL_TREE, list);
9398   TREE_CONSTANT (list) = 1;
9399   TREE_STATIC (list) = 1;
9400
9401   var = ffecom_get_invented_identifier ("__g77_vardesc_array_%d", mynumber++);
9402   var = build_decl (VAR_DECL, var, item);
9403   TREE_STATIC (var) = 1;
9404   DECL_INITIAL (var) = error_mark_node;
9405   var = start_decl (var, FALSE);
9406   finish_decl (var, list, FALSE);
9407
9408   return var;
9409 }
9410
9411 static tree
9412 ffecom_vardesc_dims_ (ffesymbol s)
9413 {
9414   if (ffesymbol_dims (s) == NULL)
9415     return convert (ffecom_f2c_ptr_to_ftnlen_type_node,
9416                     integer_zero_node);
9417
9418   {
9419     ffebld b;
9420     ffebld e;
9421     tree list;
9422     tree backlist;
9423     tree item = NULL_TREE;
9424     tree var;
9425     tree numdim;
9426     tree numelem;
9427     tree baseoff = NULL_TREE;
9428     static int mynumber = 0;
9429
9430     numdim = build_int_2 ((int) ffesymbol_rank (s), 0);
9431     TREE_TYPE (numdim) = ffecom_f2c_ftnlen_type_node;
9432
9433     numelem = ffecom_expr (ffesymbol_arraysize (s));
9434     TREE_TYPE (numelem) = ffecom_f2c_ftnlen_type_node;
9435
9436     list = NULL_TREE;
9437     backlist = NULL_TREE;
9438     for (b = ffesymbol_dims (s), e = ffesymbol_extents (s);
9439          b != NULL;
9440          b = ffebld_trail (b), e = ffebld_trail (e))
9441       {
9442         tree t;
9443         tree low;
9444         tree back;
9445
9446         if (ffebld_trail (b) == NULL)
9447           t = NULL_TREE;
9448         else
9449           {
9450             t = convert (ffecom_f2c_ftnlen_type_node,
9451                          ffecom_expr (ffebld_head (e)));
9452
9453             if (list == NULL_TREE)
9454               list = item = build_tree_list (NULL_TREE, t);
9455             else
9456               {
9457                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9458                 item = TREE_CHAIN (item);
9459               }
9460           }
9461
9462         if (ffebld_left (ffebld_head (b)) == NULL)
9463           low = ffecom_integer_one_node;
9464         else
9465           low = ffecom_expr (ffebld_left (ffebld_head (b)));
9466         low = convert (ffecom_f2c_ftnlen_type_node, low);
9467
9468         back = build_tree_list (low, t);
9469         TREE_CHAIN (back) = backlist;
9470         backlist = back;
9471       }
9472
9473     for (item = backlist; item != NULL_TREE; item = TREE_CHAIN (item))
9474       {
9475         if (TREE_VALUE (item) == NULL_TREE)
9476           baseoff = TREE_PURPOSE (item);
9477         else
9478           baseoff = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
9479                               TREE_PURPOSE (item),
9480                               ffecom_2 (MULT_EXPR,
9481                                         ffecom_f2c_ftnlen_type_node,
9482                                         TREE_VALUE (item),
9483                                         baseoff));
9484       }
9485
9486     /* backlist now dead, along with all TREE_PURPOSEs on it.  */
9487
9488     baseoff = build_tree_list (NULL_TREE, baseoff);
9489     TREE_CHAIN (baseoff) = list;
9490
9491     numelem = build_tree_list (NULL_TREE, numelem);
9492     TREE_CHAIN (numelem) = baseoff;
9493
9494     numdim = build_tree_list (NULL_TREE, numdim);
9495     TREE_CHAIN (numdim) = numelem;
9496
9497     item = build_array_type (ffecom_f2c_ftnlen_type_node,
9498                              build_range_type (integer_type_node,
9499                                                integer_zero_node,
9500                                                build_int_2
9501                                                ((int) ffesymbol_rank (s)
9502                                                 + 2, 0)));
9503     list = build (CONSTRUCTOR, item, NULL_TREE, numdim);
9504     TREE_CONSTANT (list) = 1;
9505     TREE_STATIC (list) = 1;
9506
9507     var = ffecom_get_invented_identifier ("__g77_dims_%d", mynumber++);
9508     var = build_decl (VAR_DECL, var, item);
9509     TREE_STATIC (var) = 1;
9510     DECL_INITIAL (var) = error_mark_node;
9511     var = start_decl (var, FALSE);
9512     finish_decl (var, list, FALSE);
9513
9514     var = ffecom_1 (ADDR_EXPR, build_pointer_type (item), var);
9515
9516     return var;
9517   }
9518 }
9519
9520 /* Essentially does a "fold (build1 (code, type, node))" while checking
9521    for certain housekeeping things.
9522
9523    NOTE: for building an ADDR_EXPR around a FUNCTION_DECL, use
9524    ffecom_1_fn instead.  */
9525
9526 tree
9527 ffecom_1 (enum tree_code code, tree type, tree node)
9528 {
9529   tree item;
9530
9531   if ((node == error_mark_node)
9532       || (type == error_mark_node))
9533     return error_mark_node;
9534
9535   if (code == ADDR_EXPR)
9536     {
9537       if (!ffe_mark_addressable (node))
9538         assert ("can't mark_addressable this node!" == NULL);
9539     }
9540
9541   switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9542     {
9543       tree realtype;
9544
9545     case REALPART_EXPR:
9546       item = build (COMPONENT_REF, type, node, TYPE_FIELDS (TREE_TYPE (node)));
9547       break;
9548
9549     case IMAGPART_EXPR:
9550       item = build (COMPONENT_REF, type, node, TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (node))));
9551       break;
9552
9553
9554     case NEGATE_EXPR:
9555       if (TREE_CODE (type) != RECORD_TYPE)
9556         {
9557           item = build1 (code, type, node);
9558           break;
9559         }
9560       node = ffecom_stabilize_aggregate_ (node);
9561       realtype = TREE_TYPE (TYPE_FIELDS (type));
9562       item =
9563         ffecom_2 (COMPLEX_EXPR, type,
9564                   ffecom_1 (NEGATE_EXPR, realtype,
9565                             ffecom_1 (REALPART_EXPR, realtype,
9566                                       node)),
9567                   ffecom_1 (NEGATE_EXPR, realtype,
9568                             ffecom_1 (IMAGPART_EXPR, realtype,
9569                                       node)));
9570       break;
9571
9572     default:
9573       item = build1 (code, type, node);
9574       break;
9575     }
9576
9577   if (TREE_SIDE_EFFECTS (node))
9578     TREE_SIDE_EFFECTS (item) = 1;
9579   if (code == ADDR_EXPR && staticp (node))
9580     TREE_CONSTANT (item) = 1;
9581   else if (code == INDIRECT_REF)
9582     TREE_READONLY (item) = TYPE_READONLY (type);
9583   return fold (item);
9584 }
9585
9586 /* Like ffecom_1 (ADDR_EXPR, TREE_TYPE (node), node), except
9587    handles TREE_CODE (node) == FUNCTION_DECL.  In particular,
9588    does not set TREE_ADDRESSABLE (because calling an inline
9589    function does not mean the function needs to be separately
9590    compiled).  */
9591
9592 tree
9593 ffecom_1_fn (tree node)
9594 {
9595   tree item;
9596   tree type;
9597
9598   if (node == error_mark_node)
9599     return error_mark_node;
9600
9601   type = build_type_variant (TREE_TYPE (node),
9602                              TREE_READONLY (node),
9603                              TREE_THIS_VOLATILE (node));
9604   item = build1 (ADDR_EXPR,
9605                  build_pointer_type (type), node);
9606   if (TREE_SIDE_EFFECTS (node))
9607     TREE_SIDE_EFFECTS (item) = 1;
9608   if (staticp (node))
9609     TREE_CONSTANT (item) = 1;
9610   return fold (item);
9611 }
9612
9613 /* Essentially does a "fold (build (code, type, node1, node2))" while
9614    checking for certain housekeeping things.  */
9615
9616 tree
9617 ffecom_2 (enum tree_code code, tree type, tree node1,
9618           tree node2)
9619 {
9620   tree item;
9621
9622   if ((node1 == error_mark_node)
9623       || (node2 == error_mark_node)
9624       || (type == error_mark_node))
9625     return error_mark_node;
9626
9627   switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9628     {
9629       tree a, b, c, d, realtype;
9630
9631     case CONJ_EXPR:
9632       assert ("no CONJ_EXPR support yet" == NULL);
9633       return error_mark_node;
9634
9635     case COMPLEX_EXPR:
9636       item = build_tree_list (TYPE_FIELDS (type), node1);
9637       TREE_CHAIN (item) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), node2);
9638       item = build (CONSTRUCTOR, type, NULL_TREE, item);
9639       break;
9640
9641     case PLUS_EXPR:
9642       if (TREE_CODE (type) != RECORD_TYPE)
9643         {
9644           item = build (code, type, node1, node2);
9645           break;
9646         }
9647       node1 = ffecom_stabilize_aggregate_ (node1);
9648       node2 = ffecom_stabilize_aggregate_ (node2);
9649       realtype = TREE_TYPE (TYPE_FIELDS (type));
9650       item =
9651         ffecom_2 (COMPLEX_EXPR, type,
9652                   ffecom_2 (PLUS_EXPR, realtype,
9653                             ffecom_1 (REALPART_EXPR, realtype,
9654                                       node1),
9655                             ffecom_1 (REALPART_EXPR, realtype,
9656                                       node2)),
9657                   ffecom_2 (PLUS_EXPR, realtype,
9658                             ffecom_1 (IMAGPART_EXPR, realtype,
9659                                       node1),
9660                             ffecom_1 (IMAGPART_EXPR, realtype,
9661                                       node2)));
9662       break;
9663
9664     case MINUS_EXPR:
9665       if (TREE_CODE (type) != RECORD_TYPE)
9666         {
9667           item = build (code, type, node1, node2);
9668           break;
9669         }
9670       node1 = ffecom_stabilize_aggregate_ (node1);
9671       node2 = ffecom_stabilize_aggregate_ (node2);
9672       realtype = TREE_TYPE (TYPE_FIELDS (type));
9673       item =
9674         ffecom_2 (COMPLEX_EXPR, type,
9675                   ffecom_2 (MINUS_EXPR, realtype,
9676                             ffecom_1 (REALPART_EXPR, realtype,
9677                                       node1),
9678                             ffecom_1 (REALPART_EXPR, realtype,
9679                                       node2)),
9680                   ffecom_2 (MINUS_EXPR, realtype,
9681                             ffecom_1 (IMAGPART_EXPR, realtype,
9682                                       node1),
9683                             ffecom_1 (IMAGPART_EXPR, realtype,
9684                                       node2)));
9685       break;
9686
9687     case MULT_EXPR:
9688       if (TREE_CODE (type) != RECORD_TYPE)
9689         {
9690           item = build (code, type, node1, node2);
9691           break;
9692         }
9693       node1 = ffecom_stabilize_aggregate_ (node1);
9694       node2 = ffecom_stabilize_aggregate_ (node2);
9695       realtype = TREE_TYPE (TYPE_FIELDS (type));
9696       a = save_expr (ffecom_1 (REALPART_EXPR, realtype,
9697                                node1));
9698       b = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
9699                                node1));
9700       c = save_expr (ffecom_1 (REALPART_EXPR, realtype,
9701                                node2));
9702       d = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
9703                                node2));
9704       item =
9705         ffecom_2 (COMPLEX_EXPR, type,
9706                   ffecom_2 (MINUS_EXPR, realtype,
9707                             ffecom_2 (MULT_EXPR, realtype,
9708                                       a,
9709                                       c),
9710                             ffecom_2 (MULT_EXPR, realtype,
9711                                       b,
9712                                       d)),
9713                   ffecom_2 (PLUS_EXPR, realtype,
9714                             ffecom_2 (MULT_EXPR, realtype,
9715                                       a,
9716                                       d),
9717                             ffecom_2 (MULT_EXPR, realtype,
9718                                       c,
9719                                       b)));
9720       break;
9721
9722     case EQ_EXPR:
9723       if ((TREE_CODE (node1) != RECORD_TYPE)
9724           && (TREE_CODE (node2) != RECORD_TYPE))
9725         {
9726           item = build (code, type, node1, node2);
9727           break;
9728         }
9729       assert (TREE_CODE (node1) == RECORD_TYPE);
9730       assert (TREE_CODE (node2) == RECORD_TYPE);
9731       node1 = ffecom_stabilize_aggregate_ (node1);
9732       node2 = ffecom_stabilize_aggregate_ (node2);
9733       realtype = TREE_TYPE (TYPE_FIELDS (type));
9734       item =
9735         ffecom_2 (TRUTH_ANDIF_EXPR, type,
9736                   ffecom_2 (code, type,
9737                             ffecom_1 (REALPART_EXPR, realtype,
9738                                       node1),
9739                             ffecom_1 (REALPART_EXPR, realtype,
9740                                       node2)),
9741                   ffecom_2 (code, type,
9742                             ffecom_1 (IMAGPART_EXPR, realtype,
9743                                       node1),
9744                             ffecom_1 (IMAGPART_EXPR, realtype,
9745                                       node2)));
9746       break;
9747
9748     case NE_EXPR:
9749       if ((TREE_CODE (node1) != RECORD_TYPE)
9750           && (TREE_CODE (node2) != RECORD_TYPE))
9751         {
9752           item = build (code, type, node1, node2);
9753           break;
9754         }
9755       assert (TREE_CODE (node1) == RECORD_TYPE);
9756       assert (TREE_CODE (node2) == RECORD_TYPE);
9757       node1 = ffecom_stabilize_aggregate_ (node1);
9758       node2 = ffecom_stabilize_aggregate_ (node2);
9759       realtype = TREE_TYPE (TYPE_FIELDS (type));
9760       item =
9761         ffecom_2 (TRUTH_ORIF_EXPR, type,
9762                   ffecom_2 (code, type,
9763                             ffecom_1 (REALPART_EXPR, realtype,
9764                                       node1),
9765                             ffecom_1 (REALPART_EXPR, realtype,
9766                                       node2)),
9767                   ffecom_2 (code, type,
9768                             ffecom_1 (IMAGPART_EXPR, realtype,
9769                                       node1),
9770                             ffecom_1 (IMAGPART_EXPR, realtype,
9771                                       node2)));
9772       break;
9773
9774     default:
9775       item = build (code, type, node1, node2);
9776       break;
9777     }
9778
9779   if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2))
9780     TREE_SIDE_EFFECTS (item) = 1;
9781   return fold (item);
9782 }
9783
9784 /* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint
9785
9786    ffesymbol s;  // the ENTRY point itself
9787    if (ffecom_2pass_advise_entrypoint(s))
9788        // the ENTRY point has been accepted
9789
9790    Does whatever compiler needs to do when it learns about the entrypoint,
9791    like determine the return type of the master function, count the
9792    number of entrypoints, etc.  Returns FALSE if the return type is
9793    not compatible with the return type(s) of other entrypoint(s).
9794
9795    NOTE: for every call to this fn that returns TRUE, _do_entrypoint must
9796    later (after _finish_progunit) be called with the same entrypoint(s)
9797    as passed to this fn for which TRUE was returned.
9798
9799    03-Jan-92  JCB  2.0
9800       Return FALSE if the return type conflicts with previous entrypoints.  */
9801
9802 bool
9803 ffecom_2pass_advise_entrypoint (ffesymbol entry)
9804 {
9805   ffebld list;                  /* opITEM. */
9806   ffebld mlist;                 /* opITEM. */
9807   ffebld plist;                 /* opITEM. */
9808   ffebld arg;                   /* ffebld_head(opITEM). */
9809   ffebld item;                  /* opITEM. */
9810   ffesymbol s;                  /* ffebld_symter(arg). */
9811   ffeinfoBasictype bt = ffesymbol_basictype (entry);
9812   ffeinfoKindtype kt = ffesymbol_kindtype (entry);
9813   ffetargetCharacterSize size = ffesymbol_size (entry);
9814   bool ok;
9815
9816   if (ffecom_num_entrypoints_ == 0)
9817     {                           /* First entrypoint, make list of main
9818                                    arglist's dummies. */
9819       assert (ffecom_primary_entry_ != NULL);
9820
9821       ffecom_master_bt_ = ffesymbol_basictype (ffecom_primary_entry_);
9822       ffecom_master_kt_ = ffesymbol_kindtype (ffecom_primary_entry_);
9823       ffecom_master_size_ = ffesymbol_size (ffecom_primary_entry_);
9824
9825       for (plist = NULL, list = ffesymbol_dummyargs (ffecom_primary_entry_);
9826            list != NULL;
9827            list = ffebld_trail (list))
9828         {
9829           arg = ffebld_head (list);
9830           if (ffebld_op (arg) != FFEBLD_opSYMTER)
9831             continue;           /* Alternate return or some such thing. */
9832           item = ffebld_new_item (arg, NULL);
9833           if (plist == NULL)
9834             ffecom_master_arglist_ = item;
9835           else
9836             ffebld_set_trail (plist, item);
9837           plist = item;
9838         }
9839     }
9840
9841   /* If necessary, scan entry arglist for alternate returns.  Do this scan
9842      apparently redundantly (it's done below to UNIONize the arglists) so
9843      that we don't complain about RETURN 1 if an offending ENTRY is the only
9844      one with an alternate return.  */
9845
9846   if (!ffecom_is_altreturning_)
9847     {
9848       for (list = ffesymbol_dummyargs (entry);
9849            list != NULL;
9850            list = ffebld_trail (list))
9851         {
9852           arg = ffebld_head (list);
9853           if (ffebld_op (arg) == FFEBLD_opSTAR)
9854             {
9855               ffecom_is_altreturning_ = TRUE;
9856               break;
9857             }
9858         }
9859     }
9860
9861   /* Now check type compatibility. */
9862
9863   switch (ffecom_master_bt_)
9864     {
9865     case FFEINFO_basictypeNONE:
9866       ok = (bt != FFEINFO_basictypeCHARACTER);
9867       break;
9868
9869     case FFEINFO_basictypeCHARACTER:
9870       ok
9871         = (bt == FFEINFO_basictypeCHARACTER)
9872         && (kt == ffecom_master_kt_)
9873         && (size == ffecom_master_size_);
9874       break;
9875
9876     case FFEINFO_basictypeANY:
9877       return FALSE;             /* Just don't bother. */
9878
9879     default:
9880       if (bt == FFEINFO_basictypeCHARACTER)
9881         {
9882           ok = FALSE;
9883           break;
9884         }
9885       ok = TRUE;
9886       if ((bt != ffecom_master_bt_) || (kt != ffecom_master_kt_))
9887         {
9888           ffecom_master_bt_ = FFEINFO_basictypeNONE;
9889           ffecom_master_kt_ = FFEINFO_kindtypeNONE;
9890         }
9891       break;
9892     }
9893
9894   if (!ok)
9895     {
9896       ffebad_start (FFEBAD_ENTRY_CONFLICTS);
9897       ffest_ffebad_here_current_stmt (0);
9898       ffebad_finish ();
9899       return FALSE;             /* Can't handle entrypoint. */
9900     }
9901
9902   /* Entrypoint type compatible with previous types. */
9903
9904   ++ffecom_num_entrypoints_;
9905
9906   /* Master-arg-list = UNION(Master-arg-list,entry-arg-list). */
9907
9908   for (list = ffesymbol_dummyargs (entry);
9909        list != NULL;
9910        list = ffebld_trail (list))
9911     {
9912       arg = ffebld_head (list);
9913       if (ffebld_op (arg) != FFEBLD_opSYMTER)
9914         continue;               /* Alternate return or some such thing. */
9915       s = ffebld_symter (arg);
9916       for (plist = NULL, mlist = ffecom_master_arglist_;
9917            mlist != NULL;
9918            plist = mlist, mlist = ffebld_trail (mlist))
9919         {                       /* plist points to previous item for easy
9920                                    appending of arg. */
9921           if (ffebld_symter (ffebld_head (mlist)) == s)
9922             break;              /* Already have this arg in the master list. */
9923         }
9924       if (mlist != NULL)
9925         continue;               /* Already have this arg in the master list. */
9926
9927       /* Append this arg to the master list. */
9928
9929       item = ffebld_new_item (arg, NULL);
9930       if (plist == NULL)
9931         ffecom_master_arglist_ = item;
9932       else
9933         ffebld_set_trail (plist, item);
9934     }
9935
9936   return TRUE;
9937 }
9938
9939 /* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint
9940
9941    ffesymbol s;  // the ENTRY point itself
9942    ffecom_2pass_do_entrypoint(s);
9943
9944    Does whatever compiler needs to do to make the entrypoint actually
9945    happen.  Must be called for each entrypoint after
9946    ffecom_finish_progunit is called.  */
9947
9948 void
9949 ffecom_2pass_do_entrypoint (ffesymbol entry)
9950 {
9951   static int mfn_num = 0;
9952   static int ent_num;
9953
9954   if (mfn_num != ffecom_num_fns_)
9955     {                           /* First entrypoint for this program unit. */
9956       ent_num = 1;
9957       mfn_num = ffecom_num_fns_;
9958       ffecom_do_entry_ (ffecom_primary_entry_, 0);
9959     }
9960   else
9961     ++ent_num;
9962
9963   --ffecom_num_entrypoints_;
9964
9965   ffecom_do_entry_ (entry, ent_num);
9966 }
9967
9968 /* Essentially does a "fold (build (code, type, node1, node2))" while
9969    checking for certain housekeeping things.  Always sets
9970    TREE_SIDE_EFFECTS.  */
9971
9972 tree
9973 ffecom_2s (enum tree_code code, tree type, tree node1,
9974            tree node2)
9975 {
9976   tree item;
9977
9978   if ((node1 == error_mark_node)
9979       || (node2 == error_mark_node)
9980       || (type == error_mark_node))
9981     return error_mark_node;
9982
9983   item = build (code, type, node1, node2);
9984   TREE_SIDE_EFFECTS (item) = 1;
9985   return fold (item);
9986 }
9987
9988 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
9989    checking for certain housekeeping things.  */
9990
9991 tree
9992 ffecom_3 (enum tree_code code, tree type, tree node1,
9993           tree node2, tree node3)
9994 {
9995   tree item;
9996
9997   if ((node1 == error_mark_node)
9998       || (node2 == error_mark_node)
9999       || (node3 == error_mark_node)
10000       || (type == error_mark_node))
10001     return error_mark_node;
10002
10003   item = build (code, type, node1, node2, node3);
10004   if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2)
10005       || (node3 != NULL_TREE && TREE_SIDE_EFFECTS (node3)))
10006     TREE_SIDE_EFFECTS (item) = 1;
10007   return fold (item);
10008 }
10009
10010 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10011    checking for certain housekeeping things.  Always sets
10012    TREE_SIDE_EFFECTS.  */
10013
10014 tree
10015 ffecom_3s (enum tree_code code, tree type, tree node1,
10016            tree node2, tree node3)
10017 {
10018   tree item;
10019
10020   if ((node1 == error_mark_node)
10021       || (node2 == error_mark_node)
10022       || (node3 == error_mark_node)
10023       || (type == error_mark_node))
10024     return error_mark_node;
10025
10026   item = build (code, type, node1, node2, node3);
10027   TREE_SIDE_EFFECTS (item) = 1;
10028   return fold (item);
10029 }
10030
10031 /* ffecom_arg_expr -- Transform argument expr into gcc tree
10032
10033    See use by ffecom_list_expr.
10034
10035    If expression is NULL, returns an integer zero tree.  If it is not
10036    a CHARACTER expression, returns whatever ffecom_expr
10037    returns and sets the length return value to NULL_TREE.  Otherwise
10038    generates code to evaluate the character expression, returns the proper
10039    pointer to the result, but does NOT set the length return value to a tree
10040    that specifies the length of the result.  (In other words, the length
10041    variable is always set to NULL_TREE, because a length is never passed.)
10042
10043    21-Dec-91  JCB  1.1
10044       Don't set returned length, since nobody needs it (yet; someday if
10045       we allow CHARACTER*(*) dummies to statement functions, we'll need
10046       it).  */
10047
10048 tree
10049 ffecom_arg_expr (ffebld expr, tree *length)
10050 {
10051   tree ign;
10052
10053   *length = NULL_TREE;
10054
10055   if (expr == NULL)
10056     return integer_zero_node;
10057
10058   if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10059     return ffecom_expr (expr);
10060
10061   return ffecom_arg_ptr_to_expr (expr, &ign);
10062 }
10063
10064 /* Transform expression into constant argument-pointer-to-expression tree.
10065
10066    If the expression can be transformed into a argument-pointer-to-expression
10067    tree that is constant, that is done, and the tree returned.  Else
10068    NULL_TREE is returned.
10069
10070    That way, a caller can attempt to provide compile-time initialization
10071    of a variable and, if that fails, *then* choose to start a new block
10072    and resort to using temporaries, as appropriate.  */
10073
10074 tree
10075 ffecom_arg_ptr_to_const_expr (ffebld expr, tree *length)
10076 {
10077   if (! expr)
10078     return integer_zero_node;
10079
10080   if (ffebld_op (expr) == FFEBLD_opANY)
10081     {
10082       if (length)
10083         *length = error_mark_node;
10084       return error_mark_node;
10085     }
10086
10087   if (ffebld_arity (expr) == 0
10088       && (ffebld_op (expr) != FFEBLD_opSYMTER
10089           || ffebld_where (expr) == FFEINFO_whereCOMMON
10090           || ffebld_where (expr) == FFEINFO_whereGLOBAL
10091           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10092     {
10093       tree t;
10094
10095       t = ffecom_arg_ptr_to_expr (expr, length);
10096       assert (TREE_CONSTANT (t));
10097       assert (! length || TREE_CONSTANT (*length));
10098       return t;
10099     }
10100
10101   if (length
10102       && ffebld_size (expr) != FFETARGET_charactersizeNONE)
10103     *length = build_int_2 (ffebld_size (expr), 0);
10104   else if (length)
10105     *length = NULL_TREE;
10106   return NULL_TREE;
10107 }
10108
10109 /* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree
10110
10111    See use by ffecom_list_ptr_to_expr.
10112
10113    If expression is NULL, returns an integer zero tree.  If it is not
10114    a CHARACTER expression, returns whatever ffecom_ptr_to_expr
10115    returns and sets the length return value to NULL_TREE.  Otherwise
10116    generates code to evaluate the character expression, returns the proper
10117    pointer to the result, AND sets the length return value to a tree that
10118    specifies the length of the result.
10119
10120    If the length argument is NULL, this is a slightly special
10121    case of building a FORMAT expression, that is, an expression that
10122    will be used at run time without regard to length.  For the current
10123    implementation, which uses the libf2c library, this means it is nice
10124    to append a null byte to the end of the expression, where feasible,
10125    to make sure any diagnostic about the FORMAT string terminates at
10126    some useful point.
10127
10128    For now, treat %REF(char-expr) as the same as char-expr with a NULL
10129    length argument.  This might even be seen as a feature, if a null
10130    byte can always be appended.  */
10131
10132 tree
10133 ffecom_arg_ptr_to_expr (ffebld expr, tree *length)
10134 {
10135   tree item;
10136   tree ign_length;
10137   ffecomConcatList_ catlist;
10138
10139   if (length != NULL)
10140     *length = NULL_TREE;
10141
10142   if (expr == NULL)
10143     return integer_zero_node;
10144
10145   switch (ffebld_op (expr))
10146     {
10147     case FFEBLD_opPERCENT_VAL:
10148       if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10149         return ffecom_expr (ffebld_left (expr));
10150       {
10151         tree temp_exp;
10152         tree temp_length;
10153
10154         temp_exp = ffecom_arg_ptr_to_expr (ffebld_left (expr), &temp_length);
10155         if (temp_exp == error_mark_node)
10156           return error_mark_node;
10157
10158         return ffecom_1 (INDIRECT_REF, TREE_TYPE (TREE_TYPE (temp_exp)),
10159                          temp_exp);
10160       }
10161
10162     case FFEBLD_opPERCENT_REF:
10163       if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10164         return ffecom_ptr_to_expr (ffebld_left (expr));
10165       if (length != NULL)
10166         {
10167           ign_length = NULL_TREE;
10168           length = &ign_length;
10169         }
10170       expr = ffebld_left (expr);
10171       break;
10172
10173     case FFEBLD_opPERCENT_DESCR:
10174       switch (ffeinfo_basictype (ffebld_info (expr)))
10175         {
10176 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10177         case FFEINFO_basictypeHOLLERITH:
10178 #endif
10179         case FFEINFO_basictypeCHARACTER:
10180           break;                /* Passed by descriptor anyway. */
10181
10182         default:
10183           item = ffecom_ptr_to_expr (expr);
10184           if (item != error_mark_node)
10185             *length = TYPE_SIZE (TREE_TYPE (TREE_TYPE (item)));
10186           break;
10187         }
10188       break;
10189
10190     default:
10191       break;
10192     }
10193
10194 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10195   if ((ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeHOLLERITH)
10196       && (length != NULL))
10197     {                           /* Pass Hollerith by descriptor. */
10198       ffetargetHollerith h;
10199
10200       assert (ffebld_op (expr) == FFEBLD_opCONTER);
10201       h = ffebld_cu_val_hollerith (ffebld_constant_union
10202                                    (ffebld_conter (expr)));
10203       *length
10204         = build_int_2 (h.length, 0);
10205       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10206     }
10207 #endif
10208
10209   if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10210     return ffecom_ptr_to_expr (expr);
10211
10212   assert (ffeinfo_kindtype (ffebld_info (expr))
10213           == FFEINFO_kindtypeCHARACTER1);
10214
10215   while (ffebld_op (expr) == FFEBLD_opPAREN)
10216     expr = ffebld_left (expr);
10217
10218   catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
10219   switch (ffecom_concat_list_count_ (catlist))
10220     {
10221     case 0:                     /* Shouldn't happen, but in case it does... */
10222       if (length != NULL)
10223         {
10224           *length = ffecom_f2c_ftnlen_zero_node;
10225           TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10226         }
10227       ffecom_concat_list_kill_ (catlist);
10228       return null_pointer_node;
10229
10230     case 1:                     /* The (fairly) easy case. */
10231       if (length == NULL)
10232         ffecom_char_args_with_null_ (&item, &ign_length,
10233                                      ffecom_concat_list_expr_ (catlist, 0));
10234       else
10235         ffecom_char_args_ (&item, length,
10236                            ffecom_concat_list_expr_ (catlist, 0));
10237       ffecom_concat_list_kill_ (catlist);
10238       assert (item != NULL_TREE);
10239       return item;
10240
10241     default:                    /* Must actually concatenate things. */
10242       break;
10243     }
10244
10245   {
10246     int count = ffecom_concat_list_count_ (catlist);
10247     int i;
10248     tree lengths;
10249     tree items;
10250     tree length_array;
10251     tree item_array;
10252     tree citem;
10253     tree clength;
10254     tree temporary;
10255     tree num;
10256     tree known_length;
10257     ffetargetCharacterSize sz;
10258
10259     sz = ffecom_concat_list_maxlen_ (catlist);
10260     /* ~~Kludge! */
10261     assert (sz != FFETARGET_charactersizeNONE);
10262
10263 #ifdef HOHO
10264     length_array
10265       = lengths
10266       = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
10267                              FFETARGET_charactersizeNONE, count, TRUE);
10268     item_array
10269       = items
10270       = ffecom_push_tempvar (ffecom_f2c_address_type_node,
10271                              FFETARGET_charactersizeNONE, count, TRUE);
10272     temporary = ffecom_push_tempvar (char_type_node,
10273                                      sz, -1, TRUE);
10274 #else
10275     {
10276       tree hook;
10277
10278       hook = ffebld_nonter_hook (expr);
10279       assert (hook);
10280       assert (TREE_CODE (hook) == TREE_VEC);
10281       assert (TREE_VEC_LENGTH (hook) == 3);
10282       length_array = lengths = TREE_VEC_ELT (hook, 0);
10283       item_array = items = TREE_VEC_ELT (hook, 1);
10284       temporary = TREE_VEC_ELT (hook, 2);
10285     }
10286 #endif
10287
10288     known_length = ffecom_f2c_ftnlen_zero_node;
10289
10290     for (i = 0; i < count; ++i)
10291       {
10292         if ((i == count)
10293             && (length == NULL))
10294           ffecom_char_args_with_null_ (&citem, &clength,
10295                                        ffecom_concat_list_expr_ (catlist, i));
10296         else
10297           ffecom_char_args_ (&citem, &clength,
10298                              ffecom_concat_list_expr_ (catlist, i));
10299         if ((citem == error_mark_node)
10300             || (clength == error_mark_node))
10301           {
10302             ffecom_concat_list_kill_ (catlist);
10303             *length = error_mark_node;
10304             return error_mark_node;
10305           }
10306
10307         items
10308           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
10309                       ffecom_modify (void_type_node,
10310                                      ffecom_2 (ARRAY_REF,
10311                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
10312                                                item_array,
10313                                                build_int_2 (i, 0)),
10314                                      citem),
10315                       items);
10316         clength = ffecom_save_tree (clength);
10317         if (length != NULL)
10318           known_length
10319             = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
10320                         known_length,
10321                         clength);
10322         lengths
10323           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
10324                       ffecom_modify (void_type_node,
10325                                      ffecom_2 (ARRAY_REF,
10326                    TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
10327                                                length_array,
10328                                                build_int_2 (i, 0)),
10329                                      clength),
10330                       lengths);
10331       }
10332
10333     temporary = ffecom_1 (ADDR_EXPR,
10334                           build_pointer_type (TREE_TYPE (temporary)),
10335                           temporary);
10336
10337     item = build_tree_list (NULL_TREE, temporary);
10338     TREE_CHAIN (item)
10339       = build_tree_list (NULL_TREE,
10340                          ffecom_1 (ADDR_EXPR,
10341                                    build_pointer_type (TREE_TYPE (items)),
10342                                    items));
10343     TREE_CHAIN (TREE_CHAIN (item))
10344       = build_tree_list (NULL_TREE,
10345                          ffecom_1 (ADDR_EXPR,
10346                                    build_pointer_type (TREE_TYPE (lengths)),
10347                                    lengths));
10348     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
10349       = build_tree_list
10350         (NULL_TREE,
10351          ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
10352                    convert (ffecom_f2c_ftnlen_type_node,
10353                             build_int_2 (count, 0))));
10354     num = build_int_2 (sz, 0);
10355     TREE_TYPE (num) = ffecom_f2c_ftnlen_type_node;
10356     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item))))
10357       = build_tree_list (NULL_TREE, num);
10358
10359     item = ffecom_call_gfrt (FFECOM_gfrtCAT, item, NULL_TREE);
10360     TREE_SIDE_EFFECTS (item) = 1;
10361     item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (temporary),
10362                      item,
10363                      temporary);
10364
10365     if (length != NULL)
10366       *length = known_length;
10367   }
10368
10369   ffecom_concat_list_kill_ (catlist);
10370   assert (item != NULL_TREE);
10371   return item;
10372 }
10373
10374 /* Generate call to run-time function.
10375
10376    The first arg is the GNU Fortran Run-Time function index, the second
10377    arg is the list of arguments to pass to it.  Returned is the expression
10378    (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the
10379    result (which may be void).  */
10380
10381 tree
10382 ffecom_call_gfrt (ffecomGfrt ix, tree args, tree hook)
10383 {
10384   return ffecom_call_ (ffecom_gfrt_tree_ (ix),
10385                        ffecom_gfrt_kindtype (ix),
10386                        ffe_is_f2c_library () && ffecom_gfrt_complex_[ix],
10387                        NULL_TREE, args, NULL_TREE, NULL,
10388                        NULL, NULL_TREE, TRUE, hook);
10389 }
10390
10391 /* Transform constant-union to tree.  */
10392
10393 tree
10394 ffecom_constantunion (ffebldConstantUnion *cu, ffeinfoBasictype bt,
10395                       ffeinfoKindtype kt, tree tree_type)
10396 {
10397   tree item;
10398
10399   switch (bt)
10400     {
10401     case FFEINFO_basictypeINTEGER:
10402       {
10403         int val;
10404
10405         switch (kt)
10406           {
10407 #if FFETARGET_okINTEGER1
10408           case FFEINFO_kindtypeINTEGER1:
10409             val = ffebld_cu_val_integer1 (*cu);
10410             break;
10411 #endif
10412
10413 #if FFETARGET_okINTEGER2
10414           case FFEINFO_kindtypeINTEGER2:
10415             val = ffebld_cu_val_integer2 (*cu);
10416             break;
10417 #endif
10418
10419 #if FFETARGET_okINTEGER3
10420           case FFEINFO_kindtypeINTEGER3:
10421             val = ffebld_cu_val_integer3 (*cu);
10422             break;
10423 #endif
10424
10425 #if FFETARGET_okINTEGER4
10426           case FFEINFO_kindtypeINTEGER4:
10427             val = ffebld_cu_val_integer4 (*cu);
10428             break;
10429 #endif
10430
10431           default:
10432             assert ("bad INTEGER constant kind type" == NULL);
10433             /* Fall through. */
10434           case FFEINFO_kindtypeANY:
10435             return error_mark_node;
10436           }
10437         item = build_int_2 (val, (val < 0) ? -1 : 0);
10438         TREE_TYPE (item) = tree_type;
10439       }
10440       break;
10441
10442     case FFEINFO_basictypeLOGICAL:
10443       {
10444         int val;
10445
10446         switch (kt)
10447           {
10448 #if FFETARGET_okLOGICAL1
10449           case FFEINFO_kindtypeLOGICAL1:
10450             val = ffebld_cu_val_logical1 (*cu);
10451             break;
10452 #endif
10453
10454 #if FFETARGET_okLOGICAL2
10455           case FFEINFO_kindtypeLOGICAL2:
10456             val = ffebld_cu_val_logical2 (*cu);
10457             break;
10458 #endif
10459
10460 #if FFETARGET_okLOGICAL3
10461           case FFEINFO_kindtypeLOGICAL3:
10462             val = ffebld_cu_val_logical3 (*cu);
10463             break;
10464 #endif
10465
10466 #if FFETARGET_okLOGICAL4
10467           case FFEINFO_kindtypeLOGICAL4:
10468             val = ffebld_cu_val_logical4 (*cu);
10469             break;
10470 #endif
10471
10472           default:
10473             assert ("bad LOGICAL constant kind type" == NULL);
10474             /* Fall through. */
10475           case FFEINFO_kindtypeANY:
10476             return error_mark_node;
10477           }
10478         item = build_int_2 (val, (val < 0) ? -1 : 0);
10479         TREE_TYPE (item) = tree_type;
10480       }
10481       break;
10482
10483     case FFEINFO_basictypeREAL:
10484       {
10485         REAL_VALUE_TYPE val;
10486
10487         switch (kt)
10488           {
10489 #if FFETARGET_okREAL1
10490           case FFEINFO_kindtypeREAL1:
10491             val = ffetarget_value_real1 (ffebld_cu_val_real1 (*cu));
10492             break;
10493 #endif
10494
10495 #if FFETARGET_okREAL2
10496           case FFEINFO_kindtypeREAL2:
10497             val = ffetarget_value_real2 (ffebld_cu_val_real2 (*cu));
10498             break;
10499 #endif
10500
10501 #if FFETARGET_okREAL3
10502           case FFEINFO_kindtypeREAL3:
10503             val = ffetarget_value_real3 (ffebld_cu_val_real3 (*cu));
10504             break;
10505 #endif
10506
10507 #if FFETARGET_okREAL4
10508           case FFEINFO_kindtypeREAL4:
10509             val = ffetarget_value_real4 (ffebld_cu_val_real4 (*cu));
10510             break;
10511 #endif
10512
10513           default:
10514             assert ("bad REAL constant kind type" == NULL);
10515             /* Fall through. */
10516           case FFEINFO_kindtypeANY:
10517             return error_mark_node;
10518           }
10519         item = build_real (tree_type, val);
10520       }
10521       break;
10522
10523     case FFEINFO_basictypeCOMPLEX:
10524       {
10525         REAL_VALUE_TYPE real;
10526         REAL_VALUE_TYPE imag;
10527         tree el_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
10528
10529         switch (kt)
10530           {
10531 #if FFETARGET_okCOMPLEX1
10532           case FFEINFO_kindtypeREAL1:
10533             real = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).real);
10534             imag = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).imaginary);
10535             break;
10536 #endif
10537
10538 #if FFETARGET_okCOMPLEX2
10539           case FFEINFO_kindtypeREAL2:
10540             real = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).real);
10541             imag = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).imaginary);
10542             break;
10543 #endif
10544
10545 #if FFETARGET_okCOMPLEX3
10546           case FFEINFO_kindtypeREAL3:
10547             real = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).real);
10548             imag = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).imaginary);
10549             break;
10550 #endif
10551
10552 #if FFETARGET_okCOMPLEX4
10553           case FFEINFO_kindtypeREAL4:
10554             real = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).real);
10555             imag = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).imaginary);
10556             break;
10557 #endif
10558
10559           default:
10560             assert ("bad REAL constant kind type" == NULL);
10561             /* Fall through. */
10562           case FFEINFO_kindtypeANY:
10563             return error_mark_node;
10564           }
10565         item = ffecom_build_complex_constant_ (tree_type,
10566                                                build_real (el_type, real),
10567                                                build_real (el_type, imag));
10568       }
10569       break;
10570
10571     case FFEINFO_basictypeCHARACTER:
10572       {                         /* Happens only in DATA and similar contexts. */
10573         ffetargetCharacter1 val;
10574
10575         switch (kt)
10576           {
10577 #if FFETARGET_okCHARACTER1
10578           case FFEINFO_kindtypeLOGICAL1:
10579             val = ffebld_cu_val_character1 (*cu);
10580             break;
10581 #endif
10582
10583           default:
10584             assert ("bad CHARACTER constant kind type" == NULL);
10585             /* Fall through. */
10586           case FFEINFO_kindtypeANY:
10587             return error_mark_node;
10588           }
10589         item = build_string (ffetarget_length_character1 (val),
10590                              ffetarget_text_character1 (val));
10591         TREE_TYPE (item)
10592           = build_type_variant (build_array_type (char_type_node,
10593                                                   build_range_type
10594                                                   (integer_type_node,
10595                                                    integer_one_node,
10596                                                    build_int_2
10597                                                 (ffetarget_length_character1
10598                                                  (val), 0))),
10599                                 1, 0);
10600       }
10601       break;
10602
10603     case FFEINFO_basictypeHOLLERITH:
10604       {
10605         ffetargetHollerith h;
10606
10607         h = ffebld_cu_val_hollerith (*cu);
10608
10609         /* If not at least as wide as default INTEGER, widen it.  */
10610         if (h.length >= FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE)
10611           item = build_string (h.length, h.text);
10612         else
10613           {
10614             char str[FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE];
10615
10616             memcpy (str, h.text, h.length);
10617             memset (&str[h.length], ' ',
10618                     FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE
10619                     - h.length);
10620             item = build_string (FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE,
10621                                  str);
10622           }
10623         TREE_TYPE (item)
10624           = build_type_variant (build_array_type (char_type_node,
10625                                                   build_range_type
10626                                                   (integer_type_node,
10627                                                    integer_one_node,
10628                                                    build_int_2
10629                                                    (h.length, 0))),
10630                                 1, 0);
10631       }
10632       break;
10633
10634     case FFEINFO_basictypeTYPELESS:
10635       {
10636         ffetargetInteger1 ival;
10637         ffetargetTypeless tless;
10638         ffebad error;
10639
10640         tless = ffebld_cu_val_typeless (*cu);
10641         error = ffetarget_convert_integer1_typeless (&ival, tless);
10642         assert (error == FFEBAD);
10643
10644         item = build_int_2 ((int) ival, 0);
10645       }
10646       break;
10647
10648     default:
10649       assert ("not yet on constant type" == NULL);
10650       /* Fall through. */
10651     case FFEINFO_basictypeANY:
10652       return error_mark_node;
10653     }
10654
10655   TREE_CONSTANT (item) = 1;
10656
10657   return item;
10658 }
10659
10660 /* Transform expression into constant tree.
10661
10662    If the expression can be transformed into a tree that is constant,
10663    that is done, and the tree returned.  Else NULL_TREE is returned.
10664
10665    That way, a caller can attempt to provide compile-time initialization
10666    of a variable and, if that fails, *then* choose to start a new block
10667    and resort to using temporaries, as appropriate.  */
10668
10669 tree
10670 ffecom_const_expr (ffebld expr)
10671 {
10672   if (! expr)
10673     return integer_zero_node;
10674
10675   if (ffebld_op (expr) == FFEBLD_opANY)
10676     return error_mark_node;
10677
10678   if (ffebld_arity (expr) == 0
10679       && (ffebld_op (expr) != FFEBLD_opSYMTER
10680 #if NEWCOMMON
10681           /* ~~Enable once common/equivalence is handled properly?  */
10682           || ffebld_where (expr) == FFEINFO_whereCOMMON
10683 #endif
10684           || ffebld_where (expr) == FFEINFO_whereGLOBAL
10685           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10686     {
10687       tree t;
10688
10689       t = ffecom_expr (expr);
10690       assert (TREE_CONSTANT (t));
10691       return t;
10692     }
10693
10694   return NULL_TREE;
10695 }
10696
10697 /* Handy way to make a field in a struct/union.  */
10698
10699 tree
10700 ffecom_decl_field (tree context, tree prevfield,
10701                    const char *name, tree type)
10702 {
10703   tree field;
10704
10705   field = build_decl (FIELD_DECL, get_identifier (name), type);
10706   DECL_CONTEXT (field) = context;
10707   DECL_ALIGN (field) = 0;
10708   DECL_USER_ALIGN (field) = 0;
10709   if (prevfield != NULL_TREE)
10710     TREE_CHAIN (prevfield) = field;
10711
10712   return field;
10713 }
10714
10715 void
10716 ffecom_close_include (FILE *f)
10717 {
10718   ffecom_close_include_ (f);
10719 }
10720
10721 int
10722 ffecom_decode_include_option (char *spec)
10723 {
10724   return ffecom_decode_include_option_ (spec);
10725 }
10726
10727 /* End a compound statement (block).  */
10728
10729 tree
10730 ffecom_end_compstmt (void)
10731 {
10732   return bison_rule_compstmt_ ();
10733 }
10734
10735 /* ffecom_end_transition -- Perform end transition on all symbols
10736
10737    ffecom_end_transition();
10738
10739    Calls ffecom_sym_end_transition for each global and local symbol.  */
10740
10741 void
10742 ffecom_end_transition ()
10743 {
10744   ffebld item;
10745
10746   if (ffe_is_ffedebug ())
10747     fprintf (dmpout, "; end_stmt_transition\n");
10748
10749   ffecom_list_blockdata_ = NULL;
10750   ffecom_list_common_ = NULL;
10751
10752   ffesymbol_drive (ffecom_sym_end_transition);
10753   if (ffe_is_ffedebug ())
10754     {
10755       ffestorag_report ();
10756     }
10757
10758   ffecom_start_progunit_ ();
10759
10760   for (item = ffecom_list_blockdata_;
10761        item != NULL;
10762        item = ffebld_trail (item))
10763     {
10764       ffebld callee;
10765       ffesymbol s;
10766       tree dt;
10767       tree t;
10768       tree var;
10769       static int number = 0;
10770
10771       callee = ffebld_head (item);
10772       s = ffebld_symter (callee);
10773       t = ffesymbol_hook (s).decl_tree;
10774       if (t == NULL_TREE)
10775         {
10776           s = ffecom_sym_transform_ (s);
10777           t = ffesymbol_hook (s).decl_tree;
10778         }
10779
10780       dt = build_pointer_type (TREE_TYPE (t));
10781
10782       var = build_decl (VAR_DECL,
10783                         ffecom_get_invented_identifier ("__g77_forceload_%d",
10784                                                         number++),
10785                         dt);
10786       DECL_EXTERNAL (var) = 0;
10787       TREE_STATIC (var) = 1;
10788       TREE_PUBLIC (var) = 0;
10789       DECL_INITIAL (var) = error_mark_node;
10790       TREE_USED (var) = 1;
10791
10792       var = start_decl (var, FALSE);
10793
10794       t = ffecom_1 (ADDR_EXPR, dt, t);
10795
10796       finish_decl (var, t, FALSE);
10797     }
10798
10799   /* This handles any COMMON areas that weren't referenced but have, for
10800      example, important initial data.  */
10801
10802   for (item = ffecom_list_common_;
10803        item != NULL;
10804        item = ffebld_trail (item))
10805     ffecom_transform_common_ (ffebld_symter (ffebld_head (item)));
10806
10807   ffecom_list_common_ = NULL;
10808 }
10809
10810 /* ffecom_exec_transition -- Perform exec transition on all symbols
10811
10812    ffecom_exec_transition();
10813
10814    Calls ffecom_sym_exec_transition for each global and local symbol.
10815    Make sure error updating not inhibited.  */
10816
10817 void
10818 ffecom_exec_transition ()
10819 {
10820   bool inhibited;
10821
10822   if (ffe_is_ffedebug ())
10823     fprintf (dmpout, "; exec_stmt_transition\n");
10824
10825   inhibited = ffebad_inhibit ();
10826   ffebad_set_inhibit (FALSE);
10827
10828   ffesymbol_drive (ffecom_sym_exec_transition); /* Don't retract! */
10829   ffeequiv_exec_transition ();  /* Handle all pending EQUIVALENCEs. */
10830   if (ffe_is_ffedebug ())
10831     {
10832       ffestorag_report ();
10833     }
10834
10835   if (inhibited)
10836     ffebad_set_inhibit (TRUE);
10837 }
10838
10839 /* Handle assignment statement.
10840
10841    Convert dest and source using ffecom_expr, then join them
10842    with an ASSIGN op and pass the whole thing to expand_expr_stmt.  */
10843
10844 void
10845 ffecom_expand_let_stmt (ffebld dest, ffebld source)
10846 {
10847   tree dest_tree;
10848   tree dest_length;
10849   tree source_tree;
10850   tree expr_tree;
10851
10852   if (ffeinfo_basictype (ffebld_info (dest)) != FFEINFO_basictypeCHARACTER)
10853     {
10854       bool dest_used;
10855       tree assign_temp;
10856
10857       /* This attempts to replicate the test below, but must not be
10858          true when the test below is false.  (Always err on the side
10859          of creating unused temporaries, to avoid ICEs.)  */
10860       if (ffebld_op (dest) != FFEBLD_opSYMTER
10861           || ((dest_tree = ffesymbol_hook (ffebld_symter (dest)).decl_tree)
10862               && (TREE_CODE (dest_tree) != VAR_DECL
10863                   || TREE_ADDRESSABLE (dest_tree))))
10864         {
10865           ffecom_prepare_expr_ (source, dest);
10866           dest_used = TRUE;
10867         }
10868       else
10869         {
10870           ffecom_prepare_expr_ (source, NULL);
10871           dest_used = FALSE;
10872         }
10873
10874       ffecom_prepare_expr_w (NULL_TREE, dest);
10875
10876       /* For COMPLEX assignment like C1=C2, if partial overlap is possible,
10877          create a temporary through which the assignment is to take place,
10878          since MODIFY_EXPR doesn't handle partial overlap properly.  */
10879       if (ffebld_basictype (dest) == FFEINFO_basictypeCOMPLEX
10880           && ffecom_possible_partial_overlap_ (dest, source))
10881         {
10882           assign_temp = ffecom_make_tempvar ("complex_let",
10883                                              ffecom_tree_type
10884                                              [ffebld_basictype (dest)]
10885                                              [ffebld_kindtype (dest)],
10886                                              FFETARGET_charactersizeNONE,
10887                                              -1);
10888         }
10889       else
10890         assign_temp = NULL_TREE;
10891
10892       ffecom_prepare_end ();
10893
10894       dest_tree = ffecom_expr_w (NULL_TREE, dest);
10895       if (dest_tree == error_mark_node)
10896         return;
10897
10898       if ((TREE_CODE (dest_tree) != VAR_DECL)
10899           || TREE_ADDRESSABLE (dest_tree))
10900         source_tree = ffecom_expr_ (source, dest_tree, dest, &dest_used,
10901                                     FALSE, FALSE);
10902       else
10903         {
10904           assert (! dest_used);
10905           dest_used = FALSE;
10906           source_tree = ffecom_expr (source);
10907         }
10908       if (source_tree == error_mark_node)
10909         return;
10910
10911       if (dest_used)
10912         expr_tree = source_tree;
10913       else if (assign_temp)
10914         {
10915 #ifdef MOVE_EXPR
10916           /* The back end understands a conceptual move (evaluate source;
10917              store into dest), so use that, in case it can determine
10918              that it is going to use, say, two registers as temporaries
10919              anyway.  So don't use the temp (and someday avoid generating
10920              it, once this code starts triggering regularly).  */
10921           expr_tree = ffecom_2s (MOVE_EXPR, void_type_node,
10922                                  dest_tree,
10923                                  source_tree);
10924 #else
10925           expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
10926                                  assign_temp,
10927                                  source_tree);
10928           expand_expr_stmt (expr_tree);
10929           expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
10930                                  dest_tree,
10931                                  assign_temp);
10932 #endif
10933         }
10934       else
10935         expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
10936                                dest_tree,
10937                                source_tree);
10938
10939       expand_expr_stmt (expr_tree);
10940       return;
10941     }
10942
10943   ffecom_prepare_let_char_ (ffebld_size_known (dest), source);
10944   ffecom_prepare_expr_w (NULL_TREE, dest);
10945
10946   ffecom_prepare_end ();
10947
10948   ffecom_char_args_ (&dest_tree, &dest_length, dest);
10949   ffecom_let_char_ (dest_tree, dest_length, ffebld_size_known (dest),
10950                     source);
10951 }
10952
10953 /* ffecom_expr -- Transform expr into gcc tree
10954
10955    tree t;
10956    ffebld expr;  // FFE expression.
10957    tree = ffecom_expr(expr);
10958
10959    Recursive descent on expr while making corresponding tree nodes and
10960    attaching type info and such.  */
10961
10962 tree
10963 ffecom_expr (ffebld expr)
10964 {
10965   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, FALSE, FALSE);
10966 }
10967
10968 /* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT.  */
10969
10970 tree
10971 ffecom_expr_assign (ffebld expr)
10972 {
10973   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
10974 }
10975
10976 /* Like ffecom_expr_rw, but return tree usable for ASSIGN.  */
10977
10978 tree
10979 ffecom_expr_assign_w (ffebld expr)
10980 {
10981   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
10982 }
10983
10984 /* Transform expr for use as into read/write tree and stabilize the
10985    reference.  Not for use on CHARACTER expressions.
10986
10987    Recursive descent on expr while making corresponding tree nodes and
10988    attaching type info and such.  */
10989
10990 tree
10991 ffecom_expr_rw (tree type, ffebld expr)
10992 {
10993   assert (expr != NULL);
10994   /* Different target types not yet supported.  */
10995   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
10996
10997   return stabilize_reference (ffecom_expr (expr));
10998 }
10999
11000 /* Transform expr for use as into write tree and stabilize the
11001    reference.  Not for use on CHARACTER expressions.
11002
11003    Recursive descent on expr while making corresponding tree nodes and
11004    attaching type info and such.  */
11005
11006 tree
11007 ffecom_expr_w (tree type, ffebld expr)
11008 {
11009   assert (expr != NULL);
11010   /* Different target types not yet supported.  */
11011   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
11012
11013   return stabilize_reference (ffecom_expr (expr));
11014 }
11015
11016 /* Do global stuff.  */
11017
11018 void
11019 ffecom_finish_compile ()
11020 {
11021   assert (ffecom_outer_function_decl_ == NULL_TREE);
11022   assert (current_function_decl == NULL_TREE);
11023
11024   ffeglobal_drive (ffecom_finish_global_);
11025 }
11026
11027 /* Public entry point for front end to access finish_decl.  */
11028
11029 void
11030 ffecom_finish_decl (tree decl, tree init, bool is_top_level)
11031 {
11032   assert (!is_top_level);
11033   finish_decl (decl, init, FALSE);
11034 }
11035
11036 /* Finish a program unit.  */
11037
11038 void
11039 ffecom_finish_progunit ()
11040 {
11041   ffecom_end_compstmt ();
11042
11043   ffecom_previous_function_decl_ = current_function_decl;
11044   ffecom_which_entrypoint_decl_ = NULL_TREE;
11045
11046   finish_function (0);
11047 }
11048
11049 /* Wrapper for get_identifier.  pattern is sprintf-like.  */
11050
11051 tree
11052 ffecom_get_invented_identifier (const char *pattern, ...)
11053 {
11054   tree decl;
11055   char *nam;
11056   va_list ap;
11057
11058   va_start (ap, pattern);
11059   if (vasprintf (&nam, pattern, ap) == 0)
11060     abort ();
11061   va_end (ap);
11062   decl = get_identifier (nam);
11063   free (nam);
11064   IDENTIFIER_INVENTED (decl) = 1;
11065   return decl;
11066 }
11067
11068 ffeinfoBasictype
11069 ffecom_gfrt_basictype (ffecomGfrt gfrt)
11070 {
11071   assert (gfrt < FFECOM_gfrt);
11072
11073   switch (ffecom_gfrt_type_[gfrt])
11074     {
11075     case FFECOM_rttypeVOID_:
11076     case FFECOM_rttypeVOIDSTAR_:
11077       return FFEINFO_basictypeNONE;
11078
11079     case FFECOM_rttypeFTNINT_:
11080       return FFEINFO_basictypeINTEGER;
11081
11082     case FFECOM_rttypeINTEGER_:
11083       return FFEINFO_basictypeINTEGER;
11084
11085     case FFECOM_rttypeLONGINT_:
11086       return FFEINFO_basictypeINTEGER;
11087
11088     case FFECOM_rttypeLOGICAL_:
11089       return FFEINFO_basictypeLOGICAL;
11090
11091     case FFECOM_rttypeREAL_F2C_:
11092     case FFECOM_rttypeREAL_GNU_:
11093       return FFEINFO_basictypeREAL;
11094
11095     case FFECOM_rttypeCOMPLEX_F2C_:
11096     case FFECOM_rttypeCOMPLEX_GNU_:
11097       return FFEINFO_basictypeCOMPLEX;
11098
11099     case FFECOM_rttypeDOUBLE_:
11100     case FFECOM_rttypeDOUBLEREAL_:
11101       return FFEINFO_basictypeREAL;
11102
11103     case FFECOM_rttypeDBLCMPLX_F2C_:
11104     case FFECOM_rttypeDBLCMPLX_GNU_:
11105       return FFEINFO_basictypeCOMPLEX;
11106
11107     case FFECOM_rttypeCHARACTER_:
11108       return FFEINFO_basictypeCHARACTER;
11109
11110     default:
11111       return FFEINFO_basictypeANY;
11112     }
11113 }
11114
11115 ffeinfoKindtype
11116 ffecom_gfrt_kindtype (ffecomGfrt gfrt)
11117 {
11118   assert (gfrt < FFECOM_gfrt);
11119
11120   switch (ffecom_gfrt_type_[gfrt])
11121     {
11122     case FFECOM_rttypeVOID_:
11123     case FFECOM_rttypeVOIDSTAR_:
11124       return FFEINFO_kindtypeNONE;
11125
11126     case FFECOM_rttypeFTNINT_:
11127       return FFEINFO_kindtypeINTEGER1;
11128
11129     case FFECOM_rttypeINTEGER_:
11130       return FFEINFO_kindtypeINTEGER1;
11131
11132     case FFECOM_rttypeLONGINT_:
11133       return FFEINFO_kindtypeINTEGER4;
11134
11135     case FFECOM_rttypeLOGICAL_:
11136       return FFEINFO_kindtypeLOGICAL1;
11137
11138     case FFECOM_rttypeREAL_F2C_:
11139     case FFECOM_rttypeREAL_GNU_:
11140       return FFEINFO_kindtypeREAL1;
11141
11142     case FFECOM_rttypeCOMPLEX_F2C_:
11143     case FFECOM_rttypeCOMPLEX_GNU_:
11144       return FFEINFO_kindtypeREAL1;
11145
11146     case FFECOM_rttypeDOUBLE_:
11147     case FFECOM_rttypeDOUBLEREAL_:
11148       return FFEINFO_kindtypeREAL2;
11149
11150     case FFECOM_rttypeDBLCMPLX_F2C_:
11151     case FFECOM_rttypeDBLCMPLX_GNU_:
11152       return FFEINFO_kindtypeREAL2;
11153
11154     case FFECOM_rttypeCHARACTER_:
11155       return FFEINFO_kindtypeCHARACTER1;
11156
11157     default:
11158       return FFEINFO_kindtypeANY;
11159     }
11160 }
11161
11162 void
11163 ffecom_init_0 ()
11164 {
11165   tree endlink;
11166   int i;
11167   int j;
11168   tree t;
11169   tree field;
11170   ffetype type;
11171   ffetype base_type;
11172   tree double_ftype_double;
11173   tree float_ftype_float;
11174   tree ldouble_ftype_ldouble;
11175   tree ffecom_tree_ptr_to_fun_type_void;
11176
11177   /* This block of code comes from the now-obsolete cktyps.c.  It checks
11178      whether the compiler environment is buggy in known ways, some of which
11179      would, if not explicitly checked here, result in subtle bugs in g77.  */
11180
11181   if (ffe_is_do_internal_checks ())
11182     {
11183       static const char names[][12]
11184         =
11185       {"bar", "bletch", "foo", "foobar"};
11186       const char *name;
11187       unsigned long ul;
11188       double fl;
11189
11190       name = bsearch ("foo", &names[0], ARRAY_SIZE (names), sizeof (names[0]),
11191                       (int (*)(const void *, const void *)) strcmp);
11192       if (name != &names[0][2])
11193         {
11194           assert ("bsearch doesn't work, #define FFEPROJ_BSEARCH 0 in proj.h"
11195                   == NULL);
11196           abort ();
11197         }
11198
11199       ul = strtoul ("123456789", NULL, 10);
11200       if (ul != 123456789L)
11201         {
11202           assert ("strtoul doesn't have enough range, #define FFEPROJ_STRTOUL 0\
11203  in proj.h" == NULL);
11204           abort ();
11205         }
11206
11207       fl = atof ("56.789");
11208       if ((fl < 56.788) || (fl > 56.79))
11209         {
11210           assert ("atof not type double, fix your #include <stdio.h>"
11211                   == NULL);
11212           abort ();
11213         }
11214     }
11215
11216   ffecom_outer_function_decl_ = NULL_TREE;
11217   current_function_decl = NULL_TREE;
11218   named_labels = NULL_TREE;
11219   current_binding_level = NULL_BINDING_LEVEL;
11220   free_binding_level = NULL_BINDING_LEVEL;
11221   /* Make the binding_level structure for global names.  */
11222   pushlevel (0);
11223   global_binding_level = current_binding_level;
11224   current_binding_level->prep_state = 2;
11225
11226   build_common_tree_nodes (1);
11227
11228   /* Define `int' and `char' first so that dbx will output them first.  */
11229   pushdecl (build_decl (TYPE_DECL, get_identifier ("int"),
11230                         integer_type_node));
11231   /* CHARACTER*1 is unsigned in ICHAR contexts.  */
11232   char_type_node = make_unsigned_type (CHAR_TYPE_SIZE);
11233   pushdecl (build_decl (TYPE_DECL, get_identifier ("char"),
11234                         char_type_node));
11235   pushdecl (build_decl (TYPE_DECL, get_identifier ("long int"),
11236                         long_integer_type_node));
11237   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned int"),
11238                         unsigned_type_node));
11239   pushdecl (build_decl (TYPE_DECL, get_identifier ("long unsigned int"),
11240                         long_unsigned_type_node));
11241   pushdecl (build_decl (TYPE_DECL, get_identifier ("long long int"),
11242                         long_long_integer_type_node));
11243   pushdecl (build_decl (TYPE_DECL, get_identifier ("long long unsigned int"),
11244                         long_long_unsigned_type_node));
11245   pushdecl (build_decl (TYPE_DECL, get_identifier ("short int"),
11246                         short_integer_type_node));
11247   pushdecl (build_decl (TYPE_DECL, get_identifier ("short unsigned int"),
11248                         short_unsigned_type_node));
11249
11250   /* Set the sizetype before we make other types.  This *should* be the
11251      first type we create.  */
11252
11253   set_sizetype
11254     (TREE_TYPE (IDENTIFIER_GLOBAL_VALUE (get_identifier (SIZE_TYPE))));
11255   ffecom_typesize_pointer_
11256     = TREE_INT_CST_LOW (TYPE_SIZE (sizetype)) / BITS_PER_UNIT;
11257
11258   build_common_tree_nodes_2 (0);
11259
11260   /* Define both `signed char' and `unsigned char'.  */
11261   pushdecl (build_decl (TYPE_DECL, get_identifier ("signed char"),
11262                         signed_char_type_node));
11263
11264   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned char"),
11265                         unsigned_char_type_node));
11266
11267   pushdecl (build_decl (TYPE_DECL, get_identifier ("float"),
11268                         float_type_node));
11269   pushdecl (build_decl (TYPE_DECL, get_identifier ("double"),
11270                         double_type_node));
11271   pushdecl (build_decl (TYPE_DECL, get_identifier ("long double"),
11272                         long_double_type_node));
11273
11274   /* For now, override what build_common_tree_nodes has done.  */
11275   complex_integer_type_node = ffecom_make_complex_type_ (integer_type_node);
11276   complex_float_type_node = ffecom_make_complex_type_ (float_type_node);
11277   complex_double_type_node = ffecom_make_complex_type_ (double_type_node);
11278   complex_long_double_type_node
11279     = ffecom_make_complex_type_ (long_double_type_node);
11280
11281   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex int"),
11282                         complex_integer_type_node));
11283   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex float"),
11284                         complex_float_type_node));
11285   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex double"),
11286                         complex_double_type_node));
11287   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex long double"),
11288                         complex_long_double_type_node));
11289
11290   pushdecl (build_decl (TYPE_DECL, get_identifier ("void"),
11291                         void_type_node));
11292   /* We are not going to have real types in C with less than byte alignment,
11293      so we might as well not have any types that claim to have it.  */
11294   TYPE_ALIGN (void_type_node) = BITS_PER_UNIT;
11295   TYPE_USER_ALIGN (void_type_node) = 0;
11296
11297   string_type_node = build_pointer_type (char_type_node);
11298
11299   ffecom_tree_fun_type_void
11300     = build_function_type (void_type_node, NULL_TREE);
11301
11302   ffecom_tree_ptr_to_fun_type_void
11303     = build_pointer_type (ffecom_tree_fun_type_void);
11304
11305   endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE);
11306
11307   float_ftype_float
11308     = build_function_type (float_type_node,
11309                            tree_cons (NULL_TREE, float_type_node, endlink));
11310
11311   double_ftype_double
11312     = build_function_type (double_type_node,
11313                            tree_cons (NULL_TREE, double_type_node, endlink));
11314
11315   ldouble_ftype_ldouble
11316     = build_function_type (long_double_type_node,
11317                            tree_cons (NULL_TREE, long_double_type_node,
11318                                       endlink));
11319
11320   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11321     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11322       {
11323         ffecom_tree_type[i][j] = NULL_TREE;
11324         ffecom_tree_fun_type[i][j] = NULL_TREE;
11325         ffecom_tree_ptr_to_fun_type[i][j] = NULL_TREE;
11326         ffecom_f2c_typecode_[i][j] = -1;
11327       }
11328
11329   /* Set up standard g77 types.  Note that INTEGER and LOGICAL are set
11330      to size FLOAT_TYPE_SIZE because they have to be the same size as
11331      REAL, which also is FLOAT_TYPE_SIZE, according to the standard.
11332      Compiler options and other such stuff that change the ways these
11333      types are set should not affect this particular setup.  */
11334
11335   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1]
11336     = t = make_signed_type (FLOAT_TYPE_SIZE);
11337   pushdecl (build_decl (TYPE_DECL, get_identifier ("integer"),
11338                         t));
11339   type = ffetype_new ();
11340   base_type = type;
11341   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER1,
11342                     type);
11343   ffetype_set_ams (type,
11344                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11345                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11346   ffetype_set_star (base_type,
11347                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11348                     type);
11349   ffetype_set_kind (base_type, 1, type);
11350   ffecom_typesize_integer1_ = ffetype_size (type);
11351   assert (ffetype_size (type) == sizeof (ffetargetInteger1));
11352
11353   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER1]
11354     = t = make_unsigned_type (FLOAT_TYPE_SIZE); /* HOLLERITH means unsigned. */
11355   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned"),
11356                         t));
11357
11358   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER2]
11359     = t = make_signed_type (CHAR_TYPE_SIZE);
11360   pushdecl (build_decl (TYPE_DECL, get_identifier ("byte"),
11361                         t));
11362   type = ffetype_new ();
11363   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER2,
11364                     type);
11365   ffetype_set_ams (type,
11366                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11367                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11368   ffetype_set_star (base_type,
11369                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11370                     type);
11371   ffetype_set_kind (base_type, 3, type);
11372   assert (ffetype_size (type) == sizeof (ffetargetInteger2));
11373
11374   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER2]
11375     = t = make_unsigned_type (CHAR_TYPE_SIZE);
11376   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned byte"),
11377                         t));
11378
11379   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER3]
11380     = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11381   pushdecl (build_decl (TYPE_DECL, get_identifier ("word"),
11382                         t));
11383   type = ffetype_new ();
11384   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER3,
11385                     type);
11386   ffetype_set_ams (type,
11387                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11388                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11389   ffetype_set_star (base_type,
11390                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11391                     type);
11392   ffetype_set_kind (base_type, 6, type);
11393   assert (ffetype_size (type) == sizeof (ffetargetInteger3));
11394
11395   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER3]
11396     = t = make_unsigned_type (CHAR_TYPE_SIZE * 2);
11397   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned word"),
11398                         t));
11399
11400   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER4]
11401     = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11402   pushdecl (build_decl (TYPE_DECL, get_identifier ("integer4"),
11403                         t));
11404   type = ffetype_new ();
11405   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER4,
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, 2, type);
11414   assert (ffetype_size (type) == sizeof (ffetargetInteger4));
11415
11416   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER4]
11417     = t = make_unsigned_type (FLOAT_TYPE_SIZE * 2);
11418   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned4"),
11419                         t));
11420
11421 #if 0
11422   if (ffe_is_do_internal_checks ()
11423       && LONG_TYPE_SIZE != FLOAT_TYPE_SIZE
11424       && LONG_TYPE_SIZE != CHAR_TYPE_SIZE
11425       && LONG_TYPE_SIZE != SHORT_TYPE_SIZE
11426       && LONG_TYPE_SIZE != LONG_LONG_TYPE_SIZE)
11427     {
11428       fprintf (stderr, "Sorry, no g77 support for LONG_TYPE_SIZE (%d bits) yet.\n",
11429                LONG_TYPE_SIZE);
11430     }
11431 #endif
11432
11433   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL1]
11434     = t = make_signed_type (FLOAT_TYPE_SIZE);
11435   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical"),
11436                         t));
11437   type = ffetype_new ();
11438   base_type = type;
11439   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL1,
11440                     type);
11441   ffetype_set_ams (type,
11442                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11443                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11444   ffetype_set_star (base_type,
11445                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11446                     type);
11447   ffetype_set_kind (base_type, 1, type);
11448   assert (ffetype_size (type) == sizeof (ffetargetLogical1));
11449
11450   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL2]
11451     = t = make_signed_type (CHAR_TYPE_SIZE);
11452   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical2"),
11453                         t));
11454   type = ffetype_new ();
11455   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL2,
11456                     type);
11457   ffetype_set_ams (type,
11458                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11459                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11460   ffetype_set_star (base_type,
11461                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11462                     type);
11463   ffetype_set_kind (base_type, 3, type);
11464   assert (ffetype_size (type) == sizeof (ffetargetLogical2));
11465
11466   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL3]
11467     = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11468   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical3"),
11469                         t));
11470   type = ffetype_new ();
11471   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL3,
11472                     type);
11473   ffetype_set_ams (type,
11474                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11475                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11476   ffetype_set_star (base_type,
11477                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11478                     type);
11479   ffetype_set_kind (base_type, 6, type);
11480   assert (ffetype_size (type) == sizeof (ffetargetLogical3));
11481
11482   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL4]
11483     = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11484   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical4"),
11485                         t));
11486   type = ffetype_new ();
11487   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL4,
11488                     type);
11489   ffetype_set_ams (type,
11490                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11491                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11492   ffetype_set_star (base_type,
11493                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11494                     type);
11495   ffetype_set_kind (base_type, 2, type);
11496   assert (ffetype_size (type) == sizeof (ffetargetLogical4));
11497
11498   ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11499     = t = make_node (REAL_TYPE);
11500   TYPE_PRECISION (t) = FLOAT_TYPE_SIZE;
11501   pushdecl (build_decl (TYPE_DECL, get_identifier ("real"),
11502                         t));
11503   layout_type (t);
11504   type = ffetype_new ();
11505   base_type = type;
11506   ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL1,
11507                     type);
11508   ffetype_set_ams (type,
11509                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11510                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11511   ffetype_set_star (base_type,
11512                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11513                     type);
11514   ffetype_set_kind (base_type, 1, type);
11515   ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11516     = FFETARGET_f2cTYREAL;
11517   assert (ffetype_size (type) == sizeof (ffetargetReal1));
11518
11519   ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREALDOUBLE]
11520     = t = make_node (REAL_TYPE);
11521   TYPE_PRECISION (t) = FLOAT_TYPE_SIZE * 2;     /* Always twice REAL. */
11522   pushdecl (build_decl (TYPE_DECL, get_identifier ("double precision"),
11523                         t));
11524   layout_type (t);
11525   type = ffetype_new ();
11526   ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE,
11527                     type);
11528   ffetype_set_ams (type,
11529                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11530                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11531   ffetype_set_star (base_type,
11532                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11533                     type);
11534   ffetype_set_kind (base_type, 2, type);
11535   ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]
11536     = FFETARGET_f2cTYDREAL;
11537   assert (ffetype_size (type) == sizeof (ffetargetReal2));
11538
11539   ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11540     = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]);
11541   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex"),
11542                         t));
11543   type = ffetype_new ();
11544   base_type = type;
11545   ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL1,
11546                     type);
11547   ffetype_set_ams (type,
11548                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11549                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11550   ffetype_set_star (base_type,
11551                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11552                     type);
11553   ffetype_set_kind (base_type, 1, type);
11554   ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11555     = FFETARGET_f2cTYCOMPLEX;
11556   assert (ffetype_size (type) == sizeof (ffetargetComplex1));
11557
11558   ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREALDOUBLE]
11559     = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]);
11560   pushdecl (build_decl (TYPE_DECL, get_identifier ("double complex"),
11561                         t));
11562   type = ffetype_new ();
11563   ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREALDOUBLE,
11564                     type);
11565   ffetype_set_ams (type,
11566                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11567                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11568   ffetype_set_star (base_type,
11569                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11570                     type);
11571   ffetype_set_kind (base_type, 2,
11572                     type);
11573   ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL2]
11574     = FFETARGET_f2cTYDCOMPLEX;
11575   assert (ffetype_size (type) == sizeof (ffetargetComplex2));
11576
11577   /* Make function and ptr-to-function types for non-CHARACTER types. */
11578
11579   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11580     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11581       {
11582         if ((t = ffecom_tree_type[i][j]) != NULL_TREE)
11583           {
11584             if (i == FFEINFO_basictypeINTEGER)
11585               {
11586                 /* Figure out the smallest INTEGER type that can hold
11587                    a pointer on this machine. */
11588                 if (GET_MODE_SIZE (TYPE_MODE (t))
11589                     >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
11590                   {
11591                     if ((ffecom_pointer_kind_ == FFEINFO_kindtypeNONE)
11592                         || (GET_MODE_SIZE (TYPE_MODE (ffecom_tree_type[i][ffecom_pointer_kind_]))
11593                             > GET_MODE_SIZE (TYPE_MODE (t))))
11594                       ffecom_pointer_kind_ = j;
11595                   }
11596               }
11597             else if (i == FFEINFO_basictypeCOMPLEX)
11598               t = void_type_node;
11599             /* For f2c compatibility, REAL functions are really
11600                implemented as DOUBLE PRECISION.  */
11601             else if ((i == FFEINFO_basictypeREAL)
11602                      && (j == FFEINFO_kindtypeREAL1))
11603               t = ffecom_tree_type
11604                 [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2];
11605
11606             t = ffecom_tree_fun_type[i][j] = build_function_type (t,
11607                                                                   NULL_TREE);
11608             ffecom_tree_ptr_to_fun_type[i][j] = build_pointer_type (t);
11609           }
11610       }
11611
11612   /* Set up pointer types.  */
11613
11614   if (ffecom_pointer_kind_ == FFEINFO_basictypeNONE)
11615     fatal_error ("no INTEGER type can hold a pointer on this configuration");
11616   else if (0 && ffe_is_do_internal_checks ())
11617     fprintf (stderr, "Pointer type kt=%d\n", ffecom_pointer_kind_);
11618   ffetype_set_kind (ffeinfo_type (FFEINFO_basictypeINTEGER,
11619                                   FFEINFO_kindtypeINTEGERDEFAULT),
11620                     7,
11621                     ffeinfo_type (FFEINFO_basictypeINTEGER,
11622                                   ffecom_pointer_kind_));
11623
11624   if (ffe_is_ugly_assign ())
11625     ffecom_label_kind_ = ffecom_pointer_kind_;  /* Require ASSIGN etc to this. */
11626   else
11627     ffecom_label_kind_ = FFEINFO_kindtypeINTEGERDEFAULT;
11628   if (0 && ffe_is_do_internal_checks ())
11629     fprintf (stderr, "Label type kt=%d\n", ffecom_label_kind_);
11630
11631   ffecom_integer_type_node
11632     = ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1];
11633   ffecom_integer_zero_node = convert (ffecom_integer_type_node,
11634                                       integer_zero_node);
11635   ffecom_integer_one_node = convert (ffecom_integer_type_node,
11636                                      integer_one_node);
11637
11638   /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional.
11639      Turns out that by TYLONG, runtime/libI77/lio.h really means
11640      "whatever size an ftnint is".  For consistency and sanity,
11641      com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen
11642      all are INTEGER, which we also make out of whatever back-end
11643      integer type is FLOAT_TYPE_SIZE bits wide.  This change, from
11644      LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to
11645      accommodate machines like the Alpha.  Note that this suggests
11646      f2c and libf2c are missing a distinction perhaps needed on
11647      some machines between "int" and "long int".  -- burley 0.5.5 950215 */
11648
11649   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, FLOAT_TYPE_SIZE,
11650                             FFETARGET_f2cTYLONG);
11651   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, SHORT_TYPE_SIZE,
11652                             FFETARGET_f2cTYSHORT);
11653   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, CHAR_TYPE_SIZE,
11654                             FFETARGET_f2cTYINT1);
11655   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, LONG_LONG_TYPE_SIZE,
11656                             FFETARGET_f2cTYQUAD);
11657   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, FLOAT_TYPE_SIZE,
11658                             FFETARGET_f2cTYLOGICAL);
11659   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, SHORT_TYPE_SIZE,
11660                             FFETARGET_f2cTYLOGICAL2);
11661   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, CHAR_TYPE_SIZE,
11662                             FFETARGET_f2cTYLOGICAL1);
11663   /* ~~~Not really such a type in libf2c, e.g. I/O support?  */
11664   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, LONG_LONG_TYPE_SIZE,
11665                             FFETARGET_f2cTYQUAD);
11666
11667   /* CHARACTER stuff is all special-cased, so it is not handled in the above
11668      loop.  CHARACTER items are built as arrays of unsigned char.  */
11669
11670   ffecom_tree_type[FFEINFO_basictypeCHARACTER]
11671     [FFEINFO_kindtypeCHARACTER1] = t = char_type_node;
11672   type = ffetype_new ();
11673   base_type = type;
11674   ffeinfo_set_type (FFEINFO_basictypeCHARACTER,
11675                     FFEINFO_kindtypeCHARACTER1,
11676                     type);
11677   ffetype_set_ams (type,
11678                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11679                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11680   ffetype_set_kind (base_type, 1, type);
11681   assert (ffetype_size (type)
11682           == sizeof (((ffetargetCharacter1) { 0, NULL }).text[0]));
11683
11684   ffecom_tree_fun_type[FFEINFO_basictypeCHARACTER]
11685     [FFEINFO_kindtypeCHARACTER1] = ffecom_tree_fun_type_void;
11686   ffecom_tree_ptr_to_fun_type[FFEINFO_basictypeCHARACTER]
11687     [FFEINFO_kindtypeCHARACTER1]
11688     = ffecom_tree_ptr_to_fun_type_void;
11689   ffecom_f2c_typecode_[FFEINFO_basictypeCHARACTER][FFEINFO_kindtypeCHARACTER1]
11690     = FFETARGET_f2cTYCHAR;
11691
11692   ffecom_f2c_typecode_[FFEINFO_basictypeANY][FFEINFO_kindtypeANY]
11693     = 0;
11694
11695   /* Make multi-return-value type and fields. */
11696
11697   ffecom_multi_type_node_ = make_node (UNION_TYPE);
11698
11699   field = NULL_TREE;
11700
11701   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11702     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11703       {
11704         char name[30];
11705
11706         if (ffecom_tree_type[i][j] == NULL_TREE)
11707           continue;             /* Not supported. */
11708         sprintf (&name[0], "bt_%s_kt_%s",
11709                  ffeinfo_basictype_string ((ffeinfoBasictype) i),
11710                  ffeinfo_kindtype_string ((ffeinfoKindtype) j));
11711         ffecom_multi_fields_[i][j] = build_decl (FIELD_DECL,
11712                                                  get_identifier (name),
11713                                                  ffecom_tree_type[i][j]);
11714         DECL_CONTEXT (ffecom_multi_fields_[i][j])
11715           = ffecom_multi_type_node_;
11716         DECL_ALIGN (ffecom_multi_fields_[i][j]) = 0;
11717         DECL_USER_ALIGN (ffecom_multi_fields_[i][j]) = 0;
11718         TREE_CHAIN (ffecom_multi_fields_[i][j]) = field;
11719         field = ffecom_multi_fields_[i][j];
11720       }
11721
11722   TYPE_FIELDS (ffecom_multi_type_node_) = field;
11723   layout_type (ffecom_multi_type_node_);
11724
11725   /* Subroutines usually return integer because they might have alternate
11726      returns. */
11727
11728   ffecom_tree_subr_type
11729     = build_function_type (integer_type_node, NULL_TREE);
11730   ffecom_tree_ptr_to_subr_type
11731     = build_pointer_type (ffecom_tree_subr_type);
11732   ffecom_tree_blockdata_type
11733     = build_function_type (void_type_node, NULL_TREE);
11734
11735   builtin_function ("__builtin_sqrtf", float_ftype_float,
11736                     BUILT_IN_SQRTF, BUILT_IN_NORMAL, "sqrtf");
11737   builtin_function ("__builtin_sqrt", double_ftype_double,
11738                     BUILT_IN_SQRT, BUILT_IN_NORMAL, "sqrt");
11739   builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble,
11740                     BUILT_IN_SQRTL, BUILT_IN_NORMAL, "sqrtl");
11741   builtin_function ("__builtin_sinf", float_ftype_float,
11742                     BUILT_IN_SINF, BUILT_IN_NORMAL, "sinf");
11743   builtin_function ("__builtin_sin", double_ftype_double,
11744                     BUILT_IN_SIN, BUILT_IN_NORMAL, "sin");
11745   builtin_function ("__builtin_sinl", ldouble_ftype_ldouble,
11746                     BUILT_IN_SINL, BUILT_IN_NORMAL, "sinl");
11747   builtin_function ("__builtin_cosf", float_ftype_float,
11748                     BUILT_IN_COSF, BUILT_IN_NORMAL, "cosf");
11749   builtin_function ("__builtin_cos", double_ftype_double,
11750                     BUILT_IN_COS, BUILT_IN_NORMAL, "cos");
11751   builtin_function ("__builtin_cosl", ldouble_ftype_ldouble,
11752                     BUILT_IN_COSL, BUILT_IN_NORMAL, "cosl");
11753
11754   pedantic_lvalues = FALSE;
11755
11756   ffecom_f2c_make_type_ (&ffecom_f2c_integer_type_node,
11757                          FFECOM_f2cINTEGER,
11758                          "integer");
11759   ffecom_f2c_make_type_ (&ffecom_f2c_address_type_node,
11760                          FFECOM_f2cADDRESS,
11761                          "address");
11762   ffecom_f2c_make_type_ (&ffecom_f2c_real_type_node,
11763                          FFECOM_f2cREAL,
11764                          "real");
11765   ffecom_f2c_make_type_ (&ffecom_f2c_doublereal_type_node,
11766                          FFECOM_f2cDOUBLEREAL,
11767                          "doublereal");
11768   ffecom_f2c_make_type_ (&ffecom_f2c_complex_type_node,
11769                          FFECOM_f2cCOMPLEX,
11770                          "complex");
11771   ffecom_f2c_make_type_ (&ffecom_f2c_doublecomplex_type_node,
11772                          FFECOM_f2cDOUBLECOMPLEX,
11773                          "doublecomplex");
11774   ffecom_f2c_make_type_ (&ffecom_f2c_longint_type_node,
11775                          FFECOM_f2cLONGINT,
11776                          "longint");
11777   ffecom_f2c_make_type_ (&ffecom_f2c_logical_type_node,
11778                          FFECOM_f2cLOGICAL,
11779                          "logical");
11780   ffecom_f2c_make_type_ (&ffecom_f2c_flag_type_node,
11781                          FFECOM_f2cFLAG,
11782                          "flag");
11783   ffecom_f2c_make_type_ (&ffecom_f2c_ftnlen_type_node,
11784                          FFECOM_f2cFTNLEN,
11785                          "ftnlen");
11786   ffecom_f2c_make_type_ (&ffecom_f2c_ftnint_type_node,
11787                          FFECOM_f2cFTNINT,
11788                          "ftnint");
11789
11790   ffecom_f2c_ftnlen_zero_node
11791     = convert (ffecom_f2c_ftnlen_type_node, integer_zero_node);
11792
11793   ffecom_f2c_ftnlen_one_node
11794     = convert (ffecom_f2c_ftnlen_type_node, integer_one_node);
11795
11796   ffecom_f2c_ftnlen_two_node = build_int_2 (2, 0);
11797   TREE_TYPE (ffecom_f2c_ftnlen_two_node) = ffecom_integer_type_node;
11798
11799   ffecom_f2c_ptr_to_ftnlen_type_node
11800     = build_pointer_type (ffecom_f2c_ftnlen_type_node);
11801
11802   ffecom_f2c_ptr_to_ftnint_type_node
11803     = build_pointer_type (ffecom_f2c_ftnint_type_node);
11804
11805   ffecom_f2c_ptr_to_integer_type_node
11806     = build_pointer_type (ffecom_f2c_integer_type_node);
11807
11808   ffecom_f2c_ptr_to_real_type_node
11809     = build_pointer_type (ffecom_f2c_real_type_node);
11810
11811   ffecom_float_zero_ = build_real (float_type_node, dconst0);
11812   ffecom_double_zero_ = build_real (double_type_node, dconst0);
11813   {
11814     REAL_VALUE_TYPE point_5;
11815
11816     REAL_ARITHMETIC (point_5, RDIV_EXPR, dconst1, dconst2);
11817     ffecom_float_half_ = build_real (float_type_node, point_5);
11818     ffecom_double_half_ = build_real (double_type_node, point_5);
11819   }
11820
11821   /* Do "extern int xargc;".  */
11822
11823   ffecom_tree_xargc_ = build_decl (VAR_DECL,
11824                                    get_identifier ("f__xargc"),
11825                                    integer_type_node);
11826   DECL_EXTERNAL (ffecom_tree_xargc_) = 1;
11827   TREE_STATIC (ffecom_tree_xargc_) = 1;
11828   TREE_PUBLIC (ffecom_tree_xargc_) = 1;
11829   ffecom_tree_xargc_ = start_decl (ffecom_tree_xargc_, FALSE);
11830   finish_decl (ffecom_tree_xargc_, NULL_TREE, FALSE);
11831
11832 #if 0   /* This is being fixed, and seems to be working now. */
11833   if ((FLOAT_TYPE_SIZE != 32)
11834       || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))) != 32))
11835     {
11836       warning ("configuration: REAL, INTEGER, and LOGICAL are %d bits wide,",
11837                (int) FLOAT_TYPE_SIZE);
11838       warning ("and pointers are %d bits wide, but g77 doesn't yet work",
11839           (int) TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))));
11840       warning ("properly unless they all are 32 bits wide");
11841       warning ("Please keep this in mind before you report bugs.");
11842     }
11843 #endif
11844
11845 #if 0   /* Code in ste.c that would crash has been commented out. */
11846   if (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)
11847       < TYPE_PRECISION (string_type_node))
11848     /* I/O will probably crash.  */
11849     warning ("configuration: char * holds %d bits, but ftnlen only %d",
11850              TYPE_PRECISION (string_type_node),
11851              TYPE_PRECISION (ffecom_f2c_ftnlen_type_node));
11852 #endif
11853
11854 #if 0   /* ASSIGN-related stuff has been changed to accommodate this. */
11855   if (TYPE_PRECISION (ffecom_integer_type_node)
11856       < TYPE_PRECISION (string_type_node))
11857     /* ASSIGN 10 TO I will crash.  */
11858     warning ("configuration: char * holds %d bits, but INTEGER only %d --\n\
11859  ASSIGN statement might fail",
11860              TYPE_PRECISION (string_type_node),
11861              TYPE_PRECISION (ffecom_integer_type_node));
11862 #endif
11863 }
11864
11865 /* ffecom_init_2 -- Initialize
11866
11867    ffecom_init_2();  */
11868
11869 void
11870 ffecom_init_2 ()
11871 {
11872   assert (ffecom_outer_function_decl_ == NULL_TREE);
11873   assert (current_function_decl == NULL_TREE);
11874   assert (ffecom_which_entrypoint_decl_ == NULL_TREE);
11875
11876   ffecom_master_arglist_ = NULL;
11877   ++ffecom_num_fns_;
11878   ffecom_primary_entry_ = NULL;
11879   ffecom_is_altreturning_ = FALSE;
11880   ffecom_func_result_ = NULL_TREE;
11881   ffecom_multi_retval_ = NULL_TREE;
11882 }
11883
11884 /* ffecom_list_expr -- Transform list of exprs into gcc tree
11885
11886    tree t;
11887    ffebld expr;  // FFE opITEM list.
11888    tree = ffecom_list_expr(expr);
11889
11890    List of actual args is transformed into corresponding gcc backend list.  */
11891
11892 tree
11893 ffecom_list_expr (ffebld expr)
11894 {
11895   tree list;
11896   tree *plist = &list;
11897   tree trail = NULL_TREE;       /* Append char length args here. */
11898   tree *ptrail = &trail;
11899   tree length;
11900
11901   while (expr != NULL)
11902     {
11903       tree texpr = ffecom_arg_expr (ffebld_head (expr), &length);
11904
11905       if (texpr == error_mark_node)
11906         return error_mark_node;
11907
11908       *plist = build_tree_list (NULL_TREE, texpr);
11909       plist = &TREE_CHAIN (*plist);
11910       expr = ffebld_trail (expr);
11911       if (length != NULL_TREE)
11912         {
11913           *ptrail = build_tree_list (NULL_TREE, length);
11914           ptrail = &TREE_CHAIN (*ptrail);
11915         }
11916     }
11917
11918   *plist = trail;
11919
11920   return list;
11921 }
11922
11923 /* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree
11924
11925    tree t;
11926    ffebld expr;  // FFE opITEM list.
11927    tree = ffecom_list_ptr_to_expr(expr);
11928
11929    List of actual args is transformed into corresponding gcc backend list for
11930    use in calling an external procedure (vs. a statement function).  */
11931
11932 tree
11933 ffecom_list_ptr_to_expr (ffebld expr)
11934 {
11935   tree list;
11936   tree *plist = &list;
11937   tree trail = NULL_TREE;       /* Append char length args here. */
11938   tree *ptrail = &trail;
11939   tree length;
11940
11941   while (expr != NULL)
11942     {
11943       tree texpr = ffecom_arg_ptr_to_expr (ffebld_head (expr), &length);
11944
11945       if (texpr == error_mark_node)
11946         return error_mark_node;
11947
11948       *plist = build_tree_list (NULL_TREE, texpr);
11949       plist = &TREE_CHAIN (*plist);
11950       expr = ffebld_trail (expr);
11951       if (length != NULL_TREE)
11952         {
11953           *ptrail = build_tree_list (NULL_TREE, length);
11954           ptrail = &TREE_CHAIN (*ptrail);
11955         }
11956     }
11957
11958   *plist = trail;
11959
11960   return list;
11961 }
11962
11963 /* Obtain gcc's LABEL_DECL tree for label.  */
11964
11965 tree
11966 ffecom_lookup_label (ffelab label)
11967 {
11968   tree glabel;
11969
11970   if (ffelab_hook (label) == NULL_TREE)
11971     {
11972       char labelname[16];
11973
11974       switch (ffelab_type (label))
11975         {
11976         case FFELAB_typeLOOPEND:
11977         case FFELAB_typeNOTLOOP:
11978         case FFELAB_typeENDIF:
11979           sprintf (labelname, "%" ffelabValue_f "u", ffelab_value (label));
11980           glabel = build_decl (LABEL_DECL, get_identifier (labelname),
11981                                void_type_node);
11982           DECL_CONTEXT (glabel) = current_function_decl;
11983           DECL_MODE (glabel) = VOIDmode;
11984           break;
11985
11986         case FFELAB_typeFORMAT:
11987           glabel = build_decl (VAR_DECL,
11988                                ffecom_get_invented_identifier
11989                                ("__g77_format_%d", (int) ffelab_value (label)),
11990                                build_type_variant (build_array_type
11991                                                    (char_type_node,
11992                                                     NULL_TREE),
11993                                                    1, 0));
11994           TREE_CONSTANT (glabel) = 1;
11995           TREE_STATIC (glabel) = 1;
11996           DECL_CONTEXT (glabel) = current_function_decl;
11997           DECL_INITIAL (glabel) = NULL;
11998           make_decl_rtl (glabel, NULL);
11999           expand_decl (glabel);
12000
12001           ffecom_save_tree_forever (glabel);
12002
12003           break;
12004
12005         case FFELAB_typeANY:
12006           glabel = error_mark_node;
12007           break;
12008
12009         default:
12010           assert ("bad label type" == NULL);
12011           glabel = NULL;
12012           break;
12013         }
12014       ffelab_set_hook (label, glabel);
12015     }
12016   else
12017     {
12018       glabel = ffelab_hook (label);
12019     }
12020
12021   return glabel;
12022 }
12023
12024 /* Stabilizes the arguments.  Don't use this if the lhs and rhs come from
12025    a single source specification (as in the fourth argument of MVBITS).
12026    If the type is NULL_TREE, the type of lhs is used to make the type of
12027    the MODIFY_EXPR.  */
12028
12029 tree
12030 ffecom_modify (tree newtype, tree lhs,
12031                tree rhs)
12032 {
12033   if (lhs == error_mark_node || rhs == error_mark_node)
12034     return error_mark_node;
12035
12036   if (newtype == NULL_TREE)
12037     newtype = TREE_TYPE (lhs);
12038
12039   if (TREE_SIDE_EFFECTS (lhs))
12040     lhs = stabilize_reference (lhs);
12041
12042   return ffecom_2s (MODIFY_EXPR, newtype, lhs, rhs);
12043 }
12044
12045 /* Register source file name.  */
12046
12047 void
12048 ffecom_file (const char *name)
12049 {
12050   ffecom_file_ (name);
12051 }
12052
12053 /* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed
12054
12055    ffestorag st;
12056    ffecom_notify_init_storage(st);
12057
12058    Gets called when all possible units in an aggregate storage area (a LOCAL
12059    with equivalences or a COMMON) have been initialized.  The initialization
12060    info either is in ffestorag_init or, if that is NULL,
12061    ffestorag_accretion:
12062
12063    ffestorag_init may contain an opCONTER or opARRTER.  opCONTER may occur
12064    even for an array if the array is one element in length!
12065
12066    ffestorag_accretion will contain an opACCTER.  It is much like an
12067    opARRTER except it has an ffebit object in it instead of just a size.
12068    The back end can use the info in the ffebit object, if it wants, to
12069    reduce the amount of actual initialization, but in any case it should
12070    kill the ffebit object when done.  Also, set accretion to NULL but
12071    init to a non-NULL value.
12072
12073    After performing initialization, DO NOT set init to NULL, because that'll
12074    tell the front end it is ok for more initialization to happen.  Instead,
12075    set init to an opANY expression or some such thing that you can use to
12076    tell that you've already initialized the object.
12077
12078    27-Oct-91  JCB  1.1
12079       Support two-pass FFE.  */
12080
12081 void
12082 ffecom_notify_init_storage (ffestorag st)
12083 {
12084   ffebld init;                  /* The initialization expression. */
12085
12086   if (ffestorag_init (st) == NULL)
12087     {
12088       init = ffestorag_accretion (st);
12089       assert (init != NULL);
12090       ffestorag_set_accretion (st, NULL);
12091       ffestorag_set_accretes (st, 0);
12092       ffestorag_set_init (st, init);
12093     }
12094 }
12095
12096 /* ffecom_notify_init_symbol -- A symbol is now fully init'ed
12097
12098    ffesymbol s;
12099    ffecom_notify_init_symbol(s);
12100
12101    Gets called when all possible units in a symbol (not placed in COMMON
12102    or involved in EQUIVALENCE, unless it as yet has no ffestorag object)
12103    have been initialized.  The initialization info either is in
12104    ffesymbol_init or, if that is NULL, ffesymbol_accretion:
12105
12106    ffesymbol_init may contain an opCONTER or opARRTER.  opCONTER may occur
12107    even for an array if the array is one element in length!
12108
12109    ffesymbol_accretion will contain an opACCTER.  It is much like an
12110    opARRTER except it has an ffebit object in it instead of just a size.
12111    The back end can use the info in the ffebit object, if it wants, to
12112    reduce the amount of actual initialization, but in any case it should
12113    kill the ffebit object when done.  Also, set accretion to NULL but
12114    init to a non-NULL value.
12115
12116    After performing initialization, DO NOT set init to NULL, because that'll
12117    tell the front end it is ok for more initialization to happen.  Instead,
12118    set init to an opANY expression or some such thing that you can use to
12119    tell that you've already initialized the object.
12120
12121    27-Oct-91  JCB  1.1
12122       Support two-pass FFE.  */
12123
12124 void
12125 ffecom_notify_init_symbol (ffesymbol s)
12126 {
12127   ffebld init;                  /* The initialization expression. */
12128
12129   if (ffesymbol_storage (s) == NULL)
12130     return;                     /* Do nothing until COMMON/EQUIVALENCE
12131                                    possibilities checked. */
12132
12133   if ((ffesymbol_init (s) == NULL)
12134       && ((init = ffesymbol_accretion (s)) != NULL))
12135     {
12136       ffesymbol_set_accretion (s, NULL);
12137       ffesymbol_set_accretes (s, 0);
12138       ffesymbol_set_init (s, init);
12139     }
12140 }
12141
12142 /* ffecom_notify_primary_entry -- Learn which is the primary entry point
12143
12144    ffesymbol s;
12145    ffecom_notify_primary_entry(s);
12146
12147    Gets called when implicit or explicit PROGRAM statement seen or when
12148    FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary
12149    global symbol that serves as the entry point.  */
12150
12151 void
12152 ffecom_notify_primary_entry (ffesymbol s)
12153 {
12154   ffecom_primary_entry_ = s;
12155   ffecom_primary_entry_kind_ = ffesymbol_kind (s);
12156
12157   if ((ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
12158       || (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE))
12159     ffecom_primary_entry_is_proc_ = TRUE;
12160   else
12161     ffecom_primary_entry_is_proc_ = FALSE;
12162
12163   if (!ffe_is_silent ())
12164     {
12165       if (ffecom_primary_entry_kind_ == FFEINFO_kindPROGRAM)
12166         fprintf (stderr, "%s:\n", ffesymbol_text (s));
12167       else
12168         fprintf (stderr, "  %s:\n", ffesymbol_text (s));
12169     }
12170
12171   if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
12172     {
12173       ffebld list;
12174       ffebld arg;
12175
12176       for (list = ffesymbol_dummyargs (s);
12177            list != NULL;
12178            list = ffebld_trail (list))
12179         {
12180           arg = ffebld_head (list);
12181           if (ffebld_op (arg) == FFEBLD_opSTAR)
12182             {
12183               ffecom_is_altreturning_ = TRUE;
12184               break;
12185             }
12186         }
12187     }
12188 }
12189
12190 FILE *
12191 ffecom_open_include (char *name, ffewhereLine l, ffewhereColumn c)
12192 {
12193   return ffecom_open_include_ (name, l, c);
12194 }
12195
12196 /* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front
12197
12198    tree t;
12199    ffebld expr;  // FFE expression.
12200    tree = ffecom_ptr_to_expr(expr);
12201
12202    Like ffecom_expr, but sticks address-of in front of most things.  */
12203
12204 tree
12205 ffecom_ptr_to_expr (ffebld expr)
12206 {
12207   tree item;
12208   ffeinfoBasictype bt;
12209   ffeinfoKindtype kt;
12210   ffesymbol s;
12211
12212   assert (expr != NULL);
12213
12214   switch (ffebld_op (expr))
12215     {
12216     case FFEBLD_opSYMTER:
12217       s = ffebld_symter (expr);
12218       if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
12219         {
12220           ffecomGfrt ix;
12221
12222           ix = ffeintrin_gfrt_indirect (ffebld_symter_implementation (expr));
12223           assert (ix != FFECOM_gfrt);
12224           if ((item = ffecom_gfrt_[ix]) == NULL_TREE)
12225             {
12226               ffecom_make_gfrt_ (ix);
12227               item = ffecom_gfrt_[ix];
12228             }
12229         }
12230       else
12231         {
12232           item = ffesymbol_hook (s).decl_tree;
12233           if (item == NULL_TREE)
12234             {
12235               s = ffecom_sym_transform_ (s);
12236               item = ffesymbol_hook (s).decl_tree;
12237             }
12238         }
12239       assert (item != NULL);
12240       if (item == error_mark_node)
12241         return item;
12242       if (!ffesymbol_hook (s).addr)
12243         item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12244                          item);
12245       return item;
12246
12247     case FFEBLD_opARRAYREF:
12248       return ffecom_arrayref_ (NULL_TREE, expr, 1);
12249
12250     case FFEBLD_opCONTER:
12251
12252       bt = ffeinfo_basictype (ffebld_info (expr));
12253       kt = ffeinfo_kindtype (ffebld_info (expr));
12254
12255       item = ffecom_constantunion (&ffebld_constant_union
12256                                    (ffebld_conter (expr)), bt, kt,
12257                                    ffecom_tree_type[bt][kt]);
12258       if (item == error_mark_node)
12259         return error_mark_node;
12260       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12261                        item);
12262       return item;
12263
12264     case FFEBLD_opANY:
12265       return error_mark_node;
12266
12267     default:
12268       bt = ffeinfo_basictype (ffebld_info (expr));
12269       kt = ffeinfo_kindtype (ffebld_info (expr));
12270
12271       item = ffecom_expr (expr);
12272       if (item == error_mark_node)
12273         return error_mark_node;
12274
12275       /* The back end currently optimizes a bit too zealously for us, in that
12276          we fail JCB001 if the following block of code is omitted.  It checks
12277          to see if the transformed expression is a symbol or array reference,
12278          and encloses it in a SAVE_EXPR if that is the case.  */
12279
12280       STRIP_NOPS (item);
12281       if ((TREE_CODE (item) == VAR_DECL)
12282           || (TREE_CODE (item) == PARM_DECL)
12283           || (TREE_CODE (item) == RESULT_DECL)
12284           || (TREE_CODE (item) == INDIRECT_REF)
12285           || (TREE_CODE (item) == ARRAY_REF)
12286           || (TREE_CODE (item) == COMPONENT_REF)
12287 #ifdef OFFSET_REF
12288           || (TREE_CODE (item) == OFFSET_REF)
12289 #endif
12290           || (TREE_CODE (item) == BUFFER_REF)
12291           || (TREE_CODE (item) == REALPART_EXPR)
12292           || (TREE_CODE (item) == IMAGPART_EXPR))
12293         {
12294           item = ffecom_save_tree (item);
12295         }
12296
12297       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12298                        item);
12299       return item;
12300     }
12301
12302   assert ("fall-through error" == NULL);
12303   return error_mark_node;
12304 }
12305
12306 /* Obtain a temp var with given data type.
12307
12308    size is FFETARGET_charactersizeNONE for a non-CHARACTER type
12309    or >= 0 for a CHARACTER type.
12310
12311    elements is -1 for a scalar or > 0 for an array of type.  */
12312
12313 tree
12314 ffecom_make_tempvar (const char *commentary, tree type,
12315                      ffetargetCharacterSize size, int elements)
12316 {
12317   tree t;
12318   static int mynumber;
12319
12320   assert (current_binding_level->prep_state < 2);
12321
12322   if (type == error_mark_node)
12323     return error_mark_node;
12324
12325   if (size != FFETARGET_charactersizeNONE)
12326     type = build_array_type (type,
12327                              build_range_type (ffecom_f2c_ftnlen_type_node,
12328                                                ffecom_f2c_ftnlen_one_node,
12329                                                build_int_2 (size, 0)));
12330   if (elements != -1)
12331     type = build_array_type (type,
12332                              build_range_type (integer_type_node,
12333                                                integer_zero_node,
12334                                                build_int_2 (elements - 1,
12335                                                             0)));
12336   t = build_decl (VAR_DECL,
12337                   ffecom_get_invented_identifier ("__g77_%s_%d",
12338                                                   commentary,
12339                                                   mynumber++),
12340                   type);
12341
12342   t = start_decl (t, FALSE);
12343   finish_decl (t, NULL_TREE, FALSE);
12344
12345   return t;
12346 }
12347
12348 /* Prepare argument pointer to expression.
12349
12350    Like ffecom_prepare_expr, except for expressions to be evaluated
12351    via ffecom_arg_ptr_to_expr.  */
12352
12353 void
12354 ffecom_prepare_arg_ptr_to_expr (ffebld expr)
12355 {
12356   /* ~~For now, it seems to be the same thing.  */
12357   ffecom_prepare_expr (expr);
12358   return;
12359 }
12360
12361 /* End of preparations.  */
12362
12363 bool
12364 ffecom_prepare_end (void)
12365 {
12366   int prep_state = current_binding_level->prep_state;
12367
12368   assert (prep_state < 2);
12369   current_binding_level->prep_state = 2;
12370
12371   return (prep_state == 1) ? TRUE : FALSE;
12372 }
12373
12374 /* Prepare expression.
12375
12376    This is called before any code is generated for the current block.
12377    It scans the expression, declares any temporaries that might be needed
12378    during evaluation of the expression, and stores those temporaries in
12379    the appropriate "hook" fields of the expression.  `dest', if not NULL,
12380    specifies the destination that ffecom_expr_ will see, in case that
12381    helps avoid generating unused temporaries.
12382
12383    ~~Improve to avoid allocating unused temporaries by taking `dest'
12384    into account vis-a-vis aliasing requirements of complex/character
12385    functions.  */
12386
12387 void
12388 ffecom_prepare_expr_ (ffebld expr, ffebld dest UNUSED)
12389 {
12390   ffeinfoBasictype bt;
12391   ffeinfoKindtype kt;
12392   ffetargetCharacterSize sz;
12393   tree tempvar = NULL_TREE;
12394
12395   assert (current_binding_level->prep_state < 2);
12396
12397   if (! expr)
12398     return;
12399
12400   bt = ffeinfo_basictype (ffebld_info (expr));
12401   kt = ffeinfo_kindtype (ffebld_info (expr));
12402   sz = ffeinfo_size (ffebld_info (expr));
12403
12404   /* Generate whatever temporaries are needed to represent the result
12405      of the expression.  */
12406
12407   if (bt == FFEINFO_basictypeCHARACTER)
12408     {
12409       while (ffebld_op (expr) == FFEBLD_opPAREN)
12410         expr = ffebld_left (expr);
12411     }
12412
12413   switch (ffebld_op (expr))
12414     {
12415     default:
12416       /* Don't make temps for SYMTER, CONTER, etc.  */
12417       if (ffebld_arity (expr) == 0)
12418         break;
12419
12420       switch (bt)
12421         {
12422         case FFEINFO_basictypeCOMPLEX:
12423           if (ffebld_op (expr) == FFEBLD_opFUNCREF)
12424             {
12425               ffesymbol s;
12426
12427               if (ffebld_op (ffebld_left (expr)) != FFEBLD_opSYMTER)
12428                 break;
12429
12430               s = ffebld_symter (ffebld_left (expr));
12431               if (ffesymbol_where (s) == FFEINFO_whereCONSTANT
12432                   || (ffesymbol_where (s) != FFEINFO_whereINTRINSIC
12433                       && ! ffesymbol_is_f2c (s))
12434                   || (ffesymbol_where (s) == FFEINFO_whereINTRINSIC
12435                       && ! ffe_is_f2c_library ()))
12436                 break;
12437             }
12438           else if (ffebld_op (expr) == FFEBLD_opPOWER)
12439             {
12440               /* Requires special treatment.  There's no POW_CC function
12441                  in libg2c, so POW_ZZ is used, which means we always
12442                  need a double-complex temp, not a single-complex.  */
12443               kt = FFEINFO_kindtypeREAL2;
12444             }
12445           else if (ffebld_op (expr) != FFEBLD_opDIVIDE)
12446             /* The other ops don't need temps for complex operands.  */
12447             break;
12448
12449           /* ~~~Avoid making temps for some intrinsics, such as AIMAG(C),
12450              REAL(C).  See 19990325-0.f, routine `check', for cases.  */
12451           tempvar = ffecom_make_tempvar ("complex",
12452                                          ffecom_tree_type
12453                                          [FFEINFO_basictypeCOMPLEX][kt],
12454                                          FFETARGET_charactersizeNONE,
12455                                          -1);
12456           break;
12457
12458         case FFEINFO_basictypeCHARACTER:
12459           if (ffebld_op (expr) != FFEBLD_opFUNCREF)
12460             break;
12461
12462           if (sz == FFETARGET_charactersizeNONE)
12463             /* ~~Kludge alert!  This should someday be fixed. */
12464             sz = 24;
12465
12466           tempvar = ffecom_make_tempvar ("char", char_type_node, sz, -1);
12467           break;
12468
12469         default:
12470           break;
12471         }
12472       break;
12473
12474 #ifdef HAHA
12475     case FFEBLD_opPOWER:
12476       {
12477         tree rtype, ltype;
12478         tree rtmp, ltmp, result;
12479
12480         ltype = ffecom_type_expr (ffebld_left (expr));
12481         rtype = ffecom_type_expr (ffebld_right (expr));
12482
12483         rtmp = ffecom_make_tempvar (rtype, FFETARGET_charactersizeNONE, -1);
12484         ltmp = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
12485         result = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
12486
12487         tempvar = make_tree_vec (3);
12488         TREE_VEC_ELT (tempvar, 0) = rtmp;
12489         TREE_VEC_ELT (tempvar, 1) = ltmp;
12490         TREE_VEC_ELT (tempvar, 2) = result;
12491       }
12492       break;
12493 #endif  /* HAHA */
12494
12495     case FFEBLD_opCONCATENATE:
12496       {
12497         /* This gets special handling, because only one set of temps
12498            is needed for a tree of these -- the tree is treated as
12499            a flattened list of concatenations when generating code.  */
12500
12501         ffecomConcatList_ catlist;
12502         tree ltmp, itmp, result;
12503         int count;
12504         int i;
12505
12506         catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
12507         count = ffecom_concat_list_count_ (catlist);
12508
12509         if (count >= 2)
12510           {
12511             ltmp
12512               = ffecom_make_tempvar ("concat_len",
12513                                      ffecom_f2c_ftnlen_type_node,
12514                                      FFETARGET_charactersizeNONE, count);
12515             itmp
12516               = ffecom_make_tempvar ("concat_item",
12517                                      ffecom_f2c_address_type_node,
12518                                      FFETARGET_charactersizeNONE, count);
12519             result
12520               = ffecom_make_tempvar ("concat_res",
12521                                      char_type_node,
12522                                      ffecom_concat_list_maxlen_ (catlist),
12523                                      -1);
12524
12525             tempvar = make_tree_vec (3);
12526             TREE_VEC_ELT (tempvar, 0) = ltmp;
12527             TREE_VEC_ELT (tempvar, 1) = itmp;
12528             TREE_VEC_ELT (tempvar, 2) = result;
12529           }
12530
12531         for (i = 0; i < count; ++i)
12532           ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist,
12533                                                                     i));
12534
12535         ffecom_concat_list_kill_ (catlist);
12536
12537         if (tempvar)
12538           {
12539             ffebld_nonter_set_hook (expr, tempvar);
12540             current_binding_level->prep_state = 1;
12541           }
12542       }
12543       return;
12544
12545     case FFEBLD_opCONVERT:
12546       if (bt == FFEINFO_basictypeCHARACTER
12547           && ((ffebld_size_known (ffebld_left (expr))
12548                == FFETARGET_charactersizeNONE)
12549               || (ffebld_size_known (ffebld_left (expr)) >= sz)))
12550         tempvar = ffecom_make_tempvar ("convert", char_type_node, sz, -1);
12551       break;
12552     }
12553
12554   if (tempvar)
12555     {
12556       ffebld_nonter_set_hook (expr, tempvar);
12557       current_binding_level->prep_state = 1;
12558     }
12559
12560   /* Prepare subexpressions for this expr.  */
12561
12562   switch (ffebld_op (expr))
12563     {
12564     case FFEBLD_opPERCENT_LOC:
12565       ffecom_prepare_ptr_to_expr (ffebld_left (expr));
12566       break;
12567
12568     case FFEBLD_opPERCENT_VAL:
12569     case FFEBLD_opPERCENT_REF:
12570       ffecom_prepare_expr (ffebld_left (expr));
12571       break;
12572
12573     case FFEBLD_opPERCENT_DESCR:
12574       ffecom_prepare_arg_ptr_to_expr (ffebld_left (expr));
12575       break;
12576
12577     case FFEBLD_opITEM:
12578       {
12579         ffebld item;
12580
12581         for (item = expr;
12582              item != NULL;
12583              item = ffebld_trail (item))
12584           if (ffebld_head (item) != NULL)
12585             ffecom_prepare_expr (ffebld_head (item));
12586       }
12587       break;
12588
12589     default:
12590       /* Need to handle character conversion specially.  */
12591       switch (ffebld_arity (expr))
12592         {
12593         case 2:
12594           ffecom_prepare_expr (ffebld_left (expr));
12595           ffecom_prepare_expr (ffebld_right (expr));
12596           break;
12597
12598         case 1:
12599           ffecom_prepare_expr (ffebld_left (expr));
12600           break;
12601
12602         default:
12603           break;
12604         }
12605     }
12606
12607   return;
12608 }
12609
12610 /* Prepare expression for reading and writing.
12611
12612    Like ffecom_prepare_expr, except for expressions to be evaluated
12613    via ffecom_expr_rw.  */
12614
12615 void
12616 ffecom_prepare_expr_rw (tree type, ffebld expr)
12617 {
12618   /* This is all we support for now.  */
12619   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
12620
12621   /* ~~For now, it seems to be the same thing.  */
12622   ffecom_prepare_expr (expr);
12623   return;
12624 }
12625
12626 /* Prepare expression for writing.
12627
12628    Like ffecom_prepare_expr, except for expressions to be evaluated
12629    via ffecom_expr_w.  */
12630
12631 void
12632 ffecom_prepare_expr_w (tree type, ffebld expr)
12633 {
12634   /* This is all we support for now.  */
12635   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
12636
12637   /* ~~For now, it seems to be the same thing.  */
12638   ffecom_prepare_expr (expr);
12639   return;
12640 }
12641
12642 /* Prepare expression for returning.
12643
12644    Like ffecom_prepare_expr, except for expressions to be evaluated
12645    via ffecom_return_expr.  */
12646
12647 void
12648 ffecom_prepare_return_expr (ffebld expr)
12649 {
12650   assert (current_binding_level->prep_state < 2);
12651
12652   if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE
12653       && ffecom_is_altreturning_
12654       && expr != NULL)
12655     ffecom_prepare_expr (expr);
12656 }
12657
12658 /* Prepare pointer to expression.
12659
12660    Like ffecom_prepare_expr, except for expressions to be evaluated
12661    via ffecom_ptr_to_expr.  */
12662
12663 void
12664 ffecom_prepare_ptr_to_expr (ffebld expr)
12665 {
12666   /* ~~For now, it seems to be the same thing.  */
12667   ffecom_prepare_expr (expr);
12668   return;
12669 }
12670
12671 /* Transform expression into constant pointer-to-expression tree.
12672
12673    If the expression can be transformed into a pointer-to-expression tree
12674    that is constant, that is done, and the tree returned.  Else NULL_TREE
12675    is returned.
12676
12677    That way, a caller can attempt to provide compile-time initialization
12678    of a variable and, if that fails, *then* choose to start a new block
12679    and resort to using temporaries, as appropriate.  */
12680
12681 tree
12682 ffecom_ptr_to_const_expr (ffebld expr)
12683 {
12684   if (! expr)
12685     return integer_zero_node;
12686
12687   if (ffebld_op (expr) == FFEBLD_opANY)
12688     return error_mark_node;
12689
12690   if (ffebld_arity (expr) == 0
12691       && (ffebld_op (expr) != FFEBLD_opSYMTER
12692           || ffebld_where (expr) == FFEINFO_whereCOMMON
12693           || ffebld_where (expr) == FFEINFO_whereGLOBAL
12694           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
12695     {
12696       tree t;
12697
12698       t = ffecom_ptr_to_expr (expr);
12699       assert (TREE_CONSTANT (t));
12700       return t;
12701     }
12702
12703   return NULL_TREE;
12704 }
12705
12706 /* ffecom_return_expr -- Returns return-value expr given alt return expr
12707
12708    tree rtn;  // NULL_TREE means use expand_null_return()
12709    ffebld expr;  // NULL if no alt return expr to RETURN stmt
12710    rtn = ffecom_return_expr(expr);
12711
12712    Based on the program unit type and other info (like return function
12713    type, return master function type when alternate ENTRY points,
12714    whether subroutine has any alternate RETURN points, etc), returns the
12715    appropriate expression to be returned to the caller, or NULL_TREE
12716    meaning no return value or the caller expects it to be returned somewhere
12717    else (which is handled by other parts of this module).  */
12718
12719 tree
12720 ffecom_return_expr (ffebld expr)
12721 {
12722   tree rtn;
12723
12724   switch (ffecom_primary_entry_kind_)
12725     {
12726     case FFEINFO_kindPROGRAM:
12727     case FFEINFO_kindBLOCKDATA:
12728       rtn = NULL_TREE;
12729       break;
12730
12731     case FFEINFO_kindSUBROUTINE:
12732       if (!ffecom_is_altreturning_)
12733         rtn = NULL_TREE;        /* No alt returns, never an expr. */
12734       else if (expr == NULL)
12735         rtn = integer_zero_node;
12736       else
12737         rtn = ffecom_expr (expr);
12738       break;
12739
12740     case FFEINFO_kindFUNCTION:
12741       if ((ffecom_multi_retval_ != NULL_TREE)
12742           || (ffesymbol_basictype (ffecom_primary_entry_)
12743               == FFEINFO_basictypeCHARACTER)
12744           || ((ffesymbol_basictype (ffecom_primary_entry_)
12745                == FFEINFO_basictypeCOMPLEX)
12746               && (ffecom_num_entrypoints_ == 0)
12747               && ffesymbol_is_f2c (ffecom_primary_entry_)))
12748         {                       /* Value is returned by direct assignment
12749                                    into (implicit) dummy. */
12750           rtn = NULL_TREE;
12751           break;
12752         }
12753       rtn = ffecom_func_result_;
12754 #if 0
12755       /* Spurious error if RETURN happens before first reference!  So elide
12756          this code.  In particular, for debugging registry, rtn should always
12757          be non-null after all, but TREE_USED won't be set until we encounter
12758          a reference in the code.  Perfectly okay (but weird) code that,
12759          e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in
12760          this diagnostic for no reason.  Have people use -O -Wuninitialized
12761          and leave it to the back end to find obviously weird cases.  */
12762
12763       /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid
12764          situation; if the return value has never been referenced, it won't
12765          have a tree under 2pass mode. */
12766       if ((rtn == NULL_TREE)
12767           || !TREE_USED (rtn))
12768         {
12769           ffebad_start (FFEBAD_RETURN_VALUE_UNSET);
12770           ffebad_here (0, ffesymbol_where_line (ffecom_primary_entry_),
12771                        ffesymbol_where_column (ffecom_primary_entry_));
12772           ffebad_string (ffesymbol_text (ffesymbol_funcresult
12773                                          (ffecom_primary_entry_)));
12774           ffebad_finish ();
12775         }
12776 #endif
12777       break;
12778
12779     default:
12780       assert ("bad unit kind" == NULL);
12781     case FFEINFO_kindANY:
12782       rtn = error_mark_node;
12783       break;
12784     }
12785
12786   return rtn;
12787 }
12788
12789 /* Do save_expr only if tree is not error_mark_node.  */
12790
12791 tree
12792 ffecom_save_tree (tree t)
12793 {
12794   return save_expr (t);
12795 }
12796
12797 /* Start a compound statement (block).  */
12798
12799 void
12800 ffecom_start_compstmt (void)
12801 {
12802   bison_rule_pushlevel_ ();
12803 }
12804
12805 /* Public entry point for front end to access start_decl.  */
12806
12807 tree
12808 ffecom_start_decl (tree decl, bool is_initialized)
12809 {
12810   DECL_INITIAL (decl) = is_initialized ? error_mark_node : NULL_TREE;
12811   return start_decl (decl, FALSE);
12812 }
12813
12814 /* ffecom_sym_commit -- Symbol's state being committed to reality
12815
12816    ffesymbol s;
12817    ffecom_sym_commit(s);
12818
12819    Does whatever the backend needs when a symbol is committed after having
12820    been backtrackable for a period of time.  */
12821
12822 void
12823 ffecom_sym_commit (ffesymbol s UNUSED)
12824 {
12825   assert (!ffesymbol_retractable ());
12826 }
12827
12828 /* ffecom_sym_end_transition -- Perform end transition on all symbols
12829
12830    ffecom_sym_end_transition();
12831
12832    Does backend-specific stuff and also calls ffest_sym_end_transition
12833    to do the necessary FFE stuff.
12834
12835    Backtracking is never enabled when this fn is called, so don't worry
12836    about it.  */
12837
12838 ffesymbol
12839 ffecom_sym_end_transition (ffesymbol s)
12840 {
12841   ffestorag st;
12842
12843   assert (!ffesymbol_retractable ());
12844
12845   s = ffest_sym_end_transition (s);
12846
12847   if ((ffesymbol_kind (s) == FFEINFO_kindBLOCKDATA)
12848       && (ffesymbol_where (s) == FFEINFO_whereGLOBAL))
12849     {
12850       ffecom_list_blockdata_
12851         = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
12852                                               FFEINTRIN_specNONE,
12853                                               FFEINTRIN_impNONE),
12854                            ffecom_list_blockdata_);
12855     }
12856
12857   /* This is where we finally notice that a symbol has partial initialization
12858      and finalize it. */
12859
12860   if (ffesymbol_accretion (s) != NULL)
12861     {
12862       assert (ffesymbol_init (s) == NULL);
12863       ffecom_notify_init_symbol (s);
12864     }
12865   else if (((st = ffesymbol_storage (s)) != NULL)
12866            && ((st = ffestorag_parent (st)) != NULL)
12867            && (ffestorag_accretion (st) != NULL))
12868     {
12869       assert (ffestorag_init (st) == NULL);
12870       ffecom_notify_init_storage (st);
12871     }
12872
12873   if ((ffesymbol_kind (s) == FFEINFO_kindCOMMON)
12874       && (ffesymbol_where (s) == FFEINFO_whereLOCAL)
12875       && (ffesymbol_storage (s) != NULL))
12876     {
12877       ffecom_list_common_
12878         = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
12879                                               FFEINTRIN_specNONE,
12880                                               FFEINTRIN_impNONE),
12881                            ffecom_list_common_);
12882     }
12883
12884   return s;
12885 }
12886
12887 /* ffecom_sym_exec_transition -- Perform exec transition on all symbols
12888
12889    ffecom_sym_exec_transition();
12890
12891    Does backend-specific stuff and also calls ffest_sym_exec_transition
12892    to do the necessary FFE stuff.
12893
12894    See the long-winded description in ffecom_sym_learned for info
12895    on handling the situation where backtracking is inhibited.  */
12896
12897 ffesymbol
12898 ffecom_sym_exec_transition (ffesymbol s)
12899 {
12900   s = ffest_sym_exec_transition (s);
12901
12902   return s;
12903 }
12904
12905 /* ffecom_sym_learned -- Initial or more info gained on symbol after exec
12906
12907    ffesymbol s;
12908    s = ffecom_sym_learned(s);
12909
12910    Called when a new symbol is seen after the exec transition or when more
12911    info (perhaps) is gained for an UNCERTAIN symbol.  The symbol state when
12912    it arrives here is that all its latest info is updated already, so its
12913    state may be UNCERTAIN or UNDERSTOOD, it might already have the hook
12914    field filled in if its gone through here or exec_transition first, and
12915    so on.
12916
12917    The backend probably wants to check ffesymbol_retractable() to see if
12918    backtracking is in effect.  If so, the FFE's changes to the symbol may
12919    be retracted (undone) or committed (ratified), at which time the
12920    appropriate ffecom_sym_retract or _commit function will be called
12921    for that function.
12922
12923    If the backend has its own backtracking mechanism, great, use it so that
12924    committal is a simple operation.  Though it doesn't make much difference,
12925    I suppose: the reason for tentative symbol evolution in the FFE is to
12926    enable error detection in weird incorrect statements early and to disable
12927    incorrect error detection on a correct statement.  The backend is not
12928    likely to introduce any information that'll get involved in these
12929    considerations, so it is probably just fine that the implementation
12930    model for this fn and for _exec_transition is to not do anything
12931    (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE
12932    and instead wait until ffecom_sym_commit is called (which it never
12933    will be as long as we're using ambiguity-detecting statement analysis in
12934    the FFE, which we are initially to shake out the code, but don't depend
12935    on this), otherwise go ahead and do whatever is needed.
12936
12937    In essence, then, when this fn and _exec_transition get called while
12938    backtracking is enabled, a general mechanism would be to flag which (or
12939    both) of these were called (and in what order? neat question as to what
12940    might happen that I'm too lame to think through right now) and then when
12941    _commit is called reproduce the original calling sequence, if any, for
12942    the two fns (at which point backtracking will, of course, be disabled).  */
12943
12944 ffesymbol
12945 ffecom_sym_learned (ffesymbol s)
12946 {
12947   ffestorag_exec_layout (s);
12948
12949   return s;
12950 }
12951
12952 /* ffecom_sym_retract -- Symbol's state being retracted from reality
12953
12954    ffesymbol s;
12955    ffecom_sym_retract(s);
12956
12957    Does whatever the backend needs when a symbol is retracted after having
12958    been backtrackable for a period of time.  */
12959
12960 void
12961 ffecom_sym_retract (ffesymbol s UNUSED)
12962 {
12963   assert (!ffesymbol_retractable ());
12964
12965 #if 0                           /* GCC doesn't commit any backtrackable sins,
12966                                    so nothing needed here. */
12967   switch (ffesymbol_hook (s).state)
12968     {
12969     case 0:                     /* nothing happened yet. */
12970       break;
12971
12972     case 1:                     /* exec transition happened. */
12973       break;
12974
12975     case 2:                     /* learned happened. */
12976       break;
12977
12978     case 3:                     /* learned then exec. */
12979       break;
12980
12981     case 4:                     /* exec then learned. */
12982       break;
12983
12984     default:
12985       assert ("bad hook state" == NULL);
12986       break;
12987     }
12988 #endif
12989 }
12990
12991 /* Create temporary gcc label.  */
12992
12993 tree
12994 ffecom_temp_label ()
12995 {
12996   tree glabel;
12997   static int mynumber = 0;
12998
12999   glabel = build_decl (LABEL_DECL,
13000                        ffecom_get_invented_identifier ("__g77_label_%d",
13001                                                        mynumber++),
13002                        void_type_node);
13003   DECL_CONTEXT (glabel) = current_function_decl;
13004   DECL_MODE (glabel) = VOIDmode;
13005
13006   return glabel;
13007 }
13008
13009 /* Return an expression that is usable as an arg in a conditional context
13010    (IF, DO WHILE, .NOT., and so on).
13011
13012    Use the one provided for the back end as of >2.6.0.  */
13013
13014 tree
13015 ffecom_truth_value (tree expr)
13016 {
13017   return ffe_truthvalue_conversion (expr);
13018 }
13019
13020 /* Return the inversion of a truth value (the inversion of what
13021    ffecom_truth_value builds).
13022
13023    Apparently invert_truthvalue, which is properly in the back end, is
13024    enough for now, so just use it.  */
13025
13026 tree
13027 ffecom_truth_value_invert (tree expr)
13028 {
13029   return invert_truthvalue (ffecom_truth_value (expr));
13030 }
13031
13032 /* Return the tree that is the type of the expression, as would be
13033    returned in TREE_TYPE(ffecom_expr(expr)), without otherwise
13034    transforming the expression, generating temporaries, etc.  */
13035
13036 tree
13037 ffecom_type_expr (ffebld expr)
13038 {
13039   ffeinfoBasictype bt;
13040   ffeinfoKindtype kt;
13041   tree tree_type;
13042
13043   assert (expr != NULL);
13044
13045   bt = ffeinfo_basictype (ffebld_info (expr));
13046   kt = ffeinfo_kindtype (ffebld_info (expr));
13047   tree_type = ffecom_tree_type[bt][kt];
13048
13049   switch (ffebld_op (expr))
13050     {
13051     case FFEBLD_opCONTER:
13052     case FFEBLD_opSYMTER:
13053     case FFEBLD_opARRAYREF:
13054     case FFEBLD_opUPLUS:
13055     case FFEBLD_opPAREN:
13056     case FFEBLD_opUMINUS:
13057     case FFEBLD_opADD:
13058     case FFEBLD_opSUBTRACT:
13059     case FFEBLD_opMULTIPLY:
13060     case FFEBLD_opDIVIDE:
13061     case FFEBLD_opPOWER:
13062     case FFEBLD_opNOT:
13063     case FFEBLD_opFUNCREF:
13064     case FFEBLD_opSUBRREF:
13065     case FFEBLD_opAND:
13066     case FFEBLD_opOR:
13067     case FFEBLD_opXOR:
13068     case FFEBLD_opNEQV:
13069     case FFEBLD_opEQV:
13070     case FFEBLD_opCONVERT:
13071     case FFEBLD_opLT:
13072     case FFEBLD_opLE:
13073     case FFEBLD_opEQ:
13074     case FFEBLD_opNE:
13075     case FFEBLD_opGT:
13076     case FFEBLD_opGE:
13077     case FFEBLD_opPERCENT_LOC:
13078       return tree_type;
13079
13080     case FFEBLD_opACCTER:
13081     case FFEBLD_opARRTER:
13082     case FFEBLD_opITEM:
13083     case FFEBLD_opSTAR:
13084     case FFEBLD_opBOUNDS:
13085     case FFEBLD_opREPEAT:
13086     case FFEBLD_opLABTER:
13087     case FFEBLD_opLABTOK:
13088     case FFEBLD_opIMPDO:
13089     case FFEBLD_opCONCATENATE:
13090     case FFEBLD_opSUBSTR:
13091     default:
13092       assert ("bad op for ffecom_type_expr" == NULL);
13093       /* Fall through. */
13094     case FFEBLD_opANY:
13095       return error_mark_node;
13096     }
13097 }
13098
13099 /* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points
13100
13101    If the PARM_DECL already exists, return it, else create it.  It's an
13102    integer_type_node argument for the master function that implements a
13103    subroutine or function with more than one entrypoint and is bound at
13104    run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for
13105    first ENTRY statement, and so on).  */
13106
13107 tree
13108 ffecom_which_entrypoint_decl ()
13109 {
13110   assert (ffecom_which_entrypoint_decl_ != NULL_TREE);
13111
13112   return ffecom_which_entrypoint_decl_;
13113 }
13114 \f
13115 /* The following sections consists of private and public functions
13116    that have the same names and perform roughly the same functions
13117    as counterparts in the C front end.  Changes in the C front end
13118    might affect how things should be done here.  Only functions
13119    needed by the back end should be public here; the rest should
13120    be private (static in the C sense).  Functions needed by other
13121    g77 front-end modules should be accessed by them via public
13122    ffecom_* names, which should themselves call private versions
13123    in this section so the private versions are easy to recognize
13124    when upgrading to a new gcc and finding interesting changes
13125    in the front end.
13126
13127    Functions named after rule "foo:" in c-parse.y are named
13128    "bison_rule_foo_" so they are easy to find.  */
13129
13130 static void
13131 bison_rule_pushlevel_ ()
13132 {
13133   emit_line_note (input_filename, lineno);
13134   pushlevel (0);
13135   clear_last_expr ();
13136   expand_start_bindings (0);
13137 }
13138
13139 static tree
13140 bison_rule_compstmt_ ()
13141 {
13142   tree t;
13143   int keep = kept_level_p ();
13144
13145   /* Make the temps go away.  */
13146   if (! keep)
13147     current_binding_level->names = NULL_TREE;
13148
13149   emit_line_note (input_filename, lineno);
13150   expand_end_bindings (getdecls (), keep, 0);
13151   t = poplevel (keep, 1, 0);
13152
13153   return t;
13154 }
13155
13156 /* Return a definition for a builtin function named NAME and whose data type
13157    is TYPE.  TYPE should be a function type with argument types.
13158    FUNCTION_CODE tells later passes how to compile calls to this function.
13159    See tree.h for its possible values.
13160
13161    If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
13162    the name to be called if we can't opencode the function.  */
13163
13164 tree
13165 builtin_function (const char *name, tree type, int function_code,
13166                   enum built_in_class class,
13167                   const char *library_name)
13168 {
13169   tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type);
13170   DECL_EXTERNAL (decl) = 1;
13171   TREE_PUBLIC (decl) = 1;
13172   if (library_name)
13173     SET_DECL_ASSEMBLER_NAME (decl, get_identifier (library_name));
13174   make_decl_rtl (decl, NULL);
13175   pushdecl (decl);
13176   DECL_BUILT_IN_CLASS (decl) = class;
13177   DECL_FUNCTION_CODE (decl) = function_code;
13178
13179   return decl;
13180 }
13181
13182 /* Handle when a new declaration NEWDECL
13183    has the same name as an old one OLDDECL
13184    in the same binding contour.
13185    Prints an error message if appropriate.
13186
13187    If safely possible, alter OLDDECL to look like NEWDECL, and return 1.
13188    Otherwise, return 0.  */
13189
13190 static int
13191 duplicate_decls (tree newdecl, tree olddecl)
13192 {
13193   int types_match = 1;
13194   int new_is_definition = (TREE_CODE (newdecl) == FUNCTION_DECL
13195                            && DECL_INITIAL (newdecl) != 0);
13196   tree oldtype = TREE_TYPE (olddecl);
13197   tree newtype = TREE_TYPE (newdecl);
13198
13199   if (olddecl == newdecl)
13200     return 1;
13201
13202   if (TREE_CODE (newtype) == ERROR_MARK
13203       || TREE_CODE (oldtype) == ERROR_MARK)
13204     types_match = 0;
13205
13206   /* New decl is completely inconsistent with the old one =>
13207      tell caller to replace the old one.
13208      This is always an error except in the case of shadowing a builtin.  */
13209   if (TREE_CODE (olddecl) != TREE_CODE (newdecl))
13210     return 0;
13211
13212   /* For real parm decl following a forward decl,
13213      return 1 so old decl will be reused.  */
13214   if (types_match && TREE_CODE (newdecl) == PARM_DECL
13215       && TREE_ASM_WRITTEN (olddecl) && ! TREE_ASM_WRITTEN (newdecl))
13216     return 1;
13217
13218   /* The new declaration is the same kind of object as the old one.
13219      The declarations may partially match.  Print warnings if they don't
13220      match enough.  Ultimately, copy most of the information from the new
13221      decl to the old one, and keep using the old one.  */
13222
13223   if (TREE_CODE (olddecl) == FUNCTION_DECL
13224       && DECL_BUILT_IN (olddecl))
13225     {
13226       /* A function declaration for a built-in function.  */
13227       if (!TREE_PUBLIC (newdecl))
13228         return 0;
13229       else if (!types_match)
13230         {
13231           /* Accept the return type of the new declaration if same modes.  */
13232           tree oldreturntype = TREE_TYPE (TREE_TYPE (olddecl));
13233           tree newreturntype = TREE_TYPE (TREE_TYPE (newdecl));
13234
13235           if (TYPE_MODE (oldreturntype) == TYPE_MODE (newreturntype))
13236             {
13237               /* Function types may be shared, so we can't just modify
13238                  the return type of olddecl's function type.  */
13239               tree newtype
13240                 = build_function_type (newreturntype,
13241                                        TYPE_ARG_TYPES (TREE_TYPE (olddecl)));
13242
13243               types_match = 1;
13244               if (types_match)
13245                 TREE_TYPE (olddecl) = newtype;
13246             }
13247         }
13248       if (!types_match)
13249         return 0;
13250     }
13251   else if (TREE_CODE (olddecl) == FUNCTION_DECL
13252            && DECL_SOURCE_LINE (olddecl) == 0)
13253     {
13254       /* A function declaration for a predeclared function
13255          that isn't actually built in.  */
13256       if (!TREE_PUBLIC (newdecl))
13257         return 0;
13258       else if (!types_match)
13259         {
13260           /* If the types don't match, preserve volatility indication.
13261              Later on, we will discard everything else about the
13262              default declaration.  */
13263           TREE_THIS_VOLATILE (newdecl) |= TREE_THIS_VOLATILE (olddecl);
13264         }
13265     }
13266
13267   /* Copy all the DECL_... slots specified in the new decl
13268      except for any that we copy here from the old type.
13269
13270      Past this point, we don't change OLDTYPE and NEWTYPE
13271      even if we change the types of NEWDECL and OLDDECL.  */
13272
13273   if (types_match)
13274     {
13275       /* Merge the data types specified in the two decls.  */
13276       if (TREE_CODE (newdecl) != FUNCTION_DECL || !DECL_BUILT_IN (olddecl))
13277         TREE_TYPE (newdecl)
13278           = TREE_TYPE (olddecl)
13279             = TREE_TYPE (newdecl);
13280
13281       /* Lay the type out, unless already done.  */
13282       if (oldtype != TREE_TYPE (newdecl))
13283         {
13284           if (TREE_TYPE (newdecl) != error_mark_node)
13285             layout_type (TREE_TYPE (newdecl));
13286           if (TREE_CODE (newdecl) != FUNCTION_DECL
13287               && TREE_CODE (newdecl) != TYPE_DECL
13288               && TREE_CODE (newdecl) != CONST_DECL)
13289             layout_decl (newdecl, 0);
13290         }
13291       else
13292         {
13293           /* Since the type is OLDDECL's, make OLDDECL's size go with.  */
13294           DECL_SIZE (newdecl) = DECL_SIZE (olddecl);
13295           DECL_SIZE_UNIT (newdecl) = DECL_SIZE_UNIT (olddecl);
13296           if (TREE_CODE (olddecl) != FUNCTION_DECL)
13297             if (DECL_ALIGN (olddecl) > DECL_ALIGN (newdecl))
13298               {
13299                 DECL_ALIGN (newdecl) = DECL_ALIGN (olddecl);
13300                 DECL_USER_ALIGN (newdecl) |= DECL_USER_ALIGN (olddecl);
13301               }
13302         }
13303
13304       /* Keep the old rtl since we can safely use it.  */
13305       COPY_DECL_RTL (olddecl, newdecl);
13306
13307       /* Merge the type qualifiers.  */
13308       if (DECL_BUILT_IN_NONANSI (olddecl) && TREE_THIS_VOLATILE (olddecl)
13309           && !TREE_THIS_VOLATILE (newdecl))
13310         TREE_THIS_VOLATILE (olddecl) = 0;
13311       if (TREE_READONLY (newdecl))
13312         TREE_READONLY (olddecl) = 1;
13313       if (TREE_THIS_VOLATILE (newdecl))
13314         {
13315           TREE_THIS_VOLATILE (olddecl) = 1;
13316           if (TREE_CODE (newdecl) == VAR_DECL)
13317             make_var_volatile (newdecl);
13318         }
13319
13320       /* Keep source location of definition rather than declaration.
13321          Likewise, keep decl at outer scope.  */
13322       if ((DECL_INITIAL (newdecl) == 0 && DECL_INITIAL (olddecl) != 0)
13323           || (DECL_CONTEXT (newdecl) != 0 && DECL_CONTEXT (olddecl) == 0))
13324         {
13325           DECL_SOURCE_LINE (newdecl) = DECL_SOURCE_LINE (olddecl);
13326           DECL_SOURCE_FILE (newdecl) = DECL_SOURCE_FILE (olddecl);
13327
13328           if (DECL_CONTEXT (olddecl) == 0
13329               && TREE_CODE (newdecl) != FUNCTION_DECL)
13330             DECL_CONTEXT (newdecl) = 0;
13331         }
13332
13333       /* Merge the unused-warning information.  */
13334       if (DECL_IN_SYSTEM_HEADER (olddecl))
13335         DECL_IN_SYSTEM_HEADER (newdecl) = 1;
13336       else if (DECL_IN_SYSTEM_HEADER (newdecl))
13337         DECL_IN_SYSTEM_HEADER (olddecl) = 1;
13338
13339       /* Merge the initialization information.  */
13340       if (DECL_INITIAL (newdecl) == 0)
13341         DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13342
13343       /* Merge the section attribute.
13344          We want to issue an error if the sections conflict but that must be
13345          done later in decl_attributes since we are called before attributes
13346          are assigned.  */
13347       if (DECL_SECTION_NAME (newdecl) == NULL_TREE)
13348         DECL_SECTION_NAME (newdecl) = DECL_SECTION_NAME (olddecl);
13349
13350       if (TREE_CODE (newdecl) == FUNCTION_DECL)
13351         {
13352           DECL_STATIC_CONSTRUCTOR(newdecl) |= DECL_STATIC_CONSTRUCTOR(olddecl);
13353           DECL_STATIC_DESTRUCTOR (newdecl) |= DECL_STATIC_DESTRUCTOR (olddecl);
13354         }
13355     }
13356   /* If cannot merge, then use the new type and qualifiers,
13357      and don't preserve the old rtl.  */
13358   else
13359     {
13360       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13361       TREE_READONLY (olddecl) = TREE_READONLY (newdecl);
13362       TREE_THIS_VOLATILE (olddecl) = TREE_THIS_VOLATILE (newdecl);
13363       TREE_SIDE_EFFECTS (olddecl) = TREE_SIDE_EFFECTS (newdecl);
13364     }
13365
13366   /* Merge the storage class information.  */
13367   /* For functions, static overrides non-static.  */
13368   if (TREE_CODE (newdecl) == FUNCTION_DECL)
13369     {
13370       TREE_PUBLIC (newdecl) &= TREE_PUBLIC (olddecl);
13371       /* This is since we don't automatically
13372          copy the attributes of NEWDECL into OLDDECL.  */
13373       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13374       /* If this clears `static', clear it in the identifier too.  */
13375       if (! TREE_PUBLIC (olddecl))
13376         TREE_PUBLIC (DECL_NAME (olddecl)) = 0;
13377     }
13378   if (DECL_EXTERNAL (newdecl))
13379     {
13380       TREE_STATIC (newdecl) = TREE_STATIC (olddecl);
13381       DECL_EXTERNAL (newdecl) = DECL_EXTERNAL (olddecl);
13382       /* An extern decl does not override previous storage class.  */
13383       TREE_PUBLIC (newdecl) = TREE_PUBLIC (olddecl);
13384     }
13385   else
13386     {
13387       TREE_STATIC (olddecl) = TREE_STATIC (newdecl);
13388       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13389     }
13390
13391   /* If either decl says `inline', this fn is inline,
13392      unless its definition was passed already.  */
13393   if (DECL_INLINE (newdecl) && DECL_INITIAL (olddecl) == 0)
13394     DECL_INLINE (olddecl) = 1;
13395   DECL_INLINE (newdecl) = DECL_INLINE (olddecl);
13396
13397   /* Get rid of any built-in function if new arg types don't match it
13398      or if we have a function definition.  */
13399   if (TREE_CODE (newdecl) == FUNCTION_DECL
13400       && DECL_BUILT_IN (olddecl)
13401       && (!types_match || new_is_definition))
13402     {
13403       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13404       DECL_BUILT_IN_CLASS (olddecl) = NOT_BUILT_IN;
13405     }
13406
13407   /* If redeclaring a builtin function, and not a definition,
13408      it stays built in.
13409      Also preserve various other info from the definition.  */
13410   if (TREE_CODE (newdecl) == FUNCTION_DECL && !new_is_definition)
13411     {
13412       if (DECL_BUILT_IN (olddecl))
13413         {
13414           DECL_BUILT_IN_CLASS (newdecl) = DECL_BUILT_IN_CLASS (olddecl);
13415           DECL_FUNCTION_CODE (newdecl) = DECL_FUNCTION_CODE (olddecl);
13416         }
13417
13418       DECL_RESULT (newdecl) = DECL_RESULT (olddecl);
13419       DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13420       DECL_SAVED_INSNS (newdecl) = DECL_SAVED_INSNS (olddecl);
13421       DECL_ARGUMENTS (newdecl) = DECL_ARGUMENTS (olddecl);
13422     }
13423
13424   /* Copy most of the decl-specific fields of NEWDECL into OLDDECL.
13425      But preserve olddecl's DECL_UID.  */
13426   {
13427     register unsigned olddecl_uid = DECL_UID (olddecl);
13428
13429     memcpy ((char *) olddecl + sizeof (struct tree_common),
13430             (char *) newdecl + sizeof (struct tree_common),
13431             sizeof (struct tree_decl) - sizeof (struct tree_common));
13432     DECL_UID (olddecl) = olddecl_uid;
13433   }
13434
13435   return 1;
13436 }
13437
13438 /* Finish processing of a declaration;
13439    install its initial value.
13440    If the length of an array type is not known before,
13441    it must be determined now, from the initial value, or it is an error.  */
13442
13443 static void
13444 finish_decl (tree decl, tree init, bool is_top_level)
13445 {
13446   register tree type = TREE_TYPE (decl);
13447   int was_incomplete = (DECL_SIZE (decl) == 0);
13448   bool at_top_level = (current_binding_level == global_binding_level);
13449   bool top_level = is_top_level || at_top_level;
13450
13451   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13452      level anyway.  */
13453   assert (!is_top_level || !at_top_level);
13454
13455   if (TREE_CODE (decl) == PARM_DECL)
13456     assert (init == NULL_TREE);
13457   /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it
13458      overlaps DECL_ARG_TYPE.  */
13459   else if (init == NULL_TREE)
13460     assert (DECL_INITIAL (decl) == NULL_TREE);
13461   else
13462     assert (DECL_INITIAL (decl) == error_mark_node);
13463
13464   if (init != NULL_TREE)
13465     {
13466       if (TREE_CODE (decl) != TYPE_DECL)
13467         DECL_INITIAL (decl) = init;
13468       else
13469         {
13470           /* typedef foo = bar; store the type of bar as the type of foo.  */
13471           TREE_TYPE (decl) = TREE_TYPE (init);
13472           DECL_INITIAL (decl) = init = 0;
13473         }
13474     }
13475
13476   /* Deduce size of array from initialization, if not already known */
13477
13478   if (TREE_CODE (type) == ARRAY_TYPE
13479       && TYPE_DOMAIN (type) == 0
13480       && TREE_CODE (decl) != TYPE_DECL)
13481     {
13482       assert (top_level);
13483       assert (was_incomplete);
13484
13485       layout_decl (decl, 0);
13486     }
13487
13488   if (TREE_CODE (decl) == VAR_DECL)
13489     {
13490       if (DECL_SIZE (decl) == NULL_TREE
13491           && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
13492         layout_decl (decl, 0);
13493
13494       if (DECL_SIZE (decl) == NULL_TREE
13495           && (TREE_STATIC (decl)
13496               ?
13497       /* A static variable with an incomplete type is an error if it is
13498          initialized. Also if it is not file scope. Otherwise, let it
13499          through, but if it is not `extern' then it may cause an error
13500          message later.  */
13501               (DECL_INITIAL (decl) != 0 || DECL_CONTEXT (decl) != 0)
13502               :
13503       /* An automatic variable with an incomplete type is an error.  */
13504               !DECL_EXTERNAL (decl)))
13505         {
13506           assert ("storage size not known" == NULL);
13507           abort ();
13508         }
13509
13510       if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl))
13511           && (DECL_SIZE (decl) != 0)
13512           && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST))
13513         {
13514           assert ("storage size not constant" == NULL);
13515           abort ();
13516         }
13517     }
13518
13519   /* Output the assembler code and/or RTL code for variables and functions,
13520      unless the type is an undefined structure or union. If not, it will get
13521      done when the type is completed.  */
13522
13523   if (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == FUNCTION_DECL)
13524     {
13525       rest_of_decl_compilation (decl, NULL,
13526                                 DECL_CONTEXT (decl) == 0,
13527                                 0);
13528
13529       if (DECL_CONTEXT (decl) != 0)
13530         {
13531           /* Recompute the RTL of a local array now if it used to be an
13532              incomplete type.  */
13533           if (was_incomplete
13534               && !TREE_STATIC (decl) && !DECL_EXTERNAL (decl))
13535             {
13536               /* If we used it already as memory, it must stay in memory.  */
13537               TREE_ADDRESSABLE (decl) = TREE_USED (decl);
13538               /* If it's still incomplete now, no init will save it.  */
13539               if (DECL_SIZE (decl) == 0)
13540                 DECL_INITIAL (decl) = 0;
13541               expand_decl (decl);
13542             }
13543           /* Compute and store the initial value.  */
13544           if (TREE_CODE (decl) != FUNCTION_DECL)
13545             expand_decl_init (decl);
13546         }
13547     }
13548   else if (TREE_CODE (decl) == TYPE_DECL)
13549     {
13550       rest_of_decl_compilation (decl, NULL,
13551                                 DECL_CONTEXT (decl) == 0,
13552                                 0);
13553     }
13554
13555   /* At the end of a declaration, throw away any variable type sizes of types
13556      defined inside that declaration.  There is no use computing them in the
13557      following function definition.  */
13558   if (current_binding_level == global_binding_level)
13559     get_pending_sizes ();
13560 }
13561
13562 /* Finish up a function declaration and compile that function
13563    all the way to assembler language output.  The free the storage
13564    for the function definition.
13565
13566    This is called after parsing the body of the function definition.
13567
13568    NESTED is nonzero if the function being finished is nested in another.  */
13569
13570 static void
13571 finish_function (int nested)
13572 {
13573   register tree fndecl = current_function_decl;
13574
13575   assert (fndecl != NULL_TREE);
13576   if (TREE_CODE (fndecl) != ERROR_MARK)
13577     {
13578       if (nested)
13579         assert (DECL_CONTEXT (fndecl) != NULL_TREE);
13580       else
13581         assert (DECL_CONTEXT (fndecl) == NULL_TREE);
13582     }
13583
13584 /*  TREE_READONLY (fndecl) = 1;
13585     This caused &foo to be of type ptr-to-const-function
13586     which then got a warning when stored in a ptr-to-function variable.  */
13587
13588   poplevel (1, 0, 1);
13589
13590   if (TREE_CODE (fndecl) != ERROR_MARK)
13591     {
13592       BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
13593
13594       /* Must mark the RESULT_DECL as being in this function.  */
13595
13596       DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl;
13597
13598       /* Obey `register' declarations if `setjmp' is called in this fn.  */
13599       /* Generate rtl for function exit.  */
13600       expand_function_end (input_filename, lineno, 0);
13601
13602       /* If this is a nested function, protect the local variables in the stack
13603          above us from being collected while we're compiling this function.  */
13604       if (nested)
13605         ggc_push_context ();
13606
13607       /* Run the optimizers and output the assembler code for this function.  */
13608       rest_of_compilation (fndecl);
13609
13610       /* Undo the GC context switch.  */
13611       if (nested)
13612         ggc_pop_context ();
13613     }
13614
13615   if (TREE_CODE (fndecl) != ERROR_MARK
13616       && !nested
13617       && DECL_SAVED_INSNS (fndecl) == 0)
13618     {
13619       /* Stop pointing to the local nodes about to be freed.  */
13620       /* But DECL_INITIAL must remain nonzero so we know this was an actual
13621          function definition.  */
13622       /* For a nested function, this is done in pop_f_function_context.  */
13623       /* If rest_of_compilation set this to 0, leave it 0.  */
13624       if (DECL_INITIAL (fndecl) != 0)
13625         DECL_INITIAL (fndecl) = error_mark_node;
13626       DECL_ARGUMENTS (fndecl) = 0;
13627     }
13628
13629   if (!nested)
13630     {
13631       /* Let the error reporting routines know that we're outside a function.
13632          For a nested function, this value is used in pop_c_function_context
13633          and then reset via pop_function_context.  */
13634       ffecom_outer_function_decl_ = current_function_decl = NULL;
13635     }
13636 }
13637
13638 /* Plug-in replacement for identifying the name of a decl and, for a
13639    function, what we call it in diagnostics.  For now, "program unit"
13640    should suffice, since it's a bit of a hassle to figure out which
13641    of several kinds of things it is.  Note that it could conceivably
13642    be a statement function, which probably isn't really a program unit
13643    per se, but if that comes up, it should be easy to check (being a
13644    nested function and all).  */
13645
13646 static const char *
13647 ffe_printable_name (tree decl, int v)
13648 {
13649   /* Just to keep GCC quiet about the unused variable.
13650      In theory, differing values of V should produce different
13651      output.  */
13652   switch (v)
13653     {
13654     default:
13655       if (TREE_CODE (decl) == ERROR_MARK)
13656         return "erroneous code";
13657       return IDENTIFIER_POINTER (DECL_NAME (decl));
13658     }
13659 }
13660
13661 /* g77's function to print out name of current function that caused
13662    an error.  */
13663
13664 static void
13665 ffe_print_error_function (diagnostic_context *context __attribute__((unused)),
13666                           const char *file)
13667 {
13668   static ffeglobal last_g = NULL;
13669   static ffesymbol last_s = NULL;
13670   ffeglobal g;
13671   ffesymbol s;
13672   const char *kind;
13673
13674   if ((ffecom_primary_entry_ == NULL)
13675       || (ffesymbol_global (ffecom_primary_entry_) == NULL))
13676     {
13677       g = NULL;
13678       s = NULL;
13679       kind = NULL;
13680     }
13681   else
13682     {
13683       g = ffesymbol_global (ffecom_primary_entry_);
13684       if (ffecom_nested_entry_ == NULL)
13685         {
13686           s = ffecom_primary_entry_;
13687           kind = _(ffeinfo_kind_message (ffesymbol_kind (s)));
13688         }
13689       else
13690         {
13691           s = ffecom_nested_entry_;
13692           kind = _("In statement function");
13693         }
13694     }
13695
13696   if ((last_g != g) || (last_s != s))
13697     {
13698       if (file)
13699         fprintf (stderr, "%s: ", file);
13700
13701       if (s == NULL)
13702         fprintf (stderr, _("Outside of any program unit:\n"));
13703       else
13704         {
13705           const char *name = ffesymbol_text (s);
13706
13707           fprintf (stderr, "%s `%s':\n", kind, name);
13708         }
13709
13710       last_g = g;
13711       last_s = s;
13712     }
13713 }
13714
13715 /* Similar to `lookup_name' but look only at current binding level.  */
13716
13717 static tree
13718 lookup_name_current_level (tree name)
13719 {
13720   register tree t;
13721
13722   if (current_binding_level == global_binding_level)
13723     return IDENTIFIER_GLOBAL_VALUE (name);
13724
13725   if (IDENTIFIER_LOCAL_VALUE (name) == 0)
13726     return 0;
13727
13728   for (t = current_binding_level->names; t; t = TREE_CHAIN (t))
13729     if (DECL_NAME (t) == name)
13730       break;
13731
13732   return t;
13733 }
13734
13735 /* Create a new `struct binding_level'.  */
13736
13737 static struct binding_level *
13738 make_binding_level ()
13739 {
13740   /* NOSTRICT */
13741   return (struct binding_level *) xmalloc (sizeof (struct binding_level));
13742 }
13743
13744 /* Save and restore the variables in this file and elsewhere
13745    that keep track of the progress of compilation of the current function.
13746    Used for nested functions.  */
13747
13748 struct f_function
13749 {
13750   struct f_function *next;
13751   tree named_labels;
13752   tree shadowed_labels;
13753   struct binding_level *binding_level;
13754 };
13755
13756 struct f_function *f_function_chain;
13757
13758 /* Restore the variables used during compilation of a C function.  */
13759
13760 static void
13761 pop_f_function_context ()
13762 {
13763   struct f_function *p = f_function_chain;
13764   tree link;
13765
13766   /* Bring back all the labels that were shadowed.  */
13767   for (link = shadowed_labels; link; link = TREE_CHAIN (link))
13768     if (DECL_NAME (TREE_VALUE (link)) != 0)
13769       IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link)))
13770         = TREE_VALUE (link);
13771
13772   if (current_function_decl != error_mark_node
13773       && DECL_SAVED_INSNS (current_function_decl) == 0)
13774     {
13775       /* Stop pointing to the local nodes about to be freed.  */
13776       /* But DECL_INITIAL must remain nonzero so we know this was an actual
13777          function definition.  */
13778       DECL_INITIAL (current_function_decl) = error_mark_node;
13779       DECL_ARGUMENTS (current_function_decl) = 0;
13780     }
13781
13782   pop_function_context ();
13783
13784   f_function_chain = p->next;
13785
13786   named_labels = p->named_labels;
13787   shadowed_labels = p->shadowed_labels;
13788   current_binding_level = p->binding_level;
13789
13790   free (p);
13791 }
13792
13793 /* Save and reinitialize the variables
13794    used during compilation of a C function.  */
13795
13796 static void
13797 push_f_function_context ()
13798 {
13799   struct f_function *p
13800   = (struct f_function *) xmalloc (sizeof (struct f_function));
13801
13802   push_function_context ();
13803
13804   p->next = f_function_chain;
13805   f_function_chain = p;
13806
13807   p->named_labels = named_labels;
13808   p->shadowed_labels = shadowed_labels;
13809   p->binding_level = current_binding_level;
13810 }
13811
13812 static void
13813 push_parm_decl (tree parm)
13814 {
13815   int old_immediate_size_expand = immediate_size_expand;
13816
13817   /* Don't try computing parm sizes now -- wait till fn is called.  */
13818
13819   immediate_size_expand = 0;
13820
13821   /* Fill in arg stuff.  */
13822
13823   DECL_ARG_TYPE (parm) = TREE_TYPE (parm);
13824   DECL_ARG_TYPE_AS_WRITTEN (parm) = TREE_TYPE (parm);
13825   TREE_READONLY (parm) = 1;     /* All implementation args are read-only. */
13826
13827   parm = pushdecl (parm);
13828
13829   immediate_size_expand = old_immediate_size_expand;
13830
13831   finish_decl (parm, NULL_TREE, FALSE);
13832 }
13833
13834 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate.  */
13835
13836 static tree
13837 pushdecl_top_level (x)
13838      tree x;
13839 {
13840   register tree t;
13841   register struct binding_level *b = current_binding_level;
13842   register tree f = current_function_decl;
13843
13844   current_binding_level = global_binding_level;
13845   current_function_decl = NULL_TREE;
13846   t = pushdecl (x);
13847   current_binding_level = b;
13848   current_function_decl = f;
13849   return t;
13850 }
13851
13852 /* Store the list of declarations of the current level.
13853    This is done for the parameter declarations of a function being defined,
13854    after they are modified in the light of any missing parameters.  */
13855
13856 static tree
13857 storedecls (decls)
13858      tree decls;
13859 {
13860   return current_binding_level->names = decls;
13861 }
13862
13863 /* Store the parameter declarations into the current function declaration.
13864    This is called after parsing the parameter declarations, before
13865    digesting the body of the function.
13866
13867    For an old-style definition, modify the function's type
13868    to specify at least the number of arguments.  */
13869
13870 static void
13871 store_parm_decls (int is_main_program UNUSED)
13872 {
13873   register tree fndecl = current_function_decl;
13874
13875   if (fndecl == error_mark_node)
13876     return;
13877
13878   /* This is a chain of PARM_DECLs from old-style parm declarations.  */
13879   DECL_ARGUMENTS (fndecl) = storedecls (nreverse (getdecls ()));
13880
13881   /* Initialize the RTL code for the function.  */
13882
13883   init_function_start (fndecl, input_filename, lineno);
13884
13885   /* Set up parameters and prepare for return, for the function.  */
13886
13887   expand_function_start (fndecl, 0);
13888 }
13889
13890 static tree
13891 start_decl (tree decl, bool is_top_level)
13892 {
13893   register tree tem;
13894   bool at_top_level = (current_binding_level == global_binding_level);
13895   bool top_level = is_top_level || at_top_level;
13896
13897   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13898      level anyway.  */
13899   assert (!is_top_level || !at_top_level);
13900
13901   if (DECL_INITIAL (decl) != NULL_TREE)
13902     {
13903       assert (DECL_INITIAL (decl) == error_mark_node);
13904       assert (!DECL_EXTERNAL (decl));
13905     }
13906   else if (top_level)
13907     assert ((TREE_STATIC (decl) == 1) || DECL_EXTERNAL (decl) == 1);
13908
13909   /* For Fortran, we by default put things in .common when possible.  */
13910   DECL_COMMON (decl) = 1;
13911
13912   /* Add this decl to the current binding level. TEM may equal DECL or it may
13913      be a previous decl of the same name.  */
13914   if (is_top_level)
13915     tem = pushdecl_top_level (decl);
13916   else
13917     tem = pushdecl (decl);
13918
13919   /* For a local variable, define the RTL now.  */
13920   if (!top_level
13921   /* But not if this is a duplicate decl and we preserved the rtl from the
13922      previous one (which may or may not happen).  */
13923       && !DECL_RTL_SET_P (tem))
13924     {
13925       if (TYPE_SIZE (TREE_TYPE (tem)) != 0)
13926         expand_decl (tem);
13927       else if (TREE_CODE (TREE_TYPE (tem)) == ARRAY_TYPE
13928                && DECL_INITIAL (tem) != 0)
13929         expand_decl (tem);
13930     }
13931
13932   return tem;
13933 }
13934
13935 /* Create the FUNCTION_DECL for a function definition.
13936    DECLSPECS and DECLARATOR are the parts of the declaration;
13937    they describe the function's name and the type it returns,
13938    but twisted together in a fashion that parallels the syntax of C.
13939
13940    This function creates a binding context for the function body
13941    as well as setting up the FUNCTION_DECL in current_function_decl.
13942
13943    Returns 1 on success.  If the DECLARATOR is not suitable for a function
13944    (it defines a datum instead), we return 0, which tells
13945    ffe_parse_file to report a parse error.
13946
13947    NESTED is nonzero for a function nested within another function.  */
13948
13949 static void
13950 start_function (tree name, tree type, int nested, int public)
13951 {
13952   tree decl1;
13953   tree restype;
13954   int old_immediate_size_expand = immediate_size_expand;
13955
13956   named_labels = 0;
13957   shadowed_labels = 0;
13958
13959   /* Don't expand any sizes in the return type of the function.  */
13960   immediate_size_expand = 0;
13961
13962   if (nested)
13963     {
13964       assert (!public);
13965       assert (current_function_decl != NULL_TREE);
13966       assert (DECL_CONTEXT (current_function_decl) == NULL_TREE);
13967     }
13968   else
13969     {
13970       assert (current_function_decl == NULL_TREE);
13971     }
13972
13973   if (TREE_CODE (type) == ERROR_MARK)
13974     decl1 = current_function_decl = error_mark_node;
13975   else
13976     {
13977       decl1 = build_decl (FUNCTION_DECL,
13978                           name,
13979                           type);
13980       TREE_PUBLIC (decl1) = public ? 1 : 0;
13981       if (nested)
13982         DECL_INLINE (decl1) = 1;
13983       TREE_STATIC (decl1) = 1;
13984       DECL_EXTERNAL (decl1) = 0;
13985
13986       announce_function (decl1);
13987
13988       /* Make the init_value nonzero so pushdecl knows this is not tentative.
13989          error_mark_node is replaced below (in poplevel) with the BLOCK.  */
13990       DECL_INITIAL (decl1) = error_mark_node;
13991
13992       /* Record the decl so that the function name is defined. If we already have
13993          a decl for this name, and it is a FUNCTION_DECL, use the old decl.  */
13994
13995       current_function_decl = pushdecl (decl1);
13996     }
13997
13998   if (!nested)
13999     ffecom_outer_function_decl_ = current_function_decl;
14000
14001   pushlevel (0);
14002   current_binding_level->prep_state = 2;
14003
14004   if (TREE_CODE (current_function_decl) != ERROR_MARK)
14005     {
14006       make_decl_rtl (current_function_decl, NULL);
14007
14008       restype = TREE_TYPE (TREE_TYPE (current_function_decl));
14009       DECL_RESULT (current_function_decl)
14010         = build_decl (RESULT_DECL, NULL_TREE, restype);
14011     }
14012
14013   if (!nested && (TREE_CODE (current_function_decl) != ERROR_MARK))
14014     TREE_ADDRESSABLE (current_function_decl) = 1;
14015
14016   immediate_size_expand = old_immediate_size_expand;
14017 }
14018 \f
14019 /* Here are the public functions the GNU back end needs.  */
14020
14021 tree
14022 convert (type, expr)
14023      tree type, expr;
14024 {
14025   register tree e = expr;
14026   register enum tree_code code = TREE_CODE (type);
14027
14028   if (type == TREE_TYPE (e)
14029       || TREE_CODE (e) == ERROR_MARK)
14030     return e;
14031   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
14032     return fold (build1 (NOP_EXPR, type, e));
14033   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
14034       || code == ERROR_MARK)
14035     return error_mark_node;
14036   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
14037     {
14038       assert ("void value not ignored as it ought to be" == NULL);
14039       return error_mark_node;
14040     }
14041   if (code == VOID_TYPE)
14042     return build1 (CONVERT_EXPR, type, e);
14043   if ((code != RECORD_TYPE)
14044       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
14045     e = ffecom_1 (REALPART_EXPR, TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e))),
14046                   e);
14047   if (code == INTEGER_TYPE || code == ENUMERAL_TYPE)
14048     return fold (convert_to_integer (type, e));
14049   if (code == POINTER_TYPE)
14050     return fold (convert_to_pointer (type, e));
14051   if (code == REAL_TYPE)
14052     return fold (convert_to_real (type, e));
14053   if (code == COMPLEX_TYPE)
14054     return fold (convert_to_complex (type, e));
14055   if (code == RECORD_TYPE)
14056     return fold (ffecom_convert_to_complex_ (type, e));
14057
14058   assert ("conversion to non-scalar type requested" == NULL);
14059   return error_mark_node;
14060 }
14061
14062 /* Return the list of declarations of the current level.
14063    Note that this list is in reverse order unless/until
14064    you nreverse it; and when you do nreverse it, you must
14065    store the result back using `storedecls' or you will lose.  */
14066
14067 tree
14068 getdecls ()
14069 {
14070   return current_binding_level->names;
14071 }
14072
14073 /* Nonzero if we are currently in the global binding level.  */
14074
14075 int
14076 global_bindings_p ()
14077 {
14078   return current_binding_level == global_binding_level;
14079 }
14080
14081 /* Mark ARG for GC.  */
14082 static void
14083 mark_binding_level (void *arg)
14084 {
14085   struct binding_level *level = *(struct binding_level **) arg;
14086
14087   while (level)
14088     {
14089       ggc_mark_tree (level->names);
14090       ggc_mark_tree (level->blocks);
14091       ggc_mark_tree (level->this_block);
14092       level = level->level_chain;
14093     }
14094 }
14095
14096 static void
14097 ffecom_init_decl_processing ()
14098 {
14099   static tree *const tree_roots[] = {
14100     &current_function_decl,
14101     &string_type_node,
14102     &ffecom_tree_fun_type_void,
14103     &ffecom_integer_zero_node,
14104     &ffecom_integer_one_node,
14105     &ffecom_tree_subr_type,
14106     &ffecom_tree_ptr_to_subr_type,
14107     &ffecom_tree_blockdata_type,
14108     &ffecom_tree_xargc_,
14109     &ffecom_f2c_integer_type_node,
14110     &ffecom_f2c_ptr_to_integer_type_node,
14111     &ffecom_f2c_address_type_node,
14112     &ffecom_f2c_real_type_node,
14113     &ffecom_f2c_ptr_to_real_type_node,
14114     &ffecom_f2c_doublereal_type_node,
14115     &ffecom_f2c_complex_type_node,
14116     &ffecom_f2c_doublecomplex_type_node,
14117     &ffecom_f2c_longint_type_node,
14118     &ffecom_f2c_logical_type_node,
14119     &ffecom_f2c_flag_type_node,
14120     &ffecom_f2c_ftnlen_type_node,
14121     &ffecom_f2c_ftnlen_zero_node,
14122     &ffecom_f2c_ftnlen_one_node,
14123     &ffecom_f2c_ftnlen_two_node,
14124     &ffecom_f2c_ptr_to_ftnlen_type_node,
14125     &ffecom_f2c_ftnint_type_node,
14126     &ffecom_f2c_ptr_to_ftnint_type_node,
14127     &ffecom_outer_function_decl_,
14128     &ffecom_previous_function_decl_,
14129     &ffecom_which_entrypoint_decl_,
14130     &ffecom_float_zero_,
14131     &ffecom_float_half_,
14132     &ffecom_double_zero_,
14133     &ffecom_double_half_,
14134     &ffecom_func_result_,
14135     &ffecom_func_length_,
14136     &ffecom_multi_type_node_,
14137     &ffecom_multi_retval_,
14138     &named_labels,
14139     &shadowed_labels
14140   };
14141   size_t i;
14142
14143   malloc_init ();
14144
14145   /* Record our roots.  */
14146   for (i = 0; i < ARRAY_SIZE (tree_roots); i++)
14147     ggc_add_tree_root (tree_roots[i], 1);
14148   ggc_add_tree_root (&ffecom_tree_type[0][0],
14149                      FFEINFO_basictype*FFEINFO_kindtype);
14150   ggc_add_tree_root (&ffecom_tree_fun_type[0][0],
14151                      FFEINFO_basictype*FFEINFO_kindtype);
14152   ggc_add_tree_root (&ffecom_tree_ptr_to_fun_type[0][0],
14153                      FFEINFO_basictype*FFEINFO_kindtype);
14154   ggc_add_tree_root (ffecom_gfrt_, FFECOM_gfrt);
14155   ggc_add_root (&current_binding_level, 1, sizeof current_binding_level,
14156                 mark_binding_level);
14157   ggc_add_root (&free_binding_level, 1, sizeof current_binding_level,
14158                 mark_binding_level);
14159   ggc_add_root (&tracker_head, 1, sizeof tracker_head, mark_tracker_head);
14160
14161   ffe_init_0 ();
14162 }
14163
14164 /* Delete the node BLOCK from the current binding level.
14165    This is used for the block inside a stmt expr ({...})
14166    so that the block can be reinserted where appropriate.  */
14167
14168 static void
14169 delete_block (block)
14170      tree block;
14171 {
14172   tree t;
14173   if (current_binding_level->blocks == block)
14174     current_binding_level->blocks = TREE_CHAIN (block);
14175   for (t = current_binding_level->blocks; t;)
14176     {
14177       if (TREE_CHAIN (t) == block)
14178         TREE_CHAIN (t) = TREE_CHAIN (block);
14179       else
14180         t = TREE_CHAIN (t);
14181     }
14182   TREE_CHAIN (block) = NULL;
14183   /* Clear TREE_USED which is always set by poplevel.
14184      The flag is set again if insert_block is called.  */
14185   TREE_USED (block) = 0;
14186 }
14187
14188 void
14189 insert_block (block)
14190      tree block;
14191 {
14192   TREE_USED (block) = 1;
14193   current_binding_level->blocks
14194     = chainon (current_binding_level->blocks, block);
14195 }
14196
14197 /* Each front end provides its own.  */
14198 static const char *ffe_init PARAMS ((const char *));
14199 static void ffe_finish PARAMS ((void));
14200 static void ffe_init_options PARAMS ((void));
14201 static void ffe_print_identifier PARAMS ((FILE *, tree, int));
14202 static void ffe_mark_tree (tree);
14203
14204 #undef  LANG_HOOKS_NAME
14205 #define LANG_HOOKS_NAME                 "GNU F77"
14206 #undef  LANG_HOOKS_INIT
14207 #define LANG_HOOKS_INIT                 ffe_init
14208 #undef  LANG_HOOKS_FINISH
14209 #define LANG_HOOKS_FINISH               ffe_finish
14210 #undef  LANG_HOOKS_INIT_OPTIONS
14211 #define LANG_HOOKS_INIT_OPTIONS         ffe_init_options
14212 #undef  LANG_HOOKS_DECODE_OPTION
14213 #define LANG_HOOKS_DECODE_OPTION        ffe_decode_option
14214 #undef  LANG_HOOKS_PARSE_FILE
14215 #define LANG_HOOKS_PARSE_FILE           ffe_parse_file
14216 #undef  LANG_HOOKS_MARK_TREE
14217 #define LANG_HOOKS_MARK_TREE            ffe_mark_tree
14218 #undef  LANG_HOOKS_MARK_ADDRESSABLE
14219 #define LANG_HOOKS_MARK_ADDRESSABLE     ffe_mark_addressable
14220 #undef  LANG_HOOKS_PRINT_IDENTIFIER
14221 #define LANG_HOOKS_PRINT_IDENTIFIER     ffe_print_identifier
14222 #undef  LANG_HOOKS_DECL_PRINTABLE_NAME
14223 #define LANG_HOOKS_DECL_PRINTABLE_NAME  ffe_printable_name
14224 #undef  LANG_HOOKS_PRINT_ERROR_FUNCTION
14225 #define LANG_HOOKS_PRINT_ERROR_FUNCTION ffe_print_error_function
14226 #undef  LANG_HOOKS_TRUTHVALUE_CONVERSION
14227 #define LANG_HOOKS_TRUTHVALUE_CONVERSION ffe_truthvalue_conversion
14228
14229 #undef  LANG_HOOKS_TYPE_FOR_MODE
14230 #define LANG_HOOKS_TYPE_FOR_MODE        ffe_type_for_mode
14231 #undef  LANG_HOOKS_TYPE_FOR_SIZE
14232 #define LANG_HOOKS_TYPE_FOR_SIZE        ffe_type_for_size
14233 #undef  LANG_HOOKS_SIGNED_TYPE
14234 #define LANG_HOOKS_SIGNED_TYPE          ffe_signed_type
14235 #undef  LANG_HOOKS_UNSIGNED_TYPE
14236 #define LANG_HOOKS_UNSIGNED_TYPE        ffe_unsigned_type
14237 #undef  LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE
14238 #define LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE ffe_signed_or_unsigned_type
14239
14240 /* We do not wish to use alias-set based aliasing at all.  Used in the
14241    extreme (every object with its own set, with equivalences recorded) it
14242    might be helpful, but there are problems when it comes to inlining.  We
14243    get on ok with flag_argument_noalias, and alias-set aliasing does
14244    currently limit how stack slots can be reused, which is a lose.  */
14245 #undef LANG_HOOKS_GET_ALIAS_SET
14246 #define LANG_HOOKS_GET_ALIAS_SET hook_get_alias_set_0
14247
14248 const struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER;
14249
14250 /* Table indexed by tree code giving a string containing a character
14251    classifying the tree code.  Possibilities are
14252    t, d, s, c, r, <, 1, 2 and e.  See tree.def for details.  */
14253
14254 #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) TYPE,
14255
14256 const char tree_code_type[] = {
14257 #include "tree.def"
14258 };
14259 #undef DEFTREECODE
14260
14261 /* Table indexed by tree code giving number of expression
14262    operands beyond the fixed part of the node structure.
14263    Not used for types or decls.  */
14264
14265 #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) LENGTH,
14266
14267 const unsigned char tree_code_length[] = {
14268 #include "tree.def"
14269 };
14270 #undef DEFTREECODE
14271
14272 /* Names of tree components.
14273    Used for printing out the tree and error messages.  */
14274 #define DEFTREECODE(SYM, NAME, TYPE, LEN) NAME,
14275
14276 const char *const tree_code_name[] = {
14277 #include "tree.def"
14278 };
14279 #undef DEFTREECODE
14280
14281 static const char *
14282 ffe_init (filename)
14283      const char *filename;
14284 {
14285   /* Open input file.  */
14286   if (filename == 0 || !strcmp (filename, "-"))
14287     {
14288       finput = stdin;
14289       filename = "stdin";
14290     }
14291   else
14292     finput = fopen (filename, "r");
14293   if (finput == 0)
14294     fatal_io_error ("can't open %s", filename);
14295
14296 #ifdef IO_BUFFER_SIZE
14297   setvbuf (finput, (char *) xmalloc (IO_BUFFER_SIZE), _IOFBF, IO_BUFFER_SIZE);
14298 #endif
14299
14300   ffecom_init_decl_processing ();
14301
14302   /* If the file is output from cpp, it should contain a first line
14303      `# 1 "real-filename"', and the current design of gcc (toplev.c
14304      in particular and the way it sets up information relied on by
14305      INCLUDE) requires that we read this now, and store the
14306      "real-filename" info in master_input_filename.  Ask the lexer
14307      to try doing this.  */
14308   ffelex_hash_kludge (finput);
14309
14310   /* FIXME: The ffelex_hash_kludge code needs to be cleaned up to
14311      return the new file name.  */
14312   if (main_input_filename)
14313     filename = main_input_filename;
14314
14315   return filename;
14316 }
14317
14318 static void
14319 ffe_finish ()
14320 {
14321   ffe_terminate_0 ();
14322
14323   if (ffe_is_ffedebug ())
14324     malloc_pool_display (malloc_pool_image ());
14325
14326   fclose (finput);
14327 }
14328
14329 static void
14330 ffe_init_options ()
14331 {
14332   /* Set default options for Fortran.  */
14333   flag_move_all_movables = 1;
14334   flag_reduce_all_givs = 1;
14335   flag_argument_noalias = 2;
14336   flag_merge_constants = 2;
14337   flag_errno_math = 0;
14338   flag_complex_divide_method = 1;
14339 }
14340
14341 static bool
14342 ffe_mark_addressable (exp)
14343      tree exp;
14344 {
14345   register tree x = exp;
14346   while (1)
14347     switch (TREE_CODE (x))
14348       {
14349       case ADDR_EXPR:
14350       case COMPONENT_REF:
14351       case ARRAY_REF:
14352         x = TREE_OPERAND (x, 0);
14353         break;
14354
14355       case CONSTRUCTOR:
14356         TREE_ADDRESSABLE (x) = 1;
14357         return true;
14358
14359       case VAR_DECL:
14360       case CONST_DECL:
14361       case PARM_DECL:
14362       case RESULT_DECL:
14363         if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x)
14364             && DECL_NONLOCAL (x))
14365           {
14366             if (TREE_PUBLIC (x))
14367               {
14368                 assert ("address of global register var requested" == NULL);
14369                 return false;
14370               }
14371             assert ("address of register variable requested" == NULL);
14372           }
14373         else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x))
14374           {
14375             if (TREE_PUBLIC (x))
14376               {
14377                 assert ("address of global register var requested" == NULL);
14378                 return false;
14379               }
14380             assert ("address of register var requested" == NULL);
14381           }
14382         put_var_into_stack (x);
14383
14384         /* drops in */
14385       case FUNCTION_DECL:
14386         TREE_ADDRESSABLE (x) = 1;
14387 #if 0                           /* poplevel deals with this now.  */
14388         if (DECL_CONTEXT (x) == 0)
14389           TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x)) = 1;
14390 #endif
14391
14392       default:
14393         return true;
14394       }
14395 }
14396
14397 /* Exit a binding level.
14398    Pop the level off, and restore the state of the identifier-decl mappings
14399    that were in effect when this level was entered.
14400
14401    If KEEP is nonzero, this level had explicit declarations, so
14402    and create a "block" (a BLOCK node) for the level
14403    to record its declarations and subblocks for symbol table output.
14404
14405    If FUNCTIONBODY is nonzero, this level is the body of a function,
14406    so create a block as if KEEP were set and also clear out all
14407    label names.
14408
14409    If REVERSE is nonzero, reverse the order of decls before putting
14410    them into the BLOCK.  */
14411
14412 tree
14413 poplevel (keep, reverse, functionbody)
14414      int keep;
14415      int reverse;
14416      int functionbody;
14417 {
14418   register tree link;
14419   /* The chain of decls was accumulated in reverse order.
14420      Put it into forward order, just for cleanliness.  */
14421   tree decls;
14422   tree subblocks = current_binding_level->blocks;
14423   tree block = 0;
14424   tree decl;
14425   int block_previously_created;
14426
14427   /* Get the decls in the order they were written.
14428      Usually current_binding_level->names is in reverse order.
14429      But parameter decls were previously put in forward order.  */
14430
14431   if (reverse)
14432     current_binding_level->names
14433       = decls = nreverse (current_binding_level->names);
14434   else
14435     decls = current_binding_level->names;
14436
14437   /* Output any nested inline functions within this block
14438      if they weren't already output.  */
14439
14440   for (decl = decls; decl; decl = TREE_CHAIN (decl))
14441     if (TREE_CODE (decl) == FUNCTION_DECL
14442         && ! TREE_ASM_WRITTEN (decl)
14443         && DECL_INITIAL (decl) != 0
14444         && TREE_ADDRESSABLE (decl))
14445       {
14446         /* If this decl was copied from a file-scope decl
14447            on account of a block-scope extern decl,
14448            propagate TREE_ADDRESSABLE to the file-scope decl.
14449
14450            DECL_ABSTRACT_ORIGIN can be set to itself if warn_return_type is
14451            true, since then the decl goes through save_for_inline_copying.  */
14452         if (DECL_ABSTRACT_ORIGIN (decl) != 0
14453             && DECL_ABSTRACT_ORIGIN (decl) != decl)
14454           TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl)) = 1;
14455         else if (DECL_SAVED_INSNS (decl) != 0)
14456           {
14457             push_function_context ();
14458             output_inline_function (decl);
14459             pop_function_context ();
14460           }
14461       }
14462
14463   /* If there were any declarations or structure tags in that level,
14464      or if this level is a function body,
14465      create a BLOCK to record them for the life of this function.  */
14466
14467   block = 0;
14468   block_previously_created = (current_binding_level->this_block != 0);
14469   if (block_previously_created)
14470     block = current_binding_level->this_block;
14471   else if (keep || functionbody)
14472     block = make_node (BLOCK);
14473   if (block != 0)
14474     {
14475       BLOCK_VARS (block) = decls;
14476       BLOCK_SUBBLOCKS (block) = subblocks;
14477     }
14478
14479   /* In each subblock, record that this is its superior.  */
14480
14481   for (link = subblocks; link; link = TREE_CHAIN (link))
14482     BLOCK_SUPERCONTEXT (link) = block;
14483
14484   /* Clear out the meanings of the local variables of this level.  */
14485
14486   for (link = decls; link; link = TREE_CHAIN (link))
14487     {
14488       if (DECL_NAME (link) != 0)
14489         {
14490           /* If the ident. was used or addressed via a local extern decl,
14491              don't forget that fact.  */
14492           if (DECL_EXTERNAL (link))
14493             {
14494               if (TREE_USED (link))
14495                 TREE_USED (DECL_NAME (link)) = 1;
14496               if (TREE_ADDRESSABLE (link))
14497                 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (link)) = 1;
14498             }
14499           IDENTIFIER_LOCAL_VALUE (DECL_NAME (link)) = 0;
14500         }
14501     }
14502
14503   /* If the level being exited is the top level of a function,
14504      check over all the labels, and clear out the current
14505      (function local) meanings of their names.  */
14506
14507   if (functionbody)
14508     {
14509       /* If this is the top level block of a function,
14510          the vars are the function's parameters.
14511          Don't leave them in the BLOCK because they are
14512          found in the FUNCTION_DECL instead.  */
14513
14514       BLOCK_VARS (block) = 0;
14515     }
14516
14517   /* Pop the current level, and free the structure for reuse.  */
14518
14519   {
14520     register struct binding_level *level = current_binding_level;
14521     current_binding_level = current_binding_level->level_chain;
14522
14523     level->level_chain = free_binding_level;
14524     free_binding_level = level;
14525   }
14526
14527   /* Dispose of the block that we just made inside some higher level.  */
14528   if (functionbody
14529       && current_function_decl != error_mark_node)
14530     DECL_INITIAL (current_function_decl) = block;
14531   else if (block)
14532     {
14533       if (!block_previously_created)
14534         current_binding_level->blocks
14535           = chainon (current_binding_level->blocks, block);
14536     }
14537   /* If we did not make a block for the level just exited,
14538      any blocks made for inner levels
14539      (since they cannot be recorded as subblocks in that level)
14540      must be carried forward so they will later become subblocks
14541      of something else.  */
14542   else if (subblocks)
14543     current_binding_level->blocks
14544       = chainon (current_binding_level->blocks, subblocks);
14545
14546   if (block)
14547     TREE_USED (block) = 1;
14548   return block;
14549 }
14550
14551 static void
14552 ffe_print_identifier (file, node, indent)
14553      FILE *file;
14554      tree node;
14555      int indent;
14556 {
14557   print_node (file, "global", IDENTIFIER_GLOBAL_VALUE (node), indent + 4);
14558   print_node (file, "local", IDENTIFIER_LOCAL_VALUE (node), indent + 4);
14559 }
14560
14561 /* Record a decl-node X as belonging to the current lexical scope.
14562    Check for errors (such as an incompatible declaration for the same
14563    name already seen in the same scope).
14564
14565    Returns either X or an old decl for the same name.
14566    If an old decl is returned, it may have been smashed
14567    to agree with what X says.  */
14568
14569 tree
14570 pushdecl (x)
14571      tree x;
14572 {
14573   register tree t;
14574   register tree name = DECL_NAME (x);
14575   register struct binding_level *b = current_binding_level;
14576
14577   if ((TREE_CODE (x) == FUNCTION_DECL)
14578       && (DECL_INITIAL (x) == 0)
14579       && DECL_EXTERNAL (x))
14580     DECL_CONTEXT (x) = NULL_TREE;
14581   else
14582     DECL_CONTEXT (x) = current_function_decl;
14583
14584   if (name)
14585     {
14586       if (IDENTIFIER_INVENTED (name))
14587         {
14588           DECL_ARTIFICIAL (x) = 1;
14589           DECL_IN_SYSTEM_HEADER (x) = 1;
14590         }
14591
14592       t = lookup_name_current_level (name);
14593
14594       assert ((t == NULL_TREE) || (DECL_CONTEXT (x) == NULL_TREE));
14595
14596       /* Don't push non-parms onto list for parms until we understand
14597          why we're doing this and whether it works.  */
14598
14599       assert ((b == global_binding_level)
14600               || !ffecom_transform_only_dummies_
14601               || TREE_CODE (x) == PARM_DECL);
14602
14603       if ((t != NULL_TREE) && duplicate_decls (x, t))
14604         return t;
14605
14606       /* If we are processing a typedef statement, generate a whole new
14607          ..._TYPE node (which will be just an variant of the existing
14608          ..._TYPE node with identical properties) and then install the
14609          TYPE_DECL node generated to represent the typedef name as the
14610          TYPE_NAME of this brand new (duplicate) ..._TYPE node.
14611
14612          The whole point here is to end up with a situation where each and every
14613          ..._TYPE node the compiler creates will be uniquely associated with
14614          AT MOST one node representing a typedef name. This way, even though
14615          the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL
14616          (i.e. "typedef name") nodes very early on, later parts of the
14617          compiler can always do the reverse translation and get back the
14618          corresponding typedef name.  For example, given:
14619
14620          typedef struct S MY_TYPE; MY_TYPE object;
14621
14622          Later parts of the compiler might only know that `object' was of type
14623          `struct S' if it were not for code just below.  With this code
14624          however, later parts of the compiler see something like:
14625
14626          struct S' == struct S typedef struct S' MY_TYPE; struct S' object;
14627
14628          And they can then deduce (from the node for type struct S') that the
14629          original object declaration was:
14630
14631          MY_TYPE object;
14632
14633          Being able to do this is important for proper support of protoize, and
14634          also for generating precise symbolic debugging information which
14635          takes full account of the programmer's (typedef) vocabulary.
14636
14637          Obviously, we don't want to generate a duplicate ..._TYPE node if the
14638          TYPE_DECL node that we are now processing really represents a
14639          standard built-in type.
14640
14641          Since all standard types are effectively declared at line zero in the
14642          source file, we can easily check to see if we are working on a
14643          standard type by checking the current value of lineno.  */
14644
14645       if (TREE_CODE (x) == TYPE_DECL)
14646         {
14647           if (DECL_SOURCE_LINE (x) == 0)
14648             {
14649               if (TYPE_NAME (TREE_TYPE (x)) == 0)
14650                 TYPE_NAME (TREE_TYPE (x)) = x;
14651             }
14652           else if (TREE_TYPE (x) != error_mark_node)
14653             {
14654               tree tt = TREE_TYPE (x);
14655
14656               tt = build_type_copy (tt);
14657               TYPE_NAME (tt) = x;
14658               TREE_TYPE (x) = tt;
14659             }
14660         }
14661
14662       /* This name is new in its binding level. Install the new declaration
14663          and return it.  */
14664       if (b == global_binding_level)
14665         IDENTIFIER_GLOBAL_VALUE (name) = x;
14666       else
14667         IDENTIFIER_LOCAL_VALUE (name) = x;
14668     }
14669
14670   /* Put decls on list in reverse order. We will reverse them later if
14671      necessary.  */
14672   TREE_CHAIN (x) = b->names;
14673   b->names = x;
14674
14675   return x;
14676 }
14677
14678 /* Nonzero if the current level needs to have a BLOCK made.  */
14679
14680 static int
14681 kept_level_p ()
14682 {
14683   tree decl;
14684
14685   for (decl = current_binding_level->names;
14686        decl;
14687        decl = TREE_CHAIN (decl))
14688     {
14689       if (TREE_USED (decl) || TREE_CODE (decl) != VAR_DECL
14690           || (DECL_NAME (decl) && ! DECL_ARTIFICIAL (decl)))
14691         /* Currently, there aren't supposed to be non-artificial names
14692            at other than the top block for a function -- they're
14693            believed to always be temps.  But it's wise to check anyway.  */
14694         return 1;
14695     }
14696   return 0;
14697 }
14698
14699 /* Enter a new binding level.
14700    If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
14701    not for that of tags.  */
14702
14703 void
14704 pushlevel (tag_transparent)
14705      int tag_transparent;
14706 {
14707   register struct binding_level *newlevel = NULL_BINDING_LEVEL;
14708
14709   assert (! tag_transparent);
14710
14711   if (current_binding_level == global_binding_level)
14712     {
14713       named_labels = 0;
14714     }
14715
14716   /* Reuse or create a struct for this binding level.  */
14717
14718   if (free_binding_level)
14719     {
14720       newlevel = free_binding_level;
14721       free_binding_level = free_binding_level->level_chain;
14722     }
14723   else
14724     {
14725       newlevel = make_binding_level ();
14726     }
14727
14728   /* Add this level to the front of the chain (stack) of levels that
14729      are active.  */
14730
14731   *newlevel = clear_binding_level;
14732   newlevel->level_chain = current_binding_level;
14733   current_binding_level = newlevel;
14734 }
14735
14736 /* Set the BLOCK node for the innermost scope
14737    (the one we are currently in).  */
14738
14739 void
14740 set_block (block)
14741      register tree block;
14742 {
14743   current_binding_level->this_block = block;
14744   current_binding_level->names = chainon (current_binding_level->names,
14745                                           BLOCK_VARS (block));
14746   current_binding_level->blocks = chainon (current_binding_level->blocks,
14747                                            BLOCK_SUBBLOCKS (block));
14748 }
14749
14750 static tree
14751 ffe_signed_or_unsigned_type (unsignedp, type)
14752      int unsignedp;
14753      tree type;
14754 {
14755   tree type2;
14756
14757   if (! INTEGRAL_TYPE_P (type))
14758     return type;
14759   if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node))
14760     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
14761   if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node))
14762     return unsignedp ? unsigned_type_node : integer_type_node;
14763   if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node))
14764     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
14765   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node))
14766     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
14767   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node))
14768     return (unsignedp ? long_long_unsigned_type_node
14769             : long_long_integer_type_node);
14770
14771   type2 = ffe_type_for_size (TYPE_PRECISION (type), unsignedp);
14772   if (type2 == NULL_TREE)
14773     return type;
14774
14775   return type2;
14776 }
14777
14778 static tree
14779 ffe_signed_type (type)
14780      tree type;
14781 {
14782   tree type1 = TYPE_MAIN_VARIANT (type);
14783   ffeinfoKindtype kt;
14784   tree type2;
14785
14786   if (type1 == unsigned_char_type_node || type1 == char_type_node)
14787     return signed_char_type_node;
14788   if (type1 == unsigned_type_node)
14789     return integer_type_node;
14790   if (type1 == short_unsigned_type_node)
14791     return short_integer_type_node;
14792   if (type1 == long_unsigned_type_node)
14793     return long_integer_type_node;
14794   if (type1 == long_long_unsigned_type_node)
14795     return long_long_integer_type_node;
14796 #if 0   /* gcc/c-* files only */
14797   if (type1 == unsigned_intDI_type_node)
14798     return intDI_type_node;
14799   if (type1 == unsigned_intSI_type_node)
14800     return intSI_type_node;
14801   if (type1 == unsigned_intHI_type_node)
14802     return intHI_type_node;
14803   if (type1 == unsigned_intQI_type_node)
14804     return intQI_type_node;
14805 #endif
14806
14807   type2 = ffe_type_for_size (TYPE_PRECISION (type1), 0);
14808   if (type2 != NULL_TREE)
14809     return type2;
14810
14811   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
14812     {
14813       type2 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
14814
14815       if (type1 == type2)
14816         return ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
14817     }
14818
14819   return type;
14820 }
14821
14822 /* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
14823    or validate its data type for an `if' or `while' statement or ?..: exp.
14824
14825    This preparation consists of taking the ordinary
14826    representation of an expression expr and producing a valid tree
14827    boolean expression describing whether expr is nonzero.  We could
14828    simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
14829    but we optimize comparisons, &&, ||, and !.
14830
14831    The resulting type should always be `integer_type_node'.  */
14832
14833 static tree
14834 ffe_truthvalue_conversion (expr)
14835      tree expr;
14836 {
14837   if (TREE_CODE (expr) == ERROR_MARK)
14838     return expr;
14839
14840 #if 0 /* This appears to be wrong for C++.  */
14841   /* These really should return error_mark_node after 2.4 is stable.
14842      But not all callers handle ERROR_MARK properly.  */
14843   switch (TREE_CODE (TREE_TYPE (expr)))
14844     {
14845     case RECORD_TYPE:
14846       error ("struct type value used where scalar is required");
14847       return integer_zero_node;
14848
14849     case UNION_TYPE:
14850       error ("union type value used where scalar is required");
14851       return integer_zero_node;
14852
14853     case ARRAY_TYPE:
14854       error ("array type value used where scalar is required");
14855       return integer_zero_node;
14856
14857     default:
14858       break;
14859     }
14860 #endif /* 0 */
14861
14862   switch (TREE_CODE (expr))
14863     {
14864       /* It is simpler and generates better code to have only TRUTH_*_EXPR
14865          or comparison expressions as truth values at this level.  */
14866 #if 0
14867     case COMPONENT_REF:
14868       /* A one-bit unsigned bit-field is already acceptable.  */
14869       if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr, 1)))
14870           && TREE_UNSIGNED (TREE_OPERAND (expr, 1)))
14871         return expr;
14872       break;
14873 #endif
14874
14875     case EQ_EXPR:
14876       /* It is simpler and generates better code to have only TRUTH_*_EXPR
14877          or comparison expressions as truth values at this level.  */
14878 #if 0
14879       if (integer_zerop (TREE_OPERAND (expr, 1)))
14880         return build_unary_op (TRUTH_NOT_EXPR, TREE_OPERAND (expr, 0), 0);
14881 #endif
14882     case NE_EXPR: case LE_EXPR: case GE_EXPR: case LT_EXPR: case GT_EXPR:
14883     case TRUTH_ANDIF_EXPR:
14884     case TRUTH_ORIF_EXPR:
14885     case TRUTH_AND_EXPR:
14886     case TRUTH_OR_EXPR:
14887     case TRUTH_XOR_EXPR:
14888       TREE_TYPE (expr) = integer_type_node;
14889       return expr;
14890
14891     case ERROR_MARK:
14892       return expr;
14893
14894     case INTEGER_CST:
14895       return integer_zerop (expr) ? integer_zero_node : integer_one_node;
14896
14897     case REAL_CST:
14898       return real_zerop (expr) ? integer_zero_node : integer_one_node;
14899
14900     case ADDR_EXPR:
14901       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 0)))
14902         return build (COMPOUND_EXPR, integer_type_node,
14903                       TREE_OPERAND (expr, 0), integer_one_node);
14904       else
14905         return integer_one_node;
14906
14907     case COMPLEX_EXPR:
14908       return ffecom_2 ((TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1))
14909                         ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
14910                        integer_type_node,
14911                        ffe_truthvalue_conversion (TREE_OPERAND (expr, 0)),
14912                        ffe_truthvalue_conversion (TREE_OPERAND (expr, 1)));
14913
14914     case NEGATE_EXPR:
14915     case ABS_EXPR:
14916     case FLOAT_EXPR:
14917     case FFS_EXPR:
14918       /* These don't change whether an object is non-zero or zero.  */
14919       return ffe_truthvalue_conversion (TREE_OPERAND (expr, 0));
14920
14921     case LROTATE_EXPR:
14922     case RROTATE_EXPR:
14923       /* These don't change whether an object is zero or non-zero, but
14924          we can't ignore them if their second arg has side-effects.  */
14925       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1)))
14926         return build (COMPOUND_EXPR, integer_type_node, TREE_OPERAND (expr, 1),
14927                       ffe_truthvalue_conversion (TREE_OPERAND (expr, 0)));
14928       else
14929         return ffe_truthvalue_conversion (TREE_OPERAND (expr, 0));
14930
14931     case COND_EXPR:
14932       /* Distribute the conversion into the arms of a COND_EXPR.  */
14933       return fold (build (COND_EXPR, integer_type_node, TREE_OPERAND (expr, 0),
14934                           ffe_truthvalue_conversion (TREE_OPERAND (expr, 1)),
14935                           ffe_truthvalue_conversion (TREE_OPERAND (expr, 2))));
14936
14937     case CONVERT_EXPR:
14938       /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
14939          since that affects how `default_conversion' will behave.  */
14940       if (TREE_CODE (TREE_TYPE (expr)) == REFERENCE_TYPE
14941           || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) == REFERENCE_TYPE)
14942         break;
14943       /* fall through... */
14944     case NOP_EXPR:
14945       /* If this is widening the argument, we can ignore it.  */
14946       if (TYPE_PRECISION (TREE_TYPE (expr))
14947           >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr, 0))))
14948         return ffe_truthvalue_conversion (TREE_OPERAND (expr, 0));
14949       break;
14950
14951     case MINUS_EXPR:
14952       /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize
14953          this case.  */
14954       if (TARGET_FLOAT_FORMAT == IEEE_FLOAT_FORMAT
14955           && TREE_CODE (TREE_TYPE (expr)) == REAL_TYPE)
14956         break;
14957       /* fall through... */
14958     case BIT_XOR_EXPR:
14959       /* This and MINUS_EXPR can be changed into a comparison of the
14960          two objects.  */
14961       if (TREE_TYPE (TREE_OPERAND (expr, 0))
14962           == TREE_TYPE (TREE_OPERAND (expr, 1)))
14963         return ffecom_2 (NE_EXPR, integer_type_node,
14964                          TREE_OPERAND (expr, 0),
14965                          TREE_OPERAND (expr, 1));
14966       return ffecom_2 (NE_EXPR, integer_type_node,
14967                        TREE_OPERAND (expr, 0),
14968                        fold (build1 (NOP_EXPR,
14969                                      TREE_TYPE (TREE_OPERAND (expr, 0)),
14970                                      TREE_OPERAND (expr, 1))));
14971
14972     case BIT_AND_EXPR:
14973       if (integer_onep (TREE_OPERAND (expr, 1)))
14974         return expr;
14975       break;
14976
14977     case MODIFY_EXPR:
14978 #if 0                           /* No such thing in Fortran. */
14979       if (warn_parentheses && C_EXP_ORIGINAL_CODE (expr) == MODIFY_EXPR)
14980         warning ("suggest parentheses around assignment used as truth value");
14981 #endif
14982       break;
14983
14984     default:
14985       break;
14986     }
14987
14988   if (TREE_CODE (TREE_TYPE (expr)) == COMPLEX_TYPE)
14989     return (ffecom_2
14990             ((TREE_SIDE_EFFECTS (expr)
14991               ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
14992              integer_type_node,
14993              ffe_truthvalue_conversion (ffecom_1 (REALPART_EXPR,
14994                                                   TREE_TYPE (TREE_TYPE (expr)),
14995                                                   expr)),
14996              ffe_truthvalue_conversion (ffecom_1 (IMAGPART_EXPR,
14997                                                   TREE_TYPE (TREE_TYPE (expr)),
14998                                                   expr))));
14999
15000   return ffecom_2 (NE_EXPR, integer_type_node,
15001                    expr,
15002                    convert (TREE_TYPE (expr), integer_zero_node));
15003 }
15004
15005 static tree
15006 ffe_type_for_mode (mode, unsignedp)
15007      enum machine_mode mode;
15008      int unsignedp;
15009 {
15010   int i;
15011   int j;
15012   tree t;
15013
15014   if (mode == TYPE_MODE (integer_type_node))
15015     return unsignedp ? unsigned_type_node : integer_type_node;
15016
15017   if (mode == TYPE_MODE (signed_char_type_node))
15018     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15019
15020   if (mode == TYPE_MODE (short_integer_type_node))
15021     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15022
15023   if (mode == TYPE_MODE (long_integer_type_node))
15024     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15025
15026   if (mode == TYPE_MODE (long_long_integer_type_node))
15027     return unsignedp ? long_long_unsigned_type_node : long_long_integer_type_node;
15028
15029 #if HOST_BITS_PER_WIDE_INT >= 64
15030   if (mode == TYPE_MODE (intTI_type_node))
15031     return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
15032 #endif
15033
15034   if (mode == TYPE_MODE (float_type_node))
15035     return float_type_node;
15036
15037   if (mode == TYPE_MODE (double_type_node))
15038     return double_type_node;
15039
15040   if (mode == TYPE_MODE (build_pointer_type (char_type_node)))
15041     return build_pointer_type (char_type_node);
15042
15043   if (mode == TYPE_MODE (build_pointer_type (integer_type_node)))
15044     return build_pointer_type (integer_type_node);
15045
15046   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
15047     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
15048       {
15049         if (((t = ffecom_tree_type[i][j]) != NULL_TREE)
15050             && (mode == TYPE_MODE (t)))
15051           {
15052             if ((i == FFEINFO_basictypeINTEGER) && unsignedp)
15053               return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][j];
15054             else
15055               return t;
15056           }
15057       }
15058
15059   return 0;
15060 }
15061
15062 static tree
15063 ffe_type_for_size (bits, unsignedp)
15064      unsigned bits;
15065      int unsignedp;
15066 {
15067   ffeinfoKindtype kt;
15068   tree type_node;
15069
15070   if (bits == TYPE_PRECISION (integer_type_node))
15071     return unsignedp ? unsigned_type_node : integer_type_node;
15072
15073   if (bits == TYPE_PRECISION (signed_char_type_node))
15074     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15075
15076   if (bits == TYPE_PRECISION (short_integer_type_node))
15077     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15078
15079   if (bits == TYPE_PRECISION (long_integer_type_node))
15080     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15081
15082   if (bits == TYPE_PRECISION (long_long_integer_type_node))
15083     return (unsignedp ? long_long_unsigned_type_node
15084             : long_long_integer_type_node);
15085
15086   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15087     {
15088       type_node = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15089
15090       if ((type_node != NULL_TREE) && (bits == TYPE_PRECISION (type_node)))
15091         return unsignedp ? ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]
15092           : type_node;
15093     }
15094
15095   return 0;
15096 }
15097
15098 static tree
15099 ffe_unsigned_type (type)
15100      tree type;
15101 {
15102   tree type1 = TYPE_MAIN_VARIANT (type);
15103   ffeinfoKindtype kt;
15104   tree type2;
15105
15106   if (type1 == signed_char_type_node || type1 == char_type_node)
15107     return unsigned_char_type_node;
15108   if (type1 == integer_type_node)
15109     return unsigned_type_node;
15110   if (type1 == short_integer_type_node)
15111     return short_unsigned_type_node;
15112   if (type1 == long_integer_type_node)
15113     return long_unsigned_type_node;
15114   if (type1 == long_long_integer_type_node)
15115     return long_long_unsigned_type_node;
15116 #if 0   /* gcc/c-* files only */
15117   if (type1 == intDI_type_node)
15118     return unsigned_intDI_type_node;
15119   if (type1 == intSI_type_node)
15120     return unsigned_intSI_type_node;
15121   if (type1 == intHI_type_node)
15122     return unsigned_intHI_type_node;
15123   if (type1 == intQI_type_node)
15124     return unsigned_intQI_type_node;
15125 #endif
15126
15127   type2 = ffe_type_for_size (TYPE_PRECISION (type1), 1);
15128   if (type2 != NULL_TREE)
15129     return type2;
15130
15131   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15132     {
15133       type2 = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15134
15135       if (type1 == type2)
15136         return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
15137     }
15138
15139   return type;
15140 }
15141
15142 static void
15143 ffe_mark_tree (t)
15144      tree t;
15145 {
15146   if (TREE_CODE (t) == IDENTIFIER_NODE)
15147     {
15148       struct lang_identifier *i = (struct lang_identifier *) t;
15149       ggc_mark_tree (IDENTIFIER_GLOBAL_VALUE (i));
15150       ggc_mark_tree (IDENTIFIER_LOCAL_VALUE (i));
15151       ggc_mark_tree (IDENTIFIER_LABEL_VALUE (i));
15152     }
15153   else if (TYPE_P (t) && TYPE_LANG_SPECIFIC (t))
15154     ggc_mark (TYPE_LANG_SPECIFIC (t));
15155 }
15156 \f
15157 /* From gcc/cccp.c, the code to handle -I.  */
15158
15159 /* Skip leading "./" from a directory name.
15160    This may yield the empty string, which represents the current directory.  */
15161
15162 static const char *
15163 skip_redundant_dir_prefix (const char *dir)
15164 {
15165   while (dir[0] == '.' && dir[1] == '/')
15166     for (dir += 2; *dir == '/'; dir++)
15167       continue;
15168   if (dir[0] == '.' && !dir[1])
15169     dir++;
15170   return dir;
15171 }
15172
15173 /* The file_name_map structure holds a mapping of file names for a
15174    particular directory.  This mapping is read from the file named
15175    FILE_NAME_MAP_FILE in that directory.  Such a file can be used to
15176    map filenames on a file system with severe filename restrictions,
15177    such as DOS.  The format of the file name map file is just a series
15178    of lines with two tokens on each line.  The first token is the name
15179    to map, and the second token is the actual name to use.  */
15180
15181 struct file_name_map
15182 {
15183   struct file_name_map *map_next;
15184   char *map_from;
15185   char *map_to;
15186 };
15187
15188 #define FILE_NAME_MAP_FILE "header.gcc"
15189
15190 /* Current maximum length of directory names in the search path
15191    for include files.  (Altered as we get more of them.)  */
15192
15193 static int max_include_len = 0;
15194
15195 struct file_name_list
15196   {
15197     struct file_name_list *next;
15198     char *fname;
15199     /* Mapping of file names for this directory.  */
15200     struct file_name_map *name_map;
15201     /* Non-zero if name_map is valid.  */
15202     int got_name_map;
15203   };
15204
15205 static struct file_name_list *include = NULL;   /* First dir to search */
15206 static struct file_name_list *last_include = NULL;      /* Last in chain */
15207
15208 /* I/O buffer structure.
15209    The `fname' field is nonzero for source files and #include files
15210    and for the dummy text used for -D and -U.
15211    It is zero for rescanning results of macro expansion
15212    and for expanding macro arguments.  */
15213 #define INPUT_STACK_MAX 400
15214 static struct file_buf {
15215   const char *fname;
15216   /* Filename specified with #line command.  */
15217   const char *nominal_fname;
15218   /* Record where in the search path this file was found.
15219      For #include_next.  */
15220   struct file_name_list *dir;
15221   ffewhereLine line;
15222   ffewhereColumn column;
15223 } instack[INPUT_STACK_MAX];
15224
15225 static int last_error_tick = 0;    /* Incremented each time we print it.  */
15226 static int input_file_stack_tick = 0;  /* Incremented when status changes.  */
15227
15228 /* Current nesting level of input sources.
15229    `instack[indepth]' is the level currently being read.  */
15230 static int indepth = -1;
15231
15232 typedef struct file_buf FILE_BUF;
15233
15234 /* Nonzero means -I- has been seen,
15235    so don't look for #include "foo" the source-file directory.  */
15236 static int ignore_srcdir;
15237
15238 #ifndef INCLUDE_LEN_FUDGE
15239 #define INCLUDE_LEN_FUDGE 0
15240 #endif
15241
15242 static void append_include_chain (struct file_name_list *first,
15243                                   struct file_name_list *last);
15244 static FILE *open_include_file (char *filename,
15245                                 struct file_name_list *searchptr);
15246 static void print_containing_files (ffebadSeverity sev);
15247 static char *read_filename_string (int ch, FILE *f);
15248 static struct file_name_map *read_name_map (const char *dirname);
15249
15250 /* Append a chain of `struct file_name_list's
15251    to the end of the main include chain.
15252    FIRST is the beginning of the chain to append, and LAST is the end.  */
15253
15254 static void
15255 append_include_chain (first, last)
15256      struct file_name_list *first, *last;
15257 {
15258   struct file_name_list *dir;
15259
15260   if (!first || !last)
15261     return;
15262
15263   if (include == 0)
15264     include = first;
15265   else
15266     last_include->next = first;
15267
15268   for (dir = first; ; dir = dir->next) {
15269     int len = strlen (dir->fname) + INCLUDE_LEN_FUDGE;
15270     if (len > max_include_len)
15271       max_include_len = len;
15272     if (dir == last)
15273       break;
15274   }
15275
15276   last->next = NULL;
15277   last_include = last;
15278 }
15279
15280 /* Try to open include file FILENAME.  SEARCHPTR is the directory
15281    being tried from the include file search path.  This function maps
15282    filenames on file systems based on information read by
15283    read_name_map.  */
15284
15285 static FILE *
15286 open_include_file (filename, searchptr)
15287      char *filename;
15288      struct file_name_list *searchptr;
15289 {
15290   register struct file_name_map *map;
15291   register char *from;
15292   char *p, *dir;
15293
15294   if (searchptr && ! searchptr->got_name_map)
15295     {
15296       searchptr->name_map = read_name_map (searchptr->fname
15297                                            ? searchptr->fname : ".");
15298       searchptr->got_name_map = 1;
15299     }
15300
15301   /* First check the mapping for the directory we are using.  */
15302   if (searchptr && searchptr->name_map)
15303     {
15304       from = filename;
15305       if (searchptr->fname)
15306         from += strlen (searchptr->fname) + 1;
15307       for (map = searchptr->name_map; map; map = map->map_next)
15308         {
15309           if (! strcmp (map->map_from, from))
15310             {
15311               /* Found a match.  */
15312               return fopen (map->map_to, "r");
15313             }
15314         }
15315     }
15316
15317   /* Try to find a mapping file for the particular directory we are
15318      looking in.  Thus #include <sys/types.h> will look up sys/types.h
15319      in /usr/include/header.gcc and look up types.h in
15320      /usr/include/sys/header.gcc.  */
15321   p = strrchr (filename, '/');
15322 #ifdef DIR_SEPARATOR
15323   if (! p) p = strrchr (filename, DIR_SEPARATOR);
15324   else {
15325     char *tmp = strrchr (filename, DIR_SEPARATOR);
15326     if (tmp != NULL && tmp > p) p = tmp;
15327   }
15328 #endif
15329   if (! p)
15330     p = filename;
15331   if (searchptr
15332       && searchptr->fname
15333       && strlen (searchptr->fname) == (size_t) (p - filename)
15334       && ! strncmp (searchptr->fname, filename, (int) (p - filename)))
15335     {
15336       /* FILENAME is in SEARCHPTR, which we've already checked.  */
15337       return fopen (filename, "r");
15338     }
15339
15340   if (p == filename)
15341     {
15342       from = filename;
15343       map = read_name_map (".");
15344     }
15345   else
15346     {
15347       dir = (char *) xmalloc (p - filename + 1);
15348       memcpy (dir, filename, p - filename);
15349       dir[p - filename] = '\0';
15350       from = p + 1;
15351       map = read_name_map (dir);
15352       free (dir);
15353     }
15354   for (; map; map = map->map_next)
15355     if (! strcmp (map->map_from, from))
15356       return fopen (map->map_to, "r");
15357
15358   return fopen (filename, "r");
15359 }
15360
15361 /* Print the file names and line numbers of the #include
15362    commands which led to the current file.  */
15363
15364 static void
15365 print_containing_files (ffebadSeverity sev)
15366 {
15367   FILE_BUF *ip = NULL;
15368   int i;
15369   int first = 1;
15370   const char *str1;
15371   const char *str2;
15372
15373   /* If stack of files hasn't changed since we last printed
15374      this info, don't repeat it.  */
15375   if (last_error_tick == input_file_stack_tick)
15376     return;
15377
15378   for (i = indepth; i >= 0; i--)
15379     if (instack[i].fname != NULL) {
15380       ip = &instack[i];
15381       break;
15382     }
15383
15384   /* Give up if we don't find a source file.  */
15385   if (ip == NULL)
15386     return;
15387
15388   /* Find the other, outer source files.  */
15389   for (i--; i >= 0; i--)
15390     if (instack[i].fname != NULL)
15391       {
15392         ip = &instack[i];
15393         if (first)
15394           {
15395             first = 0;
15396             str1 = "In file included";
15397           }
15398         else
15399           {
15400             str1 = "...          ...";
15401           }
15402
15403         if (i == 1)
15404           str2 = ":";
15405         else
15406           str2 = "";
15407
15408         /* xgettext:no-c-format */
15409         ffebad_start_msg ("%A from %B at %0%C", sev);
15410         ffebad_here (0, ip->line, ip->column);
15411         ffebad_string (str1);
15412         ffebad_string (ip->nominal_fname);
15413         ffebad_string (str2);
15414         ffebad_finish ();
15415       }
15416
15417   /* Record we have printed the status as of this time.  */
15418   last_error_tick = input_file_stack_tick;
15419 }
15420
15421 /* Read a space delimited string of unlimited length from a stdio
15422    file.  */
15423
15424 static char *
15425 read_filename_string (ch, f)
15426      int ch;
15427      FILE *f;
15428 {
15429   char *alloc, *set;
15430   int len;
15431
15432   len = 20;
15433   set = alloc = xmalloc (len + 1);
15434   if (! ISSPACE (ch))
15435     {
15436       *set++ = ch;
15437       while ((ch = getc (f)) != EOF && ! ISSPACE (ch))
15438         {
15439           if (set - alloc == len)
15440             {
15441               len *= 2;
15442               alloc = xrealloc (alloc, len + 1);
15443               set = alloc + len / 2;
15444             }
15445           *set++ = ch;
15446         }
15447     }
15448   *set = '\0';
15449   ungetc (ch, f);
15450   return alloc;
15451 }
15452
15453 /* Read the file name map file for DIRNAME.  */
15454
15455 static struct file_name_map *
15456 read_name_map (dirname)
15457      const char *dirname;
15458 {
15459   /* This structure holds a linked list of file name maps, one per
15460      directory.  */
15461   struct file_name_map_list
15462     {
15463       struct file_name_map_list *map_list_next;
15464       char *map_list_name;
15465       struct file_name_map *map_list_map;
15466     };
15467   static struct file_name_map_list *map_list;
15468   register struct file_name_map_list *map_list_ptr;
15469   char *name;
15470   FILE *f;
15471   size_t dirlen;
15472   int separator_needed;
15473
15474   dirname = skip_redundant_dir_prefix (dirname);
15475
15476   for (map_list_ptr = map_list; map_list_ptr;
15477        map_list_ptr = map_list_ptr->map_list_next)
15478     if (! strcmp (map_list_ptr->map_list_name, dirname))
15479       return map_list_ptr->map_list_map;
15480
15481   map_list_ptr = ((struct file_name_map_list *)
15482                   xmalloc (sizeof (struct file_name_map_list)));
15483   map_list_ptr->map_list_name = xstrdup (dirname);
15484   map_list_ptr->map_list_map = NULL;
15485
15486   dirlen = strlen (dirname);
15487   separator_needed = dirlen != 0 && dirname[dirlen - 1] != '/';
15488   name = (char *) xmalloc (dirlen + strlen (FILE_NAME_MAP_FILE) + 2);
15489   strcpy (name, dirname);
15490   name[dirlen] = '/';
15491   strcpy (name + dirlen + separator_needed, FILE_NAME_MAP_FILE);
15492   f = fopen (name, "r");
15493   free (name);
15494   if (!f)
15495     map_list_ptr->map_list_map = NULL;
15496   else
15497     {
15498       int ch;
15499
15500       while ((ch = getc (f)) != EOF)
15501         {
15502           char *from, *to;
15503           struct file_name_map *ptr;
15504
15505           if (ISSPACE (ch))
15506             continue;
15507           from = read_filename_string (ch, f);
15508           while ((ch = getc (f)) != EOF && ISSPACE (ch) && ch != '\n')
15509             ;
15510           to = read_filename_string (ch, f);
15511
15512           ptr = ((struct file_name_map *)
15513                  xmalloc (sizeof (struct file_name_map)));
15514           ptr->map_from = from;
15515
15516           /* Make the real filename absolute.  */
15517           if (*to == '/')
15518             ptr->map_to = to;
15519           else
15520             {
15521               ptr->map_to = xmalloc (dirlen + strlen (to) + 2);
15522               strcpy (ptr->map_to, dirname);
15523               ptr->map_to[dirlen] = '/';
15524               strcpy (ptr->map_to + dirlen + separator_needed, to);
15525               free (to);
15526             }
15527
15528           ptr->map_next = map_list_ptr->map_list_map;
15529           map_list_ptr->map_list_map = ptr;
15530
15531           while ((ch = getc (f)) != '\n')
15532             if (ch == EOF)
15533               break;
15534         }
15535       fclose (f);
15536     }
15537
15538   map_list_ptr->map_list_next = map_list;
15539   map_list = map_list_ptr;
15540
15541   return map_list_ptr->map_list_map;
15542 }
15543
15544 static void
15545 ffecom_file_ (const char *name)
15546 {
15547   FILE_BUF *fp;
15548
15549   /* Do partial setup of input buffer for the sake of generating
15550      early #line directives (when -g is in effect).  */
15551
15552   fp = &instack[++indepth];
15553   memset ((char *) fp, 0, sizeof (FILE_BUF));
15554   if (name == NULL)
15555     name = "";
15556   fp->nominal_fname = fp->fname = name;
15557 }
15558
15559 static void
15560 ffecom_close_include_ (FILE *f)
15561 {
15562   fclose (f);
15563
15564   indepth--;
15565   input_file_stack_tick++;
15566
15567   ffewhere_line_kill (instack[indepth].line);
15568   ffewhere_column_kill (instack[indepth].column);
15569 }
15570
15571 static int
15572 ffecom_decode_include_option_ (char *spec)
15573 {
15574   struct file_name_list *dirtmp;
15575
15576   if (! ignore_srcdir && !strcmp (spec, "-"))
15577     ignore_srcdir = 1;
15578   else
15579     {
15580       dirtmp = (struct file_name_list *)
15581         xmalloc (sizeof (struct file_name_list));
15582       dirtmp->next = 0;         /* New one goes on the end */
15583       dirtmp->fname = spec;
15584       dirtmp->got_name_map = 0;
15585       if (spec[0] == 0)
15586         error ("directory name must immediately follow -I");
15587       else
15588         append_include_chain (dirtmp, dirtmp);
15589     }
15590   return 1;
15591 }
15592
15593 /* Open INCLUDEd file.  */
15594
15595 static FILE *
15596 ffecom_open_include_ (char *name, ffewhereLine l, ffewhereColumn c)
15597 {
15598   char *fbeg = name;
15599   size_t flen = strlen (fbeg);
15600   struct file_name_list *search_start = include; /* Chain of dirs to search */
15601   struct file_name_list dsp[1]; /* First in chain, if #include "..." */
15602   struct file_name_list *searchptr = 0;
15603   char *fname;          /* Dynamically allocated fname buffer */
15604   FILE *f;
15605   FILE_BUF *fp;
15606
15607   if (flen == 0)
15608     return NULL;
15609
15610   dsp[0].fname = NULL;
15611
15612   /* If -I- was specified, don't search current dir, only spec'd ones. */
15613   if (!ignore_srcdir)
15614     {
15615       for (fp = &instack[indepth]; fp >= instack; fp--)
15616         {
15617           int n;
15618           char *ep;
15619           const char *nam;
15620
15621           if ((nam = fp->nominal_fname) != NULL)
15622             {
15623               /* Found a named file.  Figure out dir of the file,
15624                  and put it in front of the search list.  */
15625               dsp[0].next = search_start;
15626               search_start = dsp;
15627 #ifndef VMS
15628               ep = strrchr (nam, '/');
15629 #ifdef DIR_SEPARATOR
15630             if (ep == NULL) ep = strrchr (nam, DIR_SEPARATOR);
15631             else {
15632               char *tmp = strrchr (nam, DIR_SEPARATOR);
15633               if (tmp != NULL && tmp > ep) ep = tmp;
15634             }
15635 #endif
15636 #else                           /* VMS */
15637               ep = strrchr (nam, ']');
15638               if (ep == NULL) ep = strrchr (nam, '>');
15639               if (ep == NULL) ep = strrchr (nam, ':');
15640               if (ep != NULL) ep++;
15641 #endif                          /* VMS */
15642               if (ep != NULL)
15643                 {
15644                   n = ep - nam;
15645                   dsp[0].fname = (char *) xmalloc (n + 1);
15646                   strncpy (dsp[0].fname, nam, n);
15647                   dsp[0].fname[n] = '\0';
15648                   if (n + INCLUDE_LEN_FUDGE > max_include_len)
15649                     max_include_len = n + INCLUDE_LEN_FUDGE;
15650                 }
15651               else
15652                 dsp[0].fname = NULL; /* Current directory */
15653               dsp[0].got_name_map = 0;
15654               break;
15655             }
15656         }
15657     }
15658
15659   /* Allocate this permanently, because it gets stored in the definitions
15660      of macros.  */
15661   fname = xmalloc (max_include_len + flen + 4);
15662   /* + 2 above for slash and terminating null.  */
15663   /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED
15664      for g77 yet).  */
15665
15666   /* If specified file name is absolute, just open it.  */
15667
15668   if (*fbeg == '/'
15669 #ifdef DIR_SEPARATOR
15670       || *fbeg == DIR_SEPARATOR
15671 #endif
15672       )
15673     {
15674       strncpy (fname, (char *) fbeg, flen);
15675       fname[flen] = 0;
15676       f = open_include_file (fname, NULL);
15677     }
15678   else
15679     {
15680       f = NULL;
15681
15682       /* Search directory path, trying to open the file.
15683          Copy each filename tried into FNAME.  */
15684
15685       for (searchptr = search_start; searchptr; searchptr = searchptr->next)
15686         {
15687           if (searchptr->fname)
15688             {
15689               /* The empty string in a search path is ignored.
15690                  This makes it possible to turn off entirely
15691                  a standard piece of the list.  */
15692               if (searchptr->fname[0] == 0)
15693                 continue;
15694               strcpy (fname, skip_redundant_dir_prefix (searchptr->fname));
15695               if (fname[0] && fname[strlen (fname) - 1] != '/')
15696                 strcat (fname, "/");
15697               fname[strlen (fname) + flen] = 0;
15698             }
15699           else
15700             fname[0] = 0;
15701
15702           strncat (fname, fbeg, flen);
15703 #ifdef VMS
15704           /* Change this 1/2 Unix 1/2 VMS file specification into a
15705              full VMS file specification */
15706           if (searchptr->fname && (searchptr->fname[0] != 0))
15707             {
15708               /* Fix up the filename */
15709               hack_vms_include_specification (fname);
15710             }
15711           else
15712             {
15713               /* This is a normal VMS filespec, so use it unchanged.  */
15714               strncpy (fname, (char *) fbeg, flen);
15715               fname[flen] = 0;
15716 #if 0   /* Not for g77.  */
15717               /* if it's '#include filename', add the missing .h */
15718               if (strchr (fname, '.') == NULL)
15719                 strcat (fname, ".h");
15720 #endif
15721             }
15722 #endif /* VMS */
15723           f = open_include_file (fname, searchptr);
15724 #ifdef EACCES
15725           if (f == NULL && errno == EACCES)
15726             {
15727               print_containing_files (FFEBAD_severityWARNING);
15728               /* xgettext:no-c-format */
15729               ffebad_start_msg ("At %0, INCLUDE file %A exists, but is not readable",
15730                                 FFEBAD_severityWARNING);
15731               ffebad_string (fname);
15732               ffebad_here (0, l, c);
15733               ffebad_finish ();
15734             }
15735 #endif
15736           if (f != NULL)
15737             break;
15738         }
15739     }
15740
15741   if (f == NULL)
15742     {
15743       /* A file that was not found.  */
15744
15745       strncpy (fname, (char *) fbeg, flen);
15746       fname[flen] = 0;
15747       print_containing_files (ffebad_severity (FFEBAD_OPEN_INCLUDE));
15748       ffebad_start (FFEBAD_OPEN_INCLUDE);
15749       ffebad_here (0, l, c);
15750       ffebad_string (fname);
15751       ffebad_finish ();
15752     }
15753
15754   if (dsp[0].fname != NULL)
15755     free (dsp[0].fname);
15756
15757   if (f == NULL)
15758     return NULL;
15759
15760   if (indepth >= (INPUT_STACK_MAX - 1))
15761     {
15762       print_containing_files (FFEBAD_severityFATAL);
15763       /* xgettext:no-c-format */
15764       ffebad_start_msg ("At %0, INCLUDE nesting too deep",
15765                         FFEBAD_severityFATAL);
15766       ffebad_string (fname);
15767       ffebad_here (0, l, c);
15768       ffebad_finish ();
15769       return NULL;
15770     }
15771
15772   instack[indepth].line = ffewhere_line_use (l);
15773   instack[indepth].column = ffewhere_column_use (c);
15774
15775   fp = &instack[indepth + 1];
15776   memset ((char *) fp, 0, sizeof (FILE_BUF));
15777   fp->nominal_fname = fp->fname = fname;
15778   fp->dir = searchptr;
15779
15780   indepth++;
15781   input_file_stack_tick++;
15782
15783   return f;
15784 }
15785
15786 /**INDENT* (Do not reformat this comment even with -fca option.)
15787    Data-gathering files: Given the source file listed below, compiled with
15788    f2c I obtained the output file listed after that, and from the output
15789    file I derived the above code.
15790
15791 -------- (begin input file to f2c)
15792         implicit none
15793         character*10 A1,A2
15794         complex C1,C2
15795         integer I1,I2
15796         real R1,R2
15797         double precision D1,D2
15798 C
15799         call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2)
15800 c /
15801         call fooI(I1/I2)
15802         call fooR(R1/I1)
15803         call fooD(D1/I1)
15804         call fooC(C1/I1)
15805         call fooR(R1/R2)
15806         call fooD(R1/D1)
15807         call fooD(D1/D2)
15808         call fooD(D1/R1)
15809         call fooC(C1/C2)
15810         call fooC(C1/R1)
15811         call fooZ(C1/D1)
15812 c **
15813         call fooI(I1**I2)
15814         call fooR(R1**I1)
15815         call fooD(D1**I1)
15816         call fooC(C1**I1)
15817         call fooR(R1**R2)
15818         call fooD(R1**D1)
15819         call fooD(D1**D2)
15820         call fooD(D1**R1)
15821         call fooC(C1**C2)
15822         call fooC(C1**R1)
15823         call fooZ(C1**D1)
15824 c FFEINTRIN_impABS
15825         call fooR(ABS(R1))
15826 c FFEINTRIN_impACOS
15827         call fooR(ACOS(R1))
15828 c FFEINTRIN_impAIMAG
15829         call fooR(AIMAG(C1))
15830 c FFEINTRIN_impAINT
15831         call fooR(AINT(R1))
15832 c FFEINTRIN_impALOG
15833         call fooR(ALOG(R1))
15834 c FFEINTRIN_impALOG10
15835         call fooR(ALOG10(R1))
15836 c FFEINTRIN_impAMAX0
15837         call fooR(AMAX0(I1,I2))
15838 c FFEINTRIN_impAMAX1
15839         call fooR(AMAX1(R1,R2))
15840 c FFEINTRIN_impAMIN0
15841         call fooR(AMIN0(I1,I2))
15842 c FFEINTRIN_impAMIN1
15843         call fooR(AMIN1(R1,R2))
15844 c FFEINTRIN_impAMOD
15845         call fooR(AMOD(R1,R2))
15846 c FFEINTRIN_impANINT
15847         call fooR(ANINT(R1))
15848 c FFEINTRIN_impASIN
15849         call fooR(ASIN(R1))
15850 c FFEINTRIN_impATAN
15851         call fooR(ATAN(R1))
15852 c FFEINTRIN_impATAN2
15853         call fooR(ATAN2(R1,R2))
15854 c FFEINTRIN_impCABS
15855         call fooR(CABS(C1))
15856 c FFEINTRIN_impCCOS
15857         call fooC(CCOS(C1))
15858 c FFEINTRIN_impCEXP
15859         call fooC(CEXP(C1))
15860 c FFEINTRIN_impCHAR
15861         call fooA(CHAR(I1))
15862 c FFEINTRIN_impCLOG
15863         call fooC(CLOG(C1))
15864 c FFEINTRIN_impCONJG
15865         call fooC(CONJG(C1))
15866 c FFEINTRIN_impCOS
15867         call fooR(COS(R1))
15868 c FFEINTRIN_impCOSH
15869         call fooR(COSH(R1))
15870 c FFEINTRIN_impCSIN
15871         call fooC(CSIN(C1))
15872 c FFEINTRIN_impCSQRT
15873         call fooC(CSQRT(C1))
15874 c FFEINTRIN_impDABS
15875         call fooD(DABS(D1))
15876 c FFEINTRIN_impDACOS
15877         call fooD(DACOS(D1))
15878 c FFEINTRIN_impDASIN
15879         call fooD(DASIN(D1))
15880 c FFEINTRIN_impDATAN
15881         call fooD(DATAN(D1))
15882 c FFEINTRIN_impDATAN2
15883         call fooD(DATAN2(D1,D2))
15884 c FFEINTRIN_impDCOS
15885         call fooD(DCOS(D1))
15886 c FFEINTRIN_impDCOSH
15887         call fooD(DCOSH(D1))
15888 c FFEINTRIN_impDDIM
15889         call fooD(DDIM(D1,D2))
15890 c FFEINTRIN_impDEXP
15891         call fooD(DEXP(D1))
15892 c FFEINTRIN_impDIM
15893         call fooR(DIM(R1,R2))
15894 c FFEINTRIN_impDINT
15895         call fooD(DINT(D1))
15896 c FFEINTRIN_impDLOG
15897         call fooD(DLOG(D1))
15898 c FFEINTRIN_impDLOG10
15899         call fooD(DLOG10(D1))
15900 c FFEINTRIN_impDMAX1
15901         call fooD(DMAX1(D1,D2))
15902 c FFEINTRIN_impDMIN1
15903         call fooD(DMIN1(D1,D2))
15904 c FFEINTRIN_impDMOD
15905         call fooD(DMOD(D1,D2))
15906 c FFEINTRIN_impDNINT
15907         call fooD(DNINT(D1))
15908 c FFEINTRIN_impDPROD
15909         call fooD(DPROD(R1,R2))
15910 c FFEINTRIN_impDSIGN
15911         call fooD(DSIGN(D1,D2))
15912 c FFEINTRIN_impDSIN
15913         call fooD(DSIN(D1))
15914 c FFEINTRIN_impDSINH
15915         call fooD(DSINH(D1))
15916 c FFEINTRIN_impDSQRT
15917         call fooD(DSQRT(D1))
15918 c FFEINTRIN_impDTAN
15919         call fooD(DTAN(D1))
15920 c FFEINTRIN_impDTANH
15921         call fooD(DTANH(D1))
15922 c FFEINTRIN_impEXP
15923         call fooR(EXP(R1))
15924 c FFEINTRIN_impIABS
15925         call fooI(IABS(I1))
15926 c FFEINTRIN_impICHAR
15927         call fooI(ICHAR(A1))
15928 c FFEINTRIN_impIDIM
15929         call fooI(IDIM(I1,I2))
15930 c FFEINTRIN_impIDNINT
15931         call fooI(IDNINT(D1))
15932 c FFEINTRIN_impINDEX
15933         call fooI(INDEX(A1,A2))
15934 c FFEINTRIN_impISIGN
15935         call fooI(ISIGN(I1,I2))
15936 c FFEINTRIN_impLEN
15937         call fooI(LEN(A1))
15938 c FFEINTRIN_impLGE
15939         call fooL(LGE(A1,A2))
15940 c FFEINTRIN_impLGT
15941         call fooL(LGT(A1,A2))
15942 c FFEINTRIN_impLLE
15943         call fooL(LLE(A1,A2))
15944 c FFEINTRIN_impLLT
15945         call fooL(LLT(A1,A2))
15946 c FFEINTRIN_impMAX0
15947         call fooI(MAX0(I1,I2))
15948 c FFEINTRIN_impMAX1
15949         call fooI(MAX1(R1,R2))
15950 c FFEINTRIN_impMIN0
15951         call fooI(MIN0(I1,I2))
15952 c FFEINTRIN_impMIN1
15953         call fooI(MIN1(R1,R2))
15954 c FFEINTRIN_impMOD
15955         call fooI(MOD(I1,I2))
15956 c FFEINTRIN_impNINT
15957         call fooI(NINT(R1))
15958 c FFEINTRIN_impSIGN
15959         call fooR(SIGN(R1,R2))
15960 c FFEINTRIN_impSIN
15961         call fooR(SIN(R1))
15962 c FFEINTRIN_impSINH
15963         call fooR(SINH(R1))
15964 c FFEINTRIN_impSQRT
15965         call fooR(SQRT(R1))
15966 c FFEINTRIN_impTAN
15967         call fooR(TAN(R1))
15968 c FFEINTRIN_impTANH
15969         call fooR(TANH(R1))
15970 c FFEINTRIN_imp_CMPLX_C
15971         call fooC(cmplx(C1,C2))
15972 c FFEINTRIN_imp_CMPLX_D
15973         call fooZ(cmplx(D1,D2))
15974 c FFEINTRIN_imp_CMPLX_I
15975         call fooC(cmplx(I1,I2))
15976 c FFEINTRIN_imp_CMPLX_R
15977         call fooC(cmplx(R1,R2))
15978 c FFEINTRIN_imp_DBLE_C
15979         call fooD(dble(C1))
15980 c FFEINTRIN_imp_DBLE_D
15981         call fooD(dble(D1))
15982 c FFEINTRIN_imp_DBLE_I
15983         call fooD(dble(I1))
15984 c FFEINTRIN_imp_DBLE_R
15985         call fooD(dble(R1))
15986 c FFEINTRIN_imp_INT_C
15987         call fooI(int(C1))
15988 c FFEINTRIN_imp_INT_D
15989         call fooI(int(D1))
15990 c FFEINTRIN_imp_INT_I
15991         call fooI(int(I1))
15992 c FFEINTRIN_imp_INT_R
15993         call fooI(int(R1))
15994 c FFEINTRIN_imp_REAL_C
15995         call fooR(real(C1))
15996 c FFEINTRIN_imp_REAL_D
15997         call fooR(real(D1))
15998 c FFEINTRIN_imp_REAL_I
15999         call fooR(real(I1))
16000 c FFEINTRIN_imp_REAL_R
16001         call fooR(real(R1))
16002 c
16003 c FFEINTRIN_imp_INT_D:
16004 c
16005 c FFEINTRIN_specIDINT
16006         call fooI(IDINT(D1))
16007 c
16008 c FFEINTRIN_imp_INT_R:
16009 c
16010 c FFEINTRIN_specIFIX
16011         call fooI(IFIX(R1))
16012 c FFEINTRIN_specINT
16013         call fooI(INT(R1))
16014 c
16015 c FFEINTRIN_imp_REAL_D:
16016 c
16017 c FFEINTRIN_specSNGL
16018         call fooR(SNGL(D1))
16019 c
16020 c FFEINTRIN_imp_REAL_I:
16021 c
16022 c FFEINTRIN_specFLOAT
16023         call fooR(FLOAT(I1))
16024 c FFEINTRIN_specREAL
16025         call fooR(REAL(I1))
16026 c
16027         end
16028 -------- (end input file to f2c)
16029
16030 -------- (begin output from providing above input file as input to:
16031 --------  `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
16032 --------     -e "s:^#.*$::g"')
16033
16034 //  -- translated by f2c (version 19950223).
16035    You must link the resulting object file with the libraries:
16036         -lf2c -lm   (in that order)
16037 //
16038
16039
16040 // f2c.h  --  Standard Fortran to C header file //
16041
16042 ///  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
16043
16044         - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
16045
16046
16047
16048
16049 // F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems //
16050 // we assume short, float are OK //
16051 typedef long int // long int // integer;
16052 typedef char *address;
16053 typedef short int shortint;
16054 typedef float real;
16055 typedef double doublereal;
16056 typedef struct { real r, i; } complex;
16057 typedef struct { doublereal r, i; } doublecomplex;
16058 typedef long int // long int // logical;
16059 typedef short int shortlogical;
16060 typedef char logical1;
16061 typedef char integer1;
16062 // typedef long long longint; // // system-dependent //
16063
16064
16065
16066
16067 // Extern is for use with -E //
16068
16069
16070
16071
16072 // I/O stuff //
16073
16074
16075
16076
16077
16078
16079
16080
16081 typedef long int // int or long int // flag;
16082 typedef long int // int or long int // ftnlen;
16083 typedef long int // int or long int // ftnint;
16084
16085
16086 //external read, write//
16087 typedef struct
16088 {       flag cierr;
16089         ftnint ciunit;
16090         flag ciend;
16091         char *cifmt;
16092         ftnint cirec;
16093 } cilist;
16094
16095 //internal read, write//
16096 typedef struct
16097 {       flag icierr;
16098         char *iciunit;
16099         flag iciend;
16100         char *icifmt;
16101         ftnint icirlen;
16102         ftnint icirnum;
16103 } icilist;
16104
16105 //open//
16106 typedef struct
16107 {       flag oerr;
16108         ftnint ounit;
16109         char *ofnm;
16110         ftnlen ofnmlen;
16111         char *osta;
16112         char *oacc;
16113         char *ofm;
16114         ftnint orl;
16115         char *oblnk;
16116 } olist;
16117
16118 //close//
16119 typedef struct
16120 {       flag cerr;
16121         ftnint cunit;
16122         char *csta;
16123 } cllist;
16124
16125 //rewind, backspace, endfile//
16126 typedef struct
16127 {       flag aerr;
16128         ftnint aunit;
16129 } alist;
16130
16131 // inquire //
16132 typedef struct
16133 {       flag inerr;
16134         ftnint inunit;
16135         char *infile;
16136         ftnlen infilen;
16137         ftnint  *inex;  //parameters in standard's order//
16138         ftnint  *inopen;
16139         ftnint  *innum;
16140         ftnint  *innamed;
16141         char    *inname;
16142         ftnlen  innamlen;
16143         char    *inacc;
16144         ftnlen  inacclen;
16145         char    *inseq;
16146         ftnlen  inseqlen;
16147         char    *indir;
16148         ftnlen  indirlen;
16149         char    *infmt;
16150         ftnlen  infmtlen;
16151         char    *inform;
16152         ftnint  informlen;
16153         char    *inunf;
16154         ftnlen  inunflen;
16155         ftnint  *inrecl;
16156         ftnint  *innrec;
16157         char    *inblank;
16158         ftnlen  inblanklen;
16159 } inlist;
16160
16161
16162
16163 union Multitype {       // for multiple entry points //
16164         integer1 g;
16165         shortint h;
16166         integer i;
16167         // longint j; //
16168         real r;
16169         doublereal d;
16170         complex c;
16171         doublecomplex z;
16172         };
16173
16174 typedef union Multitype Multitype;
16175
16176 typedef long Long;      // No longer used; formerly in Namelist //
16177
16178 struct Vardesc {        // for Namelist //
16179         char *name;
16180         char *addr;
16181         ftnlen *dims;
16182         int  type;
16183         };
16184 typedef struct Vardesc Vardesc;
16185
16186 struct Namelist {
16187         char *name;
16188         Vardesc **vars;
16189         int nvars;
16190         };
16191 typedef struct Namelist Namelist;
16192
16193
16194
16195
16196
16197
16198
16199
16200 // procedure parameter types for -A and -C++ //
16201
16202
16203
16204
16205 typedef int // Unknown procedure type // (*U_fp)();
16206 typedef shortint (*J_fp)();
16207 typedef integer (*I_fp)();
16208 typedef real (*R_fp)();
16209 typedef doublereal (*D_fp)(), (*E_fp)();
16210 typedef // Complex // void  (*C_fp)();
16211 typedef // Double Complex // void  (*Z_fp)();
16212 typedef logical (*L_fp)();
16213 typedef shortlogical (*K_fp)();
16214 typedef // Character // void  (*H_fp)();
16215 typedef // Subroutine // int (*S_fp)();
16216
16217 // E_fp is for real functions when -R is not specified //
16218 typedef void  C_f;      // complex function //
16219 typedef void  H_f;      // character function //
16220 typedef void  Z_f;      // double complex function //
16221 typedef doublereal E_f; // real function with -R not specified //
16222
16223 // undef any lower-case symbols that your C compiler predefines, e.g.: //
16224
16225
16226 // (No such symbols should be defined in a strict ANSI C compiler.
16227    We can avoid trouble with f2c-translated code by using
16228    gcc -ansi.) //
16229
16230
16231
16232
16233
16234
16235
16236
16237
16238
16239
16240
16241
16242
16243
16244
16245
16246
16247
16248
16249
16250
16251
16252 // Main program // MAIN__()
16253 {
16254     // System generated locals //
16255     integer i__1;
16256     real r__1, r__2;
16257     doublereal d__1, d__2;
16258     complex q__1;
16259     doublecomplex z__1, z__2, z__3;
16260     logical L__1;
16261     char ch__1[1];
16262
16263     // Builtin functions //
16264     void c_div();
16265     integer pow_ii();
16266     double pow_ri(), pow_di();
16267     void pow_ci();
16268     double pow_dd();
16269     void pow_zz();
16270     double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
16271             asin(), atan(), atan2(), c_abs();
16272     void c_cos(), c_exp(), c_log(), r_cnjg();
16273     double cos(), cosh();
16274     void c_sin(), c_sqrt();
16275     double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
16276             d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
16277     integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
16278     logical l_ge(), l_gt(), l_le(), l_lt();
16279     integer i_nint();
16280     double r_sign();
16281
16282     // Local variables //
16283     extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
16284             fool_(), fooz_(), getem_();
16285     static char a1[10], a2[10];
16286     static complex c1, c2;
16287     static doublereal d1, d2;
16288     static integer i1, i2;
16289     static real r1, r2;
16290
16291
16292     getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L);
16293 // / //
16294     i__1 = i1 / i2;
16295     fooi_(&i__1);
16296     r__1 = r1 / i1;
16297     foor_(&r__1);
16298     d__1 = d1 / i1;
16299     food_(&d__1);
16300     d__1 = (doublereal) i1;
16301     q__1.r = c1.r / d__1, q__1.i = c1.i / d__1;
16302     fooc_(&q__1);
16303     r__1 = r1 / r2;
16304     foor_(&r__1);
16305     d__1 = r1 / d1;
16306     food_(&d__1);
16307     d__1 = d1 / d2;
16308     food_(&d__1);
16309     d__1 = d1 / r1;
16310     food_(&d__1);
16311     c_div(&q__1, &c1, &c2);
16312     fooc_(&q__1);
16313     q__1.r = c1.r / r1, q__1.i = c1.i / r1;
16314     fooc_(&q__1);
16315     z__1.r = c1.r / d1, z__1.i = c1.i / d1;
16316     fooz_(&z__1);
16317 // ** //
16318     i__1 = pow_ii(&i1, &i2);
16319     fooi_(&i__1);
16320     r__1 = pow_ri(&r1, &i1);
16321     foor_(&r__1);
16322     d__1 = pow_di(&d1, &i1);
16323     food_(&d__1);
16324     pow_ci(&q__1, &c1, &i1);
16325     fooc_(&q__1);
16326     d__1 = (doublereal) r1;
16327     d__2 = (doublereal) r2;
16328     r__1 = pow_dd(&d__1, &d__2);
16329     foor_(&r__1);
16330     d__2 = (doublereal) r1;
16331     d__1 = pow_dd(&d__2, &d1);
16332     food_(&d__1);
16333     d__1 = pow_dd(&d1, &d2);
16334     food_(&d__1);
16335     d__2 = (doublereal) r1;
16336     d__1 = pow_dd(&d1, &d__2);
16337     food_(&d__1);
16338     z__2.r = c1.r, z__2.i = c1.i;
16339     z__3.r = c2.r, z__3.i = c2.i;
16340     pow_zz(&z__1, &z__2, &z__3);
16341     q__1.r = z__1.r, q__1.i = z__1.i;
16342     fooc_(&q__1);
16343     z__2.r = c1.r, z__2.i = c1.i;
16344     z__3.r = r1, z__3.i = 0.;
16345     pow_zz(&z__1, &z__2, &z__3);
16346     q__1.r = z__1.r, q__1.i = z__1.i;
16347     fooc_(&q__1);
16348     z__2.r = c1.r, z__2.i = c1.i;
16349     z__3.r = d1, z__3.i = 0.;
16350     pow_zz(&z__1, &z__2, &z__3);
16351     fooz_(&z__1);
16352 // FFEINTRIN_impABS //
16353     r__1 = (doublereal)((  r1  ) >= 0 ? (  r1  ) : -(  r1  ))  ;
16354     foor_(&r__1);
16355 // FFEINTRIN_impACOS //
16356     r__1 = acos(r1);
16357     foor_(&r__1);
16358 // FFEINTRIN_impAIMAG //
16359     r__1 = r_imag(&c1);
16360     foor_(&r__1);
16361 // FFEINTRIN_impAINT //
16362     r__1 = r_int(&r1);
16363     foor_(&r__1);
16364 // FFEINTRIN_impALOG //
16365     r__1 = log(r1);
16366     foor_(&r__1);
16367 // FFEINTRIN_impALOG10 //
16368     r__1 = r_lg10(&r1);
16369     foor_(&r__1);
16370 // FFEINTRIN_impAMAX0 //
16371     r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16372     foor_(&r__1);
16373 // FFEINTRIN_impAMAX1 //
16374     r__1 = (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16375     foor_(&r__1);
16376 // FFEINTRIN_impAMIN0 //
16377     r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16378     foor_(&r__1);
16379 // FFEINTRIN_impAMIN1 //
16380     r__1 = (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16381     foor_(&r__1);
16382 // FFEINTRIN_impAMOD //
16383     r__1 = r_mod(&r1, &r2);
16384     foor_(&r__1);
16385 // FFEINTRIN_impANINT //
16386     r__1 = r_nint(&r1);
16387     foor_(&r__1);
16388 // FFEINTRIN_impASIN //
16389     r__1 = asin(r1);
16390     foor_(&r__1);
16391 // FFEINTRIN_impATAN //
16392     r__1 = atan(r1);
16393     foor_(&r__1);
16394 // FFEINTRIN_impATAN2 //
16395     r__1 = atan2(r1, r2);
16396     foor_(&r__1);
16397 // FFEINTRIN_impCABS //
16398     r__1 = c_abs(&c1);
16399     foor_(&r__1);
16400 // FFEINTRIN_impCCOS //
16401     c_cos(&q__1, &c1);
16402     fooc_(&q__1);
16403 // FFEINTRIN_impCEXP //
16404     c_exp(&q__1, &c1);
16405     fooc_(&q__1);
16406 // FFEINTRIN_impCHAR //
16407     *(unsigned char *)&ch__1[0] = i1;
16408     fooa_(ch__1, 1L);
16409 // FFEINTRIN_impCLOG //
16410     c_log(&q__1, &c1);
16411     fooc_(&q__1);
16412 // FFEINTRIN_impCONJG //
16413     r_cnjg(&q__1, &c1);
16414     fooc_(&q__1);
16415 // FFEINTRIN_impCOS //
16416     r__1 = cos(r1);
16417     foor_(&r__1);
16418 // FFEINTRIN_impCOSH //
16419     r__1 = cosh(r1);
16420     foor_(&r__1);
16421 // FFEINTRIN_impCSIN //
16422     c_sin(&q__1, &c1);
16423     fooc_(&q__1);
16424 // FFEINTRIN_impCSQRT //
16425     c_sqrt(&q__1, &c1);
16426     fooc_(&q__1);
16427 // FFEINTRIN_impDABS //
16428     d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ;
16429     food_(&d__1);
16430 // FFEINTRIN_impDACOS //
16431     d__1 = acos(d1);
16432     food_(&d__1);
16433 // FFEINTRIN_impDASIN //
16434     d__1 = asin(d1);
16435     food_(&d__1);
16436 // FFEINTRIN_impDATAN //
16437     d__1 = atan(d1);
16438     food_(&d__1);
16439 // FFEINTRIN_impDATAN2 //
16440     d__1 = atan2(d1, d2);
16441     food_(&d__1);
16442 // FFEINTRIN_impDCOS //
16443     d__1 = cos(d1);
16444     food_(&d__1);
16445 // FFEINTRIN_impDCOSH //
16446     d__1 = cosh(d1);
16447     food_(&d__1);
16448 // FFEINTRIN_impDDIM //
16449     d__1 = d_dim(&d1, &d2);
16450     food_(&d__1);
16451 // FFEINTRIN_impDEXP //
16452     d__1 = exp(d1);
16453     food_(&d__1);
16454 // FFEINTRIN_impDIM //
16455     r__1 = r_dim(&r1, &r2);
16456     foor_(&r__1);
16457 // FFEINTRIN_impDINT //
16458     d__1 = d_int(&d1);
16459     food_(&d__1);
16460 // FFEINTRIN_impDLOG //
16461     d__1 = log(d1);
16462     food_(&d__1);
16463 // FFEINTRIN_impDLOG10 //
16464     d__1 = d_lg10(&d1);
16465     food_(&d__1);
16466 // FFEINTRIN_impDMAX1 //
16467     d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ;
16468     food_(&d__1);
16469 // FFEINTRIN_impDMIN1 //
16470     d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ;
16471     food_(&d__1);
16472 // FFEINTRIN_impDMOD //
16473     d__1 = d_mod(&d1, &d2);
16474     food_(&d__1);
16475 // FFEINTRIN_impDNINT //
16476     d__1 = d_nint(&d1);
16477     food_(&d__1);
16478 // FFEINTRIN_impDPROD //
16479     d__1 = (doublereal) r1 * r2;
16480     food_(&d__1);
16481 // FFEINTRIN_impDSIGN //
16482     d__1 = d_sign(&d1, &d2);
16483     food_(&d__1);
16484 // FFEINTRIN_impDSIN //
16485     d__1 = sin(d1);
16486     food_(&d__1);
16487 // FFEINTRIN_impDSINH //
16488     d__1 = sinh(d1);
16489     food_(&d__1);
16490 // FFEINTRIN_impDSQRT //
16491     d__1 = sqrt(d1);
16492     food_(&d__1);
16493 // FFEINTRIN_impDTAN //
16494     d__1 = tan(d1);
16495     food_(&d__1);
16496 // FFEINTRIN_impDTANH //
16497     d__1 = tanh(d1);
16498     food_(&d__1);
16499 // FFEINTRIN_impEXP //
16500     r__1 = exp(r1);
16501     foor_(&r__1);
16502 // FFEINTRIN_impIABS //
16503     i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ;
16504     fooi_(&i__1);
16505 // FFEINTRIN_impICHAR //
16506     i__1 = *(unsigned char *)a1;
16507     fooi_(&i__1);
16508 // FFEINTRIN_impIDIM //
16509     i__1 = i_dim(&i1, &i2);
16510     fooi_(&i__1);
16511 // FFEINTRIN_impIDNINT //
16512     i__1 = i_dnnt(&d1);
16513     fooi_(&i__1);
16514 // FFEINTRIN_impINDEX //
16515     i__1 = i_indx(a1, a2, 10L, 10L);
16516     fooi_(&i__1);
16517 // FFEINTRIN_impISIGN //
16518     i__1 = i_sign(&i1, &i2);
16519     fooi_(&i__1);
16520 // FFEINTRIN_impLEN //
16521     i__1 = i_len(a1, 10L);
16522     fooi_(&i__1);
16523 // FFEINTRIN_impLGE //
16524     L__1 = l_ge(a1, a2, 10L, 10L);
16525     fool_(&L__1);
16526 // FFEINTRIN_impLGT //
16527     L__1 = l_gt(a1, a2, 10L, 10L);
16528     fool_(&L__1);
16529 // FFEINTRIN_impLLE //
16530     L__1 = l_le(a1, a2, 10L, 10L);
16531     fool_(&L__1);
16532 // FFEINTRIN_impLLT //
16533     L__1 = l_lt(a1, a2, 10L, 10L);
16534     fool_(&L__1);
16535 // FFEINTRIN_impMAX0 //
16536     i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16537     fooi_(&i__1);
16538 // FFEINTRIN_impMAX1 //
16539     i__1 = (integer) (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16540     fooi_(&i__1);
16541 // FFEINTRIN_impMIN0 //
16542     i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16543     fooi_(&i__1);
16544 // FFEINTRIN_impMIN1 //
16545     i__1 = (integer) (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16546     fooi_(&i__1);
16547 // FFEINTRIN_impMOD //
16548     i__1 = i1 % i2;
16549     fooi_(&i__1);
16550 // FFEINTRIN_impNINT //
16551     i__1 = i_nint(&r1);
16552     fooi_(&i__1);
16553 // FFEINTRIN_impSIGN //
16554     r__1 = r_sign(&r1, &r2);
16555     foor_(&r__1);
16556 // FFEINTRIN_impSIN //
16557     r__1 = sin(r1);
16558     foor_(&r__1);
16559 // FFEINTRIN_impSINH //
16560     r__1 = sinh(r1);
16561     foor_(&r__1);
16562 // FFEINTRIN_impSQRT //
16563     r__1 = sqrt(r1);
16564     foor_(&r__1);
16565 // FFEINTRIN_impTAN //
16566     r__1 = tan(r1);
16567     foor_(&r__1);
16568 // FFEINTRIN_impTANH //
16569     r__1 = tanh(r1);
16570     foor_(&r__1);
16571 // FFEINTRIN_imp_CMPLX_C //
16572     r__1 = c1.r;
16573     r__2 = c2.r;
16574     q__1.r = r__1, q__1.i = r__2;
16575     fooc_(&q__1);
16576 // FFEINTRIN_imp_CMPLX_D //
16577     z__1.r = d1, z__1.i = d2;
16578     fooz_(&z__1);
16579 // FFEINTRIN_imp_CMPLX_I //
16580     r__1 = (real) i1;
16581     r__2 = (real) i2;
16582     q__1.r = r__1, q__1.i = r__2;
16583     fooc_(&q__1);
16584 // FFEINTRIN_imp_CMPLX_R //
16585     q__1.r = r1, q__1.i = r2;
16586     fooc_(&q__1);
16587 // FFEINTRIN_imp_DBLE_C //
16588     d__1 = (doublereal) c1.r;
16589     food_(&d__1);
16590 // FFEINTRIN_imp_DBLE_D //
16591     d__1 = d1;
16592     food_(&d__1);
16593 // FFEINTRIN_imp_DBLE_I //
16594     d__1 = (doublereal) i1;
16595     food_(&d__1);
16596 // FFEINTRIN_imp_DBLE_R //
16597     d__1 = (doublereal) r1;
16598     food_(&d__1);
16599 // FFEINTRIN_imp_INT_C //
16600     i__1 = (integer) c1.r;
16601     fooi_(&i__1);
16602 // FFEINTRIN_imp_INT_D //
16603     i__1 = (integer) d1;
16604     fooi_(&i__1);
16605 // FFEINTRIN_imp_INT_I //
16606     i__1 = i1;
16607     fooi_(&i__1);
16608 // FFEINTRIN_imp_INT_R //
16609     i__1 = (integer) r1;
16610     fooi_(&i__1);
16611 // FFEINTRIN_imp_REAL_C //
16612     r__1 = c1.r;
16613     foor_(&r__1);
16614 // FFEINTRIN_imp_REAL_D //
16615     r__1 = (real) d1;
16616     foor_(&r__1);
16617 // FFEINTRIN_imp_REAL_I //
16618     r__1 = (real) i1;
16619     foor_(&r__1);
16620 // FFEINTRIN_imp_REAL_R //
16621     r__1 = r1;
16622     foor_(&r__1);
16623
16624 // FFEINTRIN_imp_INT_D: //
16625
16626 // FFEINTRIN_specIDINT //
16627     i__1 = (integer) d1;
16628     fooi_(&i__1);
16629
16630 // FFEINTRIN_imp_INT_R: //
16631
16632 // FFEINTRIN_specIFIX //
16633     i__1 = (integer) r1;
16634     fooi_(&i__1);
16635 // FFEINTRIN_specINT //
16636     i__1 = (integer) r1;
16637     fooi_(&i__1);
16638
16639 // FFEINTRIN_imp_REAL_D: //
16640
16641 // FFEINTRIN_specSNGL //
16642     r__1 = (real) d1;
16643     foor_(&r__1);
16644
16645 // FFEINTRIN_imp_REAL_I: //
16646
16647 // FFEINTRIN_specFLOAT //
16648     r__1 = (real) i1;
16649     foor_(&r__1);
16650 // FFEINTRIN_specREAL //
16651     r__1 = (real) i1;
16652     foor_(&r__1);
16653
16654 } // MAIN__ //
16655
16656 -------- (end output file from f2c)
16657
16658 */