gcc/f/com.c

   1 /* com.c -- Implementation File (module.c template V1.0)
   2    Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003
   3    Free Software Foundation, Inc.
   4    Contributed by James Craig Burley.
   5
   6 This file is part of GNU Fortran.
   7
   8 GNU Fortran is free software; you can redistribute it and/or modify
   9 it under the terms of the GNU General Public License as published by
  10 the Free Software Foundation; either version 2, or (at your option)
  11 any later version.
  12
  13 GNU Fortran is distributed in the hope that it will be useful,
  14 but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 GNU General Public License for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with GNU Fortran; see the file COPYING.  If not, write to
  20 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
  21 02111-1307, USA.
  22
  23    Related Modules:
  24       None
  25
  26    Description:
  27       Contains compiler-specific functions.
  28
  29    Modifications:
  30 */
  31
  32 /* Understanding this module means understanding the interface between
  33    the g77 front end and the gcc back end (or, perhaps, some other
  34    back end).  In here are the functions called by the front end proper
  35    to notify whatever back end is in place about certain things, and
  36    also the back-end-specific functions.  It's a bear to deal with, so
  37    lately I've been trying to simplify things, especially with regard
  38    to the gcc-back-end-specific stuff.
  39
  40    Building expressions generally seems quite easy, but building decls
  41    has been challenging and is undergoing revision.  gcc has several
  42    kinds of decls:
  43
  44    TYPE_DECL -- a type (int, float, struct, function, etc.)
  45    CONST_DECL -- a constant of some type other than function
  46    LABEL_DECL -- a variable or a constant?
  47    PARM_DECL -- an argument to a function (a variable that is a dummy)
  48    RESULT_DECL -- the return value of a function (a variable)
  49    VAR_DECL -- other variable (can hold a ptr-to-function, struct, int, etc.)
  50    FUNCTION_DECL -- a function (either the actual function or an extern ref)
  51    FIELD_DECL -- a field in a struct or union (goes into types)
  52
  53    g77 has a set of functions that somewhat parallels the gcc front end
  54    when it comes to building decls:
  55
  56    Internal Function (one we define, not just declare as extern):
  57    if (is_nested) push_f_function_context ();
  58    start_function (get_identifier ("function_name"), function_type,
  59                    is_nested, is_public);
  60    // for each arg, build PARM_DECL and call push_parm_decl (decl) with it;
  61    store_parm_decls (is_main_program);
  62    ffecom_start_compstmt ();
  63    // for stmts and decls inside function, do appropriate things;
  64    ffecom_end_compstmt ();
  65    finish_function (is_nested);
  66    if (is_nested) pop_f_function_context ();
  67
  68    Everything Else:
  69    tree d;
  70    tree init;
  71    // fill in external, public, static, &c for decl, and
  72    // set DECL_INITIAL to error_mark_node if going to initialize
  73    // set is_top_level TRUE only if not at top level and decl
  74    // must go in top level (i.e. not within current function decl context)
  75    d = start_decl (decl, is_top_level);
  76    init = ...;  // if have initializer
  77    finish_decl (d, init, is_top_level);
  78
  79 */
  80
  81 /* Include files. */
  82
  83 #include "proj.h"
  84 #include "flags.h"
  85 #include "real.h"
  86 #include "rtl.h"
  87 #include "toplev.h"
  88 #include "tree.h"
  89 #include "output.h"  /* Must follow tree.h so TREE_CODE is defined! */
  90 #include "convert.h"
  91 #include "ggc.h"
  92 #include "diagnostic.h"
  93 #include "intl.h"
  94 #include "langhooks.h"
  95 #include "langhooks-def.h"
  96 #include "debug.h"
  97
  98 /* VMS-specific definitions */
  99 #ifdef VMS
 100 #include <descrip.h>
 101 #define O_RDONLY        0       /* Open arg for Read/Only  */
 102 #define O_WRONLY        1       /* Open arg for Write/Only */
 103 #define read(fd,buf,size)       VMS_read (fd,buf,size)
 104 #define write(fd,buf,size)      VMS_write (fd,buf,size)
 105 #define open(fname,mode,prot)   VMS_open (fname,mode,prot)
 106 #define fopen(fname,mode)       VMS_fopen (fname,mode)
 107 #define freopen(fname,mode,ofile) VMS_freopen (fname,mode,ofile)
 108 #define strncat(dst,src,cnt) VMS_strncat (dst,src,cnt)
 109 #define fstat(fd,stbuf)         VMS_fstat (fd,stbuf)
 110 static int VMS_fstat (), VMS_stat ();
 111 static char * VMS_strncat ();
 112 static int VMS_read ();
 113 static int VMS_write ();
 114 static int VMS_open ();
 115 static FILE * VMS_fopen ();
 116 static FILE * VMS_freopen ();
 117 static void hack_vms_include_specification ();
 118 typedef struct { unsigned :16, :16, :16; } vms_ino_t;
 119 #define ino_t vms_ino_t
 120 #define INCLUDE_LEN_FUDGE 10    /* leave room for VMS syntax conversion */
 121 #endif /* VMS */
 122
 123 #define FFECOM_DETERMINE_TYPES 1 /* for com.h */
 124 #include "com.h"
 125 #include "bad.h"
 126 #include "bld.h"
 127 #include "equiv.h"
 128 #include "expr.h"
 129 #include "implic.h"
 130 #include "info.h"
 131 #include "malloc.h"
 132 #include "src.h"
 133 #include "st.h"
 134 #include "storag.h"
 135 #include "symbol.h"
 136 #include "target.h"
 137 #include "top.h"
 138 #include "type.h"
 139
 140 /* Externals defined here.  */
 141
 142 /* Stream for reading from the input file.  */
 143 FILE *finput;
 144
 145 /* These definitions parallel those in c-decl.c so that code from that
 146    module can be used pretty much as is.  Much of these defs aren't
 147    otherwise used, i.e. by g77 code per se, except some of them are used
 148    to build some of them that are.  The ones that are global (i.e. not
 149    "static") are those that ste.c and such might use (directly
 150    or by using com macros that reference them in their definitions).  */
 151
 152 tree string_type_node;
 153
 154 /* The rest of these are inventions for g77, though there might be
 155    similar things in the C front end.  As they are found, these
 156    inventions should be renamed to be canonical.  Note that only
 157    the ones currently required to be global are so.  */
 158
 159 static GTY(()) tree ffecom_tree_fun_type_void;
 160
 161 tree ffecom_integer_type_node;  /* Abbrev for _tree_type[blah][blah]. */
 162 tree ffecom_integer_zero_node;  /* Like *_*_* with g77's integer type. */
 163 tree ffecom_integer_one_node;   /* " */
 164 tree ffecom_tree_type[FFEINFO_basictype][FFEINFO_kindtype];
 165
 166 /* _fun_type things are the f2c-specific versions.  For -fno-f2c,
 167    just use build_function_type and build_pointer_type on the
 168    appropriate _tree_type array element.  */
 169
 170 static GTY(()) tree ffecom_tree_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
 171 static GTY(()) tree
 172   ffecom_tree_ptr_to_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
 173 static GTY(()) tree ffecom_tree_subr_type;
 174 static GTY(()) tree ffecom_tree_ptr_to_subr_type;
 175 static GTY(()) tree ffecom_tree_blockdata_type;
 176
 177 static GTY(()) tree ffecom_tree_xargc_;
 178
 179 ffecomSymbol ffecom_symbol_null_
 180 =
 181 {
 182   NULL_TREE,
 183   NULL_TREE,
 184   NULL_TREE,
 185   NULL_TREE,
 186   false
 187 };
 188 ffeinfoKindtype ffecom_pointer_kind_ = FFEINFO_basictypeNONE;
 189 ffeinfoKindtype ffecom_label_kind_ = FFEINFO_basictypeNONE;
 190
 191 int ffecom_f2c_typecode_[FFEINFO_basictype][FFEINFO_kindtype];
 192 tree ffecom_f2c_integer_type_node;
 193 static GTY(()) tree ffecom_f2c_ptr_to_integer_type_node;
 194 tree ffecom_f2c_address_type_node;
 195 tree ffecom_f2c_real_type_node;
 196 static GTY(()) tree ffecom_f2c_ptr_to_real_type_node;
 197 tree ffecom_f2c_doublereal_type_node;
 198 tree ffecom_f2c_complex_type_node;
 199 tree ffecom_f2c_doublecomplex_type_node;
 200 tree ffecom_f2c_longint_type_node;
 201 tree ffecom_f2c_logical_type_node;
 202 tree ffecom_f2c_flag_type_node;
 203 tree ffecom_f2c_ftnlen_type_node;
 204 tree ffecom_f2c_ftnlen_zero_node;
 205 tree ffecom_f2c_ftnlen_one_node;
 206 tree ffecom_f2c_ftnlen_two_node;
 207 tree ffecom_f2c_ptr_to_ftnlen_type_node;
 208 tree ffecom_f2c_ftnint_type_node;
 209 tree ffecom_f2c_ptr_to_ftnint_type_node;
 210
 211 /* Simple definitions and enumerations. */
 212
 213 #ifndef FFECOM_sizeMAXSTACKITEM
 214 #define FFECOM_sizeMAXSTACKITEM 32*1024 /* Keep user-declared things
 215                                            larger than this # bytes
 216                                            off stack if possible. */
 217 #endif
 218
 219 /* For systems that have large enough stacks, they should define
 220    this to 0, and here, for ease of use later on, we just undefine
 221    it if it is 0.  */
 222
 223 #if FFECOM_sizeMAXSTACKITEM == 0
 224 #undef FFECOM_sizeMAXSTACKITEM
 225 #endif
 226
 227 typedef enum
 228   {
 229     FFECOM_rttypeVOID_,
 230     FFECOM_rttypeVOIDSTAR_,     /* C's `void *' type. */
 231     FFECOM_rttypeFTNINT_,       /* f2c's `ftnint' type. */
 232     FFECOM_rttypeINTEGER_,      /* f2c's `integer' type. */
 233     FFECOM_rttypeLONGINT_,      /* f2c's `longint' type. */
 234     FFECOM_rttypeLOGICAL_,      /* f2c's `logical' type. */
 235     FFECOM_rttypeREAL_F2C_,     /* f2c's `real' returned as `double'. */
 236     FFECOM_rttypeREAL_GNU_,     /* `real' returned as such. */
 237     FFECOM_rttypeCOMPLEX_F2C_,  /* f2c's `complex' returned via 1st arg. */
 238     FFECOM_rttypeCOMPLEX_GNU_,  /* f2c's `complex' returned directly. */
 239     FFECOM_rttypeDOUBLE_,       /* C's `double' type. */
 240     FFECOM_rttypeDOUBLEREAL_,   /* f2c's `doublereal' type. */
 241     FFECOM_rttypeDBLCMPLX_F2C_, /* f2c's `doublecomplex' returned via 1st arg. */
 242     FFECOM_rttypeDBLCMPLX_GNU_, /* f2c's `doublecomplex' returned directly. */
 243     FFECOM_rttypeCHARACTER_,    /* f2c `char *'/`ftnlen' pair. */
 244     FFECOM_rttype_
 245   } ffecomRttype_;
 246
 247 /* Internal typedefs. */
 248
 249 typedef struct _ffecom_concat_list_ ffecomConcatList_;
 250
 251 /* Private include files. */
 252
 253
 254 /* Internal structure definitions. */
 255
 256 struct _ffecom_concat_list_
 257   {
 258     ffebld *exprs;
 259     int count;
 260     int max;
 261     ffetargetCharacterSize minlen;
 262     ffetargetCharacterSize maxlen;
 263   };
 264
 265 /* Static functions (internal). */
 266
 267 static tree ffe_type_for_mode PARAMS ((enum machine_mode, int));
 268 static tree ffe_type_for_size PARAMS ((unsigned int, int));
 269 static tree ffe_unsigned_type PARAMS ((tree));
 270 static tree ffe_signed_type PARAMS ((tree));
 271 static tree ffe_signed_or_unsigned_type PARAMS ((int, tree));
 272 static bool ffe_mark_addressable PARAMS ((tree));
 273 static tree ffe_truthvalue_conversion PARAMS ((tree));
 274 static void ffecom_init_decl_processing PARAMS ((void));
 275 static tree ffecom_arglist_expr_ (const char *argstring, ffebld args);
 276 static tree ffecom_widest_expr_type_ (ffebld list);
 277 static bool ffecom_overlap_ (tree dest_decl, tree dest_offset,
 278                              tree dest_size, tree source_tree,
 279                              ffebld source, bool scalar_arg);
 280 static bool ffecom_args_overlapping_ (tree dest_tree, ffebld dest,
 281                                       tree args, tree callee_commons,
 282                                       bool scalar_args);
 283 static tree ffecom_build_f2c_string_ (int i, const char *s);
 284 static tree ffecom_call_ (tree fn, ffeinfoKindtype kt,
 285                           bool is_f2c_complex, tree type,
 286                           tree args, tree dest_tree,
 287                           ffebld dest, bool *dest_used,
 288                           tree callee_commons, bool scalar_args, tree hook);
 289 static tree ffecom_call_binop_ (tree fn, ffeinfoKindtype kt,
 290                                 bool is_f2c_complex, tree type,
 291                                 ffebld left, ffebld right,
 292                                 tree dest_tree, ffebld dest,
 293                                 bool *dest_used, tree callee_commons,
 294                                 bool scalar_args, bool ref, tree hook);
 295 static void ffecom_char_args_x_ (tree *xitem, tree *length,
 296                                  ffebld expr, bool with_null);
 297 static tree ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy);
 298 static tree ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s);
 299 static ffecomConcatList_
 300   ffecom_concat_list_gather_ (ffecomConcatList_ catlist,
 301                               ffebld expr,
 302                               ffetargetCharacterSize max);
 303 static void ffecom_concat_list_kill_ (ffecomConcatList_ catlist);
 304 static ffecomConcatList_ ffecom_concat_list_new_ (ffebld expr,
 305                                                 ffetargetCharacterSize max);
 306 static void ffecom_debug_kludge_ (tree aggr, const char *aggr_type,
 307                                   ffesymbol member, tree member_type,
 308                                   ffetargetOffset offset);
 309 static void ffecom_do_entry_ (ffesymbol fn, int entrynum);
 310 static tree ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
 311                           bool *dest_used, bool assignp, bool widenp);
 312 static tree ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
 313                                     ffebld dest, bool *dest_used);
 314 static tree ffecom_expr_power_integer_ (ffebld expr);
 315 static void ffecom_expr_transform_ (ffebld expr);
 316 static void ffecom_f2c_make_type_ (tree *type, int tcode, const char *name);
 317 static void ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
 318                                       int code);
 319 static ffeglobal ffecom_finish_global_ (ffeglobal global);
 320 static ffesymbol ffecom_finish_symbol_transform_ (ffesymbol s);
 321 static tree ffecom_get_appended_identifier_ (char us, const char *text);
 322 static tree ffecom_get_external_identifier_ (ffesymbol s);
 323 static tree ffecom_get_identifier_ (const char *text);
 324 static tree ffecom_gen_sfuncdef_ (ffesymbol s,
 325                                   ffeinfoBasictype bt,
 326                                   ffeinfoKindtype kt);
 327 static const char *ffecom_gfrt_args_ (ffecomGfrt ix);
 328 static tree ffecom_gfrt_tree_ (ffecomGfrt ix);
 329 static tree ffecom_init_zero_ (tree decl);
 330 static tree ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
 331                                      tree *maybe_tree);
 332 static tree ffecom_intrinsic_len_ (ffebld expr);
 333 static void ffecom_let_char_ (tree dest_tree,
 334                               tree dest_length,
 335                               ffetargetCharacterSize dest_size,
 336                               ffebld source);
 337 static void ffecom_make_gfrt_ (ffecomGfrt ix);
 338 static void ffecom_member_phase1_ (ffestorag mst, ffestorag st);
 339 static void ffecom_member_phase2_ (ffestorag mst, ffestorag st);
 340 static void ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size,
 341                                       ffebld source);
 342 static void ffecom_push_dummy_decls_ (ffebld dumlist,
 343                                       bool stmtfunc);
 344 static void ffecom_start_progunit_ (void);
 345 static ffesymbol ffecom_sym_transform_ (ffesymbol s);
 346 static ffesymbol ffecom_sym_transform_assign_ (ffesymbol s);
 347 static void ffecom_transform_common_ (ffesymbol s);
 348 static void ffecom_transform_equiv_ (ffestorag st);
 349 static tree ffecom_transform_namelist_ (ffesymbol s);
 350 static void ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
 351                                        tree t);
 352 static void ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
 353                                        tree *size, tree tree);
 354 static tree ffecom_tree_divide_ (tree tree_type, tree left, tree right,
 355                                  tree dest_tree, ffebld dest,
 356                                  bool *dest_used, tree hook);
 357 static tree ffecom_type_localvar_ (ffesymbol s,
 358                                    ffeinfoBasictype bt,
 359                                    ffeinfoKindtype kt);
 360 static tree ffecom_type_namelist_ (void);
 361 static tree ffecom_type_vardesc_ (void);
 362 static tree ffecom_vardesc_ (ffebld expr);
 363 static tree ffecom_vardesc_array_ (ffesymbol s);
 364 static tree ffecom_vardesc_dims_ (ffesymbol s);
 365 static tree ffecom_convert_narrow_ (tree type, tree expr);
 366 static tree ffecom_convert_widen_ (tree type, tree expr);
 367
 368 /* These are static functions that parallel those found in the C front
 369    end and thus have the same names.  */
 370
 371 static tree bison_rule_compstmt_ (void);
 372 static void bison_rule_pushlevel_ (void);
 373 static void delete_block (tree block);
 374 static int duplicate_decls (tree newdecl, tree olddecl);
 375 static void finish_decl (tree decl, tree init, bool is_top_level);
 376 static void finish_function (int nested);
 377 static const char *ffe_printable_name (tree decl, int v);
 378 static void ffe_print_error_function (diagnostic_context *, const char *);
 379 static tree lookup_name_current_level (tree name);
 380 static struct f_binding_level *make_binding_level (void);
 381 static void pop_f_function_context (void);
 382 static void push_f_function_context (void);
 383 static void push_parm_decl (tree parm);
 384 static tree pushdecl_top_level (tree decl);
 385 static int kept_level_p (void);
 386 static tree storedecls (tree decls);
 387 static void store_parm_decls (int is_main_program);
 388 static tree start_decl (tree decl, bool is_top_level);
 389 static void start_function (tree name, tree type, int nested, int public);
 390 static void ffecom_file_ (const char *name);
 391 static void ffecom_close_include_ (FILE *f);
 392 static int ffecom_decode_include_option_ (char *spec);
 393 static FILE *ffecom_open_include_ (char *name, ffewhereLine l,
 394                                    ffewhereColumn c);
 395
 396 /* Static objects accessed by functions in this module. */
 397
 398 static ffesymbol ffecom_primary_entry_ = NULL;
 399 static ffesymbol ffecom_nested_entry_ = NULL;
 400 static ffeinfoKind ffecom_primary_entry_kind_;
 401 static bool ffecom_primary_entry_is_proc_;
 402 static GTY(()) tree ffecom_outer_function_decl_;
 403 static GTY(()) tree ffecom_previous_function_decl_;
 404 static GTY(()) tree ffecom_which_entrypoint_decl_;
 405 static GTY(()) tree ffecom_float_zero_;
 406 static GTY(()) tree ffecom_float_half_;
 407 static GTY(()) tree ffecom_double_zero_;
 408 static GTY(()) tree ffecom_double_half_;
 409 static GTY(()) tree ffecom_func_result_;/* For functions. */
 410 static GTY(()) tree ffecom_func_length_;/* For CHARACTER fns. */
 411 static ffebld ffecom_list_blockdata_;
 412 static ffebld ffecom_list_common_;
 413 static ffebld ffecom_master_arglist_;
 414 static ffeinfoBasictype ffecom_master_bt_;
 415 static ffeinfoKindtype ffecom_master_kt_;
 416 static ffetargetCharacterSize ffecom_master_size_;
 417 static int ffecom_num_fns_ = 0;
 418 static int ffecom_num_entrypoints_ = 0;
 419 static bool ffecom_is_altreturning_ = FALSE;
 420 static GTY(()) tree ffecom_multi_type_node_;
 421 static GTY(()) tree ffecom_multi_retval_;
 422 static GTY(()) tree
 423   ffecom_multi_fields_[FFEINFO_basictype][FFEINFO_kindtype];
 424 static bool ffecom_member_namelisted_;  /* _member_phase1_ namelisted? */
 425 static bool ffecom_doing_entry_ = FALSE;
 426 static bool ffecom_transform_only_dummies_ = FALSE;
 427 static int ffecom_typesize_pointer_;
 428 static int ffecom_typesize_integer1_;
 429
 430 /* Holds pointer-to-function expressions.  */
 431
 432 static GTY(()) tree ffecom_gfrt_[FFECOM_gfrt];
 433
 434 /* Holds the external names of the functions.  */
 435
 436 static const char *const ffecom_gfrt_name_[FFECOM_gfrt]
 437 =
 438 {
 439 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NAME,
 440 #include "com-rt.def"
 441 #undef DEFGFRT
 442 };
 443
 444 /* Whether the function returns.  */
 445
 446 static const bool ffecom_gfrt_volatile_[FFECOM_gfrt]
 447 =
 448 {
 449 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) VOLATILE,
 450 #include "com-rt.def"
 451 #undef DEFGFRT
 452 };
 453
 454 /* Whether the function returns type complex.  */
 455
 456 static const bool ffecom_gfrt_complex_[FFECOM_gfrt]
 457 =
 458 {
 459 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) COMPLEX,
 460 #include "com-rt.def"
 461 #undef DEFGFRT
 462 };
 463
 464 /* Whether the function is const
 465    (i.e., has no side effects and only depends on its arguments).  */
 466
 467 static const bool ffecom_gfrt_const_[FFECOM_gfrt]
 468 =
 469 {
 470 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) CONST,
 471 #include "com-rt.def"
 472 #undef DEFGFRT
 473 };
 474
 475 /* Type code for the function return value.  */
 476
 477 static const ffecomRttype_ ffecom_gfrt_type_[FFECOM_gfrt]
 478 =
 479 {
 480 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) TYPE,
 481 #include "com-rt.def"
 482 #undef DEFGFRT
 483 };
 484
 485 /* String of codes for the function's arguments.  */
 486
 487 static const char *const ffecom_gfrt_argstring_[FFECOM_gfrt]
 488 =
 489 {
 490 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) ARGS,
 491 #include "com-rt.def"
 492 #undef DEFGFRT
 493 };
 494
 495 /* Internal macros. */
 496
 497 /* We let tm.h override the types used here, to handle trivial differences
 498    such as the choice of unsigned int or long unsigned int for size_t.
 499    When machines start needing nontrivial differences in the size type,
 500    it would be best to do something here to figure out automatically
 501    from other information what type to use.  */
 502
 503 #ifndef SIZE_TYPE
 504 #define SIZE_TYPE "long unsigned int"
 505 #endif
 506
 507 #define ffecom_concat_list_count_(catlist) ((catlist).count)
 508 #define ffecom_concat_list_expr_(catlist,i) ((catlist).exprs[(i)])
 509 #define ffecom_concat_list_maxlen_(catlist) ((catlist).maxlen)
 510 #define ffecom_concat_list_minlen_(catlist) ((catlist).minlen)
 511
 512 #define ffecom_char_args_(i,l,e) ffecom_char_args_x_((i),(l),(e),FALSE)
 513 #define ffecom_char_args_with_null_(i,l,e) ffecom_char_args_x_((i),(l),(e),TRUE)
 514
 515 /* For each binding contour we allocate a binding_level structure
 516  * which records the names defined in that contour.
 517  * Contours include:
 518  *  0) the global one
 519  *  1) one for each function definition,
 520  *     where internal declarations of the parameters appear.
 521  *
 522  * The current meaning of a name can be found by searching the levels from
 523  * the current one out to the global one.
 524  */
 525
 526 /* Note that the information in the `names' component of the global contour
 527    is duplicated in the IDENTIFIER_GLOBAL_VALUEs of all identifiers.  */
 528
 529 struct f_binding_level GTY(())
 530   {
 531     /* A chain of _DECL nodes for all variables, constants, functions,
 532        and typedef types.  These are in the reverse of the order supplied.
 533      */
 534     tree names;
 535
 536     /* For each level (except not the global one),
 537        a chain of BLOCK nodes for all the levels
 538        that were entered and exited one level down.  */
 539     tree blocks;
 540
 541     /* The BLOCK node for this level, if one has been preallocated.
 542        If 0, the BLOCK is allocated (if needed) when the level is popped.  */
 543     tree this_block;
 544
 545     /* The binding level which this one is contained in (inherits from).  */
 546     struct f_binding_level *level_chain;
 547
 548     /* 0: no ffecom_prepare_* functions called at this level yet;
 549        1: ffecom_prepare* functions called, except not ffecom_prepare_end;
 550        2: ffecom_prepare_end called.  */
 551     int prep_state;
 552   };
 553
 554 #define NULL_BINDING_LEVEL (struct f_binding_level *) NULL
 555
 556 /* The binding level currently in effect.  */
 557
 558 static GTY(()) struct f_binding_level *current_binding_level;
 559
 560 /* A chain of binding_level structures awaiting reuse.  */
 561
 562 static GTY((deletable (""))) struct f_binding_level *free_binding_level;
 563
 564 /* The outermost binding level, for names of file scope.
 565    This is created when the compiler is started and exists
 566    through the entire run.  */
 567
 568 static struct f_binding_level *global_binding_level;
 569
 570 /* Binding level structures are initialized by copying this one.  */
 571
 572 static const struct f_binding_level clear_binding_level
 573 =
 574 {NULL, NULL, NULL, NULL_BINDING_LEVEL, 0};
 575
 576 /* Language-dependent contents of an identifier.  */
 577
 578 struct lang_identifier GTY(())
 579 {
 580   struct tree_identifier common;
 581   tree global_value;
 582   tree local_value;
 583   tree label_value;
 584   bool invented;
 585 };
 586
 587 /* Macros for access to language-specific slots in an identifier.  */
 588 /* Each of these slots contains a DECL node or null.  */
 589
 590 /* This represents the value which the identifier has in the
 591    file-scope namespace.  */
 592 #define IDENTIFIER_GLOBAL_VALUE(NODE)   \
 593   (((struct lang_identifier *)(NODE))->global_value)
 594 /* This represents the value which the identifier has in the current
 595    scope.  */
 596 #define IDENTIFIER_LOCAL_VALUE(NODE)    \
 597   (((struct lang_identifier *)(NODE))->local_value)
 598 /* This represents the value which the identifier has as a label in
 599    the current label scope.  */
 600 #define IDENTIFIER_LABEL_VALUE(NODE)    \
 601   (((struct lang_identifier *)(NODE))->label_value)
 602 /* This is nonzero if the identifier was "made up" by g77 code.  */
 603 #define IDENTIFIER_INVENTED(NODE)       \
 604   (((struct lang_identifier *)(NODE))->invented)
 605
 606 /* The resulting tree type.  */
 607 union lang_tree_node
 608   GTY((desc ("TREE_CODE (&%h.generic) == IDENTIFIER_NODE"),
 609        chain_next ("(union lang_tree_node *)TREE_CHAIN (&%h.generic)")))
 610 {
 611   union tree_node GTY ((tag ("0"),
 612                         desc ("tree_node_structure (&%h)")))
 613     generic;
 614   struct lang_identifier GTY ((tag ("1"))) identifier;
 615 };
 616
 617 /* Fortran doesn't use either of these.  */
 618 struct lang_decl GTY(())
 619 {
 620 };
 621 struct lang_type GTY(())
 622 {
 623 };
 624
 625 /* In identifiers, C uses the following fields in a special way:
 626    TREE_PUBLIC        to record that there was a previous local extern decl.
 627    TREE_USED          to record that such a decl was used.
 628    TREE_ADDRESSABLE   to record that the address of such a decl was used.  */
 629
 630 /* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function
 631    that have names.  Here so we can clear out their names' definitions
 632    at the end of the function.  */
 633
 634 static GTY(()) tree named_labels;
 635
 636 /* A list of LABEL_DECLs from outer contexts that are currently shadowed.  */
 637
 638 static GTY(()) tree shadowed_labels;
 639 \f
 640 /* Return the subscript expression, modified to do range-checking.
 641
 642    `array' is the array to be checked against.
 643    `element' is the subscript expression to check.
 644    `dim' is the dimension number (starting at 0).
 645    `total_dims' is the total number of dimensions (0 for CHARACTER substring).
 646 */
 647
 648 static tree
 649 ffecom_subscript_check_ (tree array, tree element, int dim, int total_dims,
 650                          const char *array_name)
 651 {
 652   tree low = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
 653   tree high = TYPE_MAX_VALUE (TYPE_DOMAIN (array));
 654   tree cond;
 655   tree die;
 656   tree args;
 657
 658   if (element == error_mark_node)
 659     return element;
 660
 661   if (TREE_TYPE (low) != TREE_TYPE (element))
 662     {
 663       if (TYPE_PRECISION (TREE_TYPE (low))
 664           > TYPE_PRECISION (TREE_TYPE (element)))
 665         element = convert (TREE_TYPE (low), element);
 666       else
 667         {
 668           low = convert (TREE_TYPE (element), low);
 669           if (high)
 670             high = convert (TREE_TYPE (element), high);
 671         }
 672     }
 673
 674   element = ffecom_save_tree (element);
 675   if (total_dims == 0)
 676     {
 677       /* Special handling for substring range checks.  Fortran allows the
 678          end subscript < begin subscript, which means that expressions like
 679        string(1:0) are valid (and yield a null string).  In view of this,
 680        enforce two simpler conditions:
 681           1) element<=high for end-substring;
 682           2) element>=low for start-substring.
 683        Run-time character movement will enforce remaining conditions.
 684
 685        More complicated checks would be better, but present structure only
 686        provides one index element at a time, so it is not possible to
 687        enforce a check of both i and j in string(i:j).  If it were, the
 688        complete set of rules would read,
 689          if ( ((j<i) && ((low<=i<=high) || (low<=j<=high))) ||
 690               ((low<=i<=high) && (low<=j<=high)) )
 691            ok ;
 692          else
 693            range error ;
 694       */
 695       if (dim)
 696         cond = ffecom_2 (LE_EXPR, integer_type_node, element, high);
 697       else
 698         cond = ffecom_2 (LE_EXPR, integer_type_node, low, element);
 699     }
 700   else
 701     {
 702       /* Array reference substring range checking.  */
 703
 704       cond = ffecom_2 (LE_EXPR, integer_type_node,
 705                      low,
 706                      element);
 707       if (high)
 708         {
 709           cond = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
 710                          cond,
 711                          ffecom_2 (LE_EXPR, integer_type_node,
 712                                    element,
 713                                    high));
 714         }
 715     }
 716
 717   {
 718     int len;
 719     char *proc;
 720     char *var;
 721     tree arg3;
 722     tree arg2;
 723     tree arg1;
 724     tree arg4;
 725
 726     switch (total_dims)
 727       {
 728       case 0:
 729         var = concat (array_name, "[", (dim ? "end" : "start"),
 730                       "-substring]", NULL);
 731         len = strlen (var) + 1;
 732         arg1 = build_string (len, var);
 733         free (var);
 734         break;
 735
 736       case 1:
 737         len = strlen (array_name) + 1;
 738         arg1 = build_string (len, array_name);
 739         break;
 740
 741       default:
 742         var = xmalloc (strlen (array_name) + 40);
 743         sprintf (var, "%s[subscript-%d-of-%d]",
 744                  array_name,
 745                  dim + 1, total_dims);
 746         len = strlen (var) + 1;
 747         arg1 = build_string (len, var);
 748         free (var);
 749         break;
 750       }
 751
 752     TREE_TYPE (arg1)
 753       = build_type_variant (build_array_type (char_type_node,
 754                                               build_range_type
 755                                               (integer_type_node,
 756                                                integer_one_node,
 757                                                build_int_2 (len, 0))),
 758                             1, 0);
 759     TREE_CONSTANT (arg1) = 1;
 760     TREE_STATIC (arg1) = 1;
 761     arg1 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg1)),
 762                      arg1);
 763
 764     /* s_rnge adds one to the element to print it, so bias against
 765        that -- want to print a faithful *subscript* value.  */
 766     arg2 = convert (ffecom_f2c_ftnint_type_node,
 767                     ffecom_2 (MINUS_EXPR,
 768                               TREE_TYPE (element),
 769                               element,
 770                               convert (TREE_TYPE (element),
 771                                        integer_one_node)));
 772
 773     proc = concat (input_filename, "/",
 774                    IDENTIFIER_POINTER (DECL_NAME (current_function_decl)),
 775                    NULL);
 776     len = strlen (proc) + 1;
 777     arg3 = build_string (len, proc);
 778
 779     free (proc);
 780
 781     TREE_TYPE (arg3)
 782       = build_type_variant (build_array_type (char_type_node,
 783                                               build_range_type
 784                                               (integer_type_node,
 785                                                integer_one_node,
 786                                                build_int_2 (len, 0))),
 787                             1, 0);
 788     TREE_CONSTANT (arg3) = 1;
 789     TREE_STATIC (arg3) = 1;
 790     arg3 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg3)),
 791                      arg3);
 792
 793     arg4 = convert (ffecom_f2c_ftnint_type_node,
 794                     build_int_2 (lineno, 0));
 795
 796     arg1 = build_tree_list (NULL_TREE, arg1);
 797     arg2 = build_tree_list (NULL_TREE, arg2);
 798     arg3 = build_tree_list (NULL_TREE, arg3);
 799     arg4 = build_tree_list (NULL_TREE, arg4);
 800     TREE_CHAIN (arg3) = arg4;
 801     TREE_CHAIN (arg2) = arg3;
 802     TREE_CHAIN (arg1) = arg2;
 803
 804     args = arg1;
 805   }
 806   die = ffecom_call_gfrt (FFECOM_gfrtRANGE,
 807                           args, NULL_TREE);
 808   TREE_SIDE_EFFECTS (die) = 1;
 809   die = convert (void_type_node, die);
 810
 811   element = ffecom_3 (COND_EXPR,
 812                       TREE_TYPE (element),
 813                       cond,
 814                       element,
 815                       die);
 816
 817   return element;
 818 }
 819
 820 /* Return the computed element of an array reference.
 821
 822    `item' is NULL_TREE, or the transformed pointer to the array.
 823    `expr' is the original opARRAYREF expression, which is transformed
 824      if `item' is NULL_TREE.
 825    `want_ptr' is nonzero if a pointer to the element, instead of
 826      the element itself, is to be returned.  */
 827
 828 static tree
 829 ffecom_arrayref_ (tree item, ffebld expr, int want_ptr)
 830 {
 831   ffebld dims[FFECOM_dimensionsMAX];
 832   int i;
 833   int total_dims;
 834   int flatten = ffe_is_flatten_arrays ();
 835   int need_ptr;
 836   tree array;
 837   tree element;
 838   tree tree_type;
 839   tree tree_type_x;
 840   const char *array_name;
 841   ffetype type;
 842   ffebld list;
 843
 844   if (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER)
 845     array_name = ffesymbol_text (ffebld_symter (ffebld_left (expr)));
 846   else
 847     array_name = "[expr?]";
 848
 849   /* Build up ARRAY_REFs in reverse order (since we're column major
 850      here in Fortran land). */
 851
 852   for (i = 0, list = ffebld_right (expr);
 853        list != NULL;
 854        ++i, list = ffebld_trail (list))
 855     {
 856       dims[i] = ffebld_head (list);
 857       type = ffeinfo_type (ffebld_basictype (dims[i]),
 858                            ffebld_kindtype (dims[i]));
 859       if (! flatten
 860           && ffecom_typesize_pointer_ > ffecom_typesize_integer1_
 861           && ffetype_size (type) > ffecom_typesize_integer1_)
 862         /* E.g. ARRAY(INDEX), given INTEGER*8 INDEX, on a system with 64-bit
 863            pointers and 32-bit integers.  Do the full 64-bit pointer
 864            arithmetic, for codes using arrays for nonstandard heap-like
 865            work.  */
 866         flatten = 1;
 867     }
 868
 869   total_dims = i;
 870
 871   need_ptr = want_ptr || flatten;
 872
 873   if (! item)
 874     {
 875       if (need_ptr)
 876         item = ffecom_ptr_to_expr (ffebld_left (expr));
 877       else
 878         item = ffecom_expr (ffebld_left (expr));
 879
 880       if (item == error_mark_node)
 881         return item;
 882
 883       if (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereFLEETING
 884           && ! ffe_mark_addressable (item))
 885         return error_mark_node;
 886     }
 887
 888   if (item == error_mark_node)
 889     return item;
 890
 891   if (need_ptr)
 892     {
 893       tree min;
 894
 895       for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
 896            i >= 0;
 897            --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array)))
 898         {
 899           min = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
 900           element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
 901           if (flag_bounds_check)
 902             element = ffecom_subscript_check_ (array, element, i, total_dims,
 903                                                array_name);
 904           if (element == error_mark_node)
 905             return element;
 906
 907           /* Widen integral arithmetic as desired while preserving
 908              signedness.  */
 909           tree_type = TREE_TYPE (element);
 910           tree_type_x = tree_type;
 911           if (tree_type
 912               && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
 913               && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
 914             tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
 915
 916           if (TREE_TYPE (min) != tree_type_x)
 917             min = convert (tree_type_x, min);
 918           if (TREE_TYPE (element) != tree_type_x)
 919             element = convert (tree_type_x, element);
 920
 921           item = ffecom_2 (PLUS_EXPR,
 922                            build_pointer_type (TREE_TYPE (array)),
 923                            item,
 924                            size_binop (MULT_EXPR,
 925                                        size_in_bytes (TREE_TYPE (array)),
 926                                        convert (sizetype,
 927                                                 fold (build (MINUS_EXPR,
 928                                                              tree_type_x,
 929                                                              element, min)))));
 930         }
 931       if (! want_ptr)
 932         {
 933           item = ffecom_1 (INDIRECT_REF,
 934                            TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
 935                            item);
 936         }
 937     }
 938   else
 939     {
 940       for (--i;
 941            i >= 0;
 942            --i)
 943         {
 944           array = TYPE_MAIN_VARIANT (TREE_TYPE (item));
 945
 946           element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
 947           if (flag_bounds_check)
 948             element = ffecom_subscript_check_ (array, element, i, total_dims,
 949                                                array_name);
 950           if (element == error_mark_node)
 951             return element;
 952
 953           /* Widen integral arithmetic as desired while preserving
 954              signedness.  */
 955           tree_type = TREE_TYPE (element);
 956           tree_type_x = tree_type;
 957           if (tree_type
 958               && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
 959               && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
 960             tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
 961
 962           element = convert (tree_type_x, element);
 963
 964           item = ffecom_2 (ARRAY_REF,
 965                            TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
 966                            item,
 967                            element);
 968         }
 969     }
 970
 971   return item;
 972 }
 973
 974 /* This is like gcc's stabilize_reference -- in fact, most of the code
 975    comes from that -- but it handles the situation where the reference
 976    is going to have its subparts picked at, and it shouldn't change
 977    (or trigger extra invocations of functions in the subtrees) due to
 978    this.  save_expr is a bit overzealous, because we don't need the
 979    entire thing calculated and saved like a temp.  So, for DECLs, no
 980    change is needed, because these are stable aggregates, and ARRAY_REF
 981    and such might well be stable too, but for things like calculations,
 982    we do need to calculate a snapshot of a value before picking at it.  */
 983
 984 static tree
 985 ffecom_stabilize_aggregate_ (tree ref)
 986 {
 987   tree result;
 988   enum tree_code code = TREE_CODE (ref);
 989
 990   switch (code)
 991     {
 992     case VAR_DECL:
 993     case PARM_DECL:
 994     case RESULT_DECL:
 995       /* No action is needed in this case.  */
 996       return ref;
 997
 998     case NOP_EXPR:
 999     case CONVERT_EXPR:
1000     case FLOAT_EXPR:
1001     case FIX_TRUNC_EXPR:
1002     case FIX_FLOOR_EXPR:
1003     case FIX_ROUND_EXPR:
1004     case FIX_CEIL_EXPR:
1005       result = build_nt (code, stabilize_reference (TREE_OPERAND (ref, 0)));
1006       break;
1007
1008     case INDIRECT_REF:
1009       result = build_nt (INDIRECT_REF,
1010                          stabilize_reference_1 (TREE_OPERAND (ref, 0)));
1011       break;
1012
1013     case COMPONENT_REF:
1014       result = build_nt (COMPONENT_REF,
1015                          stabilize_reference (TREE_OPERAND (ref, 0)),
1016                          TREE_OPERAND (ref, 1));
1017       break;
1018
1019     case BIT_FIELD_REF:
1020       result = build_nt (BIT_FIELD_REF,
1021                          stabilize_reference (TREE_OPERAND (ref, 0)),
1022                          stabilize_reference_1 (TREE_OPERAND (ref, 1)),
1023                          stabilize_reference_1 (TREE_OPERAND (ref, 2)));
1024       break;
1025
1026     case ARRAY_REF:
1027       result = build_nt (ARRAY_REF,
1028                          stabilize_reference (TREE_OPERAND (ref, 0)),
1029                          stabilize_reference_1 (TREE_OPERAND (ref, 1)));
1030       break;
1031
1032     case COMPOUND_EXPR:
1033       result = build_nt (COMPOUND_EXPR,
1034                          stabilize_reference_1 (TREE_OPERAND (ref, 0)),
1035                          stabilize_reference (TREE_OPERAND (ref, 1)));
1036       break;
1037
1038     case RTL_EXPR:
1039       abort ();
1040
1041
1042     default:
1043       return save_expr (ref);
1044
1045     case ERROR_MARK:
1046       return error_mark_node;
1047     }
1048
1049   TREE_TYPE (result) = TREE_TYPE (ref);
1050   TREE_READONLY (result) = TREE_READONLY (ref);
1051   TREE_SIDE_EFFECTS (result) = TREE_SIDE_EFFECTS (ref);
1052   TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref);
1053
1054   return result;
1055 }
1056
1057 /* A rip-off of gcc's convert.c convert_to_complex function,
1058    reworked to handle complex implemented as C structures
1059    (RECORD_TYPE with two fields, real and imaginary `r' and `i').  */
1060
1061 static tree
1062 ffecom_convert_to_complex_ (tree type, tree expr)
1063 {
1064   register enum tree_code form = TREE_CODE (TREE_TYPE (expr));
1065   tree subtype;
1066
1067   assert (TREE_CODE (type) == RECORD_TYPE);
1068
1069   subtype = TREE_TYPE (TYPE_FIELDS (type));
1070
1071   if (form == REAL_TYPE || form == INTEGER_TYPE || form == ENUMERAL_TYPE)
1072     {
1073       expr = convert (subtype, expr);
1074       return ffecom_2 (COMPLEX_EXPR, type, expr,
1075                        convert (subtype, integer_zero_node));
1076     }
1077
1078   if (form == RECORD_TYPE)
1079     {
1080       tree elt_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr)));
1081       if (TYPE_MAIN_VARIANT (elt_type) == TYPE_MAIN_VARIANT (subtype))
1082         return expr;
1083       else
1084         {
1085           expr = save_expr (expr);
1086           return ffecom_2 (COMPLEX_EXPR,
1087                            type,
1088                            convert (subtype,
1089                                     ffecom_1 (REALPART_EXPR,
1090                                               TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1091                                               expr)),
1092                            convert (subtype,
1093                                     ffecom_1 (IMAGPART_EXPR,
1094                                               TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1095                                               expr)));
1096         }
1097     }
1098
1099   if (form == POINTER_TYPE || form == REFERENCE_TYPE)
1100     error ("pointer value used where a complex was expected");
1101   else
1102     error ("aggregate value used where a complex was expected");
1103
1104   return ffecom_2 (COMPLEX_EXPR, type,
1105                    convert (subtype, integer_zero_node),
1106                    convert (subtype, integer_zero_node));
1107 }
1108
1109 /* Like gcc's convert(), but crashes if widening might happen.  */
1110
1111 static tree
1112 ffecom_convert_narrow_ (tree type, tree expr)
1113 {
1114   register tree e = expr;
1115   register enum tree_code code = TREE_CODE (type);
1116
1117   if (type == TREE_TYPE (e)
1118       || TREE_CODE (e) == ERROR_MARK)
1119     return e;
1120   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1121     return fold (build1 (NOP_EXPR, type, e));
1122   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1123       || code == ERROR_MARK)
1124     return error_mark_node;
1125   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1126     {
1127       assert ("void value not ignored as it ought to be" == NULL);
1128       return error_mark_node;
1129     }
1130   assert (code != VOID_TYPE);
1131   if ((code != RECORD_TYPE)
1132       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1133     assert ("converting COMPLEX to REAL" == NULL);
1134   assert (code != ENUMERAL_TYPE);
1135   if (code == INTEGER_TYPE)
1136     {
1137       assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1138                && TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)))
1139               || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1140                   && (TYPE_PRECISION (type)
1141                       == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1142       return fold (convert_to_integer (type, e));
1143     }
1144   if (code == POINTER_TYPE)
1145     {
1146       assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1147       return fold (convert_to_pointer (type, e));
1148     }
1149   if (code == REAL_TYPE)
1150     {
1151       assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1152       assert (TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)));
1153       return fold (convert_to_real (type, e));
1154     }
1155   if (code == COMPLEX_TYPE)
1156     {
1157       assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1158       assert (TYPE_PRECISION (TREE_TYPE (type)) <= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1159       return fold (convert_to_complex (type, e));
1160     }
1161   if (code == RECORD_TYPE)
1162     {
1163       assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1164       /* Check that at least the first field name agrees.  */
1165       assert (DECL_NAME (TYPE_FIELDS (type))
1166               == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1167       assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1168               <= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1169       if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1170           == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1171         return e;
1172       return fold (ffecom_convert_to_complex_ (type, e));
1173     }
1174
1175   assert ("conversion to non-scalar type requested" == NULL);
1176   return error_mark_node;
1177 }
1178
1179 /* Like gcc's convert(), but crashes if narrowing might happen.  */
1180
1181 static tree
1182 ffecom_convert_widen_ (tree type, tree expr)
1183 {
1184   register tree e = expr;
1185   register enum tree_code code = TREE_CODE (type);
1186
1187   if (type == TREE_TYPE (e)
1188       || TREE_CODE (e) == ERROR_MARK)
1189     return e;
1190   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1191     return fold (build1 (NOP_EXPR, type, e));
1192   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1193       || code == ERROR_MARK)
1194     return error_mark_node;
1195   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1196     {
1197       assert ("void value not ignored as it ought to be" == NULL);
1198       return error_mark_node;
1199     }
1200   assert (code != VOID_TYPE);
1201   if ((code != RECORD_TYPE)
1202       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1203     assert ("narrowing COMPLEX to REAL" == NULL);
1204   assert (code != ENUMERAL_TYPE);
1205   if (code == INTEGER_TYPE)
1206     {
1207       assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1208                && TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)))
1209               || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1210                   && (TYPE_PRECISION (type)
1211                       == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1212       return fold (convert_to_integer (type, e));
1213     }
1214   if (code == POINTER_TYPE)
1215     {
1216       assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1217       return fold (convert_to_pointer (type, e));
1218     }
1219   if (code == REAL_TYPE)
1220     {
1221       assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1222       assert (TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)));
1223       return fold (convert_to_real (type, e));
1224     }
1225   if (code == COMPLEX_TYPE)
1226     {
1227       assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1228       assert (TYPE_PRECISION (TREE_TYPE (type)) >= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1229       return fold (convert_to_complex (type, e));
1230     }
1231   if (code == RECORD_TYPE)
1232     {
1233       assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1234       /* Check that at least the first field name agrees.  */
1235       assert (DECL_NAME (TYPE_FIELDS (type))
1236               == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1237       assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1238               >= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1239       if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1240           == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1241         return e;
1242       return fold (ffecom_convert_to_complex_ (type, e));
1243     }
1244
1245   assert ("conversion to non-scalar type requested" == NULL);
1246   return error_mark_node;
1247 }
1248
1249 /* Handles making a COMPLEX type, either the standard
1250    (but buggy?) gbe way, or the safer (but less elegant?)
1251    f2c way.  */
1252
1253 static tree
1254 ffecom_make_complex_type_ (tree subtype)
1255 {
1256   tree type;
1257   tree realfield;
1258   tree imagfield;
1259
1260   if (ffe_is_emulate_complex ())
1261     {
1262       type = make_node (RECORD_TYPE);
1263       realfield = ffecom_decl_field (type, NULL_TREE, "r", subtype);
1264       imagfield = ffecom_decl_field (type, realfield, "i", subtype);
1265       TYPE_FIELDS (type) = realfield;
1266       layout_type (type);
1267     }
1268   else
1269     {
1270       type = make_node (COMPLEX_TYPE);
1271       TREE_TYPE (type) = subtype;
1272       layout_type (type);
1273     }
1274
1275   return type;
1276 }
1277
1278 /* Chooses either the gbe or the f2c way to build a
1279    complex constant.  */
1280
1281 static tree
1282 ffecom_build_complex_constant_ (tree type, tree realpart, tree imagpart)
1283 {
1284   tree bothparts;
1285
1286   if (ffe_is_emulate_complex ())
1287     {
1288       bothparts = build_tree_list (TYPE_FIELDS (type), realpart);
1289       TREE_CHAIN (bothparts) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), imagpart);
1290       bothparts = build_constructor (type, bothparts);
1291     }
1292   else
1293     {
1294       bothparts = build_complex (type, realpart, imagpart);
1295     }
1296
1297   return bothparts;
1298 }
1299
1300 static tree
1301 ffecom_arglist_expr_ (const char *c, ffebld expr)
1302 {
1303   tree list;
1304   tree *plist = &list;
1305   tree trail = NULL_TREE;       /* Append char length args here. */
1306   tree *ptrail = &trail;
1307   tree length;
1308   ffebld exprh;
1309   tree item;
1310   bool ptr = FALSE;
1311   tree wanted = NULL_TREE;
1312   static const char zed[] = "0";
1313
1314   if (c == NULL)
1315     c = &zed[0];
1316
1317   while (expr != NULL)
1318     {
1319       if (*c != '\0')
1320         {
1321           ptr = FALSE;
1322           if (*c == '&')
1323             {
1324               ptr = TRUE;
1325               ++c;
1326             }
1327           switch (*(c++))
1328             {
1329             case '\0':
1330               ptr = TRUE;
1331               wanted = NULL_TREE;
1332               break;
1333
1334             case 'a':
1335               assert (ptr);
1336               wanted = NULL_TREE;
1337               break;
1338
1339             case 'c':
1340               wanted = ffecom_f2c_complex_type_node;
1341               break;
1342
1343             case 'd':
1344               wanted = ffecom_f2c_doublereal_type_node;
1345               break;
1346
1347             case 'e':
1348               wanted = ffecom_f2c_doublecomplex_type_node;
1349               break;
1350
1351             case 'f':
1352               wanted = ffecom_f2c_real_type_node;
1353               break;
1354
1355             case 'i':
1356               wanted = ffecom_f2c_integer_type_node;
1357               break;
1358
1359             case 'j':
1360               wanted = ffecom_f2c_longint_type_node;
1361               break;
1362
1363             default:
1364               assert ("bad argstring code" == NULL);
1365               wanted = NULL_TREE;
1366               break;
1367             }
1368         }
1369
1370       exprh = ffebld_head (expr);
1371       if (exprh == NULL)
1372         wanted = NULL_TREE;
1373
1374       if ((wanted == NULL_TREE)
1375           || (ptr
1376               && (TYPE_MODE
1377                   (ffecom_tree_type[ffeinfo_basictype (ffebld_info (exprh))]
1378                    [ffeinfo_kindtype (ffebld_info (exprh))])
1379                    == TYPE_MODE (wanted))))
1380         *plist
1381           = build_tree_list (NULL_TREE,
1382                              ffecom_arg_ptr_to_expr (exprh,
1383                                                      &length));
1384       else
1385         {
1386           item = ffecom_arg_expr (exprh, &length);
1387           item = ffecom_convert_widen_ (wanted, item);
1388           if (ptr)
1389             {
1390               item = ffecom_1 (ADDR_EXPR,
1391                                build_pointer_type (TREE_TYPE (item)),
1392                                item);
1393             }
1394           *plist
1395             = build_tree_list (NULL_TREE,
1396                                item);
1397         }
1398
1399       plist = &TREE_CHAIN (*plist);
1400       expr = ffebld_trail (expr);
1401       if (length != NULL_TREE)
1402         {
1403           *ptrail = build_tree_list (NULL_TREE, length);
1404           ptrail = &TREE_CHAIN (*ptrail);
1405         }
1406     }
1407
1408   /* We've run out of args in the call; if the implementation expects
1409      more, supply null pointers for them, which the implementation can
1410      check to see if an arg was omitted. */
1411
1412   while (*c != '\0' && *c != '0')
1413     {
1414       if (*c == '&')
1415         ++c;
1416       else
1417         assert ("missing arg to run-time routine!" == NULL);
1418
1419       switch (*(c++))
1420         {
1421         case '\0':
1422         case 'a':
1423         case 'c':
1424         case 'd':
1425         case 'e':
1426         case 'f':
1427         case 'i':
1428         case 'j':
1429           break;
1430
1431         default:
1432           assert ("bad arg string code" == NULL);
1433           break;
1434         }
1435       *plist
1436         = build_tree_list (NULL_TREE,
1437                            null_pointer_node);
1438       plist = &TREE_CHAIN (*plist);
1439     }
1440
1441   *plist = trail;
1442
1443   return list;
1444 }
1445
1446 static tree
1447 ffecom_widest_expr_type_ (ffebld list)
1448 {
1449   ffebld item;
1450   ffebld widest = NULL;
1451   ffetype type;
1452   ffetype widest_type = NULL;
1453   tree t;
1454
1455   for (; list != NULL; list = ffebld_trail (list))
1456     {
1457       item = ffebld_head (list);
1458       if (item == NULL)
1459         continue;
1460       if ((widest != NULL)
1461           && (ffeinfo_basictype (ffebld_info (item))
1462               != ffeinfo_basictype (ffebld_info (widest))))
1463         continue;
1464       type = ffeinfo_type (ffeinfo_basictype (ffebld_info (item)),
1465                            ffeinfo_kindtype (ffebld_info (item)));
1466       if ((widest == FFEINFO_kindtypeNONE)
1467           || (ffetype_size (type)
1468               > ffetype_size (widest_type)))
1469         {
1470           widest = item;
1471           widest_type = type;
1472         }
1473     }
1474
1475   assert (widest != NULL);
1476   t = ffecom_tree_type[ffeinfo_basictype (ffebld_info (widest))]
1477     [ffeinfo_kindtype (ffebld_info (widest))];
1478   assert (t != NULL_TREE);
1479   return t;
1480 }
1481
1482 /* Check whether a partial overlap between two expressions is possible.
1483
1484    Can *starting* to write a portion of expr1 change the value
1485    computed (perhaps already, *partially*) by expr2?
1486
1487    Currently, this is a concern only for a COMPLEX expr1.  But if it
1488    isn't in COMMON or local EQUIVALENCE, since we don't support
1489    aliasing of arguments, it isn't a concern.  */
1490
1491 static bool
1492 ffecom_possible_partial_overlap_ (ffebld expr1, ffebld expr2 ATTRIBUTE_UNUSED)
1493 {
1494   ffesymbol sym;
1495   ffestorag st;
1496
1497   switch (ffebld_op (expr1))
1498     {
1499     case FFEBLD_opSYMTER:
1500       sym = ffebld_symter (expr1);
1501       break;
1502
1503     case FFEBLD_opARRAYREF:
1504       if (ffebld_op (ffebld_left (expr1)) != FFEBLD_opSYMTER)
1505         return FALSE;
1506       sym = ffebld_symter (ffebld_left (expr1));
1507       break;
1508
1509     default:
1510       return FALSE;
1511     }
1512
1513   if (ffesymbol_where (sym) != FFEINFO_whereCOMMON
1514       && (ffesymbol_where (sym) != FFEINFO_whereLOCAL
1515           || ! (st = ffesymbol_storage (sym))
1516           || ! ffestorag_parent (st)))
1517     return FALSE;
1518
1519   /* It's in COMMON or local EQUIVALENCE.  */
1520
1521   return TRUE;
1522 }
1523
1524 /* Check whether dest and source might overlap.  ffebld versions of these
1525    might or might not be passed, will be NULL if not.
1526
1527    The test is really whether source_tree is modifiable and, if modified,
1528    might overlap destination such that the value(s) in the destination might
1529    change before it is finally modified.  dest_* are the canonized
1530    destination itself.  */
1531
1532 static bool
1533 ffecom_overlap_ (tree dest_decl, tree dest_offset, tree dest_size,
1534                  tree source_tree, ffebld source UNUSED,
1535                  bool scalar_arg)
1536 {
1537   tree source_decl;
1538   tree source_offset;
1539   tree source_size;
1540   tree t;
1541
1542   if (source_tree == NULL_TREE)
1543     return FALSE;
1544
1545   switch (TREE_CODE (source_tree))
1546     {
1547     case ERROR_MARK:
1548     case IDENTIFIER_NODE:
1549     case INTEGER_CST:
1550     case REAL_CST:
1551     case COMPLEX_CST:
1552     case STRING_CST:
1553     case CONST_DECL:
1554     case VAR_DECL:
1555     case RESULT_DECL:
1556     case FIELD_DECL:
1557     case MINUS_EXPR:
1558     case MULT_EXPR:
1559     case TRUNC_DIV_EXPR:
1560     case CEIL_DIV_EXPR:
1561     case FLOOR_DIV_EXPR:
1562     case ROUND_DIV_EXPR:
1563     case TRUNC_MOD_EXPR:
1564     case CEIL_MOD_EXPR:
1565     case FLOOR_MOD_EXPR:
1566     case ROUND_MOD_EXPR:
1567     case RDIV_EXPR:
1568     case EXACT_DIV_EXPR:
1569     case FIX_TRUNC_EXPR:
1570     case FIX_CEIL_EXPR:
1571     case FIX_FLOOR_EXPR:
1572     case FIX_ROUND_EXPR:
1573     case FLOAT_EXPR:
1574     case NEGATE_EXPR:
1575     case MIN_EXPR:
1576     case MAX_EXPR:
1577     case ABS_EXPR:
1578     case FFS_EXPR:
1579     case LSHIFT_EXPR:
1580     case RSHIFT_EXPR:
1581     case LROTATE_EXPR:
1582     case RROTATE_EXPR:
1583     case BIT_IOR_EXPR:
1584     case BIT_XOR_EXPR:
1585     case BIT_AND_EXPR:
1586     case BIT_ANDTC_EXPR:
1587     case BIT_NOT_EXPR:
1588     case TRUTH_ANDIF_EXPR:
1589     case TRUTH_ORIF_EXPR:
1590     case TRUTH_AND_EXPR:
1591     case TRUTH_OR_EXPR:
1592     case TRUTH_XOR_EXPR:
1593     case TRUTH_NOT_EXPR:
1594     case LT_EXPR:
1595     case LE_EXPR:
1596     case GT_EXPR:
1597     case GE_EXPR:
1598     case EQ_EXPR:
1599     case NE_EXPR:
1600     case COMPLEX_EXPR:
1601     case CONJ_EXPR:
1602     case REALPART_EXPR:
1603     case IMAGPART_EXPR:
1604     case LABEL_EXPR:
1605     case COMPONENT_REF:
1606       return FALSE;
1607
1608     case COMPOUND_EXPR:
1609       return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1610                               TREE_OPERAND (source_tree, 1), NULL,
1611                               scalar_arg);
1612
1613     case MODIFY_EXPR:
1614       return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1615                               TREE_OPERAND (source_tree, 0), NULL,
1616                               scalar_arg);
1617
1618     case CONVERT_EXPR:
1619     case NOP_EXPR:
1620     case NON_LVALUE_EXPR:
1621     case PLUS_EXPR:
1622       if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1623         return TRUE;
1624
1625       ffecom_tree_canonize_ptr_ (&source_decl, &source_offset,
1626                                  source_tree);
1627       source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1628       break;
1629
1630     case COND_EXPR:
1631       return
1632         ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1633                          TREE_OPERAND (source_tree, 1), NULL,
1634                          scalar_arg)
1635           || ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1636                               TREE_OPERAND (source_tree, 2), NULL,
1637                               scalar_arg);
1638
1639
1640     case ADDR_EXPR:
1641       ffecom_tree_canonize_ref_ (&source_decl, &source_offset,
1642                                  &source_size,
1643                                  TREE_OPERAND (source_tree, 0));
1644       break;
1645
1646     case PARM_DECL:
1647       if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1648         return TRUE;
1649
1650       source_decl = source_tree;
1651       source_offset = bitsize_zero_node;
1652       source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1653       break;
1654
1655     case SAVE_EXPR:
1656     case REFERENCE_EXPR:
1657     case PREDECREMENT_EXPR:
1658     case PREINCREMENT_EXPR:
1659     case POSTDECREMENT_EXPR:
1660     case POSTINCREMENT_EXPR:
1661     case INDIRECT_REF:
1662     case ARRAY_REF:
1663     case CALL_EXPR:
1664     default:
1665       return TRUE;
1666     }
1667
1668   /* Come here when source_decl, source_offset, and source_size filled
1669      in appropriately.  */
1670
1671   if (source_decl == NULL_TREE)
1672     return FALSE;               /* No decl involved, so no overlap. */
1673
1674   if (source_decl != dest_decl)
1675     return FALSE;               /* Different decl, no overlap. */
1676
1677   if (TREE_CODE (dest_size) == ERROR_MARK)
1678     return TRUE;                /* Assignment into entire assumed-size
1679                                    array?  Shouldn't happen.... */
1680
1681   t = ffecom_2 (LE_EXPR, integer_type_node,
1682                 ffecom_2 (PLUS_EXPR, TREE_TYPE (dest_offset),
1683                           dest_offset,
1684                           convert (TREE_TYPE (dest_offset),
1685                                    dest_size)),
1686                 convert (TREE_TYPE (dest_offset),
1687                          source_offset));
1688
1689   if (integer_onep (t))
1690     return FALSE;               /* Destination precedes source. */
1691
1692   if (!scalar_arg
1693       || (source_size == NULL_TREE)
1694       || (TREE_CODE (source_size) == ERROR_MARK)
1695       || integer_zerop (source_size))
1696     return TRUE;                /* No way to tell if dest follows source. */
1697
1698   t = ffecom_2 (LE_EXPR, integer_type_node,
1699                 ffecom_2 (PLUS_EXPR, TREE_TYPE (source_offset),
1700                           source_offset,
1701                           convert (TREE_TYPE (source_offset),
1702                                    source_size)),
1703                 convert (TREE_TYPE (source_offset),
1704                          dest_offset));
1705
1706   if (integer_onep (t))
1707     return FALSE;               /* Destination follows source. */
1708
1709   return TRUE;          /* Destination and source overlap. */
1710 }
1711
1712 /* Check whether dest might overlap any of a list of arguments or is
1713    in a COMMON area the callee might know about (and thus modify).  */
1714
1715 static bool
1716 ffecom_args_overlapping_ (tree dest_tree, ffebld dest UNUSED,
1717                           tree args, tree callee_commons,
1718                           bool scalar_args)
1719 {
1720   tree arg;
1721   tree dest_decl;
1722   tree dest_offset;
1723   tree dest_size;
1724
1725   ffecom_tree_canonize_ref_ (&dest_decl, &dest_offset, &dest_size,
1726                              dest_tree);
1727
1728   if (dest_decl == NULL_TREE)
1729     return FALSE;               /* Seems unlikely! */
1730
1731   /* If the decl cannot be determined reliably, or if its in COMMON
1732      and the callee isn't known to not futz with COMMON via other
1733      means, overlap might happen.  */
1734
1735   if ((TREE_CODE (dest_decl) == ERROR_MARK)
1736       || ((callee_commons != NULL_TREE)
1737           && TREE_PUBLIC (dest_decl)))
1738     return TRUE;
1739
1740   for (; args != NULL_TREE; args = TREE_CHAIN (args))
1741     {
1742       if (((arg = TREE_VALUE (args)) != NULL_TREE)
1743           && ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1744                               arg, NULL, scalar_args))
1745         return TRUE;
1746     }
1747
1748   return FALSE;
1749 }
1750
1751 /* Build a string for a variable name as used by NAMELIST.  This means that
1752    if we're using the f2c library, we build an uppercase string, since
1753    f2c does this.  */
1754
1755 static tree
1756 ffecom_build_f2c_string_ (int i, const char *s)
1757 {
1758   if (!ffe_is_f2c_library ())
1759     return build_string (i, s);
1760
1761   {
1762     char *tmp;
1763     const char *p;
1764     char *q;
1765     char space[34];
1766     tree t;
1767
1768     if (((size_t) i) > ARRAY_SIZE (space))
1769       tmp = malloc_new_ks (malloc_pool_image (), "f2c_string", i);
1770     else
1771       tmp = &space[0];
1772
1773     for (p = s, q = tmp; *p != '\0'; ++p, ++q)
1774       *q = TOUPPER (*p);
1775     *q = '\0';
1776
1777     t = build_string (i, tmp);
1778
1779     if (((size_t) i) > ARRAY_SIZE (space))
1780       malloc_kill_ks (malloc_pool_image (), tmp, i);
1781
1782     return t;
1783   }
1784 }
1785
1786 /* Returns CALL_EXPR or equivalent with given type (pass NULL_TREE for
1787    type to just get whatever the function returns), handling the
1788    f2c value-returning convention, if required, by prepending
1789    to the arglist a pointer to a temporary to receive the return value.  */
1790
1791 static tree
1792 ffecom_call_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1793               tree type, tree args, tree dest_tree,
1794               ffebld dest, bool *dest_used, tree callee_commons,
1795               bool scalar_args, tree hook)
1796 {
1797   tree item;
1798   tree tempvar;
1799
1800   if (dest_used != NULL)
1801     *dest_used = FALSE;
1802
1803   if (is_f2c_complex)
1804     {
1805       if ((dest_used == NULL)
1806           || (dest == NULL)
1807           || (ffeinfo_basictype (ffebld_info (dest))
1808               != FFEINFO_basictypeCOMPLEX)
1809           || (ffeinfo_kindtype (ffebld_info (dest)) != kt)
1810           || ((type != NULL_TREE) && (TREE_TYPE (dest_tree) != type))
1811           || ffecom_args_overlapping_ (dest_tree, dest, args,
1812                                        callee_commons,
1813                                        scalar_args))
1814         {
1815           tempvar = hook;
1816           assert (tempvar);
1817         }
1818       else
1819         {
1820           *dest_used = TRUE;
1821           tempvar = dest_tree;
1822           type = NULL_TREE;
1823         }
1824
1825       item
1826         = build_tree_list (NULL_TREE,
1827                            ffecom_1 (ADDR_EXPR,
1828                                      build_pointer_type (TREE_TYPE (tempvar)),
1829                                      tempvar));
1830       TREE_CHAIN (item) = args;
1831
1832       item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1833                         item, NULL_TREE);
1834
1835       if (tempvar != dest_tree)
1836         item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item, tempvar);
1837     }
1838   else
1839     item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1840                       args, NULL_TREE);
1841
1842   if ((type != NULL_TREE) && (TREE_TYPE (item) != type))
1843     item = ffecom_convert_narrow_ (type, item);
1844
1845   return item;
1846 }
1847
1848 /* Given two arguments, transform them and make a call to the given
1849    function via ffecom_call_.  */
1850
1851 static tree
1852 ffecom_call_binop_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1853                     tree type, ffebld left, ffebld right,
1854                     tree dest_tree, ffebld dest, bool *dest_used,
1855                     tree callee_commons, bool scalar_args, bool ref, tree hook)
1856 {
1857   tree left_tree;
1858   tree right_tree;
1859   tree left_length;
1860   tree right_length;
1861
1862   if (ref)
1863     {
1864       /* Pass arguments by reference.  */
1865       left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
1866       right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
1867     }
1868   else
1869     {
1870       /* Pass arguments by value.  */
1871       left_tree = ffecom_arg_expr (left, &left_length);
1872       right_tree = ffecom_arg_expr (right, &right_length);
1873     }
1874
1875
1876   left_tree = build_tree_list (NULL_TREE, left_tree);
1877   right_tree = build_tree_list (NULL_TREE, right_tree);
1878   TREE_CHAIN (left_tree) = right_tree;
1879
1880   if (left_length != NULL_TREE)
1881     {
1882       left_length = build_tree_list (NULL_TREE, left_length);
1883       TREE_CHAIN (right_tree) = left_length;
1884     }
1885
1886   if (right_length != NULL_TREE)
1887     {
1888       right_length = build_tree_list (NULL_TREE, right_length);
1889       if (left_length != NULL_TREE)
1890         TREE_CHAIN (left_length) = right_length;
1891       else
1892         TREE_CHAIN (right_tree) = right_length;
1893     }
1894
1895   return ffecom_call_ (fn, kt, is_f2c_complex, type, left_tree,
1896                        dest_tree, dest, dest_used, callee_commons,
1897                        scalar_args, hook);
1898 }
1899
1900 /* Return ptr/length args for char subexpression
1901
1902    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
1903    subexpressions by constructing the appropriate trees for the ptr-to-
1904    character-text and length-of-character-text arguments in a calling
1905    sequence.
1906
1907    Note that if with_null is TRUE, and the expression is an opCONTER,
1908    a null byte is appended to the string.  */
1909
1910 static void
1911 ffecom_char_args_x_ (tree *xitem, tree *length, ffebld expr, bool with_null)
1912 {
1913   tree item;
1914   tree high;
1915   ffetargetCharacter1 val;
1916   ffetargetCharacterSize newlen;
1917
1918   switch (ffebld_op (expr))
1919     {
1920     case FFEBLD_opCONTER:
1921       val = ffebld_constant_character1 (ffebld_conter (expr));
1922       newlen = ffetarget_length_character1 (val);
1923       if (with_null)
1924         {
1925           /* Begin FFETARGET-NULL-KLUDGE.  */
1926           if (newlen != 0)
1927             ++newlen;
1928         }
1929       *length = build_int_2 (newlen, 0);
1930       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
1931       high = build_int_2 (newlen, 0);
1932       TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
1933       item = build_string (newlen,
1934                            ffetarget_text_character1 (val));
1935       /* End FFETARGET-NULL-KLUDGE.  */
1936       TREE_TYPE (item)
1937         = build_type_variant
1938           (build_array_type
1939            (char_type_node,
1940             build_range_type
1941             (ffecom_f2c_ftnlen_type_node,
1942              ffecom_f2c_ftnlen_one_node,
1943              high)),
1944            1, 0);
1945       TREE_CONSTANT (item) = 1;
1946       TREE_STATIC (item) = 1;
1947       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
1948                        item);
1949       break;
1950
1951     case FFEBLD_opSYMTER:
1952       {
1953         ffesymbol s = ffebld_symter (expr);
1954
1955         item = ffesymbol_hook (s).decl_tree;
1956         if (item == NULL_TREE)
1957           {
1958             s = ffecom_sym_transform_ (s);
1959             item = ffesymbol_hook (s).decl_tree;
1960           }
1961         if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
1962           {
1963             if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
1964               *length = ffesymbol_hook (s).length_tree;
1965             else
1966               {
1967                 *length = build_int_2 (ffesymbol_size (s), 0);
1968                 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
1969               }
1970           }
1971         else if (item == error_mark_node)
1972           *length = error_mark_node;
1973         else
1974           /* FFEINFO_kindFUNCTION.  */
1975           *length = NULL_TREE;
1976         if (!ffesymbol_hook (s).addr
1977             && (item != error_mark_node))
1978           item = ffecom_1 (ADDR_EXPR,
1979                            build_pointer_type (TREE_TYPE (item)),
1980                            item);
1981       }
1982       break;
1983
1984     case FFEBLD_opARRAYREF:
1985       {
1986         ffecom_char_args_ (&item, length, ffebld_left (expr));
1987
1988         if (item == error_mark_node || *length == error_mark_node)
1989           {
1990             item = *length = error_mark_node;
1991             break;
1992           }
1993
1994         item = ffecom_arrayref_ (item, expr, 1);
1995       }
1996       break;
1997
1998     case FFEBLD_opSUBSTR:
1999       {
2000         ffebld start;
2001         ffebld end;
2002         ffebld thing = ffebld_right (expr);
2003         tree start_tree;
2004         tree end_tree;
2005         const char *char_name;
2006         ffebld left_symter;
2007         tree array;
2008
2009         assert (ffebld_op (thing) == FFEBLD_opITEM);
2010         start = ffebld_head (thing);
2011         thing = ffebld_trail (thing);
2012         assert (ffebld_trail (thing) == NULL);
2013         end = ffebld_head (thing);
2014
2015         /* Determine name for pretty-printing range-check errors.  */
2016         for (left_symter = ffebld_left (expr);
2017              left_symter && ffebld_op (left_symter) == FFEBLD_opARRAYREF;
2018              left_symter = ffebld_left (left_symter))
2019           ;
2020         if (ffebld_op (left_symter) == FFEBLD_opSYMTER)
2021           char_name = ffesymbol_text (ffebld_symter (left_symter));
2022         else
2023           char_name = "[expr?]";
2024
2025         ffecom_char_args_ (&item, length, ffebld_left (expr));
2026
2027         if (item == error_mark_node || *length == error_mark_node)
2028           {
2029             item = *length = error_mark_node;
2030             break;
2031           }
2032
2033         array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
2034
2035         /* ~~~~Handle INTEGER*8 start/end, a la FFEBLD_opARRAYREF.  */
2036
2037         if (start == NULL)
2038           {
2039             if (end == NULL)
2040               ;
2041             else
2042               {
2043                 end_tree = ffecom_expr (end);
2044                 if (flag_bounds_check)
2045                   end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2046                                                       char_name);
2047                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2048                                     end_tree);
2049
2050                 if (end_tree == error_mark_node)
2051                   {
2052                     item = *length = error_mark_node;
2053                     break;
2054                   }
2055
2056                 *length = end_tree;
2057               }
2058           }
2059         else
2060           {
2061             start_tree = ffecom_expr (start);
2062             if (flag_bounds_check)
2063               start_tree = ffecom_subscript_check_ (array, start_tree, 0, 0,
2064                                                     char_name);
2065             start_tree = convert (ffecom_f2c_ftnlen_type_node,
2066                                   start_tree);
2067
2068             if (start_tree == error_mark_node)
2069               {
2070                 item = *length = error_mark_node;
2071                 break;
2072               }
2073
2074             start_tree = ffecom_save_tree (start_tree);
2075
2076             item = ffecom_2 (PLUS_EXPR, TREE_TYPE (item),
2077                              item,
2078                              ffecom_2 (MINUS_EXPR,
2079                                        TREE_TYPE (start_tree),
2080                                        start_tree,
2081                                        ffecom_f2c_ftnlen_one_node));
2082
2083             if (end == NULL)
2084               {
2085                 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2086                                     ffecom_f2c_ftnlen_one_node,
2087                                     ffecom_2 (MINUS_EXPR,
2088                                               ffecom_f2c_ftnlen_type_node,
2089                                               *length,
2090                                               start_tree));
2091               }
2092             else
2093               {
2094                 end_tree = ffecom_expr (end);
2095                 if (flag_bounds_check)
2096                   end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2097                                                       char_name);
2098                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2099                                     end_tree);
2100
2101                 if (end_tree == error_mark_node)
2102                   {
2103                     item = *length = error_mark_node;
2104                     break;
2105                   }
2106
2107                 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2108                                     ffecom_f2c_ftnlen_one_node,
2109                                     ffecom_2 (MINUS_EXPR,
2110                                               ffecom_f2c_ftnlen_type_node,
2111                                               end_tree, start_tree));
2112               }
2113           }
2114       }
2115       break;
2116
2117     case FFEBLD_opFUNCREF:
2118       {
2119         ffesymbol s = ffebld_symter (ffebld_left (expr));
2120         tree tempvar;
2121         tree args;
2122         ffetargetCharacterSize size = ffeinfo_size (ffebld_info (expr));
2123         ffecomGfrt ix;
2124
2125         if (size == FFETARGET_charactersizeNONE)
2126           /* ~~Kludge alert!  This should someday be fixed. */
2127           size = 24;
2128
2129         *length = build_int_2 (size, 0);
2130         TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2131
2132         if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
2133             == FFEINFO_whereINTRINSIC)
2134           {
2135             if (size == 1)
2136               {
2137                 /* Invocation of an intrinsic returning CHARACTER*1.  */
2138                 item = ffecom_expr_intrinsic_ (expr, NULL_TREE,
2139                                                NULL, NULL);
2140                 break;
2141               }
2142             ix = ffeintrin_gfrt_direct (ffebld_symter_implementation (ffebld_left (expr)));
2143             assert (ix != FFECOM_gfrt);
2144             item = ffecom_gfrt_tree_ (ix);
2145           }
2146         else
2147           {
2148             ix = FFECOM_gfrt;
2149             item = ffesymbol_hook (s).decl_tree;
2150             if (item == NULL_TREE)
2151               {
2152                 s = ffecom_sym_transform_ (s);
2153                 item = ffesymbol_hook (s).decl_tree;
2154               }
2155             if (item == error_mark_node)
2156               {
2157                 item = *length = error_mark_node;
2158                 break;
2159               }
2160
2161             if (!ffesymbol_hook (s).addr)
2162               item = ffecom_1_fn (item);
2163           }
2164         tempvar = ffebld_nonter_hook (expr);
2165         assert (tempvar);
2166         tempvar = ffecom_1 (ADDR_EXPR,
2167                             build_pointer_type (TREE_TYPE (tempvar)),
2168                             tempvar);
2169
2170         args = build_tree_list (NULL_TREE, tempvar);
2171
2172         if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)       /* Sfunc args by value. */
2173           TREE_CHAIN (args) = ffecom_list_expr (ffebld_right (expr));
2174         else
2175           {
2176             TREE_CHAIN (args) = build_tree_list (NULL_TREE, *length);
2177             if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
2178               {
2179                 TREE_CHAIN (TREE_CHAIN (args))
2180                   = ffecom_arglist_expr_ (ffecom_gfrt_args_ (ix),
2181                                           ffebld_right (expr));
2182               }
2183             else
2184               {
2185                 TREE_CHAIN (TREE_CHAIN (args))
2186                   = ffecom_list_ptr_to_expr (ffebld_right (expr));
2187               }
2188           }
2189
2190         item = ffecom_3s (CALL_EXPR,
2191                           TREE_TYPE (TREE_TYPE (TREE_TYPE (item))),
2192                           item, args, NULL_TREE);
2193         item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item,
2194                          tempvar);
2195       }
2196       break;
2197
2198     case FFEBLD_opCONVERT:
2199
2200       ffecom_char_args_ (&item, length, ffebld_left (expr));
2201
2202       if (item == error_mark_node || *length == error_mark_node)
2203         {
2204           item = *length = error_mark_node;
2205           break;
2206         }
2207
2208       if ((ffebld_size_known (ffebld_left (expr))
2209            == FFETARGET_charactersizeNONE)
2210           || (ffebld_size_known (ffebld_left (expr)) < (ffebld_size (expr))))
2211         {                       /* Possible blank-padding needed, copy into
2212                                    temporary. */
2213           tree tempvar;
2214           tree args;
2215           tree newlen;
2216
2217           tempvar = ffebld_nonter_hook (expr);
2218           assert (tempvar);
2219           tempvar = ffecom_1 (ADDR_EXPR,
2220                               build_pointer_type (TREE_TYPE (tempvar)),
2221                               tempvar);
2222
2223           newlen = build_int_2 (ffebld_size (expr), 0);
2224           TREE_TYPE (newlen) = ffecom_f2c_ftnlen_type_node;
2225
2226           args = build_tree_list (NULL_TREE, tempvar);
2227           TREE_CHAIN (args) = build_tree_list (NULL_TREE, item);
2228           TREE_CHAIN (TREE_CHAIN (args)) = build_tree_list (NULL_TREE, newlen);
2229           TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (args)))
2230             = build_tree_list (NULL_TREE, *length);
2231
2232           item = ffecom_call_gfrt (FFECOM_gfrtCOPY, args, NULL_TREE);
2233           TREE_SIDE_EFFECTS (item) = 1;
2234           item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), fold (item),
2235                            tempvar);
2236           *length = newlen;
2237         }
2238       else
2239         {                       /* Just truncate the length. */
2240           *length = build_int_2 (ffebld_size (expr), 0);
2241           TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2242         }
2243       break;
2244
2245     default:
2246       assert ("bad op for single char arg expr" == NULL);
2247       item = NULL_TREE;
2248       break;
2249     }
2250
2251   *xitem = item;
2252 }
2253
2254 /* Check the size of the type to be sure it doesn't overflow the
2255    "portable" capacities of the compiler back end.  `dummy' types
2256    can generally overflow the normal sizes as long as the computations
2257    themselves don't overflow.  A particular target of the back end
2258    must still enforce its size requirements, though, and the back
2259    end takes care of this in stor-layout.c.  */
2260
2261 static tree
2262 ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy)
2263 {
2264   if (TREE_CODE (type) == ERROR_MARK)
2265     return type;
2266
2267   if (TYPE_SIZE (type) == NULL_TREE)
2268     return type;
2269
2270   if (TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST)
2271     return type;
2272
2273   /* An array is too large if size is negative or the type_size overflows
2274      or its "upper half" is larger than 3 (which would make the signed
2275      byte size and offset computations overflow).  */
2276
2277   if ((tree_int_cst_sgn (TYPE_SIZE (type)) < 0)
2278       || (!dummy && (TREE_INT_CST_HIGH (TYPE_SIZE (type)) > 3
2279                      || TREE_OVERFLOW (TYPE_SIZE (type)))))
2280     {
2281       ffebad_start (FFEBAD_ARRAY_LARGE);
2282       ffebad_string (ffesymbol_text (s));
2283       ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s));
2284       ffebad_finish ();
2285
2286       return error_mark_node;
2287     }
2288
2289   return type;
2290 }
2291
2292 /* Builds a length argument (PARM_DECL).  Also wraps type in an array type
2293    where the dimension info is (1:size) where <size> is ffesymbol_size(s) if
2294    known, length_arg if not known (FFETARGET_charactersizeNONE).  */
2295
2296 static tree
2297 ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s)
2298 {
2299   ffetargetCharacterSize sz = ffesymbol_size (s);
2300   tree highval;
2301   tree tlen;
2302   tree type = *xtype;
2303
2304   if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
2305     tlen = NULL_TREE;           /* A statement function, no length passed. */
2306   else
2307     {
2308       if (ffesymbol_where (s) == FFEINFO_whereDUMMY)
2309         tlen = ffecom_get_invented_identifier ("__g77_length_%s",
2310                                                ffesymbol_text (s));
2311       else
2312         tlen = ffecom_get_invented_identifier ("__g77_%s", "length");
2313       tlen = build_decl (PARM_DECL, tlen, ffecom_f2c_ftnlen_type_node);
2314       DECL_ARTIFICIAL (tlen) = 1;
2315     }
2316
2317   if (sz == FFETARGET_charactersizeNONE)
2318     {
2319       assert (tlen != NULL_TREE);
2320       highval = variable_size (tlen);
2321     }
2322   else
2323     {
2324       highval = build_int_2 (sz, 0);
2325       TREE_TYPE (highval) = ffecom_f2c_ftnlen_type_node;
2326     }
2327
2328   type = build_array_type (type,
2329                            build_range_type (ffecom_f2c_ftnlen_type_node,
2330                                              ffecom_f2c_ftnlen_one_node,
2331                                              highval));
2332
2333   *xtype = type;
2334   return tlen;
2335 }
2336
2337 /* ffecom_concat_list_gather_ -- Gather list of concatenated string exprs
2338
2339    ffecomConcatList_ catlist;
2340    ffebld expr;  // expr of CHARACTER basictype.
2341    ffetargetCharacterSize max;  // max chars to gather or _...NONE if no max
2342    catlist = ffecom_concat_list_gather_(catlist,expr,max);
2343
2344    Scans expr for character subexpressions, updates and returns catlist
2345    accordingly.  */
2346
2347 static ffecomConcatList_
2348 ffecom_concat_list_gather_ (ffecomConcatList_ catlist, ffebld expr,
2349                             ffetargetCharacterSize max)
2350 {
2351   ffetargetCharacterSize sz;
2352
2353  recurse:
2354
2355   if (expr == NULL)
2356     return catlist;
2357
2358   if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen >= max))
2359     return catlist;             /* Don't append any more items. */
2360
2361   switch (ffebld_op (expr))
2362     {
2363     case FFEBLD_opCONTER:
2364     case FFEBLD_opSYMTER:
2365     case FFEBLD_opARRAYREF:
2366     case FFEBLD_opFUNCREF:
2367     case FFEBLD_opSUBSTR:
2368     case FFEBLD_opCONVERT:      /* Callers should strip this off beforehand
2369                                    if they don't need to preserve it. */
2370       if (catlist.count == catlist.max)
2371         {                       /* Make a (larger) list. */
2372           ffebld *newx;
2373           int newmax;
2374
2375           newmax = (catlist.max == 0) ? 8 : catlist.max * 2;
2376           newx = malloc_new_ks (malloc_pool_image (), "catlist",
2377                                 newmax * sizeof (newx[0]));
2378           if (catlist.max != 0)
2379             {
2380               memcpy (newx, catlist.exprs, catlist.max * sizeof (newx[0]));
2381               malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2382                               catlist.max * sizeof (newx[0]));
2383             }
2384           catlist.max = newmax;
2385           catlist.exprs = newx;
2386         }
2387       if ((sz = ffebld_size_known (expr)) != FFETARGET_charactersizeNONE)
2388         catlist.minlen += sz;
2389       else
2390         ++catlist.minlen;       /* Not true for F90; can be 0 length. */
2391       if ((sz = ffebld_size_max (expr)) == FFETARGET_charactersizeNONE)
2392         catlist.maxlen = sz;
2393       else
2394         catlist.maxlen += sz;
2395       if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen > max))
2396         {                       /* This item overlaps (or is beyond) the end
2397                                    of the destination. */
2398           switch (ffebld_op (expr))
2399             {
2400             case FFEBLD_opCONTER:
2401             case FFEBLD_opSYMTER:
2402             case FFEBLD_opARRAYREF:
2403             case FFEBLD_opFUNCREF:
2404             case FFEBLD_opSUBSTR:
2405               /* ~~Do useful truncations here. */
2406               break;
2407
2408             default:
2409               assert ("op changed or inconsistent switches!" == NULL);
2410               break;
2411             }
2412         }
2413       catlist.exprs[catlist.count++] = expr;
2414       return catlist;
2415
2416     case FFEBLD_opPAREN:
2417       expr = ffebld_left (expr);
2418       goto recurse;             /* :::::::::::::::::::: */
2419
2420     case FFEBLD_opCONCATENATE:
2421       catlist = ffecom_concat_list_gather_ (catlist, ffebld_left (expr), max);
2422       expr = ffebld_right (expr);
2423       goto recurse;             /* :::::::::::::::::::: */
2424
2425 #if 0                           /* Breaks passing small actual arg to larger
2426                                    dummy arg of sfunc */
2427     case FFEBLD_opCONVERT:
2428       expr = ffebld_left (expr);
2429       {
2430         ffetargetCharacterSize cmax;
2431
2432         cmax = catlist.len + ffebld_size_known (expr);
2433
2434         if ((max == FFETARGET_charactersizeNONE) || (max > cmax))
2435           max = cmax;
2436       }
2437       goto recurse;             /* :::::::::::::::::::: */
2438 #endif
2439
2440     case FFEBLD_opANY:
2441       return catlist;
2442
2443     default:
2444       assert ("bad op in _gather_" == NULL);
2445       return catlist;
2446     }
2447 }
2448
2449 /* ffecom_concat_list_kill_ -- Kill list of concatenated string exprs
2450
2451    ffecomConcatList_ catlist;
2452    ffecom_concat_list_kill_(catlist);
2453
2454    Anything allocated within the list info is deallocated.  */
2455
2456 static void
2457 ffecom_concat_list_kill_ (ffecomConcatList_ catlist)
2458 {
2459   if (catlist.max != 0)
2460     malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2461                     catlist.max * sizeof (catlist.exprs[0]));
2462 }
2463
2464 /* Make list of concatenated string exprs.
2465
2466    Returns a flattened list of concatenated subexpressions given a
2467    tree of such expressions.  */
2468
2469 static ffecomConcatList_
2470 ffecom_concat_list_new_ (ffebld expr, ffetargetCharacterSize max)
2471 {
2472   ffecomConcatList_ catlist;
2473
2474   catlist.maxlen = catlist.minlen = catlist.max = catlist.count = 0;
2475   return ffecom_concat_list_gather_ (catlist, expr, max);
2476 }
2477
2478 /* Provide some kind of useful info on member of aggregate area,
2479    since current g77/gcc technology does not provide debug info
2480    on these members.  */
2481
2482 static void
2483 ffecom_debug_kludge_ (tree aggr, const char *aggr_type, ffesymbol member,
2484                       tree member_type UNUSED, ffetargetOffset offset)
2485 {
2486   tree value;
2487   tree decl;
2488   int len;
2489   char *buff;
2490   char space[120];
2491 #if 0
2492   tree type_id;
2493
2494   for (type_id = member_type;
2495        TREE_CODE (type_id) != IDENTIFIER_NODE;
2496        )
2497     {
2498       switch (TREE_CODE (type_id))
2499         {
2500         case INTEGER_TYPE:
2501         case REAL_TYPE:
2502           type_id = TYPE_NAME (type_id);
2503           break;
2504
2505         case ARRAY_TYPE:
2506         case COMPLEX_TYPE:
2507           type_id = TREE_TYPE (type_id);
2508           break;
2509
2510         default:
2511           assert ("no IDENTIFIER_NODE for type!" == NULL);
2512           type_id = error_mark_node;
2513           break;
2514         }
2515     }
2516 #endif
2517
2518   if (ffecom_transform_only_dummies_
2519       || !ffe_is_debug_kludge ())
2520     return;     /* Can't do this yet, maybe later. */
2521
2522   len = 60
2523     + strlen (aggr_type)
2524     + IDENTIFIER_LENGTH (DECL_NAME (aggr));
2525 #if 0
2526     + IDENTIFIER_LENGTH (type_id);
2527 #endif
2528
2529   if (((size_t) len) >= ARRAY_SIZE (space))
2530     buff = malloc_new_ks (malloc_pool_image (), "debug_kludge", len + 1);
2531   else
2532     buff = &space[0];
2533
2534   sprintf (&buff[0], "At (%s) `%s' plus %ld bytes",
2535            aggr_type,
2536            IDENTIFIER_POINTER (DECL_NAME (aggr)),
2537            (long int) offset);
2538
2539   value = build_string (len, buff);
2540   TREE_TYPE (value)
2541     = build_type_variant (build_array_type (char_type_node,
2542                                             build_range_type
2543                                             (integer_type_node,
2544                                              integer_one_node,
2545                                              build_int_2 (strlen (buff), 0))),
2546                           1, 0);
2547   decl = build_decl (VAR_DECL,
2548                      ffecom_get_identifier_ (ffesymbol_text (member)),
2549                      TREE_TYPE (value));
2550   TREE_CONSTANT (decl) = 1;
2551   TREE_STATIC (decl) = 1;
2552   DECL_INITIAL (decl) = error_mark_node;
2553   DECL_IN_SYSTEM_HEADER (decl) = 1;     /* Don't let -Wunused complain. */
2554   decl = start_decl (decl, FALSE);
2555   finish_decl (decl, value, FALSE);
2556
2557   if (buff != &space[0])
2558     malloc_kill_ks (malloc_pool_image (), buff, len + 1);
2559 }
2560
2561 /* ffecom_do_entry_ -- Do compilation of a particular entrypoint
2562
2563    ffesymbol fn;  // the SUBROUTINE, FUNCTION, or ENTRY symbol itself
2564    int i;  // entry# for this entrypoint (used by master fn)
2565    ffecom_do_entrypoint_(s,i);
2566
2567    Makes a public entry point that calls our private master fn (already
2568    compiled).  */
2569
2570 static void
2571 ffecom_do_entry_ (ffesymbol fn, int entrynum)
2572 {
2573   ffebld item;
2574   tree type;                    /* Type of function. */
2575   tree multi_retval;            /* Var holding return value (union). */
2576   tree result;                  /* Var holding result. */
2577   ffeinfoBasictype bt;
2578   ffeinfoKindtype kt;
2579   ffeglobal g;
2580   ffeglobalType gt;
2581   bool charfunc;                /* All entry points return same type
2582                                    CHARACTER. */
2583   bool cmplxfunc;               /* Use f2c way of returning COMPLEX. */
2584   bool multi;                   /* Master fn has multiple return types. */
2585   bool altreturning = FALSE;    /* This entry point has alternate returns. */
2586   int old_lineno = lineno;
2587   const char *old_input_filename = input_filename;
2588
2589   input_filename = ffesymbol_where_filename (fn);
2590   lineno = ffesymbol_where_filelinenum (fn);
2591
2592   ffecom_doing_entry_ = TRUE;   /* Don't bother with array dimensions. */
2593
2594   switch (ffecom_primary_entry_kind_)
2595     {
2596     case FFEINFO_kindFUNCTION:
2597
2598       /* Determine actual return type for function. */
2599
2600       gt = FFEGLOBAL_typeFUNC;
2601       bt = ffesymbol_basictype (fn);
2602       kt = ffesymbol_kindtype (fn);
2603       if (bt == FFEINFO_basictypeNONE)
2604         {
2605           ffeimplic_establish_symbol (fn);
2606           if (ffesymbol_funcresult (fn) != NULL)
2607             ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
2608           bt = ffesymbol_basictype (fn);
2609           kt = ffesymbol_kindtype (fn);
2610         }
2611
2612       if (bt == FFEINFO_basictypeCHARACTER)
2613         charfunc = TRUE, cmplxfunc = FALSE;
2614       else if ((bt == FFEINFO_basictypeCOMPLEX)
2615                && ffesymbol_is_f2c (fn))
2616         charfunc = FALSE, cmplxfunc = TRUE;
2617       else
2618         charfunc = cmplxfunc = FALSE;
2619
2620       if (charfunc)
2621         type = ffecom_tree_fun_type_void;
2622       else if (ffesymbol_is_f2c (fn))
2623         type = ffecom_tree_fun_type[bt][kt];
2624       else
2625         type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
2626
2627       if ((type == NULL_TREE)
2628           || (TREE_TYPE (type) == NULL_TREE))
2629         type = ffecom_tree_fun_type_void;       /* _sym_exec_transition. */
2630
2631       multi = (ffecom_master_bt_ == FFEINFO_basictypeNONE);
2632       break;
2633
2634     case FFEINFO_kindSUBROUTINE:
2635       gt = FFEGLOBAL_typeSUBR;
2636       bt = FFEINFO_basictypeNONE;
2637       kt = FFEINFO_kindtypeNONE;
2638       if (ffecom_is_altreturning_)
2639         {                       /* Am _I_ altreturning? */
2640           for (item = ffesymbol_dummyargs (fn);
2641                item != NULL;
2642                item = ffebld_trail (item))
2643             {
2644               if (ffebld_op (ffebld_head (item)) == FFEBLD_opSTAR)
2645                 {
2646                   altreturning = TRUE;
2647                   break;
2648                 }
2649             }
2650           if (altreturning)
2651             type = ffecom_tree_subr_type;
2652           else
2653             type = ffecom_tree_fun_type_void;
2654         }
2655       else
2656         type = ffecom_tree_fun_type_void;
2657       charfunc = FALSE;
2658       cmplxfunc = FALSE;
2659       multi = FALSE;
2660       break;
2661
2662     default:
2663       assert ("say what??" == NULL);
2664       /* Fall through. */
2665     case FFEINFO_kindANY:
2666       gt = FFEGLOBAL_typeANY;
2667       bt = FFEINFO_basictypeNONE;
2668       kt = FFEINFO_kindtypeNONE;
2669       type = error_mark_node;
2670       charfunc = FALSE;
2671       cmplxfunc = FALSE;
2672       multi = FALSE;
2673       break;
2674     }
2675
2676   /* build_decl uses the current lineno and input_filename to set the decl
2677      source info.  So, I've putzed with ffestd and ffeste code to update that
2678      source info to point to the appropriate statement just before calling
2679      ffecom_do_entrypoint (which calls this fn).  */
2680
2681   start_function (ffecom_get_external_identifier_ (fn),
2682                   type,
2683                   0,            /* nested/inline */
2684                   1);           /* TREE_PUBLIC */
2685
2686   if (((g = ffesymbol_global (fn)) != NULL)
2687       && ((ffeglobal_type (g) == gt)
2688           || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
2689     {
2690       ffeglobal_set_hook (g, current_function_decl);
2691     }
2692
2693   /* Reset args in master arg list so they get retransitioned. */
2694
2695   for (item = ffecom_master_arglist_;
2696        item != NULL;
2697        item = ffebld_trail (item))
2698     {
2699       ffebld arg;
2700       ffesymbol s;
2701
2702       arg = ffebld_head (item);
2703       if (ffebld_op (arg) != FFEBLD_opSYMTER)
2704         continue;               /* Alternate return or some such thing. */
2705       s = ffebld_symter (arg);
2706       ffesymbol_hook (s).decl_tree = NULL_TREE;
2707       ffesymbol_hook (s).length_tree = NULL_TREE;
2708     }
2709
2710   /* Build dummy arg list for this entry point. */
2711
2712   if (charfunc || cmplxfunc)
2713     {                           /* Prepend arg for where result goes. */
2714       tree type;
2715       tree length;
2716
2717       if (charfunc)
2718         type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
2719       else
2720         type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
2721
2722       result = ffecom_get_invented_identifier ("__g77_%s", "result");
2723
2724       /* Make length arg _and_ enhance type info for CHAR arg itself.  */
2725
2726       if (charfunc)
2727         length = ffecom_char_enhance_arg_ (&type, fn);
2728       else
2729         length = NULL_TREE;     /* Not ref'd if !charfunc. */
2730
2731       type = build_pointer_type (type);
2732       result = build_decl (PARM_DECL, result, type);
2733
2734       push_parm_decl (result);
2735       ffecom_func_result_ = result;
2736
2737       if (charfunc)
2738         {
2739           push_parm_decl (length);
2740           ffecom_func_length_ = length;
2741         }
2742     }
2743   else
2744     result = DECL_RESULT (current_function_decl);
2745
2746   ffecom_push_dummy_decls_ (ffesymbol_dummyargs (fn), FALSE);
2747
2748   store_parm_decls (0);
2749
2750   ffecom_start_compstmt ();
2751   /* Disallow temp vars at this level.  */
2752   current_binding_level->prep_state = 2;
2753
2754   /* Make local var to hold return type for multi-type master fn. */
2755
2756   if (multi)
2757     {
2758       multi_retval = ffecom_get_invented_identifier ("__g77_%s",
2759                                                      "multi_retval");
2760       multi_retval = build_decl (VAR_DECL, multi_retval,
2761                                  ffecom_multi_type_node_);
2762       multi_retval = start_decl (multi_retval, FALSE);
2763       finish_decl (multi_retval, NULL_TREE, FALSE);
2764     }
2765   else
2766     multi_retval = NULL_TREE;   /* Not actually ref'd if !multi. */
2767
2768   /* Here we emit the actual code for the entry point. */
2769
2770   {
2771     ffebld list;
2772     ffebld arg;
2773     ffesymbol s;
2774     tree arglist = NULL_TREE;
2775     tree *plist = &arglist;
2776     tree prepend;
2777     tree call;
2778     tree actarg;
2779     tree master_fn;
2780
2781     /* Prepare actual arg list based on master arg list. */
2782
2783     for (list = ffecom_master_arglist_;
2784          list != NULL;
2785          list = ffebld_trail (list))
2786       {
2787         arg = ffebld_head (list);
2788         if (ffebld_op (arg) != FFEBLD_opSYMTER)
2789           continue;
2790         s = ffebld_symter (arg);
2791         if (ffesymbol_hook (s).decl_tree == NULL_TREE
2792             || ffesymbol_hook (s).decl_tree == error_mark_node)
2793           actarg = null_pointer_node;   /* We don't have this arg. */
2794         else
2795           actarg = ffesymbol_hook (s).decl_tree;
2796         *plist = build_tree_list (NULL_TREE, actarg);
2797         plist = &TREE_CHAIN (*plist);
2798       }
2799
2800     /* This code appends the length arguments for character
2801        variables/arrays.  */
2802
2803     for (list = ffecom_master_arglist_;
2804          list != NULL;
2805          list = ffebld_trail (list))
2806       {
2807         arg = ffebld_head (list);
2808         if (ffebld_op (arg) != FFEBLD_opSYMTER)
2809           continue;
2810         s = ffebld_symter (arg);
2811         if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
2812           continue;             /* Only looking for CHARACTER arguments. */
2813         if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
2814           continue;             /* Only looking for variables and arrays. */
2815         if (ffesymbol_hook (s).length_tree == NULL_TREE
2816             || ffesymbol_hook (s).length_tree == error_mark_node)
2817           actarg = ffecom_f2c_ftnlen_zero_node; /* We don't have this arg. */
2818         else
2819           actarg = ffesymbol_hook (s).length_tree;
2820         *plist = build_tree_list (NULL_TREE, actarg);
2821         plist = &TREE_CHAIN (*plist);
2822       }
2823
2824     /* Prepend character-value return info to actual arg list. */
2825
2826     if (charfunc)
2827       {
2828         prepend = build_tree_list (NULL_TREE, ffecom_func_result_);
2829         TREE_CHAIN (prepend)
2830           = build_tree_list (NULL_TREE, ffecom_func_length_);
2831         TREE_CHAIN (TREE_CHAIN (prepend)) = arglist;
2832         arglist = prepend;
2833       }
2834
2835     /* Prepend multi-type return value to actual arg list. */
2836
2837     if (multi)
2838       {
2839         prepend
2840           = build_tree_list (NULL_TREE,
2841                              ffecom_1 (ADDR_EXPR,
2842                               build_pointer_type (TREE_TYPE (multi_retval)),
2843                                        multi_retval));
2844         TREE_CHAIN (prepend) = arglist;
2845         arglist = prepend;
2846       }
2847
2848     /* Prepend my entry-point number to the actual arg list. */
2849
2850     prepend = build_tree_list (NULL_TREE, build_int_2 (entrynum, 0));
2851     TREE_CHAIN (prepend) = arglist;
2852     arglist = prepend;
2853
2854     /* Build the call to the master function. */
2855
2856     master_fn = ffecom_1_fn (ffecom_previous_function_decl_);
2857     call = ffecom_3s (CALL_EXPR,
2858                       TREE_TYPE (TREE_TYPE (TREE_TYPE (master_fn))),
2859                       master_fn, arglist, NULL_TREE);
2860
2861     /* Decide whether the master function is a function or subroutine, and
2862        handle the return value for my entry point. */
2863
2864     if (charfunc || ((ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
2865                      && !altreturning))
2866       {
2867         expand_expr_stmt (call);
2868         expand_null_return ();
2869       }
2870     else if (multi && cmplxfunc)
2871       {
2872         expand_expr_stmt (call);
2873         result
2874           = ffecom_1 (INDIRECT_REF,
2875                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
2876                       result);
2877         result = ffecom_modify (NULL_TREE, result,
2878                                 ffecom_2 (COMPONENT_REF, TREE_TYPE (result),
2879                                           multi_retval,
2880                                           ffecom_multi_fields_[bt][kt]));
2881         expand_expr_stmt (result);
2882         expand_null_return ();
2883       }
2884     else if (multi)
2885       {
2886         expand_expr_stmt (call);
2887         result
2888           = ffecom_modify (NULL_TREE, result,
2889                            convert (TREE_TYPE (result),
2890                                     ffecom_2 (COMPONENT_REF,
2891                                               ffecom_tree_type[bt][kt],
2892                                               multi_retval,
2893                                               ffecom_multi_fields_[bt][kt])));
2894         expand_return (result);
2895       }
2896     else if (cmplxfunc)
2897       {
2898         result
2899           = ffecom_1 (INDIRECT_REF,
2900                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
2901                       result);
2902         result = ffecom_modify (NULL_TREE, result, call);
2903         expand_expr_stmt (result);
2904         expand_null_return ();
2905       }
2906     else
2907       {
2908         result = ffecom_modify (NULL_TREE,
2909                                 result,
2910                                 convert (TREE_TYPE (result),
2911                                          call));
2912         expand_return (result);
2913       }
2914   }
2915
2916   ffecom_end_compstmt ();
2917
2918   finish_function (0);
2919
2920   lineno = old_lineno;
2921   input_filename = old_input_filename;
2922
2923   ffecom_doing_entry_ = FALSE;
2924 }
2925
2926 /* Transform expr into gcc tree with possible destination
2927
2928    Recursive descent on expr while making corresponding tree nodes and
2929    attaching type info and such.  If destination supplied and compatible
2930    with temporary that would be made in certain cases, temporary isn't
2931    made, destination used instead, and dest_used flag set TRUE.  */
2932
2933 static tree
2934 ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
2935               bool *dest_used, bool assignp, bool widenp)
2936 {
2937   tree item;
2938   tree list;
2939   tree args;
2940   ffeinfoBasictype bt;
2941   ffeinfoKindtype kt;
2942   tree t;
2943   tree dt;                      /* decl_tree for an ffesymbol. */
2944   tree tree_type, tree_type_x;
2945   tree left, right;
2946   ffesymbol s;
2947   enum tree_code code;
2948
2949   assert (expr != NULL);
2950
2951   if (dest_used != NULL)
2952     *dest_used = FALSE;
2953
2954   bt = ffeinfo_basictype (ffebld_info (expr));
2955   kt = ffeinfo_kindtype (ffebld_info (expr));
2956   tree_type = ffecom_tree_type[bt][kt];
2957
2958   /* Widen integral arithmetic as desired while preserving signedness.  */
2959   tree_type_x = NULL_TREE;
2960   if (widenp && tree_type
2961       && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
2962       && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
2963     tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
2964
2965   switch (ffebld_op (expr))
2966     {
2967     case FFEBLD_opACCTER:
2968       {
2969         ffebitCount i;
2970         ffebit bits = ffebld_accter_bits (expr);
2971         ffetargetOffset source_offset = 0;
2972         ffetargetOffset dest_offset = ffebld_accter_pad (expr);
2973         tree purpose;
2974
2975         assert (dest_offset == 0
2976                 || (bt == FFEINFO_basictypeCHARACTER
2977                     && kt == FFEINFO_kindtypeCHARACTER1));
2978
2979         list = item = NULL;
2980         for (;;)
2981           {
2982             ffebldConstantUnion cu;
2983             ffebitCount length;
2984             bool value;
2985             ffebldConstantArray ca = ffebld_accter (expr);
2986
2987             ffebit_test (bits, source_offset, &value, &length);
2988             if (length == 0)
2989               break;
2990
2991             if (value)
2992               {
2993                 for (i = 0; i < length; ++i)
2994                   {
2995                     cu = ffebld_constantarray_get (ca, bt, kt,
2996                                                    source_offset + i);
2997
2998                     t = ffecom_constantunion (&cu, bt, kt, tree_type);
2999
3000                     if (i == 0
3001                         && dest_offset != 0)
3002                       purpose = build_int_2 (dest_offset, 0);
3003                     else
3004                       purpose = NULL_TREE;
3005
3006                     if (list == NULL_TREE)
3007                       list = item = build_tree_list (purpose, t);
3008                     else
3009                       {
3010                         TREE_CHAIN (item) = build_tree_list (purpose, t);
3011                         item = TREE_CHAIN (item);
3012                       }
3013                   }
3014               }
3015             source_offset += length;
3016             dest_offset += length;
3017           }
3018       }
3019
3020       item = build_int_2 ((ffebld_accter_size (expr)
3021                            + ffebld_accter_pad (expr)) - 1, 0);
3022       ffebit_kill (ffebld_accter_bits (expr));
3023       TREE_TYPE (item) = ffecom_integer_type_node;
3024       item
3025         = build_array_type
3026           (tree_type,
3027            build_range_type (ffecom_integer_type_node,
3028                              ffecom_integer_zero_node,
3029                              item));
3030       list = build_constructor (item, list);
3031       TREE_CONSTANT (list) = 1;
3032       TREE_STATIC (list) = 1;
3033       return list;
3034
3035     case FFEBLD_opARRTER:
3036       {
3037         ffetargetOffset i;
3038
3039         list = NULL_TREE;
3040         if (ffebld_arrter_pad (expr) == 0)
3041           item = NULL_TREE;
3042         else
3043           {
3044             assert (bt == FFEINFO_basictypeCHARACTER
3045                     && kt == FFEINFO_kindtypeCHARACTER1);
3046
3047             /* Becomes PURPOSE first time through loop.  */
3048             item = build_int_2 (ffebld_arrter_pad (expr), 0);
3049           }
3050
3051         for (i = 0; i < ffebld_arrter_size (expr); ++i)
3052           {
3053             ffebldConstantUnion cu
3054             = ffebld_constantarray_get (ffebld_arrter (expr), bt, kt, i);
3055
3056             t = ffecom_constantunion (&cu, bt, kt, tree_type);
3057
3058             if (list == NULL_TREE)
3059               /* Assume item is PURPOSE first time through loop.  */
3060               list = item = build_tree_list (item, t);
3061             else
3062               {
3063                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
3064                 item = TREE_CHAIN (item);
3065               }
3066           }
3067       }
3068
3069       item = build_int_2 ((ffebld_arrter_size (expr)
3070                           + ffebld_arrter_pad (expr)) - 1, 0);
3071       TREE_TYPE (item) = ffecom_integer_type_node;
3072       item
3073         = build_array_type
3074           (tree_type,
3075            build_range_type (ffecom_integer_type_node,
3076                              ffecom_integer_zero_node,
3077                              item));
3078       list = build_constructor (item, list);
3079       TREE_CONSTANT (list) = 1;
3080       TREE_STATIC (list) = 1;
3081       return list;
3082
3083     case FFEBLD_opCONTER:
3084       assert (ffebld_conter_pad (expr) == 0);
3085       item
3086         = ffecom_constantunion (&ffebld_constant_union (ffebld_conter (expr)),
3087                                 bt, kt, tree_type);
3088       return item;
3089
3090     case FFEBLD_opSYMTER:
3091       if ((ffebld_symter_generic (expr) != FFEINTRIN_genNONE)
3092           || (ffebld_symter_specific (expr) != FFEINTRIN_specNONE))
3093         return ffecom_ptr_to_expr (expr);       /* Same as %REF(intrinsic). */
3094       s = ffebld_symter (expr);
3095       t = ffesymbol_hook (s).decl_tree;
3096
3097       if (assignp)
3098         {                       /* ASSIGN'ed-label expr. */
3099           if (ffe_is_ugly_assign ())
3100             {
3101               /* User explicitly wants ASSIGN'ed variables to be at the same
3102                  memory address as the variables when used in non-ASSIGN
3103                  contexts.  That can make old, arcane, non-standard code
3104                  work, but don't try to do it when a pointer wouldn't fit
3105                  in the normal variable (take other approach, and warn,
3106                  instead).  */
3107
3108               if (t == NULL_TREE)
3109                 {
3110                   s = ffecom_sym_transform_ (s);
3111                   t = ffesymbol_hook (s).decl_tree;
3112                   assert (t != NULL_TREE);
3113                 }
3114
3115               if (t == error_mark_node)
3116                 return t;
3117
3118               if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t)))
3119                   >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
3120                 {
3121                   if (ffesymbol_hook (s).addr)
3122                     t = ffecom_1 (INDIRECT_REF,
3123                                   TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3124                   return t;
3125                 }
3126
3127               if (ffesymbol_hook (s).assign_tree == NULL_TREE)
3128                 {
3129                   /* xgettext:no-c-format */
3130                   ffebad_start_msg ("ASSIGN'ed label cannot fit into `%A' at %0 -- using wider sibling",
3131                                     FFEBAD_severityWARNING);
3132                   ffebad_string (ffesymbol_text (s));
3133                   ffebad_here (0, ffesymbol_where_line (s),
3134                                ffesymbol_where_column (s));
3135                   ffebad_finish ();
3136                 }
3137             }
3138
3139           /* Don't use the normal variable's tree for ASSIGN, though mark
3140              it as in the system header (housekeeping).  Use an explicit,
3141              specially created sibling that is known to be wide enough
3142              to hold pointers to labels.  */
3143
3144           if (t != NULL_TREE
3145               && TREE_CODE (t) == VAR_DECL)
3146             DECL_IN_SYSTEM_HEADER (t) = 1;      /* Don't let -Wunused complain. */
3147
3148           t = ffesymbol_hook (s).assign_tree;
3149           if (t == NULL_TREE)
3150             {
3151               s = ffecom_sym_transform_assign_ (s);
3152               t = ffesymbol_hook (s).assign_tree;
3153               assert (t != NULL_TREE);
3154             }
3155         }
3156       else
3157         {
3158           if (t == NULL_TREE)
3159             {
3160               s = ffecom_sym_transform_ (s);
3161               t = ffesymbol_hook (s).decl_tree;
3162               assert (t != NULL_TREE);
3163             }
3164           if (ffesymbol_hook (s).addr)
3165             t = ffecom_1 (INDIRECT_REF,
3166                           TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3167         }
3168       return t;
3169
3170     case FFEBLD_opARRAYREF:
3171       return ffecom_arrayref_ (NULL_TREE, expr, 0);
3172
3173     case FFEBLD_opUPLUS:
3174       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3175       return ffecom_1 (NOP_EXPR, tree_type, left);
3176
3177     case FFEBLD_opPAREN:
3178       /* ~~~Make sure Fortran rules respected here */
3179       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3180       return ffecom_1 (NOP_EXPR, tree_type, left);
3181
3182     case FFEBLD_opUMINUS:
3183       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3184       if (tree_type_x)
3185         {
3186           tree_type = tree_type_x;
3187           left = convert (tree_type, left);
3188         }
3189       return ffecom_1 (NEGATE_EXPR, tree_type, left);
3190
3191     case FFEBLD_opADD:
3192       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3193       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3194       if (tree_type_x)
3195         {
3196           tree_type = tree_type_x;
3197           left = convert (tree_type, left);
3198           right = convert (tree_type, right);
3199         }
3200       return ffecom_2 (PLUS_EXPR, tree_type, left, right);
3201
3202     case FFEBLD_opSUBTRACT:
3203       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3204       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3205       if (tree_type_x)
3206         {
3207           tree_type = tree_type_x;
3208           left = convert (tree_type, left);
3209           right = convert (tree_type, right);
3210         }
3211       return ffecom_2 (MINUS_EXPR, tree_type, left, right);
3212
3213     case FFEBLD_opMULTIPLY:
3214       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3215       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3216       if (tree_type_x)
3217         {
3218           tree_type = tree_type_x;
3219           left = convert (tree_type, left);
3220           right = convert (tree_type, right);
3221         }
3222       return ffecom_2 (MULT_EXPR, tree_type, left, right);
3223
3224     case FFEBLD_opDIVIDE:
3225       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3226       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3227       if (tree_type_x)
3228         {
3229           tree_type = tree_type_x;
3230           left = convert (tree_type, left);
3231           right = convert (tree_type, right);
3232         }
3233       return ffecom_tree_divide_ (tree_type, left, right,
3234                                   dest_tree, dest, dest_used,
3235                                   ffebld_nonter_hook (expr));
3236
3237     case FFEBLD_opPOWER:
3238       {
3239         ffebld left = ffebld_left (expr);
3240         ffebld right = ffebld_right (expr);
3241         ffecomGfrt code;
3242         ffeinfoKindtype rtkt;
3243         ffeinfoKindtype ltkt;
3244         bool ref = TRUE;
3245
3246         switch (ffeinfo_basictype (ffebld_info (right)))
3247           {
3248
3249           case FFEINFO_basictypeINTEGER:
3250             if (1 || optimize)
3251               {
3252                 item = ffecom_expr_power_integer_ (expr);
3253                 if (item != NULL_TREE)
3254                   return item;
3255               }
3256
3257             rtkt = FFEINFO_kindtypeINTEGER1;
3258             switch (ffeinfo_basictype (ffebld_info (left)))
3259               {
3260               case FFEINFO_basictypeINTEGER:
3261                 if ((ffeinfo_kindtype (ffebld_info (left))
3262                     == FFEINFO_kindtypeINTEGER4)
3263                     || (ffeinfo_kindtype (ffebld_info (right))
3264                         == FFEINFO_kindtypeINTEGER4))
3265                   {
3266                     code = FFECOM_gfrtPOW_QQ;
3267                     ltkt = FFEINFO_kindtypeINTEGER4;
3268                     rtkt = FFEINFO_kindtypeINTEGER4;
3269                   }
3270                 else
3271                   {
3272                     code = FFECOM_gfrtPOW_II;
3273                     ltkt = FFEINFO_kindtypeINTEGER1;
3274                   }
3275                 break;
3276
3277               case FFEINFO_basictypeREAL:
3278                 if (ffeinfo_kindtype (ffebld_info (left))
3279                     == FFEINFO_kindtypeREAL1)
3280                   {
3281                     code = FFECOM_gfrtPOW_RI;
3282                     ltkt = FFEINFO_kindtypeREAL1;
3283                   }
3284                 else
3285                   {
3286                     code = FFECOM_gfrtPOW_DI;
3287                     ltkt = FFEINFO_kindtypeREAL2;
3288                   }
3289                 break;
3290
3291               case FFEINFO_basictypeCOMPLEX:
3292                 if (ffeinfo_kindtype (ffebld_info (left))
3293                     == FFEINFO_kindtypeREAL1)
3294                   {
3295                     code = FFECOM_gfrtPOW_CI;   /* Overlapping result okay. */
3296                     ltkt = FFEINFO_kindtypeREAL1;
3297                   }
3298                 else
3299                   {
3300                     code = FFECOM_gfrtPOW_ZI;   /* Overlapping result okay. */
3301                     ltkt = FFEINFO_kindtypeREAL2;
3302                   }
3303                 break;
3304
3305               default:
3306                 assert ("bad pow_*i" == NULL);
3307                 code = FFECOM_gfrtPOW_CI;       /* Overlapping result okay. */
3308                 ltkt = FFEINFO_kindtypeREAL1;
3309                 break;
3310               }
3311             if (ffeinfo_kindtype (ffebld_info (left)) != ltkt)
3312               left = ffeexpr_convert (left, NULL, NULL,
3313                                       ffeinfo_basictype (ffebld_info (left)),
3314                                       ltkt, 0,
3315                                       FFETARGET_charactersizeNONE,
3316                                       FFEEXPR_contextLET);
3317             if (ffeinfo_kindtype (ffebld_info (right)) != rtkt)
3318               right = ffeexpr_convert (right, NULL, NULL,
3319                                        FFEINFO_basictypeINTEGER,
3320                                        rtkt, 0,
3321                                        FFETARGET_charactersizeNONE,
3322                                        FFEEXPR_contextLET);
3323             break;
3324
3325           case FFEINFO_basictypeREAL:
3326             if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3327               left = ffeexpr_convert (left, NULL, NULL, FFEINFO_basictypeREAL,
3328                                       FFEINFO_kindtypeREALDOUBLE, 0,
3329                                       FFETARGET_charactersizeNONE,
3330                                       FFEEXPR_contextLET);
3331             if (ffeinfo_kindtype (ffebld_info (right))
3332                 == FFEINFO_kindtypeREAL1)
3333               right = ffeexpr_convert (right, NULL, NULL,
3334                                        FFEINFO_basictypeREAL,
3335                                        FFEINFO_kindtypeREALDOUBLE, 0,
3336                                        FFETARGET_charactersizeNONE,
3337                                        FFEEXPR_contextLET);
3338             /* We used to call FFECOM_gfrtPOW_DD here,
3339                which passes arguments by reference.  */
3340             code = FFECOM_gfrtL_POW;
3341             /* Pass arguments by value. */
3342             ref  = FALSE;
3343             break;
3344
3345           case FFEINFO_basictypeCOMPLEX:
3346             if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3347               left = ffeexpr_convert (left, NULL, NULL,
3348                                       FFEINFO_basictypeCOMPLEX,
3349                                       FFEINFO_kindtypeREALDOUBLE, 0,
3350                                       FFETARGET_charactersizeNONE,
3351                                       FFEEXPR_contextLET);
3352             if (ffeinfo_kindtype (ffebld_info (right))
3353                 == FFEINFO_kindtypeREAL1)
3354               right = ffeexpr_convert (right, NULL, NULL,
3355                                        FFEINFO_basictypeCOMPLEX,
3356                                        FFEINFO_kindtypeREALDOUBLE, 0,
3357                                        FFETARGET_charactersizeNONE,
3358                                        FFEEXPR_contextLET);
3359             code = FFECOM_gfrtPOW_ZZ;   /* Overlapping result okay. */
3360             ref = TRUE;                 /* Pass arguments by reference. */
3361             break;
3362
3363           default:
3364             assert ("bad pow_x*" == NULL);
3365             code = FFECOM_gfrtPOW_II;
3366             break;
3367           }
3368         return ffecom_call_binop_ (ffecom_gfrt_tree_ (code),
3369                                    ffecom_gfrt_kindtype (code),
3370                                    (ffe_is_f2c_library ()
3371                                     && ffecom_gfrt_complex_[code]),
3372                                    tree_type, left, right,
3373                                    dest_tree, dest, dest_used,
3374                                    NULL_TREE, FALSE, ref,
3375                                    ffebld_nonter_hook (expr));
3376       }
3377
3378     case FFEBLD_opNOT:
3379       switch (bt)
3380         {
3381         case FFEINFO_basictypeLOGICAL:
3382           item = ffecom_truth_value_invert (ffecom_expr (ffebld_left (expr)));
3383           return convert (tree_type, item);
3384
3385         case FFEINFO_basictypeINTEGER:
3386           return ffecom_1 (BIT_NOT_EXPR, tree_type,
3387                            ffecom_expr (ffebld_left (expr)));
3388
3389         default:
3390           assert ("NOT bad basictype" == NULL);
3391           /* Fall through. */
3392         case FFEINFO_basictypeANY:
3393           return error_mark_node;
3394         }
3395       break;
3396
3397     case FFEBLD_opFUNCREF:
3398       assert (ffeinfo_basictype (ffebld_info (expr))
3399               != FFEINFO_basictypeCHARACTER);
3400       /* Fall through.   */
3401     case FFEBLD_opSUBRREF:
3402       if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
3403           == FFEINFO_whereINTRINSIC)
3404         {                       /* Invocation of an intrinsic. */
3405           item = ffecom_expr_intrinsic_ (expr, dest_tree, dest,
3406                                          dest_used);
3407           return item;
3408         }
3409       s = ffebld_symter (ffebld_left (expr));
3410       dt = ffesymbol_hook (s).decl_tree;
3411       if (dt == NULL_TREE)
3412         {
3413           s = ffecom_sym_transform_ (s);
3414           dt = ffesymbol_hook (s).decl_tree;
3415         }
3416       if (dt == error_mark_node)
3417         return dt;
3418
3419       if (ffesymbol_hook (s).addr)
3420         item = dt;
3421       else
3422         item = ffecom_1_fn (dt);
3423
3424       if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
3425         args = ffecom_list_expr (ffebld_right (expr));
3426       else
3427         args = ffecom_list_ptr_to_expr (ffebld_right (expr));
3428
3429       if (args == error_mark_node)
3430         return error_mark_node;
3431
3432       item = ffecom_call_ (item, kt,
3433                            ffesymbol_is_f2c (s)
3434                            && (bt == FFEINFO_basictypeCOMPLEX)
3435                            && (ffesymbol_where (s)
3436                                != FFEINFO_whereCONSTANT),
3437                            tree_type,
3438                            args,
3439                            dest_tree, dest, dest_used,
3440                            error_mark_node, FALSE,
3441                            ffebld_nonter_hook (expr));
3442       TREE_SIDE_EFFECTS (item) = 1;
3443       return item;
3444
3445     case FFEBLD_opAND:
3446       switch (bt)
3447         {
3448         case FFEINFO_basictypeLOGICAL:
3449           item
3450             = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3451                        ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3452                      ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3453           return convert (tree_type, item);
3454
3455         case FFEINFO_basictypeINTEGER:
3456           return ffecom_2 (BIT_AND_EXPR, tree_type,
3457                            ffecom_expr (ffebld_left (expr)),
3458                            ffecom_expr (ffebld_right (expr)));
3459
3460         default:
3461           assert ("AND bad basictype" == NULL);
3462           /* Fall through. */
3463         case FFEINFO_basictypeANY:
3464           return error_mark_node;
3465         }
3466       break;
3467
3468     case FFEBLD_opOR:
3469       switch (bt)
3470         {
3471         case FFEINFO_basictypeLOGICAL:
3472           item
3473             = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
3474                        ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3475                      ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3476           return convert (tree_type, item);
3477
3478         case FFEINFO_basictypeINTEGER:
3479           return ffecom_2 (BIT_IOR_EXPR, tree_type,
3480                            ffecom_expr (ffebld_left (expr)),
3481                            ffecom_expr (ffebld_right (expr)));
3482
3483         default:
3484           assert ("OR bad basictype" == NULL);
3485           /* Fall through. */
3486         case FFEINFO_basictypeANY:
3487           return error_mark_node;
3488         }
3489       break;
3490
3491     case FFEBLD_opXOR:
3492     case FFEBLD_opNEQV:
3493       switch (bt)
3494         {
3495         case FFEINFO_basictypeLOGICAL:
3496           item
3497             = ffecom_2 (NE_EXPR, integer_type_node,
3498                         ffecom_expr (ffebld_left (expr)),
3499                         ffecom_expr (ffebld_right (expr)));
3500           return convert (tree_type, ffecom_truth_value (item));
3501
3502         case FFEINFO_basictypeINTEGER:
3503           return ffecom_2 (BIT_XOR_EXPR, tree_type,
3504                            ffecom_expr (ffebld_left (expr)),
3505                            ffecom_expr (ffebld_right (expr)));
3506
3507         default:
3508           assert ("XOR/NEQV bad basictype" == NULL);
3509           /* Fall through. */
3510         case FFEINFO_basictypeANY:
3511           return error_mark_node;
3512         }
3513       break;
3514
3515     case FFEBLD_opEQV:
3516       switch (bt)
3517         {
3518         case FFEINFO_basictypeLOGICAL:
3519           item
3520             = ffecom_2 (EQ_EXPR, integer_type_node,
3521                         ffecom_expr (ffebld_left (expr)),
3522                         ffecom_expr (ffebld_right (expr)));
3523           return convert (tree_type, ffecom_truth_value (item));
3524
3525         case FFEINFO_basictypeINTEGER:
3526           return
3527             ffecom_1 (BIT_NOT_EXPR, tree_type,
3528                       ffecom_2 (BIT_XOR_EXPR, tree_type,
3529                                 ffecom_expr (ffebld_left (expr)),
3530                                 ffecom_expr (ffebld_right (expr))));
3531
3532         default:
3533           assert ("EQV bad basictype" == NULL);
3534           /* Fall through. */
3535         case FFEINFO_basictypeANY:
3536           return error_mark_node;
3537         }
3538       break;
3539
3540     case FFEBLD_opCONVERT:
3541       if (ffebld_op (ffebld_left (expr)) == FFEBLD_opANY)
3542         return error_mark_node;
3543
3544       switch (bt)
3545         {
3546         case FFEINFO_basictypeLOGICAL:
3547         case FFEINFO_basictypeINTEGER:
3548         case FFEINFO_basictypeREAL:
3549           return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3550
3551         case FFEINFO_basictypeCOMPLEX:
3552           switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3553             {
3554             case FFEINFO_basictypeINTEGER:
3555             case FFEINFO_basictypeLOGICAL:
3556             case FFEINFO_basictypeREAL:
3557               item = ffecom_expr (ffebld_left (expr));
3558               if (item == error_mark_node)
3559                 return error_mark_node;
3560               /* convert() takes care of converting to the subtype first,
3561                  at least in gcc-2.7.2. */
3562               item = convert (tree_type, item);
3563               return item;
3564
3565             case FFEINFO_basictypeCOMPLEX:
3566               return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3567
3568             default:
3569               assert ("CONVERT COMPLEX bad basictype" == NULL);
3570               /* Fall through. */
3571             case FFEINFO_basictypeANY:
3572               return error_mark_node;
3573             }
3574           break;
3575
3576         default:
3577           assert ("CONVERT bad basictype" == NULL);
3578           /* Fall through. */
3579         case FFEINFO_basictypeANY:
3580           return error_mark_node;
3581         }
3582       break;
3583
3584     case FFEBLD_opLT:
3585       code = LT_EXPR;
3586       goto relational;          /* :::::::::::::::::::: */
3587
3588     case FFEBLD_opLE:
3589       code = LE_EXPR;
3590       goto relational;          /* :::::::::::::::::::: */
3591
3592     case FFEBLD_opEQ:
3593       code = EQ_EXPR;
3594       goto relational;          /* :::::::::::::::::::: */
3595
3596     case FFEBLD_opNE:
3597       code = NE_EXPR;
3598       goto relational;          /* :::::::::::::::::::: */
3599
3600     case FFEBLD_opGT:
3601       code = GT_EXPR;
3602       goto relational;          /* :::::::::::::::::::: */
3603
3604     case FFEBLD_opGE:
3605       code = GE_EXPR;
3606
3607     relational:         /* :::::::::::::::::::: */
3608       switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3609         {
3610         case FFEINFO_basictypeLOGICAL:
3611         case FFEINFO_basictypeINTEGER:
3612         case FFEINFO_basictypeREAL:
3613           item = ffecom_2 (code, integer_type_node,
3614                            ffecom_expr (ffebld_left (expr)),
3615                            ffecom_expr (ffebld_right (expr)));
3616           return convert (tree_type, item);
3617
3618         case FFEINFO_basictypeCOMPLEX:
3619           assert (code == EQ_EXPR || code == NE_EXPR);
3620           {
3621             tree real_type;
3622             tree arg1 = ffecom_expr (ffebld_left (expr));
3623             tree arg2 = ffecom_expr (ffebld_right (expr));
3624
3625             if (arg1 == error_mark_node || arg2 == error_mark_node)
3626               return error_mark_node;
3627
3628             arg1 = ffecom_save_tree (arg1);
3629             arg2 = ffecom_save_tree (arg2);
3630
3631             if (TREE_CODE (TREE_TYPE (arg1)) == COMPLEX_TYPE)
3632               {
3633                 real_type = TREE_TYPE (TREE_TYPE (arg1));
3634                 assert (real_type == TREE_TYPE (TREE_TYPE (arg2)));
3635               }
3636             else
3637               {
3638                 real_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg1)));
3639                 assert (real_type == TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg2))));
3640               }
3641
3642             item
3643               = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3644                           ffecom_2 (EQ_EXPR, integer_type_node,
3645                                   ffecom_1 (REALPART_EXPR, real_type, arg1),
3646                                  ffecom_1 (REALPART_EXPR, real_type, arg2)),
3647                           ffecom_2 (EQ_EXPR, integer_type_node,
3648                                   ffecom_1 (IMAGPART_EXPR, real_type, arg1),
3649                                     ffecom_1 (IMAGPART_EXPR, real_type,
3650                                               arg2)));
3651             if (code == EQ_EXPR)
3652               item = ffecom_truth_value (item);
3653             else
3654               item = ffecom_truth_value_invert (item);
3655             return convert (tree_type, item);
3656           }
3657
3658         case FFEINFO_basictypeCHARACTER:
3659           {
3660             ffebld left = ffebld_left (expr);
3661             ffebld right = ffebld_right (expr);
3662             tree left_tree;
3663             tree right_tree;
3664             tree left_length;
3665             tree right_length;
3666
3667             /* f2c run-time functions do the implicit blank-padding for us,
3668                so we don't usually have to implement blank-padding ourselves.
3669                (The exception is when we pass an argument to a separately
3670                compiled statement function -- if we know the arg is not the
3671                same length as the dummy, we must truncate or extend it.  If
3672                we "inline" statement functions, that necessity goes away as
3673                well.)
3674
3675                Strip off the CONVERT operators that blank-pad.  (Truncation by
3676                CONVERT shouldn't happen here, but it can happen in
3677                assignments.) */
3678
3679             while (ffebld_op (left) == FFEBLD_opCONVERT)
3680               left = ffebld_left (left);
3681             while (ffebld_op (right) == FFEBLD_opCONVERT)
3682               right = ffebld_left (right);
3683
3684             left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
3685             right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
3686
3687             if (left_tree == error_mark_node || left_length == error_mark_node
3688                 || right_tree == error_mark_node
3689                 || right_length == error_mark_node)
3690               return error_mark_node;
3691
3692             if ((ffebld_size_known (left) == 1)
3693                 && (ffebld_size_known (right) == 1))
3694               {
3695                 left_tree
3696                   = ffecom_1 (INDIRECT_REF,
3697                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3698                               left_tree);
3699                 right_tree
3700                   = ffecom_1 (INDIRECT_REF,
3701                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3702                               right_tree);
3703
3704                 item
3705                   = ffecom_2 (code, integer_type_node,
3706                               ffecom_2 (ARRAY_REF,
3707                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3708                                         left_tree,
3709                                         integer_one_node),
3710                               ffecom_2 (ARRAY_REF,
3711                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3712                                         right_tree,
3713                                         integer_one_node));
3714               }
3715             else
3716               {
3717                 item = build_tree_list (NULL_TREE, left_tree);
3718                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, right_tree);
3719                 TREE_CHAIN (TREE_CHAIN (item)) = build_tree_list (NULL_TREE,
3720                                                                left_length);
3721                 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
3722                   = build_tree_list (NULL_TREE, right_length);
3723                 item = ffecom_call_gfrt (FFECOM_gfrtCMP, item, NULL_TREE);
3724                 item = ffecom_2 (code, integer_type_node,
3725                                  item,
3726                                  convert (TREE_TYPE (item),
3727                                           integer_zero_node));
3728               }
3729             item = convert (tree_type, item);
3730           }
3731
3732           return item;
3733
3734         default:
3735           assert ("relational bad basictype" == NULL);
3736           /* Fall through. */
3737         case FFEINFO_basictypeANY:
3738           return error_mark_node;
3739         }
3740       break;
3741
3742     case FFEBLD_opPERCENT_LOC:
3743       item = ffecom_arg_ptr_to_expr (ffebld_left (expr), &list);
3744       return convert (tree_type, item);
3745
3746     case FFEBLD_opPERCENT_VAL:
3747       item = ffecom_arg_expr (ffebld_left (expr), &list);
3748       return convert (tree_type, item);
3749
3750     case FFEBLD_opITEM:
3751     case FFEBLD_opSTAR:
3752     case FFEBLD_opBOUNDS:
3753     case FFEBLD_opREPEAT:
3754     case FFEBLD_opLABTER:
3755     case FFEBLD_opLABTOK:
3756     case FFEBLD_opIMPDO:
3757     case FFEBLD_opCONCATENATE:
3758     case FFEBLD_opSUBSTR:
3759     default:
3760       assert ("bad op" == NULL);
3761       /* Fall through. */
3762     case FFEBLD_opANY:
3763       return error_mark_node;
3764     }
3765
3766 #if 1
3767   assert ("didn't think anything got here anymore!!" == NULL);
3768 #else
3769   switch (ffebld_arity (expr))
3770     {
3771     case 2:
3772       TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3773       TREE_OPERAND (item, 1) = ffecom_expr (ffebld_right (expr));
3774       if (TREE_OPERAND (item, 0) == error_mark_node
3775           || TREE_OPERAND (item, 1) == error_mark_node)
3776         return error_mark_node;
3777       break;
3778
3779     case 1:
3780       TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3781       if (TREE_OPERAND (item, 0) == error_mark_node)
3782         return error_mark_node;
3783       break;
3784
3785     default:
3786       break;
3787     }
3788
3789   return fold (item);
3790 #endif
3791 }
3792
3793 /* Returns the tree that does the intrinsic invocation.
3794
3795    Note: this function applies only to intrinsics returning
3796    CHARACTER*1 or non-CHARACTER results, and to intrinsic
3797    subroutines.  */
3798
3799 static tree
3800 ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
3801                         ffebld dest, bool *dest_used)
3802 {
3803   tree expr_tree;
3804   tree saved_expr1;             /* For those who need it. */
3805   tree saved_expr2;             /* For those who need it. */
3806   ffeinfoBasictype bt;
3807   ffeinfoKindtype kt;
3808   tree tree_type;
3809   tree arg1_type;
3810   tree real_type;               /* REAL type corresponding to COMPLEX. */
3811   tree tempvar;
3812   ffebld list = ffebld_right (expr);    /* List of (some) args. */
3813   ffebld arg1;                  /* For handy reference. */
3814   ffebld arg2;
3815   ffebld arg3;
3816   ffeintrinImp codegen_imp;
3817   ffecomGfrt gfrt;
3818
3819   assert (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER);
3820
3821   if (dest_used != NULL)
3822     *dest_used = FALSE;
3823
3824   bt = ffeinfo_basictype (ffebld_info (expr));
3825   kt = ffeinfo_kindtype (ffebld_info (expr));
3826   tree_type = ffecom_tree_type[bt][kt];
3827
3828   if (list != NULL)
3829     {
3830       arg1 = ffebld_head (list);
3831       if (arg1 != NULL && ffebld_op (arg1) == FFEBLD_opANY)
3832         return error_mark_node;
3833       if ((list = ffebld_trail (list)) != NULL)
3834         {
3835           arg2 = ffebld_head (list);
3836           if (arg2 != NULL && ffebld_op (arg2) == FFEBLD_opANY)
3837             return error_mark_node;
3838           if ((list = ffebld_trail (list)) != NULL)
3839             {
3840               arg3 = ffebld_head (list);
3841               if (arg3 != NULL && ffebld_op (arg3) == FFEBLD_opANY)
3842                 return error_mark_node;
3843             }
3844           else
3845             arg3 = NULL;
3846         }
3847       else
3848         arg2 = arg3 = NULL;
3849     }
3850   else
3851     arg1 = arg2 = arg3 = NULL;
3852
3853   /* <list> ends up at the opITEM of the 3rd arg, or NULL if there are < 3
3854      args.  This is used by the MAX/MIN expansions. */
3855
3856   if (arg1 != NULL)
3857     arg1_type = ffecom_tree_type
3858       [ffeinfo_basictype (ffebld_info (arg1))]
3859       [ffeinfo_kindtype (ffebld_info (arg1))];
3860   else
3861     arg1_type = NULL_TREE;      /* Really not needed, but might catch bugs
3862                                    here. */
3863
3864   /* There are several ways for each of the cases in the following switch
3865      statements to exit (from simplest to use to most complicated):
3866
3867      break;  (when expr_tree == NULL)
3868
3869      A standard call is made to the specific intrinsic just as if it had been
3870      passed in as a dummy procedure and called as any old procedure.  This
3871      method can produce slower code but in some cases it's the easiest way for
3872      now.  However, if a (presumably faster) direct call is available,
3873      that is used, so this is the easiest way in many more cases now.
3874
3875      gfrt = FFECOM_gfrtWHATEVER;
3876      break;
3877
3878      gfrt contains the gfrt index of a library function to call, passing the
3879      argument(s) by value rather than by reference.  Used when a more
3880      careful choice of library function is needed than that provided
3881      by the vanilla `break;'.
3882
3883      return expr_tree;
3884
3885      The expr_tree has been completely set up and is ready to be returned
3886      as is.  No further actions are taken.  Use this when the tree is not
3887      in the simple form for one of the arity_n labels.   */
3888
3889   /* For info on how the switch statement cases were written, see the files
3890      enclosed in comments below the switch statement. */
3891
3892   codegen_imp = ffebld_symter_implementation (ffebld_left (expr));
3893   gfrt = ffeintrin_gfrt_direct (codegen_imp);
3894   if (gfrt == FFECOM_gfrt)
3895     gfrt = ffeintrin_gfrt_indirect (codegen_imp);
3896
3897   switch (codegen_imp)
3898     {
3899     case FFEINTRIN_impABS:
3900     case FFEINTRIN_impCABS:
3901     case FFEINTRIN_impCDABS:
3902     case FFEINTRIN_impDABS:
3903     case FFEINTRIN_impIABS:
3904       if (ffeinfo_basictype (ffebld_info (arg1))
3905           == FFEINFO_basictypeCOMPLEX)
3906         {
3907           if (kt == FFEINFO_kindtypeREAL1)
3908             gfrt = FFECOM_gfrtCABS;
3909           else if (kt == FFEINFO_kindtypeREAL2)
3910             gfrt = FFECOM_gfrtCDABS;
3911           break;
3912         }
3913       return ffecom_1 (ABS_EXPR, tree_type,
3914                        convert (tree_type, ffecom_expr (arg1)));
3915
3916     case FFEINTRIN_impACOS:
3917     case FFEINTRIN_impDACOS:
3918       break;
3919
3920     case FFEINTRIN_impAIMAG:
3921     case FFEINTRIN_impDIMAG:
3922     case FFEINTRIN_impIMAGPART:
3923       if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
3924         arg1_type = TREE_TYPE (arg1_type);
3925       else
3926         arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
3927
3928       return
3929         convert (tree_type,
3930                  ffecom_1 (IMAGPART_EXPR, arg1_type,
3931                            ffecom_expr (arg1)));
3932
3933     case FFEINTRIN_impAINT:
3934     case FFEINTRIN_impDINT:
3935 #if 0
3936       /* ~~Someday implement FIX_TRUNC_EXPR yielding same type as arg.  */
3937       return ffecom_1 (FIX_TRUNC_EXPR, tree_type, ffecom_expr (arg1));
3938 #else /* in the meantime, must use floor to avoid range problems with ints */
3939       /* r__1 = r1 >= 0 ? floor(r1) : -floor(-r1); */
3940       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
3941       return
3942         convert (tree_type,
3943                  ffecom_3 (COND_EXPR, double_type_node,
3944                            ffecom_truth_value
3945                            (ffecom_2 (GE_EXPR, integer_type_node,
3946                                       saved_expr1,
3947                                       convert (arg1_type,
3948                                                ffecom_float_zero_))),
3949                            ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
3950                                              build_tree_list (NULL_TREE,
3951                                                   convert (double_type_node,
3952                                                            saved_expr1)),
3953                                              NULL_TREE),
3954                            ffecom_1 (NEGATE_EXPR, double_type_node,
3955                                      ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
3956                                                  build_tree_list (NULL_TREE,
3957                                                   convert (double_type_node,
3958                                                       ffecom_1 (NEGATE_EXPR,
3959                                                                 arg1_type,
3960                                                                saved_expr1))),
3961                                                        NULL_TREE)
3962                                      ))
3963                  );
3964 #endif
3965
3966     case FFEINTRIN_impANINT:
3967     case FFEINTRIN_impDNINT:
3968 #if 0                           /* This way of doing it won't handle real
3969                                    numbers of large magnitudes. */
3970       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
3971       expr_tree = convert (tree_type,
3972                            convert (integer_type_node,
3973                                     ffecom_3 (COND_EXPR, tree_type,
3974                                               ffecom_truth_value
3975                                               (ffecom_2 (GE_EXPR,
3976                                                          integer_type_node,
3977                                                          saved_expr1,
3978                                                        ffecom_float_zero_)),
3979                                               ffecom_2 (PLUS_EXPR,
3980                                                         tree_type,
3981                                                         saved_expr1,
3982                                                         ffecom_float_half_),
3983                                               ffecom_2 (MINUS_EXPR,
3984                                                         tree_type,
3985                                                         saved_expr1,
3986                                                      ffecom_float_half_))));
3987       return expr_tree;
3988 #else /* So we instead call floor. */
3989       /* r__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1) */
3990       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
3991       return
3992         convert (tree_type,
3993                  ffecom_3 (COND_EXPR, double_type_node,
3994                            ffecom_truth_value
3995                            (ffecom_2 (GE_EXPR, integer_type_node,
3996                                       saved_expr1,
3997                                       convert (arg1_type,
3998                                                ffecom_float_zero_))),
3999                            ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4000                                              build_tree_list (NULL_TREE,
4001                                                   convert (double_type_node,
4002                                                            ffecom_2 (PLUS_EXPR,
4003                                                                      arg1_type,
4004                                                                      saved_expr1,
4005                                                                      convert (arg1_type,
4006                                                                               ffecom_float_half_)))),
4007                                              NULL_TREE),
4008                            ffecom_1 (NEGATE_EXPR, double_type_node,
4009                                      ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4010                                                        build_tree_list (NULL_TREE,
4011                                                                         convert (double_type_node,
4012                                                                                  ffecom_2 (MINUS_EXPR,
4013                                                                                            arg1_type,
4014                                                                                            convert (arg1_type,
4015                                                                                                     ffecom_float_half_),
4016                                                                                            saved_expr1))),
4017                                                        NULL_TREE))
4018                            )
4019                  );
4020 #endif
4021
4022     case FFEINTRIN_impASIN:
4023     case FFEINTRIN_impDASIN:
4024     case FFEINTRIN_impATAN:
4025     case FFEINTRIN_impDATAN:
4026     case FFEINTRIN_impATAN2:
4027     case FFEINTRIN_impDATAN2:
4028       break;
4029
4030     case FFEINTRIN_impCHAR:
4031     case FFEINTRIN_impACHAR:
4032       tempvar = ffebld_nonter_hook (expr);
4033       assert (tempvar);
4034       {
4035         tree tmv = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (tempvar)));
4036
4037         expr_tree = ffecom_modify (tmv,
4038                                    ffecom_2 (ARRAY_REF, tmv, tempvar,
4039                                              integer_one_node),
4040                                    convert (tmv, ffecom_expr (arg1)));
4041       }
4042       expr_tree = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar),
4043                             expr_tree,
4044                             tempvar);
4045       expr_tree = ffecom_1 (ADDR_EXPR,
4046                             build_pointer_type (TREE_TYPE (expr_tree)),
4047                             expr_tree);
4048       return expr_tree;
4049
4050     case FFEINTRIN_impCMPLX:
4051     case FFEINTRIN_impDCMPLX:
4052       if (arg2 == NULL)
4053         return
4054           convert (tree_type, ffecom_expr (arg1));
4055
4056       real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4057       return
4058         ffecom_2 (COMPLEX_EXPR, tree_type,
4059                   convert (real_type, ffecom_expr (arg1)),
4060                   convert (real_type,
4061                            ffecom_expr (arg2)));
4062
4063     case FFEINTRIN_impCOMPLEX:
4064       return
4065         ffecom_2 (COMPLEX_EXPR, tree_type,
4066                   ffecom_expr (arg1),
4067                   ffecom_expr (arg2));
4068
4069     case FFEINTRIN_impCONJG:
4070     case FFEINTRIN_impDCONJG:
4071       {
4072         tree arg1_tree;
4073
4074         real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4075         arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4076         return
4077           ffecom_2 (COMPLEX_EXPR, tree_type,
4078                     ffecom_1 (REALPART_EXPR, real_type, arg1_tree),
4079                     ffecom_1 (NEGATE_EXPR, real_type,
4080                               ffecom_1 (IMAGPART_EXPR, real_type, arg1_tree)));
4081       }
4082
4083     case FFEINTRIN_impCOS:
4084     case FFEINTRIN_impCCOS:
4085     case FFEINTRIN_impCDCOS:
4086     case FFEINTRIN_impDCOS:
4087       if (bt == FFEINFO_basictypeCOMPLEX)
4088         {
4089           if (kt == FFEINFO_kindtypeREAL1)
4090             gfrt = FFECOM_gfrtCCOS;     /* Overlapping result okay. */
4091           else if (kt == FFEINFO_kindtypeREAL2)
4092             gfrt = FFECOM_gfrtCDCOS;    /* Overlapping result okay. */
4093         }
4094       break;
4095
4096     case FFEINTRIN_impCOSH:
4097     case FFEINTRIN_impDCOSH:
4098       break;
4099
4100     case FFEINTRIN_impDBLE:
4101     case FFEINTRIN_impDFLOAT:
4102     case FFEINTRIN_impDREAL:
4103     case FFEINTRIN_impFLOAT:
4104     case FFEINTRIN_impIDINT:
4105     case FFEINTRIN_impIFIX:
4106     case FFEINTRIN_impINT2:
4107     case FFEINTRIN_impINT8:
4108     case FFEINTRIN_impINT:
4109     case FFEINTRIN_impLONG:
4110     case FFEINTRIN_impREAL:
4111     case FFEINTRIN_impSHORT:
4112     case FFEINTRIN_impSNGL:
4113       return convert (tree_type, ffecom_expr (arg1));
4114
4115     case FFEINTRIN_impDIM:
4116     case FFEINTRIN_impDDIM:
4117     case FFEINTRIN_impIDIM:
4118       saved_expr1 = ffecom_save_tree (convert (tree_type,
4119                                                ffecom_expr (arg1)));
4120       saved_expr2 = ffecom_save_tree (convert (tree_type,
4121                                                ffecom_expr (arg2)));
4122       return
4123         ffecom_3 (COND_EXPR, tree_type,
4124                   ffecom_truth_value
4125                   (ffecom_2 (GT_EXPR, integer_type_node,
4126                              saved_expr1,
4127                              saved_expr2)),
4128                   ffecom_2 (MINUS_EXPR, tree_type,
4129                             saved_expr1,
4130                             saved_expr2),
4131                   convert (tree_type, ffecom_float_zero_));
4132
4133     case FFEINTRIN_impDPROD:
4134       return
4135         ffecom_2 (MULT_EXPR, tree_type,
4136                   convert (tree_type, ffecom_expr (arg1)),
4137                   convert (tree_type, ffecom_expr (arg2)));
4138
4139     case FFEINTRIN_impEXP:
4140     case FFEINTRIN_impCDEXP:
4141     case FFEINTRIN_impCEXP:
4142     case FFEINTRIN_impDEXP:
4143       if (bt == FFEINFO_basictypeCOMPLEX)
4144         {
4145           if (kt == FFEINFO_kindtypeREAL1)
4146             gfrt = FFECOM_gfrtCEXP;     /* Overlapping result okay. */
4147           else if (kt == FFEINFO_kindtypeREAL2)
4148             gfrt = FFECOM_gfrtCDEXP;    /* Overlapping result okay. */
4149         }
4150       break;
4151
4152     case FFEINTRIN_impICHAR:
4153     case FFEINTRIN_impIACHAR:
4154 #if 0                           /* The simple approach. */
4155       ffecom_char_args_ (&expr_tree, &saved_expr1 /* Ignored */ , arg1);
4156       expr_tree
4157         = ffecom_1 (INDIRECT_REF,
4158                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4159                     expr_tree);
4160       expr_tree
4161         = ffecom_2 (ARRAY_REF,
4162                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4163                     expr_tree,
4164                     integer_one_node);
4165       return convert (tree_type, expr_tree);
4166 #else /* The more interesting (and more optimal) approach. */
4167       expr_tree = ffecom_intrinsic_ichar_ (tree_type, arg1, &saved_expr1);
4168       expr_tree = ffecom_3 (COND_EXPR, tree_type,
4169                             saved_expr1,
4170                             expr_tree,
4171                             convert (tree_type, integer_zero_node));
4172       return expr_tree;
4173 #endif
4174
4175     case FFEINTRIN_impINDEX:
4176       break;
4177
4178     case FFEINTRIN_impLEN:
4179 #if 0
4180       break;                                    /* The simple approach. */
4181 #else
4182       return ffecom_intrinsic_len_ (arg1);      /* The more optimal approach. */
4183 #endif
4184
4185     case FFEINTRIN_impLGE:
4186     case FFEINTRIN_impLGT:
4187     case FFEINTRIN_impLLE:
4188     case FFEINTRIN_impLLT:
4189       break;
4190
4191     case FFEINTRIN_impLOG:
4192     case FFEINTRIN_impALOG:
4193     case FFEINTRIN_impCDLOG:
4194     case FFEINTRIN_impCLOG:
4195     case FFEINTRIN_impDLOG:
4196       if (bt == FFEINFO_basictypeCOMPLEX)
4197         {
4198           if (kt == FFEINFO_kindtypeREAL1)
4199             gfrt = FFECOM_gfrtCLOG;     /* Overlapping result okay. */
4200           else if (kt == FFEINFO_kindtypeREAL2)
4201             gfrt = FFECOM_gfrtCDLOG;    /* Overlapping result okay. */
4202         }
4203       break;
4204
4205     case FFEINTRIN_impLOG10:
4206     case FFEINTRIN_impALOG10:
4207     case FFEINTRIN_impDLOG10:
4208       if (gfrt != FFECOM_gfrt)
4209         break;  /* Already picked one, stick with it. */
4210
4211       if (kt == FFEINFO_kindtypeREAL1)
4212         /* We used to call FFECOM_gfrtALOG10 here.  */
4213         gfrt = FFECOM_gfrtL_LOG10;
4214       else if (kt == FFEINFO_kindtypeREAL2)
4215         /* We used to call FFECOM_gfrtDLOG10 here.  */
4216         gfrt = FFECOM_gfrtL_LOG10;
4217       break;
4218
4219     case FFEINTRIN_impMAX:
4220     case FFEINTRIN_impAMAX0:
4221     case FFEINTRIN_impAMAX1:
4222     case FFEINTRIN_impDMAX1:
4223     case FFEINTRIN_impMAX0:
4224     case FFEINTRIN_impMAX1:
4225       if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4226         arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4227       else
4228         arg1_type = tree_type;
4229       expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4230                             convert (arg1_type, ffecom_expr (arg1)),
4231                             convert (arg1_type, ffecom_expr (arg2)));
4232       for (; list != NULL; list = ffebld_trail (list))
4233         {
4234           if ((ffebld_head (list) == NULL)
4235               || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4236             continue;
4237           expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4238                                 expr_tree,
4239                                 convert (arg1_type,
4240                                          ffecom_expr (ffebld_head (list))));
4241         }
4242       return convert (tree_type, expr_tree);
4243
4244     case FFEINTRIN_impMIN:
4245     case FFEINTRIN_impAMIN0:
4246     case FFEINTRIN_impAMIN1:
4247     case FFEINTRIN_impDMIN1:
4248     case FFEINTRIN_impMIN0:
4249     case FFEINTRIN_impMIN1:
4250       if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4251         arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4252       else
4253         arg1_type = tree_type;
4254       expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4255                             convert (arg1_type, ffecom_expr (arg1)),
4256                             convert (arg1_type, ffecom_expr (arg2)));
4257       for (; list != NULL; list = ffebld_trail (list))
4258         {
4259           if ((ffebld_head (list) == NULL)
4260               || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4261             continue;
4262           expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4263                                 expr_tree,
4264                                 convert (arg1_type,
4265                                          ffecom_expr (ffebld_head (list))));
4266         }
4267       return convert (tree_type, expr_tree);
4268
4269     case FFEINTRIN_impMOD:
4270     case FFEINTRIN_impAMOD:
4271     case FFEINTRIN_impDMOD:
4272       if (bt != FFEINFO_basictypeREAL)
4273         return ffecom_2 (TRUNC_MOD_EXPR, tree_type,
4274                          convert (tree_type, ffecom_expr (arg1)),
4275                          convert (tree_type, ffecom_expr (arg2)));
4276
4277       if (kt == FFEINFO_kindtypeREAL1)
4278         /* We used to call FFECOM_gfrtAMOD here.  */
4279         gfrt = FFECOM_gfrtL_FMOD;
4280       else if (kt == FFEINFO_kindtypeREAL2)
4281         /* We used to call FFECOM_gfrtDMOD here.  */
4282         gfrt = FFECOM_gfrtL_FMOD;
4283       break;
4284
4285     case FFEINTRIN_impNINT:
4286     case FFEINTRIN_impIDNINT:
4287 #if 0
4288       /* ~~Ideally FIX_ROUND_EXPR would be implemented, but it ain't yet.  */
4289       return ffecom_1 (FIX_ROUND_EXPR, tree_type, ffecom_expr (arg1));
4290 #else
4291       /* i__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1); */
4292       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4293       return
4294         convert (ffecom_integer_type_node,
4295                  ffecom_3 (COND_EXPR, arg1_type,
4296                            ffecom_truth_value
4297                            (ffecom_2 (GE_EXPR, integer_type_node,
4298                                       saved_expr1,
4299                                       convert (arg1_type,
4300                                                ffecom_float_zero_))),
4301                            ffecom_2 (PLUS_EXPR, arg1_type,
4302                                      saved_expr1,
4303                                      convert (arg1_type,
4304                                               ffecom_float_half_)),
4305                            ffecom_2 (MINUS_EXPR, arg1_type,
4306                                      saved_expr1,
4307                                      convert (arg1_type,
4308                                               ffecom_float_half_))));
4309 #endif
4310
4311     case FFEINTRIN_impSIGN:
4312     case FFEINTRIN_impDSIGN:
4313     case FFEINTRIN_impISIGN:
4314       {
4315         tree arg2_tree = ffecom_expr (arg2);
4316
4317         saved_expr1
4318           = ffecom_save_tree
4319           (ffecom_1 (ABS_EXPR, tree_type,
4320                      convert (tree_type,
4321                               ffecom_expr (arg1))));
4322         expr_tree
4323           = ffecom_3 (COND_EXPR, tree_type,
4324                       ffecom_truth_value
4325                       (ffecom_2 (GE_EXPR, integer_type_node,
4326                                  arg2_tree,
4327                                  convert (TREE_TYPE (arg2_tree),
4328                                           integer_zero_node))),
4329                       saved_expr1,
4330                       ffecom_1 (NEGATE_EXPR, tree_type, saved_expr1));
4331         /* Make sure SAVE_EXPRs get referenced early enough. */
4332         expr_tree
4333           = ffecom_2 (COMPOUND_EXPR, tree_type,
4334                       convert (void_type_node, saved_expr1),
4335                       expr_tree);
4336       }
4337       return expr_tree;
4338
4339     case FFEINTRIN_impSIN:
4340     case FFEINTRIN_impCDSIN:
4341     case FFEINTRIN_impCSIN:
4342     case FFEINTRIN_impDSIN:
4343       if (bt == FFEINFO_basictypeCOMPLEX)
4344         {
4345           if (kt == FFEINFO_kindtypeREAL1)
4346             gfrt = FFECOM_gfrtCSIN;     /* Overlapping result okay. */
4347           else if (kt == FFEINFO_kindtypeREAL2)
4348             gfrt = FFECOM_gfrtCDSIN;    /* Overlapping result okay. */
4349         }
4350       break;
4351
4352     case FFEINTRIN_impSINH:
4353     case FFEINTRIN_impDSINH:
4354       break;
4355
4356     case FFEINTRIN_impSQRT:
4357     case FFEINTRIN_impCDSQRT:
4358     case FFEINTRIN_impCSQRT:
4359     case FFEINTRIN_impDSQRT:
4360       if (bt == FFEINFO_basictypeCOMPLEX)
4361         {
4362           if (kt == FFEINFO_kindtypeREAL1)
4363             gfrt = FFECOM_gfrtCSQRT;    /* Overlapping result okay. */
4364           else if (kt == FFEINFO_kindtypeREAL2)
4365             gfrt = FFECOM_gfrtCDSQRT;   /* Overlapping result okay. */
4366         }
4367       break;
4368
4369     case FFEINTRIN_impTAN:
4370     case FFEINTRIN_impDTAN:
4371     case FFEINTRIN_impTANH:
4372     case FFEINTRIN_impDTANH:
4373       break;
4374
4375     case FFEINTRIN_impREALPART:
4376       if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
4377         arg1_type = TREE_TYPE (arg1_type);
4378       else
4379         arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
4380
4381       return
4382         convert (tree_type,
4383                  ffecom_1 (REALPART_EXPR, arg1_type,
4384                            ffecom_expr (arg1)));
4385
4386     case FFEINTRIN_impIAND:
4387     case FFEINTRIN_impAND:
4388       return ffecom_2 (BIT_AND_EXPR, tree_type,
4389                        convert (tree_type,
4390                                 ffecom_expr (arg1)),
4391                        convert (tree_type,
4392                                 ffecom_expr (arg2)));
4393
4394     case FFEINTRIN_impIOR:
4395     case FFEINTRIN_impOR:
4396       return ffecom_2 (BIT_IOR_EXPR, tree_type,
4397                        convert (tree_type,
4398                                 ffecom_expr (arg1)),
4399                        convert (tree_type,
4400                                 ffecom_expr (arg2)));
4401
4402     case FFEINTRIN_impIEOR:
4403     case FFEINTRIN_impXOR:
4404       return ffecom_2 (BIT_XOR_EXPR, tree_type,
4405                        convert (tree_type,
4406                                 ffecom_expr (arg1)),
4407                        convert (tree_type,
4408                                 ffecom_expr (arg2)));
4409
4410     case FFEINTRIN_impLSHIFT:
4411       return ffecom_2 (LSHIFT_EXPR, tree_type,
4412                        ffecom_expr (arg1),
4413                        convert (integer_type_node,
4414                                 ffecom_expr (arg2)));
4415
4416     case FFEINTRIN_impRSHIFT:
4417       return ffecom_2 (RSHIFT_EXPR, tree_type,
4418                        ffecom_expr (arg1),
4419                        convert (integer_type_node,
4420                                 ffecom_expr (arg2)));
4421
4422     case FFEINTRIN_impNOT:
4423       return ffecom_1 (BIT_NOT_EXPR, tree_type, ffecom_expr (arg1));
4424
4425     case FFEINTRIN_impBIT_SIZE:
4426       return convert (tree_type, TYPE_SIZE (arg1_type));
4427
4428     case FFEINTRIN_impBTEST:
4429       {
4430         ffetargetLogical1 target_true;
4431         ffetargetLogical1 target_false;
4432         tree true_tree;
4433         tree false_tree;
4434
4435         ffetarget_logical1 (&target_true, TRUE);
4436         ffetarget_logical1 (&target_false, FALSE);
4437         if (target_true == 1)
4438           true_tree = convert (tree_type, integer_one_node);
4439         else
4440           true_tree = convert (tree_type, build_int_2 (target_true, 0));
4441         if (target_false == 0)
4442           false_tree = convert (tree_type, integer_zero_node);
4443         else
4444           false_tree = convert (tree_type, build_int_2 (target_false, 0));
4445
4446         return
4447           ffecom_3 (COND_EXPR, tree_type,
4448                     ffecom_truth_value
4449                     (ffecom_2 (EQ_EXPR, integer_type_node,
4450                                ffecom_2 (BIT_AND_EXPR, arg1_type,
4451                                          ffecom_expr (arg1),
4452                                          ffecom_2 (LSHIFT_EXPR, arg1_type,
4453                                                    convert (arg1_type,
4454                                                           integer_one_node),
4455                                                    convert (integer_type_node,
4456                                                             ffecom_expr (arg2)))),
4457                                convert (arg1_type,
4458                                         integer_zero_node))),
4459                     false_tree,
4460                     true_tree);
4461       }
4462
4463     case FFEINTRIN_impIBCLR:
4464       return
4465         ffecom_2 (BIT_AND_EXPR, tree_type,
4466                   ffecom_expr (arg1),
4467                   ffecom_1 (BIT_NOT_EXPR, tree_type,
4468                             ffecom_2 (LSHIFT_EXPR, tree_type,
4469                                       convert (tree_type,
4470                                                integer_one_node),
4471                                       convert (integer_type_node,
4472                                                ffecom_expr (arg2)))));
4473
4474     case FFEINTRIN_impIBITS:
4475       {
4476         tree arg3_tree = ffecom_save_tree (convert (integer_type_node,
4477                                                     ffecom_expr (arg3)));
4478         tree uns_type
4479         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4480
4481         expr_tree
4482           = ffecom_2 (BIT_AND_EXPR, tree_type,
4483                       ffecom_2 (RSHIFT_EXPR, tree_type,
4484                                 ffecom_expr (arg1),
4485                                 convert (integer_type_node,
4486                                          ffecom_expr (arg2))),
4487                       convert (tree_type,
4488                                ffecom_2 (RSHIFT_EXPR, uns_type,
4489                                          ffecom_1 (BIT_NOT_EXPR,
4490                                                    uns_type,
4491                                                    convert (uns_type,
4492                                                         integer_zero_node)),
4493                                          ffecom_2 (MINUS_EXPR,
4494                                                    integer_type_node,
4495                                                    TYPE_SIZE (uns_type),
4496                                                    arg3_tree))));
4497         /* Fix up, because the RSHIFT_EXPR above can't shift over TYPE_SIZE.  */
4498         expr_tree
4499           = ffecom_3 (COND_EXPR, tree_type,
4500                       ffecom_truth_value
4501                       (ffecom_2 (NE_EXPR, integer_type_node,
4502                                  arg3_tree,
4503                                  integer_zero_node)),
4504                       expr_tree,
4505                       convert (tree_type, integer_zero_node));
4506       }
4507       return expr_tree;
4508
4509     case FFEINTRIN_impIBSET:
4510       return
4511         ffecom_2 (BIT_IOR_EXPR, tree_type,
4512                   ffecom_expr (arg1),
4513                   ffecom_2 (LSHIFT_EXPR, tree_type,
4514                             convert (tree_type, integer_one_node),
4515                             convert (integer_type_node,
4516                                      ffecom_expr (arg2))));
4517
4518     case FFEINTRIN_impISHFT:
4519       {
4520         tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4521         tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4522                                                     ffecom_expr (arg2)));
4523         tree uns_type
4524         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4525
4526         expr_tree
4527           = ffecom_3 (COND_EXPR, tree_type,
4528                       ffecom_truth_value
4529                       (ffecom_2 (GE_EXPR, integer_type_node,
4530                                  arg2_tree,
4531                                  integer_zero_node)),
4532                       ffecom_2 (LSHIFT_EXPR, tree_type,
4533                                 arg1_tree,
4534                                 arg2_tree),
4535                       convert (tree_type,
4536                                ffecom_2 (RSHIFT_EXPR, uns_type,
4537                                          convert (uns_type, arg1_tree),
4538                                          ffecom_1 (NEGATE_EXPR,
4539                                                    integer_type_node,
4540                                                    arg2_tree))));
4541         /* Fix up, because {L|R}SHIFT_EXPR don't go over TYPE_SIZE bounds.  */
4542         expr_tree
4543           = ffecom_3 (COND_EXPR, tree_type,
4544                       ffecom_truth_value
4545                       (ffecom_2 (NE_EXPR, integer_type_node,
4546                                  ffecom_1 (ABS_EXPR,
4547                                            integer_type_node,
4548                                            arg2_tree),
4549                                  TYPE_SIZE (uns_type))),
4550                       expr_tree,
4551                       convert (tree_type, integer_zero_node));
4552         /* Make sure SAVE_EXPRs get referenced early enough. */
4553         expr_tree
4554           = ffecom_2 (COMPOUND_EXPR, tree_type,
4555                       convert (void_type_node, arg1_tree),
4556                       ffecom_2 (COMPOUND_EXPR, tree_type,
4557                                 convert (void_type_node, arg2_tree),
4558                                 expr_tree));
4559       }
4560       return expr_tree;
4561
4562     case FFEINTRIN_impISHFTC:
4563       {
4564         tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4565         tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4566                                                     ffecom_expr (arg2)));
4567         tree arg3_tree = (arg3 == NULL) ? TYPE_SIZE (tree_type)
4568         : ffecom_save_tree (convert (integer_type_node, ffecom_expr (arg3)));
4569         tree shift_neg;
4570         tree shift_pos;
4571         tree mask_arg1;
4572         tree masked_arg1;
4573         tree uns_type
4574         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4575
4576         mask_arg1
4577           = ffecom_2 (LSHIFT_EXPR, tree_type,
4578                       ffecom_1 (BIT_NOT_EXPR, tree_type,
4579                                 convert (tree_type, integer_zero_node)),
4580                       arg3_tree);
4581         /* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE.  */
4582         mask_arg1
4583           = ffecom_3 (COND_EXPR, tree_type,
4584                       ffecom_truth_value
4585                       (ffecom_2 (NE_EXPR, integer_type_node,
4586                                  arg3_tree,
4587                                  TYPE_SIZE (uns_type))),
4588                       mask_arg1,
4589                       convert (tree_type, integer_zero_node));
4590         mask_arg1 = ffecom_save_tree (mask_arg1);
4591         masked_arg1
4592           = ffecom_2 (BIT_AND_EXPR, tree_type,
4593                       arg1_tree,
4594                       ffecom_1 (BIT_NOT_EXPR, tree_type,
4595                                 mask_arg1));
4596         masked_arg1 = ffecom_save_tree (masked_arg1);
4597         shift_neg
4598           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4599                       convert (tree_type,
4600                                ffecom_2 (RSHIFT_EXPR, uns_type,
4601                                          convert (uns_type, masked_arg1),
4602                                          ffecom_1 (NEGATE_EXPR,
4603                                                    integer_type_node,
4604                                                    arg2_tree))),
4605                       ffecom_2 (LSHIFT_EXPR, tree_type,
4606                                 arg1_tree,
4607                                 ffecom_2 (PLUS_EXPR, integer_type_node,
4608                                           arg2_tree,
4609                                           arg3_tree)));
4610         shift_pos
4611           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4612                       ffecom_2 (LSHIFT_EXPR, tree_type,
4613                                 arg1_tree,
4614                                 arg2_tree),
4615                       convert (tree_type,
4616                                ffecom_2 (RSHIFT_EXPR, uns_type,
4617                                          convert (uns_type, masked_arg1),
4618                                          ffecom_2 (MINUS_EXPR,
4619                                                    integer_type_node,
4620                                                    arg3_tree,
4621                                                    arg2_tree))));
4622         expr_tree
4623           = ffecom_3 (COND_EXPR, tree_type,
4624                       ffecom_truth_value
4625                       (ffecom_2 (LT_EXPR, integer_type_node,
4626                                  arg2_tree,
4627                                  integer_zero_node)),
4628                       shift_neg,
4629                       shift_pos);
4630         expr_tree
4631           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4632                       ffecom_2 (BIT_AND_EXPR, tree_type,
4633                                 mask_arg1,
4634                                 arg1_tree),
4635                       ffecom_2 (BIT_AND_EXPR, tree_type,
4636                                 ffecom_1 (BIT_NOT_EXPR, tree_type,
4637                                           mask_arg1),
4638                                 expr_tree));
4639         expr_tree
4640           = ffecom_3 (COND_EXPR, tree_type,
4641                       ffecom_truth_value
4642                       (ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
4643                                  ffecom_2 (EQ_EXPR, integer_type_node,
4644                                            ffecom_1 (ABS_EXPR,
4645                                                      integer_type_node,
4646                                                      arg2_tree),
4647                                            arg3_tree),
4648                                  ffecom_2 (EQ_EXPR, integer_type_node,
4649                                            arg2_tree,
4650                                            integer_zero_node))),
4651                       arg1_tree,
4652                       expr_tree);
4653         /* Make sure SAVE_EXPRs get referenced early enough. */
4654         expr_tree
4655           = ffecom_2 (COMPOUND_EXPR, tree_type,
4656                       convert (void_type_node, arg1_tree),
4657                       ffecom_2 (COMPOUND_EXPR, tree_type,
4658                                 convert (void_type_node, arg2_tree),
4659                                 ffecom_2 (COMPOUND_EXPR, tree_type,
4660                                           convert (void_type_node,
4661                                                    mask_arg1),
4662                                           ffecom_2 (COMPOUND_EXPR, tree_type,
4663                                                     convert (void_type_node,
4664                                                              masked_arg1),
4665                                                     expr_tree))));
4666         expr_tree
4667           = ffecom_2 (COMPOUND_EXPR, tree_type,
4668                       convert (void_type_node,
4669                                arg3_tree),
4670                       expr_tree);
4671       }
4672       return expr_tree;
4673
4674     case FFEINTRIN_impLOC:
4675       {
4676         tree arg1_tree = ffecom_expr (arg1);
4677
4678         expr_tree
4679           = convert (tree_type,
4680                      ffecom_1 (ADDR_EXPR,
4681                                build_pointer_type (TREE_TYPE (arg1_tree)),
4682                                arg1_tree));
4683       }
4684       return expr_tree;
4685
4686     case FFEINTRIN_impMVBITS:
4687       {
4688         tree arg1_tree;
4689         tree arg2_tree;
4690         tree arg3_tree;
4691         ffebld arg4 = ffebld_head (ffebld_trail (list));
4692         tree arg4_tree;
4693         tree arg4_type;
4694         ffebld arg5 = ffebld_head (ffebld_trail (ffebld_trail (list)));
4695         tree arg5_tree;
4696         tree prep_arg1;
4697         tree prep_arg4;
4698         tree arg5_plus_arg3;
4699
4700         arg2_tree = convert (integer_type_node,
4701                              ffecom_expr (arg2));
4702         arg3_tree = ffecom_save_tree (convert (integer_type_node,
4703                                                ffecom_expr (arg3)));
4704         arg4_tree = ffecom_expr_rw (NULL_TREE, arg4);
4705         arg4_type = TREE_TYPE (arg4_tree);
4706
4707         arg1_tree = ffecom_save_tree (convert (arg4_type,
4708                                                ffecom_expr (arg1)));
4709
4710         arg5_tree = ffecom_save_tree (convert (integer_type_node,
4711                                                ffecom_expr (arg5)));
4712
4713         prep_arg1
4714           = ffecom_2 (LSHIFT_EXPR, arg4_type,
4715                       ffecom_2 (BIT_AND_EXPR, arg4_type,
4716                                 ffecom_2 (RSHIFT_EXPR, arg4_type,
4717                                           arg1_tree,
4718                                           arg2_tree),
4719                                 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4720                                           ffecom_2 (LSHIFT_EXPR, arg4_type,
4721                                                     ffecom_1 (BIT_NOT_EXPR,
4722                                                               arg4_type,
4723                                                               convert
4724                                                               (arg4_type,
4725                                                         integer_zero_node)),
4726                                                     arg3_tree))),
4727                       arg5_tree);
4728         arg5_plus_arg3
4729           = ffecom_save_tree (ffecom_2 (PLUS_EXPR, arg4_type,
4730                                         arg5_tree,
4731                                         arg3_tree));
4732         prep_arg4
4733           = ffecom_2 (LSHIFT_EXPR, arg4_type,
4734                       ffecom_1 (BIT_NOT_EXPR, arg4_type,
4735                                 convert (arg4_type,
4736                                          integer_zero_node)),
4737                       arg5_plus_arg3);
4738         /* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE.  */
4739         prep_arg4
4740           = ffecom_3 (COND_EXPR, arg4_type,
4741                       ffecom_truth_value
4742                       (ffecom_2 (NE_EXPR, integer_type_node,
4743                                  arg5_plus_arg3,
4744                                  convert (TREE_TYPE (arg5_plus_arg3),
4745                                           TYPE_SIZE (arg4_type)))),
4746                       prep_arg4,
4747                       convert (arg4_type, integer_zero_node));
4748         prep_arg4
4749           = ffecom_2 (BIT_AND_EXPR, arg4_type,
4750                       arg4_tree,
4751                       ffecom_2 (BIT_IOR_EXPR, arg4_type,
4752                                 prep_arg4,
4753                                 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4754                                           ffecom_2 (LSHIFT_EXPR, arg4_type,
4755                                                     ffecom_1 (BIT_NOT_EXPR,
4756                                                               arg4_type,
4757                                                               convert
4758                                                               (arg4_type,
4759                                                         integer_zero_node)),
4760                                                     arg5_tree))));
4761         prep_arg1
4762           = ffecom_2 (BIT_IOR_EXPR, arg4_type,
4763                       prep_arg1,
4764                       prep_arg4);
4765         /* Fix up (twice), because LSHIFT_EXPR above
4766            can't shift over TYPE_SIZE.  */
4767         prep_arg1
4768           = ffecom_3 (COND_EXPR, arg4_type,
4769                       ffecom_truth_value
4770                       (ffecom_2 (NE_EXPR, integer_type_node,
4771                                  arg3_tree,
4772                                  convert (TREE_TYPE (arg3_tree),
4773                                           integer_zero_node))),
4774                       prep_arg1,
4775                       arg4_tree);
4776         prep_arg1
4777           = ffecom_3 (COND_EXPR, arg4_type,
4778                       ffecom_truth_value
4779                       (ffecom_2 (NE_EXPR, integer_type_node,
4780                                  arg3_tree,
4781                                  convert (TREE_TYPE (arg3_tree),
4782                                           TYPE_SIZE (arg4_type)))),
4783                       prep_arg1,
4784                       arg1_tree);
4785         expr_tree
4786           = ffecom_2s (MODIFY_EXPR, void_type_node,
4787                        arg4_tree,
4788                        prep_arg1);
4789         /* Make sure SAVE_EXPRs get referenced early enough. */
4790         expr_tree
4791           = ffecom_2 (COMPOUND_EXPR, void_type_node,
4792                       arg1_tree,
4793                       ffecom_2 (COMPOUND_EXPR, void_type_node,
4794                                 arg3_tree,
4795                                 ffecom_2 (COMPOUND_EXPR, void_type_node,
4796                                           arg5_tree,
4797                                           ffecom_2 (COMPOUND_EXPR, void_type_node,
4798                                                     arg5_plus_arg3,
4799                                                     expr_tree))));
4800         expr_tree
4801           = ffecom_2 (COMPOUND_EXPR, void_type_node,
4802                       arg4_tree,
4803                       expr_tree);
4804
4805       }
4806       return expr_tree;
4807
4808     case FFEINTRIN_impDERF:
4809     case FFEINTRIN_impERF:
4810     case FFEINTRIN_impDERFC:
4811     case FFEINTRIN_impERFC:
4812       break;
4813
4814     case FFEINTRIN_impIARGC:
4815       /* extern int xargc; i__1 = xargc - 1; */
4816       expr_tree = ffecom_2 (MINUS_EXPR, TREE_TYPE (ffecom_tree_xargc_),
4817                             ffecom_tree_xargc_,
4818                             convert (TREE_TYPE (ffecom_tree_xargc_),
4819                                      integer_one_node));
4820       return expr_tree;
4821
4822     case FFEINTRIN_impSIGNAL_func:
4823     case FFEINTRIN_impSIGNAL_subr:
4824       {
4825         tree arg1_tree;
4826         tree arg2_tree;
4827         tree arg3_tree;
4828
4829         arg1_tree = convert (ffecom_f2c_integer_type_node,
4830                              ffecom_expr (arg1));
4831         arg1_tree = ffecom_1 (ADDR_EXPR,
4832                               build_pointer_type (TREE_TYPE (arg1_tree)),
4833                               arg1_tree);
4834
4835         /* Pass procedure as a pointer to it, anything else by value.  */
4836         if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
4837           arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
4838         else
4839           arg2_tree = ffecom_ptr_to_expr (arg2);
4840         arg2_tree = convert (TREE_TYPE (null_pointer_node),
4841                              arg2_tree);
4842
4843         if (arg3 != NULL)
4844           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
4845         else
4846           arg3_tree = NULL_TREE;
4847
4848         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4849         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4850         TREE_CHAIN (arg1_tree) = arg2_tree;
4851
4852         expr_tree
4853           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4854                           ffecom_gfrt_kindtype (gfrt),
4855                           FALSE,
4856                           ((codegen_imp == FFEINTRIN_impSIGNAL_subr) ?
4857                            NULL_TREE :
4858                            tree_type),
4859                           arg1_tree,
4860                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4861                           ffebld_nonter_hook (expr));
4862
4863         if (arg3_tree != NULL_TREE)
4864           expr_tree
4865             = ffecom_modify (NULL_TREE, arg3_tree,
4866                              convert (TREE_TYPE (arg3_tree),
4867                                       expr_tree));
4868       }
4869       return expr_tree;
4870
4871     case FFEINTRIN_impALARM:
4872       {
4873         tree arg1_tree;
4874         tree arg2_tree;
4875         tree arg3_tree;
4876
4877         arg1_tree = convert (ffecom_f2c_integer_type_node,
4878                              ffecom_expr (arg1));
4879         arg1_tree = ffecom_1 (ADDR_EXPR,
4880                               build_pointer_type (TREE_TYPE (arg1_tree)),
4881                               arg1_tree);
4882
4883         /* Pass procedure as a pointer to it, anything else by value.  */
4884         if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
4885           arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
4886         else
4887           arg2_tree = ffecom_ptr_to_expr (arg2);
4888         arg2_tree = convert (TREE_TYPE (null_pointer_node),
4889                              arg2_tree);
4890
4891         if (arg3 != NULL)
4892           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
4893         else
4894           arg3_tree = NULL_TREE;
4895
4896         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4897         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4898         TREE_CHAIN (arg1_tree) = arg2_tree;
4899
4900         expr_tree
4901           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4902                           ffecom_gfrt_kindtype (gfrt),
4903                           FALSE,
4904                           NULL_TREE,
4905                           arg1_tree,
4906                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4907                           ffebld_nonter_hook (expr));
4908
4909         if (arg3_tree != NULL_TREE)
4910           expr_tree
4911             = ffecom_modify (NULL_TREE, arg3_tree,
4912                              convert (TREE_TYPE (arg3_tree),
4913                                       expr_tree));
4914       }
4915       return expr_tree;
4916
4917     case FFEINTRIN_impCHDIR_subr:
4918     case FFEINTRIN_impFDATE_subr:
4919     case FFEINTRIN_impFGET_subr:
4920     case FFEINTRIN_impFPUT_subr:
4921     case FFEINTRIN_impGETCWD_subr:
4922     case FFEINTRIN_impHOSTNM_subr:
4923     case FFEINTRIN_impSYSTEM_subr:
4924     case FFEINTRIN_impUNLINK_subr:
4925       {
4926         tree arg1_len = integer_zero_node;
4927         tree arg1_tree;
4928         tree arg2_tree;
4929
4930         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
4931
4932         if (arg2 != NULL)
4933           arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
4934         else
4935           arg2_tree = NULL_TREE;
4936
4937         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4938         arg1_len = build_tree_list (NULL_TREE, arg1_len);
4939         TREE_CHAIN (arg1_tree) = arg1_len;
4940
4941         expr_tree
4942           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4943                           ffecom_gfrt_kindtype (gfrt),
4944                           FALSE,
4945                           NULL_TREE,
4946                           arg1_tree,
4947                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4948                           ffebld_nonter_hook (expr));
4949
4950         if (arg2_tree != NULL_TREE)
4951           expr_tree
4952             = ffecom_modify (NULL_TREE, arg2_tree,
4953                              convert (TREE_TYPE (arg2_tree),
4954                                       expr_tree));
4955       }
4956       return expr_tree;
4957
4958     case FFEINTRIN_impEXIT:
4959       if (arg1 != NULL)
4960         break;
4961
4962       expr_tree = build_tree_list (NULL_TREE,
4963                                    ffecom_1 (ADDR_EXPR,
4964                                              build_pointer_type
4965                                              (ffecom_integer_type_node),
4966                                              integer_zero_node));
4967
4968       return
4969         ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4970                       ffecom_gfrt_kindtype (gfrt),
4971                       FALSE,
4972                       void_type_node,
4973                       expr_tree,
4974                       NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4975                       ffebld_nonter_hook (expr));
4976
4977     case FFEINTRIN_impFLUSH:
4978       if (arg1 == NULL)
4979         gfrt = FFECOM_gfrtFLUSH;
4980       else
4981         gfrt = FFECOM_gfrtFLUSH1;
4982       break;
4983
4984     case FFEINTRIN_impCHMOD_subr:
4985     case FFEINTRIN_impLINK_subr:
4986     case FFEINTRIN_impRENAME_subr:
4987     case FFEINTRIN_impSYMLNK_subr:
4988       {
4989         tree arg1_len = integer_zero_node;
4990         tree arg1_tree;
4991         tree arg2_len = integer_zero_node;
4992         tree arg2_tree;
4993         tree arg3_tree;
4994
4995         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
4996         arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
4997         if (arg3 != NULL)
4998           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
4999         else
5000           arg3_tree = NULL_TREE;
5001
5002         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5003         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5004         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5005         arg2_len = build_tree_list (NULL_TREE, arg2_len);
5006         TREE_CHAIN (arg1_tree) = arg2_tree;
5007         TREE_CHAIN (arg2_tree) = arg1_len;
5008         TREE_CHAIN (arg1_len) = arg2_len;
5009         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5010                                   ffecom_gfrt_kindtype (gfrt),
5011                                   FALSE,
5012                                   NULL_TREE,
5013                                   arg1_tree,
5014                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5015                                   ffebld_nonter_hook (expr));
5016         if (arg3_tree != NULL_TREE)
5017           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5018                                      convert (TREE_TYPE (arg3_tree),
5019                                               expr_tree));
5020       }
5021       return expr_tree;
5022
5023     case FFEINTRIN_impLSTAT_subr:
5024     case FFEINTRIN_impSTAT_subr:
5025       {
5026         tree arg1_len = integer_zero_node;
5027         tree arg1_tree;
5028         tree arg2_tree;
5029         tree arg3_tree;
5030
5031         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5032
5033         arg2_tree = ffecom_ptr_to_expr (arg2);
5034
5035         if (arg3 != NULL)
5036           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5037         else
5038           arg3_tree = NULL_TREE;
5039
5040         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5041         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5042         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5043         TREE_CHAIN (arg1_tree) = arg2_tree;
5044         TREE_CHAIN (arg2_tree) = arg1_len;
5045         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5046                                   ffecom_gfrt_kindtype (gfrt),
5047                                   FALSE,
5048                                   NULL_TREE,
5049                                   arg1_tree,
5050                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5051                                   ffebld_nonter_hook (expr));
5052         if (arg3_tree != NULL_TREE)
5053           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5054                                      convert (TREE_TYPE (arg3_tree),
5055                                               expr_tree));
5056       }
5057       return expr_tree;
5058
5059     case FFEINTRIN_impFGETC_subr:
5060     case FFEINTRIN_impFPUTC_subr:
5061       {
5062         tree arg1_tree;
5063         tree arg2_tree;
5064         tree arg2_len = integer_zero_node;
5065         tree arg3_tree;
5066
5067         arg1_tree = convert (ffecom_f2c_integer_type_node,
5068                              ffecom_expr (arg1));
5069         arg1_tree = ffecom_1 (ADDR_EXPR,
5070                               build_pointer_type (TREE_TYPE (arg1_tree)),
5071                               arg1_tree);
5072
5073         arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
5074         if (arg3 != NULL)
5075           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5076         else
5077           arg3_tree = NULL_TREE;
5078
5079         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5080         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5081         arg2_len = build_tree_list (NULL_TREE, arg2_len);
5082         TREE_CHAIN (arg1_tree) = arg2_tree;
5083         TREE_CHAIN (arg2_tree) = arg2_len;
5084
5085         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5086                                   ffecom_gfrt_kindtype (gfrt),
5087                                   FALSE,
5088                                   NULL_TREE,
5089                                   arg1_tree,
5090                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5091                                   ffebld_nonter_hook (expr));
5092         if (arg3_tree != NULL_TREE)
5093           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5094                                      convert (TREE_TYPE (arg3_tree),
5095                                               expr_tree));
5096       }
5097       return expr_tree;
5098
5099     case FFEINTRIN_impFSTAT_subr:
5100       {
5101         tree arg1_tree;
5102         tree arg2_tree;
5103         tree arg3_tree;
5104
5105         arg1_tree = convert (ffecom_f2c_integer_type_node,
5106                              ffecom_expr (arg1));
5107         arg1_tree = ffecom_1 (ADDR_EXPR,
5108                               build_pointer_type (TREE_TYPE (arg1_tree)),
5109                               arg1_tree);
5110
5111         arg2_tree = convert (ffecom_f2c_ptr_to_integer_type_node,
5112                              ffecom_ptr_to_expr (arg2));
5113
5114         if (arg3 == NULL)
5115           arg3_tree = NULL_TREE;
5116         else
5117           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5118
5119         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5120         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5121         TREE_CHAIN (arg1_tree) = arg2_tree;
5122         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5123                                   ffecom_gfrt_kindtype (gfrt),
5124                                   FALSE,
5125                                   NULL_TREE,
5126                                   arg1_tree,
5127                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5128                                   ffebld_nonter_hook (expr));
5129         if (arg3_tree != NULL_TREE) {
5130           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5131                                      convert (TREE_TYPE (arg3_tree),
5132                                               expr_tree));
5133         }
5134       }
5135       return expr_tree;
5136
5137     case FFEINTRIN_impKILL_subr:
5138       {
5139         tree arg1_tree;
5140         tree arg2_tree;
5141         tree arg3_tree;
5142
5143         arg1_tree = convert (ffecom_f2c_integer_type_node,
5144                              ffecom_expr (arg1));
5145         arg1_tree = ffecom_1 (ADDR_EXPR,
5146                               build_pointer_type (TREE_TYPE (arg1_tree)),
5147                               arg1_tree);
5148
5149         arg2_tree = convert (ffecom_f2c_integer_type_node,
5150                              ffecom_expr (arg2));
5151         arg2_tree = ffecom_1 (ADDR_EXPR,
5152                               build_pointer_type (TREE_TYPE (arg2_tree)),
5153                               arg2_tree);
5154
5155         if (arg3 == NULL)
5156           arg3_tree = NULL_TREE;
5157         else
5158           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5159
5160         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5161         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5162         TREE_CHAIN (arg1_tree) = arg2_tree;
5163         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5164                                   ffecom_gfrt_kindtype (gfrt),
5165                                   FALSE,
5166                                   NULL_TREE,
5167                                   arg1_tree,
5168                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5169                                   ffebld_nonter_hook (expr));
5170         if (arg3_tree != NULL_TREE) {
5171           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5172                                      convert (TREE_TYPE (arg3_tree),
5173                                               expr_tree));
5174         }
5175       }
5176       return expr_tree;
5177
5178     case FFEINTRIN_impCTIME_subr:
5179     case FFEINTRIN_impTTYNAM_subr:
5180       {
5181         tree arg1_len = integer_zero_node;
5182         tree arg1_tree;
5183         tree arg2_tree;
5184
5185         arg1_tree = ffecom_arg_ptr_to_expr (arg2, &arg1_len);
5186
5187         arg2_tree = convert (((codegen_imp == FFEINTRIN_impCTIME_subr) ?
5188                               ffecom_f2c_longint_type_node :
5189                               ffecom_f2c_integer_type_node),
5190                              ffecom_expr (arg1));
5191         arg2_tree = ffecom_1 (ADDR_EXPR,
5192                               build_pointer_type (TREE_TYPE (arg2_tree)),
5193                               arg2_tree);
5194
5195         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5196         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5197         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5198         TREE_CHAIN (arg1_len) = arg2_tree;
5199         TREE_CHAIN (arg1_tree) = arg1_len;
5200
5201         expr_tree
5202           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5203                           ffecom_gfrt_kindtype (gfrt),
5204                           FALSE,
5205                           NULL_TREE,
5206                           arg1_tree,
5207                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5208                           ffebld_nonter_hook (expr));
5209         TREE_SIDE_EFFECTS (expr_tree) = 1;
5210       }
5211       return expr_tree;
5212
5213     case FFEINTRIN_impIRAND:
5214     case FFEINTRIN_impRAND:
5215       /* Arg defaults to 0 (normal random case) */
5216       {
5217         tree arg1_tree;
5218
5219         if (arg1 == NULL)
5220           arg1_tree = ffecom_integer_zero_node;
5221         else
5222           arg1_tree = ffecom_expr (arg1);
5223         arg1_tree = convert (ffecom_f2c_integer_type_node,
5224                              arg1_tree);
5225         arg1_tree = ffecom_1 (ADDR_EXPR,
5226                               build_pointer_type (TREE_TYPE (arg1_tree)),
5227                               arg1_tree);
5228         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5229
5230         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5231                                   ffecom_gfrt_kindtype (gfrt),
5232                                   FALSE,
5233                                   ((codegen_imp == FFEINTRIN_impIRAND) ?
5234                                    ffecom_f2c_integer_type_node :
5235                                    ffecom_f2c_real_type_node),
5236                                   arg1_tree,
5237                                   dest_tree, dest, dest_used,
5238                                   NULL_TREE, TRUE,
5239                                   ffebld_nonter_hook (expr));
5240       }
5241       return expr_tree;
5242
5243     case FFEINTRIN_impFTELL_subr:
5244     case FFEINTRIN_impUMASK_subr:
5245       {
5246         tree arg1_tree;
5247         tree arg2_tree;
5248
5249         arg1_tree = convert (ffecom_f2c_integer_type_node,
5250                              ffecom_expr (arg1));
5251         arg1_tree = ffecom_1 (ADDR_EXPR,
5252                               build_pointer_type (TREE_TYPE (arg1_tree)),
5253                               arg1_tree);
5254
5255         if (arg2 == NULL)
5256           arg2_tree = NULL_TREE;
5257         else
5258           arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
5259
5260         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5261                                   ffecom_gfrt_kindtype (gfrt),
5262                                   FALSE,
5263                                   NULL_TREE,
5264                                   build_tree_list (NULL_TREE, arg1_tree),
5265                                   NULL_TREE, NULL, NULL, NULL_TREE,
5266                                   TRUE,
5267                                   ffebld_nonter_hook (expr));
5268         if (arg2_tree != NULL_TREE) {
5269           expr_tree = ffecom_modify (NULL_TREE, arg2_tree,
5270                                      convert (TREE_TYPE (arg2_tree),
5271                                               expr_tree));
5272         }
5273       }
5274       return expr_tree;
5275
5276     case FFEINTRIN_impCPU_TIME:
5277     case FFEINTRIN_impSECOND_subr:
5278       {
5279         tree arg1_tree;
5280
5281         arg1_tree = ffecom_expr_w (NULL_TREE, arg1);
5282
5283         expr_tree
5284           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5285                           ffecom_gfrt_kindtype (gfrt),
5286                           FALSE,
5287                           NULL_TREE,
5288                           NULL_TREE,
5289                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5290                           ffebld_nonter_hook (expr));
5291
5292         expr_tree
5293           = ffecom_modify (NULL_TREE, arg1_tree,
5294                            convert (TREE_TYPE (arg1_tree),
5295                                     expr_tree));
5296       }
5297       return expr_tree;
5298
5299     case FFEINTRIN_impDTIME_subr:
5300     case FFEINTRIN_impETIME_subr:
5301       {
5302         tree arg1_tree;
5303         tree result_tree;
5304
5305         result_tree = ffecom_expr_w (NULL_TREE, arg2);
5306
5307         arg1_tree = ffecom_ptr_to_expr (arg1);
5308
5309         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5310                                   ffecom_gfrt_kindtype (gfrt),
5311                                   FALSE,
5312                                   NULL_TREE,
5313                                   build_tree_list (NULL_TREE, arg1_tree),
5314                                   NULL_TREE, NULL, NULL, NULL_TREE,
5315                                   TRUE,
5316                                   ffebld_nonter_hook (expr));
5317         expr_tree = ffecom_modify (NULL_TREE, result_tree,
5318                                    convert (TREE_TYPE (result_tree),
5319                                             expr_tree));
5320       }
5321       return expr_tree;
5322
5323       /* Straightforward calls of libf2c routines: */
5324     case FFEINTRIN_impABORT:
5325     case FFEINTRIN_impACCESS:
5326     case FFEINTRIN_impBESJ0:
5327     case FFEINTRIN_impBESJ1:
5328     case FFEINTRIN_impBESJN:
5329     case FFEINTRIN_impBESY0:
5330     case FFEINTRIN_impBESY1:
5331     case FFEINTRIN_impBESYN:
5332     case FFEINTRIN_impCHDIR_func:
5333     case FFEINTRIN_impCHMOD_func:
5334     case FFEINTRIN_impDATE:
5335     case FFEINTRIN_impDATE_AND_TIME:
5336     case FFEINTRIN_impDBESJ0:
5337     case FFEINTRIN_impDBESJ1:
5338     case FFEINTRIN_impDBESJN:
5339     case FFEINTRIN_impDBESY0:
5340     case FFEINTRIN_impDBESY1:
5341     case FFEINTRIN_impDBESYN:
5342     case FFEINTRIN_impDTIME_func:
5343     case FFEINTRIN_impETIME_func:
5344     case FFEINTRIN_impFGETC_func:
5345     case FFEINTRIN_impFGET_func:
5346     case FFEINTRIN_impFNUM:
5347     case FFEINTRIN_impFPUTC_func:
5348     case FFEINTRIN_impFPUT_func:
5349     case FFEINTRIN_impFSEEK:
5350     case FFEINTRIN_impFSTAT_func:
5351     case FFEINTRIN_impFTELL_func:
5352     case FFEINTRIN_impGERROR:
5353     case FFEINTRIN_impGETARG:
5354     case FFEINTRIN_impGETCWD_func:
5355     case FFEINTRIN_impGETENV:
5356     case FFEINTRIN_impGETGID:
5357     case FFEINTRIN_impGETLOG:
5358     case FFEINTRIN_impGETPID:
5359     case FFEINTRIN_impGETUID:
5360     case FFEINTRIN_impGMTIME:
5361     case FFEINTRIN_impHOSTNM_func:
5362     case FFEINTRIN_impIDATE_unix:
5363     case FFEINTRIN_impIDATE_vxt:
5364     case FFEINTRIN_impIERRNO:
5365     case FFEINTRIN_impISATTY:
5366     case FFEINTRIN_impITIME:
5367     case FFEINTRIN_impKILL_func:
5368     case FFEINTRIN_impLINK_func:
5369     case FFEINTRIN_impLNBLNK:
5370     case FFEINTRIN_impLSTAT_func:
5371     case FFEINTRIN_impLTIME:
5372     case FFEINTRIN_impMCLOCK8:
5373     case FFEINTRIN_impMCLOCK:
5374     case FFEINTRIN_impPERROR:
5375     case FFEINTRIN_impRENAME_func:
5376     case FFEINTRIN_impSECNDS:
5377     case FFEINTRIN_impSECOND_func:
5378     case FFEINTRIN_impSLEEP:
5379     case FFEINTRIN_impSRAND:
5380     case FFEINTRIN_impSTAT_func:
5381     case FFEINTRIN_impSYMLNK_func:
5382     case FFEINTRIN_impSYSTEM_CLOCK:
5383     case FFEINTRIN_impSYSTEM_func:
5384     case FFEINTRIN_impTIME8:
5385     case FFEINTRIN_impTIME_unix:
5386     case FFEINTRIN_impTIME_vxt:
5387     case FFEINTRIN_impUMASK_func:
5388     case FFEINTRIN_impUNLINK_func:
5389       break;
5390
5391     case FFEINTRIN_impCTIME_func:       /* CHARACTER functions not handled here. */
5392     case FFEINTRIN_impFDATE_func:       /* CHARACTER functions not handled here. */
5393     case FFEINTRIN_impTTYNAM_func:      /* CHARACTER functions not handled here. */
5394     case FFEINTRIN_impNONE:
5395     case FFEINTRIN_imp:         /* Hush up gcc warning. */
5396       fprintf (stderr, "No %s implementation.\n",
5397                ffeintrin_name_implementation (ffebld_symter_implementation (ffebld_left (expr))));
5398       assert ("unimplemented intrinsic" == NULL);
5399       return error_mark_node;
5400     }
5401
5402   assert (gfrt != FFECOM_gfrt); /* Must have an implementation! */
5403
5404   expr_tree = ffecom_arglist_expr_ (ffecom_gfrt_args_ (gfrt),
5405                                     ffebld_right (expr));
5406
5407   return ffecom_call_ (ffecom_gfrt_tree_ (gfrt), ffecom_gfrt_kindtype (gfrt),
5408                        (ffe_is_f2c_library () && ffecom_gfrt_complex_[gfrt]),
5409                        tree_type,
5410                        expr_tree, dest_tree, dest, dest_used,
5411                        NULL_TREE, TRUE,
5412                        ffebld_nonter_hook (expr));
5413
5414   /* See bottom of this file for f2c transforms used to determine
5415      many of the above implementations.  The info seems to confuse
5416      Emacs's C mode indentation, which is why it's been moved to
5417      the bottom of this source file.  */
5418 }
5419
5420 /* For power (exponentiation) where right-hand operand is type INTEGER,
5421    generate in-line code to do it the fast way (which, if the operand
5422    is a constant, might just mean a series of multiplies).  */
5423
5424 static tree
5425 ffecom_expr_power_integer_ (ffebld expr)
5426 {
5427   tree l = ffecom_expr (ffebld_left (expr));
5428   tree r = ffecom_expr (ffebld_right (expr));
5429   tree ltype = TREE_TYPE (l);
5430   tree rtype = TREE_TYPE (r);
5431   tree result = NULL_TREE;
5432
5433   if (l == error_mark_node
5434       || r == error_mark_node)
5435     return error_mark_node;
5436
5437   if (TREE_CODE (r) == INTEGER_CST)
5438     {
5439       int sgn = tree_int_cst_sgn (r);
5440
5441       if (sgn == 0)
5442         return convert (ltype, integer_one_node);
5443
5444       if ((TREE_CODE (ltype) == INTEGER_TYPE)
5445           && (sgn < 0))
5446         {
5447           /* Reciprocal of integer is either 0, -1, or 1, so after
5448              calculating that (which we leave to the back end to do
5449              or not do optimally), don't bother with any multiplying.  */
5450
5451           result = ffecom_tree_divide_ (ltype,
5452                                         convert (ltype, integer_one_node),
5453                                         l,
5454                                         NULL_TREE, NULL, NULL, NULL_TREE);
5455           r = ffecom_1 (NEGATE_EXPR,
5456                         rtype,
5457                         r);
5458           if ((TREE_INT_CST_LOW (r) & 1) == 0)
5459             result = ffecom_1 (ABS_EXPR, rtype,
5460                                result);
5461         }
5462
5463       /* Generate appropriate series of multiplies, preceded
5464          by divide if the exponent is negative.  */
5465
5466       l = save_expr (l);
5467
5468       if (sgn < 0)
5469         {
5470           l = ffecom_tree_divide_ (ltype,
5471                                    convert (ltype, integer_one_node),
5472                                    l,
5473                                    NULL_TREE, NULL, NULL,
5474                                    ffebld_nonter_hook (expr));
5475           r = ffecom_1 (NEGATE_EXPR, rtype, r);
5476           assert (TREE_CODE (r) == INTEGER_CST);
5477
5478           if (tree_int_cst_sgn (r) < 0)
5479             {                   /* The "most negative" number.  */
5480               r = ffecom_1 (NEGATE_EXPR, rtype,
5481                             ffecom_2 (RSHIFT_EXPR, rtype,
5482                                       r,
5483                                       integer_one_node));
5484               l = save_expr (l);
5485               l = ffecom_2 (MULT_EXPR, ltype,
5486                             l,
5487                             l);
5488             }
5489         }
5490
5491       for (;;)
5492         {
5493           if (TREE_INT_CST_LOW (r) & 1)
5494             {
5495               if (result == NULL_TREE)
5496                 result = l;
5497               else
5498                 result = ffecom_2 (MULT_EXPR, ltype,
5499                                    result,
5500                                    l);
5501             }
5502
5503           r = ffecom_2 (RSHIFT_EXPR, rtype,
5504                         r,
5505                         integer_one_node);
5506           if (integer_zerop (r))
5507             break;
5508           assert (TREE_CODE (r) == INTEGER_CST);
5509
5510           l = save_expr (l);
5511           l = ffecom_2 (MULT_EXPR, ltype,
5512                         l,
5513                         l);
5514         }
5515       return result;
5516     }
5517
5518   /* Though rhs isn't a constant, in-line code cannot be expanded
5519      while transforming dummies
5520      because the back end cannot be easily convinced to generate
5521      stores (MODIFY_EXPR), handle temporaries, and so on before
5522      all the appropriate rtx's have been generated for things like
5523      dummy args referenced in rhs -- which doesn't happen until
5524      store_parm_decls() is called (expand_function_start, I believe,
5525      does the actual rtx-stuffing of PARM_DECLs).
5526
5527      So, in this case, let the caller generate the call to the
5528      run-time-library function to evaluate the power for us.  */
5529
5530   if (ffecom_transform_only_dummies_)
5531     return NULL_TREE;
5532
5533   /* Right-hand operand not a constant, expand in-line code to figure
5534      out how to do the multiplies, &c.
5535
5536      The returned expression is expressed this way in GNU C, where l and
5537      r are the "inputs":
5538
5539      ({ typeof (r) rtmp = r;
5540         typeof (l) ltmp = l;
5541         typeof (l) result;
5542
5543         if (rtmp == 0)
5544           result = 1;
5545         else
5546           {
5547             if ((basetypeof (l) == basetypeof (int))
5548                 && (rtmp < 0))
5549               {
5550                 result = ((typeof (l)) 1) / ltmp;
5551                 if ((ltmp < 0) && (((-rtmp) & 1) == 0))
5552                   result = -result;
5553               }
5554             else
5555               {
5556                 result = 1;
5557                 if ((basetypeof (l) != basetypeof (int))
5558                     && (rtmp < 0))
5559                   {
5560                     ltmp = ((typeof (l)) 1) / ltmp;
5561                     rtmp = -rtmp;
5562                     if (rtmp < 0)
5563                       {
5564                         rtmp = -(rtmp >> 1);
5565                         ltmp *= ltmp;
5566                       }
5567                   }
5568                 for (;;)
5569                   {
5570                     if (rtmp & 1)
5571                       result *= ltmp;
5572                     if ((rtmp >>= 1) == 0)
5573                       break;
5574                     ltmp *= ltmp;
5575                   }
5576               }
5577           }
5578         result;
5579      })
5580
5581      Note that some of the above is compile-time collapsable, such as
5582      the first part of the if statements that checks the base type of
5583      l against int.  The if statements are phrased that way to suggest
5584      an easy way to generate the if/else constructs here, knowing that
5585      the back end should (and probably does) eliminate the resulting
5586      dead code (either the int case or the non-int case), something
5587      it couldn't do without the redundant phrasing, requiring explicit
5588      dead-code elimination here, which would be kind of difficult to
5589      read.  */
5590
5591   {
5592     tree rtmp;
5593     tree ltmp;
5594     tree divide;
5595     tree basetypeof_l_is_int;
5596     tree se;
5597     tree t;
5598
5599     basetypeof_l_is_int
5600       = build_int_2 ((TREE_CODE (ltype) == INTEGER_TYPE), 0);
5601
5602     se = expand_start_stmt_expr (/*has_scope=*/1);
5603
5604     ffecom_start_compstmt ();
5605
5606     rtmp = ffecom_make_tempvar ("power_r", rtype,
5607                                 FFETARGET_charactersizeNONE, -1);
5608     ltmp = ffecom_make_tempvar ("power_l", ltype,
5609                                 FFETARGET_charactersizeNONE, -1);
5610     result = ffecom_make_tempvar ("power_res", ltype,
5611                                   FFETARGET_charactersizeNONE, -1);
5612     if (TREE_CODE (ltype) == COMPLEX_TYPE
5613         || TREE_CODE (ltype) == RECORD_TYPE)
5614       divide = ffecom_make_tempvar ("power_div", ltype,
5615                                     FFETARGET_charactersizeNONE, -1);
5616     else
5617       divide = NULL_TREE;
5618
5619     expand_expr_stmt (ffecom_modify (void_type_node,
5620                                      rtmp,
5621                                      r));
5622     expand_expr_stmt (ffecom_modify (void_type_node,
5623                                      ltmp,
5624                                      l));
5625     expand_start_cond (ffecom_truth_value
5626                        (ffecom_2 (EQ_EXPR, integer_type_node,
5627                                   rtmp,
5628                                   convert (rtype, integer_zero_node))),
5629                        0);
5630     expand_expr_stmt (ffecom_modify (void_type_node,
5631                                      result,
5632                                      convert (ltype, integer_one_node)));
5633     expand_start_else ();
5634     if (! integer_zerop (basetypeof_l_is_int))
5635       {
5636         expand_start_cond (ffecom_2 (LT_EXPR, integer_type_node,
5637                                      rtmp,
5638                                      convert (rtype,
5639                                               integer_zero_node)),
5640                            0);
5641         expand_expr_stmt (ffecom_modify (void_type_node,
5642                                          result,
5643                                          ffecom_tree_divide_
5644                                          (ltype,
5645                                           convert (ltype, integer_one_node),
5646                                           ltmp,
5647                                           NULL_TREE, NULL, NULL,
5648                                           divide)));
5649         expand_start_cond (ffecom_truth_value
5650                            (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5651                                       ffecom_2 (LT_EXPR, integer_type_node,
5652                                                 ltmp,
5653                                                 convert (ltype,
5654                                                          integer_zero_node)),
5655                                       ffecom_2 (EQ_EXPR, integer_type_node,
5656                                                 ffecom_2 (BIT_AND_EXPR,
5657                                                           rtype,
5658                                                           ffecom_1 (NEGATE_EXPR,
5659                                                                     rtype,
5660                                                                     rtmp),
5661                                                           convert (rtype,
5662                                                                    integer_one_node)),
5663                                                 convert (rtype,
5664                                                          integer_zero_node)))),
5665                            0);
5666         expand_expr_stmt (ffecom_modify (void_type_node,
5667                                          result,
5668                                          ffecom_1 (NEGATE_EXPR,
5669                                                    ltype,
5670                                                    result)));
5671         expand_end_cond ();
5672         expand_start_else ();
5673       }
5674     expand_expr_stmt (ffecom_modify (void_type_node,
5675                                      result,
5676                                      convert (ltype, integer_one_node)));
5677     expand_start_cond (ffecom_truth_value
5678                        (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5679                                   ffecom_truth_value_invert
5680                                   (basetypeof_l_is_int),
5681                                   ffecom_2 (LT_EXPR, integer_type_node,
5682                                             rtmp,
5683                                             convert (rtype,
5684                                                      integer_zero_node)))),
5685                        0);
5686     expand_expr_stmt (ffecom_modify (void_type_node,
5687                                      ltmp,
5688                                      ffecom_tree_divide_
5689                                      (ltype,
5690                                       convert (ltype, integer_one_node),
5691                                       ltmp,
5692                                       NULL_TREE, NULL, NULL,
5693                                       divide)));
5694     expand_expr_stmt (ffecom_modify (void_type_node,
5695                                      rtmp,
5696                                      ffecom_1 (NEGATE_EXPR, rtype,
5697                                                rtmp)));
5698     expand_start_cond (ffecom_truth_value
5699                        (ffecom_2 (LT_EXPR, integer_type_node,
5700                                   rtmp,
5701                                   convert (rtype, integer_zero_node))),
5702                        0);
5703     expand_expr_stmt (ffecom_modify (void_type_node,
5704                                      rtmp,
5705                                      ffecom_1 (NEGATE_EXPR, rtype,
5706                                                ffecom_2 (RSHIFT_EXPR,
5707                                                          rtype,
5708                                                          rtmp,
5709                                                          integer_one_node))));
5710     expand_expr_stmt (ffecom_modify (void_type_node,
5711                                      ltmp,
5712                                      ffecom_2 (MULT_EXPR, ltype,
5713                                                ltmp,
5714                                                ltmp)));
5715     expand_end_cond ();
5716     expand_end_cond ();
5717     expand_start_loop (1);
5718     expand_start_cond (ffecom_truth_value
5719                        (ffecom_2 (BIT_AND_EXPR, rtype,
5720                                   rtmp,
5721                                   convert (rtype, integer_one_node))),
5722                        0);
5723     expand_expr_stmt (ffecom_modify (void_type_node,
5724                                      result,
5725                                      ffecom_2 (MULT_EXPR, ltype,
5726                                                result,
5727                                                ltmp)));
5728     expand_end_cond ();
5729     expand_exit_loop_if_false (NULL,
5730                                ffecom_truth_value
5731                                (ffecom_modify (rtype,
5732                                                rtmp,
5733                                                ffecom_2 (RSHIFT_EXPR,
5734                                                          rtype,
5735                                                          rtmp,
5736                                                          integer_one_node))));
5737     expand_expr_stmt (ffecom_modify (void_type_node,
5738                                      ltmp,
5739                                      ffecom_2 (MULT_EXPR, ltype,
5740                                                ltmp,
5741                                                ltmp)));
5742     expand_end_loop ();
5743     expand_end_cond ();
5744     if (!integer_zerop (basetypeof_l_is_int))
5745       expand_end_cond ();
5746     expand_expr_stmt (result);
5747
5748     t = ffecom_end_compstmt ();
5749
5750     result = expand_end_stmt_expr (se);
5751
5752     /* This code comes from c-parse.in, after its expand_end_stmt_expr.  */
5753
5754     if (TREE_CODE (t) == BLOCK)
5755       {
5756         /* Make a BIND_EXPR for the BLOCK already made.  */
5757         result = build (BIND_EXPR, TREE_TYPE (result),
5758                         NULL_TREE, result, t);
5759         /* Remove the block from the tree at this point.
5760            It gets put back at the proper place
5761            when the BIND_EXPR is expanded.  */
5762         delete_block (t);
5763       }
5764     else
5765       result = t;
5766   }
5767
5768   return result;
5769 }
5770
5771 /* ffecom_expr_transform_ -- Transform symbols in expr
5772
5773    ffebld expr;  // FFE expression.
5774    ffecom_expr_transform_ (expr);
5775
5776    Recursive descent on expr while transforming any untransformed SYMTERs.  */
5777
5778 static void
5779 ffecom_expr_transform_ (ffebld expr)
5780 {
5781   tree t;
5782   ffesymbol s;
5783
5784  tail_recurse:
5785
5786   if (expr == NULL)
5787     return;
5788
5789   switch (ffebld_op (expr))
5790     {
5791     case FFEBLD_opSYMTER:
5792       s = ffebld_symter (expr);
5793       t = ffesymbol_hook (s).decl_tree;
5794       if ((t == NULL_TREE)
5795           && ((ffesymbol_kind (s) != FFEINFO_kindNONE)
5796               || ((ffesymbol_where (s) != FFEINFO_whereNONE)
5797                   && (ffesymbol_where (s) != FFEINFO_whereINTRINSIC))))
5798         {
5799           s = ffecom_sym_transform_ (s);
5800           t = ffesymbol_hook (s).decl_tree;     /* Sfunc expr non-dummy,
5801                                                    DIMENSION expr? */
5802         }
5803       break;                    /* Ok if (t == NULL) here. */
5804
5805     case FFEBLD_opITEM:
5806       ffecom_expr_transform_ (ffebld_head (expr));
5807       expr = ffebld_trail (expr);
5808       goto tail_recurse;        /* :::::::::::::::::::: */
5809
5810     default:
5811       break;
5812     }
5813
5814   switch (ffebld_arity (expr))
5815     {
5816     case 2:
5817       ffecom_expr_transform_ (ffebld_left (expr));
5818       expr = ffebld_right (expr);
5819       goto tail_recurse;        /* :::::::::::::::::::: */
5820
5821     case 1:
5822       expr = ffebld_left (expr);
5823       goto tail_recurse;        /* :::::::::::::::::::: */
5824
5825     default:
5826       break;
5827     }
5828
5829   return;
5830 }
5831
5832 /* Make a type based on info in live f2c.h file.  */
5833
5834 static void
5835 ffecom_f2c_make_type_ (tree *type, int tcode, const char *name)
5836 {
5837   switch (tcode)
5838     {
5839     case FFECOM_f2ccodeCHAR:
5840       *type = make_signed_type (CHAR_TYPE_SIZE);
5841       break;
5842
5843     case FFECOM_f2ccodeSHORT:
5844       *type = make_signed_type (SHORT_TYPE_SIZE);
5845       break;
5846
5847     case FFECOM_f2ccodeINT:
5848       *type = make_signed_type (INT_TYPE_SIZE);
5849       break;
5850
5851     case FFECOM_f2ccodeLONG:
5852       *type = make_signed_type (LONG_TYPE_SIZE);
5853       break;
5854
5855     case FFECOM_f2ccodeLONGLONG:
5856       *type = make_signed_type (LONG_LONG_TYPE_SIZE);
5857       break;
5858
5859     case FFECOM_f2ccodeCHARPTR:
5860       *type = build_pointer_type (DEFAULT_SIGNED_CHAR
5861                                   ? signed_char_type_node
5862                                   : unsigned_char_type_node);
5863       break;
5864
5865     case FFECOM_f2ccodeFLOAT:
5866       *type = make_node (REAL_TYPE);
5867       TYPE_PRECISION (*type) = FLOAT_TYPE_SIZE;
5868       layout_type (*type);
5869       break;
5870
5871     case FFECOM_f2ccodeDOUBLE:
5872       *type = make_node (REAL_TYPE);
5873       TYPE_PRECISION (*type) = DOUBLE_TYPE_SIZE;
5874       layout_type (*type);
5875       break;
5876
5877     case FFECOM_f2ccodeLONGDOUBLE:
5878       *type = make_node (REAL_TYPE);
5879       TYPE_PRECISION (*type) = LONG_DOUBLE_TYPE_SIZE;
5880       layout_type (*type);
5881       break;
5882
5883     case FFECOM_f2ccodeTWOREALS:
5884       *type = ffecom_make_complex_type_ (ffecom_f2c_real_type_node);
5885       break;
5886
5887     case FFECOM_f2ccodeTWODOUBLEREALS:
5888       *type = ffecom_make_complex_type_ (ffecom_f2c_doublereal_type_node);
5889       break;
5890
5891     default:
5892       assert ("unexpected FFECOM_f2ccodeXYZZY!" == NULL);
5893       *type = error_mark_node;
5894       return;
5895     }
5896
5897   pushdecl (build_decl (TYPE_DECL,
5898                         ffecom_get_invented_identifier ("__g77_f2c_%s", name),
5899                         *type));
5900 }
5901
5902 /* Set the f2c list-directed-I/O code for whatever (integral) type has the
5903    given size.  */
5904
5905 static void
5906 ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
5907                           int code)
5908 {
5909   int j;
5910   tree t;
5911
5912   for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
5913     if ((t = ffecom_tree_type[bt][j]) != NULL_TREE
5914         && compare_tree_int (TYPE_SIZE (t), size) == 0)
5915       {
5916         assert (code != -1);
5917         ffecom_f2c_typecode_[bt][j] = code;
5918         code = -1;
5919       }
5920 }
5921
5922 /* Finish up globals after doing all program units in file
5923
5924    Need to handle only uninitialized COMMON areas.  */
5925
5926 static ffeglobal
5927 ffecom_finish_global_ (ffeglobal global)
5928 {
5929   tree cbtype;
5930   tree cbt;
5931   tree size;
5932
5933   if (ffeglobal_type (global) != FFEGLOBAL_typeCOMMON)
5934       return global;
5935
5936   if (ffeglobal_common_init (global))
5937       return global;
5938
5939   cbt = ffeglobal_hook (global);
5940   if ((cbt == NULL_TREE)
5941       || !ffeglobal_common_have_size (global))
5942     return global;              /* No need to make common, never ref'd. */
5943
5944   DECL_EXTERNAL (cbt) = 0;
5945
5946   /* Give the array a size now.  */
5947
5948   size = build_int_2 ((ffeglobal_common_size (global)
5949                       + ffeglobal_common_pad (global)) - 1,
5950                       0);
5951
5952   cbtype = TREE_TYPE (cbt);
5953   TYPE_DOMAIN (cbtype) = build_range_type (integer_type_node,
5954                                            integer_zero_node,
5955                                            size);
5956   if (!TREE_TYPE (size))
5957     TREE_TYPE (size) = TYPE_DOMAIN (cbtype);
5958   layout_type (cbtype);
5959
5960   cbt = start_decl (cbt, FALSE);
5961   assert (cbt == ffeglobal_hook (global));
5962
5963   finish_decl (cbt, NULL_TREE, FALSE);
5964
5965   return global;
5966 }
5967
5968 /* Finish up any untransformed symbols.  */
5969
5970 static ffesymbol
5971 ffecom_finish_symbol_transform_ (ffesymbol s)
5972 {
5973   if ((s == NULL) || (TREE_CODE (current_function_decl) == ERROR_MARK))
5974     return s;
5975
5976   /* It's easy to know to transform an untransformed symbol, to make sure
5977      we put out debugging info for it.  But COMMON variables, unlike
5978      EQUIVALENCE ones, aren't given declarations in addition to the
5979      tree expressions that specify offsets, because COMMON variables
5980      can be referenced in the outer scope where only dummy arguments
5981      (PARM_DECLs) should really be seen.  To be safe, just don't do any
5982      VAR_DECLs for COMMON variables when we transform them for real
5983      use, and therefore we do all the VAR_DECL creating here.  */
5984
5985   if (ffesymbol_hook (s).decl_tree == NULL_TREE)
5986     {
5987       if (ffesymbol_kind (s) != FFEINFO_kindNONE
5988           || (ffesymbol_where (s) != FFEINFO_whereNONE
5989               && ffesymbol_where (s) != FFEINFO_whereINTRINSIC
5990               && ffesymbol_where (s) != FFEINFO_whereDUMMY))
5991         /* Not transformed, and not CHARACTER*(*), and not a dummy
5992            argument, which can happen only if the entry point names
5993            it "rides in on" are all invalidated for other reasons.  */
5994         s = ffecom_sym_transform_ (s);
5995     }
5996
5997   if ((ffesymbol_where (s) == FFEINFO_whereCOMMON)
5998       && (ffesymbol_hook (s).decl_tree != error_mark_node))
5999     {
6000       /* This isn't working, at least for dbxout.  The .s file looks
6001          okay to me (burley), but in gdb 4.9 at least, the variables
6002          appear to reside somewhere outside of the common area, so
6003          it doesn't make sense to mislead anyone by generating the info
6004          on those variables until this is fixed.  NOTE: Same problem
6005          with EQUIVALENCE, sadly...see similar #if later.  */
6006       ffecom_member_phase2_ (ffesymbol_storage (ffesymbol_common (s)),
6007                              ffesymbol_storage (s));
6008     }
6009
6010   return s;
6011 }
6012
6013 /* Append underscore(s) to name before calling get_identifier.  "us"
6014    is nonzero if the name already contains an underscore and thus
6015    needs two underscores appended.  */
6016
6017 static tree
6018 ffecom_get_appended_identifier_ (char us, const char *name)
6019 {
6020   int i;
6021   char *newname;
6022   tree id;
6023
6024   newname = xmalloc ((i = strlen (name)) + 1
6025                      + ffe_is_underscoring ()
6026                      + us);
6027   memcpy (newname, name, i);
6028   newname[i] = '_';
6029   newname[i + us] = '_';
6030   newname[i + 1 + us] = '\0';
6031   id = get_identifier (newname);
6032
6033   free (newname);
6034
6035   return id;
6036 }
6037
6038 /* Decide whether to append underscore to name before calling
6039    get_identifier.  */
6040
6041 static tree
6042 ffecom_get_external_identifier_ (ffesymbol s)
6043 {
6044   char us;
6045   const char *name = ffesymbol_text (s);
6046
6047   /* If name is a built-in name, just return it as is.  */
6048
6049   if (!ffe_is_underscoring ()
6050       || (strcmp (name, FFETARGET_nameBLANK_COMMON) == 0)
6051 #if FFETARGET_isENFORCED_MAIN_NAME
6052       || (strcmp (name, FFETARGET_nameENFORCED_NAME) == 0)
6053 #else
6054       || (strcmp (name, FFETARGET_nameUNNAMED_MAIN) == 0)
6055 #endif
6056       || (strcmp (name, FFETARGET_nameUNNAMED_BLOCK_DATA) == 0))
6057     return get_identifier (name);
6058
6059   us = ffe_is_second_underscore ()
6060     ? (strchr (name, '_') != NULL)
6061       : 0;
6062
6063   return ffecom_get_appended_identifier_ (us, name);
6064 }
6065
6066 /* Decide whether to append underscore to internal name before calling
6067    get_identifier.
6068
6069    This is for non-external, top-function-context names only.  Transform
6070    identifier so it doesn't conflict with the transformed result
6071    of using a _different_ external name.  E.g. if "CALL FOO" is
6072    transformed into "FOO_();", then the variable in "FOO_ = 3"
6073    must be transformed into something that does not conflict, since
6074    these two things should be independent.
6075
6076    The transformation is as follows.  If the name does not contain
6077    an underscore, there is no possible conflict, so just return.
6078    If the name does contain an underscore, then transform it just
6079    like we transform an external identifier.  */
6080
6081 static tree
6082 ffecom_get_identifier_ (const char *name)
6083 {
6084   /* If name does not contain an underscore, just return it as is.  */
6085
6086   if (!ffe_is_underscoring ()
6087       || (strchr (name, '_') == NULL))
6088     return get_identifier (name);
6089
6090   return ffecom_get_appended_identifier_ (ffe_is_second_underscore (),
6091                                           name);
6092 }
6093
6094 /* ffecom_gen_sfuncdef_ -- Generate definition of statement function
6095
6096    tree t;
6097    ffesymbol s;  // kindFUNCTION, whereIMMEDIATE.
6098    t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s),
6099          ffesymbol_kindtype(s));
6100
6101    Call after setting up containing function and getting trees for all
6102    other symbols.  */
6103
6104 static tree
6105 ffecom_gen_sfuncdef_ (ffesymbol s, ffeinfoBasictype bt, ffeinfoKindtype kt)
6106 {
6107   ffebld expr = ffesymbol_sfexpr (s);
6108   tree type;
6109   tree func;
6110   tree result;
6111   bool charfunc = (bt == FFEINFO_basictypeCHARACTER);
6112   static bool recurse = FALSE;
6113   int old_lineno = lineno;
6114   const char *old_input_filename = input_filename;
6115
6116   ffecom_nested_entry_ = s;
6117
6118   /* For now, we don't have a handy pointer to where the sfunc is actually
6119      defined, though that should be easy to add to an ffesymbol. (The
6120      token/where info available might well point to the place where the type
6121      of the sfunc is declared, especially if that precedes the place where
6122      the sfunc itself is defined, which is typically the case.)  We should
6123      put out a null pointer rather than point somewhere wrong, but I want to
6124      see how it works at this point.  */
6125
6126   input_filename = ffesymbol_where_filename (s);
6127   lineno = ffesymbol_where_filelinenum (s);
6128
6129   /* Pretransform the expression so any newly discovered things belong to the
6130      outer program unit, not to the statement function. */
6131
6132   ffecom_expr_transform_ (expr);
6133
6134   /* Make sure no recursive invocation of this fn (a specific case of failing
6135      to pretransform an sfunc's expression, i.e. where its expression
6136      references another untransformed sfunc) happens. */
6137
6138   assert (!recurse);
6139   recurse = TRUE;
6140
6141   push_f_function_context ();
6142
6143   if (charfunc)
6144     type = void_type_node;
6145   else
6146     {
6147       type = ffecom_tree_type[bt][kt];
6148       if (type == NULL_TREE)
6149         type = integer_type_node;       /* _sym_exec_transition reports
6150                                            error. */
6151     }
6152
6153   start_function (ffecom_get_identifier_ (ffesymbol_text (s)),
6154                   build_function_type (type, NULL_TREE),
6155                   1,            /* nested/inline */
6156                   0);           /* TREE_PUBLIC */
6157
6158   /* We don't worry about COMPLEX return values here, because this is
6159      entirely internal to our code, and gcc has the ability to return COMPLEX
6160      directly as a value.  */
6161
6162   if (charfunc)
6163     {                           /* Prepend arg for where result goes. */
6164       tree type;
6165
6166       type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
6167
6168       result = ffecom_get_invented_identifier ("__g77_%s", "result");
6169
6170       ffecom_char_enhance_arg_ (&type, s);      /* Ignore returned length. */
6171
6172       type = build_pointer_type (type);
6173       result = build_decl (PARM_DECL, result, type);
6174
6175       push_parm_decl (result);
6176     }
6177   else
6178     result = NULL_TREE;         /* Not ref'd if !charfunc. */
6179
6180   ffecom_push_dummy_decls_ (ffesymbol_dummyargs (s), TRUE);
6181
6182   store_parm_decls (0);
6183
6184   ffecom_start_compstmt ();
6185
6186   if (expr != NULL)
6187     {
6188       if (charfunc)
6189         {
6190           ffetargetCharacterSize sz = ffesymbol_size (s);
6191           tree result_length;
6192
6193           result_length = build_int_2 (sz, 0);
6194           TREE_TYPE (result_length) = ffecom_f2c_ftnlen_type_node;
6195
6196           ffecom_prepare_let_char_ (sz, expr);
6197
6198           ffecom_prepare_end ();
6199
6200           ffecom_let_char_ (result, result_length, sz, expr);
6201           expand_null_return ();
6202         }
6203       else
6204         {
6205           ffecom_prepare_expr (expr);
6206
6207           ffecom_prepare_end ();
6208
6209           expand_return (ffecom_modify (NULL_TREE,
6210                                         DECL_RESULT (current_function_decl),
6211                                         ffecom_expr (expr)));
6212         }
6213     }
6214
6215   ffecom_end_compstmt ();
6216
6217   func = current_function_decl;
6218   finish_function (1);
6219
6220   pop_f_function_context ();
6221
6222   recurse = FALSE;
6223
6224   lineno = old_lineno;
6225   input_filename = old_input_filename;
6226
6227   ffecom_nested_entry_ = NULL;
6228
6229   return func;
6230 }
6231
6232 static const char *
6233 ffecom_gfrt_args_ (ffecomGfrt ix)
6234 {
6235   return ffecom_gfrt_argstring_[ix];
6236 }
6237
6238 static tree
6239 ffecom_gfrt_tree_ (ffecomGfrt ix)
6240 {
6241   if (ffecom_gfrt_[ix] == NULL_TREE)
6242     ffecom_make_gfrt_ (ix);
6243
6244   return ffecom_1 (ADDR_EXPR,
6245                    build_pointer_type (TREE_TYPE (ffecom_gfrt_[ix])),
6246                    ffecom_gfrt_[ix]);
6247 }
6248
6249 /* Return initialize-to-zero expression for this VAR_DECL.  */
6250
6251 /* A somewhat evil way to prevent the garbage collector
6252    from collecting 'tree' structures.  */
6253 #define NUM_TRACKED_CHUNK 63
6254 struct tree_ggc_tracker GTY(())
6255 {
6256   struct tree_ggc_tracker *next;
6257   tree trees[NUM_TRACKED_CHUNK];
6258 };
6259 static GTY(()) struct tree_ggc_tracker *tracker_head;
6260
6261 void
6262 ffecom_save_tree_forever (tree t)
6263 {
6264   int i;
6265   if (tracker_head != NULL)
6266     for (i = 0; i < NUM_TRACKED_CHUNK; i++)
6267       if (tracker_head->trees[i] == NULL)
6268         {
6269           tracker_head->trees[i] = t;
6270           return;
6271         }
6272
6273   {
6274     /* Need to allocate a new block.  */
6275     struct tree_ggc_tracker *old_head = tracker_head;
6276
6277     tracker_head = ggc_alloc (sizeof (*tracker_head));
6278     tracker_head->next = old_head;
6279     tracker_head->trees[0] = t;
6280     for (i = 1; i < NUM_TRACKED_CHUNK; i++)
6281       tracker_head->trees[i] = NULL;
6282   }
6283 }
6284
6285 static tree
6286 ffecom_init_zero_ (tree decl)
6287 {
6288   tree init;
6289   int incremental = TREE_STATIC (decl);
6290   tree type = TREE_TYPE (decl);
6291
6292   if (incremental)
6293     {
6294       make_decl_rtl (decl, NULL);
6295       assemble_variable (decl, TREE_PUBLIC (decl) ? 1 : 0, 0, 1);
6296     }
6297
6298   if ((TREE_CODE (type) != ARRAY_TYPE)
6299       && (TREE_CODE (type) != RECORD_TYPE)
6300       && (TREE_CODE (type) != UNION_TYPE)
6301       && !incremental)
6302     init = convert (type, integer_zero_node);
6303   else if (!incremental)
6304     {
6305       init = build_constructor (type, NULL_TREE);
6306       TREE_CONSTANT (init) = 1;
6307       TREE_STATIC (init) = 1;
6308     }
6309   else
6310     {
6311       assemble_zeros (int_size_in_bytes (type));
6312       init = error_mark_node;
6313     }
6314
6315   return init;
6316 }
6317
6318 static tree
6319 ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
6320                          tree *maybe_tree)
6321 {
6322   tree expr_tree;
6323   tree length_tree;
6324
6325   switch (ffebld_op (arg))
6326     {
6327     case FFEBLD_opCONTER:       /* For F90, check 0-length. */
6328       if (ffetarget_length_character1
6329           (ffebld_constant_character1
6330            (ffebld_conter (arg))) == 0)
6331         {
6332           *maybe_tree = integer_zero_node;
6333           return convert (tree_type, integer_zero_node);
6334         }
6335
6336       *maybe_tree = integer_one_node;
6337       expr_tree = build_int_2 (*ffetarget_text_character1
6338                                (ffebld_constant_character1
6339                                 (ffebld_conter (arg))),
6340                                0);
6341       TREE_TYPE (expr_tree) = tree_type;
6342       return expr_tree;
6343
6344     case FFEBLD_opSYMTER:
6345     case FFEBLD_opARRAYREF:
6346     case FFEBLD_opFUNCREF:
6347     case FFEBLD_opSUBSTR:
6348       ffecom_char_args_ (&expr_tree, &length_tree, arg);
6349
6350       if ((expr_tree == error_mark_node)
6351           || (length_tree == error_mark_node))
6352         {
6353           *maybe_tree = error_mark_node;
6354           return error_mark_node;
6355         }
6356
6357       if (integer_zerop (length_tree))
6358         {
6359           *maybe_tree = integer_zero_node;
6360           return convert (tree_type, integer_zero_node);
6361         }
6362
6363       expr_tree
6364         = ffecom_1 (INDIRECT_REF,
6365                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6366                     expr_tree);
6367       expr_tree
6368         = ffecom_2 (ARRAY_REF,
6369                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6370                     expr_tree,
6371                     integer_one_node);
6372       expr_tree = convert (tree_type, expr_tree);
6373
6374       if (TREE_CODE (length_tree) == INTEGER_CST)
6375         *maybe_tree = integer_one_node;
6376       else                      /* Must check length at run time.  */
6377         *maybe_tree
6378           = ffecom_truth_value
6379             (ffecom_2 (GT_EXPR, integer_type_node,
6380                        length_tree,
6381                        ffecom_f2c_ftnlen_zero_node));
6382       return expr_tree;
6383
6384     case FFEBLD_opPAREN:
6385     case FFEBLD_opCONVERT:
6386       if (ffeinfo_size (ffebld_info (arg)) == 0)
6387         {
6388           *maybe_tree = integer_zero_node;
6389           return convert (tree_type, integer_zero_node);
6390         }
6391       return ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6392                                       maybe_tree);
6393
6394     case FFEBLD_opCONCATENATE:
6395       {
6396         tree maybe_left;
6397         tree maybe_right;
6398         tree expr_left;
6399         tree expr_right;
6400
6401         expr_left = ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6402                                              &maybe_left);
6403         expr_right = ffecom_intrinsic_ichar_ (tree_type, ffebld_right (arg),
6404                                               &maybe_right);
6405         *maybe_tree = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
6406                                 maybe_left,
6407                                 maybe_right);
6408         expr_tree = ffecom_3 (COND_EXPR, tree_type,
6409                               maybe_left,
6410                               expr_left,
6411                               expr_right);
6412         return expr_tree;
6413       }
6414
6415     default:
6416       assert ("bad op in ICHAR" == NULL);
6417       return error_mark_node;
6418     }
6419 }
6420
6421 /* ffecom_intrinsic_len_ -- Return length info for char arg (LEN())
6422
6423    tree length_arg;
6424    ffebld expr;
6425    length_arg = ffecom_intrinsic_len_ (expr);
6426
6427    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
6428    subexpressions by constructing the appropriate tree for the
6429    length-of-character-text argument in a calling sequence.  */
6430
6431 static tree
6432 ffecom_intrinsic_len_ (ffebld expr)
6433 {
6434   ffetargetCharacter1 val;
6435   tree length;
6436
6437   switch (ffebld_op (expr))
6438     {
6439     case FFEBLD_opCONTER:
6440       val = ffebld_constant_character1 (ffebld_conter (expr));
6441       length = build_int_2 (ffetarget_length_character1 (val), 0);
6442       TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6443       break;
6444
6445     case FFEBLD_opSYMTER:
6446       {
6447         ffesymbol s = ffebld_symter (expr);
6448         tree item;
6449
6450         item = ffesymbol_hook (s).decl_tree;
6451         if (item == NULL_TREE)
6452           {
6453             s = ffecom_sym_transform_ (s);
6454             item = ffesymbol_hook (s).decl_tree;
6455           }
6456         if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
6457           {
6458             if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
6459               length = ffesymbol_hook (s).length_tree;
6460             else
6461               {
6462                 length = build_int_2 (ffesymbol_size (s), 0);
6463                 TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6464               }
6465           }
6466         else if (item == error_mark_node)
6467           length = error_mark_node;
6468         else                    /* FFEINFO_kindFUNCTION: */
6469           length = NULL_TREE;
6470       }
6471       break;
6472
6473     case FFEBLD_opARRAYREF:
6474       length = ffecom_intrinsic_len_ (ffebld_left (expr));
6475       break;
6476
6477     case FFEBLD_opSUBSTR:
6478       {
6479         ffebld start;
6480         ffebld end;
6481         ffebld thing = ffebld_right (expr);
6482         tree start_tree;
6483         tree end_tree;
6484
6485         assert (ffebld_op (thing) == FFEBLD_opITEM);
6486         start = ffebld_head (thing);
6487         thing = ffebld_trail (thing);
6488         assert (ffebld_trail (thing) == NULL);
6489         end = ffebld_head (thing);
6490
6491         length = ffecom_intrinsic_len_ (ffebld_left (expr));
6492
6493         if (length == error_mark_node)
6494           break;
6495
6496         if (start == NULL)
6497           {
6498             if (end == NULL)
6499               ;
6500             else
6501               {
6502                 length = convert (ffecom_f2c_ftnlen_type_node,
6503                                   ffecom_expr (end));
6504               }
6505           }
6506         else
6507           {
6508             start_tree = convert (ffecom_f2c_ftnlen_type_node,
6509                                   ffecom_expr (start));
6510
6511             if (start_tree == error_mark_node)
6512               {
6513                 length = error_mark_node;
6514                 break;
6515               }
6516
6517             if (end == NULL)
6518               {
6519                 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6520                                    ffecom_f2c_ftnlen_one_node,
6521                                    ffecom_2 (MINUS_EXPR,
6522                                              ffecom_f2c_ftnlen_type_node,
6523                                              length,
6524                                              start_tree));
6525               }
6526             else
6527               {
6528                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
6529                                     ffecom_expr (end));
6530
6531                 if (end_tree == error_mark_node)
6532                   {
6533                     length = error_mark_node;
6534                     break;
6535                   }
6536
6537                 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6538                                    ffecom_f2c_ftnlen_one_node,
6539                                    ffecom_2 (MINUS_EXPR,
6540                                              ffecom_f2c_ftnlen_type_node,
6541                                              end_tree, start_tree));
6542               }
6543           }
6544       }
6545       break;
6546
6547     case FFEBLD_opCONCATENATE:
6548       length
6549         = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6550                     ffecom_intrinsic_len_ (ffebld_left (expr)),
6551                     ffecom_intrinsic_len_ (ffebld_right (expr)));
6552       break;
6553
6554     case FFEBLD_opFUNCREF:
6555     case FFEBLD_opCONVERT:
6556       length = build_int_2 (ffebld_size (expr), 0);
6557       TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6558       break;
6559
6560     default:
6561       assert ("bad op for single char arg expr" == NULL);
6562       length = ffecom_f2c_ftnlen_zero_node;
6563       break;
6564     }
6565
6566   assert (length != NULL_TREE);
6567
6568   return length;
6569 }
6570
6571 /* Handle CHARACTER assignments.
6572
6573    Generates code to do the assignment.  Used by ordinary assignment
6574    statement handler ffecom_let_stmt and by statement-function
6575    handler to generate code for a statement function.  */
6576
6577 static void
6578 ffecom_let_char_ (tree dest_tree, tree dest_length,
6579                   ffetargetCharacterSize dest_size, ffebld source)
6580 {
6581   ffecomConcatList_ catlist;
6582   tree source_length;
6583   tree source_tree;
6584   tree expr_tree;
6585
6586   if ((dest_tree == error_mark_node)
6587       || (dest_length == error_mark_node))
6588     return;
6589
6590   assert (dest_tree != NULL_TREE);
6591   assert (dest_length != NULL_TREE);
6592
6593   /* Source might be an opCONVERT, which just means it is a different size
6594      than the destination.  Since the underlying implementation here handles
6595      that (directly or via the s_copy or s_cat run-time-library functions),
6596      we don't need the "convenience" of an opCONVERT that tells us to
6597      truncate or blank-pad, particularly since the resulting implementation
6598      would probably be slower than otherwise. */
6599
6600   while (ffebld_op (source) == FFEBLD_opCONVERT)
6601     source = ffebld_left (source);
6602
6603   catlist = ffecom_concat_list_new_ (source, dest_size);
6604   switch (ffecom_concat_list_count_ (catlist))
6605     {
6606     case 0:                     /* Shouldn't happen, but in case it does... */
6607       ffecom_concat_list_kill_ (catlist);
6608       source_tree = null_pointer_node;
6609       source_length = ffecom_f2c_ftnlen_zero_node;
6610       expr_tree = build_tree_list (NULL_TREE, dest_tree);
6611       TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6612       TREE_CHAIN (TREE_CHAIN (expr_tree))
6613         = build_tree_list (NULL_TREE, dest_length);
6614       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6615         = build_tree_list (NULL_TREE, source_length);
6616
6617       expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6618       TREE_SIDE_EFFECTS (expr_tree) = 1;
6619
6620       expand_expr_stmt (expr_tree);
6621
6622       return;
6623
6624     case 1:                     /* The (fairly) easy case. */
6625       ffecom_char_args_ (&source_tree, &source_length,
6626                          ffecom_concat_list_expr_ (catlist, 0));
6627       ffecom_concat_list_kill_ (catlist);
6628       assert (source_tree != NULL_TREE);
6629       assert (source_length != NULL_TREE);
6630
6631       if ((source_tree == error_mark_node)
6632           || (source_length == error_mark_node))
6633         return;
6634
6635       if (dest_size == 1)
6636         {
6637           dest_tree
6638             = ffecom_1 (INDIRECT_REF,
6639                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6640                                                       (dest_tree))),
6641                         dest_tree);
6642           dest_tree
6643             = ffecom_2 (ARRAY_REF,
6644                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6645                                                       (dest_tree))),
6646                         dest_tree,
6647                         integer_one_node);
6648           source_tree
6649             = ffecom_1 (INDIRECT_REF,
6650                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6651                                                       (source_tree))),
6652                         source_tree);
6653           source_tree
6654             = ffecom_2 (ARRAY_REF,
6655                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6656                                                       (source_tree))),
6657                         source_tree,
6658                         integer_one_node);
6659
6660           expr_tree = ffecom_modify (void_type_node, dest_tree, source_tree);
6661
6662           expand_expr_stmt (expr_tree);
6663
6664           return;
6665         }
6666
6667       expr_tree = build_tree_list (NULL_TREE, dest_tree);
6668       TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6669       TREE_CHAIN (TREE_CHAIN (expr_tree))
6670         = build_tree_list (NULL_TREE, dest_length);
6671       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6672         = build_tree_list (NULL_TREE, source_length);
6673
6674       expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6675       TREE_SIDE_EFFECTS (expr_tree) = 1;
6676
6677       expand_expr_stmt (expr_tree);
6678
6679       return;
6680
6681     default:                    /* Must actually concatenate things. */
6682       break;
6683     }
6684
6685   /* Heavy-duty concatenation. */
6686
6687   {
6688     int count = ffecom_concat_list_count_ (catlist);
6689     int i;
6690     tree lengths;
6691     tree items;
6692     tree length_array;
6693     tree item_array;
6694     tree citem;
6695     tree clength;
6696
6697     {
6698       tree hook;
6699
6700       hook = ffebld_nonter_hook (source);
6701       assert (hook);
6702       assert (TREE_CODE (hook) == TREE_VEC);
6703       assert (TREE_VEC_LENGTH (hook) == 2);
6704       length_array = lengths = TREE_VEC_ELT (hook, 0);
6705       item_array = items = TREE_VEC_ELT (hook, 1);
6706     }
6707
6708     for (i = 0; i < count; ++i)
6709       {
6710         ffecom_char_args_ (&citem, &clength,
6711                            ffecom_concat_list_expr_ (catlist, i));
6712         if ((citem == error_mark_node)
6713             || (clength == error_mark_node))
6714           {
6715             ffecom_concat_list_kill_ (catlist);
6716             return;
6717           }
6718
6719         items
6720           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
6721                       ffecom_modify (void_type_node,
6722                                      ffecom_2 (ARRAY_REF,
6723                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
6724                                                item_array,
6725                                                build_int_2 (i, 0)),
6726                                      citem),
6727                       items);
6728         lengths
6729           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
6730                       ffecom_modify (void_type_node,
6731                                      ffecom_2 (ARRAY_REF,
6732                    TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
6733                                                length_array,
6734                                                build_int_2 (i, 0)),
6735                                      clength),
6736                       lengths);
6737       }
6738
6739     expr_tree = build_tree_list (NULL_TREE, dest_tree);
6740     TREE_CHAIN (expr_tree)
6741       = build_tree_list (NULL_TREE,
6742                          ffecom_1 (ADDR_EXPR,
6743                                    build_pointer_type (TREE_TYPE (items)),
6744                                    items));
6745     TREE_CHAIN (TREE_CHAIN (expr_tree))
6746       = build_tree_list (NULL_TREE,
6747                          ffecom_1 (ADDR_EXPR,
6748                                    build_pointer_type (TREE_TYPE (lengths)),
6749                                    lengths));
6750     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6751       = build_tree_list
6752         (NULL_TREE,
6753          ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
6754                    convert (ffecom_f2c_ftnlen_type_node,
6755                             build_int_2 (count, 0))));
6756     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree))))
6757       = build_tree_list (NULL_TREE, dest_length);
6758
6759     expr_tree = ffecom_call_gfrt (FFECOM_gfrtCAT, expr_tree, NULL_TREE);
6760     TREE_SIDE_EFFECTS (expr_tree) = 1;
6761
6762     expand_expr_stmt (expr_tree);
6763   }
6764
6765   ffecom_concat_list_kill_ (catlist);
6766 }
6767
6768 /* ffecom_make_gfrt_ -- Make initial info for run-time routine
6769
6770    ffecomGfrt ix;
6771    ffecom_make_gfrt_(ix);
6772
6773    Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL
6774    for the indicated run-time routine (ix).  */
6775
6776 static void
6777 ffecom_make_gfrt_ (ffecomGfrt ix)
6778 {
6779   tree t;
6780   tree ttype;
6781
6782   switch (ffecom_gfrt_type_[ix])
6783     {
6784     case FFECOM_rttypeVOID_:
6785       ttype = void_type_node;
6786       break;
6787
6788     case FFECOM_rttypeVOIDSTAR_:
6789       ttype = TREE_TYPE (null_pointer_node);    /* `void *'. */
6790       break;
6791
6792     case FFECOM_rttypeFTNINT_:
6793       ttype = ffecom_f2c_ftnint_type_node;
6794       break;
6795
6796     case FFECOM_rttypeINTEGER_:
6797       ttype = ffecom_f2c_integer_type_node;
6798       break;
6799
6800     case FFECOM_rttypeLONGINT_:
6801       ttype = ffecom_f2c_longint_type_node;
6802       break;
6803
6804     case FFECOM_rttypeLOGICAL_:
6805       ttype = ffecom_f2c_logical_type_node;
6806       break;
6807
6808     case FFECOM_rttypeREAL_F2C_:
6809       ttype = double_type_node;
6810       break;
6811
6812     case FFECOM_rttypeREAL_GNU_:
6813       ttype = float_type_node;
6814       break;
6815
6816     case FFECOM_rttypeCOMPLEX_F2C_:
6817       ttype = void_type_node;
6818       break;
6819
6820     case FFECOM_rttypeCOMPLEX_GNU_:
6821       ttype = ffecom_f2c_complex_type_node;
6822       break;
6823
6824     case FFECOM_rttypeDOUBLE_:
6825       ttype = double_type_node;
6826       break;
6827
6828     case FFECOM_rttypeDOUBLEREAL_:
6829       ttype = ffecom_f2c_doublereal_type_node;
6830       break;
6831
6832     case FFECOM_rttypeDBLCMPLX_F2C_:
6833       ttype = void_type_node;
6834       break;
6835
6836     case FFECOM_rttypeDBLCMPLX_GNU_:
6837       ttype = ffecom_f2c_doublecomplex_type_node;
6838       break;
6839
6840     case FFECOM_rttypeCHARACTER_:
6841       ttype = void_type_node;
6842       break;
6843
6844     default:
6845       ttype = NULL;
6846       assert ("bad rttype" == NULL);
6847       break;
6848     }
6849
6850   ttype = build_function_type (ttype, NULL_TREE);
6851   t = build_decl (FUNCTION_DECL,
6852                   get_identifier (ffecom_gfrt_name_[ix]),
6853                   ttype);
6854   DECL_EXTERNAL (t) = 1;
6855   TREE_READONLY (t) = ffecom_gfrt_const_[ix] ? 1 : 0;
6856   TREE_PUBLIC (t) = 1;
6857   TREE_THIS_VOLATILE (t) = ffecom_gfrt_volatile_[ix] ? 1 : 0;
6858
6859   /* Sanity check:  A function that's const cannot be volatile.  */
6860
6861   assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_volatile_[ix] : 1);
6862
6863   /* Sanity check: A function that's const cannot return complex.  */
6864
6865   assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_complex_[ix] : 1);
6866
6867   t = start_decl (t, TRUE);
6868
6869   finish_decl (t, NULL_TREE, TRUE);
6870
6871   ffecom_gfrt_[ix] = t;
6872 }
6873
6874 /* Phase 1 pass over each member of a COMMON/EQUIVALENCE group.  */
6875
6876 static void
6877 ffecom_member_phase1_ (ffestorag mst UNUSED, ffestorag st)
6878 {
6879   ffesymbol s = ffestorag_symbol (st);
6880
6881   if (ffesymbol_namelisted (s))
6882     ffecom_member_namelisted_ = TRUE;
6883 }
6884
6885 /* Phase 2 pass over each member of a COMMON/EQUIVALENCE group.  Declare
6886    the member so debugger will see it.  Otherwise nobody should be
6887    referencing the member.  */
6888
6889 static void
6890 ffecom_member_phase2_ (ffestorag mst, ffestorag st)
6891 {
6892   ffesymbol s;
6893   tree t;
6894   tree mt;
6895   tree type;
6896
6897   if ((mst == NULL)
6898       || ((mt = ffestorag_hook (mst)) == NULL)
6899       || (mt == error_mark_node))
6900     return;
6901
6902   if ((st == NULL)
6903       || ((s = ffestorag_symbol (st)) == NULL))
6904     return;
6905
6906   type = ffecom_type_localvar_ (s,
6907                                 ffesymbol_basictype (s),
6908                                 ffesymbol_kindtype (s));
6909   if (type == error_mark_node)
6910     return;
6911
6912   t = build_decl (VAR_DECL,
6913                   ffecom_get_identifier_ (ffesymbol_text (s)),
6914                   type);
6915
6916   TREE_STATIC (t) = TREE_STATIC (mt);
6917   DECL_INITIAL (t) = NULL_TREE;
6918   TREE_ASM_WRITTEN (t) = 1;
6919   TREE_USED (t) = 1;
6920
6921   SET_DECL_RTL (t,
6922                 gen_rtx (MEM, TYPE_MODE (type),
6923                          plus_constant (XEXP (DECL_RTL (mt), 0),
6924                                         ffestorag_modulo (mst)
6925                                         + ffestorag_offset (st)
6926                                         - ffestorag_offset (mst))));
6927
6928   t = start_decl (t, FALSE);
6929
6930   finish_decl (t, NULL_TREE, FALSE);
6931 }
6932
6933 /* Prepare source expression for assignment into a destination perhaps known
6934    to be of a specific size.  */
6935
6936 static void
6937 ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size, ffebld source)
6938 {
6939   ffecomConcatList_ catlist;
6940   int count;
6941   int i;
6942   tree ltmp;
6943   tree itmp;
6944   tree tempvar = NULL_TREE;
6945
6946   while (ffebld_op (source) == FFEBLD_opCONVERT)
6947     source = ffebld_left (source);
6948
6949   catlist = ffecom_concat_list_new_ (source, dest_size);
6950   count = ffecom_concat_list_count_ (catlist);
6951
6952   if (count >= 2)
6953     {
6954       ltmp
6955         = ffecom_make_tempvar ("let_char_len", ffecom_f2c_ftnlen_type_node,
6956                                FFETARGET_charactersizeNONE, count);
6957       itmp
6958         = ffecom_make_tempvar ("let_char_item", ffecom_f2c_address_type_node,
6959                                FFETARGET_charactersizeNONE, count);
6960
6961       tempvar = make_tree_vec (2);
6962       TREE_VEC_ELT (tempvar, 0) = ltmp;
6963       TREE_VEC_ELT (tempvar, 1) = itmp;
6964     }
6965
6966   for (i = 0; i < count; ++i)
6967     ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist, i));
6968
6969   ffecom_concat_list_kill_ (catlist);
6970
6971   if (tempvar)
6972     {
6973       ffebld_nonter_set_hook (source, tempvar);
6974       current_binding_level->prep_state = 1;
6975     }
6976 }
6977
6978 /* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order
6979
6980    Ignores STAR (alternate-return) dummies.  All other get exec-transitioned
6981    (which generates their trees) and then their trees get push_parm_decl'd.
6982
6983    The second arg is TRUE if the dummies are for a statement function, in
6984    which case lengths are not pushed for character arguments (since they are
6985    always known by both the caller and the callee, though the code allows
6986    for someday permitting CHAR*(*) stmtfunc dummies).  */
6987
6988 static void
6989 ffecom_push_dummy_decls_ (ffebld dummy_list, bool stmtfunc)
6990 {
6991   ffebld dummy;
6992   ffebld dumlist;
6993   ffesymbol s;
6994   tree parm;
6995
6996   ffecom_transform_only_dummies_ = TRUE;
6997
6998   /* First push the parms corresponding to actual dummy "contents".  */
6999
7000   for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7001     {
7002       dummy = ffebld_head (dumlist);
7003       switch (ffebld_op (dummy))
7004         {
7005         case FFEBLD_opSTAR:
7006         case FFEBLD_opANY:
7007           continue;             /* Forget alternate returns. */
7008
7009         default:
7010           break;
7011         }
7012       assert (ffebld_op (dummy) == FFEBLD_opSYMTER);
7013       s = ffebld_symter (dummy);
7014       parm = ffesymbol_hook (s).decl_tree;
7015       if (parm == NULL_TREE)
7016         {
7017           s = ffecom_sym_transform_ (s);
7018           parm = ffesymbol_hook (s).decl_tree;
7019           assert (parm != NULL_TREE);
7020         }
7021       if (parm != error_mark_node)
7022         push_parm_decl (parm);
7023     }
7024
7025   /* Then, for CHARACTER dummies, push the parms giving their lengths.  */
7026
7027   for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7028     {
7029       dummy = ffebld_head (dumlist);
7030       switch (ffebld_op (dummy))
7031         {
7032         case FFEBLD_opSTAR:
7033         case FFEBLD_opANY:
7034           continue;             /* Forget alternate returns, they mean
7035                                    NOTHING! */
7036
7037         default:
7038           break;
7039         }
7040       s = ffebld_symter (dummy);
7041       if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
7042         continue;               /* Only looking for CHARACTER arguments. */
7043       if (stmtfunc && (ffesymbol_size (s) != FFETARGET_charactersizeNONE))
7044         continue;               /* Stmtfunc arg with known size needs no
7045                                    length param. */
7046       if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
7047         continue;               /* Only looking for variables and arrays. */
7048       parm = ffesymbol_hook (s).length_tree;
7049       assert (parm != NULL_TREE);
7050       if (parm != error_mark_node)
7051         push_parm_decl (parm);
7052     }
7053
7054   ffecom_transform_only_dummies_ = FALSE;
7055 }
7056
7057 /* ffecom_start_progunit_ -- Beginning of program unit
7058
7059    Does GNU back end stuff necessary to teach it about the start of its
7060    equivalent of a Fortran program unit.  */
7061
7062 static void
7063 ffecom_start_progunit_ ()
7064 {
7065   ffesymbol fn = ffecom_primary_entry_;
7066   ffebld arglist;
7067   tree id;                      /* Identifier (name) of function. */
7068   tree type;                    /* Type of function. */
7069   tree result;                  /* Result of function. */
7070   ffeinfoBasictype bt;
7071   ffeinfoKindtype kt;
7072   ffeglobal g;
7073   ffeglobalType gt;
7074   ffeglobalType egt = FFEGLOBAL_type;
7075   bool charfunc;
7076   bool cmplxfunc;
7077   bool altentries = (ffecom_num_entrypoints_ != 0);
7078   bool multi
7079   = altentries
7080   && (ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
7081   && (ffecom_master_bt_ == FFEINFO_basictypeNONE);
7082   bool main_program = FALSE;
7083   int old_lineno = lineno;
7084   const char *old_input_filename = input_filename;
7085
7086   assert (fn != NULL);
7087   assert (ffesymbol_hook (fn).decl_tree == NULL_TREE);
7088
7089   input_filename = ffesymbol_where_filename (fn);
7090   lineno = ffesymbol_where_filelinenum (fn);
7091
7092   switch (ffecom_primary_entry_kind_)
7093     {
7094     case FFEINFO_kindPROGRAM:
7095       main_program = TRUE;
7096       gt = FFEGLOBAL_typeMAIN;
7097       bt = FFEINFO_basictypeNONE;
7098       kt = FFEINFO_kindtypeNONE;
7099       type = ffecom_tree_fun_type_void;
7100       charfunc = FALSE;
7101       cmplxfunc = FALSE;
7102       break;
7103
7104     case FFEINFO_kindBLOCKDATA:
7105       gt = FFEGLOBAL_typeBDATA;
7106       bt = FFEINFO_basictypeNONE;
7107       kt = FFEINFO_kindtypeNONE;
7108       type = ffecom_tree_fun_type_void;
7109       charfunc = FALSE;
7110       cmplxfunc = FALSE;
7111       break;
7112
7113     case FFEINFO_kindFUNCTION:
7114       gt = FFEGLOBAL_typeFUNC;
7115       egt = FFEGLOBAL_typeEXT;
7116       bt = ffesymbol_basictype (fn);
7117       kt = ffesymbol_kindtype (fn);
7118       if (bt == FFEINFO_basictypeNONE)
7119         {
7120           ffeimplic_establish_symbol (fn);
7121           if (ffesymbol_funcresult (fn) != NULL)
7122             ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
7123           bt = ffesymbol_basictype (fn);
7124           kt = ffesymbol_kindtype (fn);
7125         }
7126
7127       if (multi)
7128         charfunc = cmplxfunc = FALSE;
7129       else if (bt == FFEINFO_basictypeCHARACTER)
7130         charfunc = TRUE, cmplxfunc = FALSE;
7131       else if ((bt == FFEINFO_basictypeCOMPLEX)
7132                && ffesymbol_is_f2c (fn)
7133                && !altentries)
7134         charfunc = FALSE, cmplxfunc = TRUE;
7135       else
7136         charfunc = cmplxfunc = FALSE;
7137
7138       if (multi || charfunc)
7139         type = ffecom_tree_fun_type_void;
7140       else if (ffesymbol_is_f2c (fn) && !altentries)
7141         type = ffecom_tree_fun_type[bt][kt];
7142       else
7143         type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
7144
7145       if ((type == NULL_TREE)
7146           || (TREE_TYPE (type) == NULL_TREE))
7147         type = ffecom_tree_fun_type_void;       /* _sym_exec_transition. */
7148       break;
7149
7150     case FFEINFO_kindSUBROUTINE:
7151       gt = FFEGLOBAL_typeSUBR;
7152       egt = FFEGLOBAL_typeEXT;
7153       bt = FFEINFO_basictypeNONE;
7154       kt = FFEINFO_kindtypeNONE;
7155       if (ffecom_is_altreturning_)
7156         type = ffecom_tree_subr_type;
7157       else
7158         type = ffecom_tree_fun_type_void;
7159       charfunc = FALSE;
7160       cmplxfunc = FALSE;
7161       break;
7162
7163     default:
7164       assert ("say what??" == NULL);
7165       /* Fall through. */
7166     case FFEINFO_kindANY:
7167       gt = FFEGLOBAL_typeANY;
7168       bt = FFEINFO_basictypeNONE;
7169       kt = FFEINFO_kindtypeNONE;
7170       type = error_mark_node;
7171       charfunc = FALSE;
7172       cmplxfunc = FALSE;
7173       break;
7174     }
7175
7176   if (altentries)
7177     {
7178       id = ffecom_get_invented_identifier ("__g77_masterfun_%s",
7179                                            ffesymbol_text (fn));
7180     }
7181 #if FFETARGET_isENFORCED_MAIN
7182   else if (main_program)
7183     id = get_identifier (FFETARGET_nameENFORCED_MAIN_NAME);
7184 #endif
7185   else
7186     id = ffecom_get_external_identifier_ (fn);
7187
7188   start_function (id,
7189                   type,
7190                   0,            /* nested/inline */
7191                   !altentries); /* TREE_PUBLIC */
7192
7193   TREE_USED (current_function_decl) = 1;        /* Avoid spurious warning if altentries. */
7194
7195   if (!altentries
7196       && ((g = ffesymbol_global (fn)) != NULL)
7197       && ((ffeglobal_type (g) == gt)
7198           || (ffeglobal_type (g) == egt)))
7199     {
7200       ffeglobal_set_hook (g, current_function_decl);
7201     }
7202
7203   /* Arg handling needs exec-transitioned ffesymbols to work with.  But
7204      exec-transitioning needs current_function_decl to be filled in.  So we
7205      do these things in two phases. */
7206
7207   if (altentries)
7208     {                           /* 1st arg identifies which entrypoint. */
7209       ffecom_which_entrypoint_decl_
7210         = build_decl (PARM_DECL,
7211                       ffecom_get_invented_identifier ("__g77_%s",
7212                                                       "which_entrypoint"),
7213                       integer_type_node);
7214       push_parm_decl (ffecom_which_entrypoint_decl_);
7215     }
7216
7217   if (charfunc
7218       || cmplxfunc
7219       || multi)
7220     {                           /* Arg for result (return value). */
7221       tree type;
7222       tree length;
7223
7224       if (charfunc)
7225         type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
7226       else if (cmplxfunc)
7227         type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
7228       else
7229         type = ffecom_multi_type_node_;
7230
7231       result = ffecom_get_invented_identifier ("__g77_%s", "result");
7232
7233       /* Make length arg _and_ enhance type info for CHAR arg itself.  */
7234
7235       if (charfunc)
7236         length = ffecom_char_enhance_arg_ (&type, fn);
7237       else
7238         length = NULL_TREE;     /* Not ref'd if !charfunc. */
7239
7240       type = build_pointer_type (type);
7241       result = build_decl (PARM_DECL, result, type);
7242
7243       push_parm_decl (result);
7244       if (multi)
7245         ffecom_multi_retval_ = result;
7246       else
7247         ffecom_func_result_ = result;
7248
7249       if (charfunc)
7250         {
7251           push_parm_decl (length);
7252           ffecom_func_length_ = length;
7253         }
7254     }
7255
7256   if (ffecom_primary_entry_is_proc_)
7257     {
7258       if (altentries)
7259         arglist = ffecom_master_arglist_;
7260       else
7261         arglist = ffesymbol_dummyargs (fn);
7262       ffecom_push_dummy_decls_ (arglist, FALSE);
7263     }
7264
7265   if (TREE_CODE (current_function_decl) != ERROR_MARK)
7266     store_parm_decls (main_program ? 1 : 0);
7267
7268   ffecom_start_compstmt ();
7269   /* Disallow temp vars at this level.  */
7270   current_binding_level->prep_state = 2;
7271
7272   lineno = old_lineno;
7273   input_filename = old_input_filename;
7274
7275   /* This handles any symbols still untransformed, in case -g specified.
7276      This used to be done in ffecom_finish_progunit, but it turns out to
7277      be necessary to do it here so that statement functions are
7278      expanded before code.  But don't bother for BLOCK DATA.  */
7279
7280   if (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
7281     ffesymbol_drive (ffecom_finish_symbol_transform_);
7282 }
7283
7284 /* ffecom_sym_transform_ -- Transform FFE sym into backend sym
7285
7286    ffesymbol s;
7287    ffecom_sym_transform_(s);
7288
7289    The ffesymbol_hook info for s is updated with appropriate backend info
7290    on the symbol.  */
7291
7292 static ffesymbol
7293 ffecom_sym_transform_ (ffesymbol s)
7294 {
7295   tree t;                       /* Transformed thingy. */
7296   tree tlen;                    /* Length if CHAR*(*). */
7297   bool addr;                    /* Is t the address of the thingy? */
7298   ffeinfoBasictype bt;
7299   ffeinfoKindtype kt;
7300   ffeglobal g;
7301   int old_lineno = lineno;
7302   const char *old_input_filename = input_filename;
7303
7304   /* Must ensure special ASSIGN variables are declared at top of outermost
7305      block, else they'll end up in the innermost block when their first
7306      ASSIGN is seen, which leaves them out of scope when they're the
7307      subject of a GOTO or I/O statement.
7308
7309      We make this variable even if -fugly-assign.  Just let it go unused,
7310      in case it turns out there are cases where we really want to use this
7311      variable anyway (e.g. ASSIGN to INTEGER*2 variable).  */
7312
7313   if (! ffecom_transform_only_dummies_
7314       && ffesymbol_assigned (s)
7315       && ! ffesymbol_hook (s).assign_tree)
7316     s = ffecom_sym_transform_assign_ (s);
7317
7318   if (ffesymbol_sfdummyparent (s) == NULL)
7319     {
7320       input_filename = ffesymbol_where_filename (s);
7321       lineno = ffesymbol_where_filelinenum (s);
7322     }
7323   else
7324     {
7325       ffesymbol sf = ffesymbol_sfdummyparent (s);
7326
7327       input_filename = ffesymbol_where_filename (sf);
7328       lineno = ffesymbol_where_filelinenum (sf);
7329     }
7330
7331   bt = ffeinfo_basictype (ffebld_info (s));
7332   kt = ffeinfo_kindtype (ffebld_info (s));
7333
7334   t = NULL_TREE;
7335   tlen = NULL_TREE;
7336   addr = FALSE;
7337
7338   switch (ffesymbol_kind (s))
7339     {
7340     case FFEINFO_kindNONE:
7341       switch (ffesymbol_where (s))
7342         {
7343         case FFEINFO_whereDUMMY:        /* Subroutine or function. */
7344           assert (ffecom_transform_only_dummies_);
7345
7346           /* Before 0.4, this could be ENTITY/DUMMY, but see
7347              ffestu_sym_end_transition -- no longer true (in particular, if
7348              it could be an ENTITY, it _will_ be made one, so that
7349              possibility won't come through here).  So we never make length
7350              arg for CHARACTER type.  */
7351
7352           t = build_decl (PARM_DECL,
7353                           ffecom_get_identifier_ (ffesymbol_text (s)),
7354                           ffecom_tree_ptr_to_subr_type);
7355           DECL_ARTIFICIAL (t) = 1;
7356           addr = TRUE;
7357           break;
7358
7359         case FFEINFO_whereGLOBAL:       /* Subroutine or function. */
7360           assert (!ffecom_transform_only_dummies_);
7361
7362           if (((g = ffesymbol_global (s)) != NULL)
7363               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7364                   || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7365                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
7366               && (ffeglobal_hook (g) != NULL_TREE)
7367               && ffe_is_globals ())
7368             {
7369               t = ffeglobal_hook (g);
7370               break;
7371             }
7372
7373           t = build_decl (FUNCTION_DECL,
7374                           ffecom_get_external_identifier_ (s),
7375                           ffecom_tree_subr_type);       /* Assume subr. */
7376           DECL_EXTERNAL (t) = 1;
7377           TREE_PUBLIC (t) = 1;
7378
7379           t = start_decl (t, FALSE);
7380           finish_decl (t, NULL_TREE, FALSE);
7381
7382           if ((g != NULL)
7383               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7384                   || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7385                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
7386             ffeglobal_set_hook (g, t);
7387
7388           ffecom_save_tree_forever (t);
7389
7390           break;
7391
7392         default:
7393           assert ("NONE where unexpected" == NULL);
7394           /* Fall through. */
7395         case FFEINFO_whereANY:
7396           break;
7397         }
7398       break;
7399
7400     case FFEINFO_kindENTITY:
7401       switch (ffeinfo_where (ffesymbol_info (s)))
7402         {
7403
7404         case FFEINFO_whereCONSTANT:
7405           /* ~~Debugging info needed? */
7406           assert (!ffecom_transform_only_dummies_);
7407           t = error_mark_node;  /* Shouldn't ever see this in expr. */
7408           break;
7409
7410         case FFEINFO_whereLOCAL:
7411           assert (!ffecom_transform_only_dummies_);
7412
7413           {
7414             ffestorag st = ffesymbol_storage (s);
7415             tree type;
7416
7417             if ((st != NULL)
7418                 && (ffestorag_size (st) == 0))
7419               {
7420                 t = error_mark_node;
7421                 break;
7422               }
7423
7424             type = ffecom_type_localvar_ (s, bt, kt);
7425
7426             if (type == error_mark_node)
7427               {
7428                 t = error_mark_node;
7429                 break;
7430               }
7431
7432             if ((st != NULL)
7433                 && (ffestorag_parent (st) != NULL))
7434               {                 /* Child of EQUIVALENCE parent. */
7435                 ffestorag est;
7436                 tree et;
7437                 ffetargetOffset offset;
7438
7439                 est = ffestorag_parent (st);
7440                 ffecom_transform_equiv_ (est);
7441
7442                 et = ffestorag_hook (est);
7443                 assert (et != NULL_TREE);
7444
7445                 if (! TREE_STATIC (et))
7446                   put_var_into_stack (et, /*rescan=*/true);
7447
7448                 offset = ffestorag_modulo (est)
7449                   + ffestorag_offset (ffesymbol_storage (s))
7450                   - ffestorag_offset (est);
7451
7452                 ffecom_debug_kludge_ (et, "EQUIVALENCE", s, type, offset);
7453
7454                 /* (t_type *) (((char *) &et) + offset) */
7455
7456                 t = convert (string_type_node,  /* (char *) */
7457                              ffecom_1 (ADDR_EXPR,
7458                                        build_pointer_type (TREE_TYPE (et)),
7459                                        et));
7460                 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
7461                               t,
7462                               build_int_2 (offset, 0));
7463                 t = convert (build_pointer_type (type),
7464                              t);
7465                 TREE_CONSTANT (t) = staticp (et);
7466
7467                 addr = TRUE;
7468               }
7469             else
7470               {
7471                 tree initexpr;
7472                 bool init = ffesymbol_is_init (s);
7473
7474                 t = build_decl (VAR_DECL,
7475                                 ffecom_get_identifier_ (ffesymbol_text (s)),
7476                                 type);
7477
7478                 if (init
7479                     || ffesymbol_namelisted (s)
7480 #ifdef FFECOM_sizeMAXSTACKITEM
7481                     || ((st != NULL)
7482                         && (ffestorag_size (st) > FFECOM_sizeMAXSTACKITEM))
7483 #endif
7484                     || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
7485                         && (ffecom_primary_entry_kind_
7486                             != FFEINFO_kindBLOCKDATA)
7487                         && (ffesymbol_is_save (s) || ffe_is_saveall ())))
7488                   TREE_STATIC (t) = !ffesymbol_attr (s, FFESYMBOL_attrADJUSTABLE);
7489                 else
7490                   TREE_STATIC (t) = 0;  /* No need to make static. */
7491
7492                 if (init || ffe_is_init_local_zero ())
7493                   DECL_INITIAL (t) = error_mark_node;
7494
7495                 /* Keep -Wunused from complaining about var if it
7496                    is used as sfunc arg or DATA implied-DO.  */
7497                 if (ffesymbol_attrs (s) & FFESYMBOL_attrsSFARG)
7498                   DECL_IN_SYSTEM_HEADER (t) = 1;
7499
7500                 t = start_decl (t, FALSE);
7501
7502                 if (init)
7503                   {
7504                     if (ffesymbol_init (s) != NULL)
7505                       initexpr = ffecom_expr (ffesymbol_init (s));
7506                     else
7507                       initexpr = ffecom_init_zero_ (t);
7508                   }
7509                 else if (ffe_is_init_local_zero ())
7510                   initexpr = ffecom_init_zero_ (t);
7511                 else
7512                   initexpr = NULL_TREE; /* Not ref'd if !init. */
7513
7514                 finish_decl (t, initexpr, FALSE);
7515
7516                 if (st != NULL && DECL_SIZE (t) != error_mark_node)
7517                   {
7518                     assert (TREE_CODE (DECL_SIZE_UNIT (t)) == INTEGER_CST);
7519                     assert (0 == compare_tree_int (DECL_SIZE_UNIT (t),
7520                                                    ffestorag_size (st)));
7521                   }
7522               }
7523           }
7524           break;
7525
7526         case FFEINFO_whereRESULT:
7527           assert (!ffecom_transform_only_dummies_);
7528
7529           if (bt == FFEINFO_basictypeCHARACTER)
7530             {                   /* Result is already in list of dummies, use
7531                                    it (& length). */
7532               t = ffecom_func_result_;
7533               tlen = ffecom_func_length_;
7534               addr = TRUE;
7535               break;
7536             }
7537           if ((ffecom_num_entrypoints_ == 0)
7538               && (bt == FFEINFO_basictypeCOMPLEX)
7539               && (ffesymbol_is_f2c (ffecom_primary_entry_)))
7540             {                   /* Result is already in list of dummies, use
7541                                    it. */
7542               t = ffecom_func_result_;
7543               addr = TRUE;
7544               break;
7545             }
7546           if (ffecom_func_result_ != NULL_TREE)
7547             {
7548               t = ffecom_func_result_;
7549               break;
7550             }
7551           if ((ffecom_num_entrypoints_ != 0)
7552               && (ffecom_master_bt_ == FFEINFO_basictypeNONE))
7553             {
7554               assert (ffecom_multi_retval_ != NULL_TREE);
7555               t = ffecom_1 (INDIRECT_REF, ffecom_multi_type_node_,
7556                             ffecom_multi_retval_);
7557               t = ffecom_2 (COMPONENT_REF, ffecom_tree_type[bt][kt],
7558                             t, ffecom_multi_fields_[bt][kt]);
7559
7560               break;
7561             }
7562
7563           t = build_decl (VAR_DECL,
7564                           ffecom_get_identifier_ (ffesymbol_text (s)),
7565                           ffecom_tree_type[bt][kt]);
7566           TREE_STATIC (t) = 0;  /* Put result on stack. */
7567           t = start_decl (t, FALSE);
7568           finish_decl (t, NULL_TREE, FALSE);
7569
7570           ffecom_func_result_ = t;
7571
7572           break;
7573
7574         case FFEINFO_whereDUMMY:
7575           {
7576             tree type;
7577             ffebld dl;
7578             ffebld dim;
7579             tree low;
7580             tree high;
7581             tree old_sizes;
7582             bool adjustable = FALSE;    /* Conditionally adjustable? */
7583
7584             type = ffecom_tree_type[bt][kt];
7585             if (ffesymbol_sfdummyparent (s) != NULL)
7586               {
7587                 if (current_function_decl == ffecom_outer_function_decl_)
7588                   {                     /* Exec transition before sfunc
7589                                            context; get it later. */
7590                     break;
7591                   }
7592                 t = ffecom_get_identifier_ (ffesymbol_text
7593                                             (ffesymbol_sfdummyparent (s)));
7594               }
7595             else
7596               t = ffecom_get_identifier_ (ffesymbol_text (s));
7597
7598             assert (ffecom_transform_only_dummies_);
7599
7600             old_sizes = get_pending_sizes ();
7601             put_pending_sizes (old_sizes);
7602
7603             if (bt == FFEINFO_basictypeCHARACTER)
7604               tlen = ffecom_char_enhance_arg_ (&type, s);
7605             type = ffecom_check_size_overflow_ (s, type, TRUE);
7606
7607             for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
7608               {
7609                 if (type == error_mark_node)
7610                   break;
7611
7612                 dim = ffebld_head (dl);
7613                 assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
7614                 if ((ffebld_left (dim) == NULL) || ffecom_doing_entry_)
7615                   low = ffecom_integer_one_node;
7616                 else
7617                   low = ffecom_expr (ffebld_left (dim));
7618                 assert (ffebld_right (dim) != NULL);
7619                 if ((ffebld_op (ffebld_right (dim)) == FFEBLD_opSTAR)
7620                     || ffecom_doing_entry_)
7621                   {
7622                     /* Used to just do high=low.  But for ffecom_tree_
7623                        canonize_ref_, it probably is important to correctly
7624                        assess the size.  E.g. given COMPLEX C(*),CFUNC and
7625                        C(2)=CFUNC(C), overlap can happen, while it can't
7626                        for, say, C(1)=CFUNC(C(2)).  */
7627                     /* Even more recently used to set to INT_MAX, but that
7628                        broke when some overflow checking went into the back
7629                        end.  Now we just leave the upper bound unspecified.  */
7630                     high = NULL;
7631                   }
7632                 else
7633                   high = ffecom_expr (ffebld_right (dim));
7634
7635                 /* Determine whether array is conditionally adjustable,
7636                    to decide whether back-end magic is needed.
7637
7638                    Normally the front end uses the back-end function
7639                    variable_size to wrap SAVE_EXPR's around expressions
7640                    affecting the size/shape of an array so that the
7641                    size/shape info doesn't change during execution
7642                    of the compiled code even though variables and
7643                    functions referenced in those expressions might.
7644
7645                    variable_size also makes sure those saved expressions
7646                    get evaluated immediately upon entry to the
7647                    compiled procedure -- the front end normally doesn't
7648                    have to worry about that.
7649
7650                    However, there is a problem with this that affects
7651                    g77's implementation of entry points, and that is
7652                    that it is _not_ true that each invocation of the
7653                    compiled procedure is permitted to evaluate
7654                    array size/shape info -- because it is possible
7655                    that, for some invocations, that info is invalid (in
7656                    which case it is "promised" -- i.e. a violation of
7657                    the Fortran standard -- that the compiled code
7658                    won't reference the array or its size/shape
7659                    during that particular invocation).
7660
7661                    To phrase this in C terms, consider this gcc function:
7662
7663                      void foo (int *n, float (*a)[*n])
7664                      {
7665                        // a is "pointer to array ...", fyi.
7666                      }
7667
7668                    Suppose that, for some invocations, it is permitted
7669                    for a caller of foo to do this:
7670
7671                        foo (NULL, NULL);
7672
7673                    Now the _written_ code for foo can take such a call
7674                    into account by either testing explicitly for whether
7675                    (a == NULL) || (n == NULL) -- presumably it is
7676                    not permitted to reference *a in various fashions
7677                    if (n == NULL) I suppose -- or it can avoid it by
7678                    looking at other info (other arguments, static/global
7679                    data, etc.).
7680
7681                    However, this won't work in gcc 2.5.8 because it'll
7682                    automatically emit the code to save the "*n"
7683                    expression, which'll yield a NULL dereference for
7684                    the "foo (NULL, NULL)" call, something the code
7685                    for foo cannot prevent.
7686
7687                    g77 definitely needs to avoid executing such
7688                    code anytime the pointer to the adjustable array
7689                    is NULL, because even if its bounds expressions
7690                    don't have any references to possible "absent"
7691                    variables like "*n" -- say all variable references
7692                    are to COMMON variables, i.e. global (though in C,
7693                    local static could actually make sense) -- the
7694                    expressions could yield other run-time problems
7695                    for allowably "dead" values in those variables.
7696
7697                    For example, let's consider a more complicated
7698                    version of foo:
7699
7700                      extern int i;
7701                      extern int j;
7702
7703                      void foo (float (*a)[i/j])
7704                      {
7705                        ...
7706                      }
7707
7708                    The above is (essentially) quite valid for Fortran
7709                    but, again, for a call like "foo (NULL);", it is
7710                    permitted for i and j to be undefined when the
7711                    call is made.  If j happened to be zero, for
7712                    example, emitting the code to evaluate "i/j"
7713                    could result in a run-time error.
7714
7715                    Offhand, though I don't have my F77 or F90
7716                    standards handy, it might even be valid for a
7717                    bounds expression to contain a function reference,
7718                    in which case I doubt it is permitted for an
7719                    implementation to invoke that function in the
7720                    Fortran case involved here (invocation of an
7721                    alternate ENTRY point that doesn't have the adjustable
7722                    array as one of its arguments).
7723
7724                    So, the code that the compiler would normally emit
7725                    to preevaluate the size/shape info for an
7726                    adjustable array _must not_ be executed at run time
7727                    in certain cases.  Specifically, for Fortran,
7728                    the case is when the pointer to the adjustable
7729                    array == NULL.  (For gnu-ish C, it might be nice
7730                    for the source code itself to specify an expression
7731                    that, if TRUE, inhibits execution of the code.  Or
7732                    reverse the sense for elegance.)
7733
7734                    (Note that g77 could use a different test than NULL,
7735                    actually, since it happens to always pass an
7736                    integer to the called function that specifies which
7737                    entry point is being invoked.  Hmm, this might
7738                    solve the next problem.)
7739
7740                    One way a user could, I suppose, write "foo" so
7741                    it works is to insert COND_EXPR's for the
7742                    size/shape info so the dangerous stuff isn't
7743                    actually done, as in:
7744
7745                      void foo (int *n, float (*a)[(a == NULL) ? 0 : *n])
7746                      {
7747                        ...
7748                      }
7749
7750                    The next problem is that the front end needs to
7751                    be able to tell the back end about the array's
7752                    decl _before_ it tells it about the conditional
7753                    expression to inhibit evaluation of size/shape info,
7754                    as shown above.
7755
7756                    To solve this, the front end needs to be able
7757                    to give the back end the expression to inhibit
7758                    generation of the preevaluation code _after_
7759                    it makes the decl for the adjustable array.
7760
7761                    Until then, the above example using the COND_EXPR
7762                    doesn't pass muster with gcc because the "(a == NULL)"
7763                    part has a reference to "a", which is still
7764                    undefined at that point.
7765
7766                    g77 will therefore use a different mechanism in the
7767                    meantime.  */
7768
7769                 if (!adjustable
7770                     && ((TREE_CODE (low) != INTEGER_CST)
7771                         || (high && TREE_CODE (high) != INTEGER_CST)))
7772                   adjustable = TRUE;
7773
7774 #if 0                           /* Old approach -- see below. */
7775                 if (TREE_CODE (low) != INTEGER_CST)
7776                   low = ffecom_3 (COND_EXPR, integer_type_node,
7777                                   ffecom_adjarray_passed_ (s),
7778                                   low,
7779                                   ffecom_integer_zero_node);
7780
7781                 if (high && TREE_CODE (high) != INTEGER_CST)
7782                   high = ffecom_3 (COND_EXPR, integer_type_node,
7783                                    ffecom_adjarray_passed_ (s),
7784                                    high,
7785                                    ffecom_integer_zero_node);
7786 #endif
7787
7788                 /* ~~~gcc/stor-layout.c (layout_type) should do this,
7789                    probably.  Fixes 950302-1.f.  */
7790
7791                 if (TREE_CODE (low) != INTEGER_CST)
7792                   low = variable_size (low);
7793
7794                 /* ~~~Similarly, this fixes dumb0.f.  The C front end
7795                    does this, which is why dumb0.c would work.  */
7796
7797                 if (high && TREE_CODE (high) != INTEGER_CST)
7798                   high = variable_size (high);
7799
7800                 type
7801                   = build_array_type
7802                     (type,
7803                      build_range_type (ffecom_integer_type_node,
7804                                        low, high));
7805                 type = ffecom_check_size_overflow_ (s, type, TRUE);
7806               }
7807
7808             if (type == error_mark_node)
7809               {
7810                 t = error_mark_node;
7811                 break;
7812               }
7813
7814             if ((ffesymbol_sfdummyparent (s) == NULL)
7815                  || (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER))
7816               {
7817                 type = build_pointer_type (type);
7818                 addr = TRUE;
7819               }
7820
7821             t = build_decl (PARM_DECL, t, type);
7822             DECL_ARTIFICIAL (t) = 1;
7823
7824             /* If this arg is present in every entry point's list of
7825                dummy args, then we're done.  */
7826
7827             if (ffesymbol_numentries (s)
7828                 == (ffecom_num_entrypoints_ + 1))
7829               break;
7830
7831 #if 1
7832
7833             /* If variable_size in stor-layout has been called during
7834                the above, then get_pending_sizes should have the
7835                yet-to-be-evaluated saved expressions pending.
7836                Make the whole lot of them get emitted, conditionally
7837                on whether the array decl ("t" above) is not NULL.  */
7838
7839             {
7840               tree sizes = get_pending_sizes ();
7841               tree tem;
7842
7843               for (tem = sizes;
7844                    tem != old_sizes;
7845                    tem = TREE_CHAIN (tem))
7846                 {
7847                   tree temv = TREE_VALUE (tem);
7848
7849                   if (sizes == tem)
7850                     sizes = temv;
7851                   else
7852                     sizes
7853                       = ffecom_2 (COMPOUND_EXPR,
7854                                   TREE_TYPE (sizes),
7855                                   temv,
7856                                   sizes);
7857                 }
7858
7859               if (sizes != tem)
7860                 {
7861                   sizes
7862                     = ffecom_3 (COND_EXPR,
7863                                 TREE_TYPE (sizes),
7864                                 ffecom_2 (NE_EXPR,
7865                                           integer_type_node,
7866                                           t,
7867                                           null_pointer_node),
7868                                 sizes,
7869                                 convert (TREE_TYPE (sizes),
7870                                          integer_zero_node));
7871                   sizes = ffecom_save_tree (sizes);
7872
7873                   sizes
7874                     = tree_cons (NULL_TREE, sizes, tem);
7875                 }
7876
7877               if (sizes)
7878                 put_pending_sizes (sizes);
7879             }
7880
7881 #else
7882 #if 0
7883             if (adjustable
7884                 && (ffesymbol_numentries (s)
7885                     != ffecom_num_entrypoints_ + 1))
7886               DECL_SOMETHING (t)
7887                 = ffecom_2 (NE_EXPR, integer_type_node,
7888                             t,
7889                             null_pointer_node);
7890 #else
7891 #if 0
7892             if (adjustable
7893                 && (ffesymbol_numentries (s)
7894                     != ffecom_num_entrypoints_ + 1))
7895               {
7896                 ffebad_start (FFEBAD_MISSING_ADJARRAY_UNSUPPORTED);
7897                 ffebad_here (0, ffesymbol_where_line (s),
7898                              ffesymbol_where_column (s));
7899                 ffebad_string (ffesymbol_text (s));
7900                 ffebad_finish ();
7901               }
7902 #endif
7903 #endif
7904 #endif
7905           }
7906           break;
7907
7908         case FFEINFO_whereCOMMON:
7909           {
7910             ffesymbol cs;
7911             ffeglobal cg;
7912             tree ct;
7913             ffestorag st = ffesymbol_storage (s);
7914             tree type;
7915
7916             cs = ffesymbol_common (s);  /* The COMMON area itself.  */
7917             if (st != NULL)     /* Else not laid out. */
7918               {
7919                 ffecom_transform_common_ (cs);
7920                 st = ffesymbol_storage (s);
7921               }
7922
7923             type = ffecom_type_localvar_ (s, bt, kt);
7924
7925             cg = ffesymbol_global (cs); /* The global COMMON info.  */
7926             if ((cg == NULL)
7927                 || (ffeglobal_type (cg) != FFEGLOBAL_typeCOMMON))
7928               ct = NULL_TREE;
7929             else
7930               ct = ffeglobal_hook (cg); /* The common area's tree.  */
7931
7932             if ((ct == NULL_TREE)
7933                 || (st == NULL)
7934                 || (type == error_mark_node))
7935               t = error_mark_node;
7936             else
7937               {
7938                 ffetargetOffset offset;
7939                 ffestorag cst;
7940
7941                 cst = ffestorag_parent (st);
7942                 assert (cst == ffesymbol_storage (cs));
7943
7944                 offset = ffestorag_modulo (cst)
7945                   + ffestorag_offset (st)
7946                   - ffestorag_offset (cst);
7947
7948                 ffecom_debug_kludge_ (ct, "COMMON", s, type, offset);
7949
7950                 /* (t_type *) (((char *) &ct) + offset) */
7951
7952                 t = convert (string_type_node,  /* (char *) */
7953                              ffecom_1 (ADDR_EXPR,
7954                                        build_pointer_type (TREE_TYPE (ct)),
7955                                        ct));
7956                 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
7957                               t,
7958                               build_int_2 (offset, 0));
7959                 t = convert (build_pointer_type (type),
7960                              t);
7961                 TREE_CONSTANT (t) = 1;
7962
7963                 addr = TRUE;
7964               }
7965           }
7966           break;
7967
7968         case FFEINFO_whereIMMEDIATE:
7969         case FFEINFO_whereGLOBAL:
7970         case FFEINFO_whereFLEETING:
7971         case FFEINFO_whereFLEETING_CADDR:
7972         case FFEINFO_whereFLEETING_IADDR:
7973         case FFEINFO_whereINTRINSIC:
7974         case FFEINFO_whereCONSTANT_SUBOBJECT:
7975         default:
7976           assert ("ENTITY where unheard of" == NULL);
7977           /* Fall through. */
7978         case FFEINFO_whereANY:
7979           t = error_mark_node;
7980           break;
7981         }
7982       break;
7983
7984     case FFEINFO_kindFUNCTION:
7985       switch (ffeinfo_where (ffesymbol_info (s)))
7986         {
7987         case FFEINFO_whereLOCAL:        /* Me. */
7988           assert (!ffecom_transform_only_dummies_);
7989           t = current_function_decl;
7990           break;
7991
7992         case FFEINFO_whereGLOBAL:
7993           assert (!ffecom_transform_only_dummies_);
7994
7995           if (((g = ffesymbol_global (s)) != NULL)
7996               && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7997                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
7998               && (ffeglobal_hook (g) != NULL_TREE)
7999               && ffe_is_globals ())
8000             {
8001               t = ffeglobal_hook (g);
8002               break;
8003             }
8004
8005           if (ffesymbol_is_f2c (s)
8006               && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8007             t = ffecom_tree_fun_type[bt][kt];
8008           else
8009             t = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
8010
8011           t = build_decl (FUNCTION_DECL,
8012                           ffecom_get_external_identifier_ (s),
8013                           t);
8014           DECL_EXTERNAL (t) = 1;
8015           TREE_PUBLIC (t) = 1;
8016
8017           t = start_decl (t, FALSE);
8018           finish_decl (t, NULL_TREE, FALSE);
8019
8020           if ((g != NULL)
8021               && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8022                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8023             ffeglobal_set_hook (g, t);
8024
8025           ffecom_save_tree_forever (t);
8026
8027           break;
8028
8029         case FFEINFO_whereDUMMY:
8030           assert (ffecom_transform_only_dummies_);
8031
8032           if (ffesymbol_is_f2c (s)
8033               && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8034             t = ffecom_tree_ptr_to_fun_type[bt][kt];
8035           else
8036             t = build_pointer_type
8037               (build_function_type (ffecom_tree_type[bt][kt], NULL_TREE));
8038
8039           t = build_decl (PARM_DECL,
8040                           ffecom_get_identifier_ (ffesymbol_text (s)),
8041                           t);
8042           DECL_ARTIFICIAL (t) = 1;
8043           addr = TRUE;
8044           break;
8045
8046         case FFEINFO_whereCONSTANT:     /* Statement function. */
8047           assert (!ffecom_transform_only_dummies_);
8048           t = ffecom_gen_sfuncdef_ (s, bt, kt);
8049           break;
8050
8051         case FFEINFO_whereINTRINSIC:
8052           assert (!ffecom_transform_only_dummies_);
8053           break;                /* Let actual references generate their
8054                                    decls. */
8055
8056         default:
8057           assert ("FUNCTION where unheard of" == NULL);
8058           /* Fall through. */
8059         case FFEINFO_whereANY:
8060           t = error_mark_node;
8061           break;
8062         }
8063       break;
8064
8065     case FFEINFO_kindSUBROUTINE:
8066       switch (ffeinfo_where (ffesymbol_info (s)))
8067         {
8068         case FFEINFO_whereLOCAL:        /* Me. */
8069           assert (!ffecom_transform_only_dummies_);
8070           t = current_function_decl;
8071           break;
8072
8073         case FFEINFO_whereGLOBAL:
8074           assert (!ffecom_transform_only_dummies_);
8075
8076           if (((g = ffesymbol_global (s)) != NULL)
8077               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8078                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8079               && (ffeglobal_hook (g) != NULL_TREE)
8080               && ffe_is_globals ())
8081             {
8082               t = ffeglobal_hook (g);
8083               break;
8084             }
8085
8086           t = build_decl (FUNCTION_DECL,
8087                           ffecom_get_external_identifier_ (s),
8088                           ffecom_tree_subr_type);
8089           DECL_EXTERNAL (t) = 1;
8090           TREE_PUBLIC (t) = 1;
8091
8092           t = start_decl (t, FALSE);
8093           finish_decl (t, NULL_TREE, FALSE);
8094
8095           if ((g != NULL)
8096               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8097                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8098             ffeglobal_set_hook (g, t);
8099
8100           ffecom_save_tree_forever (t);
8101
8102           break;
8103
8104         case FFEINFO_whereDUMMY:
8105           assert (ffecom_transform_only_dummies_);
8106
8107           t = build_decl (PARM_DECL,
8108                           ffecom_get_identifier_ (ffesymbol_text (s)),
8109                           ffecom_tree_ptr_to_subr_type);
8110           DECL_ARTIFICIAL (t) = 1;
8111           addr = TRUE;
8112           break;
8113
8114         case FFEINFO_whereINTRINSIC:
8115           assert (!ffecom_transform_only_dummies_);
8116           break;                /* Let actual references generate their
8117                                    decls. */
8118
8119         default:
8120           assert ("SUBROUTINE where unheard of" == NULL);
8121           /* Fall through. */
8122         case FFEINFO_whereANY:
8123           t = error_mark_node;
8124           break;
8125         }
8126       break;
8127
8128     case FFEINFO_kindPROGRAM:
8129       switch (ffeinfo_where (ffesymbol_info (s)))
8130         {
8131         case FFEINFO_whereLOCAL:        /* Me. */
8132           assert (!ffecom_transform_only_dummies_);
8133           t = current_function_decl;
8134           break;
8135
8136         case FFEINFO_whereCOMMON:
8137         case FFEINFO_whereDUMMY:
8138         case FFEINFO_whereGLOBAL:
8139         case FFEINFO_whereRESULT:
8140         case FFEINFO_whereFLEETING:
8141         case FFEINFO_whereFLEETING_CADDR:
8142         case FFEINFO_whereFLEETING_IADDR:
8143         case FFEINFO_whereIMMEDIATE:
8144         case FFEINFO_whereINTRINSIC:
8145         case FFEINFO_whereCONSTANT:
8146         case FFEINFO_whereCONSTANT_SUBOBJECT:
8147         default:
8148           assert ("PROGRAM where unheard of" == NULL);
8149           /* Fall through. */
8150         case FFEINFO_whereANY:
8151           t = error_mark_node;
8152           break;
8153         }
8154       break;
8155
8156     case FFEINFO_kindBLOCKDATA:
8157       switch (ffeinfo_where (ffesymbol_info (s)))
8158         {
8159         case FFEINFO_whereLOCAL:        /* Me. */
8160           assert (!ffecom_transform_only_dummies_);
8161           t = current_function_decl;
8162           break;
8163
8164         case FFEINFO_whereGLOBAL:
8165           assert (!ffecom_transform_only_dummies_);
8166
8167           t = build_decl (FUNCTION_DECL,
8168                           ffecom_get_external_identifier_ (s),
8169                           ffecom_tree_blockdata_type);
8170           DECL_EXTERNAL (t) = 1;
8171           TREE_PUBLIC (t) = 1;
8172
8173           t = start_decl (t, FALSE);
8174           finish_decl (t, NULL_TREE, FALSE);
8175
8176           ffecom_save_tree_forever (t);
8177
8178           break;
8179
8180         case FFEINFO_whereCOMMON:
8181         case FFEINFO_whereDUMMY:
8182         case FFEINFO_whereRESULT:
8183         case FFEINFO_whereFLEETING:
8184         case FFEINFO_whereFLEETING_CADDR:
8185         case FFEINFO_whereFLEETING_IADDR:
8186         case FFEINFO_whereIMMEDIATE:
8187         case FFEINFO_whereINTRINSIC:
8188         case FFEINFO_whereCONSTANT:
8189         case FFEINFO_whereCONSTANT_SUBOBJECT:
8190         default:
8191           assert ("BLOCKDATA where unheard of" == NULL);
8192           /* Fall through. */
8193         case FFEINFO_whereANY:
8194           t = error_mark_node;
8195           break;
8196         }
8197       break;
8198
8199     case FFEINFO_kindCOMMON:
8200       switch (ffeinfo_where (ffesymbol_info (s)))
8201         {
8202         case FFEINFO_whereLOCAL:
8203           assert (!ffecom_transform_only_dummies_);
8204           ffecom_transform_common_ (s);
8205           break;
8206
8207         case FFEINFO_whereNONE:
8208         case FFEINFO_whereCOMMON:
8209         case FFEINFO_whereDUMMY:
8210         case FFEINFO_whereGLOBAL:
8211         case FFEINFO_whereRESULT:
8212         case FFEINFO_whereFLEETING:
8213         case FFEINFO_whereFLEETING_CADDR:
8214         case FFEINFO_whereFLEETING_IADDR:
8215         case FFEINFO_whereIMMEDIATE:
8216         case FFEINFO_whereINTRINSIC:
8217         case FFEINFO_whereCONSTANT:
8218         case FFEINFO_whereCONSTANT_SUBOBJECT:
8219         default:
8220           assert ("COMMON where unheard of" == NULL);
8221           /* Fall through. */
8222         case FFEINFO_whereANY:
8223           t = error_mark_node;
8224           break;
8225         }
8226       break;
8227
8228     case FFEINFO_kindCONSTRUCT:
8229       switch (ffeinfo_where (ffesymbol_info (s)))
8230         {
8231         case FFEINFO_whereLOCAL:
8232           assert (!ffecom_transform_only_dummies_);
8233           break;
8234
8235         case FFEINFO_whereNONE:
8236         case FFEINFO_whereCOMMON:
8237         case FFEINFO_whereDUMMY:
8238         case FFEINFO_whereGLOBAL:
8239         case FFEINFO_whereRESULT:
8240         case FFEINFO_whereFLEETING:
8241         case FFEINFO_whereFLEETING_CADDR:
8242         case FFEINFO_whereFLEETING_IADDR:
8243         case FFEINFO_whereIMMEDIATE:
8244         case FFEINFO_whereINTRINSIC:
8245         case FFEINFO_whereCONSTANT:
8246         case FFEINFO_whereCONSTANT_SUBOBJECT:
8247         default:
8248           assert ("CONSTRUCT where unheard of" == NULL);
8249           /* Fall through. */
8250         case FFEINFO_whereANY:
8251           t = error_mark_node;
8252           break;
8253         }
8254       break;
8255
8256     case FFEINFO_kindNAMELIST:
8257       switch (ffeinfo_where (ffesymbol_info (s)))
8258         {
8259         case FFEINFO_whereLOCAL:
8260           assert (!ffecom_transform_only_dummies_);
8261           t = ffecom_transform_namelist_ (s);
8262           break;
8263
8264         case FFEINFO_whereNONE:
8265         case FFEINFO_whereCOMMON:
8266         case FFEINFO_whereDUMMY:
8267         case FFEINFO_whereGLOBAL:
8268         case FFEINFO_whereRESULT:
8269         case FFEINFO_whereFLEETING:
8270         case FFEINFO_whereFLEETING_CADDR:
8271         case FFEINFO_whereFLEETING_IADDR:
8272         case FFEINFO_whereIMMEDIATE:
8273         case FFEINFO_whereINTRINSIC:
8274         case FFEINFO_whereCONSTANT:
8275         case FFEINFO_whereCONSTANT_SUBOBJECT:
8276         default:
8277           assert ("NAMELIST where unheard of" == NULL);
8278           /* Fall through. */
8279         case FFEINFO_whereANY:
8280           t = error_mark_node;
8281           break;
8282         }
8283       break;
8284
8285     default:
8286       assert ("kind unheard of" == NULL);
8287       /* Fall through. */
8288     case FFEINFO_kindANY:
8289       t = error_mark_node;
8290       break;
8291     }
8292
8293   ffesymbol_hook (s).decl_tree = t;
8294   ffesymbol_hook (s).length_tree = tlen;
8295   ffesymbol_hook (s).addr = addr;
8296
8297   lineno = old_lineno;
8298   input_filename = old_input_filename;
8299
8300   return s;
8301 }
8302
8303 /* Transform into ASSIGNable symbol.
8304
8305    Symbol has already been transformed, but for whatever reason, the
8306    resulting decl_tree has been deemed not usable for an ASSIGN target.
8307    (E.g. it isn't wide enough to hold a pointer.)  So, here we invent
8308    another local symbol of type void * and stuff that in the assign_tree
8309    argument.  The F77/F90 standards allow this implementation.  */
8310
8311 static ffesymbol
8312 ffecom_sym_transform_assign_ (ffesymbol s)
8313 {
8314   tree t;                       /* Transformed thingy. */
8315   int old_lineno = lineno;
8316   const char *old_input_filename = input_filename;
8317
8318   if (ffesymbol_sfdummyparent (s) == NULL)
8319     {
8320       input_filename = ffesymbol_where_filename (s);
8321       lineno = ffesymbol_where_filelinenum (s);
8322     }
8323   else
8324     {
8325       ffesymbol sf = ffesymbol_sfdummyparent (s);
8326
8327       input_filename = ffesymbol_where_filename (sf);
8328       lineno = ffesymbol_where_filelinenum (sf);
8329     }
8330
8331   assert (!ffecom_transform_only_dummies_);
8332
8333   t = build_decl (VAR_DECL,
8334                   ffecom_get_invented_identifier ("__g77_ASSIGN_%s",
8335                                                    ffesymbol_text (s)),
8336                   TREE_TYPE (null_pointer_node));
8337
8338   switch (ffesymbol_where (s))
8339     {
8340     case FFEINFO_whereLOCAL:
8341       /* Unlike for regular vars, SAVE status is easy to determine for
8342          ASSIGNed vars, since there's no initialization, there's no
8343          effective storage association (so "SAVE J" does not apply to
8344          K even given "EQUIVALENCE (J,K)"), there's no size issue
8345          to worry about, etc.  */
8346       if ((ffesymbol_is_save (s) || ffe_is_saveall ())
8347           && (ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8348           && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA))
8349         TREE_STATIC (t) = 1;    /* SAVEd in proc, make static. */
8350       else
8351         TREE_STATIC (t) = 0;    /* No need to make static. */
8352       break;
8353
8354     case FFEINFO_whereCOMMON:
8355       TREE_STATIC (t) = 1;      /* Assume COMMONs always SAVEd. */
8356       break;
8357
8358     case FFEINFO_whereDUMMY:
8359       /* Note that twinning a DUMMY means the caller won't see
8360          the ASSIGNed value.  But both F77 and F90 allow implementations
8361          to do this, i.e. disallow Fortran code that would try and
8362          take advantage of actually putting a label into a variable
8363          via a dummy argument (or any other storage association, for
8364          that matter).  */
8365       TREE_STATIC (t) = 0;
8366       break;
8367
8368     default:
8369       TREE_STATIC (t) = 0;
8370       break;
8371     }
8372
8373   t = start_decl (t, FALSE);
8374   finish_decl (t, NULL_TREE, FALSE);
8375
8376   ffesymbol_hook (s).assign_tree = t;
8377
8378   lineno = old_lineno;
8379   input_filename = old_input_filename;
8380
8381   return s;
8382 }
8383
8384 /* Implement COMMON area in back end.
8385
8386    Because COMMON-based variables can be referenced in the dimension
8387    expressions of dummy (adjustable) arrays, and because dummies
8388    (in the gcc back end) need to be put in the outer binding level
8389    of a function (which has two binding levels, the outer holding
8390    the dummies and the inner holding the other vars), special care
8391    must be taken to handle COMMON areas.
8392
8393    The current strategy is basically to always tell the back end about
8394    the COMMON area as a top-level external reference to just a block
8395    of storage of the master type of that area (e.g. integer, real,
8396    character, whatever -- not a structure).  As a distinct action,
8397    if initial values are provided, tell the back end about the area
8398    as a top-level non-external (initialized) area and remember not to
8399    allow further initialization or expansion of the area.  Meanwhile,
8400    if no initialization happens at all, tell the back end about
8401    the largest size we've seen declared so the space does get reserved.
8402    (This function doesn't handle all that stuff, but it does some
8403    of the important things.)
8404
8405    Meanwhile, for COMMON variables themselves, just keep creating
8406    references like *((float *) (&common_area + offset)) each time
8407    we reference the variable.  In other words, don't make a VAR_DECL
8408    or any kind of component reference (like we used to do before 0.4),
8409    though we might do that as well just for debugging purposes (and
8410    stuff the rtl with the appropriate offset expression).  */
8411
8412 static void
8413 ffecom_transform_common_ (ffesymbol s)
8414 {
8415   ffestorag st = ffesymbol_storage (s);
8416   ffeglobal g = ffesymbol_global (s);
8417   tree cbt;
8418   tree cbtype;
8419   tree init;
8420   tree high;
8421   bool is_init = ffestorag_is_init (st);
8422
8423   assert (st != NULL);
8424
8425   if ((g == NULL)
8426       || (ffeglobal_type (g) != FFEGLOBAL_typeCOMMON))
8427     return;
8428
8429   /* First update the size of the area in global terms.  */
8430
8431   ffeglobal_size_common (s, ffestorag_size (st));
8432
8433   if (!ffeglobal_common_init (g))
8434     is_init = FALSE;    /* No explicit init, don't let erroneous joins init. */
8435
8436   cbt = ffeglobal_hook (g);
8437
8438   /* If we already have declared this common block for a previous program
8439      unit, and either we already initialized it or we don't have new
8440      initialization for it, just return what we have without changing it.  */
8441
8442   if ((cbt != NULL_TREE)
8443       && (!is_init
8444           || !DECL_EXTERNAL (cbt)))
8445     {
8446       if (st->hook == NULL) ffestorag_set_hook (st, cbt);
8447       return;
8448     }
8449
8450   /* Process inits.  */
8451
8452   if (is_init)
8453     {
8454       if (ffestorag_init (st) != NULL)
8455         {
8456           ffebld sexp;
8457
8458           /* Set the padding for the expression, so ffecom_expr
8459              knows to insert that many zeros.  */
8460           switch (ffebld_op (sexp = ffestorag_init (st)))
8461             {
8462             case FFEBLD_opCONTER:
8463               ffebld_conter_set_pad (sexp, ffestorag_modulo (st));
8464               break;
8465
8466             case FFEBLD_opARRTER:
8467               ffebld_arrter_set_pad (sexp, ffestorag_modulo (st));
8468               break;
8469
8470             case FFEBLD_opACCTER:
8471               ffebld_accter_set_pad (sexp, ffestorag_modulo (st));
8472               break;
8473
8474             default:
8475               assert ("bad op for cmn init (pad)" == NULL);
8476               break;
8477             }
8478
8479           init = ffecom_expr (sexp);
8480           if (init == error_mark_node)
8481             {                   /* Hopefully the back end complained! */
8482               init = NULL_TREE;
8483               if (cbt != NULL_TREE)
8484                 return;
8485             }
8486         }
8487       else
8488         init = error_mark_node;
8489     }
8490   else
8491     init = NULL_TREE;
8492
8493   /* cbtype must be permanently allocated!  */
8494
8495   /* Allocate the MAX of the areas so far, seen filewide.  */
8496   high = build_int_2 ((ffeglobal_common_size (g)
8497                        + ffeglobal_common_pad (g)) - 1, 0);
8498   TREE_TYPE (high) = ffecom_integer_type_node;
8499
8500   if (init)
8501     cbtype = build_array_type (char_type_node,
8502                                build_range_type (integer_type_node,
8503                                                  integer_zero_node,
8504                                                  high));
8505   else
8506     cbtype = build_array_type (char_type_node, NULL_TREE);
8507
8508   if (cbt == NULL_TREE)
8509     {
8510       cbt
8511         = build_decl (VAR_DECL,
8512                       ffecom_get_external_identifier_ (s),
8513                       cbtype);
8514       TREE_STATIC (cbt) = 1;
8515       TREE_PUBLIC (cbt) = 1;
8516     }
8517   else
8518     {
8519       assert (is_init);
8520       TREE_TYPE (cbt) = cbtype;
8521     }
8522   DECL_EXTERNAL (cbt) = init ? 0 : 1;
8523   DECL_INITIAL (cbt) = init ? error_mark_node : NULL_TREE;
8524
8525   cbt = start_decl (cbt, TRUE);
8526   if (ffeglobal_hook (g) != NULL)
8527     assert (cbt == ffeglobal_hook (g));
8528
8529   assert (!init || !DECL_EXTERNAL (cbt));
8530
8531   /* Make sure that any type can live in COMMON and be referenced
8532      without getting a bus error.  We could pick the most restrictive
8533      alignment of all entities actually placed in the COMMON, but
8534      this seems easy enough.  */
8535
8536   DECL_ALIGN (cbt) = BIGGEST_ALIGNMENT;
8537   DECL_USER_ALIGN (cbt) = 0;
8538
8539   if (is_init && (ffestorag_init (st) == NULL))
8540     init = ffecom_init_zero_ (cbt);
8541
8542   finish_decl (cbt, init, TRUE);
8543
8544   if (is_init)
8545     ffestorag_set_init (st, ffebld_new_any ());
8546
8547   if (init)
8548     {
8549       assert (DECL_SIZE_UNIT (cbt) != NULL_TREE);
8550       assert (TREE_CODE (DECL_SIZE_UNIT (cbt)) == INTEGER_CST);
8551       assert (0 == compare_tree_int (DECL_SIZE_UNIT (cbt),
8552                                      (ffeglobal_common_size (g)
8553                                       + ffeglobal_common_pad (g))));
8554     }
8555
8556   ffeglobal_set_hook (g, cbt);
8557
8558   ffestorag_set_hook (st, cbt);
8559
8560   ffecom_save_tree_forever (cbt);
8561 }
8562
8563 /* Make master area for local EQUIVALENCE.  */
8564
8565 static void
8566 ffecom_transform_equiv_ (ffestorag eqst)
8567 {
8568   tree eqt;
8569   tree eqtype;
8570   tree init;
8571   tree high;
8572   bool is_init = ffestorag_is_init (eqst);
8573
8574   assert (eqst != NULL);
8575
8576   eqt = ffestorag_hook (eqst);
8577
8578   if (eqt != NULL_TREE)
8579     return;
8580
8581   /* Process inits.  */
8582
8583   if (is_init)
8584     {
8585       if (ffestorag_init (eqst) != NULL)
8586         {
8587           ffebld sexp;
8588
8589           /* Set the padding for the expression, so ffecom_expr
8590              knows to insert that many zeros.  */
8591           switch (ffebld_op (sexp = ffestorag_init (eqst)))
8592             {
8593             case FFEBLD_opCONTER:
8594               ffebld_conter_set_pad (sexp, ffestorag_modulo (eqst));
8595               break;
8596
8597             case FFEBLD_opARRTER:
8598               ffebld_arrter_set_pad (sexp, ffestorag_modulo (eqst));
8599               break;
8600
8601             case FFEBLD_opACCTER:
8602               ffebld_accter_set_pad (sexp, ffestorag_modulo (eqst));
8603               break;
8604
8605             default:
8606               assert ("bad op for eqv init (pad)" == NULL);
8607               break;
8608             }
8609
8610           init = ffecom_expr (sexp);
8611           if (init == error_mark_node)
8612             init = NULL_TREE;   /* Hopefully the back end complained! */
8613         }
8614       else
8615         init = error_mark_node;
8616     }
8617   else if (ffe_is_init_local_zero ())
8618     init = error_mark_node;
8619   else
8620     init = NULL_TREE;
8621
8622   ffecom_member_namelisted_ = FALSE;
8623   ffestorag_drive (ffestorag_list_equivs (eqst),
8624                    &ffecom_member_phase1_,
8625                    eqst);
8626
8627   high = build_int_2 ((ffestorag_size (eqst)
8628                        + ffestorag_modulo (eqst)) - 1, 0);
8629   TREE_TYPE (high) = ffecom_integer_type_node;
8630
8631   eqtype = build_array_type (char_type_node,
8632                              build_range_type (ffecom_integer_type_node,
8633                                                ffecom_integer_zero_node,
8634                                                high));
8635
8636   eqt = build_decl (VAR_DECL,
8637                     ffecom_get_invented_identifier ("__g77_equiv_%s",
8638                                                     ffesymbol_text
8639                                                     (ffestorag_symbol (eqst))),
8640                     eqtype);
8641   DECL_EXTERNAL (eqt) = 0;
8642   if (is_init
8643       || ffecom_member_namelisted_
8644 #ifdef FFECOM_sizeMAXSTACKITEM
8645       || (ffestorag_size (eqst) > FFECOM_sizeMAXSTACKITEM)
8646 #endif
8647       || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8648           && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
8649           && (ffestorag_is_save (eqst) || ffe_is_saveall ())))
8650     TREE_STATIC (eqt) = 1;
8651   else
8652     TREE_STATIC (eqt) = 0;
8653   TREE_PUBLIC (eqt) = 0;
8654   TREE_ADDRESSABLE (eqt) = 1;  /* Ensure non-register allocation */
8655   DECL_CONTEXT (eqt) = current_function_decl;
8656   if (init)
8657     DECL_INITIAL (eqt) = error_mark_node;
8658   else
8659     DECL_INITIAL (eqt) = NULL_TREE;
8660
8661   eqt = start_decl (eqt, FALSE);
8662
8663   /* Make sure that any type can live in EQUIVALENCE and be referenced
8664      without getting a bus error.  We could pick the most restrictive
8665      alignment of all entities actually placed in the EQUIVALENCE, but
8666      this seems easy enough.  */
8667
8668   DECL_ALIGN (eqt) = BIGGEST_ALIGNMENT;
8669   DECL_USER_ALIGN (eqt) = 0;
8670
8671   if ((!is_init && ffe_is_init_local_zero ())
8672       || (is_init && (ffestorag_init (eqst) == NULL)))
8673     init = ffecom_init_zero_ (eqt);
8674
8675   finish_decl (eqt, init, FALSE);
8676
8677   if (is_init)
8678     ffestorag_set_init (eqst, ffebld_new_any ());
8679
8680   {
8681     assert (TREE_CODE (DECL_SIZE_UNIT (eqt)) == INTEGER_CST);
8682     assert (0 == compare_tree_int (DECL_SIZE_UNIT (eqt),
8683                                    (ffestorag_size (eqst)
8684                                     + ffestorag_modulo (eqst))));
8685   }
8686
8687   ffestorag_set_hook (eqst, eqt);
8688
8689   ffestorag_drive (ffestorag_list_equivs (eqst),
8690                    &ffecom_member_phase2_,
8691                    eqst);
8692 }
8693
8694 /* Implement NAMELIST in back end.  See f2c/format.c for more info.  */
8695
8696 static tree
8697 ffecom_transform_namelist_ (ffesymbol s)
8698 {
8699   tree nmlt;
8700   tree nmltype = ffecom_type_namelist_ ();
8701   tree nmlinits;
8702   tree nameinit;
8703   tree varsinit;
8704   tree nvarsinit;
8705   tree field;
8706   tree high;
8707   int i;
8708   static int mynumber = 0;
8709
8710   nmlt = build_decl (VAR_DECL,
8711                      ffecom_get_invented_identifier ("__g77_namelist_%d",
8712                                                      mynumber++),
8713                      nmltype);
8714   TREE_STATIC (nmlt) = 1;
8715   DECL_INITIAL (nmlt) = error_mark_node;
8716
8717   nmlt = start_decl (nmlt, FALSE);
8718
8719   /* Process inits.  */
8720
8721   i = strlen (ffesymbol_text (s));
8722
8723   high = build_int_2 (i, 0);
8724   TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
8725
8726   nameinit = ffecom_build_f2c_string_ (i + 1,
8727                                        ffesymbol_text (s));
8728   TREE_TYPE (nameinit)
8729     = build_type_variant
8730     (build_array_type
8731      (char_type_node,
8732       build_range_type (ffecom_f2c_ftnlen_type_node,
8733                         ffecom_f2c_ftnlen_one_node,
8734                         high)),
8735      1, 0);
8736   TREE_CONSTANT (nameinit) = 1;
8737   TREE_STATIC (nameinit) = 1;
8738   nameinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (nameinit)),
8739                        nameinit);
8740
8741   varsinit = ffecom_vardesc_array_ (s);
8742   varsinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (varsinit)),
8743                        varsinit);
8744   TREE_CONSTANT (varsinit) = 1;
8745   TREE_STATIC (varsinit) = 1;
8746
8747   {
8748     ffebld b;
8749
8750     for (i = 0, b = ffesymbol_namelist (s); b != NULL; b = ffebld_trail (b))
8751       ++i;
8752   }
8753   nvarsinit = build_int_2 (i, 0);
8754   TREE_TYPE (nvarsinit) = integer_type_node;
8755   TREE_CONSTANT (nvarsinit) = 1;
8756   TREE_STATIC (nvarsinit) = 1;
8757
8758   nmlinits = build_tree_list ((field = TYPE_FIELDS (nmltype)), nameinit);
8759   TREE_CHAIN (nmlinits) = build_tree_list ((field = TREE_CHAIN (field)),
8760                                            varsinit);
8761   TREE_CHAIN (TREE_CHAIN (nmlinits))
8762     = build_tree_list ((field = TREE_CHAIN (field)), nvarsinit);
8763
8764   nmlinits = build_constructor (nmltype, nmlinits);
8765   TREE_CONSTANT (nmlinits) = 1;
8766   TREE_STATIC (nmlinits) = 1;
8767
8768   finish_decl (nmlt, nmlinits, FALSE);
8769
8770   nmlt = ffecom_1 (ADDR_EXPR, build_pointer_type (nmltype), nmlt);
8771
8772   return nmlt;
8773 }
8774
8775 /* A subroutine of ffecom_tree_canonize_ref_.  The incoming tree is
8776    analyzed on the assumption it is calculating a pointer to be
8777    indirected through.  It must return the proper decl and offset,
8778    taking into account different units of measurements for offsets.  */
8779
8780 static void
8781 ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
8782                            tree t)
8783 {
8784   switch (TREE_CODE (t))
8785     {
8786     case NOP_EXPR:
8787     case CONVERT_EXPR:
8788     case NON_LVALUE_EXPR:
8789       ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
8790       break;
8791
8792     case PLUS_EXPR:
8793       ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
8794       if ((*decl == NULL_TREE)
8795           || (*decl == error_mark_node))
8796         break;
8797
8798       if (TREE_CODE (TREE_OPERAND (t, 1)) == INTEGER_CST)
8799         {
8800           /* An offset into COMMON.  */
8801           *offset = fold (build (PLUS_EXPR, TREE_TYPE (*offset),
8802                                  *offset, TREE_OPERAND (t, 1)));
8803           /* Convert offset (presumably in bytes) into canonical units
8804              (presumably bits).  */
8805           *offset = size_binop (MULT_EXPR,
8806                                 convert (bitsizetype, *offset),
8807                                 TYPE_SIZE (TREE_TYPE (TREE_TYPE (t))));
8808           break;
8809         }
8810       /* Not a COMMON reference, so an unrecognized pattern.  */
8811       *decl = error_mark_node;
8812       break;
8813
8814     case PARM_DECL:
8815       *decl = t;
8816       *offset = bitsize_zero_node;
8817       break;
8818
8819     case ADDR_EXPR:
8820       if (TREE_CODE (TREE_OPERAND (t, 0)) == VAR_DECL)
8821         {
8822           /* A reference to COMMON.  */
8823           *decl = TREE_OPERAND (t, 0);
8824           *offset = bitsize_zero_node;
8825           break;
8826         }
8827       /* Fall through.  */
8828     default:
8829       /* Not a COMMON reference, so an unrecognized pattern.  */
8830       *decl = error_mark_node;
8831       break;
8832     }
8833 }
8834
8835 /* Given a tree that is possibly intended for use as an lvalue, return
8836    information representing a canonical view of that tree as a decl, an
8837    offset into that decl, and a size for the lvalue.
8838
8839    If there's no applicable decl, NULL_TREE is returned for the decl,
8840    and the other fields are left undefined.
8841
8842    If the tree doesn't fit the recognizable forms, an ERROR_MARK node
8843    is returned for the decl, and the other fields are left undefined.
8844
8845    Otherwise, the decl returned currently is either a VAR_DECL or a
8846    PARM_DECL.
8847
8848    The offset returned is always valid, but of course not necessarily
8849    a constant, and not necessarily converted into the appropriate
8850    type, leaving that up to the caller (so as to avoid that overhead
8851    if the decls being looked at are different anyway).
8852
8853    If the size cannot be determined (e.g. an adjustable array),
8854    an ERROR_MARK node is returned for the size.  Otherwise, the
8855    size returned is valid, not necessarily a constant, and not
8856    necessarily converted into the appropriate type as with the
8857    offset.
8858
8859    Note that the offset and size expressions are expressed in the
8860    base storage units (usually bits) rather than in the units of
8861    the type of the decl, because two decls with different types
8862    might overlap but with apparently non-overlapping array offsets,
8863    whereas converting the array offsets to consistant offsets will
8864    reveal the overlap.  */
8865
8866 static void
8867 ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
8868                            tree *size, tree t)
8869 {
8870   /* The default path is to report a nonexistant decl.  */
8871   *decl = NULL_TREE;
8872
8873   if (t == NULL_TREE)
8874     return;
8875
8876   switch (TREE_CODE (t))
8877     {
8878     case ERROR_MARK:
8879     case IDENTIFIER_NODE:
8880     case INTEGER_CST:
8881     case REAL_CST:
8882     case COMPLEX_CST:
8883     case STRING_CST:
8884     case CONST_DECL:
8885     case PLUS_EXPR:
8886     case MINUS_EXPR:
8887     case MULT_EXPR:
8888     case TRUNC_DIV_EXPR:
8889     case CEIL_DIV_EXPR:
8890     case FLOOR_DIV_EXPR:
8891     case ROUND_DIV_EXPR:
8892     case TRUNC_MOD_EXPR:
8893     case CEIL_MOD_EXPR:
8894     case FLOOR_MOD_EXPR:
8895     case ROUND_MOD_EXPR:
8896     case RDIV_EXPR:
8897     case EXACT_DIV_EXPR:
8898     case FIX_TRUNC_EXPR:
8899     case FIX_CEIL_EXPR:
8900     case FIX_FLOOR_EXPR:
8901     case FIX_ROUND_EXPR:
8902     case FLOAT_EXPR:
8903     case NEGATE_EXPR:
8904     case MIN_EXPR:
8905     case MAX_EXPR:
8906     case ABS_EXPR:
8907     case FFS_EXPR:
8908     case LSHIFT_EXPR:
8909     case RSHIFT_EXPR:
8910     case LROTATE_EXPR:
8911     case RROTATE_EXPR:
8912     case BIT_IOR_EXPR:
8913     case BIT_XOR_EXPR:
8914     case BIT_AND_EXPR:
8915     case BIT_ANDTC_EXPR:
8916     case BIT_NOT_EXPR:
8917     case TRUTH_ANDIF_EXPR:
8918     case TRUTH_ORIF_EXPR:
8919     case TRUTH_AND_EXPR:
8920     case TRUTH_OR_EXPR:
8921     case TRUTH_XOR_EXPR:
8922     case TRUTH_NOT_EXPR:
8923     case LT_EXPR:
8924     case LE_EXPR:
8925     case GT_EXPR:
8926     case GE_EXPR:
8927     case EQ_EXPR:
8928     case NE_EXPR:
8929     case COMPLEX_EXPR:
8930     case CONJ_EXPR:
8931     case REALPART_EXPR:
8932     case IMAGPART_EXPR:
8933     case LABEL_EXPR:
8934     case COMPONENT_REF:
8935     case COMPOUND_EXPR:
8936     case ADDR_EXPR:
8937       return;
8938
8939     case VAR_DECL:
8940     case PARM_DECL:
8941       *decl = t;
8942       *offset = bitsize_zero_node;
8943       *size = TYPE_SIZE (TREE_TYPE (t));
8944       return;
8945
8946     case ARRAY_REF:
8947       {
8948         tree array = TREE_OPERAND (t, 0);
8949         tree element = TREE_OPERAND (t, 1);
8950         tree init_offset;
8951
8952         if ((array == NULL_TREE)
8953             || (element == NULL_TREE))
8954           {
8955             *decl = error_mark_node;
8956             return;
8957           }
8958
8959         ffecom_tree_canonize_ref_ (decl, &init_offset, size,
8960                                    array);
8961         if ((*decl == NULL_TREE)
8962             || (*decl == error_mark_node))
8963           return;
8964
8965         /* Calculate ((element - base) * NBBY) + init_offset.  */
8966         *offset = fold (build (MINUS_EXPR, TREE_TYPE (element),
8967                                element,
8968                                TYPE_MIN_VALUE (TYPE_DOMAIN
8969                                                (TREE_TYPE (array)))));
8970
8971         *offset = size_binop (MULT_EXPR,
8972                               convert (bitsizetype, *offset),
8973                               TYPE_SIZE (TREE_TYPE (TREE_TYPE (array))));
8974
8975         *offset = size_binop (PLUS_EXPR, init_offset, *offset);
8976
8977         *size = TYPE_SIZE (TREE_TYPE (t));
8978         return;
8979       }
8980
8981     case INDIRECT_REF:
8982
8983       /* Most of this code is to handle references to COMMON.  And so
8984          far that is useful only for calling library functions, since
8985          external (user) functions might reference common areas.  But
8986          even calling an external function, it's worthwhile to decode
8987          COMMON references because if not storing into COMMON, we don't
8988          want COMMON-based arguments to gratuitously force use of a
8989          temporary.  */
8990
8991       *size = TYPE_SIZE (TREE_TYPE (t));
8992
8993       ffecom_tree_canonize_ptr_ (decl, offset,
8994                                  TREE_OPERAND (t, 0));
8995
8996       return;
8997
8998     case CONVERT_EXPR:
8999     case NOP_EXPR:
9000     case MODIFY_EXPR:
9001     case NON_LVALUE_EXPR:
9002     case RESULT_DECL:
9003     case FIELD_DECL:
9004     case COND_EXPR:             /* More cases than we can handle. */
9005     case SAVE_EXPR:
9006     case REFERENCE_EXPR:
9007     case PREDECREMENT_EXPR:
9008     case PREINCREMENT_EXPR:
9009     case POSTDECREMENT_EXPR:
9010     case POSTINCREMENT_EXPR:
9011     case CALL_EXPR:
9012     default:
9013       *decl = error_mark_node;
9014       return;
9015     }
9016 }
9017
9018 /* Do divide operation appropriate to type of operands.  */
9019
9020 static tree
9021 ffecom_tree_divide_ (tree tree_type, tree left, tree right,
9022                      tree dest_tree, ffebld dest, bool *dest_used,
9023                      tree hook)
9024 {
9025   if ((left == error_mark_node)
9026       || (right == error_mark_node))
9027     return error_mark_node;
9028
9029   switch (TREE_CODE (tree_type))
9030     {
9031     case INTEGER_TYPE:
9032       return ffecom_2 (TRUNC_DIV_EXPR, tree_type,
9033                        left,
9034                        right);
9035
9036     case COMPLEX_TYPE:
9037       if (! optimize_size)
9038         return ffecom_2 (RDIV_EXPR, tree_type,
9039                          left,
9040                          right);
9041       {
9042         ffecomGfrt ix;
9043
9044         if (TREE_TYPE (tree_type)
9045             == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9046           ix = FFECOM_gfrtDIV_CC;       /* Overlapping result okay. */
9047         else
9048           ix = FFECOM_gfrtDIV_ZZ;       /* Overlapping result okay. */
9049
9050         left = ffecom_1 (ADDR_EXPR,
9051                          build_pointer_type (TREE_TYPE (left)),
9052                          left);
9053         left = build_tree_list (NULL_TREE, left);
9054         right = ffecom_1 (ADDR_EXPR,
9055                           build_pointer_type (TREE_TYPE (right)),
9056                           right);
9057         right = build_tree_list (NULL_TREE, right);
9058         TREE_CHAIN (left) = right;
9059
9060         return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9061                              ffecom_gfrt_kindtype (ix),
9062                              ffe_is_f2c_library (),
9063                              tree_type,
9064                              left,
9065                              dest_tree, dest, dest_used,
9066                              NULL_TREE, TRUE, hook);
9067       }
9068       break;
9069
9070     case RECORD_TYPE:
9071       {
9072         ffecomGfrt ix;
9073
9074         if (TREE_TYPE (TYPE_FIELDS (tree_type))
9075             == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9076           ix = FFECOM_gfrtDIV_CC;       /* Overlapping result okay. */
9077         else
9078           ix = FFECOM_gfrtDIV_ZZ;       /* Overlapping result okay. */
9079
9080         left = ffecom_1 (ADDR_EXPR,
9081                          build_pointer_type (TREE_TYPE (left)),
9082                          left);
9083         left = build_tree_list (NULL_TREE, left);
9084         right = ffecom_1 (ADDR_EXPR,
9085                           build_pointer_type (TREE_TYPE (right)),
9086                           right);
9087         right = build_tree_list (NULL_TREE, right);
9088         TREE_CHAIN (left) = right;
9089
9090         return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9091                              ffecom_gfrt_kindtype (ix),
9092                              ffe_is_f2c_library (),
9093                              tree_type,
9094                              left,
9095                              dest_tree, dest, dest_used,
9096                              NULL_TREE, TRUE, hook);
9097       }
9098       break;
9099
9100     default:
9101       return ffecom_2 (RDIV_EXPR, tree_type,
9102                        left,
9103                        right);
9104     }
9105 }
9106
9107 /* Build type info for non-dummy variable.  */
9108
9109 static tree
9110 ffecom_type_localvar_ (ffesymbol s, ffeinfoBasictype bt,
9111                        ffeinfoKindtype kt)
9112 {
9113   tree type;
9114   ffebld dl;
9115   ffebld dim;
9116   tree lowt;
9117   tree hight;
9118
9119   type = ffecom_tree_type[bt][kt];
9120   if (bt == FFEINFO_basictypeCHARACTER)
9121     {
9122       hight = build_int_2 (ffesymbol_size (s), 0);
9123       TREE_TYPE (hight) = ffecom_f2c_ftnlen_type_node;
9124
9125       type
9126         = build_array_type
9127           (type,
9128            build_range_type (ffecom_f2c_ftnlen_type_node,
9129                              ffecom_f2c_ftnlen_one_node,
9130                              hight));
9131       type = ffecom_check_size_overflow_ (s, type, FALSE);
9132     }
9133
9134   for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
9135     {
9136       if (type == error_mark_node)
9137         break;
9138
9139       dim = ffebld_head (dl);
9140       assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
9141
9142       if (ffebld_left (dim) == NULL)
9143         lowt = integer_one_node;
9144       else
9145         lowt = ffecom_expr (ffebld_left (dim));
9146
9147       if (TREE_CODE (lowt) != INTEGER_CST)
9148         lowt = variable_size (lowt);
9149
9150       assert (ffebld_right (dim) != NULL);
9151       hight = ffecom_expr (ffebld_right (dim));
9152
9153       if (TREE_CODE (hight) != INTEGER_CST)
9154         hight = variable_size (hight);
9155
9156       type = build_array_type (type,
9157                                build_range_type (ffecom_integer_type_node,
9158                                                  lowt, hight));
9159       type = ffecom_check_size_overflow_ (s, type, FALSE);
9160     }
9161
9162   return type;
9163 }
9164
9165 /* Build Namelist type.  */
9166
9167 static GTY(()) tree ffecom_type_namelist_var;
9168 static tree
9169 ffecom_type_namelist_ ()
9170 {
9171   if (ffecom_type_namelist_var == NULL_TREE)
9172     {
9173       tree namefield, varsfield, nvarsfield, vardesctype, type;
9174
9175       vardesctype = ffecom_type_vardesc_ ();
9176
9177       type = make_node (RECORD_TYPE);
9178
9179       vardesctype = build_pointer_type (build_pointer_type (vardesctype));
9180
9181       namefield = ffecom_decl_field (type, NULL_TREE, "name",
9182                                      string_type_node);
9183       varsfield = ffecom_decl_field (type, namefield, "vars", vardesctype);
9184       nvarsfield = ffecom_decl_field (type, varsfield, "nvars",
9185                                       integer_type_node);
9186
9187       TYPE_FIELDS (type) = namefield;
9188       layout_type (type);
9189
9190       ffecom_type_namelist_var = type;
9191     }
9192
9193   return ffecom_type_namelist_var;
9194 }
9195
9196 /* Build Vardesc type.  */
9197
9198 static GTY(()) tree ffecom_type_vardesc_var;
9199 static tree
9200 ffecom_type_vardesc_ ()
9201 {
9202   if (ffecom_type_vardesc_var == NULL_TREE)
9203     {
9204       tree namefield, addrfield, dimsfield, typefield, type;
9205       type = make_node (RECORD_TYPE);
9206
9207       namefield = ffecom_decl_field (type, NULL_TREE, "name",
9208                                      string_type_node);
9209       addrfield = ffecom_decl_field (type, namefield, "addr",
9210                                      string_type_node);
9211       dimsfield = ffecom_decl_field (type, addrfield, "dims",
9212                                      ffecom_f2c_ptr_to_ftnlen_type_node);
9213       typefield = ffecom_decl_field (type, dimsfield, "type",
9214                                      integer_type_node);
9215
9216       TYPE_FIELDS (type) = namefield;
9217       layout_type (type);
9218
9219       ffecom_type_vardesc_var = type;
9220     }
9221
9222   return ffecom_type_vardesc_var;
9223 }
9224
9225 static tree
9226 ffecom_vardesc_ (ffebld expr)
9227 {
9228   ffesymbol s;
9229
9230   assert (ffebld_op (expr) == FFEBLD_opSYMTER);
9231   s = ffebld_symter (expr);
9232
9233   if (ffesymbol_hook (s).vardesc_tree == NULL_TREE)
9234     {
9235       int i;
9236       tree vardesctype = ffecom_type_vardesc_ ();
9237       tree var;
9238       tree nameinit;
9239       tree dimsinit;
9240       tree addrinit;
9241       tree typeinit;
9242       tree field;
9243       tree varinits;
9244       static int mynumber = 0;
9245
9246       var = build_decl (VAR_DECL,
9247                         ffecom_get_invented_identifier ("__g77_vardesc_%d",
9248                                                         mynumber++),
9249                         vardesctype);
9250       TREE_STATIC (var) = 1;
9251       DECL_INITIAL (var) = error_mark_node;
9252
9253       var = start_decl (var, FALSE);
9254
9255       /* Process inits.  */
9256
9257       nameinit = ffecom_build_f2c_string_ ((i = strlen (ffesymbol_text (s)))
9258                                            + 1,
9259                                            ffesymbol_text (s));
9260       TREE_TYPE (nameinit)
9261         = build_type_variant
9262         (build_array_type
9263          (char_type_node,
9264           build_range_type (integer_type_node,
9265                             integer_one_node,
9266                             build_int_2 (i, 0))),
9267          1, 0);
9268       TREE_CONSTANT (nameinit) = 1;
9269       TREE_STATIC (nameinit) = 1;
9270       nameinit = ffecom_1 (ADDR_EXPR,
9271                            build_pointer_type (TREE_TYPE (nameinit)),
9272                            nameinit);
9273
9274       addrinit = ffecom_arg_ptr_to_expr (expr, &typeinit);
9275
9276       dimsinit = ffecom_vardesc_dims_ (s);
9277
9278       if (typeinit == NULL_TREE)
9279         {
9280           ffeinfoBasictype bt = ffesymbol_basictype (s);
9281           ffeinfoKindtype kt = ffesymbol_kindtype (s);
9282           int tc = ffecom_f2c_typecode (bt, kt);
9283
9284           assert (tc != -1);
9285           typeinit = build_int_2 (tc, (tc < 0) ? -1 : 0);
9286         }
9287       else
9288         typeinit = ffecom_1 (NEGATE_EXPR, TREE_TYPE (typeinit), typeinit);
9289
9290       varinits = build_tree_list ((field = TYPE_FIELDS (vardesctype)),
9291                                   nameinit);
9292       TREE_CHAIN (varinits) = build_tree_list ((field = TREE_CHAIN (field)),
9293                                                addrinit);
9294       TREE_CHAIN (TREE_CHAIN (varinits))
9295         = build_tree_list ((field = TREE_CHAIN (field)), dimsinit);
9296       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (varinits)))
9297         = build_tree_list ((field = TREE_CHAIN (field)), typeinit);
9298
9299       varinits = build_constructor (vardesctype, varinits);
9300       TREE_CONSTANT (varinits) = 1;
9301       TREE_STATIC (varinits) = 1;
9302
9303       finish_decl (var, varinits, FALSE);
9304
9305       var = ffecom_1 (ADDR_EXPR, build_pointer_type (vardesctype), var);
9306
9307       ffesymbol_hook (s).vardesc_tree = var;
9308     }
9309
9310   return ffesymbol_hook (s).vardesc_tree;
9311 }
9312
9313 static tree
9314 ffecom_vardesc_array_ (ffesymbol s)
9315 {
9316   ffebld b;
9317   tree list;
9318   tree item = NULL_TREE;
9319   tree var;
9320   int i;
9321   static int mynumber = 0;
9322
9323   for (i = 0, list = NULL_TREE, b = ffesymbol_namelist (s);
9324        b != NULL;
9325        b = ffebld_trail (b), ++i)
9326     {
9327       tree t;
9328
9329       t = ffecom_vardesc_ (ffebld_head (b));
9330
9331       if (list == NULL_TREE)
9332         list = item = build_tree_list (NULL_TREE, t);
9333       else
9334         {
9335           TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9336           item = TREE_CHAIN (item);
9337         }
9338     }
9339
9340   item = build_array_type (build_pointer_type (ffecom_type_vardesc_ ()),
9341                            build_range_type (integer_type_node,
9342                                              integer_one_node,
9343                                              build_int_2 (i, 0)));
9344   list = build_constructor (item, list);
9345   TREE_CONSTANT (list) = 1;
9346   TREE_STATIC (list) = 1;
9347
9348   var = ffecom_get_invented_identifier ("__g77_vardesc_array_%d", mynumber++);
9349   var = build_decl (VAR_DECL, var, item);
9350   TREE_STATIC (var) = 1;
9351   DECL_INITIAL (var) = error_mark_node;
9352   var = start_decl (var, FALSE);
9353   finish_decl (var, list, FALSE);
9354
9355   return var;
9356 }
9357
9358 static tree
9359 ffecom_vardesc_dims_ (ffesymbol s)
9360 {
9361   if (ffesymbol_dims (s) == NULL)
9362     return convert (ffecom_f2c_ptr_to_ftnlen_type_node,
9363                     integer_zero_node);
9364
9365   {
9366     ffebld b;
9367     ffebld e;
9368     tree list;
9369     tree backlist;
9370     tree item = NULL_TREE;
9371     tree var;
9372     tree numdim;
9373     tree numelem;
9374     tree baseoff = NULL_TREE;
9375     static int mynumber = 0;
9376
9377     numdim = build_int_2 ((int) ffesymbol_rank (s), 0);
9378     TREE_TYPE (numdim) = ffecom_f2c_ftnlen_type_node;
9379
9380     numelem = ffecom_expr (ffesymbol_arraysize (s));
9381     TREE_TYPE (numelem) = ffecom_f2c_ftnlen_type_node;
9382
9383     list = NULL_TREE;
9384     backlist = NULL_TREE;
9385     for (b = ffesymbol_dims (s), e = ffesymbol_extents (s);
9386          b != NULL;
9387          b = ffebld_trail (b), e = ffebld_trail (e))
9388       {
9389         tree t;
9390         tree low;
9391         tree back;
9392
9393         if (ffebld_trail (b) == NULL)
9394           t = NULL_TREE;
9395         else
9396           {
9397             t = convert (ffecom_f2c_ftnlen_type_node,
9398                          ffecom_expr (ffebld_head (e)));
9399
9400             if (list == NULL_TREE)
9401               list = item = build_tree_list (NULL_TREE, t);
9402             else
9403               {
9404                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9405                 item = TREE_CHAIN (item);
9406               }
9407           }
9408
9409         if (ffebld_left (ffebld_head (b)) == NULL)
9410           low = ffecom_integer_one_node;
9411         else
9412           low = ffecom_expr (ffebld_left (ffebld_head (b)));
9413         low = convert (ffecom_f2c_ftnlen_type_node, low);
9414
9415         back = build_tree_list (low, t);
9416         TREE_CHAIN (back) = backlist;
9417         backlist = back;
9418       }
9419
9420     for (item = backlist; item != NULL_TREE; item = TREE_CHAIN (item))
9421       {
9422         if (TREE_VALUE (item) == NULL_TREE)
9423           baseoff = TREE_PURPOSE (item);
9424         else
9425           baseoff = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
9426                               TREE_PURPOSE (item),
9427                               ffecom_2 (MULT_EXPR,
9428                                         ffecom_f2c_ftnlen_type_node,
9429                                         TREE_VALUE (item),
9430                                         baseoff));
9431       }
9432
9433     /* backlist now dead, along with all TREE_PURPOSEs on it.  */
9434
9435     baseoff = build_tree_list (NULL_TREE, baseoff);
9436     TREE_CHAIN (baseoff) = list;
9437
9438     numelem = build_tree_list (NULL_TREE, numelem);
9439     TREE_CHAIN (numelem) = baseoff;
9440
9441     numdim = build_tree_list (NULL_TREE, numdim);
9442     TREE_CHAIN (numdim) = numelem;
9443
9444     item = build_array_type (ffecom_f2c_ftnlen_type_node,
9445                              build_range_type (integer_type_node,
9446                                                integer_zero_node,
9447                                                build_int_2
9448                                                ((int) ffesymbol_rank (s)
9449                                                 + 2, 0)));
9450     list = build_constructor (item, numdim);
9451     TREE_CONSTANT (list) = 1;
9452     TREE_STATIC (list) = 1;
9453
9454     var = ffecom_get_invented_identifier ("__g77_dims_%d", mynumber++);
9455     var = build_decl (VAR_DECL, var, item);
9456     TREE_STATIC (var) = 1;
9457     DECL_INITIAL (var) = error_mark_node;
9458     var = start_decl (var, FALSE);
9459     finish_decl (var, list, FALSE);
9460
9461     var = ffecom_1 (ADDR_EXPR, build_pointer_type (item), var);
9462
9463     return var;
9464   }
9465 }
9466
9467 /* Essentially does a "fold (build1 (code, type, node))" while checking
9468    for certain housekeeping things.
9469
9470    NOTE: for building an ADDR_EXPR around a FUNCTION_DECL, use
9471    ffecom_1_fn instead.  */
9472
9473 tree
9474 ffecom_1 (enum tree_code code, tree type, tree node)
9475 {
9476   tree item;
9477
9478   if ((node == error_mark_node)
9479       || (type == error_mark_node))
9480     return error_mark_node;
9481
9482   if (code == ADDR_EXPR)
9483     {
9484       if (!ffe_mark_addressable (node))
9485         assert ("can't mark_addressable this node!" == NULL);
9486     }
9487
9488   switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9489     {
9490       tree realtype;
9491
9492     case REALPART_EXPR:
9493       item = build (COMPONENT_REF, type, node, TYPE_FIELDS (TREE_TYPE (node)));
9494       break;
9495
9496     case IMAGPART_EXPR:
9497       item = build (COMPONENT_REF, type, node, TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (node))));
9498       break;
9499
9500
9501     case NEGATE_EXPR:
9502       if (TREE_CODE (type) != RECORD_TYPE)
9503         {
9504           item = build1 (code, type, node);
9505           break;
9506         }
9507       node = ffecom_stabilize_aggregate_ (node);
9508       realtype = TREE_TYPE (TYPE_FIELDS (type));
9509       item =
9510         ffecom_2 (COMPLEX_EXPR, type,
9511                   ffecom_1 (NEGATE_EXPR, realtype,
9512                             ffecom_1 (REALPART_EXPR, realtype,
9513                                       node)),
9514                   ffecom_1 (NEGATE_EXPR, realtype,
9515                             ffecom_1 (IMAGPART_EXPR, realtype,
9516                                       node)));
9517       break;
9518
9519     default:
9520       item = build1 (code, type, node);
9521       break;
9522     }
9523
9524   if (TREE_SIDE_EFFECTS (node))
9525     TREE_SIDE_EFFECTS (item) = 1;
9526   if (code == ADDR_EXPR && staticp (node))
9527     TREE_CONSTANT (item) = 1;
9528   else if (code == INDIRECT_REF)
9529     TREE_READONLY (item) = TYPE_READONLY (type);
9530   return fold (item);
9531 }
9532
9533 /* Like ffecom_1 (ADDR_EXPR, TREE_TYPE (node), node), except
9534    handles TREE_CODE (node) == FUNCTION_DECL.  In particular,
9535    does not set TREE_ADDRESSABLE (because calling an inline
9536    function does not mean the function needs to be separately
9537    compiled).  */
9538
9539 tree
9540 ffecom_1_fn (tree node)
9541 {
9542   tree item;
9543   tree type;
9544
9545   if (node == error_mark_node)
9546     return error_mark_node;
9547
9548   type = build_type_variant (TREE_TYPE (node),
9549                              TREE_READONLY (node),
9550                              TREE_THIS_VOLATILE (node));
9551   item = build1 (ADDR_EXPR,
9552                  build_pointer_type (type), node);
9553   if (TREE_SIDE_EFFECTS (node))
9554     TREE_SIDE_EFFECTS (item) = 1;
9555   if (staticp (node))
9556     TREE_CONSTANT (item) = 1;
9557   return fold (item);
9558 }
9559
9560 /* Essentially does a "fold (build (code, type, node1, node2))" while
9561    checking for certain housekeeping things.  */
9562
9563 tree
9564 ffecom_2 (enum tree_code code, tree type, tree node1,
9565           tree node2)
9566 {
9567   tree item;
9568
9569   if ((node1 == error_mark_node)
9570       || (node2 == error_mark_node)
9571       || (type == error_mark_node))
9572     return error_mark_node;
9573
9574   switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9575     {
9576       tree a, b, c, d, realtype;
9577
9578     case CONJ_EXPR:
9579       assert ("no CONJ_EXPR support yet" == NULL);
9580       return error_mark_node;
9581
9582     case COMPLEX_EXPR:
9583       item = build_tree_list (TYPE_FIELDS (type), node1);
9584       TREE_CHAIN (item) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), node2);
9585       item = build_constructor (type, item);
9586       break;
9587
9588     case PLUS_EXPR:
9589       if (TREE_CODE (type) != RECORD_TYPE)
9590         {
9591           item = build (code, type, node1, node2);
9592           break;
9593         }
9594       node1 = ffecom_stabilize_aggregate_ (node1);
9595       node2 = ffecom_stabilize_aggregate_ (node2);
9596       realtype = TREE_TYPE (TYPE_FIELDS (type));
9597       item =
9598         ffecom_2 (COMPLEX_EXPR, type,
9599                   ffecom_2 (PLUS_EXPR, realtype,
9600                             ffecom_1 (REALPART_EXPR, realtype,
9601                                       node1),
9602                             ffecom_1 (REALPART_EXPR, realtype,
9603                                       node2)),
9604                   ffecom_2 (PLUS_EXPR, realtype,
9605                             ffecom_1 (IMAGPART_EXPR, realtype,
9606                                       node1),
9607                             ffecom_1 (IMAGPART_EXPR, realtype,
9608                                       node2)));
9609       break;
9610
9611     case MINUS_EXPR:
9612       if (TREE_CODE (type) != RECORD_TYPE)
9613         {
9614           item = build (code, type, node1, node2);
9615           break;
9616         }
9617       node1 = ffecom_stabilize_aggregate_ (node1);
9618       node2 = ffecom_stabilize_aggregate_ (node2);
9619       realtype = TREE_TYPE (TYPE_FIELDS (type));
9620       item =
9621         ffecom_2 (COMPLEX_EXPR, type,
9622                   ffecom_2 (MINUS_EXPR, realtype,
9623                             ffecom_1 (REALPART_EXPR, realtype,
9624                                       node1),
9625                             ffecom_1 (REALPART_EXPR, realtype,
9626                                       node2)),
9627                   ffecom_2 (MINUS_EXPR, realtype,
9628                             ffecom_1 (IMAGPART_EXPR, realtype,
9629                                       node1),
9630                             ffecom_1 (IMAGPART_EXPR, realtype,
9631                                       node2)));
9632       break;
9633
9634     case MULT_EXPR:
9635       if (TREE_CODE (type) != RECORD_TYPE)
9636         {
9637           item = build (code, type, node1, node2);
9638           break;
9639         }
9640       node1 = ffecom_stabilize_aggregate_ (node1);
9641       node2 = ffecom_stabilize_aggregate_ (node2);
9642       realtype = TREE_TYPE (TYPE_FIELDS (type));
9643       a = save_expr (ffecom_1 (REALPART_EXPR, realtype,
9644                                node1));
9645       b = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
9646                                node1));
9647       c = save_expr (ffecom_1 (REALPART_EXPR, realtype,
9648                                node2));
9649       d = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
9650                                node2));
9651       item =
9652         ffecom_2 (COMPLEX_EXPR, type,
9653                   ffecom_2 (MINUS_EXPR, realtype,
9654                             ffecom_2 (MULT_EXPR, realtype,
9655                                       a,
9656                                       c),
9657                             ffecom_2 (MULT_EXPR, realtype,
9658                                       b,
9659                                       d)),
9660                   ffecom_2 (PLUS_EXPR, realtype,
9661                             ffecom_2 (MULT_EXPR, realtype,
9662                                       a,
9663                                       d),
9664                             ffecom_2 (MULT_EXPR, realtype,
9665                                       c,
9666                                       b)));
9667       break;
9668
9669     case EQ_EXPR:
9670       if ((TREE_CODE (node1) != RECORD_TYPE)
9671           && (TREE_CODE (node2) != RECORD_TYPE))
9672         {
9673           item = build (code, type, node1, node2);
9674           break;
9675         }
9676       assert (TREE_CODE (node1) == RECORD_TYPE);
9677       assert (TREE_CODE (node2) == RECORD_TYPE);
9678       node1 = ffecom_stabilize_aggregate_ (node1);
9679       node2 = ffecom_stabilize_aggregate_ (node2);
9680       realtype = TREE_TYPE (TYPE_FIELDS (type));
9681       item =
9682         ffecom_2 (TRUTH_ANDIF_EXPR, type,
9683                   ffecom_2 (code, type,
9684                             ffecom_1 (REALPART_EXPR, realtype,
9685                                       node1),
9686                             ffecom_1 (REALPART_EXPR, realtype,
9687                                       node2)),
9688                   ffecom_2 (code, type,
9689                             ffecom_1 (IMAGPART_EXPR, realtype,
9690                                       node1),
9691                             ffecom_1 (IMAGPART_EXPR, realtype,
9692                                       node2)));
9693       break;
9694
9695     case NE_EXPR:
9696       if ((TREE_CODE (node1) != RECORD_TYPE)
9697           && (TREE_CODE (node2) != RECORD_TYPE))
9698         {
9699           item = build (code, type, node1, node2);
9700           break;
9701         }
9702       assert (TREE_CODE (node1) == RECORD_TYPE);
9703       assert (TREE_CODE (node2) == RECORD_TYPE);
9704       node1 = ffecom_stabilize_aggregate_ (node1);
9705       node2 = ffecom_stabilize_aggregate_ (node2);
9706       realtype = TREE_TYPE (TYPE_FIELDS (type));
9707       item =
9708         ffecom_2 (TRUTH_ORIF_EXPR, type,
9709                   ffecom_2 (code, type,
9710                             ffecom_1 (REALPART_EXPR, realtype,
9711                                       node1),
9712                             ffecom_1 (REALPART_EXPR, realtype,
9713                                       node2)),
9714                   ffecom_2 (code, type,
9715                             ffecom_1 (IMAGPART_EXPR, realtype,
9716                                       node1),
9717                             ffecom_1 (IMAGPART_EXPR, realtype,
9718                                       node2)));
9719       break;
9720
9721     default:
9722       item = build (code, type, node1, node2);
9723       break;
9724     }
9725
9726   if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2))
9727     TREE_SIDE_EFFECTS (item) = 1;
9728   return fold (item);
9729 }
9730
9731 /* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint
9732
9733    ffesymbol s;  // the ENTRY point itself
9734    if (ffecom_2pass_advise_entrypoint(s))
9735        // the ENTRY point has been accepted
9736
9737    Does whatever compiler needs to do when it learns about the entrypoint,
9738    like determine the return type of the master function, count the
9739    number of entrypoints, etc.  Returns FALSE if the return type is
9740    not compatible with the return type(s) of other entrypoint(s).
9741
9742    NOTE: for every call to this fn that returns TRUE, _do_entrypoint must
9743    later (after _finish_progunit) be called with the same entrypoint(s)
9744    as passed to this fn for which TRUE was returned.
9745
9746    03-Jan-92  JCB  2.0
9747       Return FALSE if the return type conflicts with previous entrypoints.  */
9748
9749 bool
9750 ffecom_2pass_advise_entrypoint (ffesymbol entry)
9751 {
9752   ffebld list;                  /* opITEM. */
9753   ffebld mlist;                 /* opITEM. */
9754   ffebld plist;                 /* opITEM. */
9755   ffebld arg;                   /* ffebld_head(opITEM). */
9756   ffebld item;                  /* opITEM. */
9757   ffesymbol s;                  /* ffebld_symter(arg). */
9758   ffeinfoBasictype bt = ffesymbol_basictype (entry);
9759   ffeinfoKindtype kt = ffesymbol_kindtype (entry);
9760   ffetargetCharacterSize size = ffesymbol_size (entry);
9761   bool ok;
9762
9763   if (ffecom_num_entrypoints_ == 0)
9764     {                           /* First entrypoint, make list of main
9765                                    arglist's dummies. */
9766       assert (ffecom_primary_entry_ != NULL);
9767
9768       ffecom_master_bt_ = ffesymbol_basictype (ffecom_primary_entry_);
9769       ffecom_master_kt_ = ffesymbol_kindtype (ffecom_primary_entry_);
9770       ffecom_master_size_ = ffesymbol_size (ffecom_primary_entry_);
9771
9772       for (plist = NULL, list = ffesymbol_dummyargs (ffecom_primary_entry_);
9773            list != NULL;
9774            list = ffebld_trail (list))
9775         {
9776           arg = ffebld_head (list);
9777           if (ffebld_op (arg) != FFEBLD_opSYMTER)
9778             continue;           /* Alternate return or some such thing. */
9779           item = ffebld_new_item (arg, NULL);
9780           if (plist == NULL)
9781             ffecom_master_arglist_ = item;
9782           else
9783             ffebld_set_trail (plist, item);
9784           plist = item;
9785         }
9786     }
9787
9788   /* If necessary, scan entry arglist for alternate returns.  Do this scan
9789      apparently redundantly (it's done below to UNIONize the arglists) so
9790      that we don't complain about RETURN 1 if an offending ENTRY is the only
9791      one with an alternate return.  */
9792
9793   if (!ffecom_is_altreturning_)
9794     {
9795       for (list = ffesymbol_dummyargs (entry);
9796            list != NULL;
9797            list = ffebld_trail (list))
9798         {
9799           arg = ffebld_head (list);
9800           if (ffebld_op (arg) == FFEBLD_opSTAR)
9801             {
9802               ffecom_is_altreturning_ = TRUE;
9803               break;
9804             }
9805         }
9806     }
9807
9808   /* Now check type compatibility. */
9809
9810   switch (ffecom_master_bt_)
9811     {
9812     case FFEINFO_basictypeNONE:
9813       ok = (bt != FFEINFO_basictypeCHARACTER);
9814       break;
9815
9816     case FFEINFO_basictypeCHARACTER:
9817       ok
9818         = (bt == FFEINFO_basictypeCHARACTER)
9819         && (kt == ffecom_master_kt_)
9820         && (size == ffecom_master_size_);
9821       break;
9822
9823     case FFEINFO_basictypeANY:
9824       return FALSE;             /* Just don't bother. */
9825
9826     default:
9827       if (bt == FFEINFO_basictypeCHARACTER)
9828         {
9829           ok = FALSE;
9830           break;
9831         }
9832       ok = TRUE;
9833       if ((bt != ffecom_master_bt_) || (kt != ffecom_master_kt_))
9834         {
9835           ffecom_master_bt_ = FFEINFO_basictypeNONE;
9836           ffecom_master_kt_ = FFEINFO_kindtypeNONE;
9837         }
9838       break;
9839     }
9840
9841   if (!ok)
9842     {
9843       ffebad_start (FFEBAD_ENTRY_CONFLICTS);
9844       ffest_ffebad_here_current_stmt (0);
9845       ffebad_finish ();
9846       return FALSE;             /* Can't handle entrypoint. */
9847     }
9848
9849   /* Entrypoint type compatible with previous types. */
9850
9851   ++ffecom_num_entrypoints_;
9852
9853   /* Master-arg-list = UNION(Master-arg-list,entry-arg-list). */
9854
9855   for (list = ffesymbol_dummyargs (entry);
9856        list != NULL;
9857        list = ffebld_trail (list))
9858     {
9859       arg = ffebld_head (list);
9860       if (ffebld_op (arg) != FFEBLD_opSYMTER)
9861         continue;               /* Alternate return or some such thing. */
9862       s = ffebld_symter (arg);
9863       for (plist = NULL, mlist = ffecom_master_arglist_;
9864            mlist != NULL;
9865            plist = mlist, mlist = ffebld_trail (mlist))
9866         {                       /* plist points to previous item for easy
9867                                    appending of arg. */
9868           if (ffebld_symter (ffebld_head (mlist)) == s)
9869             break;              /* Already have this arg in the master list. */
9870         }
9871       if (mlist != NULL)
9872         continue;               /* Already have this arg in the master list. */
9873
9874       /* Append this arg to the master list. */
9875
9876       item = ffebld_new_item (arg, NULL);
9877       if (plist == NULL)
9878         ffecom_master_arglist_ = item;
9879       else
9880         ffebld_set_trail (plist, item);
9881     }
9882
9883   return TRUE;
9884 }
9885
9886 /* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint
9887
9888    ffesymbol s;  // the ENTRY point itself
9889    ffecom_2pass_do_entrypoint(s);
9890
9891    Does whatever compiler needs to do to make the entrypoint actually
9892    happen.  Must be called for each entrypoint after
9893    ffecom_finish_progunit is called.  */
9894
9895 void
9896 ffecom_2pass_do_entrypoint (ffesymbol entry)
9897 {
9898   static int mfn_num = 0;
9899   static int ent_num;
9900
9901   if (mfn_num != ffecom_num_fns_)
9902     {                           /* First entrypoint for this program unit. */
9903       ent_num = 1;
9904       mfn_num = ffecom_num_fns_;
9905       ffecom_do_entry_ (ffecom_primary_entry_, 0);
9906     }
9907   else
9908     ++ent_num;
9909
9910   --ffecom_num_entrypoints_;
9911
9912   ffecom_do_entry_ (entry, ent_num);
9913 }
9914
9915 /* Essentially does a "fold (build (code, type, node1, node2))" while
9916    checking for certain housekeeping things.  Always sets
9917    TREE_SIDE_EFFECTS.  */
9918
9919 tree
9920 ffecom_2s (enum tree_code code, tree type, tree node1,
9921            tree node2)
9922 {
9923   tree item;
9924
9925   if ((node1 == error_mark_node)
9926       || (node2 == error_mark_node)
9927       || (type == error_mark_node))
9928     return error_mark_node;
9929
9930   item = build (code, type, node1, node2);
9931   TREE_SIDE_EFFECTS (item) = 1;
9932   return fold (item);
9933 }
9934
9935 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
9936    checking for certain housekeeping things.  */
9937
9938 tree
9939 ffecom_3 (enum tree_code code, tree type, tree node1,
9940           tree node2, tree node3)
9941 {
9942   tree item;
9943
9944   if ((node1 == error_mark_node)
9945       || (node2 == error_mark_node)
9946       || (node3 == error_mark_node)
9947       || (type == error_mark_node))
9948     return error_mark_node;
9949
9950   item = build (code, type, node1, node2, node3);
9951   if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2)
9952       || (node3 != NULL_TREE && TREE_SIDE_EFFECTS (node3)))
9953     TREE_SIDE_EFFECTS (item) = 1;
9954   return fold (item);
9955 }
9956
9957 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
9958    checking for certain housekeeping things.  Always sets
9959    TREE_SIDE_EFFECTS.  */
9960
9961 tree
9962 ffecom_3s (enum tree_code code, tree type, tree node1,
9963            tree node2, tree node3)
9964 {
9965   tree item;
9966
9967   if ((node1 == error_mark_node)
9968       || (node2 == error_mark_node)
9969       || (node3 == error_mark_node)
9970       || (type == error_mark_node))
9971     return error_mark_node;
9972
9973   item = build (code, type, node1, node2, node3);
9974   TREE_SIDE_EFFECTS (item) = 1;
9975   return fold (item);
9976 }
9977
9978 /* ffecom_arg_expr -- Transform argument expr into gcc tree
9979
9980    See use by ffecom_list_expr.
9981
9982    If expression is NULL, returns an integer zero tree.  If it is not
9983    a CHARACTER expression, returns whatever ffecom_expr
9984    returns and sets the length return value to NULL_TREE.  Otherwise
9985    generates code to evaluate the character expression, returns the proper
9986    pointer to the result, but does NOT set the length return value to a tree
9987    that specifies the length of the result.  (In other words, the length
9988    variable is always set to NULL_TREE, because a length is never passed.)
9989
9990    21-Dec-91  JCB  1.1
9991       Don't set returned length, since nobody needs it (yet; someday if
9992       we allow CHARACTER*(*) dummies to statement functions, we'll need
9993       it).  */
9994
9995 tree
9996 ffecom_arg_expr (ffebld expr, tree *length)
9997 {
9998   tree ign;
9999
10000   *length = NULL_TREE;
10001
10002   if (expr == NULL)
10003     return integer_zero_node;
10004
10005   if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10006     return ffecom_expr (expr);
10007
10008   return ffecom_arg_ptr_to_expr (expr, &ign);
10009 }
10010
10011 /* Transform expression into constant argument-pointer-to-expression tree.
10012
10013    If the expression can be transformed into a argument-pointer-to-expression
10014    tree that is constant, that is done, and the tree returned.  Else
10015    NULL_TREE is returned.
10016
10017    That way, a caller can attempt to provide compile-time initialization
10018    of a variable and, if that fails, *then* choose to start a new block
10019    and resort to using temporaries, as appropriate.  */
10020
10021 tree
10022 ffecom_arg_ptr_to_const_expr (ffebld expr, tree *length)
10023 {
10024   if (! expr)
10025     return integer_zero_node;
10026
10027   if (ffebld_op (expr) == FFEBLD_opANY)
10028     {
10029       if (length)
10030         *length = error_mark_node;
10031       return error_mark_node;
10032     }
10033
10034   if (ffebld_arity (expr) == 0
10035       && (ffebld_op (expr) != FFEBLD_opSYMTER
10036           || ffebld_where (expr) == FFEINFO_whereCOMMON
10037           || ffebld_where (expr) == FFEINFO_whereGLOBAL
10038           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10039     {
10040       tree t;
10041
10042       t = ffecom_arg_ptr_to_expr (expr, length);
10043       assert (TREE_CONSTANT (t));
10044       assert (! length || TREE_CONSTANT (*length));
10045       return t;
10046     }
10047
10048   if (length
10049       && ffebld_size (expr) != FFETARGET_charactersizeNONE)
10050     *length = build_int_2 (ffebld_size (expr), 0);
10051   else if (length)
10052     *length = NULL_TREE;
10053   return NULL_TREE;
10054 }
10055
10056 /* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree
10057
10058    See use by ffecom_list_ptr_to_expr.
10059
10060    If expression is NULL, returns an integer zero tree.  If it is not
10061    a CHARACTER expression, returns whatever ffecom_ptr_to_expr
10062    returns and sets the length return value to NULL_TREE.  Otherwise
10063    generates code to evaluate the character expression, returns the proper
10064    pointer to the result, AND sets the length return value to a tree that
10065    specifies the length of the result.
10066
10067    If the length argument is NULL, this is a slightly special
10068    case of building a FORMAT expression, that is, an expression that
10069    will be used at run time without regard to length.  For the current
10070    implementation, which uses the libf2c library, this means it is nice
10071    to append a null byte to the end of the expression, where feasible,
10072    to make sure any diagnostic about the FORMAT string terminates at
10073    some useful point.
10074
10075    For now, treat %REF(char-expr) as the same as char-expr with a NULL
10076    length argument.  This might even be seen as a feature, if a null
10077    byte can always be appended.  */
10078
10079 tree
10080 ffecom_arg_ptr_to_expr (ffebld expr, tree *length)
10081 {
10082   tree item;
10083   tree ign_length;
10084   ffecomConcatList_ catlist;
10085
10086   if (length != NULL)
10087     *length = NULL_TREE;
10088
10089   if (expr == NULL)
10090     return integer_zero_node;
10091
10092   switch (ffebld_op (expr))
10093     {
10094     case FFEBLD_opPERCENT_VAL:
10095       if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10096         return ffecom_expr (ffebld_left (expr));
10097       {
10098         tree temp_exp;
10099         tree temp_length;
10100
10101         temp_exp = ffecom_arg_ptr_to_expr (ffebld_left (expr), &temp_length);
10102         if (temp_exp == error_mark_node)
10103           return error_mark_node;
10104
10105         return ffecom_1 (INDIRECT_REF, TREE_TYPE (TREE_TYPE (temp_exp)),
10106                          temp_exp);
10107       }
10108
10109     case FFEBLD_opPERCENT_REF:
10110       if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10111         return ffecom_ptr_to_expr (ffebld_left (expr));
10112       if (length != NULL)
10113         {
10114           ign_length = NULL_TREE;
10115           length = &ign_length;
10116         }
10117       expr = ffebld_left (expr);
10118       break;
10119
10120     case FFEBLD_opPERCENT_DESCR:
10121       switch (ffeinfo_basictype (ffebld_info (expr)))
10122         {
10123 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10124         case FFEINFO_basictypeHOLLERITH:
10125 #endif
10126         case FFEINFO_basictypeCHARACTER:
10127           break;                /* Passed by descriptor anyway. */
10128
10129         default:
10130           item = ffecom_ptr_to_expr (expr);
10131           if (item != error_mark_node)
10132             *length = TYPE_SIZE (TREE_TYPE (TREE_TYPE (item)));
10133           break;
10134         }
10135       break;
10136
10137     default:
10138       break;
10139     }
10140
10141 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10142   if ((ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeHOLLERITH)
10143       && (length != NULL))
10144     {                           /* Pass Hollerith by descriptor. */
10145       ffetargetHollerith h;
10146
10147       assert (ffebld_op (expr) == FFEBLD_opCONTER);
10148       h = ffebld_cu_val_hollerith (ffebld_constant_union
10149                                    (ffebld_conter (expr)));
10150       *length
10151         = build_int_2 (h.length, 0);
10152       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10153     }
10154 #endif
10155
10156   if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10157     return ffecom_ptr_to_expr (expr);
10158
10159   assert (ffeinfo_kindtype (ffebld_info (expr))
10160           == FFEINFO_kindtypeCHARACTER1);
10161
10162   while (ffebld_op (expr) == FFEBLD_opPAREN)
10163     expr = ffebld_left (expr);
10164
10165   catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
10166   switch (ffecom_concat_list_count_ (catlist))
10167     {
10168     case 0:                     /* Shouldn't happen, but in case it does... */
10169       if (length != NULL)
10170         {
10171           *length = ffecom_f2c_ftnlen_zero_node;
10172           TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10173         }
10174       ffecom_concat_list_kill_ (catlist);
10175       return null_pointer_node;
10176
10177     case 1:                     /* The (fairly) easy case. */
10178       if (length == NULL)
10179         ffecom_char_args_with_null_ (&item, &ign_length,
10180                                      ffecom_concat_list_expr_ (catlist, 0));
10181       else
10182         ffecom_char_args_ (&item, length,
10183                            ffecom_concat_list_expr_ (catlist, 0));
10184       ffecom_concat_list_kill_ (catlist);
10185       assert (item != NULL_TREE);
10186       return item;
10187
10188     default:                    /* Must actually concatenate things. */
10189       break;
10190     }
10191
10192   {
10193     int count = ffecom_concat_list_count_ (catlist);
10194     int i;
10195     tree lengths;
10196     tree items;
10197     tree length_array;
10198     tree item_array;
10199     tree citem;
10200     tree clength;
10201     tree temporary;
10202     tree num;
10203     tree known_length;
10204     ffetargetCharacterSize sz;
10205
10206     sz = ffecom_concat_list_maxlen_ (catlist);
10207     /* ~~Kludge! */
10208     assert (sz != FFETARGET_charactersizeNONE);
10209
10210     {
10211       tree hook;
10212
10213       hook = ffebld_nonter_hook (expr);
10214       assert (hook);
10215       assert (TREE_CODE (hook) == TREE_VEC);
10216       assert (TREE_VEC_LENGTH (hook) == 3);
10217       length_array = lengths = TREE_VEC_ELT (hook, 0);
10218       item_array = items = TREE_VEC_ELT (hook, 1);
10219       temporary = TREE_VEC_ELT (hook, 2);
10220     }
10221
10222     known_length = ffecom_f2c_ftnlen_zero_node;
10223
10224     for (i = 0; i < count; ++i)
10225       {
10226         if ((i == count)
10227             && (length == NULL))
10228           ffecom_char_args_with_null_ (&citem, &clength,
10229                                        ffecom_concat_list_expr_ (catlist, i));
10230         else
10231           ffecom_char_args_ (&citem, &clength,
10232                              ffecom_concat_list_expr_ (catlist, i));
10233         if ((citem == error_mark_node)
10234             || (clength == error_mark_node))
10235           {
10236             ffecom_concat_list_kill_ (catlist);
10237             *length = error_mark_node;
10238             return error_mark_node;
10239           }
10240
10241         items
10242           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
10243                       ffecom_modify (void_type_node,
10244                                      ffecom_2 (ARRAY_REF,
10245                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
10246                                                item_array,
10247                                                build_int_2 (i, 0)),
10248                                      citem),
10249                       items);
10250         clength = ffecom_save_tree (clength);
10251         if (length != NULL)
10252           known_length
10253             = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
10254                         known_length,
10255                         clength);
10256         lengths
10257           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
10258                       ffecom_modify (void_type_node,
10259                                      ffecom_2 (ARRAY_REF,
10260                    TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
10261                                                length_array,
10262                                                build_int_2 (i, 0)),
10263                                      clength),
10264                       lengths);
10265       }
10266
10267     temporary = ffecom_1 (ADDR_EXPR,
10268                           build_pointer_type (TREE_TYPE (temporary)),
10269                           temporary);
10270
10271     item = build_tree_list (NULL_TREE, temporary);
10272     TREE_CHAIN (item)
10273       = build_tree_list (NULL_TREE,
10274                          ffecom_1 (ADDR_EXPR,
10275                                    build_pointer_type (TREE_TYPE (items)),
10276                                    items));
10277     TREE_CHAIN (TREE_CHAIN (item))
10278       = build_tree_list (NULL_TREE,
10279                          ffecom_1 (ADDR_EXPR,
10280                                    build_pointer_type (TREE_TYPE (lengths)),
10281                                    lengths));
10282     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
10283       = build_tree_list
10284         (NULL_TREE,
10285          ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
10286                    convert (ffecom_f2c_ftnlen_type_node,
10287                             build_int_2 (count, 0))));
10288     num = build_int_2 (sz, 0);
10289     TREE_TYPE (num) = ffecom_f2c_ftnlen_type_node;
10290     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item))))
10291       = build_tree_list (NULL_TREE, num);
10292
10293     item = ffecom_call_gfrt (FFECOM_gfrtCAT, item, NULL_TREE);
10294     TREE_SIDE_EFFECTS (item) = 1;
10295     item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (temporary),
10296                      item,
10297                      temporary);
10298
10299     if (length != NULL)
10300       *length = known_length;
10301   }
10302
10303   ffecom_concat_list_kill_ (catlist);
10304   assert (item != NULL_TREE);
10305   return item;
10306 }
10307
10308 /* Generate call to run-time function.
10309
10310    The first arg is the GNU Fortran Run-Time function index, the second
10311    arg is the list of arguments to pass to it.  Returned is the expression
10312    (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the
10313    result (which may be void).  */
10314
10315 tree
10316 ffecom_call_gfrt (ffecomGfrt ix, tree args, tree hook)
10317 {
10318   return ffecom_call_ (ffecom_gfrt_tree_ (ix),
10319                        ffecom_gfrt_kindtype (ix),
10320                        ffe_is_f2c_library () && ffecom_gfrt_complex_[ix],
10321                        NULL_TREE, args, NULL_TREE, NULL,
10322                        NULL, NULL_TREE, TRUE, hook);
10323 }
10324
10325 /* Transform constant-union to tree.  */
10326
10327 tree
10328 ffecom_constantunion (ffebldConstantUnion *cu, ffeinfoBasictype bt,
10329                       ffeinfoKindtype kt, tree tree_type)
10330 {
10331   tree item;
10332
10333   switch (bt)
10334     {
10335     case FFEINFO_basictypeINTEGER:
10336       {
10337         int val;
10338
10339         switch (kt)
10340           {
10341 #if FFETARGET_okINTEGER1
10342           case FFEINFO_kindtypeINTEGER1:
10343             val = ffebld_cu_val_integer1 (*cu);
10344             break;
10345 #endif
10346
10347 #if FFETARGET_okINTEGER2
10348           case FFEINFO_kindtypeINTEGER2:
10349             val = ffebld_cu_val_integer2 (*cu);
10350             break;
10351 #endif
10352
10353 #if FFETARGET_okINTEGER3
10354           case FFEINFO_kindtypeINTEGER3:
10355             val = ffebld_cu_val_integer3 (*cu);
10356             break;
10357 #endif
10358
10359 #if FFETARGET_okINTEGER4
10360           case FFEINFO_kindtypeINTEGER4:
10361             val = ffebld_cu_val_integer4 (*cu);
10362             break;
10363 #endif
10364
10365           default:
10366             assert ("bad INTEGER constant kind type" == NULL);
10367             /* Fall through. */
10368           case FFEINFO_kindtypeANY:
10369             return error_mark_node;
10370           }
10371         item = build_int_2 (val, (val < 0) ? -1 : 0);
10372         TREE_TYPE (item) = tree_type;
10373       }
10374       break;
10375
10376     case FFEINFO_basictypeLOGICAL:
10377       {
10378         int val;
10379
10380         switch (kt)
10381           {
10382 #if FFETARGET_okLOGICAL1
10383           case FFEINFO_kindtypeLOGICAL1:
10384             val = ffebld_cu_val_logical1 (*cu);
10385             break;
10386 #endif
10387
10388 #if FFETARGET_okLOGICAL2
10389           case FFEINFO_kindtypeLOGICAL2:
10390             val = ffebld_cu_val_logical2 (*cu);
10391             break;
10392 #endif
10393
10394 #if FFETARGET_okLOGICAL3
10395           case FFEINFO_kindtypeLOGICAL3:
10396             val = ffebld_cu_val_logical3 (*cu);
10397             break;
10398 #endif
10399
10400 #if FFETARGET_okLOGICAL4
10401           case FFEINFO_kindtypeLOGICAL4:
10402             val = ffebld_cu_val_logical4 (*cu);
10403             break;
10404 #endif
10405
10406           default:
10407             assert ("bad LOGICAL constant kind type" == NULL);
10408             /* Fall through. */
10409           case FFEINFO_kindtypeANY:
10410             return error_mark_node;
10411           }
10412         item = build_int_2 (val, (val < 0) ? -1 : 0);
10413         TREE_TYPE (item) = tree_type;
10414       }
10415       break;
10416
10417     case FFEINFO_basictypeREAL:
10418       {
10419         REAL_VALUE_TYPE val;
10420
10421         switch (kt)
10422           {
10423 #if FFETARGET_okREAL1
10424           case FFEINFO_kindtypeREAL1:
10425             val = ffetarget_value_real1 (ffebld_cu_val_real1 (*cu));
10426             break;
10427 #endif
10428
10429 #if FFETARGET_okREAL2
10430           case FFEINFO_kindtypeREAL2:
10431             val = ffetarget_value_real2 (ffebld_cu_val_real2 (*cu));
10432             break;
10433 #endif
10434
10435 #if FFETARGET_okREAL3
10436           case FFEINFO_kindtypeREAL3:
10437             val = ffetarget_value_real3 (ffebld_cu_val_real3 (*cu));
10438             break;
10439 #endif
10440
10441 #if FFETARGET_okREAL4
10442           case FFEINFO_kindtypeREAL4:
10443             val = ffetarget_value_real4 (ffebld_cu_val_real4 (*cu));
10444             break;
10445 #endif
10446
10447           default:
10448             assert ("bad REAL constant kind type" == NULL);
10449             /* Fall through. */
10450           case FFEINFO_kindtypeANY:
10451             return error_mark_node;
10452           }
10453         item = build_real (tree_type, val);
10454       }
10455       break;
10456
10457     case FFEINFO_basictypeCOMPLEX:
10458       {
10459         REAL_VALUE_TYPE real;
10460         REAL_VALUE_TYPE imag;
10461         tree el_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
10462
10463         switch (kt)
10464           {
10465 #if FFETARGET_okCOMPLEX1
10466           case FFEINFO_kindtypeREAL1:
10467             real = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).real);
10468             imag = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).imaginary);
10469             break;
10470 #endif
10471
10472 #if FFETARGET_okCOMPLEX2
10473           case FFEINFO_kindtypeREAL2:
10474             real = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).real);
10475             imag = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).imaginary);
10476             break;
10477 #endif
10478
10479 #if FFETARGET_okCOMPLEX3
10480           case FFEINFO_kindtypeREAL3:
10481             real = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).real);
10482             imag = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).imaginary);
10483             break;
10484 #endif
10485
10486 #if FFETARGET_okCOMPLEX4
10487           case FFEINFO_kindtypeREAL4:
10488             real = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).real);
10489             imag = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).imaginary);
10490             break;
10491 #endif
10492
10493           default:
10494             assert ("bad REAL constant kind type" == NULL);
10495             /* Fall through. */
10496           case FFEINFO_kindtypeANY:
10497             return error_mark_node;
10498           }
10499         item = ffecom_build_complex_constant_ (tree_type,
10500                                                build_real (el_type, real),
10501                                                build_real (el_type, imag));
10502       }
10503       break;
10504
10505     case FFEINFO_basictypeCHARACTER:
10506       {                         /* Happens only in DATA and similar contexts. */
10507         ffetargetCharacter1 val;
10508
10509         switch (kt)
10510           {
10511 #if FFETARGET_okCHARACTER1
10512           case FFEINFO_kindtypeLOGICAL1:
10513             val = ffebld_cu_val_character1 (*cu);
10514             break;
10515 #endif
10516
10517           default:
10518             assert ("bad CHARACTER constant kind type" == NULL);
10519             /* Fall through. */
10520           case FFEINFO_kindtypeANY:
10521             return error_mark_node;
10522           }
10523         item = build_string (ffetarget_length_character1 (val),
10524                              ffetarget_text_character1 (val));
10525         TREE_TYPE (item)
10526           = build_type_variant (build_array_type (char_type_node,
10527                                                   build_range_type
10528                                                   (integer_type_node,
10529                                                    integer_one_node,
10530                                                    build_int_2
10531                                                 (ffetarget_length_character1
10532                                                  (val), 0))),
10533                                 1, 0);
10534       }
10535       break;
10536
10537     case FFEINFO_basictypeHOLLERITH:
10538       {
10539         ffetargetHollerith h;
10540
10541         h = ffebld_cu_val_hollerith (*cu);
10542
10543         /* If not at least as wide as default INTEGER, widen it.  */
10544         if (h.length >= FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE)
10545           item = build_string (h.length, h.text);
10546         else
10547           {
10548             char str[FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE];
10549
10550             memcpy (str, h.text, h.length);
10551             memset (&str[h.length], ' ',
10552                     FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE
10553                     - h.length);
10554             item = build_string (FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE,
10555                                  str);
10556           }
10557         TREE_TYPE (item)
10558           = build_type_variant (build_array_type (char_type_node,
10559                                                   build_range_type
10560                                                   (integer_type_node,
10561                                                    integer_one_node,
10562                                                    build_int_2
10563                                                    (h.length, 0))),
10564                                 1, 0);
10565       }
10566       break;
10567
10568     case FFEINFO_basictypeTYPELESS:
10569       {
10570         ffetargetInteger1 ival;
10571         ffetargetTypeless tless;
10572         ffebad error;
10573
10574         tless = ffebld_cu_val_typeless (*cu);
10575         error = ffetarget_convert_integer1_typeless (&ival, tless);
10576         assert (error == FFEBAD);
10577
10578         item = build_int_2 ((int) ival, 0);
10579       }
10580       break;
10581
10582     default:
10583       assert ("not yet on constant type" == NULL);
10584       /* Fall through. */
10585     case FFEINFO_basictypeANY:
10586       return error_mark_node;
10587     }
10588
10589   TREE_CONSTANT (item) = 1;
10590
10591   return item;
10592 }
10593
10594 /* Transform constant-union to tree, with the type known.  */
10595
10596 tree
10597 ffecom_constantunion_with_type (ffebldConstantUnion *cu,
10598                       tree tree_type, ffebldConst ct)
10599 {
10600   tree item;
10601
10602   int val;
10603
10604   switch (ct)
10605   {
10606 #if FFETARGET_okINTEGER1
10607           case  FFEBLD_constINTEGER1:
10608                   val = ffebld_cu_val_integer1 (*cu);
10609                   item = build_int_2 (val, (val < 0) ? -1 : 0);
10610                   break;
10611 #endif
10612 #if FFETARGET_okINTEGER2
10613           case  FFEBLD_constINTEGER2:
10614                   val = ffebld_cu_val_integer2 (*cu);
10615                   item = build_int_2 (val, (val < 0) ? -1 : 0);
10616                   break;
10617 #endif
10618 #if FFETARGET_okINTEGER3
10619           case  FFEBLD_constINTEGER3:
10620                   val = ffebld_cu_val_integer3 (*cu);
10621                   item = build_int_2 (val, (val < 0) ? -1 : 0);
10622                   break;
10623 #endif
10624 #if FFETARGET_okINTEGER4
10625           case  FFEBLD_constINTEGER4:
10626                   val = ffebld_cu_val_integer4 (*cu);
10627                   item = build_int_2 (val, (val < 0) ? -1 : 0);
10628                   break;
10629 #endif
10630 #if FFETARGET_okLOGICAL1
10631           case  FFEBLD_constLOGICAL1:
10632                   val = ffebld_cu_val_logical1 (*cu);
10633                   item = build_int_2 (val, (val < 0) ? -1 : 0);
10634                   break;
10635 #endif
10636 #if FFETARGET_okLOGICAL2
10637           case  FFEBLD_constLOGICAL2:
10638                   val = ffebld_cu_val_logical2 (*cu);
10639                   item = build_int_2 (val, (val < 0) ? -1 : 0);
10640                   break;
10641 #endif
10642 #if FFETARGET_okLOGICAL3
10643           case  FFEBLD_constLOGICAL3:
10644                   val = ffebld_cu_val_logical3 (*cu);
10645                   item = build_int_2 (val, (val < 0) ? -1 : 0);
10646                   break;
10647 #endif
10648 #if FFETARGET_okLOGICAL4
10649           case  FFEBLD_constLOGICAL4:
10650                   val = ffebld_cu_val_logical4 (*cu);
10651                   item = build_int_2 (val, (val < 0) ? -1 : 0);
10652                   break;
10653 #endif
10654           default:
10655                   assert ("constant type not supported"==NULL);
10656                   return error_mark_node;
10657                   break;
10658   }
10659
10660   TREE_TYPE (item) = tree_type;
10661
10662   TREE_CONSTANT (item) = 1;
10663
10664   return item;
10665 }
10666 /* Transform expression into constant tree.
10667
10668    If the expression can be transformed into a tree that is constant,
10669    that is done, and the tree returned.  Else NULL_TREE is returned.
10670
10671    That way, a caller can attempt to provide compile-time initialization
10672    of a variable and, if that fails, *then* choose to start a new block
10673    and resort to using temporaries, as appropriate.  */
10674
10675 tree
10676 ffecom_const_expr (ffebld expr)
10677 {
10678   if (! expr)
10679     return integer_zero_node;
10680
10681   if (ffebld_op (expr) == FFEBLD_opANY)
10682     return error_mark_node;
10683
10684   if (ffebld_arity (expr) == 0
10685       && (ffebld_op (expr) != FFEBLD_opSYMTER
10686 #if NEWCOMMON
10687           /* ~~Enable once common/equivalence is handled properly?  */
10688           || ffebld_where (expr) == FFEINFO_whereCOMMON
10689 #endif
10690           || ffebld_where (expr) == FFEINFO_whereGLOBAL
10691           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10692     {
10693       tree t;
10694
10695       t = ffecom_expr (expr);
10696       assert (TREE_CONSTANT (t));
10697       return t;
10698     }
10699
10700   return NULL_TREE;
10701 }
10702
10703 /* Handy way to make a field in a struct/union.  */
10704
10705 tree
10706 ffecom_decl_field (tree context, tree prevfield,
10707                    const char *name, tree type)
10708 {
10709   tree field;
10710
10711   field = build_decl (FIELD_DECL, get_identifier (name), type);
10712   DECL_CONTEXT (field) = context;
10713   DECL_ALIGN (field) = 0;
10714   DECL_USER_ALIGN (field) = 0;
10715   if (prevfield != NULL_TREE)
10716     TREE_CHAIN (prevfield) = field;
10717
10718   return field;
10719 }
10720
10721 void
10722 ffecom_close_include (FILE *f)
10723 {
10724   ffecom_close_include_ (f);
10725 }
10726
10727 int
10728 ffecom_decode_include_option (char *spec)
10729 {
10730   return ffecom_decode_include_option_ (spec);
10731 }
10732
10733 /* End a compound statement (block).  */
10734
10735 tree
10736 ffecom_end_compstmt (void)
10737 {
10738   return bison_rule_compstmt_ ();
10739 }
10740
10741 /* ffecom_end_transition -- Perform end transition on all symbols
10742
10743    ffecom_end_transition();
10744
10745    Calls ffecom_sym_end_transition for each global and local symbol.  */
10746
10747 void
10748 ffecom_end_transition ()
10749 {
10750   ffebld item;
10751
10752   if (ffe_is_ffedebug ())
10753     fprintf (dmpout, "; end_stmt_transition\n");
10754
10755   ffecom_list_blockdata_ = NULL;
10756   ffecom_list_common_ = NULL;
10757
10758   ffesymbol_drive (ffecom_sym_end_transition);
10759   if (ffe_is_ffedebug ())
10760     {
10761       ffestorag_report ();
10762     }
10763
10764   ffecom_start_progunit_ ();
10765
10766   for (item = ffecom_list_blockdata_;
10767        item != NULL;
10768        item = ffebld_trail (item))
10769     {
10770       ffebld callee;
10771       ffesymbol s;
10772       tree dt;
10773       tree t;
10774       tree var;
10775       static int number = 0;
10776
10777       callee = ffebld_head (item);
10778       s = ffebld_symter (callee);
10779       t = ffesymbol_hook (s).decl_tree;
10780       if (t == NULL_TREE)
10781         {
10782           s = ffecom_sym_transform_ (s);
10783           t = ffesymbol_hook (s).decl_tree;
10784         }
10785
10786       dt = build_pointer_type (TREE_TYPE (t));
10787
10788       var = build_decl (VAR_DECL,
10789                         ffecom_get_invented_identifier ("__g77_forceload_%d",
10790                                                         number++),
10791                         dt);
10792       DECL_EXTERNAL (var) = 0;
10793       TREE_STATIC (var) = 1;
10794       TREE_PUBLIC (var) = 0;
10795       DECL_INITIAL (var) = error_mark_node;
10796       TREE_USED (var) = 1;
10797
10798       var = start_decl (var, FALSE);
10799
10800       t = ffecom_1 (ADDR_EXPR, dt, t);
10801
10802       finish_decl (var, t, FALSE);
10803     }
10804
10805   /* This handles any COMMON areas that weren't referenced but have, for
10806      example, important initial data.  */
10807
10808   for (item = ffecom_list_common_;
10809        item != NULL;
10810        item = ffebld_trail (item))
10811     ffecom_transform_common_ (ffebld_symter (ffebld_head (item)));
10812
10813   ffecom_list_common_ = NULL;
10814 }
10815
10816 /* ffecom_exec_transition -- Perform exec transition on all symbols
10817
10818    ffecom_exec_transition();
10819
10820    Calls ffecom_sym_exec_transition for each global and local symbol.
10821    Make sure error updating not inhibited.  */
10822
10823 void
10824 ffecom_exec_transition ()
10825 {
10826   bool inhibited;
10827
10828   if (ffe_is_ffedebug ())
10829     fprintf (dmpout, "; exec_stmt_transition\n");
10830
10831   inhibited = ffebad_inhibit ();
10832   ffebad_set_inhibit (FALSE);
10833
10834   ffesymbol_drive (ffecom_sym_exec_transition); /* Don't retract! */
10835   ffeequiv_exec_transition ();  /* Handle all pending EQUIVALENCEs. */
10836   if (ffe_is_ffedebug ())
10837     {
10838       ffestorag_report ();
10839     }
10840
10841   if (inhibited)
10842     ffebad_set_inhibit (TRUE);
10843 }
10844
10845 /* Handle assignment statement.
10846
10847    Convert dest and source using ffecom_expr, then join them
10848    with an ASSIGN op and pass the whole thing to expand_expr_stmt.  */
10849
10850 void
10851 ffecom_expand_let_stmt (ffebld dest, ffebld source)
10852 {
10853   tree dest_tree;
10854   tree dest_length;
10855   tree source_tree;
10856   tree expr_tree;
10857
10858   if (ffeinfo_basictype (ffebld_info (dest)) != FFEINFO_basictypeCHARACTER)
10859     {
10860       bool dest_used;
10861       tree assign_temp;
10862
10863       /* This attempts to replicate the test below, but must not be
10864          true when the test below is false.  (Always err on the side
10865          of creating unused temporaries, to avoid ICEs.)  */
10866       if (ffebld_op (dest) != FFEBLD_opSYMTER
10867           || ((dest_tree = ffesymbol_hook (ffebld_symter (dest)).decl_tree)
10868               && (TREE_CODE (dest_tree) != VAR_DECL
10869                   || TREE_ADDRESSABLE (dest_tree))))
10870         {
10871           ffecom_prepare_expr_ (source, dest);
10872           dest_used = TRUE;
10873         }
10874       else
10875         {
10876           ffecom_prepare_expr_ (source, NULL);
10877           dest_used = FALSE;
10878         }
10879
10880       ffecom_prepare_expr_w (NULL_TREE, dest);
10881
10882       /* For COMPLEX assignment like C1=C2, if partial overlap is possible,
10883          create a temporary through which the assignment is to take place,
10884          since MODIFY_EXPR doesn't handle partial overlap properly.  */
10885       if (ffebld_basictype (dest) == FFEINFO_basictypeCOMPLEX
10886           && ffecom_possible_partial_overlap_ (dest, source))
10887         {
10888           assign_temp = ffecom_make_tempvar ("complex_let",
10889                                              ffecom_tree_type
10890                                              [ffebld_basictype (dest)]
10891                                              [ffebld_kindtype (dest)],
10892                                              FFETARGET_charactersizeNONE,
10893                                              -1);
10894         }
10895       else
10896         assign_temp = NULL_TREE;
10897
10898       ffecom_prepare_end ();
10899
10900       dest_tree = ffecom_expr_w (NULL_TREE, dest);
10901       if (dest_tree == error_mark_node)
10902         return;
10903
10904       if ((TREE_CODE (dest_tree) != VAR_DECL)
10905           || TREE_ADDRESSABLE (dest_tree))
10906         source_tree = ffecom_expr_ (source, dest_tree, dest, &dest_used,
10907                                     FALSE, FALSE);
10908       else
10909         {
10910           assert (! dest_used);
10911           dest_used = FALSE;
10912           source_tree = ffecom_expr (source);
10913         }
10914       if (source_tree == error_mark_node)
10915         return;
10916
10917       if (dest_used)
10918         expr_tree = source_tree;
10919       else if (assign_temp)
10920         {
10921 #ifdef MOVE_EXPR
10922           /* The back end understands a conceptual move (evaluate source;
10923              store into dest), so use that, in case it can determine
10924              that it is going to use, say, two registers as temporaries
10925              anyway.  So don't use the temp (and someday avoid generating
10926              it, once this code starts triggering regularly).  */
10927           expr_tree = ffecom_2s (MOVE_EXPR, void_type_node,
10928                                  dest_tree,
10929                                  source_tree);
10930 #else
10931           expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
10932                                  assign_temp,
10933                                  source_tree);
10934           expand_expr_stmt (expr_tree);
10935           expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
10936                                  dest_tree,
10937                                  assign_temp);
10938 #endif
10939         }
10940       else
10941         expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
10942                                dest_tree,
10943                                source_tree);
10944
10945       expand_expr_stmt (expr_tree);
10946       return;
10947     }
10948
10949   ffecom_prepare_let_char_ (ffebld_size_known (dest), source);
10950   ffecom_prepare_expr_w (NULL_TREE, dest);
10951
10952   ffecom_prepare_end ();
10953
10954   ffecom_char_args_ (&dest_tree, &dest_length, dest);
10955   ffecom_let_char_ (dest_tree, dest_length, ffebld_size_known (dest),
10956                     source);
10957 }
10958
10959 /* ffecom_expr -- Transform expr into gcc tree
10960
10961    tree t;
10962    ffebld expr;  // FFE expression.
10963    tree = ffecom_expr(expr);
10964
10965    Recursive descent on expr while making corresponding tree nodes and
10966    attaching type info and such.  */
10967
10968 tree
10969 ffecom_expr (ffebld expr)
10970 {
10971   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, FALSE, FALSE);
10972 }
10973
10974 /* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT.  */
10975
10976 tree
10977 ffecom_expr_assign (ffebld expr)
10978 {
10979   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
10980 }
10981
10982 /* Like ffecom_expr_rw, but return tree usable for ASSIGN.  */
10983
10984 tree
10985 ffecom_expr_assign_w (ffebld expr)
10986 {
10987   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
10988 }
10989
10990 /* Transform expr for use as into read/write tree and stabilize the
10991    reference.  Not for use on CHARACTER expressions.
10992
10993    Recursive descent on expr while making corresponding tree nodes and
10994    attaching type info and such.  */
10995
10996 tree
10997 ffecom_expr_rw (tree type, ffebld expr)
10998 {
10999   assert (expr != NULL);
11000   /* Different target types not yet supported.  */
11001   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
11002
11003   return stabilize_reference (ffecom_expr (expr));
11004 }
11005
11006 /* Transform expr for use as into write tree and stabilize the
11007    reference.  Not for use on CHARACTER expressions.
11008
11009    Recursive descent on expr while making corresponding tree nodes and
11010    attaching type info and such.  */
11011
11012 tree
11013 ffecom_expr_w (tree type, ffebld expr)
11014 {
11015   assert (expr != NULL);
11016   /* Different target types not yet supported.  */
11017   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
11018
11019   return stabilize_reference (ffecom_expr (expr));
11020 }
11021
11022 /* Do global stuff.  */
11023
11024 void
11025 ffecom_finish_compile ()
11026 {
11027   assert (ffecom_outer_function_decl_ == NULL_TREE);
11028   assert (current_function_decl == NULL_TREE);
11029
11030   ffeglobal_drive (ffecom_finish_global_);
11031 }
11032
11033 /* Public entry point for front end to access finish_decl.  */
11034
11035 void
11036 ffecom_finish_decl (tree decl, tree init, bool is_top_level)
11037 {
11038   assert (!is_top_level);
11039   finish_decl (decl, init, FALSE);
11040 }
11041
11042 /* Finish a program unit.  */
11043
11044 void
11045 ffecom_finish_progunit ()
11046 {
11047   ffecom_end_compstmt ();
11048
11049   ffecom_previous_function_decl_ = current_function_decl;
11050   ffecom_which_entrypoint_decl_ = NULL_TREE;
11051
11052   finish_function (0);
11053 }
11054
11055 /* Wrapper for get_identifier.  pattern is sprintf-like.  */
11056
11057 tree
11058 ffecom_get_invented_identifier (const char *pattern, ...)
11059 {
11060   tree decl;
11061   char *nam;
11062   va_list ap;
11063
11064   va_start (ap, pattern);
11065   if (vasprintf (&nam, pattern, ap) == 0)
11066     abort ();
11067   va_end (ap);
11068   decl = get_identifier (nam);
11069   free (nam);
11070   IDENTIFIER_INVENTED (decl) = 1;
11071   return decl;
11072 }
11073
11074 ffeinfoBasictype
11075 ffecom_gfrt_basictype (ffecomGfrt gfrt)
11076 {
11077   assert (gfrt < FFECOM_gfrt);
11078
11079   switch (ffecom_gfrt_type_[gfrt])
11080     {
11081     case FFECOM_rttypeVOID_:
11082     case FFECOM_rttypeVOIDSTAR_:
11083       return FFEINFO_basictypeNONE;
11084
11085     case FFECOM_rttypeFTNINT_:
11086       return FFEINFO_basictypeINTEGER;
11087
11088     case FFECOM_rttypeINTEGER_:
11089       return FFEINFO_basictypeINTEGER;
11090
11091     case FFECOM_rttypeLONGINT_:
11092       return FFEINFO_basictypeINTEGER;
11093
11094     case FFECOM_rttypeLOGICAL_:
11095       return FFEINFO_basictypeLOGICAL;
11096
11097     case FFECOM_rttypeREAL_F2C_:
11098     case FFECOM_rttypeREAL_GNU_:
11099       return FFEINFO_basictypeREAL;
11100
11101     case FFECOM_rttypeCOMPLEX_F2C_:
11102     case FFECOM_rttypeCOMPLEX_GNU_:
11103       return FFEINFO_basictypeCOMPLEX;
11104
11105     case FFECOM_rttypeDOUBLE_:
11106     case FFECOM_rttypeDOUBLEREAL_:
11107       return FFEINFO_basictypeREAL;
11108
11109     case FFECOM_rttypeDBLCMPLX_F2C_:
11110     case FFECOM_rttypeDBLCMPLX_GNU_:
11111       return FFEINFO_basictypeCOMPLEX;
11112
11113     case FFECOM_rttypeCHARACTER_:
11114       return FFEINFO_basictypeCHARACTER;
11115
11116     default:
11117       return FFEINFO_basictypeANY;
11118     }
11119 }
11120
11121 ffeinfoKindtype
11122 ffecom_gfrt_kindtype (ffecomGfrt gfrt)
11123 {
11124   assert (gfrt < FFECOM_gfrt);
11125
11126   switch (ffecom_gfrt_type_[gfrt])
11127     {
11128     case FFECOM_rttypeVOID_:
11129     case FFECOM_rttypeVOIDSTAR_:
11130       return FFEINFO_kindtypeNONE;
11131
11132     case FFECOM_rttypeFTNINT_:
11133       return FFEINFO_kindtypeINTEGER1;
11134
11135     case FFECOM_rttypeINTEGER_:
11136       return FFEINFO_kindtypeINTEGER1;
11137
11138     case FFECOM_rttypeLONGINT_:
11139       return FFEINFO_kindtypeINTEGER4;
11140
11141     case FFECOM_rttypeLOGICAL_:
11142       return FFEINFO_kindtypeLOGICAL1;
11143
11144     case FFECOM_rttypeREAL_F2C_:
11145     case FFECOM_rttypeREAL_GNU_:
11146       return FFEINFO_kindtypeREAL1;
11147
11148     case FFECOM_rttypeCOMPLEX_F2C_:
11149     case FFECOM_rttypeCOMPLEX_GNU_:
11150       return FFEINFO_kindtypeREAL1;
11151
11152     case FFECOM_rttypeDOUBLE_:
11153     case FFECOM_rttypeDOUBLEREAL_:
11154       return FFEINFO_kindtypeREAL2;
11155
11156     case FFECOM_rttypeDBLCMPLX_F2C_:
11157     case FFECOM_rttypeDBLCMPLX_GNU_:
11158       return FFEINFO_kindtypeREAL2;
11159
11160     case FFECOM_rttypeCHARACTER_:
11161       return FFEINFO_kindtypeCHARACTER1;
11162
11163     default:
11164       return FFEINFO_kindtypeANY;
11165     }
11166 }
11167
11168 void
11169 ffecom_init_0 ()
11170 {
11171   tree endlink;
11172   int i;
11173   int j;
11174   tree t;
11175   tree field;
11176   ffetype type;
11177   ffetype base_type;
11178   tree double_ftype_double;
11179   tree float_ftype_float;
11180   tree ldouble_ftype_ldouble;
11181   tree ffecom_tree_ptr_to_fun_type_void;
11182
11183   /* This block of code comes from the now-obsolete cktyps.c.  It checks
11184      whether the compiler environment is buggy in known ways, some of which
11185      would, if not explicitly checked here, result in subtle bugs in g77.  */
11186
11187   if (ffe_is_do_internal_checks ())
11188     {
11189       static const char names[][12]
11190         =
11191       {"bar", "bletch", "foo", "foobar"};
11192       const char *name;
11193       unsigned long ul;
11194       double fl;
11195
11196       name = bsearch ("foo", &names[0], ARRAY_SIZE (names), sizeof (names[0]),
11197                       (int (*)(const void *, const void *)) strcmp);
11198       if (name != &names[2][0])
11199         {
11200           assert ("bsearch doesn't work, #define FFEPROJ_BSEARCH 0 in proj.h"
11201                   == NULL);
11202           abort ();
11203         }
11204
11205       ul = strtoul ("123456789", NULL, 10);
11206       if (ul != 123456789L)
11207         {
11208           assert ("strtoul doesn't have enough range, #define FFEPROJ_STRTOUL 0\
11209  in proj.h" == NULL);
11210           abort ();
11211         }
11212
11213       fl = atof ("56.789");
11214       if ((fl < 56.788) || (fl > 56.79))
11215         {
11216           assert ("atof not type double, fix your #include <stdio.h>"
11217                   == NULL);
11218           abort ();
11219         }
11220     }
11221
11222   ffecom_outer_function_decl_ = NULL_TREE;
11223   current_function_decl = NULL_TREE;
11224   named_labels = NULL_TREE;
11225   current_binding_level = NULL_BINDING_LEVEL;
11226   free_binding_level = NULL_BINDING_LEVEL;
11227   /* Make the binding_level structure for global names.  */
11228   pushlevel (0);
11229   global_binding_level = current_binding_level;
11230   current_binding_level->prep_state = 2;
11231
11232   build_common_tree_nodes (1);
11233
11234   /* Define `int' and `char' first so that dbx will output them first.  */
11235   pushdecl (build_decl (TYPE_DECL, get_identifier ("int"),
11236                         integer_type_node));
11237   /* CHARACTER*1 is unsigned in ICHAR contexts.  */
11238   char_type_node = make_unsigned_type (CHAR_TYPE_SIZE);
11239   pushdecl (build_decl (TYPE_DECL, get_identifier ("char"),
11240                         char_type_node));
11241   pushdecl (build_decl (TYPE_DECL, get_identifier ("long int"),
11242                         long_integer_type_node));
11243   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned int"),
11244                         unsigned_type_node));
11245   pushdecl (build_decl (TYPE_DECL, get_identifier ("long unsigned int"),
11246                         long_unsigned_type_node));
11247   pushdecl (build_decl (TYPE_DECL, get_identifier ("long long int"),
11248                         long_long_integer_type_node));
11249   pushdecl (build_decl (TYPE_DECL, get_identifier ("long long unsigned int"),
11250                         long_long_unsigned_type_node));
11251   pushdecl (build_decl (TYPE_DECL, get_identifier ("short int"),
11252                         short_integer_type_node));
11253   pushdecl (build_decl (TYPE_DECL, get_identifier ("short unsigned int"),
11254                         short_unsigned_type_node));
11255
11256   /* Set the sizetype before we make other types.  This *should* be the
11257      first type we create.  */
11258
11259   set_sizetype
11260     (TREE_TYPE (IDENTIFIER_GLOBAL_VALUE (get_identifier (SIZE_TYPE))));
11261   ffecom_typesize_pointer_
11262     = TREE_INT_CST_LOW (TYPE_SIZE (sizetype)) / BITS_PER_UNIT;
11263
11264   build_common_tree_nodes_2 (0);
11265
11266   /* Define both `signed char' and `unsigned char'.  */
11267   pushdecl (build_decl (TYPE_DECL, get_identifier ("signed char"),
11268                         signed_char_type_node));
11269
11270   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned char"),
11271                         unsigned_char_type_node));
11272
11273   pushdecl (build_decl (TYPE_DECL, get_identifier ("float"),
11274                         float_type_node));
11275   pushdecl (build_decl (TYPE_DECL, get_identifier ("double"),
11276                         double_type_node));
11277   pushdecl (build_decl (TYPE_DECL, get_identifier ("long double"),
11278                         long_double_type_node));
11279
11280   /* For now, override what build_common_tree_nodes has done.  */
11281   complex_integer_type_node = ffecom_make_complex_type_ (integer_type_node);
11282   complex_float_type_node = ffecom_make_complex_type_ (float_type_node);
11283   complex_double_type_node = ffecom_make_complex_type_ (double_type_node);
11284   complex_long_double_type_node
11285     = ffecom_make_complex_type_ (long_double_type_node);
11286
11287   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex int"),
11288                         complex_integer_type_node));
11289   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex float"),
11290                         complex_float_type_node));
11291   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex double"),
11292                         complex_double_type_node));
11293   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex long double"),
11294                         complex_long_double_type_node));
11295
11296   pushdecl (build_decl (TYPE_DECL, get_identifier ("void"),
11297                         void_type_node));
11298   /* We are not going to have real types in C with less than byte alignment,
11299      so we might as well not have any types that claim to have it.  */
11300   TYPE_ALIGN (void_type_node) = BITS_PER_UNIT;
11301   TYPE_USER_ALIGN (void_type_node) = 0;
11302
11303   string_type_node = build_pointer_type (char_type_node);
11304
11305   ffecom_tree_fun_type_void
11306     = build_function_type (void_type_node, NULL_TREE);
11307
11308   ffecom_tree_ptr_to_fun_type_void
11309     = build_pointer_type (ffecom_tree_fun_type_void);
11310
11311   endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE);
11312
11313   float_ftype_float
11314     = build_function_type (float_type_node,
11315                            tree_cons (NULL_TREE, float_type_node, endlink));
11316
11317   double_ftype_double
11318     = build_function_type (double_type_node,
11319                            tree_cons (NULL_TREE, double_type_node, endlink));
11320
11321   ldouble_ftype_ldouble
11322     = build_function_type (long_double_type_node,
11323                            tree_cons (NULL_TREE, long_double_type_node,
11324                                       endlink));
11325
11326   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11327     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11328       {
11329         ffecom_tree_type[i][j] = NULL_TREE;
11330         ffecom_tree_fun_type[i][j] = NULL_TREE;
11331         ffecom_tree_ptr_to_fun_type[i][j] = NULL_TREE;
11332         ffecom_f2c_typecode_[i][j] = -1;
11333       }
11334
11335   /* Set up standard g77 types.  Note that INTEGER and LOGICAL are set
11336      to size FLOAT_TYPE_SIZE because they have to be the same size as
11337      REAL, which also is FLOAT_TYPE_SIZE, according to the standard.
11338      Compiler options and other such stuff that change the ways these
11339      types are set should not affect this particular setup.  */
11340
11341   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1]
11342     = t = make_signed_type (FLOAT_TYPE_SIZE);
11343   pushdecl (build_decl (TYPE_DECL, get_identifier ("integer"),
11344                         t));
11345   type = ffetype_new ();
11346   base_type = type;
11347   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER1,
11348                     type);
11349   ffetype_set_ams (type,
11350                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11351                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11352   ffetype_set_star (base_type,
11353                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11354                     type);
11355   ffetype_set_kind (base_type, 1, type);
11356   ffecom_typesize_integer1_ = ffetype_size (type);
11357   assert (ffetype_size (type) == sizeof (ffetargetInteger1));
11358
11359   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER1]
11360     = t = make_unsigned_type (FLOAT_TYPE_SIZE); /* HOLLERITH means unsigned. */
11361   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned"),
11362                         t));
11363
11364   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER2]
11365     = t = make_signed_type (CHAR_TYPE_SIZE);
11366   pushdecl (build_decl (TYPE_DECL, get_identifier ("byte"),
11367                         t));
11368   type = ffetype_new ();
11369   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER2,
11370                     type);
11371   ffetype_set_ams (type,
11372                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11373                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11374   ffetype_set_star (base_type,
11375                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11376                     type);
11377   ffetype_set_kind (base_type, 3, type);
11378   assert (ffetype_size (type) == sizeof (ffetargetInteger2));
11379
11380   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER2]
11381     = t = make_unsigned_type (CHAR_TYPE_SIZE);
11382   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned byte"),
11383                         t));
11384
11385   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER3]
11386     = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11387   pushdecl (build_decl (TYPE_DECL, get_identifier ("word"),
11388                         t));
11389   type = ffetype_new ();
11390   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER3,
11391                     type);
11392   ffetype_set_ams (type,
11393                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11394                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11395   ffetype_set_star (base_type,
11396                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11397                     type);
11398   ffetype_set_kind (base_type, 6, type);
11399   assert (ffetype_size (type) == sizeof (ffetargetInteger3));
11400
11401   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER3]
11402     = t = make_unsigned_type (CHAR_TYPE_SIZE * 2);
11403   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned word"),
11404                         t));
11405
11406   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER4]
11407     = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11408   pushdecl (build_decl (TYPE_DECL, get_identifier ("integer4"),
11409                         t));
11410   type = ffetype_new ();
11411   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER4,
11412                     type);
11413   ffetype_set_ams (type,
11414                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11415                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11416   ffetype_set_star (base_type,
11417                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11418                     type);
11419   ffetype_set_kind (base_type, 2, type);
11420   assert (ffetype_size (type) == sizeof (ffetargetInteger4));
11421
11422   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER4]
11423     = t = make_unsigned_type (FLOAT_TYPE_SIZE * 2);
11424   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned4"),
11425                         t));
11426
11427 #if 0
11428   if (ffe_is_do_internal_checks ()
11429       && LONG_TYPE_SIZE != FLOAT_TYPE_SIZE
11430       && LONG_TYPE_SIZE != CHAR_TYPE_SIZE
11431       && LONG_TYPE_SIZE != SHORT_TYPE_SIZE
11432       && LONG_TYPE_SIZE != LONG_LONG_TYPE_SIZE)
11433     {
11434       fprintf (stderr, "Sorry, no g77 support for LONG_TYPE_SIZE (%d bits) yet.\n",
11435                LONG_TYPE_SIZE);
11436     }
11437 #endif
11438
11439   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL1]
11440     = t = make_signed_type (FLOAT_TYPE_SIZE);
11441   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical"),
11442                         t));
11443   type = ffetype_new ();
11444   base_type = type;
11445   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL1,
11446                     type);
11447   ffetype_set_ams (type,
11448                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11449                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11450   ffetype_set_star (base_type,
11451                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11452                     type);
11453   ffetype_set_kind (base_type, 1, type);
11454   assert (ffetype_size (type) == sizeof (ffetargetLogical1));
11455
11456   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL2]
11457     = t = make_signed_type (CHAR_TYPE_SIZE);
11458   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical2"),
11459                         t));
11460   type = ffetype_new ();
11461   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL2,
11462                     type);
11463   ffetype_set_ams (type,
11464                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11465                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11466   ffetype_set_star (base_type,
11467                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11468                     type);
11469   ffetype_set_kind (base_type, 3, type);
11470   assert (ffetype_size (type) == sizeof (ffetargetLogical2));
11471
11472   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL3]
11473     = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11474   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical3"),
11475                         t));
11476   type = ffetype_new ();
11477   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL3,
11478                     type);
11479   ffetype_set_ams (type,
11480                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11481                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11482   ffetype_set_star (base_type,
11483                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11484                     type);
11485   ffetype_set_kind (base_type, 6, type);
11486   assert (ffetype_size (type) == sizeof (ffetargetLogical3));
11487
11488   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL4]
11489     = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11490   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical4"),
11491                         t));
11492   type = ffetype_new ();
11493   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL4,
11494                     type);
11495   ffetype_set_ams (type,
11496                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11497                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11498   ffetype_set_star (base_type,
11499                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11500                     type);
11501   ffetype_set_kind (base_type, 2, type);
11502   assert (ffetype_size (type) == sizeof (ffetargetLogical4));
11503
11504   ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11505     = t = make_node (REAL_TYPE);
11506   TYPE_PRECISION (t) = FLOAT_TYPE_SIZE;
11507   pushdecl (build_decl (TYPE_DECL, get_identifier ("real"),
11508                         t));
11509   layout_type (t);
11510   type = ffetype_new ();
11511   base_type = type;
11512   ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL1,
11513                     type);
11514   ffetype_set_ams (type,
11515                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11516                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11517   ffetype_set_star (base_type,
11518                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11519                     type);
11520   ffetype_set_kind (base_type, 1, type);
11521   ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11522     = FFETARGET_f2cTYREAL;
11523   assert (ffetype_size (type) == sizeof (ffetargetReal1));
11524
11525   ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREALDOUBLE]
11526     = t = make_node (REAL_TYPE);
11527   TYPE_PRECISION (t) = FLOAT_TYPE_SIZE * 2;     /* Always twice REAL. */
11528   pushdecl (build_decl (TYPE_DECL, get_identifier ("double precision"),
11529                         t));
11530   layout_type (t);
11531   type = ffetype_new ();
11532   ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE,
11533                     type);
11534   ffetype_set_ams (type,
11535                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11536                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11537   ffetype_set_star (base_type,
11538                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11539                     type);
11540   ffetype_set_kind (base_type, 2, type);
11541   ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]
11542     = FFETARGET_f2cTYDREAL;
11543   assert (ffetype_size (type) == sizeof (ffetargetReal2));
11544
11545   ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11546     = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]);
11547   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex"),
11548                         t));
11549   type = ffetype_new ();
11550   base_type = type;
11551   ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL1,
11552                     type);
11553   ffetype_set_ams (type,
11554                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11555                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11556   ffetype_set_star (base_type,
11557                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11558                     type);
11559   ffetype_set_kind (base_type, 1, type);
11560   ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11561     = FFETARGET_f2cTYCOMPLEX;
11562   assert (ffetype_size (type) == sizeof (ffetargetComplex1));
11563
11564   ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREALDOUBLE]
11565     = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]);
11566   pushdecl (build_decl (TYPE_DECL, get_identifier ("double complex"),
11567                         t));
11568   type = ffetype_new ();
11569   ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREALDOUBLE,
11570                     type);
11571   ffetype_set_ams (type,
11572                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11573                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11574   ffetype_set_star (base_type,
11575                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11576                     type);
11577   ffetype_set_kind (base_type, 2,
11578                     type);
11579   ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL2]
11580     = FFETARGET_f2cTYDCOMPLEX;
11581   assert (ffetype_size (type) == sizeof (ffetargetComplex2));
11582
11583   /* Make function and ptr-to-function types for non-CHARACTER types. */
11584
11585   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11586     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11587       {
11588         if ((t = ffecom_tree_type[i][j]) != NULL_TREE)
11589           {
11590             if (i == FFEINFO_basictypeINTEGER)
11591               {
11592                 /* Figure out the smallest INTEGER type that can hold
11593                    a pointer on this machine. */
11594                 if (GET_MODE_SIZE (TYPE_MODE (t))
11595                     >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
11596                   {
11597                     if ((ffecom_pointer_kind_ == FFEINFO_kindtypeNONE)
11598                         || (GET_MODE_SIZE (TYPE_MODE (ffecom_tree_type[i][ffecom_pointer_kind_]))
11599                             > GET_MODE_SIZE (TYPE_MODE (t))))
11600                       ffecom_pointer_kind_ = j;
11601                   }
11602               }
11603             else if (i == FFEINFO_basictypeCOMPLEX)
11604               t = void_type_node;
11605             /* For f2c compatibility, REAL functions are really
11606                implemented as DOUBLE PRECISION.  */
11607             else if ((i == FFEINFO_basictypeREAL)
11608                      && (j == FFEINFO_kindtypeREAL1))
11609               t = ffecom_tree_type
11610                 [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2];
11611
11612             t = ffecom_tree_fun_type[i][j] = build_function_type (t,
11613                                                                   NULL_TREE);
11614             ffecom_tree_ptr_to_fun_type[i][j] = build_pointer_type (t);
11615           }
11616       }
11617
11618   /* Set up pointer types.  */
11619
11620   if (ffecom_pointer_kind_ == FFEINFO_basictypeNONE)
11621     fatal_error ("no INTEGER type can hold a pointer on this configuration");
11622   else if (0 && ffe_is_do_internal_checks ())
11623     fprintf (stderr, "Pointer type kt=%d\n", ffecom_pointer_kind_);
11624   ffetype_set_kind (ffeinfo_type (FFEINFO_basictypeINTEGER,
11625                                   FFEINFO_kindtypeINTEGERDEFAULT),
11626                     7,
11627                     ffeinfo_type (FFEINFO_basictypeINTEGER,
11628                                   ffecom_pointer_kind_));
11629
11630   if (ffe_is_ugly_assign ())
11631     ffecom_label_kind_ = ffecom_pointer_kind_;  /* Require ASSIGN etc to this. */
11632   else
11633     ffecom_label_kind_ = FFEINFO_kindtypeINTEGERDEFAULT;
11634   if (0 && ffe_is_do_internal_checks ())
11635     fprintf (stderr, "Label type kt=%d\n", ffecom_label_kind_);
11636
11637   ffecom_integer_type_node
11638     = ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1];
11639   ffecom_integer_zero_node = convert (ffecom_integer_type_node,
11640                                       integer_zero_node);
11641   ffecom_integer_one_node = convert (ffecom_integer_type_node,
11642                                      integer_one_node);
11643
11644   /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional.
11645      Turns out that by TYLONG, runtime/libI77/lio.h really means
11646      "whatever size an ftnint is".  For consistency and sanity,
11647      com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen
11648      all are INTEGER, which we also make out of whatever back-end
11649      integer type is FLOAT_TYPE_SIZE bits wide.  This change, from
11650      LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to
11651      accommodate machines like the Alpha.  Note that this suggests
11652      f2c and libf2c are missing a distinction perhaps needed on
11653      some machines between "int" and "long int".  -- burley 0.5.5 950215 */
11654
11655   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, FLOAT_TYPE_SIZE,
11656                             FFETARGET_f2cTYLONG);
11657   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, SHORT_TYPE_SIZE,
11658                             FFETARGET_f2cTYSHORT);
11659   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, CHAR_TYPE_SIZE,
11660                             FFETARGET_f2cTYINT1);
11661   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, LONG_LONG_TYPE_SIZE,
11662                             FFETARGET_f2cTYQUAD);
11663   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, FLOAT_TYPE_SIZE,
11664                             FFETARGET_f2cTYLOGICAL);
11665   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, SHORT_TYPE_SIZE,
11666                             FFETARGET_f2cTYLOGICAL2);
11667   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, CHAR_TYPE_SIZE,
11668                             FFETARGET_f2cTYLOGICAL1);
11669   /* ~~~Not really such a type in libf2c, e.g. I/O support?  */
11670   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, LONG_LONG_TYPE_SIZE,
11671                             FFETARGET_f2cTYQUAD);
11672
11673   /* CHARACTER stuff is all special-cased, so it is not handled in the above
11674      loop.  CHARACTER items are built as arrays of unsigned char.  */
11675
11676   ffecom_tree_type[FFEINFO_basictypeCHARACTER]
11677     [FFEINFO_kindtypeCHARACTER1] = t = char_type_node;
11678   type = ffetype_new ();
11679   base_type = type;
11680   ffeinfo_set_type (FFEINFO_basictypeCHARACTER,
11681                     FFEINFO_kindtypeCHARACTER1,
11682                     type);
11683   ffetype_set_ams (type,
11684                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11685                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11686   ffetype_set_kind (base_type, 1, type);
11687   assert (ffetype_size (type)
11688           == sizeof (((ffetargetCharacter1) { 0, NULL }).text[0]));
11689
11690   ffecom_tree_fun_type[FFEINFO_basictypeCHARACTER]
11691     [FFEINFO_kindtypeCHARACTER1] = ffecom_tree_fun_type_void;
11692   ffecom_tree_ptr_to_fun_type[FFEINFO_basictypeCHARACTER]
11693     [FFEINFO_kindtypeCHARACTER1]
11694     = ffecom_tree_ptr_to_fun_type_void;
11695   ffecom_f2c_typecode_[FFEINFO_basictypeCHARACTER][FFEINFO_kindtypeCHARACTER1]
11696     = FFETARGET_f2cTYCHAR;
11697
11698   ffecom_f2c_typecode_[FFEINFO_basictypeANY][FFEINFO_kindtypeANY]
11699     = 0;
11700
11701   /* Make multi-return-value type and fields. */
11702
11703   ffecom_multi_type_node_ = make_node (UNION_TYPE);
11704
11705   field = NULL_TREE;
11706
11707   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11708     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11709       {
11710         char name[30];
11711
11712         if (ffecom_tree_type[i][j] == NULL_TREE)
11713           continue;             /* Not supported. */
11714         sprintf (&name[0], "bt_%s_kt_%s",
11715                  ffeinfo_basictype_string ((ffeinfoBasictype) i),
11716                  ffeinfo_kindtype_string ((ffeinfoKindtype) j));
11717         ffecom_multi_fields_[i][j] = build_decl (FIELD_DECL,
11718                                                  get_identifier (name),
11719                                                  ffecom_tree_type[i][j]);
11720         DECL_CONTEXT (ffecom_multi_fields_[i][j])
11721           = ffecom_multi_type_node_;
11722         DECL_ALIGN (ffecom_multi_fields_[i][j]) = 0;
11723         DECL_USER_ALIGN (ffecom_multi_fields_[i][j]) = 0;
11724         TREE_CHAIN (ffecom_multi_fields_[i][j]) = field;
11725         field = ffecom_multi_fields_[i][j];
11726       }
11727
11728   TYPE_FIELDS (ffecom_multi_type_node_) = field;
11729   layout_type (ffecom_multi_type_node_);
11730
11731   /* Subroutines usually return integer because they might have alternate
11732      returns. */
11733
11734   ffecom_tree_subr_type
11735     = build_function_type (integer_type_node, NULL_TREE);
11736   ffecom_tree_ptr_to_subr_type
11737     = build_pointer_type (ffecom_tree_subr_type);
11738   ffecom_tree_blockdata_type
11739     = build_function_type (void_type_node, NULL_TREE);
11740
11741   builtin_function ("__builtin_sqrtf", float_ftype_float,
11742                     BUILT_IN_SQRTF, BUILT_IN_NORMAL, "sqrtf", NULL_TREE);
11743   builtin_function ("__builtin_sqrt", double_ftype_double,
11744                     BUILT_IN_SQRT, BUILT_IN_NORMAL, "sqrt", NULL_TREE);
11745   builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble,
11746                     BUILT_IN_SQRTL, BUILT_IN_NORMAL, "sqrtl", NULL_TREE);
11747   builtin_function ("__builtin_sinf", float_ftype_float,
11748                     BUILT_IN_SINF, BUILT_IN_NORMAL, "sinf", NULL_TREE);
11749   builtin_function ("__builtin_sin", double_ftype_double,
11750                     BUILT_IN_SIN, BUILT_IN_NORMAL, "sin", NULL_TREE);
11751   builtin_function ("__builtin_sinl", ldouble_ftype_ldouble,
11752                     BUILT_IN_SINL, BUILT_IN_NORMAL, "sinl", NULL_TREE);
11753   builtin_function ("__builtin_cosf", float_ftype_float,
11754                     BUILT_IN_COSF, BUILT_IN_NORMAL, "cosf", NULL_TREE);
11755   builtin_function ("__builtin_cos", double_ftype_double,
11756                     BUILT_IN_COS, BUILT_IN_NORMAL, "cos", NULL_TREE);
11757   builtin_function ("__builtin_cosl", ldouble_ftype_ldouble,
11758                     BUILT_IN_COSL, BUILT_IN_NORMAL, "cosl", NULL_TREE);
11759
11760   pedantic_lvalues = FALSE;
11761
11762   ffecom_f2c_make_type_ (&ffecom_f2c_integer_type_node,
11763                          FFECOM_f2cINTEGER,
11764                          "integer");
11765   ffecom_f2c_make_type_ (&ffecom_f2c_address_type_node,
11766                          FFECOM_f2cADDRESS,
11767                          "address");
11768   ffecom_f2c_make_type_ (&ffecom_f2c_real_type_node,
11769                          FFECOM_f2cREAL,
11770                          "real");
11771   ffecom_f2c_make_type_ (&ffecom_f2c_doublereal_type_node,
11772                          FFECOM_f2cDOUBLEREAL,
11773                          "doublereal");
11774   ffecom_f2c_make_type_ (&ffecom_f2c_complex_type_node,
11775                          FFECOM_f2cCOMPLEX,
11776                          "complex");
11777   ffecom_f2c_make_type_ (&ffecom_f2c_doublecomplex_type_node,
11778                          FFECOM_f2cDOUBLECOMPLEX,
11779                          "doublecomplex");
11780   ffecom_f2c_make_type_ (&ffecom_f2c_longint_type_node,
11781                          FFECOM_f2cLONGINT,
11782                          "longint");
11783   ffecom_f2c_make_type_ (&ffecom_f2c_logical_type_node,
11784                          FFECOM_f2cLOGICAL,
11785                          "logical");
11786   ffecom_f2c_make_type_ (&ffecom_f2c_flag_type_node,
11787                          FFECOM_f2cFLAG,
11788                          "flag");
11789   ffecom_f2c_make_type_ (&ffecom_f2c_ftnlen_type_node,
11790                          FFECOM_f2cFTNLEN,
11791                          "ftnlen");
11792   ffecom_f2c_make_type_ (&ffecom_f2c_ftnint_type_node,
11793                          FFECOM_f2cFTNINT,
11794                          "ftnint");
11795
11796   ffecom_f2c_ftnlen_zero_node
11797     = convert (ffecom_f2c_ftnlen_type_node, integer_zero_node);
11798
11799   ffecom_f2c_ftnlen_one_node
11800     = convert (ffecom_f2c_ftnlen_type_node, integer_one_node);
11801
11802   ffecom_f2c_ftnlen_two_node = build_int_2 (2, 0);
11803   TREE_TYPE (ffecom_f2c_ftnlen_two_node) = ffecom_integer_type_node;
11804
11805   ffecom_f2c_ptr_to_ftnlen_type_node
11806     = build_pointer_type (ffecom_f2c_ftnlen_type_node);
11807
11808   ffecom_f2c_ptr_to_ftnint_type_node
11809     = build_pointer_type (ffecom_f2c_ftnint_type_node);
11810
11811   ffecom_f2c_ptr_to_integer_type_node
11812     = build_pointer_type (ffecom_f2c_integer_type_node);
11813
11814   ffecom_f2c_ptr_to_real_type_node
11815     = build_pointer_type (ffecom_f2c_real_type_node);
11816
11817   ffecom_float_zero_ = build_real (float_type_node, dconst0);
11818   ffecom_double_zero_ = build_real (double_type_node, dconst0);
11819   {
11820     REAL_VALUE_TYPE point_5;
11821
11822     REAL_ARITHMETIC (point_5, RDIV_EXPR, dconst1, dconst2);
11823     ffecom_float_half_ = build_real (float_type_node, point_5);
11824     ffecom_double_half_ = build_real (double_type_node, point_5);
11825   }
11826
11827   /* Do "extern int xargc;".  */
11828
11829   ffecom_tree_xargc_ = build_decl (VAR_DECL,
11830                                    get_identifier ("f__xargc"),
11831                                    integer_type_node);
11832   DECL_EXTERNAL (ffecom_tree_xargc_) = 1;
11833   TREE_STATIC (ffecom_tree_xargc_) = 1;
11834   TREE_PUBLIC (ffecom_tree_xargc_) = 1;
11835   ffecom_tree_xargc_ = start_decl (ffecom_tree_xargc_, FALSE);
11836   finish_decl (ffecom_tree_xargc_, NULL_TREE, FALSE);
11837
11838 #if 0   /* This is being fixed, and seems to be working now. */
11839   if ((FLOAT_TYPE_SIZE != 32)
11840       || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))) != 32))
11841     {
11842       warning ("configuration: REAL, INTEGER, and LOGICAL are %d bits wide,",
11843                (int) FLOAT_TYPE_SIZE);
11844       warning ("and pointers are %d bits wide, but g77 doesn't yet work",
11845           (int) TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))));
11846       warning ("properly unless they all are 32 bits wide");
11847       warning ("Please keep this in mind before you report bugs.");
11848     }
11849 #endif
11850
11851 #if 0   /* Code in ste.c that would crash has been commented out. */
11852   if (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)
11853       < TYPE_PRECISION (string_type_node))
11854     /* I/O will probably crash.  */
11855     warning ("configuration: char * holds %d bits, but ftnlen only %d",
11856              TYPE_PRECISION (string_type_node),
11857              TYPE_PRECISION (ffecom_f2c_ftnlen_type_node));
11858 #endif
11859
11860 #if 0   /* ASSIGN-related stuff has been changed to accommodate this. */
11861   if (TYPE_PRECISION (ffecom_integer_type_node)
11862       < TYPE_PRECISION (string_type_node))
11863     /* ASSIGN 10 TO I will crash.  */
11864     warning ("configuration: char * holds %d bits, but INTEGER only %d --\n\
11865  ASSIGN statement might fail",
11866              TYPE_PRECISION (string_type_node),
11867              TYPE_PRECISION (ffecom_integer_type_node));
11868 #endif
11869 }
11870
11871 /* ffecom_init_2 -- Initialize
11872
11873    ffecom_init_2();  */
11874
11875 void
11876 ffecom_init_2 ()
11877 {
11878   assert (ffecom_outer_function_decl_ == NULL_TREE);
11879   assert (current_function_decl == NULL_TREE);
11880   assert (ffecom_which_entrypoint_decl_ == NULL_TREE);
11881
11882   ffecom_master_arglist_ = NULL;
11883   ++ffecom_num_fns_;
11884   ffecom_primary_entry_ = NULL;
11885   ffecom_is_altreturning_ = FALSE;
11886   ffecom_func_result_ = NULL_TREE;
11887   ffecom_multi_retval_ = NULL_TREE;
11888 }
11889
11890 /* ffecom_list_expr -- Transform list of exprs into gcc tree
11891
11892    tree t;
11893    ffebld expr;  // FFE opITEM list.
11894    tree = ffecom_list_expr(expr);
11895
11896    List of actual args is transformed into corresponding gcc backend list.  */
11897
11898 tree
11899 ffecom_list_expr (ffebld expr)
11900 {
11901   tree list;
11902   tree *plist = &list;
11903   tree trail = NULL_TREE;       /* Append char length args here. */
11904   tree *ptrail = &trail;
11905   tree length;
11906
11907   while (expr != NULL)
11908     {
11909       tree texpr = ffecom_arg_expr (ffebld_head (expr), &length);
11910
11911       if (texpr == error_mark_node)
11912         return error_mark_node;
11913
11914       *plist = build_tree_list (NULL_TREE, texpr);
11915       plist = &TREE_CHAIN (*plist);
11916       expr = ffebld_trail (expr);
11917       if (length != NULL_TREE)
11918         {
11919           *ptrail = build_tree_list (NULL_TREE, length);
11920           ptrail = &TREE_CHAIN (*ptrail);
11921         }
11922     }
11923
11924   *plist = trail;
11925
11926   return list;
11927 }
11928
11929 /* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree
11930
11931    tree t;
11932    ffebld expr;  // FFE opITEM list.
11933    tree = ffecom_list_ptr_to_expr(expr);
11934
11935    List of actual args is transformed into corresponding gcc backend list for
11936    use in calling an external procedure (vs. a statement function).  */
11937
11938 tree
11939 ffecom_list_ptr_to_expr (ffebld expr)
11940 {
11941   tree list;
11942   tree *plist = &list;
11943   tree trail = NULL_TREE;       /* Append char length args here. */
11944   tree *ptrail = &trail;
11945   tree length;
11946
11947   while (expr != NULL)
11948     {
11949       tree texpr = ffecom_arg_ptr_to_expr (ffebld_head (expr), &length);
11950
11951       if (texpr == error_mark_node)
11952         return error_mark_node;
11953
11954       *plist = build_tree_list (NULL_TREE, texpr);
11955       plist = &TREE_CHAIN (*plist);
11956       expr = ffebld_trail (expr);
11957       if (length != NULL_TREE)
11958         {
11959           *ptrail = build_tree_list (NULL_TREE, length);
11960           ptrail = &TREE_CHAIN (*ptrail);
11961         }
11962     }
11963
11964   *plist = trail;
11965
11966   return list;
11967 }
11968
11969 /* Obtain gcc's LABEL_DECL tree for label.  */
11970
11971 tree
11972 ffecom_lookup_label (ffelab label)
11973 {
11974   tree glabel;
11975
11976   if (ffelab_hook (label) == NULL_TREE)
11977     {
11978       char labelname[16];
11979
11980       switch (ffelab_type (label))
11981         {
11982         case FFELAB_typeLOOPEND:
11983         case FFELAB_typeNOTLOOP:
11984         case FFELAB_typeENDIF:
11985           sprintf (labelname, "%" ffelabValue_f "u", ffelab_value (label));
11986           glabel = build_decl (LABEL_DECL, get_identifier (labelname),
11987                                void_type_node);
11988           DECL_CONTEXT (glabel) = current_function_decl;
11989           DECL_MODE (glabel) = VOIDmode;
11990           break;
11991
11992         case FFELAB_typeFORMAT:
11993           glabel = build_decl (VAR_DECL,
11994                                ffecom_get_invented_identifier
11995                                ("__g77_format_%d", (int) ffelab_value (label)),
11996                                build_type_variant (build_array_type
11997                                                    (char_type_node,
11998                                                     NULL_TREE),
11999                                                    1, 0));
12000           TREE_CONSTANT (glabel) = 1;
12001           TREE_STATIC (glabel) = 1;
12002           DECL_CONTEXT (glabel) = current_function_decl;
12003           DECL_INITIAL (glabel) = NULL;
12004           make_decl_rtl (glabel, NULL);
12005           expand_decl (glabel);
12006
12007           ffecom_save_tree_forever (glabel);
12008
12009           break;
12010
12011         case FFELAB_typeANY:
12012           glabel = error_mark_node;
12013           break;
12014
12015         default:
12016           assert ("bad label type" == NULL);
12017           glabel = NULL;
12018           break;
12019         }
12020       ffelab_set_hook (label, glabel);
12021     }
12022   else
12023     {
12024       glabel = ffelab_hook (label);
12025     }
12026
12027   return glabel;
12028 }
12029
12030 /* Stabilizes the arguments.  Don't use this if the lhs and rhs come from
12031    a single source specification (as in the fourth argument of MVBITS).
12032    If the type is NULL_TREE, the type of lhs is used to make the type of
12033    the MODIFY_EXPR.  */
12034
12035 tree
12036 ffecom_modify (tree newtype, tree lhs,
12037                tree rhs)
12038 {
12039   if (lhs == error_mark_node || rhs == error_mark_node)
12040     return error_mark_node;
12041
12042   if (newtype == NULL_TREE)
12043     newtype = TREE_TYPE (lhs);
12044
12045   if (TREE_SIDE_EFFECTS (lhs))
12046     lhs = stabilize_reference (lhs);
12047
12048   return ffecom_2s (MODIFY_EXPR, newtype, lhs, rhs);
12049 }
12050
12051 /* Register source file name.  */
12052
12053 void
12054 ffecom_file (const char *name)
12055 {
12056   ffecom_file_ (name);
12057 }
12058
12059 /* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed
12060
12061    ffestorag st;
12062    ffecom_notify_init_storage(st);
12063
12064    Gets called when all possible units in an aggregate storage area (a LOCAL
12065    with equivalences or a COMMON) have been initialized.  The initialization
12066    info either is in ffestorag_init or, if that is NULL,
12067    ffestorag_accretion:
12068
12069    ffestorag_init may contain an opCONTER or opARRTER.  opCONTER may occur
12070    even for an array if the array is one element in length!
12071
12072    ffestorag_accretion will contain an opACCTER.  It is much like an
12073    opARRTER except it has an ffebit object in it instead of just a size.
12074    The back end can use the info in the ffebit object, if it wants, to
12075    reduce the amount of actual initialization, but in any case it should
12076    kill the ffebit object when done.  Also, set accretion to NULL but
12077    init to a non-NULL value.
12078
12079    After performing initialization, DO NOT set init to NULL, because that'll
12080    tell the front end it is ok for more initialization to happen.  Instead,
12081    set init to an opANY expression or some such thing that you can use to
12082    tell that you've already initialized the object.
12083
12084    27-Oct-91  JCB  1.1
12085       Support two-pass FFE.  */
12086
12087 void
12088 ffecom_notify_init_storage (ffestorag st)
12089 {
12090   ffebld init;                  /* The initialization expression. */
12091
12092   if (ffestorag_init (st) == NULL)
12093     {
12094       init = ffestorag_accretion (st);
12095       assert (init != NULL);
12096       ffestorag_set_accretion (st, NULL);
12097       ffestorag_set_accretes (st, 0);
12098       ffestorag_set_init (st, init);
12099     }
12100 }
12101
12102 /* ffecom_notify_init_symbol -- A symbol is now fully init'ed
12103
12104    ffesymbol s;
12105    ffecom_notify_init_symbol(s);
12106
12107    Gets called when all possible units in a symbol (not placed in COMMON
12108    or involved in EQUIVALENCE, unless it as yet has no ffestorag object)
12109    have been initialized.  The initialization info either is in
12110    ffesymbol_init or, if that is NULL, ffesymbol_accretion:
12111
12112    ffesymbol_init may contain an opCONTER or opARRTER.  opCONTER may occur
12113    even for an array if the array is one element in length!
12114
12115    ffesymbol_accretion will contain an opACCTER.  It is much like an
12116    opARRTER except it has an ffebit object in it instead of just a size.
12117    The back end can use the info in the ffebit object, if it wants, to
12118    reduce the amount of actual initialization, but in any case it should
12119    kill the ffebit object when done.  Also, set accretion to NULL but
12120    init to a non-NULL value.
12121
12122    After performing initialization, DO NOT set init to NULL, because that'll
12123    tell the front end it is ok for more initialization to happen.  Instead,
12124    set init to an opANY expression or some such thing that you can use to
12125    tell that you've already initialized the object.
12126
12127    27-Oct-91  JCB  1.1
12128       Support two-pass FFE.  */
12129
12130 void
12131 ffecom_notify_init_symbol (ffesymbol s)
12132 {
12133   ffebld init;                  /* The initialization expression. */
12134
12135   if (ffesymbol_storage (s) == NULL)
12136     return;                     /* Do nothing until COMMON/EQUIVALENCE
12137                                    possibilities checked. */
12138
12139   if ((ffesymbol_init (s) == NULL)
12140       && ((init = ffesymbol_accretion (s)) != NULL))
12141     {
12142       ffesymbol_set_accretion (s, NULL);
12143       ffesymbol_set_accretes (s, 0);
12144       ffesymbol_set_init (s, init);
12145     }
12146 }
12147
12148 /* ffecom_notify_primary_entry -- Learn which is the primary entry point
12149
12150    ffesymbol s;
12151    ffecom_notify_primary_entry(s);
12152
12153    Gets called when implicit or explicit PROGRAM statement seen or when
12154    FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary
12155    global symbol that serves as the entry point.  */
12156
12157 void
12158 ffecom_notify_primary_entry (ffesymbol s)
12159 {
12160   ffecom_primary_entry_ = s;
12161   ffecom_primary_entry_kind_ = ffesymbol_kind (s);
12162
12163   if ((ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
12164       || (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE))
12165     ffecom_primary_entry_is_proc_ = TRUE;
12166   else
12167     ffecom_primary_entry_is_proc_ = FALSE;
12168
12169   if (!ffe_is_silent ())
12170     {
12171       if (ffecom_primary_entry_kind_ == FFEINFO_kindPROGRAM)
12172         fprintf (stderr, "%s:\n", ffesymbol_text (s));
12173       else
12174         fprintf (stderr, "  %s:\n", ffesymbol_text (s));
12175     }
12176
12177   if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
12178     {
12179       ffebld list;
12180       ffebld arg;
12181
12182       for (list = ffesymbol_dummyargs (s);
12183            list != NULL;
12184            list = ffebld_trail (list))
12185         {
12186           arg = ffebld_head (list);
12187           if (ffebld_op (arg) == FFEBLD_opSTAR)
12188             {
12189               ffecom_is_altreturning_ = TRUE;
12190               break;
12191             }
12192         }
12193     }
12194 }
12195
12196 FILE *
12197 ffecom_open_include (char *name, ffewhereLine l, ffewhereColumn c)
12198 {
12199   return ffecom_open_include_ (name, l, c);
12200 }
12201
12202 /* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front
12203
12204    tree t;
12205    ffebld expr;  // FFE expression.
12206    tree = ffecom_ptr_to_expr(expr);
12207
12208    Like ffecom_expr, but sticks address-of in front of most things.  */
12209
12210 tree
12211 ffecom_ptr_to_expr (ffebld expr)
12212 {
12213   tree item;
12214   ffeinfoBasictype bt;
12215   ffeinfoKindtype kt;
12216   ffesymbol s;
12217
12218   assert (expr != NULL);
12219
12220   switch (ffebld_op (expr))
12221     {
12222     case FFEBLD_opSYMTER:
12223       s = ffebld_symter (expr);
12224       if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
12225         {
12226           ffecomGfrt ix;
12227
12228           ix = ffeintrin_gfrt_indirect (ffebld_symter_implementation (expr));
12229           assert (ix != FFECOM_gfrt);
12230           if ((item = ffecom_gfrt_[ix]) == NULL_TREE)
12231             {
12232               ffecom_make_gfrt_ (ix);
12233               item = ffecom_gfrt_[ix];
12234             }
12235         }
12236       else
12237         {
12238           item = ffesymbol_hook (s).decl_tree;
12239           if (item == NULL_TREE)
12240             {
12241               s = ffecom_sym_transform_ (s);
12242               item = ffesymbol_hook (s).decl_tree;
12243             }
12244         }
12245       assert (item != NULL);
12246       if (item == error_mark_node)
12247         return item;
12248       if (!ffesymbol_hook (s).addr)
12249         item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12250                          item);
12251       return item;
12252
12253     case FFEBLD_opARRAYREF:
12254       return ffecom_arrayref_ (NULL_TREE, expr, 1);
12255
12256     case FFEBLD_opCONTER:
12257
12258       bt = ffeinfo_basictype (ffebld_info (expr));
12259       kt = ffeinfo_kindtype (ffebld_info (expr));
12260
12261       item = ffecom_constantunion (&ffebld_constant_union
12262                                    (ffebld_conter (expr)), bt, kt,
12263                                    ffecom_tree_type[bt][kt]);
12264       if (item == error_mark_node)
12265         return error_mark_node;
12266       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12267                        item);
12268       return item;
12269
12270     case FFEBLD_opANY:
12271       return error_mark_node;
12272
12273     default:
12274       bt = ffeinfo_basictype (ffebld_info (expr));
12275       kt = ffeinfo_kindtype (ffebld_info (expr));
12276
12277       item = ffecom_expr (expr);
12278       if (item == error_mark_node)
12279         return error_mark_node;
12280
12281       /* The back end currently optimizes a bit too zealously for us, in that
12282          we fail JCB001 if the following block of code is omitted.  It checks
12283          to see if the transformed expression is a symbol or array reference,
12284          and encloses it in a SAVE_EXPR if that is the case.  */
12285
12286       STRIP_NOPS (item);
12287       if ((TREE_CODE (item) == VAR_DECL)
12288           || (TREE_CODE (item) == PARM_DECL)
12289           || (TREE_CODE (item) == RESULT_DECL)
12290           || (TREE_CODE (item) == INDIRECT_REF)
12291           || (TREE_CODE (item) == ARRAY_REF)
12292           || (TREE_CODE (item) == COMPONENT_REF)
12293 #ifdef OFFSET_REF
12294           || (TREE_CODE (item) == OFFSET_REF)
12295 #endif
12296           || (TREE_CODE (item) == BUFFER_REF)
12297           || (TREE_CODE (item) == REALPART_EXPR)
12298           || (TREE_CODE (item) == IMAGPART_EXPR))
12299         {
12300           item = ffecom_save_tree (item);
12301         }
12302
12303       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12304                        item);
12305       return item;
12306     }
12307
12308   assert ("fall-through error" == NULL);
12309   return error_mark_node;
12310 }
12311
12312 /* Obtain a temp var with given data type.
12313
12314    size is FFETARGET_charactersizeNONE for a non-CHARACTER type
12315    or >= 0 for a CHARACTER type.
12316
12317    elements is -1 for a scalar or > 0 for an array of type.  */
12318
12319 tree
12320 ffecom_make_tempvar (const char *commentary, tree type,
12321                      ffetargetCharacterSize size, int elements)
12322 {
12323   tree t;
12324   static int mynumber;
12325
12326   assert (current_binding_level->prep_state < 2);
12327
12328   if (type == error_mark_node)
12329     return error_mark_node;
12330
12331   if (size != FFETARGET_charactersizeNONE)
12332     type = build_array_type (type,
12333                              build_range_type (ffecom_f2c_ftnlen_type_node,
12334                                                ffecom_f2c_ftnlen_one_node,
12335                                                build_int_2 (size, 0)));
12336   if (elements != -1)
12337     type = build_array_type (type,
12338                              build_range_type (integer_type_node,
12339                                                integer_zero_node,
12340                                                build_int_2 (elements - 1,
12341                                                             0)));
12342   t = build_decl (VAR_DECL,
12343                   ffecom_get_invented_identifier ("__g77_%s_%d",
12344                                                   commentary,
12345                                                   mynumber++),
12346                   type);
12347
12348   t = start_decl (t, FALSE);
12349   finish_decl (t, NULL_TREE, FALSE);
12350
12351   return t;
12352 }
12353
12354 /* Prepare argument pointer to expression.
12355
12356    Like ffecom_prepare_expr, except for expressions to be evaluated
12357    via ffecom_arg_ptr_to_expr.  */
12358
12359 void
12360 ffecom_prepare_arg_ptr_to_expr (ffebld expr)
12361 {
12362   /* ~~For now, it seems to be the same thing.  */
12363   ffecom_prepare_expr (expr);
12364   return;
12365 }
12366
12367 /* End of preparations.  */
12368
12369 bool
12370 ffecom_prepare_end (void)
12371 {
12372   int prep_state = current_binding_level->prep_state;
12373
12374   assert (prep_state < 2);
12375   current_binding_level->prep_state = 2;
12376
12377   return (prep_state == 1) ? TRUE : FALSE;
12378 }
12379
12380 /* Prepare expression.
12381
12382    This is called before any code is generated for the current block.
12383    It scans the expression, declares any temporaries that might be needed
12384    during evaluation of the expression, and stores those temporaries in
12385    the appropriate "hook" fields of the expression.  `dest', if not NULL,
12386    specifies the destination that ffecom_expr_ will see, in case that
12387    helps avoid generating unused temporaries.
12388
12389    ~~Improve to avoid allocating unused temporaries by taking `dest'
12390    into account vis-a-vis aliasing requirements of complex/character
12391    functions.  */
12392
12393 void
12394 ffecom_prepare_expr_ (ffebld expr, ffebld dest UNUSED)
12395 {
12396   ffeinfoBasictype bt;
12397   ffeinfoKindtype kt;
12398   ffetargetCharacterSize sz;
12399   tree tempvar = NULL_TREE;
12400
12401   assert (current_binding_level->prep_state < 2);
12402
12403   if (! expr)
12404     return;
12405
12406   bt = ffeinfo_basictype (ffebld_info (expr));
12407   kt = ffeinfo_kindtype (ffebld_info (expr));
12408   sz = ffeinfo_size (ffebld_info (expr));
12409
12410   /* Generate whatever temporaries are needed to represent the result
12411      of the expression.  */
12412
12413   if (bt == FFEINFO_basictypeCHARACTER)
12414     {
12415       while (ffebld_op (expr) == FFEBLD_opPAREN)
12416         expr = ffebld_left (expr);
12417     }
12418
12419   switch (ffebld_op (expr))
12420     {
12421     default:
12422       /* Don't make temps for SYMTER, CONTER, etc.  */
12423       if (ffebld_arity (expr) == 0)
12424         break;
12425
12426       switch (bt)
12427         {
12428         case FFEINFO_basictypeCOMPLEX:
12429           if (ffebld_op (expr) == FFEBLD_opFUNCREF)
12430             {
12431               ffesymbol s;
12432
12433               if (ffebld_op (ffebld_left (expr)) != FFEBLD_opSYMTER)
12434                 break;
12435
12436               s = ffebld_symter (ffebld_left (expr));
12437               if (ffesymbol_where (s) == FFEINFO_whereCONSTANT
12438                   || (ffesymbol_where (s) != FFEINFO_whereINTRINSIC
12439                       && ! ffesymbol_is_f2c (s))
12440                   || (ffesymbol_where (s) == FFEINFO_whereINTRINSIC
12441                       && ! ffe_is_f2c_library ()))
12442                 break;
12443             }
12444           else if (ffebld_op (expr) == FFEBLD_opPOWER)
12445             {
12446               /* Requires special treatment.  There's no POW_CC function
12447                  in libg2c, so POW_ZZ is used, which means we always
12448                  need a double-complex temp, not a single-complex.  */
12449               kt = FFEINFO_kindtypeREAL2;
12450             }
12451           else if (ffebld_op (expr) != FFEBLD_opDIVIDE)
12452             /* The other ops don't need temps for complex operands.  */
12453             break;
12454
12455           /* ~~~Avoid making temps for some intrinsics, such as AIMAG(C),
12456              REAL(C).  See 19990325-0.f, routine `check', for cases.  */
12457           tempvar = ffecom_make_tempvar ("complex",
12458                                          ffecom_tree_type
12459                                          [FFEINFO_basictypeCOMPLEX][kt],
12460                                          FFETARGET_charactersizeNONE,
12461                                          -1);
12462           break;
12463
12464         case FFEINFO_basictypeCHARACTER:
12465           if (ffebld_op (expr) != FFEBLD_opFUNCREF)
12466             break;
12467
12468           if (sz == FFETARGET_charactersizeNONE)
12469             /* ~~Kludge alert!  This should someday be fixed. */
12470             sz = 24;
12471
12472           tempvar = ffecom_make_tempvar ("char", char_type_node, sz, -1);
12473           break;
12474
12475         default:
12476           break;
12477         }
12478       break;
12479
12480     case FFEBLD_opCONCATENATE:
12481       {
12482         /* This gets special handling, because only one set of temps
12483            is needed for a tree of these -- the tree is treated as
12484            a flattened list of concatenations when generating code.  */
12485
12486         ffecomConcatList_ catlist;
12487         tree ltmp, itmp, result;
12488         int count;
12489         int i;
12490
12491         catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
12492         count = ffecom_concat_list_count_ (catlist);
12493
12494         if (count >= 2)
12495           {
12496             ltmp
12497               = ffecom_make_tempvar ("concat_len",
12498                                      ffecom_f2c_ftnlen_type_node,
12499                                      FFETARGET_charactersizeNONE, count);
12500             itmp
12501               = ffecom_make_tempvar ("concat_item",
12502                                      ffecom_f2c_address_type_node,
12503                                      FFETARGET_charactersizeNONE, count);
12504             result
12505               = ffecom_make_tempvar ("concat_res",
12506                                      char_type_node,
12507                                      ffecom_concat_list_maxlen_ (catlist),
12508                                      -1);
12509
12510             tempvar = make_tree_vec (3);
12511             TREE_VEC_ELT (tempvar, 0) = ltmp;
12512             TREE_VEC_ELT (tempvar, 1) = itmp;
12513             TREE_VEC_ELT (tempvar, 2) = result;
12514           }
12515
12516         for (i = 0; i < count; ++i)
12517           ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist,
12518                                                                     i));
12519
12520         ffecom_concat_list_kill_ (catlist);
12521
12522         if (tempvar)
12523           {
12524             ffebld_nonter_set_hook (expr, tempvar);
12525             current_binding_level->prep_state = 1;
12526           }
12527       }
12528       return;
12529
12530     case FFEBLD_opCONVERT:
12531       if (bt == FFEINFO_basictypeCHARACTER
12532           && ((ffebld_size_known (ffebld_left (expr))
12533                == FFETARGET_charactersizeNONE)
12534               || (ffebld_size_known (ffebld_left (expr)) >= sz)))
12535         tempvar = ffecom_make_tempvar ("convert", char_type_node, sz, -1);
12536       break;
12537     }
12538
12539   if (tempvar)
12540     {
12541       ffebld_nonter_set_hook (expr, tempvar);
12542       current_binding_level->prep_state = 1;
12543     }
12544
12545   /* Prepare subexpressions for this expr.  */
12546
12547   switch (ffebld_op (expr))
12548     {
12549     case FFEBLD_opPERCENT_LOC:
12550       ffecom_prepare_ptr_to_expr (ffebld_left (expr));
12551       break;
12552
12553     case FFEBLD_opPERCENT_VAL:
12554     case FFEBLD_opPERCENT_REF:
12555       ffecom_prepare_expr (ffebld_left (expr));
12556       break;
12557
12558     case FFEBLD_opPERCENT_DESCR:
12559       ffecom_prepare_arg_ptr_to_expr (ffebld_left (expr));
12560       break;
12561
12562     case FFEBLD_opITEM:
12563       {
12564         ffebld item;
12565
12566         for (item = expr;
12567              item != NULL;
12568              item = ffebld_trail (item))
12569           if (ffebld_head (item) != NULL)
12570             ffecom_prepare_expr (ffebld_head (item));
12571       }
12572       break;
12573
12574     default:
12575       /* Need to handle character conversion specially.  */
12576       switch (ffebld_arity (expr))
12577         {
12578         case 2:
12579           ffecom_prepare_expr (ffebld_left (expr));
12580           ffecom_prepare_expr (ffebld_right (expr));
12581           break;
12582
12583         case 1:
12584           ffecom_prepare_expr (ffebld_left (expr));
12585           break;
12586
12587         default:
12588           break;
12589         }
12590     }
12591
12592   return;
12593 }
12594
12595 /* Prepare expression for reading and writing.
12596
12597    Like ffecom_prepare_expr, except for expressions to be evaluated
12598    via ffecom_expr_rw.  */
12599
12600 void
12601 ffecom_prepare_expr_rw (tree type, ffebld expr)
12602 {
12603   /* This is all we support for now.  */
12604   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
12605
12606   /* ~~For now, it seems to be the same thing.  */
12607   ffecom_prepare_expr (expr);
12608   return;
12609 }
12610
12611 /* Prepare expression for writing.
12612
12613    Like ffecom_prepare_expr, except for expressions to be evaluated
12614    via ffecom_expr_w.  */
12615
12616 void
12617 ffecom_prepare_expr_w (tree type, ffebld expr)
12618 {
12619   /* This is all we support for now.  */
12620   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
12621
12622   /* ~~For now, it seems to be the same thing.  */
12623   ffecom_prepare_expr (expr);
12624   return;
12625 }
12626
12627 /* Prepare expression for returning.
12628
12629    Like ffecom_prepare_expr, except for expressions to be evaluated
12630    via ffecom_return_expr.  */
12631
12632 void
12633 ffecom_prepare_return_expr (ffebld expr)
12634 {
12635   assert (current_binding_level->prep_state < 2);
12636
12637   if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE
12638       && ffecom_is_altreturning_
12639       && expr != NULL)
12640     ffecom_prepare_expr (expr);
12641 }
12642
12643 /* Prepare pointer to expression.
12644
12645    Like ffecom_prepare_expr, except for expressions to be evaluated
12646    via ffecom_ptr_to_expr.  */
12647
12648 void
12649 ffecom_prepare_ptr_to_expr (ffebld expr)
12650 {
12651   /* ~~For now, it seems to be the same thing.  */
12652   ffecom_prepare_expr (expr);
12653   return;
12654 }
12655
12656 /* Transform expression into constant pointer-to-expression tree.
12657
12658    If the expression can be transformed into a pointer-to-expression tree
12659    that is constant, that is done, and the tree returned.  Else NULL_TREE
12660    is returned.
12661
12662    That way, a caller can attempt to provide compile-time initialization
12663    of a variable and, if that fails, *then* choose to start a new block
12664    and resort to using temporaries, as appropriate.  */
12665
12666 tree
12667 ffecom_ptr_to_const_expr (ffebld expr)
12668 {
12669   if (! expr)
12670     return integer_zero_node;
12671
12672   if (ffebld_op (expr) == FFEBLD_opANY)
12673     return error_mark_node;
12674
12675   if (ffebld_arity (expr) == 0
12676       && (ffebld_op (expr) != FFEBLD_opSYMTER
12677           || ffebld_where (expr) == FFEINFO_whereCOMMON
12678           || ffebld_where (expr) == FFEINFO_whereGLOBAL
12679           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
12680     {
12681       tree t;
12682
12683       t = ffecom_ptr_to_expr (expr);
12684       assert (TREE_CONSTANT (t));
12685       return t;
12686     }
12687
12688   return NULL_TREE;
12689 }
12690
12691 /* ffecom_return_expr -- Returns return-value expr given alt return expr
12692
12693    tree rtn;  // NULL_TREE means use expand_null_return()
12694    ffebld expr;  // NULL if no alt return expr to RETURN stmt
12695    rtn = ffecom_return_expr(expr);
12696
12697    Based on the program unit type and other info (like return function
12698    type, return master function type when alternate ENTRY points,
12699    whether subroutine has any alternate RETURN points, etc), returns the
12700    appropriate expression to be returned to the caller, or NULL_TREE
12701    meaning no return value or the caller expects it to be returned somewhere
12702    else (which is handled by other parts of this module).  */
12703
12704 tree
12705 ffecom_return_expr (ffebld expr)
12706 {
12707   tree rtn;
12708
12709   switch (ffecom_primary_entry_kind_)
12710     {
12711     case FFEINFO_kindPROGRAM:
12712     case FFEINFO_kindBLOCKDATA:
12713       rtn = NULL_TREE;
12714       break;
12715
12716     case FFEINFO_kindSUBROUTINE:
12717       if (!ffecom_is_altreturning_)
12718         rtn = NULL_TREE;        /* No alt returns, never an expr. */
12719       else if (expr == NULL)
12720         rtn = integer_zero_node;
12721       else
12722         rtn = ffecom_expr (expr);
12723       break;
12724
12725     case FFEINFO_kindFUNCTION:
12726       if ((ffecom_multi_retval_ != NULL_TREE)
12727           || (ffesymbol_basictype (ffecom_primary_entry_)
12728               == FFEINFO_basictypeCHARACTER)
12729           || ((ffesymbol_basictype (ffecom_primary_entry_)
12730                == FFEINFO_basictypeCOMPLEX)
12731               && (ffecom_num_entrypoints_ == 0)
12732               && ffesymbol_is_f2c (ffecom_primary_entry_)))
12733         {                       /* Value is returned by direct assignment
12734                                    into (implicit) dummy. */
12735           rtn = NULL_TREE;
12736           break;
12737         }
12738       rtn = ffecom_func_result_;
12739 #if 0
12740       /* Spurious error if RETURN happens before first reference!  So elide
12741          this code.  In particular, for debugging registry, rtn should always
12742          be non-null after all, but TREE_USED won't be set until we encounter
12743          a reference in the code.  Perfectly okay (but weird) code that,
12744          e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in
12745          this diagnostic for no reason.  Have people use -O -Wuninitialized
12746          and leave it to the back end to find obviously weird cases.  */
12747
12748       /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid
12749          situation; if the return value has never been referenced, it won't
12750          have a tree under 2pass mode. */
12751       if ((rtn == NULL_TREE)
12752           || !TREE_USED (rtn))
12753         {
12754           ffebad_start (FFEBAD_RETURN_VALUE_UNSET);
12755           ffebad_here (0, ffesymbol_where_line (ffecom_primary_entry_),
12756                        ffesymbol_where_column (ffecom_primary_entry_));
12757           ffebad_string (ffesymbol_text (ffesymbol_funcresult
12758                                          (ffecom_primary_entry_)));
12759           ffebad_finish ();
12760         }
12761 #endif
12762       break;
12763
12764     default:
12765       assert ("bad unit kind" == NULL);
12766     case FFEINFO_kindANY:
12767       rtn = error_mark_node;
12768       break;
12769     }
12770
12771   return rtn;
12772 }
12773
12774 /* Do save_expr only if tree is not error_mark_node.  */
12775
12776 tree
12777 ffecom_save_tree (tree t)
12778 {
12779   return save_expr (t);
12780 }
12781
12782 /* Start a compound statement (block).  */
12783
12784 void
12785 ffecom_start_compstmt (void)
12786 {
12787   bison_rule_pushlevel_ ();
12788 }
12789
12790 /* Public entry point for front end to access start_decl.  */
12791
12792 tree
12793 ffecom_start_decl (tree decl, bool is_initialized)
12794 {
12795   DECL_INITIAL (decl) = is_initialized ? error_mark_node : NULL_TREE;
12796   return start_decl (decl, FALSE);
12797 }
12798
12799 /* ffecom_sym_commit -- Symbol's state being committed to reality
12800
12801    ffesymbol s;
12802    ffecom_sym_commit(s);
12803
12804    Does whatever the backend needs when a symbol is committed after having
12805    been backtrackable for a period of time.  */
12806
12807 void
12808 ffecom_sym_commit (ffesymbol s UNUSED)
12809 {
12810   assert (!ffesymbol_retractable ());
12811 }
12812
12813 /* ffecom_sym_end_transition -- Perform end transition on all symbols
12814
12815    ffecom_sym_end_transition();
12816
12817    Does backend-specific stuff and also calls ffest_sym_end_transition
12818    to do the necessary FFE stuff.
12819
12820    Backtracking is never enabled when this fn is called, so don't worry
12821    about it.  */
12822
12823 ffesymbol
12824 ffecom_sym_end_transition (ffesymbol s)
12825 {
12826   ffestorag st;
12827
12828   assert (!ffesymbol_retractable ());
12829
12830   s = ffest_sym_end_transition (s);
12831
12832   if ((ffesymbol_kind (s) == FFEINFO_kindBLOCKDATA)
12833       && (ffesymbol_where (s) == FFEINFO_whereGLOBAL))
12834     {
12835       ffecom_list_blockdata_
12836         = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
12837                                               FFEINTRIN_specNONE,
12838                                               FFEINTRIN_impNONE),
12839                            ffecom_list_blockdata_);
12840     }
12841
12842   /* This is where we finally notice that a symbol has partial initialization
12843      and finalize it. */
12844
12845   if (ffesymbol_accretion (s) != NULL)
12846     {
12847       assert (ffesymbol_init (s) == NULL);
12848       ffecom_notify_init_symbol (s);
12849     }
12850   else if (((st = ffesymbol_storage (s)) != NULL)
12851            && ((st = ffestorag_parent (st)) != NULL)
12852            && (ffestorag_accretion (st) != NULL))
12853     {
12854       assert (ffestorag_init (st) == NULL);
12855       ffecom_notify_init_storage (st);
12856     }
12857
12858   if ((ffesymbol_kind (s) == FFEINFO_kindCOMMON)
12859       && (ffesymbol_where (s) == FFEINFO_whereLOCAL)
12860       && (ffesymbol_storage (s) != NULL))
12861     {
12862       ffecom_list_common_
12863         = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
12864                                               FFEINTRIN_specNONE,
12865                                               FFEINTRIN_impNONE),
12866                            ffecom_list_common_);
12867     }
12868
12869   return s;
12870 }
12871
12872 /* ffecom_sym_exec_transition -- Perform exec transition on all symbols
12873
12874    ffecom_sym_exec_transition();
12875
12876    Does backend-specific stuff and also calls ffest_sym_exec_transition
12877    to do the necessary FFE stuff.
12878
12879    See the long-winded description in ffecom_sym_learned for info
12880    on handling the situation where backtracking is inhibited.  */
12881
12882 ffesymbol
12883 ffecom_sym_exec_transition (ffesymbol s)
12884 {
12885   s = ffest_sym_exec_transition (s);
12886
12887   return s;
12888 }
12889
12890 /* ffecom_sym_learned -- Initial or more info gained on symbol after exec
12891
12892    ffesymbol s;
12893    s = ffecom_sym_learned(s);
12894
12895    Called when a new symbol is seen after the exec transition or when more
12896    info (perhaps) is gained for an UNCERTAIN symbol.  The symbol state when
12897    it arrives here is that all its latest info is updated already, so its
12898    state may be UNCERTAIN or UNDERSTOOD, it might already have the hook
12899    field filled in if its gone through here or exec_transition first, and
12900    so on.
12901
12902    The backend probably wants to check ffesymbol_retractable() to see if
12903    backtracking is in effect.  If so, the FFE's changes to the symbol may
12904    be retracted (undone) or committed (ratified), at which time the
12905    appropriate ffecom_sym_retract or _commit function will be called
12906    for that function.
12907
12908    If the backend has its own backtracking mechanism, great, use it so that
12909    committal is a simple operation.  Though it doesn't make much difference,
12910    I suppose: the reason for tentative symbol evolution in the FFE is to
12911    enable error detection in weird incorrect statements early and to disable
12912    incorrect error detection on a correct statement.  The backend is not
12913    likely to introduce any information that'll get involved in these
12914    considerations, so it is probably just fine that the implementation
12915    model for this fn and for _exec_transition is to not do anything
12916    (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE
12917    and instead wait until ffecom_sym_commit is called (which it never
12918    will be as long as we're using ambiguity-detecting statement analysis in
12919    the FFE, which we are initially to shake out the code, but don't depend
12920    on this), otherwise go ahead and do whatever is needed.
12921
12922    In essence, then, when this fn and _exec_transition get called while
12923    backtracking is enabled, a general mechanism would be to flag which (or
12924    both) of these were called (and in what order? neat question as to what
12925    might happen that I'm too lame to think through right now) and then when
12926    _commit is called reproduce the original calling sequence, if any, for
12927    the two fns (at which point backtracking will, of course, be disabled).  */
12928
12929 ffesymbol
12930 ffecom_sym_learned (ffesymbol s)
12931 {
12932   ffestorag_exec_layout (s);
12933
12934   return s;
12935 }
12936
12937 /* ffecom_sym_retract -- Symbol's state being retracted from reality
12938
12939    ffesymbol s;
12940    ffecom_sym_retract(s);
12941
12942    Does whatever the backend needs when a symbol is retracted after having
12943    been backtrackable for a period of time.  */
12944
12945 void
12946 ffecom_sym_retract (ffesymbol s UNUSED)
12947 {
12948   assert (!ffesymbol_retractable ());
12949
12950 #if 0                           /* GCC doesn't commit any backtrackable sins,
12951                                    so nothing needed here. */
12952   switch (ffesymbol_hook (s).state)
12953     {
12954     case 0:                     /* nothing happened yet. */
12955       break;
12956
12957     case 1:                     /* exec transition happened. */
12958       break;
12959
12960     case 2:                     /* learned happened. */
12961       break;
12962
12963     case 3:                     /* learned then exec. */
12964       break;
12965
12966     case 4:                     /* exec then learned. */
12967       break;
12968
12969     default:
12970       assert ("bad hook state" == NULL);
12971       break;
12972     }
12973 #endif
12974 }
12975
12976 /* Create temporary gcc label.  */
12977
12978 tree
12979 ffecom_temp_label ()
12980 {
12981   tree glabel;
12982   static int mynumber = 0;
12983
12984   glabel = build_decl (LABEL_DECL,
12985                        ffecom_get_invented_identifier ("__g77_label_%d",
12986                                                        mynumber++),
12987                        void_type_node);
12988   DECL_CONTEXT (glabel) = current_function_decl;
12989   DECL_MODE (glabel) = VOIDmode;
12990
12991   return glabel;
12992 }
12993
12994 /* Return an expression that is usable as an arg in a conditional context
12995    (IF, DO WHILE, .NOT., and so on).
12996
12997    Use the one provided for the back end as of >2.6.0.  */
12998
12999 tree
13000 ffecom_truth_value (tree expr)
13001 {
13002   return ffe_truthvalue_conversion (expr);
13003 }
13004
13005 /* Return the inversion of a truth value (the inversion of what
13006    ffecom_truth_value builds).
13007
13008    Apparently invert_truthvalue, which is properly in the back end, is
13009    enough for now, so just use it.  */
13010
13011 tree
13012 ffecom_truth_value_invert (tree expr)
13013 {
13014   return invert_truthvalue (ffecom_truth_value (expr));
13015 }
13016
13017 /* Return the tree that is the type of the expression, as would be
13018    returned in TREE_TYPE(ffecom_expr(expr)), without otherwise
13019    transforming the expression, generating temporaries, etc.  */
13020
13021 tree
13022 ffecom_type_expr (ffebld expr)
13023 {
13024   ffeinfoBasictype bt;
13025   ffeinfoKindtype kt;
13026   tree tree_type;
13027
13028   assert (expr != NULL);
13029
13030   bt = ffeinfo_basictype (ffebld_info (expr));
13031   kt = ffeinfo_kindtype (ffebld_info (expr));
13032   tree_type = ffecom_tree_type[bt][kt];
13033
13034   switch (ffebld_op (expr))
13035     {
13036     case FFEBLD_opCONTER:
13037     case FFEBLD_opSYMTER:
13038     case FFEBLD_opARRAYREF:
13039     case FFEBLD_opUPLUS:
13040     case FFEBLD_opPAREN:
13041     case FFEBLD_opUMINUS:
13042     case FFEBLD_opADD:
13043     case FFEBLD_opSUBTRACT:
13044     case FFEBLD_opMULTIPLY:
13045     case FFEBLD_opDIVIDE:
13046     case FFEBLD_opPOWER:
13047     case FFEBLD_opNOT:
13048     case FFEBLD_opFUNCREF:
13049     case FFEBLD_opSUBRREF:
13050     case FFEBLD_opAND:
13051     case FFEBLD_opOR:
13052     case FFEBLD_opXOR:
13053     case FFEBLD_opNEQV:
13054     case FFEBLD_opEQV:
13055     case FFEBLD_opCONVERT:
13056     case FFEBLD_opLT:
13057     case FFEBLD_opLE:
13058     case FFEBLD_opEQ:
13059     case FFEBLD_opNE:
13060     case FFEBLD_opGT:
13061     case FFEBLD_opGE:
13062     case FFEBLD_opPERCENT_LOC:
13063       return tree_type;
13064
13065     case FFEBLD_opACCTER:
13066     case FFEBLD_opARRTER:
13067     case FFEBLD_opITEM:
13068     case FFEBLD_opSTAR:
13069     case FFEBLD_opBOUNDS:
13070     case FFEBLD_opREPEAT:
13071     case FFEBLD_opLABTER:
13072     case FFEBLD_opLABTOK:
13073     case FFEBLD_opIMPDO:
13074     case FFEBLD_opCONCATENATE:
13075     case FFEBLD_opSUBSTR:
13076     default:
13077       assert ("bad op for ffecom_type_expr" == NULL);
13078       /* Fall through. */
13079     case FFEBLD_opANY:
13080       return error_mark_node;
13081     }
13082 }
13083
13084 /* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points
13085
13086    If the PARM_DECL already exists, return it, else create it.  It's an
13087    integer_type_node argument for the master function that implements a
13088    subroutine or function with more than one entrypoint and is bound at
13089    run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for
13090    first ENTRY statement, and so on).  */
13091
13092 tree
13093 ffecom_which_entrypoint_decl ()
13094 {
13095   assert (ffecom_which_entrypoint_decl_ != NULL_TREE);
13096
13097   return ffecom_which_entrypoint_decl_;
13098 }
13099 \f
13100 /* The following sections consists of private and public functions
13101    that have the same names and perform roughly the same functions
13102    as counterparts in the C front end.  Changes in the C front end
13103    might affect how things should be done here.  Only functions
13104    needed by the back end should be public here; the rest should
13105    be private (static in the C sense).  Functions needed by other
13106    g77 front-end modules should be accessed by them via public
13107    ffecom_* names, which should themselves call private versions
13108    in this section so the private versions are easy to recognize
13109    when upgrading to a new gcc and finding interesting changes
13110    in the front end.
13111
13112    Functions named after rule "foo:" in c-parse.y are named
13113    "bison_rule_foo_" so they are easy to find.  */
13114
13115 static void
13116 bison_rule_pushlevel_ ()
13117 {
13118   emit_line_note (input_filename, lineno);
13119   pushlevel (0);
13120   clear_last_expr ();
13121   expand_start_bindings (0);
13122 }
13123
13124 static tree
13125 bison_rule_compstmt_ ()
13126 {
13127   tree t;
13128   int keep = kept_level_p ();
13129
13130   /* Make the temps go away.  */
13131   if (! keep)
13132     current_binding_level->names = NULL_TREE;
13133
13134   emit_line_note (input_filename, lineno);
13135   expand_end_bindings (getdecls (), keep, 0);
13136   t = poplevel (keep, 1, 0);
13137
13138   return t;
13139 }
13140
13141 /* Return a definition for a builtin function named NAME and whose data type
13142    is TYPE.  TYPE should be a function type with argument types.
13143    FUNCTION_CODE tells later passes how to compile calls to this function.
13144    See tree.h for its possible values.
13145
13146    If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
13147    the name to be called if we can't opencode the function.  If
13148    ATTRS is nonzero, use that for the function's attribute list.  */
13149
13150 tree
13151 builtin_function (const char *name, tree type, int function_code,
13152                   enum built_in_class class,
13153                   const char *library_name,
13154                   tree attrs ATTRIBUTE_UNUSED)
13155 {
13156   tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type);
13157   DECL_EXTERNAL (decl) = 1;
13158   TREE_PUBLIC (decl) = 1;
13159   if (library_name)
13160     SET_DECL_ASSEMBLER_NAME (decl, get_identifier (library_name));
13161   make_decl_rtl (decl, NULL);
13162   pushdecl (decl);
13163   DECL_BUILT_IN_CLASS (decl) = class;
13164   DECL_FUNCTION_CODE (decl) = function_code;
13165
13166   return decl;
13167 }
13168
13169 /* Handle when a new declaration NEWDECL
13170    has the same name as an old one OLDDECL
13171    in the same binding contour.
13172    Prints an error message if appropriate.
13173
13174    If safely possible, alter OLDDECL to look like NEWDECL, and return 1.
13175    Otherwise, return 0.  */
13176
13177 static int
13178 duplicate_decls (tree newdecl, tree olddecl)
13179 {
13180   int types_match = 1;
13181   int new_is_definition = (TREE_CODE (newdecl) == FUNCTION_DECL
13182                            && DECL_INITIAL (newdecl) != 0);
13183   tree oldtype = TREE_TYPE (olddecl);
13184   tree newtype = TREE_TYPE (newdecl);
13185
13186   if (olddecl == newdecl)
13187     return 1;
13188
13189   if (TREE_CODE (newtype) == ERROR_MARK
13190       || TREE_CODE (oldtype) == ERROR_MARK)
13191     types_match = 0;
13192
13193   /* New decl is completely inconsistent with the old one =>
13194      tell caller to replace the old one.
13195      This is always an error except in the case of shadowing a builtin.  */
13196   if (TREE_CODE (olddecl) != TREE_CODE (newdecl))
13197     return 0;
13198
13199   /* For real parm decl following a forward decl,
13200      return 1 so old decl will be reused.  */
13201   if (types_match && TREE_CODE (newdecl) == PARM_DECL
13202       && TREE_ASM_WRITTEN (olddecl) && ! TREE_ASM_WRITTEN (newdecl))
13203     return 1;
13204
13205   /* The new declaration is the same kind of object as the old one.
13206      The declarations may partially match.  Print warnings if they don't
13207      match enough.  Ultimately, copy most of the information from the new
13208      decl to the old one, and keep using the old one.  */
13209
13210   if (TREE_CODE (olddecl) == FUNCTION_DECL
13211       && DECL_BUILT_IN (olddecl))
13212     {
13213       /* A function declaration for a built-in function.  */
13214       if (!TREE_PUBLIC (newdecl))
13215         return 0;
13216       else if (!types_match)
13217         {
13218           /* Accept the return type of the new declaration if same modes.  */
13219           tree oldreturntype = TREE_TYPE (TREE_TYPE (olddecl));
13220           tree newreturntype = TREE_TYPE (TREE_TYPE (newdecl));
13221
13222           if (TYPE_MODE (oldreturntype) == TYPE_MODE (newreturntype))
13223             {
13224               /* Function types may be shared, so we can't just modify
13225                  the return type of olddecl's function type.  */
13226               tree newtype
13227                 = build_function_type (newreturntype,
13228                                        TYPE_ARG_TYPES (TREE_TYPE (olddecl)));
13229
13230               types_match = 1;
13231               if (types_match)
13232                 TREE_TYPE (olddecl) = newtype;
13233             }
13234         }
13235       if (!types_match)
13236         return 0;
13237     }
13238   else if (TREE_CODE (olddecl) == FUNCTION_DECL
13239            && DECL_SOURCE_LINE (olddecl) == 0)
13240     {
13241       /* A function declaration for a predeclared function
13242          that isn't actually built in.  */
13243       if (!TREE_PUBLIC (newdecl))
13244         return 0;
13245       else if (!types_match)
13246         {
13247           /* If the types don't match, preserve volatility indication.
13248              Later on, we will discard everything else about the
13249              default declaration.  */
13250           TREE_THIS_VOLATILE (newdecl) |= TREE_THIS_VOLATILE (olddecl);
13251         }
13252     }
13253
13254   /* Copy all the DECL_... slots specified in the new decl
13255      except for any that we copy here from the old type.
13256
13257      Past this point, we don't change OLDTYPE and NEWTYPE
13258      even if we change the types of NEWDECL and OLDDECL.  */
13259
13260   if (types_match)
13261     {
13262       /* Merge the data types specified in the two decls.  */
13263       if (TREE_CODE (newdecl) != FUNCTION_DECL || !DECL_BUILT_IN (olddecl))
13264         TREE_TYPE (newdecl)
13265           = TREE_TYPE (olddecl)
13266             = TREE_TYPE (newdecl);
13267
13268       /* Lay the type out, unless already done.  */
13269       if (oldtype != TREE_TYPE (newdecl))
13270         {
13271           if (TREE_TYPE (newdecl) != error_mark_node)
13272             layout_type (TREE_TYPE (newdecl));
13273           if (TREE_CODE (newdecl) != FUNCTION_DECL
13274               && TREE_CODE (newdecl) != TYPE_DECL
13275               && TREE_CODE (newdecl) != CONST_DECL)
13276             layout_decl (newdecl, 0);
13277         }
13278       else
13279         {
13280           /* Since the type is OLDDECL's, make OLDDECL's size go with.  */
13281           DECL_SIZE (newdecl) = DECL_SIZE (olddecl);
13282           DECL_SIZE_UNIT (newdecl) = DECL_SIZE_UNIT (olddecl);
13283           if (TREE_CODE (olddecl) != FUNCTION_DECL)
13284             if (DECL_ALIGN (olddecl) > DECL_ALIGN (newdecl))
13285               {
13286                 DECL_ALIGN (newdecl) = DECL_ALIGN (olddecl);
13287                 DECL_USER_ALIGN (newdecl) |= DECL_USER_ALIGN (olddecl);
13288               }
13289         }
13290
13291       /* Keep the old rtl since we can safely use it.  */
13292       COPY_DECL_RTL (olddecl, newdecl);
13293
13294       /* Merge the type qualifiers.  */
13295       if (TREE_READONLY (newdecl))
13296         TREE_READONLY (olddecl) = 1;
13297       if (TREE_THIS_VOLATILE (newdecl))
13298         {
13299           TREE_THIS_VOLATILE (olddecl) = 1;
13300           if (TREE_CODE (newdecl) == VAR_DECL)
13301             make_var_volatile (newdecl);
13302         }
13303
13304       /* Keep source location of definition rather than declaration.
13305          Likewise, keep decl at outer scope.  */
13306       if ((DECL_INITIAL (newdecl) == 0 && DECL_INITIAL (olddecl) != 0)
13307           || (DECL_CONTEXT (newdecl) != 0 && DECL_CONTEXT (olddecl) == 0))
13308         {
13309           DECL_SOURCE_LINE (newdecl) = DECL_SOURCE_LINE (olddecl);
13310           DECL_SOURCE_FILE (newdecl) = DECL_SOURCE_FILE (olddecl);
13311
13312           if (DECL_CONTEXT (olddecl) == 0
13313               && TREE_CODE (newdecl) != FUNCTION_DECL)
13314             DECL_CONTEXT (newdecl) = 0;
13315         }
13316
13317       /* Merge the unused-warning information.  */
13318       if (DECL_IN_SYSTEM_HEADER (olddecl))
13319         DECL_IN_SYSTEM_HEADER (newdecl) = 1;
13320       else if (DECL_IN_SYSTEM_HEADER (newdecl))
13321         DECL_IN_SYSTEM_HEADER (olddecl) = 1;
13322
13323       /* Merge the initialization information.  */
13324       if (DECL_INITIAL (newdecl) == 0)
13325         DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13326
13327       /* Merge the section attribute.
13328          We want to issue an error if the sections conflict but that must be
13329          done later in decl_attributes since we are called before attributes
13330          are assigned.  */
13331       if (DECL_SECTION_NAME (newdecl) == NULL_TREE)
13332         DECL_SECTION_NAME (newdecl) = DECL_SECTION_NAME (olddecl);
13333
13334       if (TREE_CODE (newdecl) == FUNCTION_DECL)
13335         {
13336           DECL_STATIC_CONSTRUCTOR(newdecl) |= DECL_STATIC_CONSTRUCTOR(olddecl);
13337           DECL_STATIC_DESTRUCTOR (newdecl) |= DECL_STATIC_DESTRUCTOR (olddecl);
13338           DECL_IS_MALLOC (newdecl) |= DECL_IS_MALLOC (olddecl);
13339           DECL_IS_PURE (newdecl) |= DECL_IS_PURE (olddecl);
13340         }
13341     }
13342   /* If cannot merge, then use the new type and qualifiers,
13343      and don't preserve the old rtl.  */
13344   else
13345     {
13346       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13347       TREE_READONLY (olddecl) = TREE_READONLY (newdecl);
13348       TREE_THIS_VOLATILE (olddecl) = TREE_THIS_VOLATILE (newdecl);
13349       TREE_SIDE_EFFECTS (olddecl) = TREE_SIDE_EFFECTS (newdecl);
13350     }
13351
13352   /* Merge the storage class information.  */
13353   /* For functions, static overrides non-static.  */
13354   if (TREE_CODE (newdecl) == FUNCTION_DECL)
13355     {
13356       TREE_PUBLIC (newdecl) &= TREE_PUBLIC (olddecl);
13357       /* This is since we don't automatically
13358          copy the attributes of NEWDECL into OLDDECL.  */
13359       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13360       /* If this clears `static', clear it in the identifier too.  */
13361       if (! TREE_PUBLIC (olddecl))
13362         TREE_PUBLIC (DECL_NAME (olddecl)) = 0;
13363     }
13364   if (DECL_EXTERNAL (newdecl))
13365     {
13366       TREE_STATIC (newdecl) = TREE_STATIC (olddecl);
13367       DECL_EXTERNAL (newdecl) = DECL_EXTERNAL (olddecl);
13368       /* An extern decl does not override previous storage class.  */
13369       TREE_PUBLIC (newdecl) = TREE_PUBLIC (olddecl);
13370     }
13371   else
13372     {
13373       TREE_STATIC (olddecl) = TREE_STATIC (newdecl);
13374       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13375     }
13376
13377   /* If either decl says `inline', this fn is inline,
13378      unless its definition was passed already.  */
13379   if (DECL_INLINE (newdecl) && DECL_INITIAL (olddecl) == 0)
13380     DECL_INLINE (olddecl) = 1;
13381   DECL_INLINE (newdecl) = DECL_INLINE (olddecl);
13382
13383   /* Get rid of any built-in function if new arg types don't match it
13384      or if we have a function definition.  */
13385   if (TREE_CODE (newdecl) == FUNCTION_DECL
13386       && DECL_BUILT_IN (olddecl)
13387       && (!types_match || new_is_definition))
13388     {
13389       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13390       DECL_BUILT_IN_CLASS (olddecl) = NOT_BUILT_IN;
13391     }
13392
13393   /* If redeclaring a builtin function, and not a definition,
13394      it stays built in.
13395      Also preserve various other info from the definition.  */
13396   if (TREE_CODE (newdecl) == FUNCTION_DECL && !new_is_definition)
13397     {
13398       if (DECL_BUILT_IN (olddecl))
13399         {
13400           DECL_BUILT_IN_CLASS (newdecl) = DECL_BUILT_IN_CLASS (olddecl);
13401           DECL_FUNCTION_CODE (newdecl) = DECL_FUNCTION_CODE (olddecl);
13402         }
13403
13404       DECL_RESULT (newdecl) = DECL_RESULT (olddecl);
13405       DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13406       DECL_SAVED_INSNS (newdecl) = DECL_SAVED_INSNS (olddecl);
13407       DECL_ARGUMENTS (newdecl) = DECL_ARGUMENTS (olddecl);
13408     }
13409
13410   /* Copy most of the decl-specific fields of NEWDECL into OLDDECL.
13411      But preserve olddecl's DECL_UID.  */
13412   {
13413     register unsigned olddecl_uid = DECL_UID (olddecl);
13414
13415     memcpy ((char *) olddecl + sizeof (struct tree_common),
13416             (char *) newdecl + sizeof (struct tree_common),
13417             sizeof (struct tree_decl) - sizeof (struct tree_common));
13418     DECL_UID (olddecl) = olddecl_uid;
13419   }
13420
13421   return 1;
13422 }
13423
13424 /* Finish processing of a declaration;
13425    install its initial value.
13426    If the length of an array type is not known before,
13427    it must be determined now, from the initial value, or it is an error.  */
13428
13429 static void
13430 finish_decl (tree decl, tree init, bool is_top_level)
13431 {
13432   register tree type = TREE_TYPE (decl);
13433   int was_incomplete = (DECL_SIZE (decl) == 0);
13434   bool at_top_level = (current_binding_level == global_binding_level);
13435   bool top_level = is_top_level || at_top_level;
13436
13437   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13438      level anyway.  */
13439   assert (!is_top_level || !at_top_level);
13440
13441   if (TREE_CODE (decl) == PARM_DECL)
13442     assert (init == NULL_TREE);
13443   /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it
13444      overlaps DECL_ARG_TYPE.  */
13445   else if (init == NULL_TREE)
13446     assert (DECL_INITIAL (decl) == NULL_TREE);
13447   else
13448     assert (DECL_INITIAL (decl) == error_mark_node);
13449
13450   if (init != NULL_TREE)
13451     {
13452       if (TREE_CODE (decl) != TYPE_DECL)
13453         DECL_INITIAL (decl) = init;
13454       else
13455         {
13456           /* typedef foo = bar; store the type of bar as the type of foo.  */
13457           TREE_TYPE (decl) = TREE_TYPE (init);
13458           DECL_INITIAL (decl) = init = 0;
13459         }
13460     }
13461
13462   /* Deduce size of array from initialization, if not already known */
13463
13464   if (TREE_CODE (type) == ARRAY_TYPE
13465       && TYPE_DOMAIN (type) == 0
13466       && TREE_CODE (decl) != TYPE_DECL)
13467     {
13468       assert (top_level);
13469       assert (was_incomplete);
13470
13471       layout_decl (decl, 0);
13472     }
13473
13474   if (TREE_CODE (decl) == VAR_DECL)
13475     {
13476       if (DECL_SIZE (decl) == NULL_TREE
13477           && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
13478         layout_decl (decl, 0);
13479
13480       if (DECL_SIZE (decl) == NULL_TREE
13481           && (TREE_STATIC (decl)
13482               ?
13483       /* A static variable with an incomplete type is an error if it is
13484          initialized. Also if it is not file scope. Otherwise, let it
13485          through, but if it is not `extern' then it may cause an error
13486          message later.  */
13487               (DECL_INITIAL (decl) != 0 || DECL_CONTEXT (decl) != 0)
13488               :
13489       /* An automatic variable with an incomplete type is an error.  */
13490               !DECL_EXTERNAL (decl)))
13491         {
13492           assert ("storage size not known" == NULL);
13493           abort ();
13494         }
13495
13496       if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl))
13497           && (DECL_SIZE (decl) != 0)
13498           && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST))
13499         {
13500           assert ("storage size not constant" == NULL);
13501           abort ();
13502         }
13503     }
13504
13505   /* Output the assembler code and/or RTL code for variables and functions,
13506      unless the type is an undefined structure or union. If not, it will get
13507      done when the type is completed.  */
13508
13509   if (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == FUNCTION_DECL)
13510     {
13511       rest_of_decl_compilation (decl, NULL,
13512                                 DECL_CONTEXT (decl) == 0,
13513                                 0);
13514
13515       if (DECL_CONTEXT (decl) != 0)
13516         {
13517           /* Recompute the RTL of a local array now if it used to be an
13518              incomplete type.  */
13519           if (was_incomplete
13520               && !TREE_STATIC (decl) && !DECL_EXTERNAL (decl))
13521             {
13522               /* If we used it already as memory, it must stay in memory.  */
13523               TREE_ADDRESSABLE (decl) = TREE_USED (decl);
13524               /* If it's still incomplete now, no init will save it.  */
13525               if (DECL_SIZE (decl) == 0)
13526                 DECL_INITIAL (decl) = 0;
13527               expand_decl (decl);
13528             }
13529           /* Compute and store the initial value.  */
13530           if (TREE_CODE (decl) != FUNCTION_DECL)
13531             expand_decl_init (decl);
13532         }
13533     }
13534   else if (TREE_CODE (decl) == TYPE_DECL)
13535     {
13536       rest_of_decl_compilation (decl, NULL,
13537                                 DECL_CONTEXT (decl) == 0,
13538                                 0);
13539     }
13540
13541   /* At the end of a declaration, throw away any variable type sizes of types
13542      defined inside that declaration.  There is no use computing them in the
13543      following function definition.  */
13544   if (current_binding_level == global_binding_level)
13545     get_pending_sizes ();
13546 }
13547
13548 /* Finish up a function declaration and compile that function
13549    all the way to assembler language output.  The free the storage
13550    for the function definition.
13551
13552    This is called after parsing the body of the function definition.
13553
13554    NESTED is nonzero if the function being finished is nested in another.  */
13555
13556 static void
13557 finish_function (int nested)
13558 {
13559   register tree fndecl = current_function_decl;
13560
13561   assert (fndecl != NULL_TREE);
13562   if (TREE_CODE (fndecl) != ERROR_MARK)
13563     {
13564       if (nested)
13565         assert (DECL_CONTEXT (fndecl) != NULL_TREE);
13566       else
13567         assert (DECL_CONTEXT (fndecl) == NULL_TREE);
13568     }
13569
13570 /*  TREE_READONLY (fndecl) = 1;
13571     This caused &foo to be of type ptr-to-const-function
13572     which then got a warning when stored in a ptr-to-function variable.  */
13573
13574   poplevel (1, 0, 1);
13575
13576   if (TREE_CODE (fndecl) != ERROR_MARK)
13577     {
13578       BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
13579
13580       /* Must mark the RESULT_DECL as being in this function.  */
13581
13582       DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl;
13583
13584       /* Obey `register' declarations if `setjmp' is called in this fn.  */
13585       /* Generate rtl for function exit.  */
13586       expand_function_end (input_filename, lineno, 0);
13587
13588       /* If this is a nested function, protect the local variables in the stack
13589          above us from being collected while we're compiling this function.  */
13590       if (nested)
13591         ggc_push_context ();
13592
13593       /* Run the optimizers and output the assembler code for this function.  */
13594       rest_of_compilation (fndecl);
13595
13596       /* Undo the GC context switch.  */
13597       if (nested)
13598         ggc_pop_context ();
13599     }
13600
13601   if (TREE_CODE (fndecl) != ERROR_MARK
13602       && !nested
13603       && DECL_SAVED_INSNS (fndecl) == 0)
13604     {
13605       /* Stop pointing to the local nodes about to be freed.  */
13606       /* But DECL_INITIAL must remain nonzero so we know this was an actual
13607          function definition.  */
13608       /* For a nested function, this is done in pop_f_function_context.  */
13609       /* If rest_of_compilation set this to 0, leave it 0.  */
13610       if (DECL_INITIAL (fndecl) != 0)
13611         DECL_INITIAL (fndecl) = error_mark_node;
13612       DECL_ARGUMENTS (fndecl) = 0;
13613     }
13614
13615   if (!nested)
13616     {
13617       /* Let the error reporting routines know that we're outside a function.
13618          For a nested function, this value is used in pop_c_function_context
13619          and then reset via pop_function_context.  */
13620       ffecom_outer_function_decl_ = current_function_decl = NULL;
13621     }
13622 }
13623
13624 /* Plug-in replacement for identifying the name of a decl and, for a
13625    function, what we call it in diagnostics.  For now, "program unit"
13626    should suffice, since it's a bit of a hassle to figure out which
13627    of several kinds of things it is.  Note that it could conceivably
13628    be a statement function, which probably isn't really a program unit
13629    per se, but if that comes up, it should be easy to check (being a
13630    nested function and all).  */
13631
13632 static const char *
13633 ffe_printable_name (tree decl, int v)
13634 {
13635   /* Just to keep GCC quiet about the unused variable.
13636      In theory, differing values of V should produce different
13637      output.  */
13638   switch (v)
13639     {
13640     default:
13641       if (TREE_CODE (decl) == ERROR_MARK)
13642         return "erroneous code";
13643       return IDENTIFIER_POINTER (DECL_NAME (decl));
13644     }
13645 }
13646
13647 /* g77's function to print out name of current function that caused
13648    an error.  */
13649
13650 static void
13651 ffe_print_error_function (diagnostic_context *context __attribute__((unused)),
13652                           const char *file)
13653 {
13654   static ffeglobal last_g = NULL;
13655   static ffesymbol last_s = NULL;
13656   ffeglobal g;
13657   ffesymbol s;
13658   const char *kind;
13659
13660   if ((ffecom_primary_entry_ == NULL)
13661       || (ffesymbol_global (ffecom_primary_entry_) == NULL))
13662     {
13663       g = NULL;
13664       s = NULL;
13665       kind = NULL;
13666     }
13667   else
13668     {
13669       g = ffesymbol_global (ffecom_primary_entry_);
13670       if (ffecom_nested_entry_ == NULL)
13671         {
13672           s = ffecom_primary_entry_;
13673           kind = _(ffeinfo_kind_message (ffesymbol_kind (s)));
13674         }
13675       else
13676         {
13677           s = ffecom_nested_entry_;
13678           kind = _("In statement function");
13679         }
13680     }
13681
13682   if ((last_g != g) || (last_s != s))
13683     {
13684       if (file)
13685         fprintf (stderr, "%s: ", file);
13686
13687       if (s == NULL)
13688         fprintf (stderr, _("Outside of any program unit:\n"));
13689       else
13690         {
13691           const char *name = ffesymbol_text (s);
13692
13693           fprintf (stderr, "%s `%s':\n", kind, name);
13694         }
13695
13696       last_g = g;
13697       last_s = s;
13698     }
13699 }
13700
13701 /* Similar to `lookup_name' but look only at current binding level.  */
13702
13703 static tree
13704 lookup_name_current_level (tree name)
13705 {
13706   register tree t;
13707
13708   if (current_binding_level == global_binding_level)
13709     return IDENTIFIER_GLOBAL_VALUE (name);
13710
13711   if (IDENTIFIER_LOCAL_VALUE (name) == 0)
13712     return 0;
13713
13714   for (t = current_binding_level->names; t; t = TREE_CHAIN (t))
13715     if (DECL_NAME (t) == name)
13716       break;
13717
13718   return t;
13719 }
13720
13721 /* Create a new `struct f_binding_level'.  */
13722
13723 static struct f_binding_level *
13724 make_binding_level ()
13725 {
13726   /* NOSTRICT */
13727   return ggc_alloc (sizeof (struct f_binding_level));
13728 }
13729
13730 /* Save and restore the variables in this file and elsewhere
13731    that keep track of the progress of compilation of the current function.
13732    Used for nested functions.  */
13733
13734 struct f_function
13735 {
13736   struct f_function *next;
13737   tree named_labels;
13738   tree shadowed_labels;
13739   struct f_binding_level *binding_level;
13740 };
13741
13742 struct f_function *f_function_chain;
13743
13744 /* Restore the variables used during compilation of a C function.  */
13745
13746 static void
13747 pop_f_function_context ()
13748 {
13749   struct f_function *p = f_function_chain;
13750   tree link;
13751
13752   /* Bring back all the labels that were shadowed.  */
13753   for (link = shadowed_labels; link; link = TREE_CHAIN (link))
13754     if (DECL_NAME (TREE_VALUE (link)) != 0)
13755       IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link)))
13756         = TREE_VALUE (link);
13757
13758   if (current_function_decl != error_mark_node
13759       && DECL_SAVED_INSNS (current_function_decl) == 0)
13760     {
13761       /* Stop pointing to the local nodes about to be freed.  */
13762       /* But DECL_INITIAL must remain nonzero so we know this was an actual
13763          function definition.  */
13764       DECL_INITIAL (current_function_decl) = error_mark_node;
13765       DECL_ARGUMENTS (current_function_decl) = 0;
13766     }
13767
13768   pop_function_context ();
13769
13770   f_function_chain = p->next;
13771
13772   named_labels = p->named_labels;
13773   shadowed_labels = p->shadowed_labels;
13774   current_binding_level = p->binding_level;
13775
13776   free (p);
13777 }
13778
13779 /* Save and reinitialize the variables
13780    used during compilation of a C function.  */
13781
13782 static void
13783 push_f_function_context ()
13784 {
13785   struct f_function *p
13786   = (struct f_function *) xmalloc (sizeof (struct f_function));
13787
13788   push_function_context ();
13789
13790   p->next = f_function_chain;
13791   f_function_chain = p;
13792
13793   p->named_labels = named_labels;
13794   p->shadowed_labels = shadowed_labels;
13795   p->binding_level = current_binding_level;
13796 }
13797
13798 static void
13799 push_parm_decl (tree parm)
13800 {
13801   int old_immediate_size_expand = immediate_size_expand;
13802
13803   /* Don't try computing parm sizes now -- wait till fn is called.  */
13804
13805   immediate_size_expand = 0;
13806
13807   /* Fill in arg stuff.  */
13808
13809   DECL_ARG_TYPE (parm) = TREE_TYPE (parm);
13810   DECL_ARG_TYPE_AS_WRITTEN (parm) = TREE_TYPE (parm);
13811   TREE_READONLY (parm) = 1;     /* All implementation args are read-only. */
13812
13813   parm = pushdecl (parm);
13814
13815   immediate_size_expand = old_immediate_size_expand;
13816
13817   finish_decl (parm, NULL_TREE, FALSE);
13818 }
13819
13820 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate.  */
13821
13822 static tree
13823 pushdecl_top_level (tree x)
13824 {
13825   register tree t;
13826   register struct f_binding_level *b = current_binding_level;
13827   register tree f = current_function_decl;
13828
13829   current_binding_level = global_binding_level;
13830   current_function_decl = NULL_TREE;
13831   t = pushdecl (x);
13832   current_binding_level = b;
13833   current_function_decl = f;
13834   return t;
13835 }
13836
13837 /* Store the list of declarations of the current level.
13838    This is done for the parameter declarations of a function being defined,
13839    after they are modified in the light of any missing parameters.  */
13840
13841 static tree
13842 storedecls (tree decls)
13843 {
13844   return current_binding_level->names = decls;
13845 }
13846
13847 /* Store the parameter declarations into the current function declaration.
13848    This is called after parsing the parameter declarations, before
13849    digesting the body of the function.
13850
13851    For an old-style definition, modify the function's type
13852    to specify at least the number of arguments.  */
13853
13854 static void
13855 store_parm_decls (int is_main_program UNUSED)
13856 {
13857   register tree fndecl = current_function_decl;
13858
13859   if (fndecl == error_mark_node)
13860     return;
13861
13862   /* This is a chain of PARM_DECLs from old-style parm declarations.  */
13863   DECL_ARGUMENTS (fndecl) = storedecls (nreverse (getdecls ()));
13864
13865   /* Initialize the RTL code for the function.  */
13866
13867   init_function_start (fndecl, input_filename, lineno);
13868
13869   /* Set up parameters and prepare for return, for the function.  */
13870
13871   expand_function_start (fndecl, 0);
13872 }
13873
13874 static tree
13875 start_decl (tree decl, bool is_top_level)
13876 {
13877   register tree tem;
13878   bool at_top_level = (current_binding_level == global_binding_level);
13879   bool top_level = is_top_level || at_top_level;
13880
13881   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13882      level anyway.  */
13883   assert (!is_top_level || !at_top_level);
13884
13885   if (DECL_INITIAL (decl) != NULL_TREE)
13886     {
13887       assert (DECL_INITIAL (decl) == error_mark_node);
13888       assert (!DECL_EXTERNAL (decl));
13889     }
13890   else if (top_level)
13891     assert ((TREE_STATIC (decl) == 1) || DECL_EXTERNAL (decl) == 1);
13892
13893   /* For Fortran, we by default put things in .common when possible.  */
13894   DECL_COMMON (decl) = 1;
13895
13896   /* Add this decl to the current binding level. TEM may equal DECL or it may
13897      be a previous decl of the same name.  */
13898   if (is_top_level)
13899     tem = pushdecl_top_level (decl);
13900   else
13901     tem = pushdecl (decl);
13902
13903   /* For a local variable, define the RTL now.  */
13904   if (!top_level
13905   /* But not if this is a duplicate decl and we preserved the rtl from the
13906      previous one (which may or may not happen).  */
13907       && !DECL_RTL_SET_P (tem))
13908     {
13909       if (TYPE_SIZE (TREE_TYPE (tem)) != 0)
13910         expand_decl (tem);
13911       else if (TREE_CODE (TREE_TYPE (tem)) == ARRAY_TYPE
13912                && DECL_INITIAL (tem) != 0)
13913         expand_decl (tem);
13914     }
13915
13916   return tem;
13917 }
13918
13919 /* Create the FUNCTION_DECL for a function definition.
13920    DECLSPECS and DECLARATOR are the parts of the declaration;
13921    they describe the function's name and the type it returns,
13922    but twisted together in a fashion that parallels the syntax of C.
13923
13924    This function creates a binding context for the function body
13925    as well as setting up the FUNCTION_DECL in current_function_decl.
13926
13927    Returns 1 on success.  If the DECLARATOR is not suitable for a function
13928    (it defines a datum instead), we return 0, which tells
13929    ffe_parse_file to report a parse error.
13930
13931    NESTED is nonzero for a function nested within another function.  */
13932
13933 static void
13934 start_function (tree name, tree type, int nested, int public)
13935 {
13936   tree decl1;
13937   tree restype;
13938   int old_immediate_size_expand = immediate_size_expand;
13939
13940   named_labels = 0;
13941   shadowed_labels = 0;
13942
13943   /* Don't expand any sizes in the return type of the function.  */
13944   immediate_size_expand = 0;
13945
13946   if (nested)
13947     {
13948       assert (!public);
13949       assert (current_function_decl != NULL_TREE);
13950       assert (DECL_CONTEXT (current_function_decl) == NULL_TREE);
13951     }
13952   else
13953     {
13954       assert (current_function_decl == NULL_TREE);
13955     }
13956
13957   if (TREE_CODE (type) == ERROR_MARK)
13958     decl1 = current_function_decl = error_mark_node;
13959   else
13960     {
13961       decl1 = build_decl (FUNCTION_DECL,
13962                           name,
13963                           type);
13964       TREE_PUBLIC (decl1) = public ? 1 : 0;
13965       if (nested)
13966         DECL_INLINE (decl1) = 1;
13967       TREE_STATIC (decl1) = 1;
13968       DECL_EXTERNAL (decl1) = 0;
13969
13970       announce_function (decl1);
13971
13972       /* Make the init_value nonzero so pushdecl knows this is not tentative.
13973          error_mark_node is replaced below (in poplevel) with the BLOCK.  */
13974       DECL_INITIAL (decl1) = error_mark_node;
13975
13976       /* Record the decl so that the function name is defined. If we already have
13977          a decl for this name, and it is a FUNCTION_DECL, use the old decl.  */
13978
13979       current_function_decl = pushdecl (decl1);
13980     }
13981
13982   if (!nested)
13983     ffecom_outer_function_decl_ = current_function_decl;
13984
13985   pushlevel (0);
13986   current_binding_level->prep_state = 2;
13987
13988   if (TREE_CODE (current_function_decl) != ERROR_MARK)
13989     {
13990       make_decl_rtl (current_function_decl, NULL);
13991
13992       restype = TREE_TYPE (TREE_TYPE (current_function_decl));
13993       DECL_RESULT (current_function_decl)
13994         = build_decl (RESULT_DECL, NULL_TREE, restype);
13995     }
13996
13997   if (!nested && (TREE_CODE (current_function_decl) != ERROR_MARK))
13998     TREE_ADDRESSABLE (current_function_decl) = 1;
13999
14000   immediate_size_expand = old_immediate_size_expand;
14001 }
14002 \f
14003 /* Here are the public functions the GNU back end needs.  */
14004
14005 tree
14006 convert (tree type, tree expr)
14007 {
14008   register tree e = expr;
14009   register enum tree_code code = TREE_CODE (type);
14010
14011   if (type == TREE_TYPE (e)
14012       || TREE_CODE (e) == ERROR_MARK)
14013     return e;
14014   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
14015     return fold (build1 (NOP_EXPR, type, e));
14016   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
14017       || code == ERROR_MARK)
14018     return error_mark_node;
14019   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
14020     {
14021       assert ("void value not ignored as it ought to be" == NULL);
14022       return error_mark_node;
14023     }
14024   if (code == VOID_TYPE)
14025     return build1 (CONVERT_EXPR, type, e);
14026   if ((code != RECORD_TYPE)
14027       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
14028     e = ffecom_1 (REALPART_EXPR, TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e))),
14029                   e);
14030   if (code == INTEGER_TYPE || code == ENUMERAL_TYPE)
14031     return fold (convert_to_integer (type, e));
14032   if (code == POINTER_TYPE)
14033     return fold (convert_to_pointer (type, e));
14034   if (code == REAL_TYPE)
14035     return fold (convert_to_real (type, e));
14036   if (code == COMPLEX_TYPE)
14037     return fold (convert_to_complex (type, e));
14038   if (code == RECORD_TYPE)
14039     return fold (ffecom_convert_to_complex_ (type, e));
14040
14041   assert ("conversion to non-scalar type requested" == NULL);
14042   return error_mark_node;
14043 }
14044
14045 /* Return the list of declarations of the current level.
14046    Note that this list is in reverse order unless/until
14047    you nreverse it; and when you do nreverse it, you must
14048    store the result back using `storedecls' or you will lose.  */
14049
14050 tree
14051 getdecls ()
14052 {
14053   return current_binding_level->names;
14054 }
14055
14056 /* Nonzero if we are currently in the global binding level.  */
14057
14058 int
14059 global_bindings_p ()
14060 {
14061   return current_binding_level == global_binding_level;
14062 }
14063
14064 static void
14065 ffecom_init_decl_processing ()
14066 {
14067   malloc_init ();
14068
14069   ffe_init_0 ();
14070 }
14071
14072 /* Delete the node BLOCK from the current binding level.
14073    This is used for the block inside a stmt expr ({...})
14074    so that the block can be reinserted where appropriate.  */
14075
14076 static void
14077 delete_block (tree block)
14078 {
14079   tree t;
14080   if (current_binding_level->blocks == block)
14081     current_binding_level->blocks = TREE_CHAIN (block);
14082   for (t = current_binding_level->blocks; t;)
14083     {
14084       if (TREE_CHAIN (t) == block)
14085         TREE_CHAIN (t) = TREE_CHAIN (block);
14086       else
14087         t = TREE_CHAIN (t);
14088     }
14089   TREE_CHAIN (block) = NULL;
14090   /* Clear TREE_USED which is always set by poplevel.
14091      The flag is set again if insert_block is called.  */
14092   TREE_USED (block) = 0;
14093 }
14094
14095 void
14096 insert_block (tree block)
14097 {
14098   TREE_USED (block) = 1;
14099   current_binding_level->blocks
14100     = chainon (current_binding_level->blocks, block);
14101 }
14102
14103 /* Each front end provides its own.  */
14104 static bool ffe_init PARAMS ((void));
14105 static void ffe_finish PARAMS ((void));
14106 static bool ffe_post_options PARAMS ((const char **));
14107 static void ffe_init_options PARAMS ((void));
14108 static void ffe_print_identifier PARAMS ((FILE *, tree, int));
14109
14110 struct language_function GTY(())
14111 {
14112   int unused;
14113 };
14114
14115 #undef  LANG_HOOKS_NAME
14116 #define LANG_HOOKS_NAME                 "GNU F77"
14117 #undef  LANG_HOOKS_INIT
14118 #define LANG_HOOKS_INIT                 ffe_init
14119 #undef  LANG_HOOKS_FINISH
14120 #define LANG_HOOKS_FINISH               ffe_finish
14121 #undef  LANG_HOOKS_INIT_OPTIONS
14122 #define LANG_HOOKS_INIT_OPTIONS         ffe_init_options
14123 #undef  LANG_HOOKS_DECODE_OPTION
14124 #define LANG_HOOKS_DECODE_OPTION        ffe_decode_option
14125 #undef  LANG_HOOKS_POST_OPTIONS
14126 #define LANG_HOOKS_POST_OPTIONS         ffe_post_options
14127 #undef  LANG_HOOKS_PARSE_FILE
14128 #define LANG_HOOKS_PARSE_FILE           ffe_parse_file
14129 #undef  LANG_HOOKS_MARK_ADDRESSABLE
14130 #define LANG_HOOKS_MARK_ADDRESSABLE     ffe_mark_addressable
14131 #undef  LANG_HOOKS_PRINT_IDENTIFIER
14132 #define LANG_HOOKS_PRINT_IDENTIFIER     ffe_print_identifier
14133 #undef  LANG_HOOKS_DECL_PRINTABLE_NAME
14134 #define LANG_HOOKS_DECL_PRINTABLE_NAME  ffe_printable_name
14135 #undef  LANG_HOOKS_PRINT_ERROR_FUNCTION
14136 #define LANG_HOOKS_PRINT_ERROR_FUNCTION ffe_print_error_function
14137 #undef  LANG_HOOKS_TRUTHVALUE_CONVERSION
14138 #define LANG_HOOKS_TRUTHVALUE_CONVERSION ffe_truthvalue_conversion
14139
14140 #undef  LANG_HOOKS_TYPE_FOR_MODE
14141 #define LANG_HOOKS_TYPE_FOR_MODE        ffe_type_for_mode
14142 #undef  LANG_HOOKS_TYPE_FOR_SIZE
14143 #define LANG_HOOKS_TYPE_FOR_SIZE        ffe_type_for_size
14144 #undef  LANG_HOOKS_SIGNED_TYPE
14145 #define LANG_HOOKS_SIGNED_TYPE          ffe_signed_type
14146 #undef  LANG_HOOKS_UNSIGNED_TYPE
14147 #define LANG_HOOKS_UNSIGNED_TYPE        ffe_unsigned_type
14148 #undef  LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE
14149 #define LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE ffe_signed_or_unsigned_type
14150
14151 /* We do not wish to use alias-set based aliasing at all.  Used in the
14152    extreme (every object with its own set, with equivalences recorded) it
14153    might be helpful, but there are problems when it comes to inlining.  We
14154    get on ok with flag_argument_noalias, and alias-set aliasing does
14155    currently limit how stack slots can be reused, which is a lose.  */
14156 #undef LANG_HOOKS_GET_ALIAS_SET
14157 #define LANG_HOOKS_GET_ALIAS_SET hook_get_alias_set_0
14158
14159 const struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER;
14160
14161 /* Table indexed by tree code giving a string containing a character
14162    classifying the tree code.  Possibilities are
14163    t, d, s, c, r, <, 1, 2 and e.  See tree.def for details.  */
14164
14165 #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) TYPE,
14166
14167 const char tree_code_type[] = {
14168 #include "tree.def"
14169 };
14170 #undef DEFTREECODE
14171
14172 /* Table indexed by tree code giving number of expression
14173    operands beyond the fixed part of the node structure.
14174    Not used for types or decls.  */
14175
14176 #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) LENGTH,
14177
14178 const unsigned char tree_code_length[] = {
14179 #include "tree.def"
14180 };
14181 #undef DEFTREECODE
14182
14183 /* Names of tree components.
14184    Used for printing out the tree and error messages.  */
14185 #define DEFTREECODE(SYM, NAME, TYPE, LEN) NAME,
14186
14187 const char *const tree_code_name[] = {
14188 #include "tree.def"
14189 };
14190 #undef DEFTREECODE
14191
14192 static bool
14193 ffe_post_options (pfilename)
14194      const char **pfilename;
14195 {
14196   const char *filename = *pfilename;
14197
14198   /* Open input file.  */
14199   if (filename == 0 || !strcmp (filename, "-"))
14200     {
14201       finput = stdin;
14202       filename = "stdin";
14203     }
14204   else
14205     finput = fopen (filename, "r");
14206
14207   if (finput == 0)
14208     fatal_io_error ("can't open %s", filename);
14209
14210   return false;
14211 }
14212
14213
14214 static bool
14215 ffe_init ()
14216 {
14217 #ifdef IO_BUFFER_SIZE
14218   setvbuf (finput, (char *) xmalloc (IO_BUFFER_SIZE), _IOFBF, IO_BUFFER_SIZE);
14219 #endif
14220
14221   ffecom_init_decl_processing ();
14222
14223   /* If the file is output from cpp, it should contain a first line
14224      `# 1 "real-filename"', and the current design of gcc (toplev.c
14225      in particular and the way it sets up information relied on by
14226      INCLUDE) requires that we read this now, and store the
14227      "real-filename" info in master_input_filename.  Ask the lexer
14228      to try doing this.  */
14229   ffelex_hash_kludge (finput);
14230
14231   /* FIXME: The ffelex_hash_kludge code needs to be cleaned up to
14232      set the new file name.  Maybe in ffe_post_options.  */
14233   return true;
14234 }
14235
14236 static void
14237 ffe_finish ()
14238 {
14239   ffe_terminate_0 ();
14240
14241   if (ffe_is_ffedebug ())
14242     malloc_pool_display (malloc_pool_image ());
14243
14244   fclose (finput);
14245 }
14246
14247 static void
14248 ffe_init_options ()
14249 {
14250   /* Set default options for Fortran.  */
14251   flag_move_all_movables = 1;
14252   flag_reduce_all_givs = 1;
14253   flag_argument_noalias = 2;
14254   flag_merge_constants = 2;
14255   flag_errno_math = 0;
14256   flag_complex_divide_method = 1;
14257 }
14258
14259 static bool
14260 ffe_mark_addressable (tree exp)
14261 {
14262   register tree x = exp;
14263   while (1)
14264     switch (TREE_CODE (x))
14265       {
14266       case ADDR_EXPR:
14267       case COMPONENT_REF:
14268       case ARRAY_REF:
14269         x = TREE_OPERAND (x, 0);
14270         break;
14271
14272       case CONSTRUCTOR:
14273         TREE_ADDRESSABLE (x) = 1;
14274         return true;
14275
14276       case VAR_DECL:
14277       case CONST_DECL:
14278       case PARM_DECL:
14279       case RESULT_DECL:
14280         if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x)
14281             && DECL_NONLOCAL (x))
14282           {
14283             if (TREE_PUBLIC (x))
14284               {
14285                 assert ("address of global register var requested" == NULL);
14286                 return false;
14287               }
14288             assert ("address of register variable requested" == NULL);
14289           }
14290         else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x))
14291           {
14292             if (TREE_PUBLIC (x))
14293               {
14294                 assert ("address of global register var requested" == NULL);
14295                 return false;
14296               }
14297             assert ("address of register var requested" == NULL);
14298           }
14299         put_var_into_stack (x, /*rescan=*/true);
14300
14301         /* drops in */
14302       case FUNCTION_DECL:
14303         TREE_ADDRESSABLE (x) = 1;
14304 #if 0                           /* poplevel deals with this now.  */
14305         if (DECL_CONTEXT (x) == 0)
14306           TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x)) = 1;
14307 #endif
14308
14309       default:
14310         return true;
14311       }
14312 }
14313
14314 /* Exit a binding level.
14315    Pop the level off, and restore the state of the identifier-decl mappings
14316    that were in effect when this level was entered.
14317
14318    If KEEP is nonzero, this level had explicit declarations, so
14319    and create a "block" (a BLOCK node) for the level
14320    to record its declarations and subblocks for symbol table output.
14321
14322    If FUNCTIONBODY is nonzero, this level is the body of a function,
14323    so create a block as if KEEP were set and also clear out all
14324    label names.
14325
14326    If REVERSE is nonzero, reverse the order of decls before putting
14327    them into the BLOCK.  */
14328
14329 tree
14330 poplevel (int keep, int reverse, int functionbody)
14331 {
14332   register tree link;
14333   /* The chain of decls was accumulated in reverse order.
14334      Put it into forward order, just for cleanliness.  */
14335   tree decls;
14336   tree subblocks = current_binding_level->blocks;
14337   tree block = 0;
14338   tree decl;
14339   int block_previously_created;
14340
14341   /* Get the decls in the order they were written.
14342      Usually current_binding_level->names is in reverse order.
14343      But parameter decls were previously put in forward order.  */
14344
14345   if (reverse)
14346     current_binding_level->names
14347       = decls = nreverse (current_binding_level->names);
14348   else
14349     decls = current_binding_level->names;
14350
14351   /* Output any nested inline functions within this block
14352      if they weren't already output.  */
14353
14354   for (decl = decls; decl; decl = TREE_CHAIN (decl))
14355     if (TREE_CODE (decl) == FUNCTION_DECL
14356         && ! TREE_ASM_WRITTEN (decl)
14357         && DECL_INITIAL (decl) != 0
14358         && TREE_ADDRESSABLE (decl))
14359       {
14360         /* If this decl was copied from a file-scope decl
14361            on account of a block-scope extern decl,
14362            propagate TREE_ADDRESSABLE to the file-scope decl.
14363
14364            DECL_ABSTRACT_ORIGIN can be set to itself if warn_return_type is
14365            true, since then the decl goes through save_for_inline_copying.  */
14366         if (DECL_ABSTRACT_ORIGIN (decl) != 0
14367             && DECL_ABSTRACT_ORIGIN (decl) != decl)
14368           TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl)) = 1;
14369         else if (DECL_SAVED_INSNS (decl) != 0)
14370           {
14371             push_function_context ();
14372             output_inline_function (decl);
14373             pop_function_context ();
14374           }
14375       }
14376
14377   /* If there were any declarations or structure tags in that level,
14378      or if this level is a function body,
14379      create a BLOCK to record them for the life of this function.  */
14380
14381   block = 0;
14382   block_previously_created = (current_binding_level->this_block != 0);
14383   if (block_previously_created)
14384     block = current_binding_level->this_block;
14385   else if (keep || functionbody)
14386     block = make_node (BLOCK);
14387   if (block != 0)
14388     {
14389       BLOCK_VARS (block) = decls;
14390       BLOCK_SUBBLOCKS (block) = subblocks;
14391     }
14392
14393   /* In each subblock, record that this is its superior.  */
14394
14395   for (link = subblocks; link; link = TREE_CHAIN (link))
14396     BLOCK_SUPERCONTEXT (link) = block;
14397
14398   /* Clear out the meanings of the local variables of this level.  */
14399
14400   for (link = decls; link; link = TREE_CHAIN (link))
14401     {
14402       if (DECL_NAME (link) != 0)
14403         {
14404           /* If the ident. was used or addressed via a local extern decl,
14405              don't forget that fact.  */
14406           if (DECL_EXTERNAL (link))
14407             {
14408               if (TREE_USED (link))
14409                 TREE_USED (DECL_NAME (link)) = 1;
14410               if (TREE_ADDRESSABLE (link))
14411                 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (link)) = 1;
14412             }
14413           IDENTIFIER_LOCAL_VALUE (DECL_NAME (link)) = 0;
14414         }
14415     }
14416
14417   /* If the level being exited is the top level of a function,
14418      check over all the labels, and clear out the current
14419      (function local) meanings of their names.  */
14420
14421   if (functionbody)
14422     {
14423       /* If this is the top level block of a function,
14424          the vars are the function's parameters.
14425          Don't leave them in the BLOCK because they are
14426          found in the FUNCTION_DECL instead.  */
14427
14428       BLOCK_VARS (block) = 0;
14429     }
14430
14431   /* Pop the current level, and free the structure for reuse.  */
14432
14433   {
14434     register struct f_binding_level *level = current_binding_level;
14435     current_binding_level = current_binding_level->level_chain;
14436
14437     level->level_chain = free_binding_level;
14438     free_binding_level = level;
14439   }
14440
14441   /* Dispose of the block that we just made inside some higher level.  */
14442   if (functionbody
14443       && current_function_decl != error_mark_node)
14444     DECL_INITIAL (current_function_decl) = block;
14445   else if (block)
14446     {
14447       if (!block_previously_created)
14448         current_binding_level->blocks
14449           = chainon (current_binding_level->blocks, block);
14450     }
14451   /* If we did not make a block for the level just exited,
14452      any blocks made for inner levels
14453      (since they cannot be recorded as subblocks in that level)
14454      must be carried forward so they will later become subblocks
14455      of something else.  */
14456   else if (subblocks)
14457     current_binding_level->blocks
14458       = chainon (current_binding_level->blocks, subblocks);
14459
14460   if (block)
14461     TREE_USED (block) = 1;
14462   return block;
14463 }
14464
14465 static void
14466 ffe_print_identifier (FILE *file, tree node, int indent)
14467 {
14468   print_node (file, "global", IDENTIFIER_GLOBAL_VALUE (node), indent + 4);
14469   print_node (file, "local", IDENTIFIER_LOCAL_VALUE (node), indent + 4);
14470 }
14471
14472 /* Record a decl-node X as belonging to the current lexical scope.
14473    Check for errors (such as an incompatible declaration for the same
14474    name already seen in the same scope).
14475
14476    Returns either X or an old decl for the same name.
14477    If an old decl is returned, it may have been smashed
14478    to agree with what X says.  */
14479
14480 tree
14481 pushdecl (tree x)
14482 {
14483   register tree t;
14484   register tree name = DECL_NAME (x);
14485   register struct f_binding_level *b = current_binding_level;
14486
14487   if ((TREE_CODE (x) == FUNCTION_DECL)
14488       && (DECL_INITIAL (x) == 0)
14489       && DECL_EXTERNAL (x))
14490     DECL_CONTEXT (x) = NULL_TREE;
14491   else
14492     DECL_CONTEXT (x) = current_function_decl;
14493
14494   if (name)
14495     {
14496       if (IDENTIFIER_INVENTED (name))
14497         {
14498           DECL_ARTIFICIAL (x) = 1;
14499           DECL_IN_SYSTEM_HEADER (x) = 1;
14500         }
14501
14502       t = lookup_name_current_level (name);
14503
14504       assert ((t == NULL_TREE) || (DECL_CONTEXT (x) == NULL_TREE));
14505
14506       /* Don't push non-parms onto list for parms until we understand
14507          why we're doing this and whether it works.  */
14508
14509       assert ((b == global_binding_level)
14510               || !ffecom_transform_only_dummies_
14511               || TREE_CODE (x) == PARM_DECL);
14512
14513       if ((t != NULL_TREE) && duplicate_decls (x, t))
14514         return t;
14515
14516       /* If we are processing a typedef statement, generate a whole new
14517          ..._TYPE node (which will be just an variant of the existing
14518          ..._TYPE node with identical properties) and then install the
14519          TYPE_DECL node generated to represent the typedef name as the
14520          TYPE_NAME of this brand new (duplicate) ..._TYPE node.
14521
14522          The whole point here is to end up with a situation where each and every
14523          ..._TYPE node the compiler creates will be uniquely associated with
14524          AT MOST one node representing a typedef name. This way, even though
14525          the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL
14526          (i.e. "typedef name") nodes very early on, later parts of the
14527          compiler can always do the reverse translation and get back the
14528          corresponding typedef name.  For example, given:
14529
14530          typedef struct S MY_TYPE; MY_TYPE object;
14531
14532          Later parts of the compiler might only know that `object' was of type
14533          `struct S' if it were not for code just below.  With this code
14534          however, later parts of the compiler see something like:
14535
14536          struct S' == struct S typedef struct S' MY_TYPE; struct S' object;
14537
14538          And they can then deduce (from the node for type struct S') that the
14539          original object declaration was:
14540
14541          MY_TYPE object;
14542
14543          Being able to do this is important for proper support of protoize, and
14544          also for generating precise symbolic debugging information which
14545          takes full account of the programmer's (typedef) vocabulary.
14546
14547          Obviously, we don't want to generate a duplicate ..._TYPE node if the
14548          TYPE_DECL node that we are now processing really represents a
14549          standard built-in type.
14550
14551          Since all standard types are effectively declared at line zero in the
14552          source file, we can easily check to see if we are working on a
14553          standard type by checking the current value of lineno.  */
14554
14555       if (TREE_CODE (x) == TYPE_DECL)
14556         {
14557           if (DECL_SOURCE_LINE (x) == 0)
14558             {
14559               if (TYPE_NAME (TREE_TYPE (x)) == 0)
14560                 TYPE_NAME (TREE_TYPE (x)) = x;
14561             }
14562           else if (TREE_TYPE (x) != error_mark_node)
14563             {
14564               tree tt = TREE_TYPE (x);
14565
14566               tt = build_type_copy (tt);
14567               TYPE_NAME (tt) = x;
14568               TREE_TYPE (x) = tt;
14569             }
14570         }
14571
14572       /* This name is new in its binding level. Install the new declaration
14573          and return it.  */
14574       if (b == global_binding_level)
14575         IDENTIFIER_GLOBAL_VALUE (name) = x;
14576       else
14577         IDENTIFIER_LOCAL_VALUE (name) = x;
14578     }
14579
14580   /* Put decls on list in reverse order. We will reverse them later if
14581      necessary.  */
14582   TREE_CHAIN (x) = b->names;
14583   b->names = x;
14584
14585   return x;
14586 }
14587
14588 /* Nonzero if the current level needs to have a BLOCK made.  */
14589
14590 static int
14591 kept_level_p ()
14592 {
14593   tree decl;
14594
14595   for (decl = current_binding_level->names;
14596        decl;
14597        decl = TREE_CHAIN (decl))
14598     {
14599       if (TREE_USED (decl) || TREE_CODE (decl) != VAR_DECL
14600           || (DECL_NAME (decl) && ! DECL_ARTIFICIAL (decl)))
14601         /* Currently, there aren't supposed to be non-artificial names
14602            at other than the top block for a function -- they're
14603            believed to always be temps.  But it's wise to check anyway.  */
14604         return 1;
14605     }
14606   return 0;
14607 }
14608
14609 /* Enter a new binding level.
14610    If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
14611    not for that of tags.  */
14612
14613 void
14614 pushlevel (int tag_transparent)
14615 {
14616   register struct f_binding_level *newlevel = NULL_BINDING_LEVEL;
14617
14618   assert (! tag_transparent);
14619
14620   if (current_binding_level == global_binding_level)
14621     {
14622       named_labels = 0;
14623     }
14624
14625   /* Reuse or create a struct for this binding level.  */
14626
14627   if (free_binding_level)
14628     {
14629       newlevel = free_binding_level;
14630       free_binding_level = free_binding_level->level_chain;
14631     }
14632   else
14633     {
14634       newlevel = make_binding_level ();
14635     }
14636
14637   /* Add this level to the front of the chain (stack) of levels that
14638      are active.  */
14639
14640   *newlevel = clear_binding_level;
14641   newlevel->level_chain = current_binding_level;
14642   current_binding_level = newlevel;
14643 }
14644
14645 /* Set the BLOCK node for the innermost scope
14646    (the one we are currently in).  */
14647
14648 void
14649 set_block (tree block)
14650 {
14651   current_binding_level->this_block = block;
14652   current_binding_level->names = chainon (current_binding_level->names,
14653                                           BLOCK_VARS (block));
14654   current_binding_level->blocks = chainon (current_binding_level->blocks,
14655                                            BLOCK_SUBBLOCKS (block));
14656 }
14657
14658 static tree
14659 ffe_signed_or_unsigned_type (int unsignedp, tree type)
14660 {
14661   tree type2;
14662
14663   if (! INTEGRAL_TYPE_P (type))
14664     return type;
14665   if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node))
14666     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
14667   if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node))
14668     return unsignedp ? unsigned_type_node : integer_type_node;
14669   if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node))
14670     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
14671   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node))
14672     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
14673   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node))
14674     return (unsignedp ? long_long_unsigned_type_node
14675             : long_long_integer_type_node);
14676
14677   type2 = ffe_type_for_size (TYPE_PRECISION (type), unsignedp);
14678   if (type2 == NULL_TREE)
14679     return type;
14680
14681   return type2;
14682 }
14683
14684 static tree
14685 ffe_signed_type (tree type)
14686 {
14687   tree type1 = TYPE_MAIN_VARIANT (type);
14688   ffeinfoKindtype kt;
14689   tree type2;
14690
14691   if (type1 == unsigned_char_type_node || type1 == char_type_node)
14692     return signed_char_type_node;
14693   if (type1 == unsigned_type_node)
14694     return integer_type_node;
14695   if (type1 == short_unsigned_type_node)
14696     return short_integer_type_node;
14697   if (type1 == long_unsigned_type_node)
14698     return long_integer_type_node;
14699   if (type1 == long_long_unsigned_type_node)
14700     return long_long_integer_type_node;
14701 #if 0   /* gcc/c-* files only */
14702   if (type1 == unsigned_intDI_type_node)
14703     return intDI_type_node;
14704   if (type1 == unsigned_intSI_type_node)
14705     return intSI_type_node;
14706   if (type1 == unsigned_intHI_type_node)
14707     return intHI_type_node;
14708   if (type1 == unsigned_intQI_type_node)
14709     return intQI_type_node;
14710 #endif
14711
14712   type2 = ffe_type_for_size (TYPE_PRECISION (type1), 0);
14713   if (type2 != NULL_TREE)
14714     return type2;
14715
14716   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
14717     {
14718       type2 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
14719
14720       if (type1 == type2)
14721         return ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
14722     }
14723
14724   return type;
14725 }
14726
14727 /* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
14728    or validate its data type for an `if' or `while' statement or ?..: exp.
14729
14730    This preparation consists of taking the ordinary
14731    representation of an expression expr and producing a valid tree
14732    boolean expression describing whether expr is nonzero.  We could
14733    simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
14734    but we optimize comparisons, &&, ||, and !.
14735
14736    The resulting type should always be `integer_type_node'.  */
14737
14738 static tree
14739 ffe_truthvalue_conversion (tree expr)
14740 {
14741   if (TREE_CODE (expr) == ERROR_MARK)
14742     return expr;
14743
14744 #if 0 /* This appears to be wrong for C++.  */
14745   /* These really should return error_mark_node after 2.4 is stable.
14746      But not all callers handle ERROR_MARK properly.  */
14747   switch (TREE_CODE (TREE_TYPE (expr)))
14748     {
14749     case RECORD_TYPE:
14750       error ("struct type value used where scalar is required");
14751       return integer_zero_node;
14752
14753     case UNION_TYPE:
14754       error ("union type value used where scalar is required");
14755       return integer_zero_node;
14756
14757     case ARRAY_TYPE:
14758       error ("array type value used where scalar is required");
14759       return integer_zero_node;
14760
14761     default:
14762       break;
14763     }
14764 #endif /* 0 */
14765
14766   switch (TREE_CODE (expr))
14767     {
14768       /* It is simpler and generates better code to have only TRUTH_*_EXPR
14769          or comparison expressions as truth values at this level.  */
14770 #if 0
14771     case COMPONENT_REF:
14772       /* A one-bit unsigned bit-field is already acceptable.  */
14773       if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr, 1)))
14774           && TREE_UNSIGNED (TREE_OPERAND (expr, 1)))
14775         return expr;
14776       break;
14777 #endif
14778
14779     case EQ_EXPR:
14780       /* It is simpler and generates better code to have only TRUTH_*_EXPR
14781          or comparison expressions as truth values at this level.  */
14782 #if 0
14783       if (integer_zerop (TREE_OPERAND (expr, 1)))
14784         return build_unary_op (TRUTH_NOT_EXPR, TREE_OPERAND (expr, 0), 0);
14785 #endif
14786     case NE_EXPR: case LE_EXPR: case GE_EXPR: case LT_EXPR: case GT_EXPR:
14787     case TRUTH_ANDIF_EXPR:
14788     case TRUTH_ORIF_EXPR:
14789     case TRUTH_AND_EXPR:
14790     case TRUTH_OR_EXPR:
14791     case TRUTH_XOR_EXPR:
14792       TREE_TYPE (expr) = integer_type_node;
14793       return expr;
14794
14795     case ERROR_MARK:
14796       return expr;
14797
14798     case INTEGER_CST:
14799       return integer_zerop (expr) ? integer_zero_node : integer_one_node;
14800
14801     case REAL_CST:
14802       return real_zerop (expr) ? integer_zero_node : integer_one_node;
14803
14804     case ADDR_EXPR:
14805       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 0)))
14806         return build (COMPOUND_EXPR, integer_type_node,
14807                       TREE_OPERAND (expr, 0), integer_one_node);
14808       else
14809         return integer_one_node;
14810
14811     case COMPLEX_EXPR:
14812       return ffecom_2 ((TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1))
14813                         ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
14814                        integer_type_node,
14815                        ffe_truthvalue_conversion (TREE_OPERAND (expr, 0)),
14816                        ffe_truthvalue_conversion (TREE_OPERAND (expr, 1)));
14817
14818     case NEGATE_EXPR:
14819     case ABS_EXPR:
14820     case FLOAT_EXPR:
14821     case FFS_EXPR:
14822       /* These don't change whether an object is nonzero or zero.  */
14823       return ffe_truthvalue_conversion (TREE_OPERAND (expr, 0));
14824
14825     case LROTATE_EXPR:
14826     case RROTATE_EXPR:
14827       /* These don't change whether an object is zero or nonzero, but
14828          we can't ignore them if their second arg has side-effects.  */
14829       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1)))
14830         return build (COMPOUND_EXPR, integer_type_node, TREE_OPERAND (expr, 1),
14831                       ffe_truthvalue_conversion (TREE_OPERAND (expr, 0)));
14832       else
14833         return ffe_truthvalue_conversion (TREE_OPERAND (expr, 0));
14834
14835     case COND_EXPR:
14836       {
14837         /* Distribute the conversion into the arms of a COND_EXPR.  */
14838         tree arg1 = TREE_OPERAND (expr, 1);
14839         tree arg2 = TREE_OPERAND (expr, 2);
14840         if (! VOID_TYPE_P (TREE_TYPE (arg1)))
14841           arg1 = ffe_truthvalue_conversion (arg1);
14842         if (! VOID_TYPE_P (TREE_TYPE (arg2)))
14843           arg2 = ffe_truthvalue_conversion (arg2);
14844         return fold (build (COND_EXPR, integer_type_node,
14845                             TREE_OPERAND (expr, 0), arg1, arg2));
14846       }
14847
14848     case CONVERT_EXPR:
14849       /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
14850          since that affects how `default_conversion' will behave.  */
14851       if (TREE_CODE (TREE_TYPE (expr)) == REFERENCE_TYPE
14852           || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) == REFERENCE_TYPE)
14853         break;
14854       /* fall through... */
14855     case NOP_EXPR:
14856       /* If this is widening the argument, we can ignore it.  */
14857       if (TYPE_PRECISION (TREE_TYPE (expr))
14858           >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr, 0))))
14859         return ffe_truthvalue_conversion (TREE_OPERAND (expr, 0));
14860       break;
14861
14862     case MINUS_EXPR:
14863       /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize
14864          this case.  */
14865       if (TARGET_FLOAT_FORMAT == IEEE_FLOAT_FORMAT
14866           && TREE_CODE (TREE_TYPE (expr)) == REAL_TYPE)
14867         break;
14868       /* fall through... */
14869     case BIT_XOR_EXPR:
14870       /* This and MINUS_EXPR can be changed into a comparison of the
14871          two objects.  */
14872       if (TREE_TYPE (TREE_OPERAND (expr, 0))
14873           == TREE_TYPE (TREE_OPERAND (expr, 1)))
14874         return ffecom_2 (NE_EXPR, integer_type_node,
14875                          TREE_OPERAND (expr, 0),
14876                          TREE_OPERAND (expr, 1));
14877       return ffecom_2 (NE_EXPR, integer_type_node,
14878                        TREE_OPERAND (expr, 0),
14879                        fold (build1 (NOP_EXPR,
14880                                      TREE_TYPE (TREE_OPERAND (expr, 0)),
14881                                      TREE_OPERAND (expr, 1))));
14882
14883     case BIT_AND_EXPR:
14884       if (integer_onep (TREE_OPERAND (expr, 1)))
14885         return expr;
14886       break;
14887
14888     case MODIFY_EXPR:
14889 #if 0                           /* No such thing in Fortran. */
14890       if (warn_parentheses && C_EXP_ORIGINAL_CODE (expr) == MODIFY_EXPR)
14891         warning ("suggest parentheses around assignment used as truth value");
14892 #endif
14893       break;
14894
14895     default:
14896       break;
14897     }
14898
14899   if (TREE_CODE (TREE_TYPE (expr)) == COMPLEX_TYPE)
14900     return (ffecom_2
14901             ((TREE_SIDE_EFFECTS (expr)
14902               ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
14903              integer_type_node,
14904              ffe_truthvalue_conversion (ffecom_1 (REALPART_EXPR,
14905                                                   TREE_TYPE (TREE_TYPE (expr)),
14906                                                   expr)),
14907              ffe_truthvalue_conversion (ffecom_1 (IMAGPART_EXPR,
14908                                                   TREE_TYPE (TREE_TYPE (expr)),
14909                                                   expr))));
14910
14911   return ffecom_2 (NE_EXPR, integer_type_node,
14912                    expr,
14913                    convert (TREE_TYPE (expr), integer_zero_node));
14914 }
14915
14916 static tree
14917 ffe_type_for_mode (enum machine_mode mode, int unsignedp)
14918 {
14919   int i;
14920   int j;
14921   tree t;
14922
14923   if (mode == TYPE_MODE (integer_type_node))
14924     return unsignedp ? unsigned_type_node : integer_type_node;
14925
14926   if (mode == TYPE_MODE (signed_char_type_node))
14927     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
14928
14929   if (mode == TYPE_MODE (short_integer_type_node))
14930     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
14931
14932   if (mode == TYPE_MODE (long_integer_type_node))
14933     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
14934
14935   if (mode == TYPE_MODE (long_long_integer_type_node))
14936     return unsignedp ? long_long_unsigned_type_node : long_long_integer_type_node;
14937
14938 #if HOST_BITS_PER_WIDE_INT >= 64
14939   if (mode == TYPE_MODE (intTI_type_node))
14940     return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
14941 #endif
14942
14943   if (mode == TYPE_MODE (float_type_node))
14944     return float_type_node;
14945
14946   if (mode == TYPE_MODE (double_type_node))
14947     return double_type_node;
14948
14949   if (mode == TYPE_MODE (long_double_type_node))
14950     return long_double_type_node;
14951
14952  if (mode == TYPE_MODE (build_pointer_type (char_type_node)))
14953     return build_pointer_type (char_type_node);
14954
14955   if (mode == TYPE_MODE (build_pointer_type (integer_type_node)))
14956     return build_pointer_type (integer_type_node);
14957
14958   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
14959     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
14960       {
14961         if (((t = ffecom_tree_type[i][j]) != NULL_TREE)
14962             && (mode == TYPE_MODE (t)))
14963           {
14964             if ((i == FFEINFO_basictypeINTEGER) && unsignedp)
14965               return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][j];
14966             else
14967               return t;
14968           }
14969       }
14970
14971   return 0;
14972 }
14973
14974 static tree
14975 ffe_type_for_size (unsigned bits, int unsignedp)
14976 {
14977   ffeinfoKindtype kt;
14978   tree type_node;
14979
14980   if (bits == TYPE_PRECISION (integer_type_node))
14981     return unsignedp ? unsigned_type_node : integer_type_node;
14982
14983   if (bits == TYPE_PRECISION (signed_char_type_node))
14984     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
14985
14986   if (bits == TYPE_PRECISION (short_integer_type_node))
14987     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
14988
14989   if (bits == TYPE_PRECISION (long_integer_type_node))
14990     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
14991
14992   if (bits == TYPE_PRECISION (long_long_integer_type_node))
14993     return (unsignedp ? long_long_unsigned_type_node
14994             : long_long_integer_type_node);
14995
14996   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
14997     {
14998       type_node = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
14999
15000       if ((type_node != NULL_TREE) && (bits == TYPE_PRECISION (type_node)))
15001         return unsignedp ? ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]
15002           : type_node;
15003     }
15004
15005   return 0;
15006 }
15007
15008 static tree
15009 ffe_unsigned_type (tree type)
15010 {
15011   tree type1 = TYPE_MAIN_VARIANT (type);
15012   ffeinfoKindtype kt;
15013   tree type2;
15014
15015   if (type1 == signed_char_type_node || type1 == char_type_node)
15016     return unsigned_char_type_node;
15017   if (type1 == integer_type_node)
15018     return unsigned_type_node;
15019   if (type1 == short_integer_type_node)
15020     return short_unsigned_type_node;
15021   if (type1 == long_integer_type_node)
15022     return long_unsigned_type_node;
15023   if (type1 == long_long_integer_type_node)
15024     return long_long_unsigned_type_node;
15025 #if 0   /* gcc/c-* files only */
15026   if (type1 == intDI_type_node)
15027     return unsigned_intDI_type_node;
15028   if (type1 == intSI_type_node)
15029     return unsigned_intSI_type_node;
15030   if (type1 == intHI_type_node)
15031     return unsigned_intHI_type_node;
15032   if (type1 == intQI_type_node)
15033     return unsigned_intQI_type_node;
15034 #endif
15035
15036   type2 = ffe_type_for_size (TYPE_PRECISION (type1), 1);
15037   if (type2 != NULL_TREE)
15038     return type2;
15039
15040   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15041     {
15042       type2 = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15043
15044       if (type1 == type2)
15045         return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
15046     }
15047
15048   return type;
15049 }
15050 \f
15051 /* From gcc/cccp.c, the code to handle -I.  */
15052
15053 /* Skip leading "./" from a directory name.
15054    This may yield the empty string, which represents the current directory.  */
15055
15056 static const char *
15057 skip_redundant_dir_prefix (const char *dir)
15058 {
15059   while (dir[0] == '.' && dir[1] == '/')
15060     for (dir += 2; *dir == '/'; dir++)
15061       continue;
15062   if (dir[0] == '.' && !dir[1])
15063     dir++;
15064   return dir;
15065 }
15066
15067 /* The file_name_map structure holds a mapping of file names for a
15068    particular directory.  This mapping is read from the file named
15069    FILE_NAME_MAP_FILE in that directory.  Such a file can be used to
15070    map filenames on a file system with severe filename restrictions,
15071    such as DOS.  The format of the file name map file is just a series
15072    of lines with two tokens on each line.  The first token is the name
15073    to map, and the second token is the actual name to use.  */
15074
15075 struct file_name_map
15076 {
15077   struct file_name_map *map_next;
15078   char *map_from;
15079   char *map_to;
15080 };
15081
15082 #define FILE_NAME_MAP_FILE "header.gcc"
15083
15084 /* Current maximum length of directory names in the search path
15085    for include files.  (Altered as we get more of them.)  */
15086
15087 static int max_include_len = 0;
15088
15089 struct file_name_list
15090   {
15091     struct file_name_list *next;
15092     char *fname;
15093     /* Mapping of file names for this directory.  */
15094     struct file_name_map *name_map;
15095     /* Nonzero if name_map is valid.  */
15096     int got_name_map;
15097   };
15098
15099 static struct file_name_list *include = NULL;   /* First dir to search */
15100 static struct file_name_list *last_include = NULL;      /* Last in chain */
15101
15102 /* I/O buffer structure.
15103    The `fname' field is nonzero for source files and #include files
15104    and for the dummy text used for -D and -U.
15105    It is zero for rescanning results of macro expansion
15106    and for expanding macro arguments.  */
15107 #define INPUT_STACK_MAX 400
15108 static struct file_buf {
15109   const char *fname;
15110   /* Filename specified with #line command.  */
15111   const char *nominal_fname;
15112   /* Record where in the search path this file was found.
15113      For #include_next.  */
15114   struct file_name_list *dir;
15115   ffewhereLine line;
15116   ffewhereColumn column;
15117 } instack[INPUT_STACK_MAX];
15118
15119 static int last_error_tick = 0;    /* Incremented each time we print it.  */
15120 static int input_file_stack_tick = 0;  /* Incremented when status changes.  */
15121
15122 /* Current nesting level of input sources.
15123    `instack[indepth]' is the level currently being read.  */
15124 static int indepth = -1;
15125
15126 typedef struct file_buf FILE_BUF;
15127
15128 /* Nonzero means -I- has been seen,
15129    so don't look for #include "foo" the source-file directory.  */
15130 static int ignore_srcdir;
15131
15132 #ifndef INCLUDE_LEN_FUDGE
15133 #define INCLUDE_LEN_FUDGE 0
15134 #endif
15135
15136 static void append_include_chain (struct file_name_list *first,
15137                                   struct file_name_list *last);
15138 static FILE *open_include_file (char *filename,
15139                                 struct file_name_list *searchptr);
15140 static void print_containing_files (ffebadSeverity sev);
15141 static char *read_filename_string (int ch, FILE *f);
15142 static struct file_name_map *read_name_map (const char *dirname);
15143
15144 /* Append a chain of `struct file_name_list's
15145    to the end of the main include chain.
15146    FIRST is the beginning of the chain to append, and LAST is the end.  */
15147
15148 static void
15149 append_include_chain (struct file_name_list *first, struct file_name_list *last)
15150 {
15151   struct file_name_list *dir;
15152
15153   if (!first || !last)
15154     return;
15155
15156   if (include == 0)
15157     include = first;
15158   else
15159     last_include->next = first;
15160
15161   for (dir = first; ; dir = dir->next) {
15162     int len = strlen (dir->fname) + INCLUDE_LEN_FUDGE;
15163     if (len > max_include_len)
15164       max_include_len = len;
15165     if (dir == last)
15166       break;
15167   }
15168
15169   last->next = NULL;
15170   last_include = last;
15171 }
15172
15173 /* Try to open include file FILENAME.  SEARCHPTR is the directory
15174    being tried from the include file search path.  This function maps
15175    filenames on file systems based on information read by
15176    read_name_map.  */
15177
15178 static FILE *
15179 open_include_file (char *filename, struct file_name_list *searchptr)
15180 {
15181   register struct file_name_map *map;
15182   register char *from;
15183   char *p, *dir;
15184
15185   if (searchptr && ! searchptr->got_name_map)
15186     {
15187       searchptr->name_map = read_name_map (searchptr->fname
15188                                            ? searchptr->fname : ".");
15189       searchptr->got_name_map = 1;
15190     }
15191
15192   /* First check the mapping for the directory we are using.  */
15193   if (searchptr && searchptr->name_map)
15194     {
15195       from = filename;
15196       if (searchptr->fname)
15197         from += strlen (searchptr->fname) + 1;
15198       for (map = searchptr->name_map; map; map = map->map_next)
15199         {
15200           if (! strcmp (map->map_from, from))
15201             {
15202               /* Found a match.  */
15203               return fopen (map->map_to, "r");
15204             }
15205         }
15206     }
15207
15208   /* Try to find a mapping file for the particular directory we are
15209      looking in.  Thus #include <sys/types.h> will look up sys/types.h
15210      in /usr/include/header.gcc and look up types.h in
15211      /usr/include/sys/header.gcc.  */
15212   p = strrchr (filename, '/');
15213 #ifdef DIR_SEPARATOR
15214   if (! p) p = strrchr (filename, DIR_SEPARATOR);
15215   else {
15216     char *tmp = strrchr (filename, DIR_SEPARATOR);
15217     if (tmp != NULL && tmp > p) p = tmp;
15218   }
15219 #endif
15220   if (! p)
15221     p = filename;
15222   if (searchptr
15223       && searchptr->fname
15224       && strlen (searchptr->fname) == (size_t) (p - filename)
15225       && ! strncmp (searchptr->fname, filename, (int) (p - filename)))
15226     {
15227       /* FILENAME is in SEARCHPTR, which we've already checked.  */
15228       return fopen (filename, "r");
15229     }
15230
15231   if (p == filename)
15232     {
15233       from = filename;
15234       map = read_name_map (".");
15235     }
15236   else
15237     {
15238       dir = (char *) xmalloc (p - filename + 1);
15239       memcpy (dir, filename, p - filename);
15240       dir[p - filename] = '\0';
15241       from = p + 1;
15242       map = read_name_map (dir);
15243       free (dir);
15244     }
15245   for (; map; map = map->map_next)
15246     if (! strcmp (map->map_from, from))
15247       return fopen (map->map_to, "r");
15248
15249   return fopen (filename, "r");
15250 }
15251
15252 /* Print the file names and line numbers of the #include
15253    commands which led to the current file.  */
15254
15255 static void
15256 print_containing_files (ffebadSeverity sev)
15257 {
15258   FILE_BUF *ip = NULL;
15259   int i;
15260   int first = 1;
15261   const char *str1;
15262   const char *str2;
15263
15264   /* If stack of files hasn't changed since we last printed
15265      this info, don't repeat it.  */
15266   if (last_error_tick == input_file_stack_tick)
15267     return;
15268
15269   for (i = indepth; i >= 0; i--)
15270     if (instack[i].fname != NULL) {
15271       ip = &instack[i];
15272       break;
15273     }
15274
15275   /* Give up if we don't find a source file.  */
15276   if (ip == NULL)
15277     return;
15278
15279   /* Find the other, outer source files.  */
15280   for (i--; i >= 0; i--)
15281     if (instack[i].fname != NULL)
15282       {
15283         ip = &instack[i];
15284         if (first)
15285           {
15286             first = 0;
15287             str1 = "In file included";
15288           }
15289         else
15290           {
15291             str1 = "...          ...";
15292           }
15293
15294         if (i == 1)
15295           str2 = ":";
15296         else
15297           str2 = "";
15298
15299         /* xgettext:no-c-format */
15300         ffebad_start_msg ("%A from %B at %0%C", sev);
15301         ffebad_here (0, ip->line, ip->column);
15302         ffebad_string (str1);
15303         ffebad_string (ip->nominal_fname);
15304         ffebad_string (str2);
15305         ffebad_finish ();
15306       }
15307
15308   /* Record we have printed the status as of this time.  */
15309   last_error_tick = input_file_stack_tick;
15310 }
15311
15312 /* Read a space delimited string of unlimited length from a stdio
15313    file.  */
15314
15315 static char *
15316 read_filename_string (int ch, FILE *f)
15317 {
15318   char *alloc, *set;
15319   int len;
15320
15321   len = 20;
15322   set = alloc = xmalloc (len + 1);
15323   if (! ISSPACE (ch))
15324     {
15325       *set++ = ch;
15326       while ((ch = getc (f)) != EOF && ! ISSPACE (ch))
15327         {
15328           if (set - alloc == len)
15329             {
15330               len *= 2;
15331               alloc = xrealloc (alloc, len + 1);
15332               set = alloc + len / 2;
15333             }
15334           *set++ = ch;
15335         }
15336     }
15337   *set = '\0';
15338   ungetc (ch, f);
15339   return alloc;
15340 }
15341
15342 /* Read the file name map file for DIRNAME.  */
15343
15344 static struct file_name_map *
15345 read_name_map (const char *dirname)
15346 {
15347   /* This structure holds a linked list of file name maps, one per
15348      directory.  */
15349   struct file_name_map_list
15350     {
15351       struct file_name_map_list *map_list_next;
15352       char *map_list_name;
15353       struct file_name_map *map_list_map;
15354     };
15355   static struct file_name_map_list *map_list;
15356   register struct file_name_map_list *map_list_ptr;
15357   char *name;
15358   FILE *f;
15359   size_t dirlen;
15360   int separator_needed;
15361
15362   dirname = skip_redundant_dir_prefix (dirname);
15363
15364   for (map_list_ptr = map_list; map_list_ptr;
15365        map_list_ptr = map_list_ptr->map_list_next)
15366     if (! strcmp (map_list_ptr->map_list_name, dirname))
15367       return map_list_ptr->map_list_map;
15368
15369   map_list_ptr = ((struct file_name_map_list *)
15370                   xmalloc (sizeof (struct file_name_map_list)));
15371   map_list_ptr->map_list_name = xstrdup (dirname);
15372   map_list_ptr->map_list_map = NULL;
15373
15374   dirlen = strlen (dirname);
15375   separator_needed = dirlen != 0 && dirname[dirlen - 1] != '/';
15376   if (separator_needed)
15377     name = concat (dirname, "/", FILE_NAME_MAP_FILE, NULL);
15378   else
15379     name = concat (dirname, FILE_NAME_MAP_FILE, NULL);
15380   f = fopen (name, "r");
15381   free (name);
15382   if (!f)
15383     map_list_ptr->map_list_map = NULL;
15384   else
15385     {
15386       int ch;
15387
15388       while ((ch = getc (f)) != EOF)
15389         {
15390           char *from, *to;
15391           struct file_name_map *ptr;
15392
15393           if (ISSPACE (ch))
15394             continue;
15395           from = read_filename_string (ch, f);
15396           while ((ch = getc (f)) != EOF && ISSPACE (ch) && ch != '\n')
15397             ;
15398           to = read_filename_string (ch, f);
15399
15400           ptr = ((struct file_name_map *)
15401                  xmalloc (sizeof (struct file_name_map)));
15402           ptr->map_from = from;
15403
15404           /* Make the real filename absolute.  */
15405           if (*to == '/')
15406             ptr->map_to = to;
15407           else
15408             {
15409               if (separator_needed)
15410                 ptr->map_to = concat (dirname, "/", to, NULL);
15411               else
15412                 ptr->map_to = concat (dirname, to, NULL);
15413               free (to);
15414             }
15415
15416           ptr->map_next = map_list_ptr->map_list_map;
15417           map_list_ptr->map_list_map = ptr;
15418
15419           while ((ch = getc (f)) != '\n')
15420             if (ch == EOF)
15421               break;
15422         }
15423       fclose (f);
15424     }
15425
15426   map_list_ptr->map_list_next = map_list;
15427   map_list = map_list_ptr;
15428
15429   return map_list_ptr->map_list_map;
15430 }
15431
15432 static void
15433 ffecom_file_ (const char *name)
15434 {
15435   FILE_BUF *fp;
15436
15437   /* Do partial setup of input buffer for the sake of generating
15438      early #line directives (when -g is in effect).  */
15439
15440   fp = &instack[++indepth];
15441   memset ((char *) fp, 0, sizeof (FILE_BUF));
15442   if (name == NULL)
15443     name = "";
15444   fp->nominal_fname = fp->fname = name;
15445 }
15446
15447 static void
15448 ffecom_close_include_ (FILE *f)
15449 {
15450   fclose (f);
15451
15452   indepth--;
15453   input_file_stack_tick++;
15454
15455   ffewhere_line_kill (instack[indepth].line);
15456   ffewhere_column_kill (instack[indepth].column);
15457 }
15458
15459 static int
15460 ffecom_decode_include_option_ (char *spec)
15461 {
15462   struct file_name_list *dirtmp;
15463
15464   if (! ignore_srcdir && !strcmp (spec, "-"))
15465     ignore_srcdir = 1;
15466   else
15467     {
15468       dirtmp = (struct file_name_list *)
15469         xmalloc (sizeof (struct file_name_list));
15470       dirtmp->next = 0;         /* New one goes on the end */
15471       dirtmp->fname = spec;
15472       dirtmp->got_name_map = 0;
15473       if (spec[0] == 0)
15474         error ("directory name must immediately follow -I");
15475       else
15476         append_include_chain (dirtmp, dirtmp);
15477     }
15478   return 1;
15479 }
15480
15481 /* Open INCLUDEd file.  */
15482
15483 static FILE *
15484 ffecom_open_include_ (char *name, ffewhereLine l, ffewhereColumn c)
15485 {
15486   char *fbeg = name;
15487   size_t flen = strlen (fbeg);
15488   struct file_name_list *search_start = include; /* Chain of dirs to search */
15489   struct file_name_list dsp[1]; /* First in chain, if #include "..." */
15490   struct file_name_list *searchptr = 0;
15491   char *fname;          /* Dynamically allocated fname buffer */
15492   FILE *f;
15493   FILE_BUF *fp;
15494
15495   if (flen == 0)
15496     return NULL;
15497
15498   dsp[0].fname = NULL;
15499
15500   /* If -I- was specified, don't search current dir, only spec'd ones. */
15501   if (!ignore_srcdir)
15502     {
15503       for (fp = &instack[indepth]; fp >= instack; fp--)
15504         {
15505           int n;
15506           char *ep;
15507           const char *nam;
15508
15509           if ((nam = fp->nominal_fname) != NULL)
15510             {
15511               /* Found a named file.  Figure out dir of the file,
15512                  and put it in front of the search list.  */
15513               dsp[0].next = search_start;
15514               search_start = dsp;
15515 #ifndef VMS
15516               ep = strrchr (nam, '/');
15517 #ifdef DIR_SEPARATOR
15518             if (ep == NULL) ep = strrchr (nam, DIR_SEPARATOR);
15519             else {
15520               char *tmp = strrchr (nam, DIR_SEPARATOR);
15521               if (tmp != NULL && tmp > ep) ep = tmp;
15522             }
15523 #endif
15524 #else                           /* VMS */
15525               ep = strrchr (nam, ']');
15526               if (ep == NULL) ep = strrchr (nam, '>');
15527               if (ep == NULL) ep = strrchr (nam, ':');
15528               if (ep != NULL) ep++;
15529 #endif                          /* VMS */
15530               if (ep != NULL)
15531                 {
15532                   n = ep - nam;
15533                   dsp[0].fname = (char *) xmalloc (n + 1);
15534                   strncpy (dsp[0].fname, nam, n);
15535                   dsp[0].fname[n] = '\0';
15536                   if (n + INCLUDE_LEN_FUDGE > max_include_len)
15537                     max_include_len = n + INCLUDE_LEN_FUDGE;
15538                 }
15539               else
15540                 dsp[0].fname = NULL; /* Current directory */
15541               dsp[0].got_name_map = 0;
15542               break;
15543             }
15544         }
15545     }
15546
15547   /* Allocate this permanently, because it gets stored in the definitions
15548      of macros.  */
15549   fname = xmalloc (max_include_len + flen + 4);
15550   /* + 2 above for slash and terminating null.  */
15551   /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED
15552      for g77 yet).  */
15553
15554   /* If specified file name is absolute, just open it.  */
15555
15556   if (*fbeg == '/'
15557 #ifdef DIR_SEPARATOR
15558       || *fbeg == DIR_SEPARATOR
15559 #endif
15560       )
15561     {
15562       strncpy (fname, (char *) fbeg, flen);
15563       fname[flen] = 0;
15564       f = open_include_file (fname, NULL);
15565     }
15566   else
15567     {
15568       f = NULL;
15569
15570       /* Search directory path, trying to open the file.
15571          Copy each filename tried into FNAME.  */
15572
15573       for (searchptr = search_start; searchptr; searchptr = searchptr->next)
15574         {
15575           if (searchptr->fname)
15576             {
15577               /* The empty string in a search path is ignored.
15578                  This makes it possible to turn off entirely
15579                  a standard piece of the list.  */
15580               if (searchptr->fname[0] == 0)
15581                 continue;
15582               strcpy (fname, skip_redundant_dir_prefix (searchptr->fname));
15583               if (fname[0] && fname[strlen (fname) - 1] != '/')
15584                 strcat (fname, "/");
15585               fname[strlen (fname) + flen] = 0;
15586             }
15587           else
15588             fname[0] = 0;
15589
15590           strncat (fname, fbeg, flen);
15591 #ifdef VMS
15592           /* Change this 1/2 Unix 1/2 VMS file specification into a
15593              full VMS file specification */
15594           if (searchptr->fname && (searchptr->fname[0] != 0))
15595             {
15596               /* Fix up the filename */
15597               hack_vms_include_specification (fname);
15598             }
15599           else
15600             {
15601               /* This is a normal VMS filespec, so use it unchanged.  */
15602               strncpy (fname, (char *) fbeg, flen);
15603               fname[flen] = 0;
15604 #if 0   /* Not for g77.  */
15605               /* if it's '#include filename', add the missing .h */
15606               if (strchr (fname, '.') == NULL)
15607                 strcat (fname, ".h");
15608 #endif
15609             }
15610 #endif /* VMS */
15611           f = open_include_file (fname, searchptr);
15612 #ifdef EACCES
15613           if (f == NULL && errno == EACCES)
15614             {
15615               print_containing_files (FFEBAD_severityWARNING);
15616               /* xgettext:no-c-format */
15617               ffebad_start_msg ("At %0, INCLUDE file %A exists, but is not readable",
15618                                 FFEBAD_severityWARNING);
15619               ffebad_string (fname);
15620               ffebad_here (0, l, c);
15621               ffebad_finish ();
15622             }
15623 #endif
15624           if (f != NULL)
15625             break;
15626         }
15627     }
15628
15629   if (f == NULL)
15630     {
15631       /* A file that was not found.  */
15632
15633       strncpy (fname, (char *) fbeg, flen);
15634       fname[flen] = 0;
15635       print_containing_files (ffebad_severity (FFEBAD_OPEN_INCLUDE));
15636       ffebad_start (FFEBAD_OPEN_INCLUDE);
15637       ffebad_here (0, l, c);
15638       ffebad_string (fname);
15639       ffebad_finish ();
15640     }
15641
15642   if (dsp[0].fname != NULL)
15643     free (dsp[0].fname);
15644
15645   if (f == NULL)
15646     return NULL;
15647
15648   if (indepth >= (INPUT_STACK_MAX - 1))
15649     {
15650       print_containing_files (FFEBAD_severityFATAL);
15651       /* xgettext:no-c-format */
15652       ffebad_start_msg ("At %0, INCLUDE nesting too deep",
15653                         FFEBAD_severityFATAL);
15654       ffebad_string (fname);
15655       ffebad_here (0, l, c);
15656       ffebad_finish ();
15657       return NULL;
15658     }
15659
15660   instack[indepth].line = ffewhere_line_use (l);
15661   instack[indepth].column = ffewhere_column_use (c);
15662
15663   fp = &instack[indepth + 1];
15664   memset ((char *) fp, 0, sizeof (FILE_BUF));
15665   fp->nominal_fname = fp->fname = fname;
15666   fp->dir = searchptr;
15667
15668   indepth++;
15669   input_file_stack_tick++;
15670
15671   return f;
15672 }
15673
15674 /**INDENT* (Do not reformat this comment even with -fca option.)
15675    Data-gathering files: Given the source file listed below, compiled with
15676    f2c I obtained the output file listed after that, and from the output
15677    file I derived the above code.
15678
15679 -------- (begin input file to f2c)
15680         implicit none
15681         character*10 A1,A2
15682         complex C1,C2
15683         integer I1,I2
15684         real R1,R2
15685         double precision D1,D2
15686 C
15687         call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2)
15688 c /
15689         call fooI(I1/I2)
15690         call fooR(R1/I1)
15691         call fooD(D1/I1)
15692         call fooC(C1/I1)
15693         call fooR(R1/R2)
15694         call fooD(R1/D1)
15695         call fooD(D1/D2)
15696         call fooD(D1/R1)
15697         call fooC(C1/C2)
15698         call fooC(C1/R1)
15699         call fooZ(C1/D1)
15700 c **
15701         call fooI(I1**I2)
15702         call fooR(R1**I1)
15703         call fooD(D1**I1)
15704         call fooC(C1**I1)
15705         call fooR(R1**R2)
15706         call fooD(R1**D1)
15707         call fooD(D1**D2)
15708         call fooD(D1**R1)
15709         call fooC(C1**C2)
15710         call fooC(C1**R1)
15711         call fooZ(C1**D1)
15712 c FFEINTRIN_impABS
15713         call fooR(ABS(R1))
15714 c FFEINTRIN_impACOS
15715         call fooR(ACOS(R1))
15716 c FFEINTRIN_impAIMAG
15717         call fooR(AIMAG(C1))
15718 c FFEINTRIN_impAINT
15719         call fooR(AINT(R1))
15720 c FFEINTRIN_impALOG
15721         call fooR(ALOG(R1))
15722 c FFEINTRIN_impALOG10
15723         call fooR(ALOG10(R1))
15724 c FFEINTRIN_impAMAX0
15725         call fooR(AMAX0(I1,I2))
15726 c FFEINTRIN_impAMAX1
15727         call fooR(AMAX1(R1,R2))
15728 c FFEINTRIN_impAMIN0
15729         call fooR(AMIN0(I1,I2))
15730 c FFEINTRIN_impAMIN1
15731         call fooR(AMIN1(R1,R2))
15732 c FFEINTRIN_impAMOD
15733         call fooR(AMOD(R1,R2))
15734 c FFEINTRIN_impANINT
15735         call fooR(ANINT(R1))
15736 c FFEINTRIN_impASIN
15737         call fooR(ASIN(R1))
15738 c FFEINTRIN_impATAN
15739         call fooR(ATAN(R1))
15740 c FFEINTRIN_impATAN2
15741         call fooR(ATAN2(R1,R2))
15742 c FFEINTRIN_impCABS
15743         call fooR(CABS(C1))
15744 c FFEINTRIN_impCCOS
15745         call fooC(CCOS(C1))
15746 c FFEINTRIN_impCEXP
15747         call fooC(CEXP(C1))
15748 c FFEINTRIN_impCHAR
15749         call fooA(CHAR(I1))
15750 c FFEINTRIN_impCLOG
15751         call fooC(CLOG(C1))
15752 c FFEINTRIN_impCONJG
15753         call fooC(CONJG(C1))
15754 c FFEINTRIN_impCOS
15755         call fooR(COS(R1))
15756 c FFEINTRIN_impCOSH
15757         call fooR(COSH(R1))
15758 c FFEINTRIN_impCSIN
15759         call fooC(CSIN(C1))
15760 c FFEINTRIN_impCSQRT
15761         call fooC(CSQRT(C1))
15762 c FFEINTRIN_impDABS
15763         call fooD(DABS(D1))
15764 c FFEINTRIN_impDACOS
15765         call fooD(DACOS(D1))
15766 c FFEINTRIN_impDASIN
15767         call fooD(DASIN(D1))
15768 c FFEINTRIN_impDATAN
15769         call fooD(DATAN(D1))
15770 c FFEINTRIN_impDATAN2
15771         call fooD(DATAN2(D1,D2))
15772 c FFEINTRIN_impDCOS
15773         call fooD(DCOS(D1))
15774 c FFEINTRIN_impDCOSH
15775         call fooD(DCOSH(D1))
15776 c FFEINTRIN_impDDIM
15777         call fooD(DDIM(D1,D2))
15778 c FFEINTRIN_impDEXP
15779         call fooD(DEXP(D1))
15780 c FFEINTRIN_impDIM
15781         call fooR(DIM(R1,R2))
15782 c FFEINTRIN_impDINT
15783         call fooD(DINT(D1))
15784 c FFEINTRIN_impDLOG
15785         call fooD(DLOG(D1))
15786 c FFEINTRIN_impDLOG10
15787         call fooD(DLOG10(D1))
15788 c FFEINTRIN_impDMAX1
15789         call fooD(DMAX1(D1,D2))
15790 c FFEINTRIN_impDMIN1
15791         call fooD(DMIN1(D1,D2))
15792 c FFEINTRIN_impDMOD
15793         call fooD(DMOD(D1,D2))
15794 c FFEINTRIN_impDNINT
15795         call fooD(DNINT(D1))
15796 c FFEINTRIN_impDPROD
15797         call fooD(DPROD(R1,R2))
15798 c FFEINTRIN_impDSIGN
15799         call fooD(DSIGN(D1,D2))
15800 c FFEINTRIN_impDSIN
15801         call fooD(DSIN(D1))
15802 c FFEINTRIN_impDSINH
15803         call fooD(DSINH(D1))
15804 c FFEINTRIN_impDSQRT
15805         call fooD(DSQRT(D1))
15806 c FFEINTRIN_impDTAN
15807         call fooD(DTAN(D1))
15808 c FFEINTRIN_impDTANH
15809         call fooD(DTANH(D1))
15810 c FFEINTRIN_impEXP
15811         call fooR(EXP(R1))
15812 c FFEINTRIN_impIABS
15813         call fooI(IABS(I1))
15814 c FFEINTRIN_impICHAR
15815         call fooI(ICHAR(A1))
15816 c FFEINTRIN_impIDIM
15817         call fooI(IDIM(I1,I2))
15818 c FFEINTRIN_impIDNINT
15819         call fooI(IDNINT(D1))
15820 c FFEINTRIN_impINDEX
15821         call fooI(INDEX(A1,A2))
15822 c FFEINTRIN_impISIGN
15823         call fooI(ISIGN(I1,I2))
15824 c FFEINTRIN_impLEN
15825         call fooI(LEN(A1))
15826 c FFEINTRIN_impLGE
15827         call fooL(LGE(A1,A2))
15828 c FFEINTRIN_impLGT
15829         call fooL(LGT(A1,A2))
15830 c FFEINTRIN_impLLE
15831         call fooL(LLE(A1,A2))
15832 c FFEINTRIN_impLLT
15833         call fooL(LLT(A1,A2))
15834 c FFEINTRIN_impMAX0
15835         call fooI(MAX0(I1,I2))
15836 c FFEINTRIN_impMAX1
15837         call fooI(MAX1(R1,R2))
15838 c FFEINTRIN_impMIN0
15839         call fooI(MIN0(I1,I2))
15840 c FFEINTRIN_impMIN1
15841         call fooI(MIN1(R1,R2))
15842 c FFEINTRIN_impMOD
15843         call fooI(MOD(I1,I2))
15844 c FFEINTRIN_impNINT
15845         call fooI(NINT(R1))
15846 c FFEINTRIN_impSIGN
15847         call fooR(SIGN(R1,R2))
15848 c FFEINTRIN_impSIN
15849         call fooR(SIN(R1))
15850 c FFEINTRIN_impSINH
15851         call fooR(SINH(R1))
15852 c FFEINTRIN_impSQRT
15853         call fooR(SQRT(R1))
15854 c FFEINTRIN_impTAN
15855         call fooR(TAN(R1))
15856 c FFEINTRIN_impTANH
15857         call fooR(TANH(R1))
15858 c FFEINTRIN_imp_CMPLX_C
15859         call fooC(cmplx(C1,C2))
15860 c FFEINTRIN_imp_CMPLX_D
15861         call fooZ(cmplx(D1,D2))
15862 c FFEINTRIN_imp_CMPLX_I
15863         call fooC(cmplx(I1,I2))
15864 c FFEINTRIN_imp_CMPLX_R
15865         call fooC(cmplx(R1,R2))
15866 c FFEINTRIN_imp_DBLE_C
15867         call fooD(dble(C1))
15868 c FFEINTRIN_imp_DBLE_D
15869         call fooD(dble(D1))
15870 c FFEINTRIN_imp_DBLE_I
15871         call fooD(dble(I1))
15872 c FFEINTRIN_imp_DBLE_R
15873         call fooD(dble(R1))
15874 c FFEINTRIN_imp_INT_C
15875         call fooI(int(C1))
15876 c FFEINTRIN_imp_INT_D
15877         call fooI(int(D1))
15878 c FFEINTRIN_imp_INT_I
15879         call fooI(int(I1))
15880 c FFEINTRIN_imp_INT_R
15881         call fooI(int(R1))
15882 c FFEINTRIN_imp_REAL_C
15883         call fooR(real(C1))
15884 c FFEINTRIN_imp_REAL_D
15885         call fooR(real(D1))
15886 c FFEINTRIN_imp_REAL_I
15887         call fooR(real(I1))
15888 c FFEINTRIN_imp_REAL_R
15889         call fooR(real(R1))
15890 c
15891 c FFEINTRIN_imp_INT_D:
15892 c
15893 c FFEINTRIN_specIDINT
15894         call fooI(IDINT(D1))
15895 c
15896 c FFEINTRIN_imp_INT_R:
15897 c
15898 c FFEINTRIN_specIFIX
15899         call fooI(IFIX(R1))
15900 c FFEINTRIN_specINT
15901         call fooI(INT(R1))
15902 c
15903 c FFEINTRIN_imp_REAL_D:
15904 c
15905 c FFEINTRIN_specSNGL
15906         call fooR(SNGL(D1))
15907 c
15908 c FFEINTRIN_imp_REAL_I:
15909 c
15910 c FFEINTRIN_specFLOAT
15911         call fooR(FLOAT(I1))
15912 c FFEINTRIN_specREAL
15913         call fooR(REAL(I1))
15914 c
15915         end
15916 -------- (end input file to f2c)
15917
15918 -------- (begin output from providing above input file as input to:
15919 --------  `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
15920 --------     -e "s:^#.*$::g"')
15921
15922 //  -- translated by f2c (version 19950223).
15923    You must link the resulting object file with the libraries:
15924         -lf2c -lm   (in that order)
15925 //
15926
15927
15928 // f2c.h  --  Standard Fortran to C header file //
15929
15930 ///  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
15931
15932         - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
15933
15934
15935
15936
15937 // F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems //
15938 // we assume short, float are OK //
15939 typedef long int // long int // integer;
15940 typedef char *address;
15941 typedef short int shortint;
15942 typedef float real;
15943 typedef double doublereal;
15944 typedef struct { real r, i; } complex;
15945 typedef struct { doublereal r, i; } doublecomplex;
15946 typedef long int // long int // logical;
15947 typedef short int shortlogical;
15948 typedef char logical1;
15949 typedef char integer1;
15950 // typedef long long longint; // // system-dependent //
15951
15952
15953
15954
15955 // Extern is for use with -E //
15956
15957
15958
15959
15960 // I/O stuff //
15961
15962
15963
15964
15965
15966
15967
15968
15969 typedef long int // int or long int // flag;
15970 typedef long int // int or long int // ftnlen;
15971 typedef long int // int or long int // ftnint;
15972
15973
15974 //external read, write//
15975 typedef struct
15976 {       flag cierr;
15977         ftnint ciunit;
15978         flag ciend;
15979         char *cifmt;
15980         ftnint cirec;
15981 } cilist;
15982
15983 //internal read, write//
15984 typedef struct
15985 {       flag icierr;
15986         char *iciunit;
15987         flag iciend;
15988         char *icifmt;
15989         ftnint icirlen;
15990         ftnint icirnum;
15991 } icilist;
15992
15993 //open//
15994 typedef struct
15995 {       flag oerr;
15996         ftnint ounit;
15997         char *ofnm;
15998         ftnlen ofnmlen;
15999         char *osta;
16000         char *oacc;
16001         char *ofm;
16002         ftnint orl;
16003         char *oblnk;
16004 } olist;
16005
16006 //close//
16007 typedef struct
16008 {       flag cerr;
16009         ftnint cunit;
16010         char *csta;
16011 } cllist;
16012
16013 //rewind, backspace, endfile//
16014 typedef struct
16015 {       flag aerr;
16016         ftnint aunit;
16017 } alist;
16018
16019 // inquire //
16020 typedef struct
16021 {       flag inerr;
16022         ftnint inunit;
16023         char *infile;
16024         ftnlen infilen;
16025         ftnint  *inex;  //parameters in standard's order//
16026         ftnint  *inopen;
16027         ftnint  *innum;
16028         ftnint  *innamed;
16029         char    *inname;
16030         ftnlen  innamlen;
16031         char    *inacc;
16032         ftnlen  inacclen;
16033         char    *inseq;
16034         ftnlen  inseqlen;
16035         char    *indir;
16036         ftnlen  indirlen;
16037         char    *infmt;
16038         ftnlen  infmtlen;
16039         char    *inform;
16040         ftnint  informlen;
16041         char    *inunf;
16042         ftnlen  inunflen;
16043         ftnint  *inrecl;
16044         ftnint  *innrec;
16045         char    *inblank;
16046         ftnlen  inblanklen;
16047 } inlist;
16048
16049
16050
16051 union Multitype {       // for multiple entry points //
16052         integer1 g;
16053         shortint h;
16054         integer i;
16055         // longint j; //
16056         real r;
16057         doublereal d;
16058         complex c;
16059         doublecomplex z;
16060         };
16061
16062 typedef union Multitype Multitype;
16063
16064 typedef long Long;      // No longer used; formerly in Namelist //
16065
16066 struct Vardesc {        // for Namelist //
16067         char *name;
16068         char *addr;
16069         ftnlen *dims;
16070         int  type;
16071         };
16072 typedef struct Vardesc Vardesc;
16073
16074 struct Namelist {
16075         char *name;
16076         Vardesc **vars;
16077         int nvars;
16078         };
16079 typedef struct Namelist Namelist;
16080
16081
16082
16083
16084
16085
16086
16087
16088 // procedure parameter types for -A and -C++ //
16089
16090
16091
16092
16093 typedef int // Unknown procedure type // (*U_fp)();
16094 typedef shortint (*J_fp)();
16095 typedef integer (*I_fp)();
16096 typedef real (*R_fp)();
16097 typedef doublereal (*D_fp)(), (*E_fp)();
16098 typedef // Complex // void  (*C_fp)();
16099 typedef // Double Complex // void  (*Z_fp)();
16100 typedef logical (*L_fp)();
16101 typedef shortlogical (*K_fp)();
16102 typedef // Character // void  (*H_fp)();
16103 typedef // Subroutine // int (*S_fp)();
16104
16105 // E_fp is for real functions when -R is not specified //
16106 typedef void  C_f;      // complex function //
16107 typedef void  H_f;      // character function //
16108 typedef void  Z_f;      // double complex function //
16109 typedef doublereal E_f; // real function with -R not specified //
16110
16111 // undef any lower-case symbols that your C compiler predefines, e.g.: //
16112
16113
16114 // (No such symbols should be defined in a strict ANSI C compiler.
16115    We can avoid trouble with f2c-translated code by using
16116    gcc -ansi.) //
16117
16118
16119
16120
16121
16122
16123
16124
16125
16126
16127
16128
16129
16130
16131
16132
16133
16134
16135
16136
16137
16138
16139
16140 // Main program // MAIN__()
16141 {
16142     // System generated locals //
16143     integer i__1;
16144     real r__1, r__2;
16145     doublereal d__1, d__2;
16146     complex q__1;
16147     doublecomplex z__1, z__2, z__3;
16148     logical L__1;
16149     char ch__1[1];
16150
16151     // Builtin functions //
16152     void c_div();
16153     integer pow_ii();
16154     double pow_ri(), pow_di();
16155     void pow_ci();
16156     double pow_dd();
16157     void pow_zz();
16158     double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
16159             asin(), atan(), atan2(), c_abs();
16160     void c_cos(), c_exp(), c_log(), r_cnjg();
16161     double cos(), cosh();
16162     void c_sin(), c_sqrt();
16163     double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
16164             d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
16165     integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
16166     logical l_ge(), l_gt(), l_le(), l_lt();
16167     integer i_nint();
16168     double r_sign();
16169
16170     // Local variables //
16171     extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
16172             fool_(), fooz_(), getem_();
16173     static char a1[10], a2[10];
16174     static complex c1, c2;
16175     static doublereal d1, d2;
16176     static integer i1, i2;
16177     static real r1, r2;
16178
16179
16180     getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L);
16181 // / //
16182     i__1 = i1 / i2;
16183     fooi_(&i__1);
16184     r__1 = r1 / i1;
16185     foor_(&r__1);
16186     d__1 = d1 / i1;
16187     food_(&d__1);
16188     d__1 = (doublereal) i1;
16189     q__1.r = c1.r / d__1, q__1.i = c1.i / d__1;
16190     fooc_(&q__1);
16191     r__1 = r1 / r2;
16192     foor_(&r__1);
16193     d__1 = r1 / d1;
16194     food_(&d__1);
16195     d__1 = d1 / d2;
16196     food_(&d__1);
16197     d__1 = d1 / r1;
16198     food_(&d__1);
16199     c_div(&q__1, &c1, &c2);
16200     fooc_(&q__1);
16201     q__1.r = c1.r / r1, q__1.i = c1.i / r1;
16202     fooc_(&q__1);
16203     z__1.r = c1.r / d1, z__1.i = c1.i / d1;
16204     fooz_(&z__1);
16205 // ** //
16206     i__1 = pow_ii(&i1, &i2);
16207     fooi_(&i__1);
16208     r__1 = pow_ri(&r1, &i1);
16209     foor_(&r__1);
16210     d__1 = pow_di(&d1, &i1);
16211     food_(&d__1);
16212     pow_ci(&q__1, &c1, &i1);
16213     fooc_(&q__1);
16214     d__1 = (doublereal) r1;
16215     d__2 = (doublereal) r2;
16216     r__1 = pow_dd(&d__1, &d__2);
16217     foor_(&r__1);
16218     d__2 = (doublereal) r1;
16219     d__1 = pow_dd(&d__2, &d1);
16220     food_(&d__1);
16221     d__1 = pow_dd(&d1, &d2);
16222     food_(&d__1);
16223     d__2 = (doublereal) r1;
16224     d__1 = pow_dd(&d1, &d__2);
16225     food_(&d__1);
16226     z__2.r = c1.r, z__2.i = c1.i;
16227     z__3.r = c2.r, z__3.i = c2.i;
16228     pow_zz(&z__1, &z__2, &z__3);
16229     q__1.r = z__1.r, q__1.i = z__1.i;
16230     fooc_(&q__1);
16231     z__2.r = c1.r, z__2.i = c1.i;
16232     z__3.r = r1, z__3.i = 0.;
16233     pow_zz(&z__1, &z__2, &z__3);
16234     q__1.r = z__1.r, q__1.i = z__1.i;
16235     fooc_(&q__1);
16236     z__2.r = c1.r, z__2.i = c1.i;
16237     z__3.r = d1, z__3.i = 0.;
16238     pow_zz(&z__1, &z__2, &z__3);
16239     fooz_(&z__1);
16240 // FFEINTRIN_impABS //
16241     r__1 = (doublereal)((  r1  ) >= 0 ? (  r1  ) : -(  r1  ))  ;
16242     foor_(&r__1);
16243 // FFEINTRIN_impACOS //
16244     r__1 = acos(r1);
16245     foor_(&r__1);
16246 // FFEINTRIN_impAIMAG //
16247     r__1 = r_imag(&c1);
16248     foor_(&r__1);
16249 // FFEINTRIN_impAINT //
16250     r__1 = r_int(&r1);
16251     foor_(&r__1);
16252 // FFEINTRIN_impALOG //
16253     r__1 = log(r1);
16254     foor_(&r__1);
16255 // FFEINTRIN_impALOG10 //
16256     r__1 = r_lg10(&r1);
16257     foor_(&r__1);
16258 // FFEINTRIN_impAMAX0 //
16259     r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16260     foor_(&r__1);
16261 // FFEINTRIN_impAMAX1 //
16262     r__1 = (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16263     foor_(&r__1);
16264 // FFEINTRIN_impAMIN0 //
16265     r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16266     foor_(&r__1);
16267 // FFEINTRIN_impAMIN1 //
16268     r__1 = (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16269     foor_(&r__1);
16270 // FFEINTRIN_impAMOD //
16271     r__1 = r_mod(&r1, &r2);
16272     foor_(&r__1);
16273 // FFEINTRIN_impANINT //
16274     r__1 = r_nint(&r1);
16275     foor_(&r__1);
16276 // FFEINTRIN_impASIN //
16277     r__1 = asin(r1);
16278     foor_(&r__1);
16279 // FFEINTRIN_impATAN //
16280     r__1 = atan(r1);
16281     foor_(&r__1);
16282 // FFEINTRIN_impATAN2 //
16283     r__1 = atan2(r1, r2);
16284     foor_(&r__1);
16285 // FFEINTRIN_impCABS //
16286     r__1 = c_abs(&c1);
16287     foor_(&r__1);
16288 // FFEINTRIN_impCCOS //
16289     c_cos(&q__1, &c1);
16290     fooc_(&q__1);
16291 // FFEINTRIN_impCEXP //
16292     c_exp(&q__1, &c1);
16293     fooc_(&q__1);
16294 // FFEINTRIN_impCHAR //
16295     *(unsigned char *)&ch__1[0] = i1;
16296     fooa_(ch__1, 1L);
16297 // FFEINTRIN_impCLOG //
16298     c_log(&q__1, &c1);
16299     fooc_(&q__1);
16300 // FFEINTRIN_impCONJG //
16301     r_cnjg(&q__1, &c1);
16302     fooc_(&q__1);
16303 // FFEINTRIN_impCOS //
16304     r__1 = cos(r1);
16305     foor_(&r__1);
16306 // FFEINTRIN_impCOSH //
16307     r__1 = cosh(r1);
16308     foor_(&r__1);
16309 // FFEINTRIN_impCSIN //
16310     c_sin(&q__1, &c1);
16311     fooc_(&q__1);
16312 // FFEINTRIN_impCSQRT //
16313     c_sqrt(&q__1, &c1);
16314     fooc_(&q__1);
16315 // FFEINTRIN_impDABS //
16316     d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ;
16317     food_(&d__1);
16318 // FFEINTRIN_impDACOS //
16319     d__1 = acos(d1);
16320     food_(&d__1);
16321 // FFEINTRIN_impDASIN //
16322     d__1 = asin(d1);
16323     food_(&d__1);
16324 // FFEINTRIN_impDATAN //
16325     d__1 = atan(d1);
16326     food_(&d__1);
16327 // FFEINTRIN_impDATAN2 //
16328     d__1 = atan2(d1, d2);
16329     food_(&d__1);
16330 // FFEINTRIN_impDCOS //
16331     d__1 = cos(d1);
16332     food_(&d__1);
16333 // FFEINTRIN_impDCOSH //
16334     d__1 = cosh(d1);
16335     food_(&d__1);
16336 // FFEINTRIN_impDDIM //
16337     d__1 = d_dim(&d1, &d2);
16338     food_(&d__1);
16339 // FFEINTRIN_impDEXP //
16340     d__1 = exp(d1);
16341     food_(&d__1);
16342 // FFEINTRIN_impDIM //
16343     r__1 = r_dim(&r1, &r2);
16344     foor_(&r__1);
16345 // FFEINTRIN_impDINT //
16346     d__1 = d_int(&d1);
16347     food_(&d__1);
16348 // FFEINTRIN_impDLOG //
16349     d__1 = log(d1);
16350     food_(&d__1);
16351 // FFEINTRIN_impDLOG10 //
16352     d__1 = d_lg10(&d1);
16353     food_(&d__1);
16354 // FFEINTRIN_impDMAX1 //
16355     d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ;
16356     food_(&d__1);
16357 // FFEINTRIN_impDMIN1 //
16358     d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ;
16359     food_(&d__1);
16360 // FFEINTRIN_impDMOD //
16361     d__1 = d_mod(&d1, &d2);
16362     food_(&d__1);
16363 // FFEINTRIN_impDNINT //
16364     d__1 = d_nint(&d1);
16365     food_(&d__1);
16366 // FFEINTRIN_impDPROD //
16367     d__1 = (doublereal) r1 * r2;
16368     food_(&d__1);
16369 // FFEINTRIN_impDSIGN //
16370     d__1 = d_sign(&d1, &d2);
16371     food_(&d__1);
16372 // FFEINTRIN_impDSIN //
16373     d__1 = sin(d1);
16374     food_(&d__1);
16375 // FFEINTRIN_impDSINH //
16376     d__1 = sinh(d1);
16377     food_(&d__1);
16378 // FFEINTRIN_impDSQRT //
16379     d__1 = sqrt(d1);
16380     food_(&d__1);
16381 // FFEINTRIN_impDTAN //
16382     d__1 = tan(d1);
16383     food_(&d__1);
16384 // FFEINTRIN_impDTANH //
16385     d__1 = tanh(d1);
16386     food_(&d__1);
16387 // FFEINTRIN_impEXP //
16388     r__1 = exp(r1);
16389     foor_(&r__1);
16390 // FFEINTRIN_impIABS //
16391     i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ;
16392     fooi_(&i__1);
16393 // FFEINTRIN_impICHAR //
16394     i__1 = *(unsigned char *)a1;
16395     fooi_(&i__1);
16396 // FFEINTRIN_impIDIM //
16397     i__1 = i_dim(&i1, &i2);
16398     fooi_(&i__1);
16399 // FFEINTRIN_impIDNINT //
16400     i__1 = i_dnnt(&d1);
16401     fooi_(&i__1);
16402 // FFEINTRIN_impINDEX //
16403     i__1 = i_indx(a1, a2, 10L, 10L);
16404     fooi_(&i__1);
16405 // FFEINTRIN_impISIGN //
16406     i__1 = i_sign(&i1, &i2);
16407     fooi_(&i__1);
16408 // FFEINTRIN_impLEN //
16409     i__1 = i_len(a1, 10L);
16410     fooi_(&i__1);
16411 // FFEINTRIN_impLGE //
16412     L__1 = l_ge(a1, a2, 10L, 10L);
16413     fool_(&L__1);
16414 // FFEINTRIN_impLGT //
16415     L__1 = l_gt(a1, a2, 10L, 10L);
16416     fool_(&L__1);
16417 // FFEINTRIN_impLLE //
16418     L__1 = l_le(a1, a2, 10L, 10L);
16419     fool_(&L__1);
16420 // FFEINTRIN_impLLT //
16421     L__1 = l_lt(a1, a2, 10L, 10L);
16422     fool_(&L__1);
16423 // FFEINTRIN_impMAX0 //
16424     i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16425     fooi_(&i__1);
16426 // FFEINTRIN_impMAX1 //
16427     i__1 = (integer) (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16428     fooi_(&i__1);
16429 // FFEINTRIN_impMIN0 //
16430     i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16431     fooi_(&i__1);
16432 // FFEINTRIN_impMIN1 //
16433     i__1 = (integer) (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16434     fooi_(&i__1);
16435 // FFEINTRIN_impMOD //
16436     i__1 = i1 % i2;
16437     fooi_(&i__1);
16438 // FFEINTRIN_impNINT //
16439     i__1 = i_nint(&r1);
16440     fooi_(&i__1);
16441 // FFEINTRIN_impSIGN //
16442     r__1 = r_sign(&r1, &r2);
16443     foor_(&r__1);
16444 // FFEINTRIN_impSIN //
16445     r__1 = sin(r1);
16446     foor_(&r__1);
16447 // FFEINTRIN_impSINH //
16448     r__1 = sinh(r1);
16449     foor_(&r__1);
16450 // FFEINTRIN_impSQRT //
16451     r__1 = sqrt(r1);
16452     foor_(&r__1);
16453 // FFEINTRIN_impTAN //
16454     r__1 = tan(r1);
16455     foor_(&r__1);
16456 // FFEINTRIN_impTANH //
16457     r__1 = tanh(r1);
16458     foor_(&r__1);
16459 // FFEINTRIN_imp_CMPLX_C //
16460     r__1 = c1.r;
16461     r__2 = c2.r;
16462     q__1.r = r__1, q__1.i = r__2;
16463     fooc_(&q__1);
16464 // FFEINTRIN_imp_CMPLX_D //
16465     z__1.r = d1, z__1.i = d2;
16466     fooz_(&z__1);
16467 // FFEINTRIN_imp_CMPLX_I //
16468     r__1 = (real) i1;
16469     r__2 = (real) i2;
16470     q__1.r = r__1, q__1.i = r__2;
16471     fooc_(&q__1);
16472 // FFEINTRIN_imp_CMPLX_R //
16473     q__1.r = r1, q__1.i = r2;
16474     fooc_(&q__1);
16475 // FFEINTRIN_imp_DBLE_C //
16476     d__1 = (doublereal) c1.r;
16477     food_(&d__1);
16478 // FFEINTRIN_imp_DBLE_D //
16479     d__1 = d1;
16480     food_(&d__1);
16481 // FFEINTRIN_imp_DBLE_I //
16482     d__1 = (doublereal) i1;
16483     food_(&d__1);
16484 // FFEINTRIN_imp_DBLE_R //
16485     d__1 = (doublereal) r1;
16486     food_(&d__1);
16487 // FFEINTRIN_imp_INT_C //
16488     i__1 = (integer) c1.r;
16489     fooi_(&i__1);
16490 // FFEINTRIN_imp_INT_D //
16491     i__1 = (integer) d1;
16492     fooi_(&i__1);
16493 // FFEINTRIN_imp_INT_I //
16494     i__1 = i1;
16495     fooi_(&i__1);
16496 // FFEINTRIN_imp_INT_R //
16497     i__1 = (integer) r1;
16498     fooi_(&i__1);
16499 // FFEINTRIN_imp_REAL_C //
16500     r__1 = c1.r;
16501     foor_(&r__1);
16502 // FFEINTRIN_imp_REAL_D //
16503     r__1 = (real) d1;
16504     foor_(&r__1);
16505 // FFEINTRIN_imp_REAL_I //
16506     r__1 = (real) i1;
16507     foor_(&r__1);
16508 // FFEINTRIN_imp_REAL_R //
16509     r__1 = r1;
16510     foor_(&r__1);
16511
16512 // FFEINTRIN_imp_INT_D: //
16513
16514 // FFEINTRIN_specIDINT //
16515     i__1 = (integer) d1;
16516     fooi_(&i__1);
16517
16518 // FFEINTRIN_imp_INT_R: //
16519
16520 // FFEINTRIN_specIFIX //
16521     i__1 = (integer) r1;
16522     fooi_(&i__1);
16523 // FFEINTRIN_specINT //
16524     i__1 = (integer) r1;
16525     fooi_(&i__1);
16526
16527 // FFEINTRIN_imp_REAL_D: //
16528
16529 // FFEINTRIN_specSNGL //
16530     r__1 = (real) d1;
16531     foor_(&r__1);
16532
16533 // FFEINTRIN_imp_REAL_I: //
16534
16535 // FFEINTRIN_specFLOAT //
16536     r__1 = (real) i1;
16537     foor_(&r__1);
16538 // FFEINTRIN_specREAL //
16539     r__1 = (real) i1;
16540     foor_(&r__1);
16541
16542 } // MAIN__ //
16543
16544 -------- (end output file from f2c)
16545
16546 */
16547
16548 #include "gt-f-com.h"
16549 #include "gtype-f.h"