gcc/f/com.c

   1 /* com.c -- Implementation File (module.c template V1.0)
   2    Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002
   3    Free Software Foundation, Inc.
   4    Contributed by James Craig Burley.
   5
   6 This file is part of GNU Fortran.
   7
   8 GNU Fortran is free software; you can redistribute it and/or modify
   9 it under the terms of the GNU General Public License as published by
  10 the Free Software Foundation; either version 2, or (at your option)
  11 any later version.
  12
  13 GNU Fortran is distributed in the hope that it will be useful,
  14 but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 GNU General Public License for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with GNU Fortran; see the file COPYING.  If not, write to
  20 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
  21 02111-1307, USA.
  22
  23    Related Modules:
  24       None
  25
  26    Description:
  27       Contains compiler-specific functions.
  28
  29    Modifications:
  30 */
  31
  32 /* Understanding this module means understanding the interface between
  33    the g77 front end and the gcc back end (or, perhaps, some other
  34    back end).  In here are the functions called by the front end proper
  35    to notify whatever back end is in place about certain things, and
  36    also the back-end-specific functions.  It's a bear to deal with, so
  37    lately I've been trying to simplify things, especially with regard
  38    to the gcc-back-end-specific stuff.
  39
  40    Building expressions generally seems quite easy, but building decls
  41    has been challenging and is undergoing revision.  gcc has several
  42    kinds of decls:
  43
  44    TYPE_DECL -- a type (int, float, struct, function, etc.)
  45    CONST_DECL -- a constant of some type other than function
  46    LABEL_DECL -- a variable or a constant?
  47    PARM_DECL -- an argument to a function (a variable that is a dummy)
  48    RESULT_DECL -- the return value of a function (a variable)
  49    VAR_DECL -- other variable (can hold a ptr-to-function, struct, int, etc.)
  50    FUNCTION_DECL -- a function (either the actual function or an extern ref)
  51    FIELD_DECL -- a field in a struct or union (goes into types)
  52
  53    g77 has a set of functions that somewhat parallels the gcc front end
  54    when it comes to building decls:
  55
  56    Internal Function (one we define, not just declare as extern):
  57    if (is_nested) push_f_function_context ();
  58    start_function (get_identifier ("function_name"), function_type,
  59                    is_nested, is_public);
  60    // for each arg, build PARM_DECL and call push_parm_decl (decl) with it;
  61    store_parm_decls (is_main_program);
  62    ffecom_start_compstmt ();
  63    // for stmts and decls inside function, do appropriate things;
  64    ffecom_end_compstmt ();
  65    finish_function (is_nested);
  66    if (is_nested) pop_f_function_context ();
  67
  68    Everything Else:
  69    tree d;
  70    tree init;
  71    // fill in external, public, static, &c for decl, and
  72    // set DECL_INITIAL to error_mark_node if going to initialize
  73    // set is_top_level TRUE only if not at top level and decl
  74    // must go in top level (i.e. not within current function decl context)
  75    d = start_decl (decl, is_top_level);
  76    init = ...;  // if have initializer
  77    finish_decl (d, init, is_top_level);
  78
  79 */
  80
  81 /* Include files. */
  82
  83 #include "proj.h"
  84 #include "flags.h"
  85 #include "real.h"
  86 #include "rtl.h"
  87 #include "toplev.h"
  88 #include "tree.h"
  89 #include "output.h"  /* Must follow tree.h so TREE_CODE is defined! */
  90 #include "convert.h"
  91 #include "ggc.h"
  92 #include "diagnostic.h"
  93 #include "intl.h"
  94 #include "langhooks.h"
  95 #include "langhooks-def.h"
  96 #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 {
 610   union tree_node GTY ((tag ("0"),
 611                         desc ("tree_node_structure (&%h)")))
 612     generic;
 613   struct lang_identifier GTY ((tag ("1"))) identifier;
 614 };
 615
 616 /* Fortran doesn't use either of these.  */
 617 struct lang_decl GTY(())
 618 {
 619 };
 620 struct lang_type GTY(())
 621 {
 622 };
 623
 624 /* In identifiers, C uses the following fields in a special way:
 625    TREE_PUBLIC        to record that there was a previous local extern decl.
 626    TREE_USED          to record that such a decl was used.
 627    TREE_ADDRESSABLE   to record that the address of such a decl was used.  */
 628
 629 /* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function
 630    that have names.  Here so we can clear out their names' definitions
 631    at the end of the function.  */
 632
 633 static GTY(()) tree named_labels;
 634
 635 /* A list of LABEL_DECLs from outer contexts that are currently shadowed.  */
 636
 637 static GTY(()) tree shadowed_labels;
 638 \f
 639 /* Return the subscript expression, modified to do range-checking.
 640
 641    `array' is the array to be checked against.
 642    `element' is the subscript expression to check.
 643    `dim' is the dimension number (starting at 0).
 644    `total_dims' is the total number of dimensions (0 for CHARACTER substring).
 645 */
 646
 647 static tree
 648 ffecom_subscript_check_ (tree array, tree element, int dim, int total_dims,
 649                          const char *array_name)
 650 {
 651   tree low = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
 652   tree high = TYPE_MAX_VALUE (TYPE_DOMAIN (array));
 653   tree cond;
 654   tree die;
 655   tree args;
 656
 657   if (element == error_mark_node)
 658     return element;
 659
 660   if (TREE_TYPE (low) != TREE_TYPE (element))
 661     {
 662       if (TYPE_PRECISION (TREE_TYPE (low))
 663           > TYPE_PRECISION (TREE_TYPE (element)))
 664         element = convert (TREE_TYPE (low), element);
 665       else
 666         {
 667           low = convert (TREE_TYPE (element), low);
 668           if (high)
 669             high = convert (TREE_TYPE (element), high);
 670         }
 671     }
 672
 673   element = ffecom_save_tree (element);
 674   if (total_dims == 0)
 675     {
 676       /* Special handling for substring range checks.  Fortran allows the
 677          end subscript < begin subscript, which means that expressions like
 678        string(1:0) are valid (and yield a null string).  In view of this,
 679        enforce two simpler conditions:
 680           1) element<=high for end-substring;
 681           2) element>=low for start-substring.
 682        Run-time character movement will enforce remaining conditions.
 683
 684        More complicated checks would be better, but present structure only
 685        provides one index element at a time, so it is not possible to
 686        enforce a check of both i and j in string(i:j).  If it were, the
 687        complete set of rules would read,
 688          if ( ((j<i) && ((low<=i<=high) || (low<=j<=high))) ||
 689               ((low<=i<=high) && (low<=j<=high)) )
 690            ok ;
 691          else
 692            range error ;
 693       */
 694       if (dim)
 695         cond = ffecom_2 (LE_EXPR, integer_type_node, element, high);
 696       else
 697         cond = ffecom_2 (LE_EXPR, integer_type_node, low, element);
 698     }
 699   else
 700     {
 701       /* Array reference substring range checking.  */
 702
 703       cond = ffecom_2 (LE_EXPR, integer_type_node,
 704                      low,
 705                      element);
 706       if (high)
 707         {
 708           cond = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
 709                          cond,
 710                          ffecom_2 (LE_EXPR, integer_type_node,
 711                                    element,
 712                                    high));
 713         }
 714     }
 715
 716   {
 717     int len;
 718     char *proc;
 719     char *var;
 720     tree arg3;
 721     tree arg2;
 722     tree arg1;
 723     tree arg4;
 724
 725     switch (total_dims)
 726       {
 727       case 0:
 728         var = concat (array_name, "[", (dim ? "end" : "start"),
 729                       "-substring]", NULL);
 730         len = strlen (var) + 1;
 731         arg1 = build_string (len, var);
 732         free (var);
 733         break;
 734
 735       case 1:
 736         len = strlen (array_name) + 1;
 737         arg1 = build_string (len, array_name);
 738         break;
 739
 740       default:
 741         var = xmalloc (strlen (array_name) + 40);
 742         sprintf (var, "%s[subscript-%d-of-%d]",
 743                  array_name,
 744                  dim + 1, total_dims);
 745         len = strlen (var) + 1;
 746         arg1 = build_string (len, var);
 747         free (var);
 748         break;
 749       }
 750
 751     TREE_TYPE (arg1)
 752       = build_type_variant (build_array_type (char_type_node,
 753                                               build_range_type
 754                                               (integer_type_node,
 755                                                integer_one_node,
 756                                                build_int_2 (len, 0))),
 757                             1, 0);
 758     TREE_CONSTANT (arg1) = 1;
 759     TREE_STATIC (arg1) = 1;
 760     arg1 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg1)),
 761                      arg1);
 762
 763     /* s_rnge adds one to the element to print it, so bias against
 764        that -- want to print a faithful *subscript* value.  */
 765     arg2 = convert (ffecom_f2c_ftnint_type_node,
 766                     ffecom_2 (MINUS_EXPR,
 767                               TREE_TYPE (element),
 768                               element,
 769                               convert (TREE_TYPE (element),
 770                                        integer_one_node)));
 771
 772     proc = concat (input_filename, "/",
 773                    IDENTIFIER_POINTER (DECL_NAME (current_function_decl)),
 774                    NULL);
 775     len = strlen (proc) + 1;
 776     arg3 = build_string (len, proc);
 777
 778     free (proc);
 779
 780     TREE_TYPE (arg3)
 781       = build_type_variant (build_array_type (char_type_node,
 782                                               build_range_type
 783                                               (integer_type_node,
 784                                                integer_one_node,
 785                                                build_int_2 (len, 0))),
 786                             1, 0);
 787     TREE_CONSTANT (arg3) = 1;
 788     TREE_STATIC (arg3) = 1;
 789     arg3 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg3)),
 790                      arg3);
 791
 792     arg4 = convert (ffecom_f2c_ftnint_type_node,
 793                     build_int_2 (lineno, 0));
 794
 795     arg1 = build_tree_list (NULL_TREE, arg1);
 796     arg2 = build_tree_list (NULL_TREE, arg2);
 797     arg3 = build_tree_list (NULL_TREE, arg3);
 798     arg4 = build_tree_list (NULL_TREE, arg4);
 799     TREE_CHAIN (arg3) = arg4;
 800     TREE_CHAIN (arg2) = arg3;
 801     TREE_CHAIN (arg1) = arg2;
 802
 803     args = arg1;
 804   }
 805   die = ffecom_call_gfrt (FFECOM_gfrtRANGE,
 806                           args, NULL_TREE);
 807   TREE_SIDE_EFFECTS (die) = 1;
 808
 809   element = ffecom_3 (COND_EXPR,
 810                       TREE_TYPE (element),
 811                       cond,
 812                       element,
 813                       die);
 814
 815   return element;
 816 }
 817
 818 /* Return the computed element of an array reference.
 819
 820    `item' is NULL_TREE, or the transformed pointer to the array.
 821    `expr' is the original opARRAYREF expression, which is transformed
 822      if `item' is NULL_TREE.
 823    `want_ptr' is non-zero if a pointer to the element, instead of
 824      the element itself, is to be returned.  */
 825
 826 static tree
 827 ffecom_arrayref_ (tree item, ffebld expr, int want_ptr)
 828 {
 829   ffebld dims[FFECOM_dimensionsMAX];
 830   int i;
 831   int total_dims;
 832   int flatten = ffe_is_flatten_arrays ();
 833   int need_ptr;
 834   tree array;
 835   tree element;
 836   tree tree_type;
 837   tree tree_type_x;
 838   const char *array_name;
 839   ffetype type;
 840   ffebld list;
 841
 842   if (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER)
 843     array_name = ffesymbol_text (ffebld_symter (ffebld_left (expr)));
 844   else
 845     array_name = "[expr?]";
 846
 847   /* Build up ARRAY_REFs in reverse order (since we're column major
 848      here in Fortran land). */
 849
 850   for (i = 0, list = ffebld_right (expr);
 851        list != NULL;
 852        ++i, list = ffebld_trail (list))
 853     {
 854       dims[i] = ffebld_head (list);
 855       type = ffeinfo_type (ffebld_basictype (dims[i]),
 856                            ffebld_kindtype (dims[i]));
 857       if (! flatten
 858           && ffecom_typesize_pointer_ > ffecom_typesize_integer1_
 859           && ffetype_size (type) > ffecom_typesize_integer1_)
 860         /* E.g. ARRAY(INDEX), given INTEGER*8 INDEX, on a system with 64-bit
 861            pointers and 32-bit integers.  Do the full 64-bit pointer
 862            arithmetic, for codes using arrays for nonstandard heap-like
 863            work.  */
 864         flatten = 1;
 865     }
 866
 867   total_dims = i;
 868
 869   need_ptr = want_ptr || flatten;
 870
 871   if (! item)
 872     {
 873       if (need_ptr)
 874         item = ffecom_ptr_to_expr (ffebld_left (expr));
 875       else
 876         item = ffecom_expr (ffebld_left (expr));
 877
 878       if (item == error_mark_node)
 879         return item;
 880
 881       if (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereFLEETING
 882           && ! ffe_mark_addressable (item))
 883         return error_mark_node;
 884     }
 885
 886   if (item == error_mark_node)
 887     return item;
 888
 889   if (need_ptr)
 890     {
 891       tree min;
 892
 893       for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
 894            i >= 0;
 895            --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array)))
 896         {
 897           min = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
 898           element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
 899           if (flag_bounds_check)
 900             element = ffecom_subscript_check_ (array, element, i, total_dims,
 901                                                array_name);
 902           if (element == error_mark_node)
 903             return element;
 904
 905           /* Widen integral arithmetic as desired while preserving
 906              signedness.  */
 907           tree_type = TREE_TYPE (element);
 908           tree_type_x = tree_type;
 909           if (tree_type
 910               && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
 911               && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
 912             tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
 913
 914           if (TREE_TYPE (min) != tree_type_x)
 915             min = convert (tree_type_x, min);
 916           if (TREE_TYPE (element) != tree_type_x)
 917             element = convert (tree_type_x, element);
 918
 919           item = ffecom_2 (PLUS_EXPR,
 920                            build_pointer_type (TREE_TYPE (array)),
 921                            item,
 922                            size_binop (MULT_EXPR,
 923                                        size_in_bytes (TREE_TYPE (array)),
 924                                        convert (sizetype,
 925                                                 fold (build (MINUS_EXPR,
 926                                                              tree_type_x,
 927                                                              element, min)))));
 928         }
 929       if (! want_ptr)
 930         {
 931           item = ffecom_1 (INDIRECT_REF,
 932                            TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
 933                            item);
 934         }
 935     }
 936   else
 937     {
 938       for (--i;
 939            i >= 0;
 940            --i)
 941         {
 942           array = TYPE_MAIN_VARIANT (TREE_TYPE (item));
 943
 944           element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
 945           if (flag_bounds_check)
 946             element = ffecom_subscript_check_ (array, element, i, total_dims,
 947                                                array_name);
 948           if (element == error_mark_node)
 949             return element;
 950
 951           /* Widen integral arithmetic as desired while preserving
 952              signedness.  */
 953           tree_type = TREE_TYPE (element);
 954           tree_type_x = tree_type;
 955           if (tree_type
 956               && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
 957               && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
 958             tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
 959
 960           element = convert (tree_type_x, element);
 961
 962           item = ffecom_2 (ARRAY_REF,
 963                            TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
 964                            item,
 965                            element);
 966         }
 967     }
 968
 969   return item;
 970 }
 971
 972 /* This is like gcc's stabilize_reference -- in fact, most of the code
 973    comes from that -- but it handles the situation where the reference
 974    is going to have its subparts picked at, and it shouldn't change
 975    (or trigger extra invocations of functions in the subtrees) due to
 976    this.  save_expr is a bit overzealous, because we don't need the
 977    entire thing calculated and saved like a temp.  So, for DECLs, no
 978    change is needed, because these are stable aggregates, and ARRAY_REF
 979    and such might well be stable too, but for things like calculations,
 980    we do need to calculate a snapshot of a value before picking at it.  */
 981
 982 static tree
 983 ffecom_stabilize_aggregate_ (tree ref)
 984 {
 985   tree result;
 986   enum tree_code code = TREE_CODE (ref);
 987
 988   switch (code)
 989     {
 990     case VAR_DECL:
 991     case PARM_DECL:
 992     case RESULT_DECL:
 993       /* No action is needed in this case.  */
 994       return ref;
 995
 996     case NOP_EXPR:
 997     case CONVERT_EXPR:
 998     case FLOAT_EXPR:
 999     case FIX_TRUNC_EXPR:
1000     case FIX_FLOOR_EXPR:
1001     case FIX_ROUND_EXPR:
1002     case FIX_CEIL_EXPR:
1003       result = build_nt (code, stabilize_reference (TREE_OPERAND (ref, 0)));
1004       break;
1005
1006     case INDIRECT_REF:
1007       result = build_nt (INDIRECT_REF,
1008                          stabilize_reference_1 (TREE_OPERAND (ref, 0)));
1009       break;
1010
1011     case COMPONENT_REF:
1012       result = build_nt (COMPONENT_REF,
1013                          stabilize_reference (TREE_OPERAND (ref, 0)),
1014                          TREE_OPERAND (ref, 1));
1015       break;
1016
1017     case BIT_FIELD_REF:
1018       result = build_nt (BIT_FIELD_REF,
1019                          stabilize_reference (TREE_OPERAND (ref, 0)),
1020                          stabilize_reference_1 (TREE_OPERAND (ref, 1)),
1021                          stabilize_reference_1 (TREE_OPERAND (ref, 2)));
1022       break;
1023
1024     case ARRAY_REF:
1025       result = build_nt (ARRAY_REF,
1026                          stabilize_reference (TREE_OPERAND (ref, 0)),
1027                          stabilize_reference_1 (TREE_OPERAND (ref, 1)));
1028       break;
1029
1030     case COMPOUND_EXPR:
1031       result = build_nt (COMPOUND_EXPR,
1032                          stabilize_reference_1 (TREE_OPERAND (ref, 0)),
1033                          stabilize_reference (TREE_OPERAND (ref, 1)));
1034       break;
1035
1036     case RTL_EXPR:
1037       abort ();
1038
1039
1040     default:
1041       return save_expr (ref);
1042
1043     case ERROR_MARK:
1044       return error_mark_node;
1045     }
1046
1047   TREE_TYPE (result) = TREE_TYPE (ref);
1048   TREE_READONLY (result) = TREE_READONLY (ref);
1049   TREE_SIDE_EFFECTS (result) = TREE_SIDE_EFFECTS (ref);
1050   TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref);
1051
1052   return result;
1053 }
1054
1055 /* A rip-off of gcc's convert.c convert_to_complex function,
1056    reworked to handle complex implemented as C structures
1057    (RECORD_TYPE with two fields, real and imaginary `r' and `i').  */
1058
1059 static tree
1060 ffecom_convert_to_complex_ (tree type, tree expr)
1061 {
1062   register enum tree_code form = TREE_CODE (TREE_TYPE (expr));
1063   tree subtype;
1064
1065   assert (TREE_CODE (type) == RECORD_TYPE);
1066
1067   subtype = TREE_TYPE (TYPE_FIELDS (type));
1068
1069   if (form == REAL_TYPE || form == INTEGER_TYPE || form == ENUMERAL_TYPE)
1070     {
1071       expr = convert (subtype, expr);
1072       return ffecom_2 (COMPLEX_EXPR, type, expr,
1073                        convert (subtype, integer_zero_node));
1074     }
1075
1076   if (form == RECORD_TYPE)
1077     {
1078       tree elt_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr)));
1079       if (TYPE_MAIN_VARIANT (elt_type) == TYPE_MAIN_VARIANT (subtype))
1080         return expr;
1081       else
1082         {
1083           expr = save_expr (expr);
1084           return ffecom_2 (COMPLEX_EXPR,
1085                            type,
1086                            convert (subtype,
1087                                     ffecom_1 (REALPART_EXPR,
1088                                               TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1089                                               expr)),
1090                            convert (subtype,
1091                                     ffecom_1 (IMAGPART_EXPR,
1092                                               TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1093                                               expr)));
1094         }
1095     }
1096
1097   if (form == POINTER_TYPE || form == REFERENCE_TYPE)
1098     error ("pointer value used where a complex was expected");
1099   else
1100     error ("aggregate value used where a complex was expected");
1101
1102   return ffecom_2 (COMPLEX_EXPR, type,
1103                    convert (subtype, integer_zero_node),
1104                    convert (subtype, integer_zero_node));
1105 }
1106
1107 /* Like gcc's convert(), but crashes if widening might happen.  */
1108
1109 static tree
1110 ffecom_convert_narrow_ (type, expr)
1111      tree type, expr;
1112 {
1113   register tree e = expr;
1114   register enum tree_code code = TREE_CODE (type);
1115
1116   if (type == TREE_TYPE (e)
1117       || TREE_CODE (e) == ERROR_MARK)
1118     return e;
1119   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1120     return fold (build1 (NOP_EXPR, type, e));
1121   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1122       || code == ERROR_MARK)
1123     return error_mark_node;
1124   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1125     {
1126       assert ("void value not ignored as it ought to be" == NULL);
1127       return error_mark_node;
1128     }
1129   assert (code != VOID_TYPE);
1130   if ((code != RECORD_TYPE)
1131       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1132     assert ("converting COMPLEX to REAL" == NULL);
1133   assert (code != ENUMERAL_TYPE);
1134   if (code == INTEGER_TYPE)
1135     {
1136       assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1137                && TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)))
1138               || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1139                   && (TYPE_PRECISION (type)
1140                       == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1141       return fold (convert_to_integer (type, e));
1142     }
1143   if (code == POINTER_TYPE)
1144     {
1145       assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1146       return fold (convert_to_pointer (type, e));
1147     }
1148   if (code == REAL_TYPE)
1149     {
1150       assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1151       assert (TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)));
1152       return fold (convert_to_real (type, e));
1153     }
1154   if (code == COMPLEX_TYPE)
1155     {
1156       assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1157       assert (TYPE_PRECISION (TREE_TYPE (type)) <= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1158       return fold (convert_to_complex (type, e));
1159     }
1160   if (code == RECORD_TYPE)
1161     {
1162       assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1163       /* Check that at least the first field name agrees.  */
1164       assert (DECL_NAME (TYPE_FIELDS (type))
1165               == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1166       assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1167               <= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1168       if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1169           == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1170         return e;
1171       return fold (ffecom_convert_to_complex_ (type, e));
1172     }
1173
1174   assert ("conversion to non-scalar type requested" == NULL);
1175   return error_mark_node;
1176 }
1177
1178 /* Like gcc's convert(), but crashes if narrowing might happen.  */
1179
1180 static tree
1181 ffecom_convert_widen_ (type, expr)
1182      tree type, 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, NULL_TREE, 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 #ifdef HOHO
1816           tempvar = ffecom_make_tempvar (ffecom_tree_type
1817                                          [FFEINFO_basictypeCOMPLEX][kt],
1818                                          FFETARGET_charactersizeNONE,
1819                                          -1);
1820 #else
1821           tempvar = hook;
1822           assert (tempvar);
1823 #endif
1824         }
1825       else
1826         {
1827           *dest_used = TRUE;
1828           tempvar = dest_tree;
1829           type = NULL_TREE;
1830         }
1831
1832       item
1833         = build_tree_list (NULL_TREE,
1834                            ffecom_1 (ADDR_EXPR,
1835                                      build_pointer_type (TREE_TYPE (tempvar)),
1836                                      tempvar));
1837       TREE_CHAIN (item) = args;
1838
1839       item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1840                         item, NULL_TREE);
1841
1842       if (tempvar != dest_tree)
1843         item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item, tempvar);
1844     }
1845   else
1846     item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1847                       args, NULL_TREE);
1848
1849   if ((type != NULL_TREE) && (TREE_TYPE (item) != type))
1850     item = ffecom_convert_narrow_ (type, item);
1851
1852   return item;
1853 }
1854
1855 /* Given two arguments, transform them and make a call to the given
1856    function via ffecom_call_.  */
1857
1858 static tree
1859 ffecom_call_binop_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1860                     tree type, ffebld left, ffebld right,
1861                     tree dest_tree, ffebld dest, bool *dest_used,
1862                     tree callee_commons, bool scalar_args, bool ref, tree hook)
1863 {
1864   tree left_tree;
1865   tree right_tree;
1866   tree left_length;
1867   tree right_length;
1868
1869   if (ref)
1870     {
1871       /* Pass arguments by reference.  */
1872       left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
1873       right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
1874     }
1875   else
1876     {
1877       /* Pass arguments by value.  */
1878       left_tree = ffecom_arg_expr (left, &left_length);
1879       right_tree = ffecom_arg_expr (right, &right_length);
1880     }
1881
1882
1883   left_tree = build_tree_list (NULL_TREE, left_tree);
1884   right_tree = build_tree_list (NULL_TREE, right_tree);
1885   TREE_CHAIN (left_tree) = right_tree;
1886
1887   if (left_length != NULL_TREE)
1888     {
1889       left_length = build_tree_list (NULL_TREE, left_length);
1890       TREE_CHAIN (right_tree) = left_length;
1891     }
1892
1893   if (right_length != NULL_TREE)
1894     {
1895       right_length = build_tree_list (NULL_TREE, right_length);
1896       if (left_length != NULL_TREE)
1897         TREE_CHAIN (left_length) = right_length;
1898       else
1899         TREE_CHAIN (right_tree) = right_length;
1900     }
1901
1902   return ffecom_call_ (fn, kt, is_f2c_complex, type, left_tree,
1903                        dest_tree, dest, dest_used, callee_commons,
1904                        scalar_args, hook);
1905 }
1906
1907 /* Return ptr/length args for char subexpression
1908
1909    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
1910    subexpressions by constructing the appropriate trees for the ptr-to-
1911    character-text and length-of-character-text arguments in a calling
1912    sequence.
1913
1914    Note that if with_null is TRUE, and the expression is an opCONTER,
1915    a null byte is appended to the string.  */
1916
1917 static void
1918 ffecom_char_args_x_ (tree *xitem, tree *length, ffebld expr, bool with_null)
1919 {
1920   tree item;
1921   tree high;
1922   ffetargetCharacter1 val;
1923   ffetargetCharacterSize newlen;
1924
1925   switch (ffebld_op (expr))
1926     {
1927     case FFEBLD_opCONTER:
1928       val = ffebld_constant_character1 (ffebld_conter (expr));
1929       newlen = ffetarget_length_character1 (val);
1930       if (with_null)
1931         {
1932           /* Begin FFETARGET-NULL-KLUDGE.  */
1933           if (newlen != 0)
1934             ++newlen;
1935         }
1936       *length = build_int_2 (newlen, 0);
1937       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
1938       high = build_int_2 (newlen, 0);
1939       TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
1940       item = build_string (newlen,
1941                            ffetarget_text_character1 (val));
1942       /* End FFETARGET-NULL-KLUDGE.  */
1943       TREE_TYPE (item)
1944         = build_type_variant
1945           (build_array_type
1946            (char_type_node,
1947             build_range_type
1948             (ffecom_f2c_ftnlen_type_node,
1949              ffecom_f2c_ftnlen_one_node,
1950              high)),
1951            1, 0);
1952       TREE_CONSTANT (item) = 1;
1953       TREE_STATIC (item) = 1;
1954       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
1955                        item);
1956       break;
1957
1958     case FFEBLD_opSYMTER:
1959       {
1960         ffesymbol s = ffebld_symter (expr);
1961
1962         item = ffesymbol_hook (s).decl_tree;
1963         if (item == NULL_TREE)
1964           {
1965             s = ffecom_sym_transform_ (s);
1966             item = ffesymbol_hook (s).decl_tree;
1967           }
1968         if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
1969           {
1970             if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
1971               *length = ffesymbol_hook (s).length_tree;
1972             else
1973               {
1974                 *length = build_int_2 (ffesymbol_size (s), 0);
1975                 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
1976               }
1977           }
1978         else if (item == error_mark_node)
1979           *length = error_mark_node;
1980         else
1981           /* FFEINFO_kindFUNCTION.  */
1982           *length = NULL_TREE;
1983         if (!ffesymbol_hook (s).addr
1984             && (item != error_mark_node))
1985           item = ffecom_1 (ADDR_EXPR,
1986                            build_pointer_type (TREE_TYPE (item)),
1987                            item);
1988       }
1989       break;
1990
1991     case FFEBLD_opARRAYREF:
1992       {
1993         ffecom_char_args_ (&item, length, ffebld_left (expr));
1994
1995         if (item == error_mark_node || *length == error_mark_node)
1996           {
1997             item = *length = error_mark_node;
1998             break;
1999           }
2000
2001         item = ffecom_arrayref_ (item, expr, 1);
2002       }
2003       break;
2004
2005     case FFEBLD_opSUBSTR:
2006       {
2007         ffebld start;
2008         ffebld end;
2009         ffebld thing = ffebld_right (expr);
2010         tree start_tree;
2011         tree end_tree;
2012         const char *char_name;
2013         ffebld left_symter;
2014         tree array;
2015
2016         assert (ffebld_op (thing) == FFEBLD_opITEM);
2017         start = ffebld_head (thing);
2018         thing = ffebld_trail (thing);
2019         assert (ffebld_trail (thing) == NULL);
2020         end = ffebld_head (thing);
2021
2022         /* Determine name for pretty-printing range-check errors.  */
2023         for (left_symter = ffebld_left (expr);
2024              left_symter && ffebld_op (left_symter) == FFEBLD_opARRAYREF;
2025              left_symter = ffebld_left (left_symter))
2026           ;
2027         if (ffebld_op (left_symter) == FFEBLD_opSYMTER)
2028           char_name = ffesymbol_text (ffebld_symter (left_symter));
2029         else
2030           char_name = "[expr?]";
2031
2032         ffecom_char_args_ (&item, length, ffebld_left (expr));
2033
2034         if (item == error_mark_node || *length == error_mark_node)
2035           {
2036             item = *length = error_mark_node;
2037             break;
2038           }
2039
2040         array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
2041
2042         /* ~~~~Handle INTEGER*8 start/end, a la FFEBLD_opARRAYREF.  */
2043
2044         if (start == NULL)
2045           {
2046             if (end == NULL)
2047               ;
2048             else
2049               {
2050                 end_tree = ffecom_expr (end);
2051                 if (flag_bounds_check)
2052                   end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2053                                                       char_name);
2054                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2055                                     end_tree);
2056
2057                 if (end_tree == error_mark_node)
2058                   {
2059                     item = *length = error_mark_node;
2060                     break;
2061                   }
2062
2063                 *length = end_tree;
2064               }
2065           }
2066         else
2067           {
2068             start_tree = ffecom_expr (start);
2069             if (flag_bounds_check)
2070               start_tree = ffecom_subscript_check_ (array, start_tree, 0, 0,
2071                                                     char_name);
2072             start_tree = convert (ffecom_f2c_ftnlen_type_node,
2073                                   start_tree);
2074
2075             if (start_tree == error_mark_node)
2076               {
2077                 item = *length = error_mark_node;
2078                 break;
2079               }
2080
2081             start_tree = ffecom_save_tree (start_tree);
2082
2083             item = ffecom_2 (PLUS_EXPR, TREE_TYPE (item),
2084                              item,
2085                              ffecom_2 (MINUS_EXPR,
2086                                        TREE_TYPE (start_tree),
2087                                        start_tree,
2088                                        ffecom_f2c_ftnlen_one_node));
2089
2090             if (end == NULL)
2091               {
2092                 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2093                                     ffecom_f2c_ftnlen_one_node,
2094                                     ffecom_2 (MINUS_EXPR,
2095                                               ffecom_f2c_ftnlen_type_node,
2096                                               *length,
2097                                               start_tree));
2098               }
2099             else
2100               {
2101                 end_tree = ffecom_expr (end);
2102                 if (flag_bounds_check)
2103                   end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2104                                                       char_name);
2105                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2106                                     end_tree);
2107
2108                 if (end_tree == error_mark_node)
2109                   {
2110                     item = *length = error_mark_node;
2111                     break;
2112                   }
2113
2114                 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2115                                     ffecom_f2c_ftnlen_one_node,
2116                                     ffecom_2 (MINUS_EXPR,
2117                                               ffecom_f2c_ftnlen_type_node,
2118                                               end_tree, start_tree));
2119               }
2120           }
2121       }
2122       break;
2123
2124     case FFEBLD_opFUNCREF:
2125       {
2126         ffesymbol s = ffebld_symter (ffebld_left (expr));
2127         tree tempvar;
2128         tree args;
2129         ffetargetCharacterSize size = ffeinfo_size (ffebld_info (expr));
2130         ffecomGfrt ix;
2131
2132         if (size == FFETARGET_charactersizeNONE)
2133           /* ~~Kludge alert!  This should someday be fixed. */
2134           size = 24;
2135
2136         *length = build_int_2 (size, 0);
2137         TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2138
2139         if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
2140             == FFEINFO_whereINTRINSIC)
2141           {
2142             if (size == 1)
2143               {
2144                 /* Invocation of an intrinsic returning CHARACTER*1.  */
2145                 item = ffecom_expr_intrinsic_ (expr, NULL_TREE,
2146                                                NULL, NULL);
2147                 break;
2148               }
2149             ix = ffeintrin_gfrt_direct (ffebld_symter_implementation (ffebld_left (expr)));
2150             assert (ix != FFECOM_gfrt);
2151             item = ffecom_gfrt_tree_ (ix);
2152           }
2153         else
2154           {
2155             ix = FFECOM_gfrt;
2156             item = ffesymbol_hook (s).decl_tree;
2157             if (item == NULL_TREE)
2158               {
2159                 s = ffecom_sym_transform_ (s);
2160                 item = ffesymbol_hook (s).decl_tree;
2161               }
2162             if (item == error_mark_node)
2163               {
2164                 item = *length = error_mark_node;
2165                 break;
2166               }
2167
2168             if (!ffesymbol_hook (s).addr)
2169               item = ffecom_1_fn (item);
2170           }
2171
2172 #ifdef HOHO
2173         tempvar = ffecom_push_tempvar (char_type_node, size, -1, TRUE);
2174 #else
2175         tempvar = ffebld_nonter_hook (expr);
2176         assert (tempvar);
2177 #endif
2178         tempvar = ffecom_1 (ADDR_EXPR,
2179                             build_pointer_type (TREE_TYPE (tempvar)),
2180                             tempvar);
2181
2182         args = build_tree_list (NULL_TREE, tempvar);
2183
2184         if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)       /* Sfunc args by value. */
2185           TREE_CHAIN (args) = ffecom_list_expr (ffebld_right (expr));
2186         else
2187           {
2188             TREE_CHAIN (args) = build_tree_list (NULL_TREE, *length);
2189             if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
2190               {
2191                 TREE_CHAIN (TREE_CHAIN (args))
2192                   = ffecom_arglist_expr_ (ffecom_gfrt_args_ (ix),
2193                                           ffebld_right (expr));
2194               }
2195             else
2196               {
2197                 TREE_CHAIN (TREE_CHAIN (args))
2198                   = ffecom_list_ptr_to_expr (ffebld_right (expr));
2199               }
2200           }
2201
2202         item = ffecom_3s (CALL_EXPR,
2203                           TREE_TYPE (TREE_TYPE (TREE_TYPE (item))),
2204                           item, args, NULL_TREE);
2205         item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item,
2206                          tempvar);
2207       }
2208       break;
2209
2210     case FFEBLD_opCONVERT:
2211
2212       ffecom_char_args_ (&item, length, ffebld_left (expr));
2213
2214       if (item == error_mark_node || *length == error_mark_node)
2215         {
2216           item = *length = error_mark_node;
2217           break;
2218         }
2219
2220       if ((ffebld_size_known (ffebld_left (expr))
2221            == FFETARGET_charactersizeNONE)
2222           || (ffebld_size_known (ffebld_left (expr)) < (ffebld_size (expr))))
2223         {                       /* Possible blank-padding needed, copy into
2224                                    temporary. */
2225           tree tempvar;
2226           tree args;
2227           tree newlen;
2228
2229 #ifdef HOHO
2230           tempvar = ffecom_make_tempvar (char_type_node,
2231                                          ffebld_size (expr), -1);
2232 #else
2233           tempvar = ffebld_nonter_hook (expr);
2234           assert (tempvar);
2235 #endif
2236           tempvar = ffecom_1 (ADDR_EXPR,
2237                               build_pointer_type (TREE_TYPE (tempvar)),
2238                               tempvar);
2239
2240           newlen = build_int_2 (ffebld_size (expr), 0);
2241           TREE_TYPE (newlen) = ffecom_f2c_ftnlen_type_node;
2242
2243           args = build_tree_list (NULL_TREE, tempvar);
2244           TREE_CHAIN (args) = build_tree_list (NULL_TREE, item);
2245           TREE_CHAIN (TREE_CHAIN (args)) = build_tree_list (NULL_TREE, newlen);
2246           TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (args)))
2247             = build_tree_list (NULL_TREE, *length);
2248
2249           item = ffecom_call_gfrt (FFECOM_gfrtCOPY, args, NULL_TREE);
2250           TREE_SIDE_EFFECTS (item) = 1;
2251           item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), fold (item),
2252                            tempvar);
2253           *length = newlen;
2254         }
2255       else
2256         {                       /* Just truncate the length. */
2257           *length = build_int_2 (ffebld_size (expr), 0);
2258           TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2259         }
2260       break;
2261
2262     default:
2263       assert ("bad op for single char arg expr" == NULL);
2264       item = NULL_TREE;
2265       break;
2266     }
2267
2268   *xitem = item;
2269 }
2270
2271 /* Check the size of the type to be sure it doesn't overflow the
2272    "portable" capacities of the compiler back end.  `dummy' types
2273    can generally overflow the normal sizes as long as the computations
2274    themselves don't overflow.  A particular target of the back end
2275    must still enforce its size requirements, though, and the back
2276    end takes care of this in stor-layout.c.  */
2277
2278 static tree
2279 ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy)
2280 {
2281   if (TREE_CODE (type) == ERROR_MARK)
2282     return type;
2283
2284   if (TYPE_SIZE (type) == NULL_TREE)
2285     return type;
2286
2287   if (TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST)
2288     return type;
2289
2290   /* An array is too large if size is negative or the type_size overflows
2291      or its "upper half" is larger than 3 (which would make the signed
2292      byte size and offset computations overflow).  */
2293
2294   if ((tree_int_cst_sgn (TYPE_SIZE (type)) < 0)
2295       || (!dummy && (TREE_INT_CST_HIGH (TYPE_SIZE (type)) > 3
2296                      || TREE_OVERFLOW (TYPE_SIZE (type)))))
2297     {
2298       ffebad_start (FFEBAD_ARRAY_LARGE);
2299       ffebad_string (ffesymbol_text (s));
2300       ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s));
2301       ffebad_finish ();
2302
2303       return error_mark_node;
2304     }
2305
2306   return type;
2307 }
2308
2309 /* Builds a length argument (PARM_DECL).  Also wraps type in an array type
2310    where the dimension info is (1:size) where <size> is ffesymbol_size(s) if
2311    known, length_arg if not known (FFETARGET_charactersizeNONE).  */
2312
2313 static tree
2314 ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s)
2315 {
2316   ffetargetCharacterSize sz = ffesymbol_size (s);
2317   tree highval;
2318   tree tlen;
2319   tree type = *xtype;
2320
2321   if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
2322     tlen = NULL_TREE;           /* A statement function, no length passed. */
2323   else
2324     {
2325       if (ffesymbol_where (s) == FFEINFO_whereDUMMY)
2326         tlen = ffecom_get_invented_identifier ("__g77_length_%s",
2327                                                ffesymbol_text (s));
2328       else
2329         tlen = ffecom_get_invented_identifier ("__g77_%s", "length");
2330       tlen = build_decl (PARM_DECL, tlen, ffecom_f2c_ftnlen_type_node);
2331       DECL_ARTIFICIAL (tlen) = 1;
2332     }
2333
2334   if (sz == FFETARGET_charactersizeNONE)
2335     {
2336       assert (tlen != NULL_TREE);
2337       highval = variable_size (tlen);
2338     }
2339   else
2340     {
2341       highval = build_int_2 (sz, 0);
2342       TREE_TYPE (highval) = ffecom_f2c_ftnlen_type_node;
2343     }
2344
2345   type = build_array_type (type,
2346                            build_range_type (ffecom_f2c_ftnlen_type_node,
2347                                              ffecom_f2c_ftnlen_one_node,
2348                                              highval));
2349
2350   *xtype = type;
2351   return tlen;
2352 }
2353
2354 /* ffecom_concat_list_gather_ -- Gather list of concatenated string exprs
2355
2356    ffecomConcatList_ catlist;
2357    ffebld expr;  // expr of CHARACTER basictype.
2358    ffetargetCharacterSize max;  // max chars to gather or _...NONE if no max
2359    catlist = ffecom_concat_list_gather_(catlist,expr,max);
2360
2361    Scans expr for character subexpressions, updates and returns catlist
2362    accordingly.  */
2363
2364 static ffecomConcatList_
2365 ffecom_concat_list_gather_ (ffecomConcatList_ catlist, ffebld expr,
2366                             ffetargetCharacterSize max)
2367 {
2368   ffetargetCharacterSize sz;
2369
2370  recurse:
2371
2372   if (expr == NULL)
2373     return catlist;
2374
2375   if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen >= max))
2376     return catlist;             /* Don't append any more items. */
2377
2378   switch (ffebld_op (expr))
2379     {
2380     case FFEBLD_opCONTER:
2381     case FFEBLD_opSYMTER:
2382     case FFEBLD_opARRAYREF:
2383     case FFEBLD_opFUNCREF:
2384     case FFEBLD_opSUBSTR:
2385     case FFEBLD_opCONVERT:      /* Callers should strip this off beforehand
2386                                    if they don't need to preserve it. */
2387       if (catlist.count == catlist.max)
2388         {                       /* Make a (larger) list. */
2389           ffebld *newx;
2390           int newmax;
2391
2392           newmax = (catlist.max == 0) ? 8 : catlist.max * 2;
2393           newx = malloc_new_ks (malloc_pool_image (), "catlist",
2394                                 newmax * sizeof (newx[0]));
2395           if (catlist.max != 0)
2396             {
2397               memcpy (newx, catlist.exprs, catlist.max * sizeof (newx[0]));
2398               malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2399                               catlist.max * sizeof (newx[0]));
2400             }
2401           catlist.max = newmax;
2402           catlist.exprs = newx;
2403         }
2404       if ((sz = ffebld_size_known (expr)) != FFETARGET_charactersizeNONE)
2405         catlist.minlen += sz;
2406       else
2407         ++catlist.minlen;       /* Not true for F90; can be 0 length. */
2408       if ((sz = ffebld_size_max (expr)) == FFETARGET_charactersizeNONE)
2409         catlist.maxlen = sz;
2410       else
2411         catlist.maxlen += sz;
2412       if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen > max))
2413         {                       /* This item overlaps (or is beyond) the end
2414                                    of the destination. */
2415           switch (ffebld_op (expr))
2416             {
2417             case FFEBLD_opCONTER:
2418             case FFEBLD_opSYMTER:
2419             case FFEBLD_opARRAYREF:
2420             case FFEBLD_opFUNCREF:
2421             case FFEBLD_opSUBSTR:
2422               /* ~~Do useful truncations here. */
2423               break;
2424
2425             default:
2426               assert ("op changed or inconsistent switches!" == NULL);
2427               break;
2428             }
2429         }
2430       catlist.exprs[catlist.count++] = expr;
2431       return catlist;
2432
2433     case FFEBLD_opPAREN:
2434       expr = ffebld_left (expr);
2435       goto recurse;             /* :::::::::::::::::::: */
2436
2437     case FFEBLD_opCONCATENATE:
2438       catlist = ffecom_concat_list_gather_ (catlist, ffebld_left (expr), max);
2439       expr = ffebld_right (expr);
2440       goto recurse;             /* :::::::::::::::::::: */
2441
2442 #if 0                           /* Breaks passing small actual arg to larger
2443                                    dummy arg of sfunc */
2444     case FFEBLD_opCONVERT:
2445       expr = ffebld_left (expr);
2446       {
2447         ffetargetCharacterSize cmax;
2448
2449         cmax = catlist.len + ffebld_size_known (expr);
2450
2451         if ((max == FFETARGET_charactersizeNONE) || (max > cmax))
2452           max = cmax;
2453       }
2454       goto recurse;             /* :::::::::::::::::::: */
2455 #endif
2456
2457     case FFEBLD_opANY:
2458       return catlist;
2459
2460     default:
2461       assert ("bad op in _gather_" == NULL);
2462       return catlist;
2463     }
2464 }
2465
2466 /* ffecom_concat_list_kill_ -- Kill list of concatenated string exprs
2467
2468    ffecomConcatList_ catlist;
2469    ffecom_concat_list_kill_(catlist);
2470
2471    Anything allocated within the list info is deallocated.  */
2472
2473 static void
2474 ffecom_concat_list_kill_ (ffecomConcatList_ catlist)
2475 {
2476   if (catlist.max != 0)
2477     malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2478                     catlist.max * sizeof (catlist.exprs[0]));
2479 }
2480
2481 /* Make list of concatenated string exprs.
2482
2483    Returns a flattened list of concatenated subexpressions given a
2484    tree of such expressions.  */
2485
2486 static ffecomConcatList_
2487 ffecom_concat_list_new_ (ffebld expr, ffetargetCharacterSize max)
2488 {
2489   ffecomConcatList_ catlist;
2490
2491   catlist.maxlen = catlist.minlen = catlist.max = catlist.count = 0;
2492   return ffecom_concat_list_gather_ (catlist, expr, max);
2493 }
2494
2495 /* Provide some kind of useful info on member of aggregate area,
2496    since current g77/gcc technology does not provide debug info
2497    on these members.  */
2498
2499 static void
2500 ffecom_debug_kludge_ (tree aggr, const char *aggr_type, ffesymbol member,
2501                       tree member_type UNUSED, ffetargetOffset offset)
2502 {
2503   tree value;
2504   tree decl;
2505   int len;
2506   char *buff;
2507   char space[120];
2508 #if 0
2509   tree type_id;
2510
2511   for (type_id = member_type;
2512        TREE_CODE (type_id) != IDENTIFIER_NODE;
2513        )
2514     {
2515       switch (TREE_CODE (type_id))
2516         {
2517         case INTEGER_TYPE:
2518         case REAL_TYPE:
2519           type_id = TYPE_NAME (type_id);
2520           break;
2521
2522         case ARRAY_TYPE:
2523         case COMPLEX_TYPE:
2524           type_id = TREE_TYPE (type_id);
2525           break;
2526
2527         default:
2528           assert ("no IDENTIFIER_NODE for type!" == NULL);
2529           type_id = error_mark_node;
2530           break;
2531         }
2532     }
2533 #endif
2534
2535   if (ffecom_transform_only_dummies_
2536       || !ffe_is_debug_kludge ())
2537     return;     /* Can't do this yet, maybe later. */
2538
2539   len = 60
2540     + strlen (aggr_type)
2541     + IDENTIFIER_LENGTH (DECL_NAME (aggr));
2542 #if 0
2543     + IDENTIFIER_LENGTH (type_id);
2544 #endif
2545
2546   if (((size_t) len) >= ARRAY_SIZE (space))
2547     buff = malloc_new_ks (malloc_pool_image (), "debug_kludge", len + 1);
2548   else
2549     buff = &space[0];
2550
2551   sprintf (&buff[0], "At (%s) `%s' plus %ld bytes",
2552            aggr_type,
2553            IDENTIFIER_POINTER (DECL_NAME (aggr)),
2554            (long int) offset);
2555
2556   value = build_string (len, buff);
2557   TREE_TYPE (value)
2558     = build_type_variant (build_array_type (char_type_node,
2559                                             build_range_type
2560                                             (integer_type_node,
2561                                              integer_one_node,
2562                                              build_int_2 (strlen (buff), 0))),
2563                           1, 0);
2564   decl = build_decl (VAR_DECL,
2565                      ffecom_get_identifier_ (ffesymbol_text (member)),
2566                      TREE_TYPE (value));
2567   TREE_CONSTANT (decl) = 1;
2568   TREE_STATIC (decl) = 1;
2569   DECL_INITIAL (decl) = error_mark_node;
2570   DECL_IN_SYSTEM_HEADER (decl) = 1;     /* Don't let -Wunused complain. */
2571   decl = start_decl (decl, FALSE);
2572   finish_decl (decl, value, FALSE);
2573
2574   if (buff != &space[0])
2575     malloc_kill_ks (malloc_pool_image (), buff, len + 1);
2576 }
2577
2578 /* ffecom_do_entry_ -- Do compilation of a particular entrypoint
2579
2580    ffesymbol fn;  // the SUBROUTINE, FUNCTION, or ENTRY symbol itself
2581    int i;  // entry# for this entrypoint (used by master fn)
2582    ffecom_do_entrypoint_(s,i);
2583
2584    Makes a public entry point that calls our private master fn (already
2585    compiled).  */
2586
2587 static void
2588 ffecom_do_entry_ (ffesymbol fn, int entrynum)
2589 {
2590   ffebld item;
2591   tree type;                    /* Type of function. */
2592   tree multi_retval;            /* Var holding return value (union). */
2593   tree result;                  /* Var holding result. */
2594   ffeinfoBasictype bt;
2595   ffeinfoKindtype kt;
2596   ffeglobal g;
2597   ffeglobalType gt;
2598   bool charfunc;                /* All entry points return same type
2599                                    CHARACTER. */
2600   bool cmplxfunc;               /* Use f2c way of returning COMPLEX. */
2601   bool multi;                   /* Master fn has multiple return types. */
2602   bool altreturning = FALSE;    /* This entry point has alternate returns. */
2603   int old_lineno = lineno;
2604   const char *old_input_filename = input_filename;
2605
2606   input_filename = ffesymbol_where_filename (fn);
2607   lineno = ffesymbol_where_filelinenum (fn);
2608
2609   ffecom_doing_entry_ = TRUE;   /* Don't bother with array dimensions. */
2610
2611   switch (ffecom_primary_entry_kind_)
2612     {
2613     case FFEINFO_kindFUNCTION:
2614
2615       /* Determine actual return type for function. */
2616
2617       gt = FFEGLOBAL_typeFUNC;
2618       bt = ffesymbol_basictype (fn);
2619       kt = ffesymbol_kindtype (fn);
2620       if (bt == FFEINFO_basictypeNONE)
2621         {
2622           ffeimplic_establish_symbol (fn);
2623           if (ffesymbol_funcresult (fn) != NULL)
2624             ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
2625           bt = ffesymbol_basictype (fn);
2626           kt = ffesymbol_kindtype (fn);
2627         }
2628
2629       if (bt == FFEINFO_basictypeCHARACTER)
2630         charfunc = TRUE, cmplxfunc = FALSE;
2631       else if ((bt == FFEINFO_basictypeCOMPLEX)
2632                && ffesymbol_is_f2c (fn))
2633         charfunc = FALSE, cmplxfunc = TRUE;
2634       else
2635         charfunc = cmplxfunc = FALSE;
2636
2637       if (charfunc)
2638         type = ffecom_tree_fun_type_void;
2639       else if (ffesymbol_is_f2c (fn))
2640         type = ffecom_tree_fun_type[bt][kt];
2641       else
2642         type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
2643
2644       if ((type == NULL_TREE)
2645           || (TREE_TYPE (type) == NULL_TREE))
2646         type = ffecom_tree_fun_type_void;       /* _sym_exec_transition. */
2647
2648       multi = (ffecom_master_bt_ == FFEINFO_basictypeNONE);
2649       break;
2650
2651     case FFEINFO_kindSUBROUTINE:
2652       gt = FFEGLOBAL_typeSUBR;
2653       bt = FFEINFO_basictypeNONE;
2654       kt = FFEINFO_kindtypeNONE;
2655       if (ffecom_is_altreturning_)
2656         {                       /* Am _I_ altreturning? */
2657           for (item = ffesymbol_dummyargs (fn);
2658                item != NULL;
2659                item = ffebld_trail (item))
2660             {
2661               if (ffebld_op (ffebld_head (item)) == FFEBLD_opSTAR)
2662                 {
2663                   altreturning = TRUE;
2664                   break;
2665                 }
2666             }
2667           if (altreturning)
2668             type = ffecom_tree_subr_type;
2669           else
2670             type = ffecom_tree_fun_type_void;
2671         }
2672       else
2673         type = ffecom_tree_fun_type_void;
2674       charfunc = FALSE;
2675       cmplxfunc = FALSE;
2676       multi = FALSE;
2677       break;
2678
2679     default:
2680       assert ("say what??" == NULL);
2681       /* Fall through. */
2682     case FFEINFO_kindANY:
2683       gt = FFEGLOBAL_typeANY;
2684       bt = FFEINFO_basictypeNONE;
2685       kt = FFEINFO_kindtypeNONE;
2686       type = error_mark_node;
2687       charfunc = FALSE;
2688       cmplxfunc = FALSE;
2689       multi = FALSE;
2690       break;
2691     }
2692
2693   /* build_decl uses the current lineno and input_filename to set the decl
2694      source info.  So, I've putzed with ffestd and ffeste code to update that
2695      source info to point to the appropriate statement just before calling
2696      ffecom_do_entrypoint (which calls this fn).  */
2697
2698   start_function (ffecom_get_external_identifier_ (fn),
2699                   type,
2700                   0,            /* nested/inline */
2701                   1);           /* TREE_PUBLIC */
2702
2703   if (((g = ffesymbol_global (fn)) != NULL)
2704       && ((ffeglobal_type (g) == gt)
2705           || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
2706     {
2707       ffeglobal_set_hook (g, current_function_decl);
2708     }
2709
2710   /* Reset args in master arg list so they get retransitioned. */
2711
2712   for (item = ffecom_master_arglist_;
2713        item != NULL;
2714        item = ffebld_trail (item))
2715     {
2716       ffebld arg;
2717       ffesymbol s;
2718
2719       arg = ffebld_head (item);
2720       if (ffebld_op (arg) != FFEBLD_opSYMTER)
2721         continue;               /* Alternate return or some such thing. */
2722       s = ffebld_symter (arg);
2723       ffesymbol_hook (s).decl_tree = NULL_TREE;
2724       ffesymbol_hook (s).length_tree = NULL_TREE;
2725     }
2726
2727   /* Build dummy arg list for this entry point. */
2728
2729   if (charfunc || cmplxfunc)
2730     {                           /* Prepend arg for where result goes. */
2731       tree type;
2732       tree length;
2733
2734       if (charfunc)
2735         type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
2736       else
2737         type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
2738
2739       result = ffecom_get_invented_identifier ("__g77_%s", "result");
2740
2741       /* Make length arg _and_ enhance type info for CHAR arg itself.  */
2742
2743       if (charfunc)
2744         length = ffecom_char_enhance_arg_ (&type, fn);
2745       else
2746         length = NULL_TREE;     /* Not ref'd if !charfunc. */
2747
2748       type = build_pointer_type (type);
2749       result = build_decl (PARM_DECL, result, type);
2750
2751       push_parm_decl (result);
2752       ffecom_func_result_ = result;
2753
2754       if (charfunc)
2755         {
2756           push_parm_decl (length);
2757           ffecom_func_length_ = length;
2758         }
2759     }
2760   else
2761     result = DECL_RESULT (current_function_decl);
2762
2763   ffecom_push_dummy_decls_ (ffesymbol_dummyargs (fn), FALSE);
2764
2765   store_parm_decls (0);
2766
2767   ffecom_start_compstmt ();
2768   /* Disallow temp vars at this level.  */
2769   current_binding_level->prep_state = 2;
2770
2771   /* Make local var to hold return type for multi-type master fn. */
2772
2773   if (multi)
2774     {
2775       multi_retval = ffecom_get_invented_identifier ("__g77_%s",
2776                                                      "multi_retval");
2777       multi_retval = build_decl (VAR_DECL, multi_retval,
2778                                  ffecom_multi_type_node_);
2779       multi_retval = start_decl (multi_retval, FALSE);
2780       finish_decl (multi_retval, NULL_TREE, FALSE);
2781     }
2782   else
2783     multi_retval = NULL_TREE;   /* Not actually ref'd if !multi. */
2784
2785   /* Here we emit the actual code for the entry point. */
2786
2787   {
2788     ffebld list;
2789     ffebld arg;
2790     ffesymbol s;
2791     tree arglist = NULL_TREE;
2792     tree *plist = &arglist;
2793     tree prepend;
2794     tree call;
2795     tree actarg;
2796     tree master_fn;
2797
2798     /* Prepare actual arg list based on master arg list. */
2799
2800     for (list = ffecom_master_arglist_;
2801          list != NULL;
2802          list = ffebld_trail (list))
2803       {
2804         arg = ffebld_head (list);
2805         if (ffebld_op (arg) != FFEBLD_opSYMTER)
2806           continue;
2807         s = ffebld_symter (arg);
2808         if (ffesymbol_hook (s).decl_tree == NULL_TREE
2809             || ffesymbol_hook (s).decl_tree == error_mark_node)
2810           actarg = null_pointer_node;   /* We don't have this arg. */
2811         else
2812           actarg = ffesymbol_hook (s).decl_tree;
2813         *plist = build_tree_list (NULL_TREE, actarg);
2814         plist = &TREE_CHAIN (*plist);
2815       }
2816
2817     /* This code appends the length arguments for character
2818        variables/arrays.  */
2819
2820     for (list = ffecom_master_arglist_;
2821          list != NULL;
2822          list = ffebld_trail (list))
2823       {
2824         arg = ffebld_head (list);
2825         if (ffebld_op (arg) != FFEBLD_opSYMTER)
2826           continue;
2827         s = ffebld_symter (arg);
2828         if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
2829           continue;             /* Only looking for CHARACTER arguments. */
2830         if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
2831           continue;             /* Only looking for variables and arrays. */
2832         if (ffesymbol_hook (s).length_tree == NULL_TREE
2833             || ffesymbol_hook (s).length_tree == error_mark_node)
2834           actarg = ffecom_f2c_ftnlen_zero_node; /* We don't have this arg. */
2835         else
2836           actarg = ffesymbol_hook (s).length_tree;
2837         *plist = build_tree_list (NULL_TREE, actarg);
2838         plist = &TREE_CHAIN (*plist);
2839       }
2840
2841     /* Prepend character-value return info to actual arg list. */
2842
2843     if (charfunc)
2844       {
2845         prepend = build_tree_list (NULL_TREE, ffecom_func_result_);
2846         TREE_CHAIN (prepend)
2847           = build_tree_list (NULL_TREE, ffecom_func_length_);
2848         TREE_CHAIN (TREE_CHAIN (prepend)) = arglist;
2849         arglist = prepend;
2850       }
2851
2852     /* Prepend multi-type return value to actual arg list. */
2853
2854     if (multi)
2855       {
2856         prepend
2857           = build_tree_list (NULL_TREE,
2858                              ffecom_1 (ADDR_EXPR,
2859                               build_pointer_type (TREE_TYPE (multi_retval)),
2860                                        multi_retval));
2861         TREE_CHAIN (prepend) = arglist;
2862         arglist = prepend;
2863       }
2864
2865     /* Prepend my entry-point number to the actual arg list. */
2866
2867     prepend = build_tree_list (NULL_TREE, build_int_2 (entrynum, 0));
2868     TREE_CHAIN (prepend) = arglist;
2869     arglist = prepend;
2870
2871     /* Build the call to the master function. */
2872
2873     master_fn = ffecom_1_fn (ffecom_previous_function_decl_);
2874     call = ffecom_3s (CALL_EXPR,
2875                       TREE_TYPE (TREE_TYPE (TREE_TYPE (master_fn))),
2876                       master_fn, arglist, NULL_TREE);
2877
2878     /* Decide whether the master function is a function or subroutine, and
2879        handle the return value for my entry point. */
2880
2881     if (charfunc || ((ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
2882                      && !altreturning))
2883       {
2884         expand_expr_stmt (call);
2885         expand_null_return ();
2886       }
2887     else if (multi && cmplxfunc)
2888       {
2889         expand_expr_stmt (call);
2890         result
2891           = ffecom_1 (INDIRECT_REF,
2892                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
2893                       result);
2894         result = ffecom_modify (NULL_TREE, result,
2895                                 ffecom_2 (COMPONENT_REF, TREE_TYPE (result),
2896                                           multi_retval,
2897                                           ffecom_multi_fields_[bt][kt]));
2898         expand_expr_stmt (result);
2899         expand_null_return ();
2900       }
2901     else if (multi)
2902       {
2903         expand_expr_stmt (call);
2904         result
2905           = ffecom_modify (NULL_TREE, result,
2906                            convert (TREE_TYPE (result),
2907                                     ffecom_2 (COMPONENT_REF,
2908                                               ffecom_tree_type[bt][kt],
2909                                               multi_retval,
2910                                               ffecom_multi_fields_[bt][kt])));
2911         expand_return (result);
2912       }
2913     else if (cmplxfunc)
2914       {
2915         result
2916           = ffecom_1 (INDIRECT_REF,
2917                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
2918                       result);
2919         result = ffecom_modify (NULL_TREE, result, call);
2920         expand_expr_stmt (result);
2921         expand_null_return ();
2922       }
2923     else
2924       {
2925         result = ffecom_modify (NULL_TREE,
2926                                 result,
2927                                 convert (TREE_TYPE (result),
2928                                          call));
2929         expand_return (result);
2930       }
2931   }
2932
2933   ffecom_end_compstmt ();
2934
2935   finish_function (0);
2936
2937   lineno = old_lineno;
2938   input_filename = old_input_filename;
2939
2940   ffecom_doing_entry_ = FALSE;
2941 }
2942
2943 /* Transform expr into gcc tree with possible destination
2944
2945    Recursive descent on expr while making corresponding tree nodes and
2946    attaching type info and such.  If destination supplied and compatible
2947    with temporary that would be made in certain cases, temporary isn't
2948    made, destination used instead, and dest_used flag set TRUE.  */
2949
2950 static tree
2951 ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
2952               bool *dest_used, bool assignp, bool widenp)
2953 {
2954   tree item;
2955   tree list;
2956   tree args;
2957   ffeinfoBasictype bt;
2958   ffeinfoKindtype kt;
2959   tree t;
2960   tree dt;                      /* decl_tree for an ffesymbol. */
2961   tree tree_type, tree_type_x;
2962   tree left, right;
2963   ffesymbol s;
2964   enum tree_code code;
2965
2966   assert (expr != NULL);
2967
2968   if (dest_used != NULL)
2969     *dest_used = FALSE;
2970
2971   bt = ffeinfo_basictype (ffebld_info (expr));
2972   kt = ffeinfo_kindtype (ffebld_info (expr));
2973   tree_type = ffecom_tree_type[bt][kt];
2974
2975   /* Widen integral arithmetic as desired while preserving signedness.  */
2976   tree_type_x = NULL_TREE;
2977   if (widenp && tree_type
2978       && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
2979       && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
2980     tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
2981
2982   switch (ffebld_op (expr))
2983     {
2984     case FFEBLD_opACCTER:
2985       {
2986         ffebitCount i;
2987         ffebit bits = ffebld_accter_bits (expr);
2988         ffetargetOffset source_offset = 0;
2989         ffetargetOffset dest_offset = ffebld_accter_pad (expr);
2990         tree purpose;
2991
2992         assert (dest_offset == 0
2993                 || (bt == FFEINFO_basictypeCHARACTER
2994                     && kt == FFEINFO_kindtypeCHARACTER1));
2995
2996         list = item = NULL;
2997         for (;;)
2998           {
2999             ffebldConstantUnion cu;
3000             ffebitCount length;
3001             bool value;
3002             ffebldConstantArray ca = ffebld_accter (expr);
3003
3004             ffebit_test (bits, source_offset, &value, &length);
3005             if (length == 0)
3006               break;
3007
3008             if (value)
3009               {
3010                 for (i = 0; i < length; ++i)
3011                   {
3012                     cu = ffebld_constantarray_get (ca, bt, kt,
3013                                                    source_offset + i);
3014
3015                     t = ffecom_constantunion (&cu, bt, kt, tree_type);
3016
3017                     if (i == 0
3018                         && dest_offset != 0)
3019                       purpose = build_int_2 (dest_offset, 0);
3020                     else
3021                       purpose = NULL_TREE;
3022
3023                     if (list == NULL_TREE)
3024                       list = item = build_tree_list (purpose, t);
3025                     else
3026                       {
3027                         TREE_CHAIN (item) = build_tree_list (purpose, t);
3028                         item = TREE_CHAIN (item);
3029                       }
3030                   }
3031               }
3032             source_offset += length;
3033             dest_offset += length;
3034           }
3035       }
3036
3037       item = build_int_2 ((ffebld_accter_size (expr)
3038                            + ffebld_accter_pad (expr)) - 1, 0);
3039       ffebit_kill (ffebld_accter_bits (expr));
3040       TREE_TYPE (item) = ffecom_integer_type_node;
3041       item
3042         = build_array_type
3043           (tree_type,
3044            build_range_type (ffecom_integer_type_node,
3045                              ffecom_integer_zero_node,
3046                              item));
3047       list = build (CONSTRUCTOR, item, NULL_TREE, list);
3048       TREE_CONSTANT (list) = 1;
3049       TREE_STATIC (list) = 1;
3050       return list;
3051
3052     case FFEBLD_opARRTER:
3053       {
3054         ffetargetOffset i;
3055
3056         list = NULL_TREE;
3057         if (ffebld_arrter_pad (expr) == 0)
3058           item = NULL_TREE;
3059         else
3060           {
3061             assert (bt == FFEINFO_basictypeCHARACTER
3062                     && kt == FFEINFO_kindtypeCHARACTER1);
3063
3064             /* Becomes PURPOSE first time through loop.  */
3065             item = build_int_2 (ffebld_arrter_pad (expr), 0);
3066           }
3067
3068         for (i = 0; i < ffebld_arrter_size (expr); ++i)
3069           {
3070             ffebldConstantUnion cu
3071             = ffebld_constantarray_get (ffebld_arrter (expr), bt, kt, i);
3072
3073             t = ffecom_constantunion (&cu, bt, kt, tree_type);
3074
3075             if (list == NULL_TREE)
3076               /* Assume item is PURPOSE first time through loop.  */
3077               list = item = build_tree_list (item, t);
3078             else
3079               {
3080                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
3081                 item = TREE_CHAIN (item);
3082               }
3083           }
3084       }
3085
3086       item = build_int_2 ((ffebld_arrter_size (expr)
3087                           + ffebld_arrter_pad (expr)) - 1, 0);
3088       TREE_TYPE (item) = ffecom_integer_type_node;
3089       item
3090         = build_array_type
3091           (tree_type,
3092            build_range_type (ffecom_integer_type_node,
3093                              ffecom_integer_zero_node,
3094                              item));
3095       list = build (CONSTRUCTOR, item, NULL_TREE, list);
3096       TREE_CONSTANT (list) = 1;
3097       TREE_STATIC (list) = 1;
3098       return list;
3099
3100     case FFEBLD_opCONTER:
3101       assert (ffebld_conter_pad (expr) == 0);
3102       item
3103         = ffecom_constantunion (&ffebld_constant_union (ffebld_conter (expr)),
3104                                 bt, kt, tree_type);
3105       return item;
3106
3107     case FFEBLD_opSYMTER:
3108       if ((ffebld_symter_generic (expr) != FFEINTRIN_genNONE)
3109           || (ffebld_symter_specific (expr) != FFEINTRIN_specNONE))
3110         return ffecom_ptr_to_expr (expr);       /* Same as %REF(intrinsic). */
3111       s = ffebld_symter (expr);
3112       t = ffesymbol_hook (s).decl_tree;
3113
3114       if (assignp)
3115         {                       /* ASSIGN'ed-label expr. */
3116           if (ffe_is_ugly_assign ())
3117             {
3118               /* User explicitly wants ASSIGN'ed variables to be at the same
3119                  memory address as the variables when used in non-ASSIGN
3120                  contexts.  That can make old, arcane, non-standard code
3121                  work, but don't try to do it when a pointer wouldn't fit
3122                  in the normal variable (take other approach, and warn,
3123                  instead).  */
3124
3125               if (t == NULL_TREE)
3126                 {
3127                   s = ffecom_sym_transform_ (s);
3128                   t = ffesymbol_hook (s).decl_tree;
3129                   assert (t != NULL_TREE);
3130                 }
3131
3132               if (t == error_mark_node)
3133                 return t;
3134
3135               if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t)))
3136                   >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
3137                 {
3138                   if (ffesymbol_hook (s).addr)
3139                     t = ffecom_1 (INDIRECT_REF,
3140                                   TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3141                   return t;
3142                 }
3143
3144               if (ffesymbol_hook (s).assign_tree == NULL_TREE)
3145                 {
3146                   /* xgettext:no-c-format */
3147                   ffebad_start_msg ("ASSIGN'ed label cannot fit into `%A' at %0 -- using wider sibling",
3148                                     FFEBAD_severityWARNING);
3149                   ffebad_string (ffesymbol_text (s));
3150                   ffebad_here (0, ffesymbol_where_line (s),
3151                                ffesymbol_where_column (s));
3152                   ffebad_finish ();
3153                 }
3154             }
3155
3156           /* Don't use the normal variable's tree for ASSIGN, though mark
3157              it as in the system header (housekeeping).  Use an explicit,
3158              specially created sibling that is known to be wide enough
3159              to hold pointers to labels.  */
3160
3161           if (t != NULL_TREE
3162               && TREE_CODE (t) == VAR_DECL)
3163             DECL_IN_SYSTEM_HEADER (t) = 1;      /* Don't let -Wunused complain. */
3164
3165           t = ffesymbol_hook (s).assign_tree;
3166           if (t == NULL_TREE)
3167             {
3168               s = ffecom_sym_transform_assign_ (s);
3169               t = ffesymbol_hook (s).assign_tree;
3170               assert (t != NULL_TREE);
3171             }
3172         }
3173       else
3174         {
3175           if (t == NULL_TREE)
3176             {
3177               s = ffecom_sym_transform_ (s);
3178               t = ffesymbol_hook (s).decl_tree;
3179               assert (t != NULL_TREE);
3180             }
3181           if (ffesymbol_hook (s).addr)
3182             t = ffecom_1 (INDIRECT_REF,
3183                           TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3184         }
3185       return t;
3186
3187     case FFEBLD_opARRAYREF:
3188       return ffecom_arrayref_ (NULL_TREE, expr, 0);
3189
3190     case FFEBLD_opUPLUS:
3191       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3192       return ffecom_1 (NOP_EXPR, tree_type, left);
3193
3194     case FFEBLD_opPAREN:
3195       /* ~~~Make sure Fortran rules respected here */
3196       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3197       return ffecom_1 (NOP_EXPR, tree_type, left);
3198
3199     case FFEBLD_opUMINUS:
3200       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3201       if (tree_type_x)
3202         {
3203           tree_type = tree_type_x;
3204           left = convert (tree_type, left);
3205         }
3206       return ffecom_1 (NEGATE_EXPR, tree_type, left);
3207
3208     case FFEBLD_opADD:
3209       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3210       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3211       if (tree_type_x)
3212         {
3213           tree_type = tree_type_x;
3214           left = convert (tree_type, left);
3215           right = convert (tree_type, right);
3216         }
3217       return ffecom_2 (PLUS_EXPR, tree_type, left, right);
3218
3219     case FFEBLD_opSUBTRACT:
3220       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3221       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3222       if (tree_type_x)
3223         {
3224           tree_type = tree_type_x;
3225           left = convert (tree_type, left);
3226           right = convert (tree_type, right);
3227         }
3228       return ffecom_2 (MINUS_EXPR, tree_type, left, right);
3229
3230     case FFEBLD_opMULTIPLY:
3231       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3232       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3233       if (tree_type_x)
3234         {
3235           tree_type = tree_type_x;
3236           left = convert (tree_type, left);
3237           right = convert (tree_type, right);
3238         }
3239       return ffecom_2 (MULT_EXPR, tree_type, left, right);
3240
3241     case FFEBLD_opDIVIDE:
3242       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3243       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3244       if (tree_type_x)
3245         {
3246           tree_type = tree_type_x;
3247           left = convert (tree_type, left);
3248           right = convert (tree_type, right);
3249         }
3250       return ffecom_tree_divide_ (tree_type, left, right,
3251                                   dest_tree, dest, dest_used,
3252                                   ffebld_nonter_hook (expr));
3253
3254     case FFEBLD_opPOWER:
3255       {
3256         ffebld left = ffebld_left (expr);
3257         ffebld right = ffebld_right (expr);
3258         ffecomGfrt code;
3259         ffeinfoKindtype rtkt;
3260         ffeinfoKindtype ltkt;
3261         bool ref = TRUE;
3262
3263         switch (ffeinfo_basictype (ffebld_info (right)))
3264           {
3265
3266           case FFEINFO_basictypeINTEGER:
3267             if (1 || optimize)
3268               {
3269                 item = ffecom_expr_power_integer_ (expr);
3270                 if (item != NULL_TREE)
3271                   return item;
3272               }
3273
3274             rtkt = FFEINFO_kindtypeINTEGER1;
3275             switch (ffeinfo_basictype (ffebld_info (left)))
3276               {
3277               case FFEINFO_basictypeINTEGER:
3278                 if ((ffeinfo_kindtype (ffebld_info (left))
3279                     == FFEINFO_kindtypeINTEGER4)
3280                     || (ffeinfo_kindtype (ffebld_info (right))
3281                         == FFEINFO_kindtypeINTEGER4))
3282                   {
3283                     code = FFECOM_gfrtPOW_QQ;
3284                     ltkt = FFEINFO_kindtypeINTEGER4;
3285                     rtkt = FFEINFO_kindtypeINTEGER4;
3286                   }
3287                 else
3288                   {
3289                     code = FFECOM_gfrtPOW_II;
3290                     ltkt = FFEINFO_kindtypeINTEGER1;
3291                   }
3292                 break;
3293
3294               case FFEINFO_basictypeREAL:
3295                 if (ffeinfo_kindtype (ffebld_info (left))
3296                     == FFEINFO_kindtypeREAL1)
3297                   {
3298                     code = FFECOM_gfrtPOW_RI;
3299                     ltkt = FFEINFO_kindtypeREAL1;
3300                   }
3301                 else
3302                   {
3303                     code = FFECOM_gfrtPOW_DI;
3304                     ltkt = FFEINFO_kindtypeREAL2;
3305                   }
3306                 break;
3307
3308               case FFEINFO_basictypeCOMPLEX:
3309                 if (ffeinfo_kindtype (ffebld_info (left))
3310                     == FFEINFO_kindtypeREAL1)
3311                   {
3312                     code = FFECOM_gfrtPOW_CI;   /* Overlapping result okay. */
3313                     ltkt = FFEINFO_kindtypeREAL1;
3314                   }
3315                 else
3316                   {
3317                     code = FFECOM_gfrtPOW_ZI;   /* Overlapping result okay. */
3318                     ltkt = FFEINFO_kindtypeREAL2;
3319                   }
3320                 break;
3321
3322               default:
3323                 assert ("bad pow_*i" == NULL);
3324                 code = FFECOM_gfrtPOW_CI;       /* Overlapping result okay. */
3325                 ltkt = FFEINFO_kindtypeREAL1;
3326                 break;
3327               }
3328             if (ffeinfo_kindtype (ffebld_info (left)) != ltkt)
3329               left = ffeexpr_convert (left, NULL, NULL,
3330                                       ffeinfo_basictype (ffebld_info (left)),
3331                                       ltkt, 0,
3332                                       FFETARGET_charactersizeNONE,
3333                                       FFEEXPR_contextLET);
3334             if (ffeinfo_kindtype (ffebld_info (right)) != rtkt)
3335               right = ffeexpr_convert (right, NULL, NULL,
3336                                        FFEINFO_basictypeINTEGER,
3337                                        rtkt, 0,
3338                                        FFETARGET_charactersizeNONE,
3339                                        FFEEXPR_contextLET);
3340             break;
3341
3342           case FFEINFO_basictypeREAL:
3343             if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3344               left = ffeexpr_convert (left, NULL, NULL, FFEINFO_basictypeREAL,
3345                                       FFEINFO_kindtypeREALDOUBLE, 0,
3346                                       FFETARGET_charactersizeNONE,
3347                                       FFEEXPR_contextLET);
3348             if (ffeinfo_kindtype (ffebld_info (right))
3349                 == FFEINFO_kindtypeREAL1)
3350               right = ffeexpr_convert (right, NULL, NULL,
3351                                        FFEINFO_basictypeREAL,
3352                                        FFEINFO_kindtypeREALDOUBLE, 0,
3353                                        FFETARGET_charactersizeNONE,
3354                                        FFEEXPR_contextLET);
3355             /* We used to call FFECOM_gfrtPOW_DD here,
3356                which passes arguments by reference.  */
3357             code = FFECOM_gfrtL_POW;
3358             /* Pass arguments by value. */
3359             ref  = FALSE;
3360             break;
3361
3362           case FFEINFO_basictypeCOMPLEX:
3363             if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3364               left = ffeexpr_convert (left, NULL, NULL,
3365                                       FFEINFO_basictypeCOMPLEX,
3366                                       FFEINFO_kindtypeREALDOUBLE, 0,
3367                                       FFETARGET_charactersizeNONE,
3368                                       FFEEXPR_contextLET);
3369             if (ffeinfo_kindtype (ffebld_info (right))
3370                 == FFEINFO_kindtypeREAL1)
3371               right = ffeexpr_convert (right, NULL, NULL,
3372                                        FFEINFO_basictypeCOMPLEX,
3373                                        FFEINFO_kindtypeREALDOUBLE, 0,
3374                                        FFETARGET_charactersizeNONE,
3375                                        FFEEXPR_contextLET);
3376             code = FFECOM_gfrtPOW_ZZ;   /* Overlapping result okay. */
3377             ref = TRUE;                 /* Pass arguments by reference. */
3378             break;
3379
3380           default:
3381             assert ("bad pow_x*" == NULL);
3382             code = FFECOM_gfrtPOW_II;
3383             break;
3384           }
3385         return ffecom_call_binop_ (ffecom_gfrt_tree_ (code),
3386                                    ffecom_gfrt_kindtype (code),
3387                                    (ffe_is_f2c_library ()
3388                                     && ffecom_gfrt_complex_[code]),
3389                                    tree_type, left, right,
3390                                    dest_tree, dest, dest_used,
3391                                    NULL_TREE, FALSE, ref,
3392                                    ffebld_nonter_hook (expr));
3393       }
3394
3395     case FFEBLD_opNOT:
3396       switch (bt)
3397         {
3398         case FFEINFO_basictypeLOGICAL:
3399           item = ffecom_truth_value_invert (ffecom_expr (ffebld_left (expr)));
3400           return convert (tree_type, item);
3401
3402         case FFEINFO_basictypeINTEGER:
3403           return ffecom_1 (BIT_NOT_EXPR, tree_type,
3404                            ffecom_expr (ffebld_left (expr)));
3405
3406         default:
3407           assert ("NOT bad basictype" == NULL);
3408           /* Fall through. */
3409         case FFEINFO_basictypeANY:
3410           return error_mark_node;
3411         }
3412       break;
3413
3414     case FFEBLD_opFUNCREF:
3415       assert (ffeinfo_basictype (ffebld_info (expr))
3416               != FFEINFO_basictypeCHARACTER);
3417       /* Fall through.   */
3418     case FFEBLD_opSUBRREF:
3419       if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
3420           == FFEINFO_whereINTRINSIC)
3421         {                       /* Invocation of an intrinsic. */
3422           item = ffecom_expr_intrinsic_ (expr, dest_tree, dest,
3423                                          dest_used);
3424           return item;
3425         }
3426       s = ffebld_symter (ffebld_left (expr));
3427       dt = ffesymbol_hook (s).decl_tree;
3428       if (dt == NULL_TREE)
3429         {
3430           s = ffecom_sym_transform_ (s);
3431           dt = ffesymbol_hook (s).decl_tree;
3432         }
3433       if (dt == error_mark_node)
3434         return dt;
3435
3436       if (ffesymbol_hook (s).addr)
3437         item = dt;
3438       else
3439         item = ffecom_1_fn (dt);
3440
3441       if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
3442         args = ffecom_list_expr (ffebld_right (expr));
3443       else
3444         args = ffecom_list_ptr_to_expr (ffebld_right (expr));
3445
3446       if (args == error_mark_node)
3447         return error_mark_node;
3448
3449       item = ffecom_call_ (item, kt,
3450                            ffesymbol_is_f2c (s)
3451                            && (bt == FFEINFO_basictypeCOMPLEX)
3452                            && (ffesymbol_where (s)
3453                                != FFEINFO_whereCONSTANT),
3454                            tree_type,
3455                            args,
3456                            dest_tree, dest, dest_used,
3457                            error_mark_node, FALSE,
3458                            ffebld_nonter_hook (expr));
3459       TREE_SIDE_EFFECTS (item) = 1;
3460       return item;
3461
3462     case FFEBLD_opAND:
3463       switch (bt)
3464         {
3465         case FFEINFO_basictypeLOGICAL:
3466           item
3467             = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3468                        ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3469                      ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3470           return convert (tree_type, item);
3471
3472         case FFEINFO_basictypeINTEGER:
3473           return ffecom_2 (BIT_AND_EXPR, tree_type,
3474                            ffecom_expr (ffebld_left (expr)),
3475                            ffecom_expr (ffebld_right (expr)));
3476
3477         default:
3478           assert ("AND bad basictype" == NULL);
3479           /* Fall through. */
3480         case FFEINFO_basictypeANY:
3481           return error_mark_node;
3482         }
3483       break;
3484
3485     case FFEBLD_opOR:
3486       switch (bt)
3487         {
3488         case FFEINFO_basictypeLOGICAL:
3489           item
3490             = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
3491                        ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3492                      ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3493           return convert (tree_type, item);
3494
3495         case FFEINFO_basictypeINTEGER:
3496           return ffecom_2 (BIT_IOR_EXPR, tree_type,
3497                            ffecom_expr (ffebld_left (expr)),
3498                            ffecom_expr (ffebld_right (expr)));
3499
3500         default:
3501           assert ("OR bad basictype" == NULL);
3502           /* Fall through. */
3503         case FFEINFO_basictypeANY:
3504           return error_mark_node;
3505         }
3506       break;
3507
3508     case FFEBLD_opXOR:
3509     case FFEBLD_opNEQV:
3510       switch (bt)
3511         {
3512         case FFEINFO_basictypeLOGICAL:
3513           item
3514             = ffecom_2 (NE_EXPR, integer_type_node,
3515                         ffecom_expr (ffebld_left (expr)),
3516                         ffecom_expr (ffebld_right (expr)));
3517           return convert (tree_type, ffecom_truth_value (item));
3518
3519         case FFEINFO_basictypeINTEGER:
3520           return ffecom_2 (BIT_XOR_EXPR, tree_type,
3521                            ffecom_expr (ffebld_left (expr)),
3522                            ffecom_expr (ffebld_right (expr)));
3523
3524         default:
3525           assert ("XOR/NEQV bad basictype" == NULL);
3526           /* Fall through. */
3527         case FFEINFO_basictypeANY:
3528           return error_mark_node;
3529         }
3530       break;
3531
3532     case FFEBLD_opEQV:
3533       switch (bt)
3534         {
3535         case FFEINFO_basictypeLOGICAL:
3536           item
3537             = ffecom_2 (EQ_EXPR, integer_type_node,
3538                         ffecom_expr (ffebld_left (expr)),
3539                         ffecom_expr (ffebld_right (expr)));
3540           return convert (tree_type, ffecom_truth_value (item));
3541
3542         case FFEINFO_basictypeINTEGER:
3543           return
3544             ffecom_1 (BIT_NOT_EXPR, tree_type,
3545                       ffecom_2 (BIT_XOR_EXPR, tree_type,
3546                                 ffecom_expr (ffebld_left (expr)),
3547                                 ffecom_expr (ffebld_right (expr))));
3548
3549         default:
3550           assert ("EQV bad basictype" == NULL);
3551           /* Fall through. */
3552         case FFEINFO_basictypeANY:
3553           return error_mark_node;
3554         }
3555       break;
3556
3557     case FFEBLD_opCONVERT:
3558       if (ffebld_op (ffebld_left (expr)) == FFEBLD_opANY)
3559         return error_mark_node;
3560
3561       switch (bt)
3562         {
3563         case FFEINFO_basictypeLOGICAL:
3564         case FFEINFO_basictypeINTEGER:
3565         case FFEINFO_basictypeREAL:
3566           return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3567
3568         case FFEINFO_basictypeCOMPLEX:
3569           switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3570             {
3571             case FFEINFO_basictypeINTEGER:
3572             case FFEINFO_basictypeLOGICAL:
3573             case FFEINFO_basictypeREAL:
3574               item = ffecom_expr (ffebld_left (expr));
3575               if (item == error_mark_node)
3576                 return error_mark_node;
3577               /* convert() takes care of converting to the subtype first,
3578                  at least in gcc-2.7.2. */
3579               item = convert (tree_type, item);
3580               return item;
3581
3582             case FFEINFO_basictypeCOMPLEX:
3583               return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3584
3585             default:
3586               assert ("CONVERT COMPLEX bad basictype" == NULL);
3587               /* Fall through. */
3588             case FFEINFO_basictypeANY:
3589               return error_mark_node;
3590             }
3591           break;
3592
3593         default:
3594           assert ("CONVERT bad basictype" == NULL);
3595           /* Fall through. */
3596         case FFEINFO_basictypeANY:
3597           return error_mark_node;
3598         }
3599       break;
3600
3601     case FFEBLD_opLT:
3602       code = LT_EXPR;
3603       goto relational;          /* :::::::::::::::::::: */
3604
3605     case FFEBLD_opLE:
3606       code = LE_EXPR;
3607       goto relational;          /* :::::::::::::::::::: */
3608
3609     case FFEBLD_opEQ:
3610       code = EQ_EXPR;
3611       goto relational;          /* :::::::::::::::::::: */
3612
3613     case FFEBLD_opNE:
3614       code = NE_EXPR;
3615       goto relational;          /* :::::::::::::::::::: */
3616
3617     case FFEBLD_opGT:
3618       code = GT_EXPR;
3619       goto relational;          /* :::::::::::::::::::: */
3620
3621     case FFEBLD_opGE:
3622       code = GE_EXPR;
3623
3624     relational:         /* :::::::::::::::::::: */
3625       switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3626         {
3627         case FFEINFO_basictypeLOGICAL:
3628         case FFEINFO_basictypeINTEGER:
3629         case FFEINFO_basictypeREAL:
3630           item = ffecom_2 (code, integer_type_node,
3631                            ffecom_expr (ffebld_left (expr)),
3632                            ffecom_expr (ffebld_right (expr)));
3633           return convert (tree_type, item);
3634
3635         case FFEINFO_basictypeCOMPLEX:
3636           assert (code == EQ_EXPR || code == NE_EXPR);
3637           {
3638             tree real_type;
3639             tree arg1 = ffecom_expr (ffebld_left (expr));
3640             tree arg2 = ffecom_expr (ffebld_right (expr));
3641
3642             if (arg1 == error_mark_node || arg2 == error_mark_node)
3643               return error_mark_node;
3644
3645             arg1 = ffecom_save_tree (arg1);
3646             arg2 = ffecom_save_tree (arg2);
3647
3648             if (TREE_CODE (TREE_TYPE (arg1)) == COMPLEX_TYPE)
3649               {
3650                 real_type = TREE_TYPE (TREE_TYPE (arg1));
3651                 assert (real_type == TREE_TYPE (TREE_TYPE (arg2)));
3652               }
3653             else
3654               {
3655                 real_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg1)));
3656                 assert (real_type == TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg2))));
3657               }
3658
3659             item
3660               = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3661                           ffecom_2 (EQ_EXPR, integer_type_node,
3662                                   ffecom_1 (REALPART_EXPR, real_type, arg1),
3663                                  ffecom_1 (REALPART_EXPR, real_type, arg2)),
3664                           ffecom_2 (EQ_EXPR, integer_type_node,
3665                                   ffecom_1 (IMAGPART_EXPR, real_type, arg1),
3666                                     ffecom_1 (IMAGPART_EXPR, real_type,
3667                                               arg2)));
3668             if (code == EQ_EXPR)
3669               item = ffecom_truth_value (item);
3670             else
3671               item = ffecom_truth_value_invert (item);
3672             return convert (tree_type, item);
3673           }
3674
3675         case FFEINFO_basictypeCHARACTER:
3676           {
3677             ffebld left = ffebld_left (expr);
3678             ffebld right = ffebld_right (expr);
3679             tree left_tree;
3680             tree right_tree;
3681             tree left_length;
3682             tree right_length;
3683
3684             /* f2c run-time functions do the implicit blank-padding for us,
3685                so we don't usually have to implement blank-padding ourselves.
3686                (The exception is when we pass an argument to a separately
3687                compiled statement function -- if we know the arg is not the
3688                same length as the dummy, we must truncate or extend it.  If
3689                we "inline" statement functions, that necessity goes away as
3690                well.)
3691
3692                Strip off the CONVERT operators that blank-pad.  (Truncation by
3693                CONVERT shouldn't happen here, but it can happen in
3694                assignments.) */
3695
3696             while (ffebld_op (left) == FFEBLD_opCONVERT)
3697               left = ffebld_left (left);
3698             while (ffebld_op (right) == FFEBLD_opCONVERT)
3699               right = ffebld_left (right);
3700
3701             left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
3702             right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
3703
3704             if (left_tree == error_mark_node || left_length == error_mark_node
3705                 || right_tree == error_mark_node
3706                 || right_length == error_mark_node)
3707               return error_mark_node;
3708
3709             if ((ffebld_size_known (left) == 1)
3710                 && (ffebld_size_known (right) == 1))
3711               {
3712                 left_tree
3713                   = ffecom_1 (INDIRECT_REF,
3714                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3715                               left_tree);
3716                 right_tree
3717                   = ffecom_1 (INDIRECT_REF,
3718                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3719                               right_tree);
3720
3721                 item
3722                   = ffecom_2 (code, integer_type_node,
3723                               ffecom_2 (ARRAY_REF,
3724                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3725                                         left_tree,
3726                                         integer_one_node),
3727                               ffecom_2 (ARRAY_REF,
3728                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3729                                         right_tree,
3730                                         integer_one_node));
3731               }
3732             else
3733               {
3734                 item = build_tree_list (NULL_TREE, left_tree);
3735                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, right_tree);
3736                 TREE_CHAIN (TREE_CHAIN (item)) = build_tree_list (NULL_TREE,
3737                                                                left_length);
3738                 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
3739                   = build_tree_list (NULL_TREE, right_length);
3740                 item = ffecom_call_gfrt (FFECOM_gfrtCMP, item, NULL_TREE);
3741                 item = ffecom_2 (code, integer_type_node,
3742                                  item,
3743                                  convert (TREE_TYPE (item),
3744                                           integer_zero_node));
3745               }
3746             item = convert (tree_type, item);
3747           }
3748
3749           return item;
3750
3751         default:
3752           assert ("relational bad basictype" == NULL);
3753           /* Fall through. */
3754         case FFEINFO_basictypeANY:
3755           return error_mark_node;
3756         }
3757       break;
3758
3759     case FFEBLD_opPERCENT_LOC:
3760       item = ffecom_arg_ptr_to_expr (ffebld_left (expr), &list);
3761       return convert (tree_type, item);
3762
3763     case FFEBLD_opPERCENT_VAL:
3764       item = ffecom_arg_expr (ffebld_left (expr), &list);
3765       return convert (tree_type, item);
3766
3767     case FFEBLD_opITEM:
3768     case FFEBLD_opSTAR:
3769     case FFEBLD_opBOUNDS:
3770     case FFEBLD_opREPEAT:
3771     case FFEBLD_opLABTER:
3772     case FFEBLD_opLABTOK:
3773     case FFEBLD_opIMPDO:
3774     case FFEBLD_opCONCATENATE:
3775     case FFEBLD_opSUBSTR:
3776     default:
3777       assert ("bad op" == NULL);
3778       /* Fall through. */
3779     case FFEBLD_opANY:
3780       return error_mark_node;
3781     }
3782
3783 #if 1
3784   assert ("didn't think anything got here anymore!!" == NULL);
3785 #else
3786   switch (ffebld_arity (expr))
3787     {
3788     case 2:
3789       TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3790       TREE_OPERAND (item, 1) = ffecom_expr (ffebld_right (expr));
3791       if (TREE_OPERAND (item, 0) == error_mark_node
3792           || TREE_OPERAND (item, 1) == error_mark_node)
3793         return error_mark_node;
3794       break;
3795
3796     case 1:
3797       TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3798       if (TREE_OPERAND (item, 0) == error_mark_node)
3799         return error_mark_node;
3800       break;
3801
3802     default:
3803       break;
3804     }
3805
3806   return fold (item);
3807 #endif
3808 }
3809
3810 /* Returns the tree that does the intrinsic invocation.
3811
3812    Note: this function applies only to intrinsics returning
3813    CHARACTER*1 or non-CHARACTER results, and to intrinsic
3814    subroutines.  */
3815
3816 static tree
3817 ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
3818                         ffebld dest, bool *dest_used)
3819 {
3820   tree expr_tree;
3821   tree saved_expr1;             /* For those who need it. */
3822   tree saved_expr2;             /* For those who need it. */
3823   ffeinfoBasictype bt;
3824   ffeinfoKindtype kt;
3825   tree tree_type;
3826   tree arg1_type;
3827   tree real_type;               /* REAL type corresponding to COMPLEX. */
3828   tree tempvar;
3829   ffebld list = ffebld_right (expr);    /* List of (some) args. */
3830   ffebld arg1;                  /* For handy reference. */
3831   ffebld arg2;
3832   ffebld arg3;
3833   ffeintrinImp codegen_imp;
3834   ffecomGfrt gfrt;
3835
3836   assert (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER);
3837
3838   if (dest_used != NULL)
3839     *dest_used = FALSE;
3840
3841   bt = ffeinfo_basictype (ffebld_info (expr));
3842   kt = ffeinfo_kindtype (ffebld_info (expr));
3843   tree_type = ffecom_tree_type[bt][kt];
3844
3845   if (list != NULL)
3846     {
3847       arg1 = ffebld_head (list);
3848       if (arg1 != NULL && ffebld_op (arg1) == FFEBLD_opANY)
3849         return error_mark_node;
3850       if ((list = ffebld_trail (list)) != NULL)
3851         {
3852           arg2 = ffebld_head (list);
3853           if (arg2 != NULL && ffebld_op (arg2) == FFEBLD_opANY)
3854             return error_mark_node;
3855           if ((list = ffebld_trail (list)) != NULL)
3856             {
3857               arg3 = ffebld_head (list);
3858               if (arg3 != NULL && ffebld_op (arg3) == FFEBLD_opANY)
3859                 return error_mark_node;
3860             }
3861           else
3862             arg3 = NULL;
3863         }
3864       else
3865         arg2 = arg3 = NULL;
3866     }
3867   else
3868     arg1 = arg2 = arg3 = NULL;
3869
3870   /* <list> ends up at the opITEM of the 3rd arg, or NULL if there are < 3
3871      args.  This is used by the MAX/MIN expansions. */
3872
3873   if (arg1 != NULL)
3874     arg1_type = ffecom_tree_type
3875       [ffeinfo_basictype (ffebld_info (arg1))]
3876       [ffeinfo_kindtype (ffebld_info (arg1))];
3877   else
3878     arg1_type = NULL_TREE;      /* Really not needed, but might catch bugs
3879                                    here. */
3880
3881   /* There are several ways for each of the cases in the following switch
3882      statements to exit (from simplest to use to most complicated):
3883
3884      break;  (when expr_tree == NULL)
3885
3886      A standard call is made to the specific intrinsic just as if it had been
3887      passed in as a dummy procedure and called as any old procedure.  This
3888      method can produce slower code but in some cases it's the easiest way for
3889      now.  However, if a (presumably faster) direct call is available,
3890      that is used, so this is the easiest way in many more cases now.
3891
3892      gfrt = FFECOM_gfrtWHATEVER;
3893      break;
3894
3895      gfrt contains the gfrt index of a library function to call, passing the
3896      argument(s) by value rather than by reference.  Used when a more
3897      careful choice of library function is needed than that provided
3898      by the vanilla `break;'.
3899
3900      return expr_tree;
3901
3902      The expr_tree has been completely set up and is ready to be returned
3903      as is.  No further actions are taken.  Use this when the tree is not
3904      in the simple form for one of the arity_n labels.   */
3905
3906   /* For info on how the switch statement cases were written, see the files
3907      enclosed in comments below the switch statement. */
3908
3909   codegen_imp = ffebld_symter_implementation (ffebld_left (expr));
3910   gfrt = ffeintrin_gfrt_direct (codegen_imp);
3911   if (gfrt == FFECOM_gfrt)
3912     gfrt = ffeintrin_gfrt_indirect (codegen_imp);
3913
3914   switch (codegen_imp)
3915     {
3916     case FFEINTRIN_impABS:
3917     case FFEINTRIN_impCABS:
3918     case FFEINTRIN_impCDABS:
3919     case FFEINTRIN_impDABS:
3920     case FFEINTRIN_impIABS:
3921       if (ffeinfo_basictype (ffebld_info (arg1))
3922           == FFEINFO_basictypeCOMPLEX)
3923         {
3924           if (kt == FFEINFO_kindtypeREAL1)
3925             gfrt = FFECOM_gfrtCABS;
3926           else if (kt == FFEINFO_kindtypeREAL2)
3927             gfrt = FFECOM_gfrtCDABS;
3928           break;
3929         }
3930       return ffecom_1 (ABS_EXPR, tree_type,
3931                        convert (tree_type, ffecom_expr (arg1)));
3932
3933     case FFEINTRIN_impACOS:
3934     case FFEINTRIN_impDACOS:
3935       break;
3936
3937     case FFEINTRIN_impAIMAG:
3938     case FFEINTRIN_impDIMAG:
3939     case FFEINTRIN_impIMAGPART:
3940       if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
3941         arg1_type = TREE_TYPE (arg1_type);
3942       else
3943         arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
3944
3945       return
3946         convert (tree_type,
3947                  ffecom_1 (IMAGPART_EXPR, arg1_type,
3948                            ffecom_expr (arg1)));
3949
3950     case FFEINTRIN_impAINT:
3951     case FFEINTRIN_impDINT:
3952 #if 0
3953       /* ~~Someday implement FIX_TRUNC_EXPR yielding same type as arg.  */
3954       return ffecom_1 (FIX_TRUNC_EXPR, tree_type, ffecom_expr (arg1));
3955 #else /* in the meantime, must use floor to avoid range problems with ints */
3956       /* r__1 = r1 >= 0 ? floor(r1) : -floor(-r1); */
3957       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
3958       return
3959         convert (tree_type,
3960                  ffecom_3 (COND_EXPR, double_type_node,
3961                            ffecom_truth_value
3962                            (ffecom_2 (GE_EXPR, integer_type_node,
3963                                       saved_expr1,
3964                                       convert (arg1_type,
3965                                                ffecom_float_zero_))),
3966                            ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
3967                                              build_tree_list (NULL_TREE,
3968                                                   convert (double_type_node,
3969                                                            saved_expr1)),
3970                                              NULL_TREE),
3971                            ffecom_1 (NEGATE_EXPR, double_type_node,
3972                                      ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
3973                                                  build_tree_list (NULL_TREE,
3974                                                   convert (double_type_node,
3975                                                       ffecom_1 (NEGATE_EXPR,
3976                                                                 arg1_type,
3977                                                                saved_expr1))),
3978                                                        NULL_TREE)
3979                                      ))
3980                  );
3981 #endif
3982
3983     case FFEINTRIN_impANINT:
3984     case FFEINTRIN_impDNINT:
3985 #if 0                           /* This way of doing it won't handle real
3986                                    numbers of large magnitudes. */
3987       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
3988       expr_tree = convert (tree_type,
3989                            convert (integer_type_node,
3990                                     ffecom_3 (COND_EXPR, tree_type,
3991                                               ffecom_truth_value
3992                                               (ffecom_2 (GE_EXPR,
3993                                                          integer_type_node,
3994                                                          saved_expr1,
3995                                                        ffecom_float_zero_)),
3996                                               ffecom_2 (PLUS_EXPR,
3997                                                         tree_type,
3998                                                         saved_expr1,
3999                                                         ffecom_float_half_),
4000                                               ffecom_2 (MINUS_EXPR,
4001                                                         tree_type,
4002                                                         saved_expr1,
4003                                                      ffecom_float_half_))));
4004       return expr_tree;
4005 #else /* So we instead call floor. */
4006       /* r__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1) */
4007       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4008       return
4009         convert (tree_type,
4010                  ffecom_3 (COND_EXPR, double_type_node,
4011                            ffecom_truth_value
4012                            (ffecom_2 (GE_EXPR, integer_type_node,
4013                                       saved_expr1,
4014                                       convert (arg1_type,
4015                                                ffecom_float_zero_))),
4016                            ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4017                                              build_tree_list (NULL_TREE,
4018                                                   convert (double_type_node,
4019                                                            ffecom_2 (PLUS_EXPR,
4020                                                                      arg1_type,
4021                                                                      saved_expr1,
4022                                                                      convert (arg1_type,
4023                                                                               ffecom_float_half_)))),
4024                                              NULL_TREE),
4025                            ffecom_1 (NEGATE_EXPR, double_type_node,
4026                                      ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4027                                                        build_tree_list (NULL_TREE,
4028                                                                         convert (double_type_node,
4029                                                                                  ffecom_2 (MINUS_EXPR,
4030                                                                                            arg1_type,
4031                                                                                            convert (arg1_type,
4032                                                                                                     ffecom_float_half_),
4033                                                                                            saved_expr1))),
4034                                                        NULL_TREE))
4035                            )
4036                  );
4037 #endif
4038
4039     case FFEINTRIN_impASIN:
4040     case FFEINTRIN_impDASIN:
4041     case FFEINTRIN_impATAN:
4042     case FFEINTRIN_impDATAN:
4043     case FFEINTRIN_impATAN2:
4044     case FFEINTRIN_impDATAN2:
4045       break;
4046
4047     case FFEINTRIN_impCHAR:
4048     case FFEINTRIN_impACHAR:
4049 #ifdef HOHO
4050       tempvar = ffecom_make_tempvar (char_type_node, 1, -1);
4051 #else
4052       tempvar = ffebld_nonter_hook (expr);
4053       assert (tempvar);
4054 #endif
4055       {
4056         tree tmv = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (tempvar)));
4057
4058         expr_tree = ffecom_modify (tmv,
4059                                    ffecom_2 (ARRAY_REF, tmv, tempvar,
4060                                              integer_one_node),
4061                                    convert (tmv, ffecom_expr (arg1)));
4062       }
4063       expr_tree = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar),
4064                             expr_tree,
4065                             tempvar);
4066       expr_tree = ffecom_1 (ADDR_EXPR,
4067                             build_pointer_type (TREE_TYPE (expr_tree)),
4068                             expr_tree);
4069       return expr_tree;
4070
4071     case FFEINTRIN_impCMPLX:
4072     case FFEINTRIN_impDCMPLX:
4073       if (arg2 == NULL)
4074         return
4075           convert (tree_type, ffecom_expr (arg1));
4076
4077       real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4078       return
4079         ffecom_2 (COMPLEX_EXPR, tree_type,
4080                   convert (real_type, ffecom_expr (arg1)),
4081                   convert (real_type,
4082                            ffecom_expr (arg2)));
4083
4084     case FFEINTRIN_impCOMPLEX:
4085       return
4086         ffecom_2 (COMPLEX_EXPR, tree_type,
4087                   ffecom_expr (arg1),
4088                   ffecom_expr (arg2));
4089
4090     case FFEINTRIN_impCONJG:
4091     case FFEINTRIN_impDCONJG:
4092       {
4093         tree arg1_tree;
4094
4095         real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4096         arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4097         return
4098           ffecom_2 (COMPLEX_EXPR, tree_type,
4099                     ffecom_1 (REALPART_EXPR, real_type, arg1_tree),
4100                     ffecom_1 (NEGATE_EXPR, real_type,
4101                               ffecom_1 (IMAGPART_EXPR, real_type, arg1_tree)));
4102       }
4103
4104     case FFEINTRIN_impCOS:
4105     case FFEINTRIN_impCCOS:
4106     case FFEINTRIN_impCDCOS:
4107     case FFEINTRIN_impDCOS:
4108       if (bt == FFEINFO_basictypeCOMPLEX)
4109         {
4110           if (kt == FFEINFO_kindtypeREAL1)
4111             gfrt = FFECOM_gfrtCCOS;     /* Overlapping result okay. */
4112           else if (kt == FFEINFO_kindtypeREAL2)
4113             gfrt = FFECOM_gfrtCDCOS;    /* Overlapping result okay. */
4114         }
4115       break;
4116
4117     case FFEINTRIN_impCOSH:
4118     case FFEINTRIN_impDCOSH:
4119       break;
4120
4121     case FFEINTRIN_impDBLE:
4122     case FFEINTRIN_impDFLOAT:
4123     case FFEINTRIN_impDREAL:
4124     case FFEINTRIN_impFLOAT:
4125     case FFEINTRIN_impIDINT:
4126     case FFEINTRIN_impIFIX:
4127     case FFEINTRIN_impINT2:
4128     case FFEINTRIN_impINT8:
4129     case FFEINTRIN_impINT:
4130     case FFEINTRIN_impLONG:
4131     case FFEINTRIN_impREAL:
4132     case FFEINTRIN_impSHORT:
4133     case FFEINTRIN_impSNGL:
4134       return convert (tree_type, ffecom_expr (arg1));
4135
4136     case FFEINTRIN_impDIM:
4137     case FFEINTRIN_impDDIM:
4138     case FFEINTRIN_impIDIM:
4139       saved_expr1 = ffecom_save_tree (convert (tree_type,
4140                                                ffecom_expr (arg1)));
4141       saved_expr2 = ffecom_save_tree (convert (tree_type,
4142                                                ffecom_expr (arg2)));
4143       return
4144         ffecom_3 (COND_EXPR, tree_type,
4145                   ffecom_truth_value
4146                   (ffecom_2 (GT_EXPR, integer_type_node,
4147                              saved_expr1,
4148                              saved_expr2)),
4149                   ffecom_2 (MINUS_EXPR, tree_type,
4150                             saved_expr1,
4151                             saved_expr2),
4152                   convert (tree_type, ffecom_float_zero_));
4153
4154     case FFEINTRIN_impDPROD:
4155       return
4156         ffecom_2 (MULT_EXPR, tree_type,
4157                   convert (tree_type, ffecom_expr (arg1)),
4158                   convert (tree_type, ffecom_expr (arg2)));
4159
4160     case FFEINTRIN_impEXP:
4161     case FFEINTRIN_impCDEXP:
4162     case FFEINTRIN_impCEXP:
4163     case FFEINTRIN_impDEXP:
4164       if (bt == FFEINFO_basictypeCOMPLEX)
4165         {
4166           if (kt == FFEINFO_kindtypeREAL1)
4167             gfrt = FFECOM_gfrtCEXP;     /* Overlapping result okay. */
4168           else if (kt == FFEINFO_kindtypeREAL2)
4169             gfrt = FFECOM_gfrtCDEXP;    /* Overlapping result okay. */
4170         }
4171       break;
4172
4173     case FFEINTRIN_impICHAR:
4174     case FFEINTRIN_impIACHAR:
4175 #if 0                           /* The simple approach. */
4176       ffecom_char_args_ (&expr_tree, &saved_expr1 /* Ignored */ , arg1);
4177       expr_tree
4178         = ffecom_1 (INDIRECT_REF,
4179                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4180                     expr_tree);
4181       expr_tree
4182         = ffecom_2 (ARRAY_REF,
4183                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4184                     expr_tree,
4185                     integer_one_node);
4186       return convert (tree_type, expr_tree);
4187 #else /* The more interesting (and more optimal) approach. */
4188       expr_tree = ffecom_intrinsic_ichar_ (tree_type, arg1, &saved_expr1);
4189       expr_tree = ffecom_3 (COND_EXPR, tree_type,
4190                             saved_expr1,
4191                             expr_tree,
4192                             convert (tree_type, integer_zero_node));
4193       return expr_tree;
4194 #endif
4195
4196     case FFEINTRIN_impINDEX:
4197       break;
4198
4199     case FFEINTRIN_impLEN:
4200 #if 0
4201       break;                                    /* The simple approach. */
4202 #else
4203       return ffecom_intrinsic_len_ (arg1);      /* The more optimal approach. */
4204 #endif
4205
4206     case FFEINTRIN_impLGE:
4207     case FFEINTRIN_impLGT:
4208     case FFEINTRIN_impLLE:
4209     case FFEINTRIN_impLLT:
4210       break;
4211
4212     case FFEINTRIN_impLOG:
4213     case FFEINTRIN_impALOG:
4214     case FFEINTRIN_impCDLOG:
4215     case FFEINTRIN_impCLOG:
4216     case FFEINTRIN_impDLOG:
4217       if (bt == FFEINFO_basictypeCOMPLEX)
4218         {
4219           if (kt == FFEINFO_kindtypeREAL1)
4220             gfrt = FFECOM_gfrtCLOG;     /* Overlapping result okay. */
4221           else if (kt == FFEINFO_kindtypeREAL2)
4222             gfrt = FFECOM_gfrtCDLOG;    /* Overlapping result okay. */
4223         }
4224       break;
4225
4226     case FFEINTRIN_impLOG10:
4227     case FFEINTRIN_impALOG10:
4228     case FFEINTRIN_impDLOG10:
4229       if (gfrt != FFECOM_gfrt)
4230         break;  /* Already picked one, stick with it. */
4231
4232       if (kt == FFEINFO_kindtypeREAL1)
4233         /* We used to call FFECOM_gfrtALOG10 here.  */
4234         gfrt = FFECOM_gfrtL_LOG10;
4235       else if (kt == FFEINFO_kindtypeREAL2)
4236         /* We used to call FFECOM_gfrtDLOG10 here.  */
4237         gfrt = FFECOM_gfrtL_LOG10;
4238       break;
4239
4240     case FFEINTRIN_impMAX:
4241     case FFEINTRIN_impAMAX0:
4242     case FFEINTRIN_impAMAX1:
4243     case FFEINTRIN_impDMAX1:
4244     case FFEINTRIN_impMAX0:
4245     case FFEINTRIN_impMAX1:
4246       if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4247         arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4248       else
4249         arg1_type = tree_type;
4250       expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4251                             convert (arg1_type, ffecom_expr (arg1)),
4252                             convert (arg1_type, ffecom_expr (arg2)));
4253       for (; list != NULL; list = ffebld_trail (list))
4254         {
4255           if ((ffebld_head (list) == NULL)
4256               || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4257             continue;
4258           expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4259                                 expr_tree,
4260                                 convert (arg1_type,
4261                                          ffecom_expr (ffebld_head (list))));
4262         }
4263       return convert (tree_type, expr_tree);
4264
4265     case FFEINTRIN_impMIN:
4266     case FFEINTRIN_impAMIN0:
4267     case FFEINTRIN_impAMIN1:
4268     case FFEINTRIN_impDMIN1:
4269     case FFEINTRIN_impMIN0:
4270     case FFEINTRIN_impMIN1:
4271       if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4272         arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4273       else
4274         arg1_type = tree_type;
4275       expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4276                             convert (arg1_type, ffecom_expr (arg1)),
4277                             convert (arg1_type, ffecom_expr (arg2)));
4278       for (; list != NULL; list = ffebld_trail (list))
4279         {
4280           if ((ffebld_head (list) == NULL)
4281               || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4282             continue;
4283           expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4284                                 expr_tree,
4285                                 convert (arg1_type,
4286                                          ffecom_expr (ffebld_head (list))));
4287         }
4288       return convert (tree_type, expr_tree);
4289
4290     case FFEINTRIN_impMOD:
4291     case FFEINTRIN_impAMOD:
4292     case FFEINTRIN_impDMOD:
4293       if (bt != FFEINFO_basictypeREAL)
4294         return ffecom_2 (TRUNC_MOD_EXPR, tree_type,
4295                          convert (tree_type, ffecom_expr (arg1)),
4296                          convert (tree_type, ffecom_expr (arg2)));
4297
4298       if (kt == FFEINFO_kindtypeREAL1)
4299         /* We used to call FFECOM_gfrtAMOD here.  */
4300         gfrt = FFECOM_gfrtL_FMOD;
4301       else if (kt == FFEINFO_kindtypeREAL2)
4302         /* We used to call FFECOM_gfrtDMOD here.  */
4303         gfrt = FFECOM_gfrtL_FMOD;
4304       break;
4305
4306     case FFEINTRIN_impNINT:
4307     case FFEINTRIN_impIDNINT:
4308 #if 0
4309       /* ~~Ideally FIX_ROUND_EXPR would be implemented, but it ain't yet.  */
4310       return ffecom_1 (FIX_ROUND_EXPR, tree_type, ffecom_expr (arg1));
4311 #else
4312       /* i__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1); */
4313       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4314       return
4315         convert (ffecom_integer_type_node,
4316                  ffecom_3 (COND_EXPR, arg1_type,
4317                            ffecom_truth_value
4318                            (ffecom_2 (GE_EXPR, integer_type_node,
4319                                       saved_expr1,
4320                                       convert (arg1_type,
4321                                                ffecom_float_zero_))),
4322                            ffecom_2 (PLUS_EXPR, arg1_type,
4323                                      saved_expr1,
4324                                      convert (arg1_type,
4325                                               ffecom_float_half_)),
4326                            ffecom_2 (MINUS_EXPR, arg1_type,
4327                                      saved_expr1,
4328                                      convert (arg1_type,
4329                                               ffecom_float_half_))));
4330 #endif
4331
4332     case FFEINTRIN_impSIGN:
4333     case FFEINTRIN_impDSIGN:
4334     case FFEINTRIN_impISIGN:
4335       {
4336         tree arg2_tree = ffecom_expr (arg2);
4337
4338         saved_expr1
4339           = ffecom_save_tree
4340           (ffecom_1 (ABS_EXPR, tree_type,
4341                      convert (tree_type,
4342                               ffecom_expr (arg1))));
4343         expr_tree
4344           = ffecom_3 (COND_EXPR, tree_type,
4345                       ffecom_truth_value
4346                       (ffecom_2 (GE_EXPR, integer_type_node,
4347                                  arg2_tree,
4348                                  convert (TREE_TYPE (arg2_tree),
4349                                           integer_zero_node))),
4350                       saved_expr1,
4351                       ffecom_1 (NEGATE_EXPR, tree_type, saved_expr1));
4352         /* Make sure SAVE_EXPRs get referenced early enough. */
4353         expr_tree
4354           = ffecom_2 (COMPOUND_EXPR, tree_type,
4355                       convert (void_type_node, saved_expr1),
4356                       expr_tree);
4357       }
4358       return expr_tree;
4359
4360     case FFEINTRIN_impSIN:
4361     case FFEINTRIN_impCDSIN:
4362     case FFEINTRIN_impCSIN:
4363     case FFEINTRIN_impDSIN:
4364       if (bt == FFEINFO_basictypeCOMPLEX)
4365         {
4366           if (kt == FFEINFO_kindtypeREAL1)
4367             gfrt = FFECOM_gfrtCSIN;     /* Overlapping result okay. */
4368           else if (kt == FFEINFO_kindtypeREAL2)
4369             gfrt = FFECOM_gfrtCDSIN;    /* Overlapping result okay. */
4370         }
4371       break;
4372
4373     case FFEINTRIN_impSINH:
4374     case FFEINTRIN_impDSINH:
4375       break;
4376
4377     case FFEINTRIN_impSQRT:
4378     case FFEINTRIN_impCDSQRT:
4379     case FFEINTRIN_impCSQRT:
4380     case FFEINTRIN_impDSQRT:
4381       if (bt == FFEINFO_basictypeCOMPLEX)
4382         {
4383           if (kt == FFEINFO_kindtypeREAL1)
4384             gfrt = FFECOM_gfrtCSQRT;    /* Overlapping result okay. */
4385           else if (kt == FFEINFO_kindtypeREAL2)
4386             gfrt = FFECOM_gfrtCDSQRT;   /* Overlapping result okay. */
4387         }
4388       break;
4389
4390     case FFEINTRIN_impTAN:
4391     case FFEINTRIN_impDTAN:
4392     case FFEINTRIN_impTANH:
4393     case FFEINTRIN_impDTANH:
4394       break;
4395
4396     case FFEINTRIN_impREALPART:
4397       if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
4398         arg1_type = TREE_TYPE (arg1_type);
4399       else
4400         arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
4401
4402       return
4403         convert (tree_type,
4404                  ffecom_1 (REALPART_EXPR, arg1_type,
4405                            ffecom_expr (arg1)));
4406
4407     case FFEINTRIN_impIAND:
4408     case FFEINTRIN_impAND:
4409       return ffecom_2 (BIT_AND_EXPR, tree_type,
4410                        convert (tree_type,
4411                                 ffecom_expr (arg1)),
4412                        convert (tree_type,
4413                                 ffecom_expr (arg2)));
4414
4415     case FFEINTRIN_impIOR:
4416     case FFEINTRIN_impOR:
4417       return ffecom_2 (BIT_IOR_EXPR, tree_type,
4418                        convert (tree_type,
4419                                 ffecom_expr (arg1)),
4420                        convert (tree_type,
4421                                 ffecom_expr (arg2)));
4422
4423     case FFEINTRIN_impIEOR:
4424     case FFEINTRIN_impXOR:
4425       return ffecom_2 (BIT_XOR_EXPR, tree_type,
4426                        convert (tree_type,
4427                                 ffecom_expr (arg1)),
4428                        convert (tree_type,
4429                                 ffecom_expr (arg2)));
4430
4431     case FFEINTRIN_impLSHIFT:
4432       return ffecom_2 (LSHIFT_EXPR, tree_type,
4433                        ffecom_expr (arg1),
4434                        convert (integer_type_node,
4435                                 ffecom_expr (arg2)));
4436
4437     case FFEINTRIN_impRSHIFT:
4438       return ffecom_2 (RSHIFT_EXPR, tree_type,
4439                        ffecom_expr (arg1),
4440                        convert (integer_type_node,
4441                                 ffecom_expr (arg2)));
4442
4443     case FFEINTRIN_impNOT:
4444       return ffecom_1 (BIT_NOT_EXPR, tree_type, ffecom_expr (arg1));
4445
4446     case FFEINTRIN_impBIT_SIZE:
4447       return convert (tree_type, TYPE_SIZE (arg1_type));
4448
4449     case FFEINTRIN_impBTEST:
4450       {
4451         ffetargetLogical1 target_true;
4452         ffetargetLogical1 target_false;
4453         tree true_tree;
4454         tree false_tree;
4455
4456         ffetarget_logical1 (&target_true, TRUE);
4457         ffetarget_logical1 (&target_false, FALSE);
4458         if (target_true == 1)
4459           true_tree = convert (tree_type, integer_one_node);
4460         else
4461           true_tree = convert (tree_type, build_int_2 (target_true, 0));
4462         if (target_false == 0)
4463           false_tree = convert (tree_type, integer_zero_node);
4464         else
4465           false_tree = convert (tree_type, build_int_2 (target_false, 0));
4466
4467         return
4468           ffecom_3 (COND_EXPR, tree_type,
4469                     ffecom_truth_value
4470                     (ffecom_2 (EQ_EXPR, integer_type_node,
4471                                ffecom_2 (BIT_AND_EXPR, arg1_type,
4472                                          ffecom_expr (arg1),
4473                                          ffecom_2 (LSHIFT_EXPR, arg1_type,
4474                                                    convert (arg1_type,
4475                                                           integer_one_node),
4476                                                    convert (integer_type_node,
4477                                                             ffecom_expr (arg2)))),
4478                                convert (arg1_type,
4479                                         integer_zero_node))),
4480                     false_tree,
4481                     true_tree);
4482       }
4483
4484     case FFEINTRIN_impIBCLR:
4485       return
4486         ffecom_2 (BIT_AND_EXPR, tree_type,
4487                   ffecom_expr (arg1),
4488                   ffecom_1 (BIT_NOT_EXPR, tree_type,
4489                             ffecom_2 (LSHIFT_EXPR, tree_type,
4490                                       convert (tree_type,
4491                                                integer_one_node),
4492                                       convert (integer_type_node,
4493                                                ffecom_expr (arg2)))));
4494
4495     case FFEINTRIN_impIBITS:
4496       {
4497         tree arg3_tree = ffecom_save_tree (convert (integer_type_node,
4498                                                     ffecom_expr (arg3)));
4499         tree uns_type
4500         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4501
4502         expr_tree
4503           = ffecom_2 (BIT_AND_EXPR, tree_type,
4504                       ffecom_2 (RSHIFT_EXPR, tree_type,
4505                                 ffecom_expr (arg1),
4506                                 convert (integer_type_node,
4507                                          ffecom_expr (arg2))),
4508                       convert (tree_type,
4509                                ffecom_2 (RSHIFT_EXPR, uns_type,
4510                                          ffecom_1 (BIT_NOT_EXPR,
4511                                                    uns_type,
4512                                                    convert (uns_type,
4513                                                         integer_zero_node)),
4514                                          ffecom_2 (MINUS_EXPR,
4515                                                    integer_type_node,
4516                                                    TYPE_SIZE (uns_type),
4517                                                    arg3_tree))));
4518         /* Fix up, because the RSHIFT_EXPR above can't shift over TYPE_SIZE.  */
4519         expr_tree
4520           = ffecom_3 (COND_EXPR, tree_type,
4521                       ffecom_truth_value
4522                       (ffecom_2 (NE_EXPR, integer_type_node,
4523                                  arg3_tree,
4524                                  integer_zero_node)),
4525                       expr_tree,
4526                       convert (tree_type, integer_zero_node));
4527       }
4528       return expr_tree;
4529
4530     case FFEINTRIN_impIBSET:
4531       return
4532         ffecom_2 (BIT_IOR_EXPR, tree_type,
4533                   ffecom_expr (arg1),
4534                   ffecom_2 (LSHIFT_EXPR, tree_type,
4535                             convert (tree_type, integer_one_node),
4536                             convert (integer_type_node,
4537                                      ffecom_expr (arg2))));
4538
4539     case FFEINTRIN_impISHFT:
4540       {
4541         tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4542         tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4543                                                     ffecom_expr (arg2)));
4544         tree uns_type
4545         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4546
4547         expr_tree
4548           = ffecom_3 (COND_EXPR, tree_type,
4549                       ffecom_truth_value
4550                       (ffecom_2 (GE_EXPR, integer_type_node,
4551                                  arg2_tree,
4552                                  integer_zero_node)),
4553                       ffecom_2 (LSHIFT_EXPR, tree_type,
4554                                 arg1_tree,
4555                                 arg2_tree),
4556                       convert (tree_type,
4557                                ffecom_2 (RSHIFT_EXPR, uns_type,
4558                                          convert (uns_type, arg1_tree),
4559                                          ffecom_1 (NEGATE_EXPR,
4560                                                    integer_type_node,
4561                                                    arg2_tree))));
4562         /* Fix up, because {L|R}SHIFT_EXPR don't go over TYPE_SIZE bounds.  */
4563         expr_tree
4564           = ffecom_3 (COND_EXPR, tree_type,
4565                       ffecom_truth_value
4566                       (ffecom_2 (NE_EXPR, integer_type_node,
4567                                  ffecom_1 (ABS_EXPR,
4568                                            integer_type_node,
4569                                            arg2_tree),
4570                                  TYPE_SIZE (uns_type))),
4571                       expr_tree,
4572                       convert (tree_type, integer_zero_node));
4573         /* Make sure SAVE_EXPRs get referenced early enough. */
4574         expr_tree
4575           = ffecom_2 (COMPOUND_EXPR, tree_type,
4576                       convert (void_type_node, arg1_tree),
4577                       ffecom_2 (COMPOUND_EXPR, tree_type,
4578                                 convert (void_type_node, arg2_tree),
4579                                 expr_tree));
4580       }
4581       return expr_tree;
4582
4583     case FFEINTRIN_impISHFTC:
4584       {
4585         tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4586         tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4587                                                     ffecom_expr (arg2)));
4588         tree arg3_tree = (arg3 == NULL) ? TYPE_SIZE (tree_type)
4589         : ffecom_save_tree (convert (integer_type_node, ffecom_expr (arg3)));
4590         tree shift_neg;
4591         tree shift_pos;
4592         tree mask_arg1;
4593         tree masked_arg1;
4594         tree uns_type
4595         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4596
4597         mask_arg1
4598           = ffecom_2 (LSHIFT_EXPR, tree_type,
4599                       ffecom_1 (BIT_NOT_EXPR, tree_type,
4600                                 convert (tree_type, integer_zero_node)),
4601                       arg3_tree);
4602         /* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE.  */
4603         mask_arg1
4604           = ffecom_3 (COND_EXPR, tree_type,
4605                       ffecom_truth_value
4606                       (ffecom_2 (NE_EXPR, integer_type_node,
4607                                  arg3_tree,
4608                                  TYPE_SIZE (uns_type))),
4609                       mask_arg1,
4610                       convert (tree_type, integer_zero_node));
4611         mask_arg1 = ffecom_save_tree (mask_arg1);
4612         masked_arg1
4613           = ffecom_2 (BIT_AND_EXPR, tree_type,
4614                       arg1_tree,
4615                       ffecom_1 (BIT_NOT_EXPR, tree_type,
4616                                 mask_arg1));
4617         masked_arg1 = ffecom_save_tree (masked_arg1);
4618         shift_neg
4619           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4620                       convert (tree_type,
4621                                ffecom_2 (RSHIFT_EXPR, uns_type,
4622                                          convert (uns_type, masked_arg1),
4623                                          ffecom_1 (NEGATE_EXPR,
4624                                                    integer_type_node,
4625                                                    arg2_tree))),
4626                       ffecom_2 (LSHIFT_EXPR, tree_type,
4627                                 arg1_tree,
4628                                 ffecom_2 (PLUS_EXPR, integer_type_node,
4629                                           arg2_tree,
4630                                           arg3_tree)));
4631         shift_pos
4632           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4633                       ffecom_2 (LSHIFT_EXPR, tree_type,
4634                                 arg1_tree,
4635                                 arg2_tree),
4636                       convert (tree_type,
4637                                ffecom_2 (RSHIFT_EXPR, uns_type,
4638                                          convert (uns_type, masked_arg1),
4639                                          ffecom_2 (MINUS_EXPR,
4640                                                    integer_type_node,
4641                                                    arg3_tree,
4642                                                    arg2_tree))));
4643         expr_tree
4644           = ffecom_3 (COND_EXPR, tree_type,
4645                       ffecom_truth_value
4646                       (ffecom_2 (LT_EXPR, integer_type_node,
4647                                  arg2_tree,
4648                                  integer_zero_node)),
4649                       shift_neg,
4650                       shift_pos);
4651         expr_tree
4652           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4653                       ffecom_2 (BIT_AND_EXPR, tree_type,
4654                                 mask_arg1,
4655                                 arg1_tree),
4656                       ffecom_2 (BIT_AND_EXPR, tree_type,
4657                                 ffecom_1 (BIT_NOT_EXPR, tree_type,
4658                                           mask_arg1),
4659                                 expr_tree));
4660         expr_tree
4661           = ffecom_3 (COND_EXPR, tree_type,
4662                       ffecom_truth_value
4663                       (ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
4664                                  ffecom_2 (EQ_EXPR, integer_type_node,
4665                                            ffecom_1 (ABS_EXPR,
4666                                                      integer_type_node,
4667                                                      arg2_tree),
4668                                            arg3_tree),
4669                                  ffecom_2 (EQ_EXPR, integer_type_node,
4670                                            arg2_tree,
4671                                            integer_zero_node))),
4672                       arg1_tree,
4673                       expr_tree);
4674         /* Make sure SAVE_EXPRs get referenced early enough. */
4675         expr_tree
4676           = ffecom_2 (COMPOUND_EXPR, tree_type,
4677                       convert (void_type_node, arg1_tree),
4678                       ffecom_2 (COMPOUND_EXPR, tree_type,
4679                                 convert (void_type_node, arg2_tree),
4680                                 ffecom_2 (COMPOUND_EXPR, tree_type,
4681                                           convert (void_type_node,
4682                                                    mask_arg1),
4683                                           ffecom_2 (COMPOUND_EXPR, tree_type,
4684                                                     convert (void_type_node,
4685                                                              masked_arg1),
4686                                                     expr_tree))));
4687         expr_tree
4688           = ffecom_2 (COMPOUND_EXPR, tree_type,
4689                       convert (void_type_node,
4690                                arg3_tree),
4691                       expr_tree);
4692       }
4693       return expr_tree;
4694
4695     case FFEINTRIN_impLOC:
4696       {
4697         tree arg1_tree = ffecom_expr (arg1);
4698
4699         expr_tree
4700           = convert (tree_type,
4701                      ffecom_1 (ADDR_EXPR,
4702                                build_pointer_type (TREE_TYPE (arg1_tree)),
4703                                arg1_tree));
4704       }
4705       return expr_tree;
4706
4707     case FFEINTRIN_impMVBITS:
4708       {
4709         tree arg1_tree;
4710         tree arg2_tree;
4711         tree arg3_tree;
4712         ffebld arg4 = ffebld_head (ffebld_trail (list));
4713         tree arg4_tree;
4714         tree arg4_type;
4715         ffebld arg5 = ffebld_head (ffebld_trail (ffebld_trail (list)));
4716         tree arg5_tree;
4717         tree prep_arg1;
4718         tree prep_arg4;
4719         tree arg5_plus_arg3;
4720
4721         arg2_tree = convert (integer_type_node,
4722                              ffecom_expr (arg2));
4723         arg3_tree = ffecom_save_tree (convert (integer_type_node,
4724                                                ffecom_expr (arg3)));
4725         arg4_tree = ffecom_expr_rw (NULL_TREE, arg4);
4726         arg4_type = TREE_TYPE (arg4_tree);
4727
4728         arg1_tree = ffecom_save_tree (convert (arg4_type,
4729                                                ffecom_expr (arg1)));
4730
4731         arg5_tree = ffecom_save_tree (convert (integer_type_node,
4732                                                ffecom_expr (arg5)));
4733
4734         prep_arg1
4735           = ffecom_2 (LSHIFT_EXPR, arg4_type,
4736                       ffecom_2 (BIT_AND_EXPR, arg4_type,
4737                                 ffecom_2 (RSHIFT_EXPR, arg4_type,
4738                                           arg1_tree,
4739                                           arg2_tree),
4740                                 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4741                                           ffecom_2 (LSHIFT_EXPR, arg4_type,
4742                                                     ffecom_1 (BIT_NOT_EXPR,
4743                                                               arg4_type,
4744                                                               convert
4745                                                               (arg4_type,
4746                                                         integer_zero_node)),
4747                                                     arg3_tree))),
4748                       arg5_tree);
4749         arg5_plus_arg3
4750           = ffecom_save_tree (ffecom_2 (PLUS_EXPR, arg4_type,
4751                                         arg5_tree,
4752                                         arg3_tree));
4753         prep_arg4
4754           = ffecom_2 (LSHIFT_EXPR, arg4_type,
4755                       ffecom_1 (BIT_NOT_EXPR, arg4_type,
4756                                 convert (arg4_type,
4757                                          integer_zero_node)),
4758                       arg5_plus_arg3);
4759         /* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE.  */
4760         prep_arg4
4761           = ffecom_3 (COND_EXPR, arg4_type,
4762                       ffecom_truth_value
4763                       (ffecom_2 (NE_EXPR, integer_type_node,
4764                                  arg5_plus_arg3,
4765                                  convert (TREE_TYPE (arg5_plus_arg3),
4766                                           TYPE_SIZE (arg4_type)))),
4767                       prep_arg4,
4768                       convert (arg4_type, integer_zero_node));
4769         prep_arg4
4770           = ffecom_2 (BIT_AND_EXPR, arg4_type,
4771                       arg4_tree,
4772                       ffecom_2 (BIT_IOR_EXPR, arg4_type,
4773                                 prep_arg4,
4774                                 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4775                                           ffecom_2 (LSHIFT_EXPR, arg4_type,
4776                                                     ffecom_1 (BIT_NOT_EXPR,
4777                                                               arg4_type,
4778                                                               convert
4779                                                               (arg4_type,
4780                                                         integer_zero_node)),
4781                                                     arg5_tree))));
4782         prep_arg1
4783           = ffecom_2 (BIT_IOR_EXPR, arg4_type,
4784                       prep_arg1,
4785                       prep_arg4);
4786         /* Fix up (twice), because LSHIFT_EXPR above
4787            can't shift over TYPE_SIZE.  */
4788         prep_arg1
4789           = ffecom_3 (COND_EXPR, arg4_type,
4790                       ffecom_truth_value
4791                       (ffecom_2 (NE_EXPR, integer_type_node,
4792                                  arg3_tree,
4793                                  convert (TREE_TYPE (arg3_tree),
4794                                           integer_zero_node))),
4795                       prep_arg1,
4796                       arg4_tree);
4797         prep_arg1
4798           = ffecom_3 (COND_EXPR, arg4_type,
4799                       ffecom_truth_value
4800                       (ffecom_2 (NE_EXPR, integer_type_node,
4801                                  arg3_tree,
4802                                  convert (TREE_TYPE (arg3_tree),
4803                                           TYPE_SIZE (arg4_type)))),
4804                       prep_arg1,
4805                       arg1_tree);
4806         expr_tree
4807           = ffecom_2s (MODIFY_EXPR, void_type_node,
4808                        arg4_tree,
4809                        prep_arg1);
4810         /* Make sure SAVE_EXPRs get referenced early enough. */
4811         expr_tree
4812           = ffecom_2 (COMPOUND_EXPR, void_type_node,
4813                       arg1_tree,
4814                       ffecom_2 (COMPOUND_EXPR, void_type_node,
4815                                 arg3_tree,
4816                                 ffecom_2 (COMPOUND_EXPR, void_type_node,
4817                                           arg5_tree,
4818                                           ffecom_2 (COMPOUND_EXPR, void_type_node,
4819                                                     arg5_plus_arg3,
4820                                                     expr_tree))));
4821         expr_tree
4822           = ffecom_2 (COMPOUND_EXPR, void_type_node,
4823                       arg4_tree,
4824                       expr_tree);
4825
4826       }
4827       return expr_tree;
4828
4829     case FFEINTRIN_impDERF:
4830     case FFEINTRIN_impERF:
4831     case FFEINTRIN_impDERFC:
4832     case FFEINTRIN_impERFC:
4833       break;
4834
4835     case FFEINTRIN_impIARGC:
4836       /* extern int xargc; i__1 = xargc - 1; */
4837       expr_tree = ffecom_2 (MINUS_EXPR, TREE_TYPE (ffecom_tree_xargc_),
4838                             ffecom_tree_xargc_,
4839                             convert (TREE_TYPE (ffecom_tree_xargc_),
4840                                      integer_one_node));
4841       return expr_tree;
4842
4843     case FFEINTRIN_impSIGNAL_func:
4844     case FFEINTRIN_impSIGNAL_subr:
4845       {
4846         tree arg1_tree;
4847         tree arg2_tree;
4848         tree arg3_tree;
4849
4850         arg1_tree = convert (ffecom_f2c_integer_type_node,
4851                              ffecom_expr (arg1));
4852         arg1_tree = ffecom_1 (ADDR_EXPR,
4853                               build_pointer_type (TREE_TYPE (arg1_tree)),
4854                               arg1_tree);
4855
4856         /* Pass procedure as a pointer to it, anything else by value.  */
4857         if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
4858           arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
4859         else
4860           arg2_tree = ffecom_ptr_to_expr (arg2);
4861         arg2_tree = convert (TREE_TYPE (null_pointer_node),
4862                              arg2_tree);
4863
4864         if (arg3 != NULL)
4865           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
4866         else
4867           arg3_tree = NULL_TREE;
4868
4869         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4870         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4871         TREE_CHAIN (arg1_tree) = arg2_tree;
4872
4873         expr_tree
4874           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4875                           ffecom_gfrt_kindtype (gfrt),
4876                           FALSE,
4877                           ((codegen_imp == FFEINTRIN_impSIGNAL_subr) ?
4878                            NULL_TREE :
4879                            tree_type),
4880                           arg1_tree,
4881                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4882                           ffebld_nonter_hook (expr));
4883
4884         if (arg3_tree != NULL_TREE)
4885           expr_tree
4886             = ffecom_modify (NULL_TREE, arg3_tree,
4887                              convert (TREE_TYPE (arg3_tree),
4888                                       expr_tree));
4889       }
4890       return expr_tree;
4891
4892     case FFEINTRIN_impALARM:
4893       {
4894         tree arg1_tree;
4895         tree arg2_tree;
4896         tree arg3_tree;
4897
4898         arg1_tree = convert (ffecom_f2c_integer_type_node,
4899                              ffecom_expr (arg1));
4900         arg1_tree = ffecom_1 (ADDR_EXPR,
4901                               build_pointer_type (TREE_TYPE (arg1_tree)),
4902                               arg1_tree);
4903
4904         /* Pass procedure as a pointer to it, anything else by value.  */
4905         if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
4906           arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
4907         else
4908           arg2_tree = ffecom_ptr_to_expr (arg2);
4909         arg2_tree = convert (TREE_TYPE (null_pointer_node),
4910                              arg2_tree);
4911
4912         if (arg3 != NULL)
4913           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
4914         else
4915           arg3_tree = NULL_TREE;
4916
4917         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4918         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4919         TREE_CHAIN (arg1_tree) = arg2_tree;
4920
4921         expr_tree
4922           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4923                           ffecom_gfrt_kindtype (gfrt),
4924                           FALSE,
4925                           NULL_TREE,
4926                           arg1_tree,
4927                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4928                           ffebld_nonter_hook (expr));
4929
4930         if (arg3_tree != NULL_TREE)
4931           expr_tree
4932             = ffecom_modify (NULL_TREE, arg3_tree,
4933                              convert (TREE_TYPE (arg3_tree),
4934                                       expr_tree));
4935       }
4936       return expr_tree;
4937
4938     case FFEINTRIN_impCHDIR_subr:
4939     case FFEINTRIN_impFDATE_subr:
4940     case FFEINTRIN_impFGET_subr:
4941     case FFEINTRIN_impFPUT_subr:
4942     case FFEINTRIN_impGETCWD_subr:
4943     case FFEINTRIN_impHOSTNM_subr:
4944     case FFEINTRIN_impSYSTEM_subr:
4945     case FFEINTRIN_impUNLINK_subr:
4946       {
4947         tree arg1_len = integer_zero_node;
4948         tree arg1_tree;
4949         tree arg2_tree;
4950
4951         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
4952
4953         if (arg2 != NULL)
4954           arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
4955         else
4956           arg2_tree = NULL_TREE;
4957
4958         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4959         arg1_len = build_tree_list (NULL_TREE, arg1_len);
4960         TREE_CHAIN (arg1_tree) = arg1_len;
4961
4962         expr_tree
4963           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4964                           ffecom_gfrt_kindtype (gfrt),
4965                           FALSE,
4966                           NULL_TREE,
4967                           arg1_tree,
4968                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4969                           ffebld_nonter_hook (expr));
4970
4971         if (arg2_tree != NULL_TREE)
4972           expr_tree
4973             = ffecom_modify (NULL_TREE, arg2_tree,
4974                              convert (TREE_TYPE (arg2_tree),
4975                                       expr_tree));
4976       }
4977       return expr_tree;
4978
4979     case FFEINTRIN_impEXIT:
4980       if (arg1 != NULL)
4981         break;
4982
4983       expr_tree = build_tree_list (NULL_TREE,
4984                                    ffecom_1 (ADDR_EXPR,
4985                                              build_pointer_type
4986                                              (ffecom_integer_type_node),
4987                                              integer_zero_node));
4988
4989       return
4990         ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4991                       ffecom_gfrt_kindtype (gfrt),
4992                       FALSE,
4993                       void_type_node,
4994                       expr_tree,
4995                       NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4996                       ffebld_nonter_hook (expr));
4997
4998     case FFEINTRIN_impFLUSH:
4999       if (arg1 == NULL)
5000         gfrt = FFECOM_gfrtFLUSH;
5001       else
5002         gfrt = FFECOM_gfrtFLUSH1;
5003       break;
5004
5005     case FFEINTRIN_impCHMOD_subr:
5006     case FFEINTRIN_impLINK_subr:
5007     case FFEINTRIN_impRENAME_subr:
5008     case FFEINTRIN_impSYMLNK_subr:
5009       {
5010         tree arg1_len = integer_zero_node;
5011         tree arg1_tree;
5012         tree arg2_len = integer_zero_node;
5013         tree arg2_tree;
5014         tree arg3_tree;
5015
5016         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5017         arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
5018         if (arg3 != NULL)
5019           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5020         else
5021           arg3_tree = NULL_TREE;
5022
5023         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5024         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5025         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5026         arg2_len = build_tree_list (NULL_TREE, arg2_len);
5027         TREE_CHAIN (arg1_tree) = arg2_tree;
5028         TREE_CHAIN (arg2_tree) = arg1_len;
5029         TREE_CHAIN (arg1_len) = arg2_len;
5030         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5031                                   ffecom_gfrt_kindtype (gfrt),
5032                                   FALSE,
5033                                   NULL_TREE,
5034                                   arg1_tree,
5035                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5036                                   ffebld_nonter_hook (expr));
5037         if (arg3_tree != NULL_TREE)
5038           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5039                                      convert (TREE_TYPE (arg3_tree),
5040                                               expr_tree));
5041       }
5042       return expr_tree;
5043
5044     case FFEINTRIN_impLSTAT_subr:
5045     case FFEINTRIN_impSTAT_subr:
5046       {
5047         tree arg1_len = integer_zero_node;
5048         tree arg1_tree;
5049         tree arg2_tree;
5050         tree arg3_tree;
5051
5052         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5053
5054         arg2_tree = ffecom_ptr_to_expr (arg2);
5055
5056         if (arg3 != NULL)
5057           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5058         else
5059           arg3_tree = NULL_TREE;
5060
5061         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5062         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5063         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5064         TREE_CHAIN (arg1_tree) = arg2_tree;
5065         TREE_CHAIN (arg2_tree) = arg1_len;
5066         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5067                                   ffecom_gfrt_kindtype (gfrt),
5068                                   FALSE,
5069                                   NULL_TREE,
5070                                   arg1_tree,
5071                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5072                                   ffebld_nonter_hook (expr));
5073         if (arg3_tree != NULL_TREE)
5074           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5075                                      convert (TREE_TYPE (arg3_tree),
5076                                               expr_tree));
5077       }
5078       return expr_tree;
5079
5080     case FFEINTRIN_impFGETC_subr:
5081     case FFEINTRIN_impFPUTC_subr:
5082       {
5083         tree arg1_tree;
5084         tree arg2_tree;
5085         tree arg2_len = integer_zero_node;
5086         tree arg3_tree;
5087
5088         arg1_tree = convert (ffecom_f2c_integer_type_node,
5089                              ffecom_expr (arg1));
5090         arg1_tree = ffecom_1 (ADDR_EXPR,
5091                               build_pointer_type (TREE_TYPE (arg1_tree)),
5092                               arg1_tree);
5093
5094         arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
5095         if (arg3 != NULL)
5096           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5097         else
5098           arg3_tree = NULL_TREE;
5099
5100         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5101         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5102         arg2_len = build_tree_list (NULL_TREE, arg2_len);
5103         TREE_CHAIN (arg1_tree) = arg2_tree;
5104         TREE_CHAIN (arg2_tree) = arg2_len;
5105
5106         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5107                                   ffecom_gfrt_kindtype (gfrt),
5108                                   FALSE,
5109                                   NULL_TREE,
5110                                   arg1_tree,
5111                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5112                                   ffebld_nonter_hook (expr));
5113         if (arg3_tree != NULL_TREE)
5114           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5115                                      convert (TREE_TYPE (arg3_tree),
5116                                               expr_tree));
5117       }
5118       return expr_tree;
5119
5120     case FFEINTRIN_impFSTAT_subr:
5121       {
5122         tree arg1_tree;
5123         tree arg2_tree;
5124         tree arg3_tree;
5125
5126         arg1_tree = convert (ffecom_f2c_integer_type_node,
5127                              ffecom_expr (arg1));
5128         arg1_tree = ffecom_1 (ADDR_EXPR,
5129                               build_pointer_type (TREE_TYPE (arg1_tree)),
5130                               arg1_tree);
5131
5132         arg2_tree = convert (ffecom_f2c_ptr_to_integer_type_node,
5133                              ffecom_ptr_to_expr (arg2));
5134
5135         if (arg3 == NULL)
5136           arg3_tree = NULL_TREE;
5137         else
5138           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5139
5140         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5141         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5142         TREE_CHAIN (arg1_tree) = arg2_tree;
5143         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5144                                   ffecom_gfrt_kindtype (gfrt),
5145                                   FALSE,
5146                                   NULL_TREE,
5147                                   arg1_tree,
5148                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5149                                   ffebld_nonter_hook (expr));
5150         if (arg3_tree != NULL_TREE) {
5151           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5152                                      convert (TREE_TYPE (arg3_tree),
5153                                               expr_tree));
5154         }
5155       }
5156       return expr_tree;
5157
5158     case FFEINTRIN_impKILL_subr:
5159       {
5160         tree arg1_tree;
5161         tree arg2_tree;
5162         tree arg3_tree;
5163
5164         arg1_tree = convert (ffecom_f2c_integer_type_node,
5165                              ffecom_expr (arg1));
5166         arg1_tree = ffecom_1 (ADDR_EXPR,
5167                               build_pointer_type (TREE_TYPE (arg1_tree)),
5168                               arg1_tree);
5169
5170         arg2_tree = convert (ffecom_f2c_integer_type_node,
5171                              ffecom_expr (arg2));
5172         arg2_tree = ffecom_1 (ADDR_EXPR,
5173                               build_pointer_type (TREE_TYPE (arg2_tree)),
5174                               arg2_tree);
5175
5176         if (arg3 == NULL)
5177           arg3_tree = NULL_TREE;
5178         else
5179           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5180
5181         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5182         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5183         TREE_CHAIN (arg1_tree) = arg2_tree;
5184         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5185                                   ffecom_gfrt_kindtype (gfrt),
5186                                   FALSE,
5187                                   NULL_TREE,
5188                                   arg1_tree,
5189                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5190                                   ffebld_nonter_hook (expr));
5191         if (arg3_tree != NULL_TREE) {
5192           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5193                                      convert (TREE_TYPE (arg3_tree),
5194                                               expr_tree));
5195         }
5196       }
5197       return expr_tree;
5198
5199     case FFEINTRIN_impCTIME_subr:
5200     case FFEINTRIN_impTTYNAM_subr:
5201       {
5202         tree arg1_len = integer_zero_node;
5203         tree arg1_tree;
5204         tree arg2_tree;
5205
5206         arg1_tree = ffecom_arg_ptr_to_expr (arg2, &arg1_len);
5207
5208         arg2_tree = convert (((codegen_imp == FFEINTRIN_impCTIME_subr) ?
5209                               ffecom_f2c_longint_type_node :
5210                               ffecom_f2c_integer_type_node),
5211                              ffecom_expr (arg1));
5212         arg2_tree = ffecom_1 (ADDR_EXPR,
5213                               build_pointer_type (TREE_TYPE (arg2_tree)),
5214                               arg2_tree);
5215
5216         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5217         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5218         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5219         TREE_CHAIN (arg1_len) = arg2_tree;
5220         TREE_CHAIN (arg1_tree) = arg1_len;
5221
5222         expr_tree
5223           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5224                           ffecom_gfrt_kindtype (gfrt),
5225                           FALSE,
5226                           NULL_TREE,
5227                           arg1_tree,
5228                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5229                           ffebld_nonter_hook (expr));
5230         TREE_SIDE_EFFECTS (expr_tree) = 1;
5231       }
5232       return expr_tree;
5233
5234     case FFEINTRIN_impIRAND:
5235     case FFEINTRIN_impRAND:
5236       /* Arg defaults to 0 (normal random case) */
5237       {
5238         tree arg1_tree;
5239
5240         if (arg1 == NULL)
5241           arg1_tree = ffecom_integer_zero_node;
5242         else
5243           arg1_tree = ffecom_expr (arg1);
5244         arg1_tree = convert (ffecom_f2c_integer_type_node,
5245                              arg1_tree);
5246         arg1_tree = ffecom_1 (ADDR_EXPR,
5247                               build_pointer_type (TREE_TYPE (arg1_tree)),
5248                               arg1_tree);
5249         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5250
5251         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5252                                   ffecom_gfrt_kindtype (gfrt),
5253                                   FALSE,
5254                                   ((codegen_imp == FFEINTRIN_impIRAND) ?
5255                                    ffecom_f2c_integer_type_node :
5256                                    ffecom_f2c_real_type_node),
5257                                   arg1_tree,
5258                                   dest_tree, dest, dest_used,
5259                                   NULL_TREE, TRUE,
5260                                   ffebld_nonter_hook (expr));
5261       }
5262       return expr_tree;
5263
5264     case FFEINTRIN_impFTELL_subr:
5265     case FFEINTRIN_impUMASK_subr:
5266       {
5267         tree arg1_tree;
5268         tree arg2_tree;
5269
5270         arg1_tree = convert (ffecom_f2c_integer_type_node,
5271                              ffecom_expr (arg1));
5272         arg1_tree = ffecom_1 (ADDR_EXPR,
5273                               build_pointer_type (TREE_TYPE (arg1_tree)),
5274                               arg1_tree);
5275
5276         if (arg2 == NULL)
5277           arg2_tree = NULL_TREE;
5278         else
5279           arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
5280
5281         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5282                                   ffecom_gfrt_kindtype (gfrt),
5283                                   FALSE,
5284                                   NULL_TREE,
5285                                   build_tree_list (NULL_TREE, arg1_tree),
5286                                   NULL_TREE, NULL, NULL, NULL_TREE,
5287                                   TRUE,
5288                                   ffebld_nonter_hook (expr));
5289         if (arg2_tree != NULL_TREE) {
5290           expr_tree = ffecom_modify (NULL_TREE, arg2_tree,
5291                                      convert (TREE_TYPE (arg2_tree),
5292                                               expr_tree));
5293         }
5294       }
5295       return expr_tree;
5296
5297     case FFEINTRIN_impCPU_TIME:
5298     case FFEINTRIN_impSECOND_subr:
5299       {
5300         tree arg1_tree;
5301
5302         arg1_tree = ffecom_expr_w (NULL_TREE, arg1);
5303
5304         expr_tree
5305           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5306                           ffecom_gfrt_kindtype (gfrt),
5307                           FALSE,
5308                           NULL_TREE,
5309                           NULL_TREE,
5310                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5311                           ffebld_nonter_hook (expr));
5312
5313         expr_tree
5314           = ffecom_modify (NULL_TREE, arg1_tree,
5315                            convert (TREE_TYPE (arg1_tree),
5316                                     expr_tree));
5317       }
5318       return expr_tree;
5319
5320     case FFEINTRIN_impDTIME_subr:
5321     case FFEINTRIN_impETIME_subr:
5322       {
5323         tree arg1_tree;
5324         tree result_tree;
5325
5326         result_tree = ffecom_expr_w (NULL_TREE, arg2);
5327
5328         arg1_tree = ffecom_ptr_to_expr (arg1);
5329
5330         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5331                                   ffecom_gfrt_kindtype (gfrt),
5332                                   FALSE,
5333                                   NULL_TREE,
5334                                   build_tree_list (NULL_TREE, arg1_tree),
5335                                   NULL_TREE, NULL, NULL, NULL_TREE,
5336                                   TRUE,
5337                                   ffebld_nonter_hook (expr));
5338         expr_tree = ffecom_modify (NULL_TREE, result_tree,
5339                                    convert (TREE_TYPE (result_tree),
5340                                             expr_tree));
5341       }
5342       return expr_tree;
5343
5344       /* Straightforward calls of libf2c routines: */
5345     case FFEINTRIN_impABORT:
5346     case FFEINTRIN_impACCESS:
5347     case FFEINTRIN_impBESJ0:
5348     case FFEINTRIN_impBESJ1:
5349     case FFEINTRIN_impBESJN:
5350     case FFEINTRIN_impBESY0:
5351     case FFEINTRIN_impBESY1:
5352     case FFEINTRIN_impBESYN:
5353     case FFEINTRIN_impCHDIR_func:
5354     case FFEINTRIN_impCHMOD_func:
5355     case FFEINTRIN_impDATE:
5356     case FFEINTRIN_impDATE_AND_TIME:
5357     case FFEINTRIN_impDBESJ0:
5358     case FFEINTRIN_impDBESJ1:
5359     case FFEINTRIN_impDBESJN:
5360     case FFEINTRIN_impDBESY0:
5361     case FFEINTRIN_impDBESY1:
5362     case FFEINTRIN_impDBESYN:
5363     case FFEINTRIN_impDTIME_func:
5364     case FFEINTRIN_impETIME_func:
5365     case FFEINTRIN_impFGETC_func:
5366     case FFEINTRIN_impFGET_func:
5367     case FFEINTRIN_impFNUM:
5368     case FFEINTRIN_impFPUTC_func:
5369     case FFEINTRIN_impFPUT_func:
5370     case FFEINTRIN_impFSEEK:
5371     case FFEINTRIN_impFSTAT_func:
5372     case FFEINTRIN_impFTELL_func:
5373     case FFEINTRIN_impGERROR:
5374     case FFEINTRIN_impGETARG:
5375     case FFEINTRIN_impGETCWD_func:
5376     case FFEINTRIN_impGETENV:
5377     case FFEINTRIN_impGETGID:
5378     case FFEINTRIN_impGETLOG:
5379     case FFEINTRIN_impGETPID:
5380     case FFEINTRIN_impGETUID:
5381     case FFEINTRIN_impGMTIME:
5382     case FFEINTRIN_impHOSTNM_func:
5383     case FFEINTRIN_impIDATE_unix:
5384     case FFEINTRIN_impIDATE_vxt:
5385     case FFEINTRIN_impIERRNO:
5386     case FFEINTRIN_impISATTY:
5387     case FFEINTRIN_impITIME:
5388     case FFEINTRIN_impKILL_func:
5389     case FFEINTRIN_impLINK_func:
5390     case FFEINTRIN_impLNBLNK:
5391     case FFEINTRIN_impLSTAT_func:
5392     case FFEINTRIN_impLTIME:
5393     case FFEINTRIN_impMCLOCK8:
5394     case FFEINTRIN_impMCLOCK:
5395     case FFEINTRIN_impPERROR:
5396     case FFEINTRIN_impRENAME_func:
5397     case FFEINTRIN_impSECNDS:
5398     case FFEINTRIN_impSECOND_func:
5399     case FFEINTRIN_impSLEEP:
5400     case FFEINTRIN_impSRAND:
5401     case FFEINTRIN_impSTAT_func:
5402     case FFEINTRIN_impSYMLNK_func:
5403     case FFEINTRIN_impSYSTEM_CLOCK:
5404     case FFEINTRIN_impSYSTEM_func:
5405     case FFEINTRIN_impTIME8:
5406     case FFEINTRIN_impTIME_unix:
5407     case FFEINTRIN_impTIME_vxt:
5408     case FFEINTRIN_impUMASK_func:
5409     case FFEINTRIN_impUNLINK_func:
5410       break;
5411
5412     case FFEINTRIN_impCTIME_func:       /* CHARACTER functions not handled here. */
5413     case FFEINTRIN_impFDATE_func:       /* CHARACTER functions not handled here. */
5414     case FFEINTRIN_impTTYNAM_func:      /* CHARACTER functions not handled here. */
5415     case FFEINTRIN_impNONE:
5416     case FFEINTRIN_imp:         /* Hush up gcc warning. */
5417       fprintf (stderr, "No %s implementation.\n",
5418                ffeintrin_name_implementation (ffebld_symter_implementation (ffebld_left (expr))));
5419       assert ("unimplemented intrinsic" == NULL);
5420       return error_mark_node;
5421     }
5422
5423   assert (gfrt != FFECOM_gfrt); /* Must have an implementation! */
5424
5425   expr_tree = ffecom_arglist_expr_ (ffecom_gfrt_args_ (gfrt),
5426                                     ffebld_right (expr));
5427
5428   return ffecom_call_ (ffecom_gfrt_tree_ (gfrt), ffecom_gfrt_kindtype (gfrt),
5429                        (ffe_is_f2c_library () && ffecom_gfrt_complex_[gfrt]),
5430                        tree_type,
5431                        expr_tree, dest_tree, dest, dest_used,
5432                        NULL_TREE, TRUE,
5433                        ffebld_nonter_hook (expr));
5434
5435   /* See bottom of this file for f2c transforms used to determine
5436      many of the above implementations.  The info seems to confuse
5437      Emacs's C mode indentation, which is why it's been moved to
5438      the bottom of this source file.  */
5439 }
5440
5441 /* For power (exponentiation) where right-hand operand is type INTEGER,
5442    generate in-line code to do it the fast way (which, if the operand
5443    is a constant, might just mean a series of multiplies).  */
5444
5445 static tree
5446 ffecom_expr_power_integer_ (ffebld expr)
5447 {
5448   tree l = ffecom_expr (ffebld_left (expr));
5449   tree r = ffecom_expr (ffebld_right (expr));
5450   tree ltype = TREE_TYPE (l);
5451   tree rtype = TREE_TYPE (r);
5452   tree result = NULL_TREE;
5453
5454   if (l == error_mark_node
5455       || r == error_mark_node)
5456     return error_mark_node;
5457
5458   if (TREE_CODE (r) == INTEGER_CST)
5459     {
5460       int sgn = tree_int_cst_sgn (r);
5461
5462       if (sgn == 0)
5463         return convert (ltype, integer_one_node);
5464
5465       if ((TREE_CODE (ltype) == INTEGER_TYPE)
5466           && (sgn < 0))
5467         {
5468           /* Reciprocal of integer is either 0, -1, or 1, so after
5469              calculating that (which we leave to the back end to do
5470              or not do optimally), don't bother with any multiplying.  */
5471
5472           result = ffecom_tree_divide_ (ltype,
5473                                         convert (ltype, integer_one_node),
5474                                         l,
5475                                         NULL_TREE, NULL, NULL, NULL_TREE);
5476           r = ffecom_1 (NEGATE_EXPR,
5477                         rtype,
5478                         r);
5479           if ((TREE_INT_CST_LOW (r) & 1) == 0)
5480             result = ffecom_1 (ABS_EXPR, rtype,
5481                                result);
5482         }
5483
5484       /* Generate appropriate series of multiplies, preceded
5485          by divide if the exponent is negative.  */
5486
5487       l = save_expr (l);
5488
5489       if (sgn < 0)
5490         {
5491           l = ffecom_tree_divide_ (ltype,
5492                                    convert (ltype, integer_one_node),
5493                                    l,
5494                                    NULL_TREE, NULL, NULL,
5495                                    ffebld_nonter_hook (expr));
5496           r = ffecom_1 (NEGATE_EXPR, rtype, r);
5497           assert (TREE_CODE (r) == INTEGER_CST);
5498
5499           if (tree_int_cst_sgn (r) < 0)
5500             {                   /* The "most negative" number.  */
5501               r = ffecom_1 (NEGATE_EXPR, rtype,
5502                             ffecom_2 (RSHIFT_EXPR, rtype,
5503                                       r,
5504                                       integer_one_node));
5505               l = save_expr (l);
5506               l = ffecom_2 (MULT_EXPR, ltype,
5507                             l,
5508                             l);
5509             }
5510         }
5511
5512       for (;;)
5513         {
5514           if (TREE_INT_CST_LOW (r) & 1)
5515             {
5516               if (result == NULL_TREE)
5517                 result = l;
5518               else
5519                 result = ffecom_2 (MULT_EXPR, ltype,
5520                                    result,
5521                                    l);
5522             }
5523
5524           r = ffecom_2 (RSHIFT_EXPR, rtype,
5525                         r,
5526                         integer_one_node);
5527           if (integer_zerop (r))
5528             break;
5529           assert (TREE_CODE (r) == INTEGER_CST);
5530
5531           l = save_expr (l);
5532           l = ffecom_2 (MULT_EXPR, ltype,
5533                         l,
5534                         l);
5535         }
5536       return result;
5537     }
5538
5539   /* Though rhs isn't a constant, in-line code cannot be expanded
5540      while transforming dummies
5541      because the back end cannot be easily convinced to generate
5542      stores (MODIFY_EXPR), handle temporaries, and so on before
5543      all the appropriate rtx's have been generated for things like
5544      dummy args referenced in rhs -- which doesn't happen until
5545      store_parm_decls() is called (expand_function_start, I believe,
5546      does the actual rtx-stuffing of PARM_DECLs).
5547
5548      So, in this case, let the caller generate the call to the
5549      run-time-library function to evaluate the power for us.  */
5550
5551   if (ffecom_transform_only_dummies_)
5552     return NULL_TREE;
5553
5554   /* Right-hand operand not a constant, expand in-line code to figure
5555      out how to do the multiplies, &c.
5556
5557      The returned expression is expressed this way in GNU C, where l and
5558      r are the "inputs":
5559
5560      ({ typeof (r) rtmp = r;
5561         typeof (l) ltmp = l;
5562         typeof (l) result;
5563
5564         if (rtmp == 0)
5565           result = 1;
5566         else
5567           {
5568             if ((basetypeof (l) == basetypeof (int))
5569                 && (rtmp < 0))
5570               {
5571                 result = ((typeof (l)) 1) / ltmp;
5572                 if ((ltmp < 0) && (((-rtmp) & 1) == 0))
5573                   result = -result;
5574               }
5575             else
5576               {
5577                 result = 1;
5578                 if ((basetypeof (l) != basetypeof (int))
5579                     && (rtmp < 0))
5580                   {
5581                     ltmp = ((typeof (l)) 1) / ltmp;
5582                     rtmp = -rtmp;
5583                     if (rtmp < 0)
5584                       {
5585                         rtmp = -(rtmp >> 1);
5586                         ltmp *= ltmp;
5587                       }
5588                   }
5589                 for (;;)
5590                   {
5591                     if (rtmp & 1)
5592                       result *= ltmp;
5593                     if ((rtmp >>= 1) == 0)
5594                       break;
5595                     ltmp *= ltmp;
5596                   }
5597               }
5598           }
5599         result;
5600      })
5601
5602      Note that some of the above is compile-time collapsable, such as
5603      the first part of the if statements that checks the base type of
5604      l against int.  The if statements are phrased that way to suggest
5605      an easy way to generate the if/else constructs here, knowing that
5606      the back end should (and probably does) eliminate the resulting
5607      dead code (either the int case or the non-int case), something
5608      it couldn't do without the redundant phrasing, requiring explicit
5609      dead-code elimination here, which would be kind of difficult to
5610      read.  */
5611
5612   {
5613     tree rtmp;
5614     tree ltmp;
5615     tree divide;
5616     tree basetypeof_l_is_int;
5617     tree se;
5618     tree t;
5619
5620     basetypeof_l_is_int
5621       = build_int_2 ((TREE_CODE (ltype) == INTEGER_TYPE), 0);
5622
5623     se = expand_start_stmt_expr (/*has_scope=*/1);
5624
5625     ffecom_start_compstmt ();
5626
5627 #ifndef HAHA
5628     rtmp = ffecom_make_tempvar ("power_r", rtype,
5629                                 FFETARGET_charactersizeNONE, -1);
5630     ltmp = ffecom_make_tempvar ("power_l", ltype,
5631                                 FFETARGET_charactersizeNONE, -1);
5632     result = ffecom_make_tempvar ("power_res", ltype,
5633                                   FFETARGET_charactersizeNONE, -1);
5634     if (TREE_CODE (ltype) == COMPLEX_TYPE
5635         || TREE_CODE (ltype) == RECORD_TYPE)
5636       divide = ffecom_make_tempvar ("power_div", ltype,
5637                                     FFETARGET_charactersizeNONE, -1);
5638     else
5639       divide = NULL_TREE;
5640 #else  /* HAHA */
5641     {
5642       tree hook;
5643
5644       hook = ffebld_nonter_hook (expr);
5645       assert (hook);
5646       assert (TREE_CODE (hook) == TREE_VEC);
5647       assert (TREE_VEC_LENGTH (hook) == 4);
5648       rtmp = TREE_VEC_ELT (hook, 0);
5649       ltmp = TREE_VEC_ELT (hook, 1);
5650       result = TREE_VEC_ELT (hook, 2);
5651       divide = TREE_VEC_ELT (hook, 3);
5652       if (TREE_CODE (ltype) == COMPLEX_TYPE
5653           || TREE_CODE (ltype) == RECORD_TYPE)
5654         assert (divide);
5655       else
5656         assert (! divide);
5657     }
5658 #endif  /* HAHA */
5659
5660     expand_expr_stmt (ffecom_modify (void_type_node,
5661                                      rtmp,
5662                                      r));
5663     expand_expr_stmt (ffecom_modify (void_type_node,
5664                                      ltmp,
5665                                      l));
5666     expand_start_cond (ffecom_truth_value
5667                        (ffecom_2 (EQ_EXPR, integer_type_node,
5668                                   rtmp,
5669                                   convert (rtype, integer_zero_node))),
5670                        0);
5671     expand_expr_stmt (ffecom_modify (void_type_node,
5672                                      result,
5673                                      convert (ltype, integer_one_node)));
5674     expand_start_else ();
5675     if (! integer_zerop (basetypeof_l_is_int))
5676       {
5677         expand_start_cond (ffecom_2 (LT_EXPR, integer_type_node,
5678                                      rtmp,
5679                                      convert (rtype,
5680                                               integer_zero_node)),
5681                            0);
5682         expand_expr_stmt (ffecom_modify (void_type_node,
5683                                          result,
5684                                          ffecom_tree_divide_
5685                                          (ltype,
5686                                           convert (ltype, integer_one_node),
5687                                           ltmp,
5688                                           NULL_TREE, NULL, NULL,
5689                                           divide)));
5690         expand_start_cond (ffecom_truth_value
5691                            (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5692                                       ffecom_2 (LT_EXPR, integer_type_node,
5693                                                 ltmp,
5694                                                 convert (ltype,
5695                                                          integer_zero_node)),
5696                                       ffecom_2 (EQ_EXPR, integer_type_node,
5697                                                 ffecom_2 (BIT_AND_EXPR,
5698                                                           rtype,
5699                                                           ffecom_1 (NEGATE_EXPR,
5700                                                                     rtype,
5701                                                                     rtmp),
5702                                                           convert (rtype,
5703                                                                    integer_one_node)),
5704                                                 convert (rtype,
5705                                                          integer_zero_node)))),
5706                            0);
5707         expand_expr_stmt (ffecom_modify (void_type_node,
5708                                          result,
5709                                          ffecom_1 (NEGATE_EXPR,
5710                                                    ltype,
5711                                                    result)));
5712         expand_end_cond ();
5713         expand_start_else ();
5714       }
5715     expand_expr_stmt (ffecom_modify (void_type_node,
5716                                      result,
5717                                      convert (ltype, integer_one_node)));
5718     expand_start_cond (ffecom_truth_value
5719                        (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5720                                   ffecom_truth_value_invert
5721                                   (basetypeof_l_is_int),
5722                                   ffecom_2 (LT_EXPR, integer_type_node,
5723                                             rtmp,
5724                                             convert (rtype,
5725                                                      integer_zero_node)))),
5726                        0);
5727     expand_expr_stmt (ffecom_modify (void_type_node,
5728                                      ltmp,
5729                                      ffecom_tree_divide_
5730                                      (ltype,
5731                                       convert (ltype, integer_one_node),
5732                                       ltmp,
5733                                       NULL_TREE, NULL, NULL,
5734                                       divide)));
5735     expand_expr_stmt (ffecom_modify (void_type_node,
5736                                      rtmp,
5737                                      ffecom_1 (NEGATE_EXPR, rtype,
5738                                                rtmp)));
5739     expand_start_cond (ffecom_truth_value
5740                        (ffecom_2 (LT_EXPR, integer_type_node,
5741                                   rtmp,
5742                                   convert (rtype, integer_zero_node))),
5743                        0);
5744     expand_expr_stmt (ffecom_modify (void_type_node,
5745                                      rtmp,
5746                                      ffecom_1 (NEGATE_EXPR, rtype,
5747                                                ffecom_2 (RSHIFT_EXPR,
5748                                                          rtype,
5749                                                          rtmp,
5750                                                          integer_one_node))));
5751     expand_expr_stmt (ffecom_modify (void_type_node,
5752                                      ltmp,
5753                                      ffecom_2 (MULT_EXPR, ltype,
5754                                                ltmp,
5755                                                ltmp)));
5756     expand_end_cond ();
5757     expand_end_cond ();
5758     expand_start_loop (1);
5759     expand_start_cond (ffecom_truth_value
5760                        (ffecom_2 (BIT_AND_EXPR, rtype,
5761                                   rtmp,
5762                                   convert (rtype, integer_one_node))),
5763                        0);
5764     expand_expr_stmt (ffecom_modify (void_type_node,
5765                                      result,
5766                                      ffecom_2 (MULT_EXPR, ltype,
5767                                                result,
5768                                                ltmp)));
5769     expand_end_cond ();
5770     expand_exit_loop_if_false (NULL,
5771                                ffecom_truth_value
5772                                (ffecom_modify (rtype,
5773                                                rtmp,
5774                                                ffecom_2 (RSHIFT_EXPR,
5775                                                          rtype,
5776                                                          rtmp,
5777                                                          integer_one_node))));
5778     expand_expr_stmt (ffecom_modify (void_type_node,
5779                                      ltmp,
5780                                      ffecom_2 (MULT_EXPR, ltype,
5781                                                ltmp,
5782                                                ltmp)));
5783     expand_end_loop ();
5784     expand_end_cond ();
5785     if (!integer_zerop (basetypeof_l_is_int))
5786       expand_end_cond ();
5787     expand_expr_stmt (result);
5788
5789     t = ffecom_end_compstmt ();
5790
5791     result = expand_end_stmt_expr (se);
5792
5793     /* This code comes from c-parse.in, after its expand_end_stmt_expr.  */
5794
5795     if (TREE_CODE (t) == BLOCK)
5796       {
5797         /* Make a BIND_EXPR for the BLOCK already made.  */
5798         result = build (BIND_EXPR, TREE_TYPE (result),
5799                         NULL_TREE, result, t);
5800         /* Remove the block from the tree at this point.
5801            It gets put back at the proper place
5802            when the BIND_EXPR is expanded.  */
5803         delete_block (t);
5804       }
5805     else
5806       result = t;
5807   }
5808
5809   return result;
5810 }
5811
5812 /* ffecom_expr_transform_ -- Transform symbols in expr
5813
5814    ffebld expr;  // FFE expression.
5815    ffecom_expr_transform_ (expr);
5816
5817    Recursive descent on expr while transforming any untransformed SYMTERs.  */
5818
5819 static void
5820 ffecom_expr_transform_ (ffebld expr)
5821 {
5822   tree t;
5823   ffesymbol s;
5824
5825  tail_recurse:
5826
5827   if (expr == NULL)
5828     return;
5829
5830   switch (ffebld_op (expr))
5831     {
5832     case FFEBLD_opSYMTER:
5833       s = ffebld_symter (expr);
5834       t = ffesymbol_hook (s).decl_tree;
5835       if ((t == NULL_TREE)
5836           && ((ffesymbol_kind (s) != FFEINFO_kindNONE)
5837               || ((ffesymbol_where (s) != FFEINFO_whereNONE)
5838                   && (ffesymbol_where (s) != FFEINFO_whereINTRINSIC))))
5839         {
5840           s = ffecom_sym_transform_ (s);
5841           t = ffesymbol_hook (s).decl_tree;     /* Sfunc expr non-dummy,
5842                                                    DIMENSION expr? */
5843         }
5844       break;                    /* Ok if (t == NULL) here. */
5845
5846     case FFEBLD_opITEM:
5847       ffecom_expr_transform_ (ffebld_head (expr));
5848       expr = ffebld_trail (expr);
5849       goto tail_recurse;        /* :::::::::::::::::::: */
5850
5851     default:
5852       break;
5853     }
5854
5855   switch (ffebld_arity (expr))
5856     {
5857     case 2:
5858       ffecom_expr_transform_ (ffebld_left (expr));
5859       expr = ffebld_right (expr);
5860       goto tail_recurse;        /* :::::::::::::::::::: */
5861
5862     case 1:
5863       expr = ffebld_left (expr);
5864       goto tail_recurse;        /* :::::::::::::::::::: */
5865
5866     default:
5867       break;
5868     }
5869
5870   return;
5871 }
5872
5873 /* Make a type based on info in live f2c.h file.  */
5874
5875 static void
5876 ffecom_f2c_make_type_ (tree *type, int tcode, const char *name)
5877 {
5878   switch (tcode)
5879     {
5880     case FFECOM_f2ccodeCHAR:
5881       *type = make_signed_type (CHAR_TYPE_SIZE);
5882       break;
5883
5884     case FFECOM_f2ccodeSHORT:
5885       *type = make_signed_type (SHORT_TYPE_SIZE);
5886       break;
5887
5888     case FFECOM_f2ccodeINT:
5889       *type = make_signed_type (INT_TYPE_SIZE);
5890       break;
5891
5892     case FFECOM_f2ccodeLONG:
5893       *type = make_signed_type (LONG_TYPE_SIZE);
5894       break;
5895
5896     case FFECOM_f2ccodeLONGLONG:
5897       *type = make_signed_type (LONG_LONG_TYPE_SIZE);
5898       break;
5899
5900     case FFECOM_f2ccodeCHARPTR:
5901       *type = build_pointer_type (DEFAULT_SIGNED_CHAR
5902                                   ? signed_char_type_node
5903                                   : unsigned_char_type_node);
5904       break;
5905
5906     case FFECOM_f2ccodeFLOAT:
5907       *type = make_node (REAL_TYPE);
5908       TYPE_PRECISION (*type) = FLOAT_TYPE_SIZE;
5909       layout_type (*type);
5910       break;
5911
5912     case FFECOM_f2ccodeDOUBLE:
5913       *type = make_node (REAL_TYPE);
5914       TYPE_PRECISION (*type) = DOUBLE_TYPE_SIZE;
5915       layout_type (*type);
5916       break;
5917
5918     case FFECOM_f2ccodeLONGDOUBLE:
5919       *type = make_node (REAL_TYPE);
5920       TYPE_PRECISION (*type) = LONG_DOUBLE_TYPE_SIZE;
5921       layout_type (*type);
5922       break;
5923
5924     case FFECOM_f2ccodeTWOREALS:
5925       *type = ffecom_make_complex_type_ (ffecom_f2c_real_type_node);
5926       break;
5927
5928     case FFECOM_f2ccodeTWODOUBLEREALS:
5929       *type = ffecom_make_complex_type_ (ffecom_f2c_doublereal_type_node);
5930       break;
5931
5932     default:
5933       assert ("unexpected FFECOM_f2ccodeXYZZY!" == NULL);
5934       *type = error_mark_node;
5935       return;
5936     }
5937
5938   pushdecl (build_decl (TYPE_DECL,
5939                         ffecom_get_invented_identifier ("__g77_f2c_%s", name),
5940                         *type));
5941 }
5942
5943 /* Set the f2c list-directed-I/O code for whatever (integral) type has the
5944    given size.  */
5945
5946 static void
5947 ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
5948                           int code)
5949 {
5950   int j;
5951   tree t;
5952
5953   for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
5954     if ((t = ffecom_tree_type[bt][j]) != NULL_TREE
5955         && compare_tree_int (TYPE_SIZE (t), size) == 0)
5956       {
5957         assert (code != -1);
5958         ffecom_f2c_typecode_[bt][j] = code;
5959         code = -1;
5960       }
5961 }
5962
5963 /* Finish up globals after doing all program units in file
5964
5965    Need to handle only uninitialized COMMON areas.  */
5966
5967 static ffeglobal
5968 ffecom_finish_global_ (ffeglobal global)
5969 {
5970   tree cbtype;
5971   tree cbt;
5972   tree size;
5973
5974   if (ffeglobal_type (global) != FFEGLOBAL_typeCOMMON)
5975       return global;
5976
5977   if (ffeglobal_common_init (global))
5978       return global;
5979
5980   cbt = ffeglobal_hook (global);
5981   if ((cbt == NULL_TREE)
5982       || !ffeglobal_common_have_size (global))
5983     return global;              /* No need to make common, never ref'd. */
5984
5985   DECL_EXTERNAL (cbt) = 0;
5986
5987   /* Give the array a size now.  */
5988
5989   size = build_int_2 ((ffeglobal_common_size (global)
5990                       + ffeglobal_common_pad (global)) - 1,
5991                       0);
5992
5993   cbtype = TREE_TYPE (cbt);
5994   TYPE_DOMAIN (cbtype) = build_range_type (integer_type_node,
5995                                            integer_zero_node,
5996                                            size);
5997   if (!TREE_TYPE (size))
5998     TREE_TYPE (size) = TYPE_DOMAIN (cbtype);
5999   layout_type (cbtype);
6000
6001   cbt = start_decl (cbt, FALSE);
6002   assert (cbt == ffeglobal_hook (global));
6003
6004   finish_decl (cbt, NULL_TREE, FALSE);
6005
6006   return global;
6007 }
6008
6009 /* Finish up any untransformed symbols.  */
6010
6011 static ffesymbol
6012 ffecom_finish_symbol_transform_ (ffesymbol s)
6013 {
6014   if ((s == NULL) || (TREE_CODE (current_function_decl) == ERROR_MARK))
6015     return s;
6016
6017   /* It's easy to know to transform an untransformed symbol, to make sure
6018      we put out debugging info for it.  But COMMON variables, unlike
6019      EQUIVALENCE ones, aren't given declarations in addition to the
6020      tree expressions that specify offsets, because COMMON variables
6021      can be referenced in the outer scope where only dummy arguments
6022      (PARM_DECLs) should really be seen.  To be safe, just don't do any
6023      VAR_DECLs for COMMON variables when we transform them for real
6024      use, and therefore we do all the VAR_DECL creating here.  */
6025
6026   if (ffesymbol_hook (s).decl_tree == NULL_TREE)
6027     {
6028       if (ffesymbol_kind (s) != FFEINFO_kindNONE
6029           || (ffesymbol_where (s) != FFEINFO_whereNONE
6030               && ffesymbol_where (s) != FFEINFO_whereINTRINSIC
6031               && ffesymbol_where (s) != FFEINFO_whereDUMMY))
6032         /* Not transformed, and not CHARACTER*(*), and not a dummy
6033            argument, which can happen only if the entry point names
6034            it "rides in on" are all invalidated for other reasons.  */
6035         s = ffecom_sym_transform_ (s);
6036     }
6037
6038   if ((ffesymbol_where (s) == FFEINFO_whereCOMMON)
6039       && (ffesymbol_hook (s).decl_tree != error_mark_node))
6040     {
6041       /* This isn't working, at least for dbxout.  The .s file looks
6042          okay to me (burley), but in gdb 4.9 at least, the variables
6043          appear to reside somewhere outside of the common area, so
6044          it doesn't make sense to mislead anyone by generating the info
6045          on those variables until this is fixed.  NOTE: Same problem
6046          with EQUIVALENCE, sadly...see similar #if later.  */
6047       ffecom_member_phase2_ (ffesymbol_storage (ffesymbol_common (s)),
6048                              ffesymbol_storage (s));
6049     }
6050
6051   return s;
6052 }
6053
6054 /* Append underscore(s) to name before calling get_identifier.  "us"
6055    is nonzero if the name already contains an underscore and thus
6056    needs two underscores appended.  */
6057
6058 static tree
6059 ffecom_get_appended_identifier_ (char us, const char *name)
6060 {
6061   int i;
6062   char *newname;
6063   tree id;
6064
6065   newname = xmalloc ((i = strlen (name)) + 1
6066                      + ffe_is_underscoring ()
6067                      + us);
6068   memcpy (newname, name, i);
6069   newname[i] = '_';
6070   newname[i + us] = '_';
6071   newname[i + 1 + us] = '\0';
6072   id = get_identifier (newname);
6073
6074   free (newname);
6075
6076   return id;
6077 }
6078
6079 /* Decide whether to append underscore to name before calling
6080    get_identifier.  */
6081
6082 static tree
6083 ffecom_get_external_identifier_ (ffesymbol s)
6084 {
6085   char us;
6086   const char *name = ffesymbol_text (s);
6087
6088   /* If name is a built-in name, just return it as is.  */
6089
6090   if (!ffe_is_underscoring ()
6091       || (strcmp (name, FFETARGET_nameBLANK_COMMON) == 0)
6092 #if FFETARGET_isENFORCED_MAIN_NAME
6093       || (strcmp (name, FFETARGET_nameENFORCED_NAME) == 0)
6094 #else
6095       || (strcmp (name, FFETARGET_nameUNNAMED_MAIN) == 0)
6096 #endif
6097       || (strcmp (name, FFETARGET_nameUNNAMED_BLOCK_DATA) == 0))
6098     return get_identifier (name);
6099
6100   us = ffe_is_second_underscore ()
6101     ? (strchr (name, '_') != NULL)
6102       : 0;
6103
6104   return ffecom_get_appended_identifier_ (us, name);
6105 }
6106
6107 /* Decide whether to append underscore to internal name before calling
6108    get_identifier.
6109
6110    This is for non-external, top-function-context names only.  Transform
6111    identifier so it doesn't conflict with the transformed result
6112    of using a _different_ external name.  E.g. if "CALL FOO" is
6113    transformed into "FOO_();", then the variable in "FOO_ = 3"
6114    must be transformed into something that does not conflict, since
6115    these two things should be independent.
6116
6117    The transformation is as follows.  If the name does not contain
6118    an underscore, there is no possible conflict, so just return.
6119    If the name does contain an underscore, then transform it just
6120    like we transform an external identifier.  */
6121
6122 static tree
6123 ffecom_get_identifier_ (const char *name)
6124 {
6125   /* If name does not contain an underscore, just return it as is.  */
6126
6127   if (!ffe_is_underscoring ()
6128       || (strchr (name, '_') == NULL))
6129     return get_identifier (name);
6130
6131   return ffecom_get_appended_identifier_ (ffe_is_second_underscore (),
6132                                           name);
6133 }
6134
6135 /* ffecom_gen_sfuncdef_ -- Generate definition of statement function
6136
6137    tree t;
6138    ffesymbol s;  // kindFUNCTION, whereIMMEDIATE.
6139    t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s),
6140          ffesymbol_kindtype(s));
6141
6142    Call after setting up containing function and getting trees for all
6143    other symbols.  */
6144
6145 static tree
6146 ffecom_gen_sfuncdef_ (ffesymbol s, ffeinfoBasictype bt, ffeinfoKindtype kt)
6147 {
6148   ffebld expr = ffesymbol_sfexpr (s);
6149   tree type;
6150   tree func;
6151   tree result;
6152   bool charfunc = (bt == FFEINFO_basictypeCHARACTER);
6153   static bool recurse = FALSE;
6154   int old_lineno = lineno;
6155   const char *old_input_filename = input_filename;
6156
6157   ffecom_nested_entry_ = s;
6158
6159   /* For now, we don't have a handy pointer to where the sfunc is actually
6160      defined, though that should be easy to add to an ffesymbol. (The
6161      token/where info available might well point to the place where the type
6162      of the sfunc is declared, especially if that precedes the place where
6163      the sfunc itself is defined, which is typically the case.)  We should
6164      put out a null pointer rather than point somewhere wrong, but I want to
6165      see how it works at this point.  */
6166
6167   input_filename = ffesymbol_where_filename (s);
6168   lineno = ffesymbol_where_filelinenum (s);
6169
6170   /* Pretransform the expression so any newly discovered things belong to the
6171      outer program unit, not to the statement function. */
6172
6173   ffecom_expr_transform_ (expr);
6174
6175   /* Make sure no recursive invocation of this fn (a specific case of failing
6176      to pretransform an sfunc's expression, i.e. where its expression
6177      references another untransformed sfunc) happens. */
6178
6179   assert (!recurse);
6180   recurse = TRUE;
6181
6182   push_f_function_context ();
6183
6184   if (charfunc)
6185     type = void_type_node;
6186   else
6187     {
6188       type = ffecom_tree_type[bt][kt];
6189       if (type == NULL_TREE)
6190         type = integer_type_node;       /* _sym_exec_transition reports
6191                                            error. */
6192     }
6193
6194   start_function (ffecom_get_identifier_ (ffesymbol_text (s)),
6195                   build_function_type (type, NULL_TREE),
6196                   1,            /* nested/inline */
6197                   0);           /* TREE_PUBLIC */
6198
6199   /* We don't worry about COMPLEX return values here, because this is
6200      entirely internal to our code, and gcc has the ability to return COMPLEX
6201      directly as a value.  */
6202
6203   if (charfunc)
6204     {                           /* Prepend arg for where result goes. */
6205       tree type;
6206
6207       type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
6208
6209       result = ffecom_get_invented_identifier ("__g77_%s", "result");
6210
6211       ffecom_char_enhance_arg_ (&type, s);      /* Ignore returned length. */
6212
6213       type = build_pointer_type (type);
6214       result = build_decl (PARM_DECL, result, type);
6215
6216       push_parm_decl (result);
6217     }
6218   else
6219     result = NULL_TREE;         /* Not ref'd if !charfunc. */
6220
6221   ffecom_push_dummy_decls_ (ffesymbol_dummyargs (s), TRUE);
6222
6223   store_parm_decls (0);
6224
6225   ffecom_start_compstmt ();
6226
6227   if (expr != NULL)
6228     {
6229       if (charfunc)
6230         {
6231           ffetargetCharacterSize sz = ffesymbol_size (s);
6232           tree result_length;
6233
6234           result_length = build_int_2 (sz, 0);
6235           TREE_TYPE (result_length) = ffecom_f2c_ftnlen_type_node;
6236
6237           ffecom_prepare_let_char_ (sz, expr);
6238
6239           ffecom_prepare_end ();
6240
6241           ffecom_let_char_ (result, result_length, sz, expr);
6242           expand_null_return ();
6243         }
6244       else
6245         {
6246           ffecom_prepare_expr (expr);
6247
6248           ffecom_prepare_end ();
6249
6250           expand_return (ffecom_modify (NULL_TREE,
6251                                         DECL_RESULT (current_function_decl),
6252                                         ffecom_expr (expr)));
6253         }
6254     }
6255
6256   ffecom_end_compstmt ();
6257
6258   func = current_function_decl;
6259   finish_function (1);
6260
6261   pop_f_function_context ();
6262
6263   recurse = FALSE;
6264
6265   lineno = old_lineno;
6266   input_filename = old_input_filename;
6267
6268   ffecom_nested_entry_ = NULL;
6269
6270   return func;
6271 }
6272
6273 static const char *
6274 ffecom_gfrt_args_ (ffecomGfrt ix)
6275 {
6276   return ffecom_gfrt_argstring_[ix];
6277 }
6278
6279 static tree
6280 ffecom_gfrt_tree_ (ffecomGfrt ix)
6281 {
6282   if (ffecom_gfrt_[ix] == NULL_TREE)
6283     ffecom_make_gfrt_ (ix);
6284
6285   return ffecom_1 (ADDR_EXPR,
6286                    build_pointer_type (TREE_TYPE (ffecom_gfrt_[ix])),
6287                    ffecom_gfrt_[ix]);
6288 }
6289
6290 /* Return initialize-to-zero expression for this VAR_DECL.  */
6291
6292 /* A somewhat evil way to prevent the garbage collector
6293    from collecting 'tree' structures.  */
6294 #define NUM_TRACKED_CHUNK 63
6295 struct tree_ggc_tracker GTY(())
6296 {
6297   struct tree_ggc_tracker *next;
6298   tree trees[NUM_TRACKED_CHUNK];
6299 };
6300 static GTY(()) struct tree_ggc_tracker *tracker_head;
6301
6302 void
6303 ffecom_save_tree_forever (tree t)
6304 {
6305   int i;
6306   if (tracker_head != NULL)
6307     for (i = 0; i < NUM_TRACKED_CHUNK; i++)
6308       if (tracker_head->trees[i] == NULL)
6309         {
6310           tracker_head->trees[i] = t;
6311           return;
6312         }
6313
6314   {
6315     /* Need to allocate a new block.  */
6316     struct tree_ggc_tracker *old_head = tracker_head;
6317
6318     tracker_head = ggc_alloc (sizeof (*tracker_head));
6319     tracker_head->next = old_head;
6320     tracker_head->trees[0] = t;
6321     for (i = 1; i < NUM_TRACKED_CHUNK; i++)
6322       tracker_head->trees[i] = NULL;
6323   }
6324 }
6325
6326 static tree
6327 ffecom_init_zero_ (tree decl)
6328 {
6329   tree init;
6330   int incremental = TREE_STATIC (decl);
6331   tree type = TREE_TYPE (decl);
6332
6333   if (incremental)
6334     {
6335       make_decl_rtl (decl, NULL);
6336       assemble_variable (decl, TREE_PUBLIC (decl) ? 1 : 0, 0, 1);
6337     }
6338
6339   if ((TREE_CODE (type) != ARRAY_TYPE)
6340       && (TREE_CODE (type) != RECORD_TYPE)
6341       && (TREE_CODE (type) != UNION_TYPE)
6342       && !incremental)
6343     init = convert (type, integer_zero_node);
6344   else if (!incremental)
6345     {
6346       init = build (CONSTRUCTOR, type, NULL_TREE, NULL_TREE);
6347       TREE_CONSTANT (init) = 1;
6348       TREE_STATIC (init) = 1;
6349     }
6350   else
6351     {
6352       assemble_zeros (int_size_in_bytes (type));
6353       init = error_mark_node;
6354     }
6355
6356   return init;
6357 }
6358
6359 static tree
6360 ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
6361                          tree *maybe_tree)
6362 {
6363   tree expr_tree;
6364   tree length_tree;
6365
6366   switch (ffebld_op (arg))
6367     {
6368     case FFEBLD_opCONTER:       /* For F90, check 0-length. */
6369       if (ffetarget_length_character1
6370           (ffebld_constant_character1
6371            (ffebld_conter (arg))) == 0)
6372         {
6373           *maybe_tree = integer_zero_node;
6374           return convert (tree_type, integer_zero_node);
6375         }
6376
6377       *maybe_tree = integer_one_node;
6378       expr_tree = build_int_2 (*ffetarget_text_character1
6379                                (ffebld_constant_character1
6380                                 (ffebld_conter (arg))),
6381                                0);
6382       TREE_TYPE (expr_tree) = tree_type;
6383       return expr_tree;
6384
6385     case FFEBLD_opSYMTER:
6386     case FFEBLD_opARRAYREF:
6387     case FFEBLD_opFUNCREF:
6388     case FFEBLD_opSUBSTR:
6389       ffecom_char_args_ (&expr_tree, &length_tree, arg);
6390
6391       if ((expr_tree == error_mark_node)
6392           || (length_tree == error_mark_node))
6393         {
6394           *maybe_tree = error_mark_node;
6395           return error_mark_node;
6396         }
6397
6398       if (integer_zerop (length_tree))
6399         {
6400           *maybe_tree = integer_zero_node;
6401           return convert (tree_type, integer_zero_node);
6402         }
6403
6404       expr_tree
6405         = ffecom_1 (INDIRECT_REF,
6406                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6407                     expr_tree);
6408       expr_tree
6409         = ffecom_2 (ARRAY_REF,
6410                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6411                     expr_tree,
6412                     integer_one_node);
6413       expr_tree = convert (tree_type, expr_tree);
6414
6415       if (TREE_CODE (length_tree) == INTEGER_CST)
6416         *maybe_tree = integer_one_node;
6417       else                      /* Must check length at run time.  */
6418         *maybe_tree
6419           = ffecom_truth_value
6420             (ffecom_2 (GT_EXPR, integer_type_node,
6421                        length_tree,
6422                        ffecom_f2c_ftnlen_zero_node));
6423       return expr_tree;
6424
6425     case FFEBLD_opPAREN:
6426     case FFEBLD_opCONVERT:
6427       if (ffeinfo_size (ffebld_info (arg)) == 0)
6428         {
6429           *maybe_tree = integer_zero_node;
6430           return convert (tree_type, integer_zero_node);
6431         }
6432       return ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6433                                       maybe_tree);
6434
6435     case FFEBLD_opCONCATENATE:
6436       {
6437         tree maybe_left;
6438         tree maybe_right;
6439         tree expr_left;
6440         tree expr_right;
6441
6442         expr_left = ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6443                                              &maybe_left);
6444         expr_right = ffecom_intrinsic_ichar_ (tree_type, ffebld_right (arg),
6445                                               &maybe_right);
6446         *maybe_tree = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
6447                                 maybe_left,
6448                                 maybe_right);
6449         expr_tree = ffecom_3 (COND_EXPR, tree_type,
6450                               maybe_left,
6451                               expr_left,
6452                               expr_right);
6453         return expr_tree;
6454       }
6455
6456     default:
6457       assert ("bad op in ICHAR" == NULL);
6458       return error_mark_node;
6459     }
6460 }
6461
6462 /* ffecom_intrinsic_len_ -- Return length info for char arg (LEN())
6463
6464    tree length_arg;
6465    ffebld expr;
6466    length_arg = ffecom_intrinsic_len_ (expr);
6467
6468    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
6469    subexpressions by constructing the appropriate tree for the
6470    length-of-character-text argument in a calling sequence.  */
6471
6472 static tree
6473 ffecom_intrinsic_len_ (ffebld expr)
6474 {
6475   ffetargetCharacter1 val;
6476   tree length;
6477
6478   switch (ffebld_op (expr))
6479     {
6480     case FFEBLD_opCONTER:
6481       val = ffebld_constant_character1 (ffebld_conter (expr));
6482       length = build_int_2 (ffetarget_length_character1 (val), 0);
6483       TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6484       break;
6485
6486     case FFEBLD_opSYMTER:
6487       {
6488         ffesymbol s = ffebld_symter (expr);
6489         tree item;
6490
6491         item = ffesymbol_hook (s).decl_tree;
6492         if (item == NULL_TREE)
6493           {
6494             s = ffecom_sym_transform_ (s);
6495             item = ffesymbol_hook (s).decl_tree;
6496           }
6497         if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
6498           {
6499             if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
6500               length = ffesymbol_hook (s).length_tree;
6501             else
6502               {
6503                 length = build_int_2 (ffesymbol_size (s), 0);
6504                 TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6505               }
6506           }
6507         else if (item == error_mark_node)
6508           length = error_mark_node;
6509         else                    /* FFEINFO_kindFUNCTION: */
6510           length = NULL_TREE;
6511       }
6512       break;
6513
6514     case FFEBLD_opARRAYREF:
6515       length = ffecom_intrinsic_len_ (ffebld_left (expr));
6516       break;
6517
6518     case FFEBLD_opSUBSTR:
6519       {
6520         ffebld start;
6521         ffebld end;
6522         ffebld thing = ffebld_right (expr);
6523         tree start_tree;
6524         tree end_tree;
6525
6526         assert (ffebld_op (thing) == FFEBLD_opITEM);
6527         start = ffebld_head (thing);
6528         thing = ffebld_trail (thing);
6529         assert (ffebld_trail (thing) == NULL);
6530         end = ffebld_head (thing);
6531
6532         length = ffecom_intrinsic_len_ (ffebld_left (expr));
6533
6534         if (length == error_mark_node)
6535           break;
6536
6537         if (start == NULL)
6538           {
6539             if (end == NULL)
6540               ;
6541             else
6542               {
6543                 length = convert (ffecom_f2c_ftnlen_type_node,
6544                                   ffecom_expr (end));
6545               }
6546           }
6547         else
6548           {
6549             start_tree = convert (ffecom_f2c_ftnlen_type_node,
6550                                   ffecom_expr (start));
6551
6552             if (start_tree == error_mark_node)
6553               {
6554                 length = error_mark_node;
6555                 break;
6556               }
6557
6558             if (end == NULL)
6559               {
6560                 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6561                                    ffecom_f2c_ftnlen_one_node,
6562                                    ffecom_2 (MINUS_EXPR,
6563                                              ffecom_f2c_ftnlen_type_node,
6564                                              length,
6565                                              start_tree));
6566               }
6567             else
6568               {
6569                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
6570                                     ffecom_expr (end));
6571
6572                 if (end_tree == error_mark_node)
6573                   {
6574                     length = error_mark_node;
6575                     break;
6576                   }
6577
6578                 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6579                                    ffecom_f2c_ftnlen_one_node,
6580                                    ffecom_2 (MINUS_EXPR,
6581                                              ffecom_f2c_ftnlen_type_node,
6582                                              end_tree, start_tree));
6583               }
6584           }
6585       }
6586       break;
6587
6588     case FFEBLD_opCONCATENATE:
6589       length
6590         = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6591                     ffecom_intrinsic_len_ (ffebld_left (expr)),
6592                     ffecom_intrinsic_len_ (ffebld_right (expr)));
6593       break;
6594
6595     case FFEBLD_opFUNCREF:
6596     case FFEBLD_opCONVERT:
6597       length = build_int_2 (ffebld_size (expr), 0);
6598       TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6599       break;
6600
6601     default:
6602       assert ("bad op for single char arg expr" == NULL);
6603       length = ffecom_f2c_ftnlen_zero_node;
6604       break;
6605     }
6606
6607   assert (length != NULL_TREE);
6608
6609   return length;
6610 }
6611
6612 /* Handle CHARACTER assignments.
6613
6614    Generates code to do the assignment.  Used by ordinary assignment
6615    statement handler ffecom_let_stmt and by statement-function
6616    handler to generate code for a statement function.  */
6617
6618 static void
6619 ffecom_let_char_ (tree dest_tree, tree dest_length,
6620                   ffetargetCharacterSize dest_size, ffebld source)
6621 {
6622   ffecomConcatList_ catlist;
6623   tree source_length;
6624   tree source_tree;
6625   tree expr_tree;
6626
6627   if ((dest_tree == error_mark_node)
6628       || (dest_length == error_mark_node))
6629     return;
6630
6631   assert (dest_tree != NULL_TREE);
6632   assert (dest_length != NULL_TREE);
6633
6634   /* Source might be an opCONVERT, which just means it is a different size
6635      than the destination.  Since the underlying implementation here handles
6636      that (directly or via the s_copy or s_cat run-time-library functions),
6637      we don't need the "convenience" of an opCONVERT that tells us to
6638      truncate or blank-pad, particularly since the resulting implementation
6639      would probably be slower than otherwise. */
6640
6641   while (ffebld_op (source) == FFEBLD_opCONVERT)
6642     source = ffebld_left (source);
6643
6644   catlist = ffecom_concat_list_new_ (source, dest_size);
6645   switch (ffecom_concat_list_count_ (catlist))
6646     {
6647     case 0:                     /* Shouldn't happen, but in case it does... */
6648       ffecom_concat_list_kill_ (catlist);
6649       source_tree = null_pointer_node;
6650       source_length = ffecom_f2c_ftnlen_zero_node;
6651       expr_tree = build_tree_list (NULL_TREE, dest_tree);
6652       TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6653       TREE_CHAIN (TREE_CHAIN (expr_tree))
6654         = build_tree_list (NULL_TREE, dest_length);
6655       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6656         = build_tree_list (NULL_TREE, source_length);
6657
6658       expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6659       TREE_SIDE_EFFECTS (expr_tree) = 1;
6660
6661       expand_expr_stmt (expr_tree);
6662
6663       return;
6664
6665     case 1:                     /* The (fairly) easy case. */
6666       ffecom_char_args_ (&source_tree, &source_length,
6667                          ffecom_concat_list_expr_ (catlist, 0));
6668       ffecom_concat_list_kill_ (catlist);
6669       assert (source_tree != NULL_TREE);
6670       assert (source_length != NULL_TREE);
6671
6672       if ((source_tree == error_mark_node)
6673           || (source_length == error_mark_node))
6674         return;
6675
6676       if (dest_size == 1)
6677         {
6678           dest_tree
6679             = ffecom_1 (INDIRECT_REF,
6680                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6681                                                       (dest_tree))),
6682                         dest_tree);
6683           dest_tree
6684             = ffecom_2 (ARRAY_REF,
6685                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6686                                                       (dest_tree))),
6687                         dest_tree,
6688                         integer_one_node);
6689           source_tree
6690             = ffecom_1 (INDIRECT_REF,
6691                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6692                                                       (source_tree))),
6693                         source_tree);
6694           source_tree
6695             = ffecom_2 (ARRAY_REF,
6696                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6697                                                       (source_tree))),
6698                         source_tree,
6699                         integer_one_node);
6700
6701           expr_tree = ffecom_modify (void_type_node, dest_tree, source_tree);
6702
6703           expand_expr_stmt (expr_tree);
6704
6705           return;
6706         }
6707
6708       expr_tree = build_tree_list (NULL_TREE, dest_tree);
6709       TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6710       TREE_CHAIN (TREE_CHAIN (expr_tree))
6711         = build_tree_list (NULL_TREE, dest_length);
6712       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6713         = build_tree_list (NULL_TREE, source_length);
6714
6715       expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6716       TREE_SIDE_EFFECTS (expr_tree) = 1;
6717
6718       expand_expr_stmt (expr_tree);
6719
6720       return;
6721
6722     default:                    /* Must actually concatenate things. */
6723       break;
6724     }
6725
6726   /* Heavy-duty concatenation. */
6727
6728   {
6729     int count = ffecom_concat_list_count_ (catlist);
6730     int i;
6731     tree lengths;
6732     tree items;
6733     tree length_array;
6734     tree item_array;
6735     tree citem;
6736     tree clength;
6737
6738 #ifdef HOHO
6739     length_array
6740       = lengths
6741       = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
6742                              FFETARGET_charactersizeNONE, count, TRUE);
6743     item_array = items = ffecom_push_tempvar (ffecom_f2c_address_type_node,
6744                                               FFETARGET_charactersizeNONE,
6745                                               count, TRUE);
6746 #else
6747     {
6748       tree hook;
6749
6750       hook = ffebld_nonter_hook (source);
6751       assert (hook);
6752       assert (TREE_CODE (hook) == TREE_VEC);
6753       assert (TREE_VEC_LENGTH (hook) == 2);
6754       length_array = lengths = TREE_VEC_ELT (hook, 0);
6755       item_array = items = TREE_VEC_ELT (hook, 1);
6756     }
6757 #endif
6758
6759     for (i = 0; i < count; ++i)
6760       {
6761         ffecom_char_args_ (&citem, &clength,
6762                            ffecom_concat_list_expr_ (catlist, i));
6763         if ((citem == error_mark_node)
6764             || (clength == error_mark_node))
6765           {
6766             ffecom_concat_list_kill_ (catlist);
6767             return;
6768           }
6769
6770         items
6771           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
6772                       ffecom_modify (void_type_node,
6773                                      ffecom_2 (ARRAY_REF,
6774                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
6775                                                item_array,
6776                                                build_int_2 (i, 0)),
6777                                      citem),
6778                       items);
6779         lengths
6780           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
6781                       ffecom_modify (void_type_node,
6782                                      ffecom_2 (ARRAY_REF,
6783                    TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
6784                                                length_array,
6785                                                build_int_2 (i, 0)),
6786                                      clength),
6787                       lengths);
6788       }
6789
6790     expr_tree = build_tree_list (NULL_TREE, dest_tree);
6791     TREE_CHAIN (expr_tree)
6792       = build_tree_list (NULL_TREE,
6793                          ffecom_1 (ADDR_EXPR,
6794                                    build_pointer_type (TREE_TYPE (items)),
6795                                    items));
6796     TREE_CHAIN (TREE_CHAIN (expr_tree))
6797       = build_tree_list (NULL_TREE,
6798                          ffecom_1 (ADDR_EXPR,
6799                                    build_pointer_type (TREE_TYPE (lengths)),
6800                                    lengths));
6801     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6802       = build_tree_list
6803         (NULL_TREE,
6804          ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
6805                    convert (ffecom_f2c_ftnlen_type_node,
6806                             build_int_2 (count, 0))));
6807     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree))))
6808       = build_tree_list (NULL_TREE, dest_length);
6809
6810     expr_tree = ffecom_call_gfrt (FFECOM_gfrtCAT, expr_tree, NULL_TREE);
6811     TREE_SIDE_EFFECTS (expr_tree) = 1;
6812
6813     expand_expr_stmt (expr_tree);
6814   }
6815
6816   ffecom_concat_list_kill_ (catlist);
6817 }
6818
6819 /* ffecom_make_gfrt_ -- Make initial info for run-time routine
6820
6821    ffecomGfrt ix;
6822    ffecom_make_gfrt_(ix);
6823
6824    Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL
6825    for the indicated run-time routine (ix).  */
6826
6827 static void
6828 ffecom_make_gfrt_ (ffecomGfrt ix)
6829 {
6830   tree t;
6831   tree ttype;
6832
6833   switch (ffecom_gfrt_type_[ix])
6834     {
6835     case FFECOM_rttypeVOID_:
6836       ttype = void_type_node;
6837       break;
6838
6839     case FFECOM_rttypeVOIDSTAR_:
6840       ttype = TREE_TYPE (null_pointer_node);    /* `void *'. */
6841       break;
6842
6843     case FFECOM_rttypeFTNINT_:
6844       ttype = ffecom_f2c_ftnint_type_node;
6845       break;
6846
6847     case FFECOM_rttypeINTEGER_:
6848       ttype = ffecom_f2c_integer_type_node;
6849       break;
6850
6851     case FFECOM_rttypeLONGINT_:
6852       ttype = ffecom_f2c_longint_type_node;
6853       break;
6854
6855     case FFECOM_rttypeLOGICAL_:
6856       ttype = ffecom_f2c_logical_type_node;
6857       break;
6858
6859     case FFECOM_rttypeREAL_F2C_:
6860       ttype = double_type_node;
6861       break;
6862
6863     case FFECOM_rttypeREAL_GNU_:
6864       ttype = float_type_node;
6865       break;
6866
6867     case FFECOM_rttypeCOMPLEX_F2C_:
6868       ttype = void_type_node;
6869       break;
6870
6871     case FFECOM_rttypeCOMPLEX_GNU_:
6872       ttype = ffecom_f2c_complex_type_node;
6873       break;
6874
6875     case FFECOM_rttypeDOUBLE_:
6876       ttype = double_type_node;
6877       break;
6878
6879     case FFECOM_rttypeDOUBLEREAL_:
6880       ttype = ffecom_f2c_doublereal_type_node;
6881       break;
6882
6883     case FFECOM_rttypeDBLCMPLX_F2C_:
6884       ttype = void_type_node;
6885       break;
6886
6887     case FFECOM_rttypeDBLCMPLX_GNU_:
6888       ttype = ffecom_f2c_doublecomplex_type_node;
6889       break;
6890
6891     case FFECOM_rttypeCHARACTER_:
6892       ttype = void_type_node;
6893       break;
6894
6895     default:
6896       ttype = NULL;
6897       assert ("bad rttype" == NULL);
6898       break;
6899     }
6900
6901   ttype = build_function_type (ttype, NULL_TREE);
6902   t = build_decl (FUNCTION_DECL,
6903                   get_identifier (ffecom_gfrt_name_[ix]),
6904                   ttype);
6905   DECL_EXTERNAL (t) = 1;
6906   TREE_READONLY (t) = ffecom_gfrt_const_[ix] ? 1 : 0;
6907   TREE_PUBLIC (t) = 1;
6908   TREE_THIS_VOLATILE (t) = ffecom_gfrt_volatile_[ix] ? 1 : 0;
6909
6910   /* Sanity check:  A function that's const cannot be volatile.  */
6911
6912   assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_volatile_[ix] : 1);
6913
6914   /* Sanity check: A function that's const cannot return complex.  */
6915
6916   assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_complex_[ix] : 1);
6917
6918   t = start_decl (t, TRUE);
6919
6920   finish_decl (t, NULL_TREE, TRUE);
6921
6922   ffecom_gfrt_[ix] = t;
6923 }
6924
6925 /* Phase 1 pass over each member of a COMMON/EQUIVALENCE group.  */
6926
6927 static void
6928 ffecom_member_phase1_ (ffestorag mst UNUSED, ffestorag st)
6929 {
6930   ffesymbol s = ffestorag_symbol (st);
6931
6932   if (ffesymbol_namelisted (s))
6933     ffecom_member_namelisted_ = TRUE;
6934 }
6935
6936 /* Phase 2 pass over each member of a COMMON/EQUIVALENCE group.  Declare
6937    the member so debugger will see it.  Otherwise nobody should be
6938    referencing the member.  */
6939
6940 static void
6941 ffecom_member_phase2_ (ffestorag mst, ffestorag st)
6942 {
6943   ffesymbol s;
6944   tree t;
6945   tree mt;
6946   tree type;
6947
6948   if ((mst == NULL)
6949       || ((mt = ffestorag_hook (mst)) == NULL)
6950       || (mt == error_mark_node))
6951     return;
6952
6953   if ((st == NULL)
6954       || ((s = ffestorag_symbol (st)) == NULL))
6955     return;
6956
6957   type = ffecom_type_localvar_ (s,
6958                                 ffesymbol_basictype (s),
6959                                 ffesymbol_kindtype (s));
6960   if (type == error_mark_node)
6961     return;
6962
6963   t = build_decl (VAR_DECL,
6964                   ffecom_get_identifier_ (ffesymbol_text (s)),
6965                   type);
6966
6967   TREE_STATIC (t) = TREE_STATIC (mt);
6968   DECL_INITIAL (t) = NULL_TREE;
6969   TREE_ASM_WRITTEN (t) = 1;
6970   TREE_USED (t) = 1;
6971
6972   SET_DECL_RTL (t,
6973                 gen_rtx (MEM, TYPE_MODE (type),
6974                          plus_constant (XEXP (DECL_RTL (mt), 0),
6975                                         ffestorag_modulo (mst)
6976                                         + ffestorag_offset (st)
6977                                         - ffestorag_offset (mst))));
6978
6979   t = start_decl (t, FALSE);
6980
6981   finish_decl (t, NULL_TREE, FALSE);
6982 }
6983
6984 /* Prepare source expression for assignment into a destination perhaps known
6985    to be of a specific size.  */
6986
6987 static void
6988 ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size, ffebld source)
6989 {
6990   ffecomConcatList_ catlist;
6991   int count;
6992   int i;
6993   tree ltmp;
6994   tree itmp;
6995   tree tempvar = NULL_TREE;
6996
6997   while (ffebld_op (source) == FFEBLD_opCONVERT)
6998     source = ffebld_left (source);
6999
7000   catlist = ffecom_concat_list_new_ (source, dest_size);
7001   count = ffecom_concat_list_count_ (catlist);
7002
7003   if (count >= 2)
7004     {
7005       ltmp
7006         = ffecom_make_tempvar ("let_char_len", ffecom_f2c_ftnlen_type_node,
7007                                FFETARGET_charactersizeNONE, count);
7008       itmp
7009         = ffecom_make_tempvar ("let_char_item", ffecom_f2c_address_type_node,
7010                                FFETARGET_charactersizeNONE, count);
7011
7012       tempvar = make_tree_vec (2);
7013       TREE_VEC_ELT (tempvar, 0) = ltmp;
7014       TREE_VEC_ELT (tempvar, 1) = itmp;
7015     }
7016
7017   for (i = 0; i < count; ++i)
7018     ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist, i));
7019
7020   ffecom_concat_list_kill_ (catlist);
7021
7022   if (tempvar)
7023     {
7024       ffebld_nonter_set_hook (source, tempvar);
7025       current_binding_level->prep_state = 1;
7026     }
7027 }
7028
7029 /* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order
7030
7031    Ignores STAR (alternate-return) dummies.  All other get exec-transitioned
7032    (which generates their trees) and then their trees get push_parm_decl'd.
7033
7034    The second arg is TRUE if the dummies are for a statement function, in
7035    which case lengths are not pushed for character arguments (since they are
7036    always known by both the caller and the callee, though the code allows
7037    for someday permitting CHAR*(*) stmtfunc dummies).  */
7038
7039 static void
7040 ffecom_push_dummy_decls_ (ffebld dummy_list, bool stmtfunc)
7041 {
7042   ffebld dummy;
7043   ffebld dumlist;
7044   ffesymbol s;
7045   tree parm;
7046
7047   ffecom_transform_only_dummies_ = TRUE;
7048
7049   /* First push the parms corresponding to actual dummy "contents".  */
7050
7051   for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7052     {
7053       dummy = ffebld_head (dumlist);
7054       switch (ffebld_op (dummy))
7055         {
7056         case FFEBLD_opSTAR:
7057         case FFEBLD_opANY:
7058           continue;             /* Forget alternate returns. */
7059
7060         default:
7061           break;
7062         }
7063       assert (ffebld_op (dummy) == FFEBLD_opSYMTER);
7064       s = ffebld_symter (dummy);
7065       parm = ffesymbol_hook (s).decl_tree;
7066       if (parm == NULL_TREE)
7067         {
7068           s = ffecom_sym_transform_ (s);
7069           parm = ffesymbol_hook (s).decl_tree;
7070           assert (parm != NULL_TREE);
7071         }
7072       if (parm != error_mark_node)
7073         push_parm_decl (parm);
7074     }
7075
7076   /* Then, for CHARACTER dummies, push the parms giving their lengths.  */
7077
7078   for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7079     {
7080       dummy = ffebld_head (dumlist);
7081       switch (ffebld_op (dummy))
7082         {
7083         case FFEBLD_opSTAR:
7084         case FFEBLD_opANY:
7085           continue;             /* Forget alternate returns, they mean
7086                                    NOTHING! */
7087
7088         default:
7089           break;
7090         }
7091       s = ffebld_symter (dummy);
7092       if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
7093         continue;               /* Only looking for CHARACTER arguments. */
7094       if (stmtfunc && (ffesymbol_size (s) != FFETARGET_charactersizeNONE))
7095         continue;               /* Stmtfunc arg with known size needs no
7096                                    length param. */
7097       if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
7098         continue;               /* Only looking for variables and arrays. */
7099       parm = ffesymbol_hook (s).length_tree;
7100       assert (parm != NULL_TREE);
7101       if (parm != error_mark_node)
7102         push_parm_decl (parm);
7103     }
7104
7105   ffecom_transform_only_dummies_ = FALSE;
7106 }
7107
7108 /* ffecom_start_progunit_ -- Beginning of program unit
7109
7110    Does GNU back end stuff necessary to teach it about the start of its
7111    equivalent of a Fortran program unit.  */
7112
7113 static void
7114 ffecom_start_progunit_ ()
7115 {
7116   ffesymbol fn = ffecom_primary_entry_;
7117   ffebld arglist;
7118   tree id;                      /* Identifier (name) of function. */
7119   tree type;                    /* Type of function. */
7120   tree result;                  /* Result of function. */
7121   ffeinfoBasictype bt;
7122   ffeinfoKindtype kt;
7123   ffeglobal g;
7124   ffeglobalType gt;
7125   ffeglobalType egt = FFEGLOBAL_type;
7126   bool charfunc;
7127   bool cmplxfunc;
7128   bool altentries = (ffecom_num_entrypoints_ != 0);
7129   bool multi
7130   = altentries
7131   && (ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
7132   && (ffecom_master_bt_ == FFEINFO_basictypeNONE);
7133   bool main_program = FALSE;
7134   int old_lineno = lineno;
7135   const char *old_input_filename = input_filename;
7136
7137   assert (fn != NULL);
7138   assert (ffesymbol_hook (fn).decl_tree == NULL_TREE);
7139
7140   input_filename = ffesymbol_where_filename (fn);
7141   lineno = ffesymbol_where_filelinenum (fn);
7142
7143   switch (ffecom_primary_entry_kind_)
7144     {
7145     case FFEINFO_kindPROGRAM:
7146       main_program = TRUE;
7147       gt = FFEGLOBAL_typeMAIN;
7148       bt = FFEINFO_basictypeNONE;
7149       kt = FFEINFO_kindtypeNONE;
7150       type = ffecom_tree_fun_type_void;
7151       charfunc = FALSE;
7152       cmplxfunc = FALSE;
7153       break;
7154
7155     case FFEINFO_kindBLOCKDATA:
7156       gt = FFEGLOBAL_typeBDATA;
7157       bt = FFEINFO_basictypeNONE;
7158       kt = FFEINFO_kindtypeNONE;
7159       type = ffecom_tree_fun_type_void;
7160       charfunc = FALSE;
7161       cmplxfunc = FALSE;
7162       break;
7163
7164     case FFEINFO_kindFUNCTION:
7165       gt = FFEGLOBAL_typeFUNC;
7166       egt = FFEGLOBAL_typeEXT;
7167       bt = ffesymbol_basictype (fn);
7168       kt = ffesymbol_kindtype (fn);
7169       if (bt == FFEINFO_basictypeNONE)
7170         {
7171           ffeimplic_establish_symbol (fn);
7172           if (ffesymbol_funcresult (fn) != NULL)
7173             ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
7174           bt = ffesymbol_basictype (fn);
7175           kt = ffesymbol_kindtype (fn);
7176         }
7177
7178       if (multi)
7179         charfunc = cmplxfunc = FALSE;
7180       else if (bt == FFEINFO_basictypeCHARACTER)
7181         charfunc = TRUE, cmplxfunc = FALSE;
7182       else if ((bt == FFEINFO_basictypeCOMPLEX)
7183                && ffesymbol_is_f2c (fn)
7184                && !altentries)
7185         charfunc = FALSE, cmplxfunc = TRUE;
7186       else
7187         charfunc = cmplxfunc = FALSE;
7188
7189       if (multi || charfunc)
7190         type = ffecom_tree_fun_type_void;
7191       else if (ffesymbol_is_f2c (fn) && !altentries)
7192         type = ffecom_tree_fun_type[bt][kt];
7193       else
7194         type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
7195
7196       if ((type == NULL_TREE)
7197           || (TREE_TYPE (type) == NULL_TREE))
7198         type = ffecom_tree_fun_type_void;       /* _sym_exec_transition. */
7199       break;
7200
7201     case FFEINFO_kindSUBROUTINE:
7202       gt = FFEGLOBAL_typeSUBR;
7203       egt = FFEGLOBAL_typeEXT;
7204       bt = FFEINFO_basictypeNONE;
7205       kt = FFEINFO_kindtypeNONE;
7206       if (ffecom_is_altreturning_)
7207         type = ffecom_tree_subr_type;
7208       else
7209         type = ffecom_tree_fun_type_void;
7210       charfunc = FALSE;
7211       cmplxfunc = FALSE;
7212       break;
7213
7214     default:
7215       assert ("say what??" == NULL);
7216       /* Fall through. */
7217     case FFEINFO_kindANY:
7218       gt = FFEGLOBAL_typeANY;
7219       bt = FFEINFO_basictypeNONE;
7220       kt = FFEINFO_kindtypeNONE;
7221       type = error_mark_node;
7222       charfunc = FALSE;
7223       cmplxfunc = FALSE;
7224       break;
7225     }
7226
7227   if (altentries)
7228     {
7229       id = ffecom_get_invented_identifier ("__g77_masterfun_%s",
7230                                            ffesymbol_text (fn));
7231     }
7232 #if FFETARGET_isENFORCED_MAIN
7233   else if (main_program)
7234     id = get_identifier (FFETARGET_nameENFORCED_MAIN_NAME);
7235 #endif
7236   else
7237     id = ffecom_get_external_identifier_ (fn);
7238
7239   start_function (id,
7240                   type,
7241                   0,            /* nested/inline */
7242                   !altentries); /* TREE_PUBLIC */
7243
7244   TREE_USED (current_function_decl) = 1;        /* Avoid spurious warning if altentries. */
7245
7246   if (!altentries
7247       && ((g = ffesymbol_global (fn)) != NULL)
7248       && ((ffeglobal_type (g) == gt)
7249           || (ffeglobal_type (g) == egt)))
7250     {
7251       ffeglobal_set_hook (g, current_function_decl);
7252     }
7253
7254   /* Arg handling needs exec-transitioned ffesymbols to work with.  But
7255      exec-transitioning needs current_function_decl to be filled in.  So we
7256      do these things in two phases. */
7257
7258   if (altentries)
7259     {                           /* 1st arg identifies which entrypoint. */
7260       ffecom_which_entrypoint_decl_
7261         = build_decl (PARM_DECL,
7262                       ffecom_get_invented_identifier ("__g77_%s",
7263                                                       "which_entrypoint"),
7264                       integer_type_node);
7265       push_parm_decl (ffecom_which_entrypoint_decl_);
7266     }
7267
7268   if (charfunc
7269       || cmplxfunc
7270       || multi)
7271     {                           /* Arg for result (return value). */
7272       tree type;
7273       tree length;
7274
7275       if (charfunc)
7276         type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
7277       else if (cmplxfunc)
7278         type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
7279       else
7280         type = ffecom_multi_type_node_;
7281
7282       result = ffecom_get_invented_identifier ("__g77_%s", "result");
7283
7284       /* Make length arg _and_ enhance type info for CHAR arg itself.  */
7285
7286       if (charfunc)
7287         length = ffecom_char_enhance_arg_ (&type, fn);
7288       else
7289         length = NULL_TREE;     /* Not ref'd if !charfunc. */
7290
7291       type = build_pointer_type (type);
7292       result = build_decl (PARM_DECL, result, type);
7293
7294       push_parm_decl (result);
7295       if (multi)
7296         ffecom_multi_retval_ = result;
7297       else
7298         ffecom_func_result_ = result;
7299
7300       if (charfunc)
7301         {
7302           push_parm_decl (length);
7303           ffecom_func_length_ = length;
7304         }
7305     }
7306
7307   if (ffecom_primary_entry_is_proc_)
7308     {
7309       if (altentries)
7310         arglist = ffecom_master_arglist_;
7311       else
7312         arglist = ffesymbol_dummyargs (fn);
7313       ffecom_push_dummy_decls_ (arglist, FALSE);
7314     }
7315
7316   if (TREE_CODE (current_function_decl) != ERROR_MARK)
7317     store_parm_decls (main_program ? 1 : 0);
7318
7319   ffecom_start_compstmt ();
7320   /* Disallow temp vars at this level.  */
7321   current_binding_level->prep_state = 2;
7322
7323   lineno = old_lineno;
7324   input_filename = old_input_filename;
7325
7326   /* This handles any symbols still untransformed, in case -g specified.
7327      This used to be done in ffecom_finish_progunit, but it turns out to
7328      be necessary to do it here so that statement functions are
7329      expanded before code.  But don't bother for BLOCK DATA.  */
7330
7331   if (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
7332     ffesymbol_drive (ffecom_finish_symbol_transform_);
7333 }
7334
7335 /* ffecom_sym_transform_ -- Transform FFE sym into backend sym
7336
7337    ffesymbol s;
7338    ffecom_sym_transform_(s);
7339
7340    The ffesymbol_hook info for s is updated with appropriate backend info
7341    on the symbol.  */
7342
7343 static ffesymbol
7344 ffecom_sym_transform_ (ffesymbol s)
7345 {
7346   tree t;                       /* Transformed thingy. */
7347   tree tlen;                    /* Length if CHAR*(*). */
7348   bool addr;                    /* Is t the address of the thingy? */
7349   ffeinfoBasictype bt;
7350   ffeinfoKindtype kt;
7351   ffeglobal g;
7352   int old_lineno = lineno;
7353   const char *old_input_filename = input_filename;
7354
7355   /* Must ensure special ASSIGN variables are declared at top of outermost
7356      block, else they'll end up in the innermost block when their first
7357      ASSIGN is seen, which leaves them out of scope when they're the
7358      subject of a GOTO or I/O statement.
7359
7360      We make this variable even if -fugly-assign.  Just let it go unused,
7361      in case it turns out there are cases where we really want to use this
7362      variable anyway (e.g. ASSIGN to INTEGER*2 variable).  */
7363
7364   if (! ffecom_transform_only_dummies_
7365       && ffesymbol_assigned (s)
7366       && ! ffesymbol_hook (s).assign_tree)
7367     s = ffecom_sym_transform_assign_ (s);
7368
7369   if (ffesymbol_sfdummyparent (s) == NULL)
7370     {
7371       input_filename = ffesymbol_where_filename (s);
7372       lineno = ffesymbol_where_filelinenum (s);
7373     }
7374   else
7375     {
7376       ffesymbol sf = ffesymbol_sfdummyparent (s);
7377
7378       input_filename = ffesymbol_where_filename (sf);
7379       lineno = ffesymbol_where_filelinenum (sf);
7380     }
7381
7382   bt = ffeinfo_basictype (ffebld_info (s));
7383   kt = ffeinfo_kindtype (ffebld_info (s));
7384
7385   t = NULL_TREE;
7386   tlen = NULL_TREE;
7387   addr = FALSE;
7388
7389   switch (ffesymbol_kind (s))
7390     {
7391     case FFEINFO_kindNONE:
7392       switch (ffesymbol_where (s))
7393         {
7394         case FFEINFO_whereDUMMY:        /* Subroutine or function. */
7395           assert (ffecom_transform_only_dummies_);
7396
7397           /* Before 0.4, this could be ENTITY/DUMMY, but see
7398              ffestu_sym_end_transition -- no longer true (in particular, if
7399              it could be an ENTITY, it _will_ be made one, so that
7400              possibility won't come through here).  So we never make length
7401              arg for CHARACTER type.  */
7402
7403           t = build_decl (PARM_DECL,
7404                           ffecom_get_identifier_ (ffesymbol_text (s)),
7405                           ffecom_tree_ptr_to_subr_type);
7406           DECL_ARTIFICIAL (t) = 1;
7407           addr = TRUE;
7408           break;
7409
7410         case FFEINFO_whereGLOBAL:       /* Subroutine or function. */
7411           assert (!ffecom_transform_only_dummies_);
7412
7413           if (((g = ffesymbol_global (s)) != NULL)
7414               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7415                   || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7416                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
7417               && (ffeglobal_hook (g) != NULL_TREE)
7418               && ffe_is_globals ())
7419             {
7420               t = ffeglobal_hook (g);
7421               break;
7422             }
7423
7424           t = build_decl (FUNCTION_DECL,
7425                           ffecom_get_external_identifier_ (s),
7426                           ffecom_tree_subr_type);       /* Assume subr. */
7427           DECL_EXTERNAL (t) = 1;
7428           TREE_PUBLIC (t) = 1;
7429
7430           t = start_decl (t, FALSE);
7431           finish_decl (t, NULL_TREE, FALSE);
7432
7433           if ((g != NULL)
7434               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7435                   || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7436                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
7437             ffeglobal_set_hook (g, t);
7438
7439           ffecom_save_tree_forever (t);
7440
7441           break;
7442
7443         default:
7444           assert ("NONE where unexpected" == NULL);
7445           /* Fall through. */
7446         case FFEINFO_whereANY:
7447           break;
7448         }
7449       break;
7450
7451     case FFEINFO_kindENTITY:
7452       switch (ffeinfo_where (ffesymbol_info (s)))
7453         {
7454
7455         case FFEINFO_whereCONSTANT:
7456           /* ~~Debugging info needed? */
7457           assert (!ffecom_transform_only_dummies_);
7458           t = error_mark_node;  /* Shouldn't ever see this in expr. */
7459           break;
7460
7461         case FFEINFO_whereLOCAL:
7462           assert (!ffecom_transform_only_dummies_);
7463
7464           {
7465             ffestorag st = ffesymbol_storage (s);
7466             tree type;
7467
7468             if ((st != NULL)
7469                 && (ffestorag_size (st) == 0))
7470               {
7471                 t = error_mark_node;
7472                 break;
7473               }
7474
7475             type = ffecom_type_localvar_ (s, bt, kt);
7476
7477             if (type == error_mark_node)
7478               {
7479                 t = error_mark_node;
7480                 break;
7481               }
7482
7483             if ((st != NULL)
7484                 && (ffestorag_parent (st) != NULL))
7485               {                 /* Child of EQUIVALENCE parent. */
7486                 ffestorag est;
7487                 tree et;
7488                 ffetargetOffset offset;
7489
7490                 est = ffestorag_parent (st);
7491                 ffecom_transform_equiv_ (est);
7492
7493                 et = ffestorag_hook (est);
7494                 assert (et != NULL_TREE);
7495
7496                 if (! TREE_STATIC (et))
7497                   put_var_into_stack (et);
7498
7499                 offset = ffestorag_modulo (est)
7500                   + ffestorag_offset (ffesymbol_storage (s))
7501                   - ffestorag_offset (est);
7502
7503                 ffecom_debug_kludge_ (et, "EQUIVALENCE", s, type, offset);
7504
7505                 /* (t_type *) (((char *) &et) + offset) */
7506
7507                 t = convert (string_type_node,  /* (char *) */
7508                              ffecom_1 (ADDR_EXPR,
7509                                        build_pointer_type (TREE_TYPE (et)),
7510                                        et));
7511                 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
7512                               t,
7513                               build_int_2 (offset, 0));
7514                 t = convert (build_pointer_type (type),
7515                              t);
7516                 TREE_CONSTANT (t) = staticp (et);
7517
7518                 addr = TRUE;
7519               }
7520             else
7521               {
7522                 tree initexpr;
7523                 bool init = ffesymbol_is_init (s);
7524
7525                 t = build_decl (VAR_DECL,
7526                                 ffecom_get_identifier_ (ffesymbol_text (s)),
7527                                 type);
7528
7529                 if (init
7530                     || ffesymbol_namelisted (s)
7531 #ifdef FFECOM_sizeMAXSTACKITEM
7532                     || ((st != NULL)
7533                         && (ffestorag_size (st) > FFECOM_sizeMAXSTACKITEM))
7534 #endif
7535                     || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
7536                         && (ffecom_primary_entry_kind_
7537                             != FFEINFO_kindBLOCKDATA)
7538                         && (ffesymbol_is_save (s) || ffe_is_saveall ())))
7539                   TREE_STATIC (t) = !ffesymbol_attr (s, FFESYMBOL_attrADJUSTABLE);
7540                 else
7541                   TREE_STATIC (t) = 0;  /* No need to make static. */
7542
7543                 if (init || ffe_is_init_local_zero ())
7544                   DECL_INITIAL (t) = error_mark_node;
7545
7546                 /* Keep -Wunused from complaining about var if it
7547                    is used as sfunc arg or DATA implied-DO.  */
7548                 if (ffesymbol_attrs (s) & FFESYMBOL_attrsSFARG)
7549                   DECL_IN_SYSTEM_HEADER (t) = 1;
7550
7551                 t = start_decl (t, FALSE);
7552
7553                 if (init)
7554                   {
7555                     if (ffesymbol_init (s) != NULL)
7556                       initexpr = ffecom_expr (ffesymbol_init (s));
7557                     else
7558                       initexpr = ffecom_init_zero_ (t);
7559                   }
7560                 else if (ffe_is_init_local_zero ())
7561                   initexpr = ffecom_init_zero_ (t);
7562                 else
7563                   initexpr = NULL_TREE; /* Not ref'd if !init. */
7564
7565                 finish_decl (t, initexpr, FALSE);
7566
7567                 if (st != NULL && DECL_SIZE (t) != error_mark_node)
7568                   {
7569                     assert (TREE_CODE (DECL_SIZE_UNIT (t)) == INTEGER_CST);
7570                     assert (0 == compare_tree_int (DECL_SIZE_UNIT (t),
7571                                                    ffestorag_size (st)));
7572                   }
7573               }
7574           }
7575           break;
7576
7577         case FFEINFO_whereRESULT:
7578           assert (!ffecom_transform_only_dummies_);
7579
7580           if (bt == FFEINFO_basictypeCHARACTER)
7581             {                   /* Result is already in list of dummies, use
7582                                    it (& length). */
7583               t = ffecom_func_result_;
7584               tlen = ffecom_func_length_;
7585               addr = TRUE;
7586               break;
7587             }
7588           if ((ffecom_num_entrypoints_ == 0)
7589               && (bt == FFEINFO_basictypeCOMPLEX)
7590               && (ffesymbol_is_f2c (ffecom_primary_entry_)))
7591             {                   /* Result is already in list of dummies, use
7592                                    it. */
7593               t = ffecom_func_result_;
7594               addr = TRUE;
7595               break;
7596             }
7597           if (ffecom_func_result_ != NULL_TREE)
7598             {
7599               t = ffecom_func_result_;
7600               break;
7601             }
7602           if ((ffecom_num_entrypoints_ != 0)
7603               && (ffecom_master_bt_ == FFEINFO_basictypeNONE))
7604             {
7605               assert (ffecom_multi_retval_ != NULL_TREE);
7606               t = ffecom_1 (INDIRECT_REF, ffecom_multi_type_node_,
7607                             ffecom_multi_retval_);
7608               t = ffecom_2 (COMPONENT_REF, ffecom_tree_type[bt][kt],
7609                             t, ffecom_multi_fields_[bt][kt]);
7610
7611               break;
7612             }
7613
7614           t = build_decl (VAR_DECL,
7615                           ffecom_get_identifier_ (ffesymbol_text (s)),
7616                           ffecom_tree_type[bt][kt]);
7617           TREE_STATIC (t) = 0;  /* Put result on stack. */
7618           t = start_decl (t, FALSE);
7619           finish_decl (t, NULL_TREE, FALSE);
7620
7621           ffecom_func_result_ = t;
7622
7623           break;
7624
7625         case FFEINFO_whereDUMMY:
7626           {
7627             tree type;
7628             ffebld dl;
7629             ffebld dim;
7630             tree low;
7631             tree high;
7632             tree old_sizes;
7633             bool adjustable = FALSE;    /* Conditionally adjustable? */
7634
7635             type = ffecom_tree_type[bt][kt];
7636             if (ffesymbol_sfdummyparent (s) != NULL)
7637               {
7638                 if (current_function_decl == ffecom_outer_function_decl_)
7639                   {                     /* Exec transition before sfunc
7640                                            context; get it later. */
7641                     break;
7642                   }
7643                 t = ffecom_get_identifier_ (ffesymbol_text
7644                                             (ffesymbol_sfdummyparent (s)));
7645               }
7646             else
7647               t = ffecom_get_identifier_ (ffesymbol_text (s));
7648
7649             assert (ffecom_transform_only_dummies_);
7650
7651             old_sizes = get_pending_sizes ();
7652             put_pending_sizes (old_sizes);
7653
7654             if (bt == FFEINFO_basictypeCHARACTER)
7655               tlen = ffecom_char_enhance_arg_ (&type, s);
7656             type = ffecom_check_size_overflow_ (s, type, TRUE);
7657
7658             for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
7659               {
7660                 if (type == error_mark_node)
7661                   break;
7662
7663                 dim = ffebld_head (dl);
7664                 assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
7665                 if ((ffebld_left (dim) == NULL) || ffecom_doing_entry_)
7666                   low = ffecom_integer_one_node;
7667                 else
7668                   low = ffecom_expr (ffebld_left (dim));
7669                 assert (ffebld_right (dim) != NULL);
7670                 if ((ffebld_op (ffebld_right (dim)) == FFEBLD_opSTAR)
7671                     || ffecom_doing_entry_)
7672                   {
7673                     /* Used to just do high=low.  But for ffecom_tree_
7674                        canonize_ref_, it probably is important to correctly
7675                        assess the size.  E.g. given COMPLEX C(*),CFUNC and
7676                        C(2)=CFUNC(C), overlap can happen, while it can't
7677                        for, say, C(1)=CFUNC(C(2)).  */
7678                     /* Even more recently used to set to INT_MAX, but that
7679                        broke when some overflow checking went into the back
7680                        end.  Now we just leave the upper bound unspecified.  */
7681                     high = NULL;
7682                   }
7683                 else
7684                   high = ffecom_expr (ffebld_right (dim));
7685
7686                 /* Determine whether array is conditionally adjustable,
7687                    to decide whether back-end magic is needed.
7688
7689                    Normally the front end uses the back-end function
7690                    variable_size to wrap SAVE_EXPR's around expressions
7691                    affecting the size/shape of an array so that the
7692                    size/shape info doesn't change during execution
7693                    of the compiled code even though variables and
7694                    functions referenced in those expressions might.
7695
7696                    variable_size also makes sure those saved expressions
7697                    get evaluated immediately upon entry to the
7698                    compiled procedure -- the front end normally doesn't
7699                    have to worry about that.
7700
7701                    However, there is a problem with this that affects
7702                    g77's implementation of entry points, and that is
7703                    that it is _not_ true that each invocation of the
7704                    compiled procedure is permitted to evaluate
7705                    array size/shape info -- because it is possible
7706                    that, for some invocations, that info is invalid (in
7707                    which case it is "promised" -- i.e. a violation of
7708                    the Fortran standard -- that the compiled code
7709                    won't reference the array or its size/shape
7710                    during that particular invocation).
7711
7712                    To phrase this in C terms, consider this gcc function:
7713
7714                      void foo (int *n, float (*a)[*n])
7715                      {
7716                        // a is "pointer to array ...", fyi.
7717                      }
7718
7719                    Suppose that, for some invocations, it is permitted
7720                    for a caller of foo to do this:
7721
7722                        foo (NULL, NULL);
7723
7724                    Now the _written_ code for foo can take such a call
7725                    into account by either testing explicitly for whether
7726                    (a == NULL) || (n == NULL) -- presumably it is
7727                    not permitted to reference *a in various fashions
7728                    if (n == NULL) I suppose -- or it can avoid it by
7729                    looking at other info (other arguments, static/global
7730                    data, etc.).
7731
7732                    However, this won't work in gcc 2.5.8 because it'll
7733                    automatically emit the code to save the "*n"
7734                    expression, which'll yield a NULL dereference for
7735                    the "foo (NULL, NULL)" call, something the code
7736                    for foo cannot prevent.
7737
7738                    g77 definitely needs to avoid executing such
7739                    code anytime the pointer to the adjustable array
7740                    is NULL, because even if its bounds expressions
7741                    don't have any references to possible "absent"
7742                    variables like "*n" -- say all variable references
7743                    are to COMMON variables, i.e. global (though in C,
7744                    local static could actually make sense) -- the
7745                    expressions could yield other run-time problems
7746                    for allowably "dead" values in those variables.
7747
7748                    For example, let's consider a more complicated
7749                    version of foo:
7750
7751                      extern int i;
7752                      extern int j;
7753
7754                      void foo (float (*a)[i/j])
7755                      {
7756                        ...
7757                      }
7758
7759                    The above is (essentially) quite valid for Fortran
7760                    but, again, for a call like "foo (NULL);", it is
7761                    permitted for i and j to be undefined when the
7762                    call is made.  If j happened to be zero, for
7763                    example, emitting the code to evaluate "i/j"
7764                    could result in a run-time error.
7765
7766                    Offhand, though I don't have my F77 or F90
7767                    standards handy, it might even be valid for a
7768                    bounds expression to contain a function reference,
7769                    in which case I doubt it is permitted for an
7770                    implementation to invoke that function in the
7771                    Fortran case involved here (invocation of an
7772                    alternate ENTRY point that doesn't have the adjustable
7773                    array as one of its arguments).
7774
7775                    So, the code that the compiler would normally emit
7776                    to preevaluate the size/shape info for an
7777                    adjustable array _must not_ be executed at run time
7778                    in certain cases.  Specifically, for Fortran,
7779                    the case is when the pointer to the adjustable
7780                    array == NULL.  (For gnu-ish C, it might be nice
7781                    for the source code itself to specify an expression
7782                    that, if TRUE, inhibits execution of the code.  Or
7783                    reverse the sense for elegance.)
7784
7785                    (Note that g77 could use a different test than NULL,
7786                    actually, since it happens to always pass an
7787                    integer to the called function that specifies which
7788                    entry point is being invoked.  Hmm, this might
7789                    solve the next problem.)
7790
7791                    One way a user could, I suppose, write "foo" so
7792                    it works is to insert COND_EXPR's for the
7793                    size/shape info so the dangerous stuff isn't
7794                    actually done, as in:
7795
7796                      void foo (int *n, float (*a)[(a == NULL) ? 0 : *n])
7797                      {
7798                        ...
7799                      }
7800
7801                    The next problem is that the front end needs to
7802                    be able to tell the back end about the array's
7803                    decl _before_ it tells it about the conditional
7804                    expression to inhibit evaluation of size/shape info,
7805                    as shown above.
7806
7807                    To solve this, the front end needs to be able
7808                    to give the back end the expression to inhibit
7809                    generation of the preevaluation code _after_
7810                    it makes the decl for the adjustable array.
7811
7812                    Until then, the above example using the COND_EXPR
7813                    doesn't pass muster with gcc because the "(a == NULL)"
7814                    part has a reference to "a", which is still
7815                    undefined at that point.
7816
7817                    g77 will therefore use a different mechanism in the
7818                    meantime.  */
7819
7820                 if (!adjustable
7821                     && ((TREE_CODE (low) != INTEGER_CST)
7822                         || (high && TREE_CODE (high) != INTEGER_CST)))
7823                   adjustable = TRUE;
7824
7825 #if 0                           /* Old approach -- see below. */
7826                 if (TREE_CODE (low) != INTEGER_CST)
7827                   low = ffecom_3 (COND_EXPR, integer_type_node,
7828                                   ffecom_adjarray_passed_ (s),
7829                                   low,
7830                                   ffecom_integer_zero_node);
7831
7832                 if (high && TREE_CODE (high) != INTEGER_CST)
7833                   high = ffecom_3 (COND_EXPR, integer_type_node,
7834                                    ffecom_adjarray_passed_ (s),
7835                                    high,
7836                                    ffecom_integer_zero_node);
7837 #endif
7838
7839                 /* ~~~gcc/stor-layout.c (layout_type) should do this,
7840                    probably.  Fixes 950302-1.f.  */
7841
7842                 if (TREE_CODE (low) != INTEGER_CST)
7843                   low = variable_size (low);
7844
7845                 /* ~~~Similarly, this fixes dumb0.f.  The C front end
7846                    does this, which is why dumb0.c would work.  */
7847
7848                 if (high && TREE_CODE (high) != INTEGER_CST)
7849                   high = variable_size (high);
7850
7851                 type
7852                   = build_array_type
7853                     (type,
7854                      build_range_type (ffecom_integer_type_node,
7855                                        low, high));
7856                 type = ffecom_check_size_overflow_ (s, type, TRUE);
7857               }
7858
7859             if (type == error_mark_node)
7860               {
7861                 t = error_mark_node;
7862                 break;
7863               }
7864
7865             if ((ffesymbol_sfdummyparent (s) == NULL)
7866                  || (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER))
7867               {
7868                 type = build_pointer_type (type);
7869                 addr = TRUE;
7870               }
7871
7872             t = build_decl (PARM_DECL, t, type);
7873             DECL_ARTIFICIAL (t) = 1;
7874
7875             /* If this arg is present in every entry point's list of
7876                dummy args, then we're done.  */
7877
7878             if (ffesymbol_numentries (s)
7879                 == (ffecom_num_entrypoints_ + 1))
7880               break;
7881
7882 #if 1
7883
7884             /* If variable_size in stor-layout has been called during
7885                the above, then get_pending_sizes should have the
7886                yet-to-be-evaluated saved expressions pending.
7887                Make the whole lot of them get emitted, conditionally
7888                on whether the array decl ("t" above) is not NULL.  */
7889
7890             {
7891               tree sizes = get_pending_sizes ();
7892               tree tem;
7893
7894               for (tem = sizes;
7895                    tem != old_sizes;
7896                    tem = TREE_CHAIN (tem))
7897                 {
7898                   tree temv = TREE_VALUE (tem);
7899
7900                   if (sizes == tem)
7901                     sizes = temv;
7902                   else
7903                     sizes
7904                       = ffecom_2 (COMPOUND_EXPR,
7905                                   TREE_TYPE (sizes),
7906                                   temv,
7907                                   sizes);
7908                 }
7909
7910               if (sizes != tem)
7911                 {
7912                   sizes
7913                     = ffecom_3 (COND_EXPR,
7914                                 TREE_TYPE (sizes),
7915                                 ffecom_2 (NE_EXPR,
7916                                           integer_type_node,
7917                                           t,
7918                                           null_pointer_node),
7919                                 sizes,
7920                                 convert (TREE_TYPE (sizes),
7921                                          integer_zero_node));
7922                   sizes = ffecom_save_tree (sizes);
7923
7924                   sizes
7925                     = tree_cons (NULL_TREE, sizes, tem);
7926                 }
7927
7928               if (sizes)
7929                 put_pending_sizes (sizes);
7930             }
7931
7932 #else
7933 #if 0
7934             if (adjustable
7935                 && (ffesymbol_numentries (s)
7936                     != ffecom_num_entrypoints_ + 1))
7937               DECL_SOMETHING (t)
7938                 = ffecom_2 (NE_EXPR, integer_type_node,
7939                             t,
7940                             null_pointer_node);
7941 #else
7942 #if 0
7943             if (adjustable
7944                 && (ffesymbol_numentries (s)
7945                     != ffecom_num_entrypoints_ + 1))
7946               {
7947                 ffebad_start (FFEBAD_MISSING_ADJARRAY_UNSUPPORTED);
7948                 ffebad_here (0, ffesymbol_where_line (s),
7949                              ffesymbol_where_column (s));
7950                 ffebad_string (ffesymbol_text (s));
7951                 ffebad_finish ();
7952               }
7953 #endif
7954 #endif
7955 #endif
7956           }
7957           break;
7958
7959         case FFEINFO_whereCOMMON:
7960           {
7961             ffesymbol cs;
7962             ffeglobal cg;
7963             tree ct;
7964             ffestorag st = ffesymbol_storage (s);
7965             tree type;
7966
7967             cs = ffesymbol_common (s);  /* The COMMON area itself.  */
7968             if (st != NULL)     /* Else not laid out. */
7969               {
7970                 ffecom_transform_common_ (cs);
7971                 st = ffesymbol_storage (s);
7972               }
7973
7974             type = ffecom_type_localvar_ (s, bt, kt);
7975
7976             cg = ffesymbol_global (cs); /* The global COMMON info.  */
7977             if ((cg == NULL)
7978                 || (ffeglobal_type (cg) != FFEGLOBAL_typeCOMMON))
7979               ct = NULL_TREE;
7980             else
7981               ct = ffeglobal_hook (cg); /* The common area's tree.  */
7982
7983             if ((ct == NULL_TREE)
7984                 || (st == NULL)
7985                 || (type == error_mark_node))
7986               t = error_mark_node;
7987             else
7988               {
7989                 ffetargetOffset offset;
7990                 ffestorag cst;
7991
7992                 cst = ffestorag_parent (st);
7993                 assert (cst == ffesymbol_storage (cs));
7994
7995                 offset = ffestorag_modulo (cst)
7996                   + ffestorag_offset (st)
7997                   - ffestorag_offset (cst);
7998
7999                 ffecom_debug_kludge_ (ct, "COMMON", s, type, offset);
8000
8001                 /* (t_type *) (((char *) &ct) + offset) */
8002
8003                 t = convert (string_type_node,  /* (char *) */
8004                              ffecom_1 (ADDR_EXPR,
8005                                        build_pointer_type (TREE_TYPE (ct)),
8006                                        ct));
8007                 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
8008                               t,
8009                               build_int_2 (offset, 0));
8010                 t = convert (build_pointer_type (type),
8011                              t);
8012                 TREE_CONSTANT (t) = 1;
8013
8014                 addr = TRUE;
8015               }
8016           }
8017           break;
8018
8019         case FFEINFO_whereIMMEDIATE:
8020         case FFEINFO_whereGLOBAL:
8021         case FFEINFO_whereFLEETING:
8022         case FFEINFO_whereFLEETING_CADDR:
8023         case FFEINFO_whereFLEETING_IADDR:
8024         case FFEINFO_whereINTRINSIC:
8025         case FFEINFO_whereCONSTANT_SUBOBJECT:
8026         default:
8027           assert ("ENTITY where unheard of" == NULL);
8028           /* Fall through. */
8029         case FFEINFO_whereANY:
8030           t = error_mark_node;
8031           break;
8032         }
8033       break;
8034
8035     case FFEINFO_kindFUNCTION:
8036       switch (ffeinfo_where (ffesymbol_info (s)))
8037         {
8038         case FFEINFO_whereLOCAL:        /* Me. */
8039           assert (!ffecom_transform_only_dummies_);
8040           t = current_function_decl;
8041           break;
8042
8043         case FFEINFO_whereGLOBAL:
8044           assert (!ffecom_transform_only_dummies_);
8045
8046           if (((g = ffesymbol_global (s)) != NULL)
8047               && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8048                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8049               && (ffeglobal_hook (g) != NULL_TREE)
8050               && ffe_is_globals ())
8051             {
8052               t = ffeglobal_hook (g);
8053               break;
8054             }
8055
8056           if (ffesymbol_is_f2c (s)
8057               && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8058             t = ffecom_tree_fun_type[bt][kt];
8059           else
8060             t = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
8061
8062           t = build_decl (FUNCTION_DECL,
8063                           ffecom_get_external_identifier_ (s),
8064                           t);
8065           DECL_EXTERNAL (t) = 1;
8066           TREE_PUBLIC (t) = 1;
8067
8068           t = start_decl (t, FALSE);
8069           finish_decl (t, NULL_TREE, FALSE);
8070
8071           if ((g != NULL)
8072               && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8073                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8074             ffeglobal_set_hook (g, t);
8075
8076           ffecom_save_tree_forever (t);
8077
8078           break;
8079
8080         case FFEINFO_whereDUMMY:
8081           assert (ffecom_transform_only_dummies_);
8082
8083           if (ffesymbol_is_f2c (s)
8084               && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8085             t = ffecom_tree_ptr_to_fun_type[bt][kt];
8086           else
8087             t = build_pointer_type
8088               (build_function_type (ffecom_tree_type[bt][kt], NULL_TREE));
8089
8090           t = build_decl (PARM_DECL,
8091                           ffecom_get_identifier_ (ffesymbol_text (s)),
8092                           t);
8093           DECL_ARTIFICIAL (t) = 1;
8094           addr = TRUE;
8095           break;
8096
8097         case FFEINFO_whereCONSTANT:     /* Statement function. */
8098           assert (!ffecom_transform_only_dummies_);
8099           t = ffecom_gen_sfuncdef_ (s, bt, kt);
8100           break;
8101
8102         case FFEINFO_whereINTRINSIC:
8103           assert (!ffecom_transform_only_dummies_);
8104           break;                /* Let actual references generate their
8105                                    decls. */
8106
8107         default:
8108           assert ("FUNCTION where unheard of" == NULL);
8109           /* Fall through. */
8110         case FFEINFO_whereANY:
8111           t = error_mark_node;
8112           break;
8113         }
8114       break;
8115
8116     case FFEINFO_kindSUBROUTINE:
8117       switch (ffeinfo_where (ffesymbol_info (s)))
8118         {
8119         case FFEINFO_whereLOCAL:        /* Me. */
8120           assert (!ffecom_transform_only_dummies_);
8121           t = current_function_decl;
8122           break;
8123
8124         case FFEINFO_whereGLOBAL:
8125           assert (!ffecom_transform_only_dummies_);
8126
8127           if (((g = ffesymbol_global (s)) != NULL)
8128               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8129                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8130               && (ffeglobal_hook (g) != NULL_TREE)
8131               && ffe_is_globals ())
8132             {
8133               t = ffeglobal_hook (g);
8134               break;
8135             }
8136
8137           t = build_decl (FUNCTION_DECL,
8138                           ffecom_get_external_identifier_ (s),
8139                           ffecom_tree_subr_type);
8140           DECL_EXTERNAL (t) = 1;
8141           TREE_PUBLIC (t) = 1;
8142
8143           t = start_decl (t, FALSE);
8144           finish_decl (t, NULL_TREE, FALSE);
8145
8146           if ((g != NULL)
8147               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8148                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8149             ffeglobal_set_hook (g, t);
8150
8151           ffecom_save_tree_forever (t);
8152
8153           break;
8154
8155         case FFEINFO_whereDUMMY:
8156           assert (ffecom_transform_only_dummies_);
8157
8158           t = build_decl (PARM_DECL,
8159                           ffecom_get_identifier_ (ffesymbol_text (s)),
8160                           ffecom_tree_ptr_to_subr_type);
8161           DECL_ARTIFICIAL (t) = 1;
8162           addr = TRUE;
8163           break;
8164
8165         case FFEINFO_whereINTRINSIC:
8166           assert (!ffecom_transform_only_dummies_);
8167           break;                /* Let actual references generate their
8168                                    decls. */
8169
8170         default:
8171           assert ("SUBROUTINE where unheard of" == NULL);
8172           /* Fall through. */
8173         case FFEINFO_whereANY:
8174           t = error_mark_node;
8175           break;
8176         }
8177       break;
8178
8179     case FFEINFO_kindPROGRAM:
8180       switch (ffeinfo_where (ffesymbol_info (s)))
8181         {
8182         case FFEINFO_whereLOCAL:        /* Me. */
8183           assert (!ffecom_transform_only_dummies_);
8184           t = current_function_decl;
8185           break;
8186
8187         case FFEINFO_whereCOMMON:
8188         case FFEINFO_whereDUMMY:
8189         case FFEINFO_whereGLOBAL:
8190         case FFEINFO_whereRESULT:
8191         case FFEINFO_whereFLEETING:
8192         case FFEINFO_whereFLEETING_CADDR:
8193         case FFEINFO_whereFLEETING_IADDR:
8194         case FFEINFO_whereIMMEDIATE:
8195         case FFEINFO_whereINTRINSIC:
8196         case FFEINFO_whereCONSTANT:
8197         case FFEINFO_whereCONSTANT_SUBOBJECT:
8198         default:
8199           assert ("PROGRAM where unheard of" == NULL);
8200           /* Fall through. */
8201         case FFEINFO_whereANY:
8202           t = error_mark_node;
8203           break;
8204         }
8205       break;
8206
8207     case FFEINFO_kindBLOCKDATA:
8208       switch (ffeinfo_where (ffesymbol_info (s)))
8209         {
8210         case FFEINFO_whereLOCAL:        /* Me. */
8211           assert (!ffecom_transform_only_dummies_);
8212           t = current_function_decl;
8213           break;
8214
8215         case FFEINFO_whereGLOBAL:
8216           assert (!ffecom_transform_only_dummies_);
8217
8218           t = build_decl (FUNCTION_DECL,
8219                           ffecom_get_external_identifier_ (s),
8220                           ffecom_tree_blockdata_type);
8221           DECL_EXTERNAL (t) = 1;
8222           TREE_PUBLIC (t) = 1;
8223
8224           t = start_decl (t, FALSE);
8225           finish_decl (t, NULL_TREE, FALSE);
8226
8227           ffecom_save_tree_forever (t);
8228
8229           break;
8230
8231         case FFEINFO_whereCOMMON:
8232         case FFEINFO_whereDUMMY:
8233         case FFEINFO_whereRESULT:
8234         case FFEINFO_whereFLEETING:
8235         case FFEINFO_whereFLEETING_CADDR:
8236         case FFEINFO_whereFLEETING_IADDR:
8237         case FFEINFO_whereIMMEDIATE:
8238         case FFEINFO_whereINTRINSIC:
8239         case FFEINFO_whereCONSTANT:
8240         case FFEINFO_whereCONSTANT_SUBOBJECT:
8241         default:
8242           assert ("BLOCKDATA where unheard of" == NULL);
8243           /* Fall through. */
8244         case FFEINFO_whereANY:
8245           t = error_mark_node;
8246           break;
8247         }
8248       break;
8249
8250     case FFEINFO_kindCOMMON:
8251       switch (ffeinfo_where (ffesymbol_info (s)))
8252         {
8253         case FFEINFO_whereLOCAL:
8254           assert (!ffecom_transform_only_dummies_);
8255           ffecom_transform_common_ (s);
8256           break;
8257
8258         case FFEINFO_whereNONE:
8259         case FFEINFO_whereCOMMON:
8260         case FFEINFO_whereDUMMY:
8261         case FFEINFO_whereGLOBAL:
8262         case FFEINFO_whereRESULT:
8263         case FFEINFO_whereFLEETING:
8264         case FFEINFO_whereFLEETING_CADDR:
8265         case FFEINFO_whereFLEETING_IADDR:
8266         case FFEINFO_whereIMMEDIATE:
8267         case FFEINFO_whereINTRINSIC:
8268         case FFEINFO_whereCONSTANT:
8269         case FFEINFO_whereCONSTANT_SUBOBJECT:
8270         default:
8271           assert ("COMMON where unheard of" == NULL);
8272           /* Fall through. */
8273         case FFEINFO_whereANY:
8274           t = error_mark_node;
8275           break;
8276         }
8277       break;
8278
8279     case FFEINFO_kindCONSTRUCT:
8280       switch (ffeinfo_where (ffesymbol_info (s)))
8281         {
8282         case FFEINFO_whereLOCAL:
8283           assert (!ffecom_transform_only_dummies_);
8284           break;
8285
8286         case FFEINFO_whereNONE:
8287         case FFEINFO_whereCOMMON:
8288         case FFEINFO_whereDUMMY:
8289         case FFEINFO_whereGLOBAL:
8290         case FFEINFO_whereRESULT:
8291         case FFEINFO_whereFLEETING:
8292         case FFEINFO_whereFLEETING_CADDR:
8293         case FFEINFO_whereFLEETING_IADDR:
8294         case FFEINFO_whereIMMEDIATE:
8295         case FFEINFO_whereINTRINSIC:
8296         case FFEINFO_whereCONSTANT:
8297         case FFEINFO_whereCONSTANT_SUBOBJECT:
8298         default:
8299           assert ("CONSTRUCT where unheard of" == NULL);
8300           /* Fall through. */
8301         case FFEINFO_whereANY:
8302           t = error_mark_node;
8303           break;
8304         }
8305       break;
8306
8307     case FFEINFO_kindNAMELIST:
8308       switch (ffeinfo_where (ffesymbol_info (s)))
8309         {
8310         case FFEINFO_whereLOCAL:
8311           assert (!ffecom_transform_only_dummies_);
8312           t = ffecom_transform_namelist_ (s);
8313           break;
8314
8315         case FFEINFO_whereNONE:
8316         case FFEINFO_whereCOMMON:
8317         case FFEINFO_whereDUMMY:
8318         case FFEINFO_whereGLOBAL:
8319         case FFEINFO_whereRESULT:
8320         case FFEINFO_whereFLEETING:
8321         case FFEINFO_whereFLEETING_CADDR:
8322         case FFEINFO_whereFLEETING_IADDR:
8323         case FFEINFO_whereIMMEDIATE:
8324         case FFEINFO_whereINTRINSIC:
8325         case FFEINFO_whereCONSTANT:
8326         case FFEINFO_whereCONSTANT_SUBOBJECT:
8327         default:
8328           assert ("NAMELIST where unheard of" == NULL);
8329           /* Fall through. */
8330         case FFEINFO_whereANY:
8331           t = error_mark_node;
8332           break;
8333         }
8334       break;
8335
8336     default:
8337       assert ("kind unheard of" == NULL);
8338       /* Fall through. */
8339     case FFEINFO_kindANY:
8340       t = error_mark_node;
8341       break;
8342     }
8343
8344   ffesymbol_hook (s).decl_tree = t;
8345   ffesymbol_hook (s).length_tree = tlen;
8346   ffesymbol_hook (s).addr = addr;
8347
8348   lineno = old_lineno;
8349   input_filename = old_input_filename;
8350
8351   return s;
8352 }
8353
8354 /* Transform into ASSIGNable symbol.
8355
8356    Symbol has already been transformed, but for whatever reason, the
8357    resulting decl_tree has been deemed not usable for an ASSIGN target.
8358    (E.g. it isn't wide enough to hold a pointer.)  So, here we invent
8359    another local symbol of type void * and stuff that in the assign_tree
8360    argument.  The F77/F90 standards allow this implementation.  */
8361
8362 static ffesymbol
8363 ffecom_sym_transform_assign_ (ffesymbol s)
8364 {
8365   tree t;                       /* Transformed thingy. */
8366   int old_lineno = lineno;
8367   const char *old_input_filename = input_filename;
8368
8369   if (ffesymbol_sfdummyparent (s) == NULL)
8370     {
8371       input_filename = ffesymbol_where_filename (s);
8372       lineno = ffesymbol_where_filelinenum (s);
8373     }
8374   else
8375     {
8376       ffesymbol sf = ffesymbol_sfdummyparent (s);
8377
8378       input_filename = ffesymbol_where_filename (sf);
8379       lineno = ffesymbol_where_filelinenum (sf);
8380     }
8381
8382   assert (!ffecom_transform_only_dummies_);
8383
8384   t = build_decl (VAR_DECL,
8385                   ffecom_get_invented_identifier ("__g77_ASSIGN_%s",
8386                                                    ffesymbol_text (s)),
8387                   TREE_TYPE (null_pointer_node));
8388
8389   switch (ffesymbol_where (s))
8390     {
8391     case FFEINFO_whereLOCAL:
8392       /* Unlike for regular vars, SAVE status is easy to determine for
8393          ASSIGNed vars, since there's no initialization, there's no
8394          effective storage association (so "SAVE J" does not apply to
8395          K even given "EQUIVALENCE (J,K)"), there's no size issue
8396          to worry about, etc.  */
8397       if ((ffesymbol_is_save (s) || ffe_is_saveall ())
8398           && (ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8399           && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA))
8400         TREE_STATIC (t) = 1;    /* SAVEd in proc, make static. */
8401       else
8402         TREE_STATIC (t) = 0;    /* No need to make static. */
8403       break;
8404
8405     case FFEINFO_whereCOMMON:
8406       TREE_STATIC (t) = 1;      /* Assume COMMONs always SAVEd. */
8407       break;
8408
8409     case FFEINFO_whereDUMMY:
8410       /* Note that twinning a DUMMY means the caller won't see
8411          the ASSIGNed value.  But both F77 and F90 allow implementations
8412          to do this, i.e. disallow Fortran code that would try and
8413          take advantage of actually putting a label into a variable
8414          via a dummy argument (or any other storage association, for
8415          that matter).  */
8416       TREE_STATIC (t) = 0;
8417       break;
8418
8419     default:
8420       TREE_STATIC (t) = 0;
8421       break;
8422     }
8423
8424   t = start_decl (t, FALSE);
8425   finish_decl (t, NULL_TREE, FALSE);
8426
8427   ffesymbol_hook (s).assign_tree = t;
8428
8429   lineno = old_lineno;
8430   input_filename = old_input_filename;
8431
8432   return s;
8433 }
8434
8435 /* Implement COMMON area in back end.
8436
8437    Because COMMON-based variables can be referenced in the dimension
8438    expressions of dummy (adjustable) arrays, and because dummies
8439    (in the gcc back end) need to be put in the outer binding level
8440    of a function (which has two binding levels, the outer holding
8441    the dummies and the inner holding the other vars), special care
8442    must be taken to handle COMMON areas.
8443
8444    The current strategy is basically to always tell the back end about
8445    the COMMON area as a top-level external reference to just a block
8446    of storage of the master type of that area (e.g. integer, real,
8447    character, whatever -- not a structure).  As a distinct action,
8448    if initial values are provided, tell the back end about the area
8449    as a top-level non-external (initialized) area and remember not to
8450    allow further initialization or expansion of the area.  Meanwhile,
8451    if no initialization happens at all, tell the back end about
8452    the largest size we've seen declared so the space does get reserved.
8453    (This function doesn't handle all that stuff, but it does some
8454    of the important things.)
8455
8456    Meanwhile, for COMMON variables themselves, just keep creating
8457    references like *((float *) (&common_area + offset)) each time
8458    we reference the variable.  In other words, don't make a VAR_DECL
8459    or any kind of component reference (like we used to do before 0.4),
8460    though we might do that as well just for debugging purposes (and
8461    stuff the rtl with the appropriate offset expression).  */
8462
8463 static void
8464 ffecom_transform_common_ (ffesymbol s)
8465 {
8466   ffestorag st = ffesymbol_storage (s);
8467   ffeglobal g = ffesymbol_global (s);
8468   tree cbt;
8469   tree cbtype;
8470   tree init;
8471   tree high;
8472   bool is_init = ffestorag_is_init (st);
8473
8474   assert (st != NULL);
8475
8476   if ((g == NULL)
8477       || (ffeglobal_type (g) != FFEGLOBAL_typeCOMMON))
8478     return;
8479
8480   /* First update the size of the area in global terms.  */
8481
8482   ffeglobal_size_common (s, ffestorag_size (st));
8483
8484   if (!ffeglobal_common_init (g))
8485     is_init = FALSE;    /* No explicit init, don't let erroneous joins init. */
8486
8487   cbt = ffeglobal_hook (g);
8488
8489   /* If we already have declared this common block for a previous program
8490      unit, and either we already initialized it or we don't have new
8491      initialization for it, just return what we have without changing it.  */
8492
8493   if ((cbt != NULL_TREE)
8494       && (!is_init
8495           || !DECL_EXTERNAL (cbt)))
8496     {
8497       if (st->hook == NULL) ffestorag_set_hook (st, cbt);
8498       return;
8499     }
8500
8501   /* Process inits.  */
8502
8503   if (is_init)
8504     {
8505       if (ffestorag_init (st) != NULL)
8506         {
8507           ffebld sexp;
8508
8509           /* Set the padding for the expression, so ffecom_expr
8510              knows to insert that many zeros.  */
8511           switch (ffebld_op (sexp = ffestorag_init (st)))
8512             {
8513             case FFEBLD_opCONTER:
8514               ffebld_conter_set_pad (sexp, ffestorag_modulo (st));
8515               break;
8516
8517             case FFEBLD_opARRTER:
8518               ffebld_arrter_set_pad (sexp, ffestorag_modulo (st));
8519               break;
8520
8521             case FFEBLD_opACCTER:
8522               ffebld_accter_set_pad (sexp, ffestorag_modulo (st));
8523               break;
8524
8525             default:
8526               assert ("bad op for cmn init (pad)" == NULL);
8527               break;
8528             }
8529
8530           init = ffecom_expr (sexp);
8531           if (init == error_mark_node)
8532             {                   /* Hopefully the back end complained! */
8533               init = NULL_TREE;
8534               if (cbt != NULL_TREE)
8535                 return;
8536             }
8537         }
8538       else
8539         init = error_mark_node;
8540     }
8541   else
8542     init = NULL_TREE;
8543
8544   /* cbtype must be permanently allocated!  */
8545
8546   /* Allocate the MAX of the areas so far, seen filewide.  */
8547   high = build_int_2 ((ffeglobal_common_size (g)
8548                        + ffeglobal_common_pad (g)) - 1, 0);
8549   TREE_TYPE (high) = ffecom_integer_type_node;
8550
8551   if (init)
8552     cbtype = build_array_type (char_type_node,
8553                                build_range_type (integer_type_node,
8554                                                  integer_zero_node,
8555                                                  high));
8556   else
8557     cbtype = build_array_type (char_type_node, NULL_TREE);
8558
8559   if (cbt == NULL_TREE)
8560     {
8561       cbt
8562         = build_decl (VAR_DECL,
8563                       ffecom_get_external_identifier_ (s),
8564                       cbtype);
8565       TREE_STATIC (cbt) = 1;
8566       TREE_PUBLIC (cbt) = 1;
8567     }
8568   else
8569     {
8570       assert (is_init);
8571       TREE_TYPE (cbt) = cbtype;
8572     }
8573   DECL_EXTERNAL (cbt) = init ? 0 : 1;
8574   DECL_INITIAL (cbt) = init ? error_mark_node : NULL_TREE;
8575
8576   cbt = start_decl (cbt, TRUE);
8577   if (ffeglobal_hook (g) != NULL)
8578     assert (cbt == ffeglobal_hook (g));
8579
8580   assert (!init || !DECL_EXTERNAL (cbt));
8581
8582   /* Make sure that any type can live in COMMON and be referenced
8583      without getting a bus error.  We could pick the most restrictive
8584      alignment of all entities actually placed in the COMMON, but
8585      this seems easy enough.  */
8586
8587   DECL_ALIGN (cbt) = BIGGEST_ALIGNMENT;
8588   DECL_USER_ALIGN (cbt) = 0;
8589
8590   if (is_init && (ffestorag_init (st) == NULL))
8591     init = ffecom_init_zero_ (cbt);
8592
8593   finish_decl (cbt, init, TRUE);
8594
8595   if (is_init)
8596     ffestorag_set_init (st, ffebld_new_any ());
8597
8598   if (init)
8599     {
8600       assert (DECL_SIZE_UNIT (cbt) != NULL_TREE);
8601       assert (TREE_CODE (DECL_SIZE_UNIT (cbt)) == INTEGER_CST);
8602       assert (0 == compare_tree_int (DECL_SIZE_UNIT (cbt),
8603                                      (ffeglobal_common_size (g)
8604                                       + ffeglobal_common_pad (g))));
8605     }
8606
8607   ffeglobal_set_hook (g, cbt);
8608
8609   ffestorag_set_hook (st, cbt);
8610
8611   ffecom_save_tree_forever (cbt);
8612 }
8613
8614 /* Make master area for local EQUIVALENCE.  */
8615
8616 static void
8617 ffecom_transform_equiv_ (ffestorag eqst)
8618 {
8619   tree eqt;
8620   tree eqtype;
8621   tree init;
8622   tree high;
8623   bool is_init = ffestorag_is_init (eqst);
8624
8625   assert (eqst != NULL);
8626
8627   eqt = ffestorag_hook (eqst);
8628
8629   if (eqt != NULL_TREE)
8630     return;
8631
8632   /* Process inits.  */
8633
8634   if (is_init)
8635     {
8636       if (ffestorag_init (eqst) != NULL)
8637         {
8638           ffebld sexp;
8639
8640           /* Set the padding for the expression, so ffecom_expr
8641              knows to insert that many zeros.  */
8642           switch (ffebld_op (sexp = ffestorag_init (eqst)))
8643             {
8644             case FFEBLD_opCONTER:
8645               ffebld_conter_set_pad (sexp, ffestorag_modulo (eqst));
8646               break;
8647
8648             case FFEBLD_opARRTER:
8649               ffebld_arrter_set_pad (sexp, ffestorag_modulo (eqst));
8650               break;
8651
8652             case FFEBLD_opACCTER:
8653               ffebld_accter_set_pad (sexp, ffestorag_modulo (eqst));
8654               break;
8655
8656             default:
8657               assert ("bad op for eqv init (pad)" == NULL);
8658               break;
8659             }
8660
8661           init = ffecom_expr (sexp);
8662           if (init == error_mark_node)
8663             init = NULL_TREE;   /* Hopefully the back end complained! */
8664         }
8665       else
8666         init = error_mark_node;
8667     }
8668   else if (ffe_is_init_local_zero ())
8669     init = error_mark_node;
8670   else
8671     init = NULL_TREE;
8672
8673   ffecom_member_namelisted_ = FALSE;
8674   ffestorag_drive (ffestorag_list_equivs (eqst),
8675                    &ffecom_member_phase1_,
8676                    eqst);
8677
8678   high = build_int_2 ((ffestorag_size (eqst)
8679                        + ffestorag_modulo (eqst)) - 1, 0);
8680   TREE_TYPE (high) = ffecom_integer_type_node;
8681
8682   eqtype = build_array_type (char_type_node,
8683                              build_range_type (ffecom_integer_type_node,
8684                                                ffecom_integer_zero_node,
8685                                                high));
8686
8687   eqt = build_decl (VAR_DECL,
8688                     ffecom_get_invented_identifier ("__g77_equiv_%s",
8689                                                     ffesymbol_text
8690                                                     (ffestorag_symbol (eqst))),
8691                     eqtype);
8692   DECL_EXTERNAL (eqt) = 0;
8693   if (is_init
8694       || ffecom_member_namelisted_
8695 #ifdef FFECOM_sizeMAXSTACKITEM
8696       || (ffestorag_size (eqst) > FFECOM_sizeMAXSTACKITEM)
8697 #endif
8698       || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8699           && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
8700           && (ffestorag_is_save (eqst) || ffe_is_saveall ())))
8701     TREE_STATIC (eqt) = 1;
8702   else
8703     TREE_STATIC (eqt) = 0;
8704   TREE_PUBLIC (eqt) = 0;
8705   TREE_ADDRESSABLE (eqt) = 1;  /* Ensure non-register allocation */
8706   DECL_CONTEXT (eqt) = current_function_decl;
8707   if (init)
8708     DECL_INITIAL (eqt) = error_mark_node;
8709   else
8710     DECL_INITIAL (eqt) = NULL_TREE;
8711
8712   eqt = start_decl (eqt, FALSE);
8713
8714   /* Make sure that any type can live in EQUIVALENCE and be referenced
8715      without getting a bus error.  We could pick the most restrictive
8716      alignment of all entities actually placed in the EQUIVALENCE, but
8717      this seems easy enough.  */
8718
8719   DECL_ALIGN (eqt) = BIGGEST_ALIGNMENT;
8720   DECL_USER_ALIGN (eqt) = 0;
8721
8722   if ((!is_init && ffe_is_init_local_zero ())
8723       || (is_init && (ffestorag_init (eqst) == NULL)))
8724     init = ffecom_init_zero_ (eqt);
8725
8726   finish_decl (eqt, init, FALSE);
8727
8728   if (is_init)
8729     ffestorag_set_init (eqst, ffebld_new_any ());
8730
8731   {
8732     assert (TREE_CODE (DECL_SIZE_UNIT (eqt)) == INTEGER_CST);
8733     assert (0 == compare_tree_int (DECL_SIZE_UNIT (eqt),
8734                                    (ffestorag_size (eqst)
8735                                     + ffestorag_modulo (eqst))));
8736   }
8737
8738   ffestorag_set_hook (eqst, eqt);
8739
8740   ffestorag_drive (ffestorag_list_equivs (eqst),
8741                    &ffecom_member_phase2_,
8742                    eqst);
8743 }
8744
8745 /* Implement NAMELIST in back end.  See f2c/format.c for more info.  */
8746
8747 static tree
8748 ffecom_transform_namelist_ (ffesymbol s)
8749 {
8750   tree nmlt;
8751   tree nmltype = ffecom_type_namelist_ ();
8752   tree nmlinits;
8753   tree nameinit;
8754   tree varsinit;
8755   tree nvarsinit;
8756   tree field;
8757   tree high;
8758   int i;
8759   static int mynumber = 0;
8760
8761   nmlt = build_decl (VAR_DECL,
8762                      ffecom_get_invented_identifier ("__g77_namelist_%d",
8763                                                      mynumber++),
8764                      nmltype);
8765   TREE_STATIC (nmlt) = 1;
8766   DECL_INITIAL (nmlt) = error_mark_node;
8767
8768   nmlt = start_decl (nmlt, FALSE);
8769
8770   /* Process inits.  */
8771
8772   i = strlen (ffesymbol_text (s));
8773
8774   high = build_int_2 (i, 0);
8775   TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
8776
8777   nameinit = ffecom_build_f2c_string_ (i + 1,
8778                                        ffesymbol_text (s));
8779   TREE_TYPE (nameinit)
8780     = build_type_variant
8781     (build_array_type
8782      (char_type_node,
8783       build_range_type (ffecom_f2c_ftnlen_type_node,
8784                         ffecom_f2c_ftnlen_one_node,
8785                         high)),
8786      1, 0);
8787   TREE_CONSTANT (nameinit) = 1;
8788   TREE_STATIC (nameinit) = 1;
8789   nameinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (nameinit)),
8790                        nameinit);
8791
8792   varsinit = ffecom_vardesc_array_ (s);
8793   varsinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (varsinit)),
8794                        varsinit);
8795   TREE_CONSTANT (varsinit) = 1;
8796   TREE_STATIC (varsinit) = 1;
8797
8798   {
8799     ffebld b;
8800
8801     for (i = 0, b = ffesymbol_namelist (s); b != NULL; b = ffebld_trail (b))
8802       ++i;
8803   }
8804   nvarsinit = build_int_2 (i, 0);
8805   TREE_TYPE (nvarsinit) = integer_type_node;
8806   TREE_CONSTANT (nvarsinit) = 1;
8807   TREE_STATIC (nvarsinit) = 1;
8808
8809   nmlinits = build_tree_list ((field = TYPE_FIELDS (nmltype)), nameinit);
8810   TREE_CHAIN (nmlinits) = build_tree_list ((field = TREE_CHAIN (field)),
8811                                            varsinit);
8812   TREE_CHAIN (TREE_CHAIN (nmlinits))
8813     = build_tree_list ((field = TREE_CHAIN (field)), nvarsinit);
8814
8815   nmlinits = build (CONSTRUCTOR, nmltype, NULL_TREE, nmlinits);
8816   TREE_CONSTANT (nmlinits) = 1;
8817   TREE_STATIC (nmlinits) = 1;
8818
8819   finish_decl (nmlt, nmlinits, FALSE);
8820
8821   nmlt = ffecom_1 (ADDR_EXPR, build_pointer_type (nmltype), nmlt);
8822
8823   return nmlt;
8824 }
8825
8826 /* A subroutine of ffecom_tree_canonize_ref_.  The incoming tree is
8827    analyzed on the assumption it is calculating a pointer to be
8828    indirected through.  It must return the proper decl and offset,
8829    taking into account different units of measurements for offsets.  */
8830
8831 static void
8832 ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
8833                            tree t)
8834 {
8835   switch (TREE_CODE (t))
8836     {
8837     case NOP_EXPR:
8838     case CONVERT_EXPR:
8839     case NON_LVALUE_EXPR:
8840       ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
8841       break;
8842
8843     case PLUS_EXPR:
8844       ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
8845       if ((*decl == NULL_TREE)
8846           || (*decl == error_mark_node))
8847         break;
8848
8849       if (TREE_CODE (TREE_OPERAND (t, 1)) == INTEGER_CST)
8850         {
8851           /* An offset into COMMON.  */
8852           *offset = fold (build (PLUS_EXPR, TREE_TYPE (*offset),
8853                                  *offset, TREE_OPERAND (t, 1)));
8854           /* Convert offset (presumably in bytes) into canonical units
8855              (presumably bits).  */
8856           *offset = size_binop (MULT_EXPR,
8857                                 convert (bitsizetype, *offset),
8858                                 TYPE_SIZE (TREE_TYPE (TREE_TYPE (t))));
8859           break;
8860         }
8861       /* Not a COMMON reference, so an unrecognized pattern.  */
8862       *decl = error_mark_node;
8863       break;
8864
8865     case PARM_DECL:
8866       *decl = t;
8867       *offset = bitsize_zero_node;
8868       break;
8869
8870     case ADDR_EXPR:
8871       if (TREE_CODE (TREE_OPERAND (t, 0)) == VAR_DECL)
8872         {
8873           /* A reference to COMMON.  */
8874           *decl = TREE_OPERAND (t, 0);
8875           *offset = bitsize_zero_node;
8876           break;
8877         }
8878       /* Fall through.  */
8879     default:
8880       /* Not a COMMON reference, so an unrecognized pattern.  */
8881       *decl = error_mark_node;
8882       break;
8883     }
8884 }
8885
8886 /* Given a tree that is possibly intended for use as an lvalue, return
8887    information representing a canonical view of that tree as a decl, an
8888    offset into that decl, and a size for the lvalue.
8889
8890    If there's no applicable decl, NULL_TREE is returned for the decl,
8891    and the other fields are left undefined.
8892
8893    If the tree doesn't fit the recognizable forms, an ERROR_MARK node
8894    is returned for the decl, and the other fields are left undefined.
8895
8896    Otherwise, the decl returned currently is either a VAR_DECL or a
8897    PARM_DECL.
8898
8899    The offset returned is always valid, but of course not necessarily
8900    a constant, and not necessarily converted into the appropriate
8901    type, leaving that up to the caller (so as to avoid that overhead
8902    if the decls being looked at are different anyway).
8903
8904    If the size cannot be determined (e.g. an adjustable array),
8905    an ERROR_MARK node is returned for the size.  Otherwise, the
8906    size returned is valid, not necessarily a constant, and not
8907    necessarily converted into the appropriate type as with the
8908    offset.
8909
8910    Note that the offset and size expressions are expressed in the
8911    base storage units (usually bits) rather than in the units of
8912    the type of the decl, because two decls with different types
8913    might overlap but with apparently non-overlapping array offsets,
8914    whereas converting the array offsets to consistant offsets will
8915    reveal the overlap.  */
8916
8917 static void
8918 ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
8919                            tree *size, tree t)
8920 {
8921   /* The default path is to report a nonexistant decl.  */
8922   *decl = NULL_TREE;
8923
8924   if (t == NULL_TREE)
8925     return;
8926
8927   switch (TREE_CODE (t))
8928     {
8929     case ERROR_MARK:
8930     case IDENTIFIER_NODE:
8931     case INTEGER_CST:
8932     case REAL_CST:
8933     case COMPLEX_CST:
8934     case STRING_CST:
8935     case CONST_DECL:
8936     case PLUS_EXPR:
8937     case MINUS_EXPR:
8938     case MULT_EXPR:
8939     case TRUNC_DIV_EXPR:
8940     case CEIL_DIV_EXPR:
8941     case FLOOR_DIV_EXPR:
8942     case ROUND_DIV_EXPR:
8943     case TRUNC_MOD_EXPR:
8944     case CEIL_MOD_EXPR:
8945     case FLOOR_MOD_EXPR:
8946     case ROUND_MOD_EXPR:
8947     case RDIV_EXPR:
8948     case EXACT_DIV_EXPR:
8949     case FIX_TRUNC_EXPR:
8950     case FIX_CEIL_EXPR:
8951     case FIX_FLOOR_EXPR:
8952     case FIX_ROUND_EXPR:
8953     case FLOAT_EXPR:
8954     case NEGATE_EXPR:
8955     case MIN_EXPR:
8956     case MAX_EXPR:
8957     case ABS_EXPR:
8958     case FFS_EXPR:
8959     case LSHIFT_EXPR:
8960     case RSHIFT_EXPR:
8961     case LROTATE_EXPR:
8962     case RROTATE_EXPR:
8963     case BIT_IOR_EXPR:
8964     case BIT_XOR_EXPR:
8965     case BIT_AND_EXPR:
8966     case BIT_ANDTC_EXPR:
8967     case BIT_NOT_EXPR:
8968     case TRUTH_ANDIF_EXPR:
8969     case TRUTH_ORIF_EXPR:
8970     case TRUTH_AND_EXPR:
8971     case TRUTH_OR_EXPR:
8972     case TRUTH_XOR_EXPR:
8973     case TRUTH_NOT_EXPR:
8974     case LT_EXPR:
8975     case LE_EXPR:
8976     case GT_EXPR:
8977     case GE_EXPR:
8978     case EQ_EXPR:
8979     case NE_EXPR:
8980     case COMPLEX_EXPR:
8981     case CONJ_EXPR:
8982     case REALPART_EXPR:
8983     case IMAGPART_EXPR:
8984     case LABEL_EXPR:
8985     case COMPONENT_REF:
8986     case COMPOUND_EXPR:
8987     case ADDR_EXPR:
8988       return;
8989
8990     case VAR_DECL:
8991     case PARM_DECL:
8992       *decl = t;
8993       *offset = bitsize_zero_node;
8994       *size = TYPE_SIZE (TREE_TYPE (t));
8995       return;
8996
8997     case ARRAY_REF:
8998       {
8999         tree array = TREE_OPERAND (t, 0);
9000         tree element = TREE_OPERAND (t, 1);
9001         tree init_offset;
9002
9003         if ((array == NULL_TREE)
9004             || (element == NULL_TREE))
9005           {
9006             *decl = error_mark_node;
9007             return;
9008           }
9009
9010         ffecom_tree_canonize_ref_ (decl, &init_offset, size,
9011                                    array);
9012         if ((*decl == NULL_TREE)
9013             || (*decl == error_mark_node))
9014           return;
9015
9016         /* Calculate ((element - base) * NBBY) + init_offset.  */
9017         *offset = fold (build (MINUS_EXPR, TREE_TYPE (element),
9018                                element,
9019                                TYPE_MIN_VALUE (TYPE_DOMAIN
9020                                                (TREE_TYPE (array)))));
9021
9022         *offset = size_binop (MULT_EXPR,
9023                               convert (bitsizetype, *offset),
9024                               TYPE_SIZE (TREE_TYPE (TREE_TYPE (array))));
9025
9026         *offset = size_binop (PLUS_EXPR, init_offset, *offset);
9027
9028         *size = TYPE_SIZE (TREE_TYPE (t));
9029         return;
9030       }
9031
9032     case INDIRECT_REF:
9033
9034       /* Most of this code is to handle references to COMMON.  And so
9035          far that is useful only for calling library functions, since
9036          external (user) functions might reference common areas.  But
9037          even calling an external function, it's worthwhile to decode
9038          COMMON references because if not storing into COMMON, we don't
9039          want COMMON-based arguments to gratuitously force use of a
9040          temporary.  */
9041
9042       *size = TYPE_SIZE (TREE_TYPE (t));
9043
9044       ffecom_tree_canonize_ptr_ (decl, offset,
9045                                  TREE_OPERAND (t, 0));
9046
9047       return;
9048
9049     case CONVERT_EXPR:
9050     case NOP_EXPR:
9051     case MODIFY_EXPR:
9052     case NON_LVALUE_EXPR:
9053     case RESULT_DECL:
9054     case FIELD_DECL:
9055     case COND_EXPR:             /* More cases than we can handle. */
9056     case SAVE_EXPR:
9057     case REFERENCE_EXPR:
9058     case PREDECREMENT_EXPR:
9059     case PREINCREMENT_EXPR:
9060     case POSTDECREMENT_EXPR:
9061     case POSTINCREMENT_EXPR:
9062     case CALL_EXPR:
9063     default:
9064       *decl = error_mark_node;
9065       return;
9066     }
9067 }
9068
9069 /* Do divide operation appropriate to type of operands.  */
9070
9071 static tree
9072 ffecom_tree_divide_ (tree tree_type, tree left, tree right,
9073                      tree dest_tree, ffebld dest, bool *dest_used,
9074                      tree hook)
9075 {
9076   if ((left == error_mark_node)
9077       || (right == error_mark_node))
9078     return error_mark_node;
9079
9080   switch (TREE_CODE (tree_type))
9081     {
9082     case INTEGER_TYPE:
9083       return ffecom_2 (TRUNC_DIV_EXPR, tree_type,
9084                        left,
9085                        right);
9086
9087     case COMPLEX_TYPE:
9088       if (! optimize_size)
9089         return ffecom_2 (RDIV_EXPR, tree_type,
9090                          left,
9091                          right);
9092       {
9093         ffecomGfrt ix;
9094
9095         if (TREE_TYPE (tree_type)
9096             == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9097           ix = FFECOM_gfrtDIV_CC;       /* Overlapping result okay. */
9098         else
9099           ix = FFECOM_gfrtDIV_ZZ;       /* Overlapping result okay. */
9100
9101         left = ffecom_1 (ADDR_EXPR,
9102                          build_pointer_type (TREE_TYPE (left)),
9103                          left);
9104         left = build_tree_list (NULL_TREE, left);
9105         right = ffecom_1 (ADDR_EXPR,
9106                           build_pointer_type (TREE_TYPE (right)),
9107                           right);
9108         right = build_tree_list (NULL_TREE, right);
9109         TREE_CHAIN (left) = right;
9110
9111         return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9112                              ffecom_gfrt_kindtype (ix),
9113                              ffe_is_f2c_library (),
9114                              tree_type,
9115                              left,
9116                              dest_tree, dest, dest_used,
9117                              NULL_TREE, TRUE, hook);
9118       }
9119       break;
9120
9121     case RECORD_TYPE:
9122       {
9123         ffecomGfrt ix;
9124
9125         if (TREE_TYPE (TYPE_FIELDS (tree_type))
9126             == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9127           ix = FFECOM_gfrtDIV_CC;       /* Overlapping result okay. */
9128         else
9129           ix = FFECOM_gfrtDIV_ZZ;       /* Overlapping result okay. */
9130
9131         left = ffecom_1 (ADDR_EXPR,
9132                          build_pointer_type (TREE_TYPE (left)),
9133                          left);
9134         left = build_tree_list (NULL_TREE, left);
9135         right = ffecom_1 (ADDR_EXPR,
9136                           build_pointer_type (TREE_TYPE (right)),
9137                           right);
9138         right = build_tree_list (NULL_TREE, right);
9139         TREE_CHAIN (left) = right;
9140
9141         return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9142                              ffecom_gfrt_kindtype (ix),
9143                              ffe_is_f2c_library (),
9144                              tree_type,
9145                              left,
9146                              dest_tree, dest, dest_used,
9147                              NULL_TREE, TRUE, hook);
9148       }
9149       break;
9150
9151     default:
9152       return ffecom_2 (RDIV_EXPR, tree_type,
9153                        left,
9154                        right);
9155     }
9156 }
9157
9158 /* Build type info for non-dummy variable.  */
9159
9160 static tree
9161 ffecom_type_localvar_ (ffesymbol s, ffeinfoBasictype bt,
9162                        ffeinfoKindtype kt)
9163 {
9164   tree type;
9165   ffebld dl;
9166   ffebld dim;
9167   tree lowt;
9168   tree hight;
9169
9170   type = ffecom_tree_type[bt][kt];
9171   if (bt == FFEINFO_basictypeCHARACTER)
9172     {
9173       hight = build_int_2 (ffesymbol_size (s), 0);
9174       TREE_TYPE (hight) = ffecom_f2c_ftnlen_type_node;
9175
9176       type
9177         = build_array_type
9178           (type,
9179            build_range_type (ffecom_f2c_ftnlen_type_node,
9180                              ffecom_f2c_ftnlen_one_node,
9181                              hight));
9182       type = ffecom_check_size_overflow_ (s, type, FALSE);
9183     }
9184
9185   for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
9186     {
9187       if (type == error_mark_node)
9188         break;
9189
9190       dim = ffebld_head (dl);
9191       assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
9192
9193       if (ffebld_left (dim) == NULL)
9194         lowt = integer_one_node;
9195       else
9196         lowt = ffecom_expr (ffebld_left (dim));
9197
9198       if (TREE_CODE (lowt) != INTEGER_CST)
9199         lowt = variable_size (lowt);
9200
9201       assert (ffebld_right (dim) != NULL);
9202       hight = ffecom_expr (ffebld_right (dim));
9203
9204       if (TREE_CODE (hight) != INTEGER_CST)
9205         hight = variable_size (hight);
9206
9207       type = build_array_type (type,
9208                                build_range_type (ffecom_integer_type_node,
9209                                                  lowt, hight));
9210       type = ffecom_check_size_overflow_ (s, type, FALSE);
9211     }
9212
9213   return type;
9214 }
9215
9216 /* Build Namelist type.  */
9217
9218 static GTY(()) tree ffecom_type_namelist_var;
9219 static tree
9220 ffecom_type_namelist_ ()
9221 {
9222   if (ffecom_type_namelist_var == NULL_TREE)
9223     {
9224       tree namefield, varsfield, nvarsfield, vardesctype, type;
9225
9226       vardesctype = ffecom_type_vardesc_ ();
9227
9228       type = make_node (RECORD_TYPE);
9229
9230       vardesctype = build_pointer_type (build_pointer_type (vardesctype));
9231
9232       namefield = ffecom_decl_field (type, NULL_TREE, "name",
9233                                      string_type_node);
9234       varsfield = ffecom_decl_field (type, namefield, "vars", vardesctype);
9235       nvarsfield = ffecom_decl_field (type, varsfield, "nvars",
9236                                       integer_type_node);
9237
9238       TYPE_FIELDS (type) = namefield;
9239       layout_type (type);
9240
9241       ffecom_type_namelist_var = type;
9242     }
9243
9244   return ffecom_type_namelist_var;
9245 }
9246
9247 /* Build Vardesc type.  */
9248
9249 static GTY(()) tree ffecom_type_vardesc_var;
9250 static tree
9251 ffecom_type_vardesc_ ()
9252 {
9253   if (ffecom_type_vardesc_var == NULL_TREE)
9254     {
9255       tree namefield, addrfield, dimsfield, typefield, type;
9256       type = make_node (RECORD_TYPE);
9257
9258       namefield = ffecom_decl_field (type, NULL_TREE, "name",
9259                                      string_type_node);
9260       addrfield = ffecom_decl_field (type, namefield, "addr",
9261                                      string_type_node);
9262       dimsfield = ffecom_decl_field (type, addrfield, "dims",
9263                                      ffecom_f2c_ptr_to_ftnlen_type_node);
9264       typefield = ffecom_decl_field (type, dimsfield, "type",
9265                                      integer_type_node);
9266
9267       TYPE_FIELDS (type) = namefield;
9268       layout_type (type);
9269
9270       ffecom_type_vardesc_var = type;
9271     }
9272
9273   return ffecom_type_vardesc_var;
9274 }
9275
9276 static tree
9277 ffecom_vardesc_ (ffebld expr)
9278 {
9279   ffesymbol s;
9280
9281   assert (ffebld_op (expr) == FFEBLD_opSYMTER);
9282   s = ffebld_symter (expr);
9283
9284   if (ffesymbol_hook (s).vardesc_tree == NULL_TREE)
9285     {
9286       int i;
9287       tree vardesctype = ffecom_type_vardesc_ ();
9288       tree var;
9289       tree nameinit;
9290       tree dimsinit;
9291       tree addrinit;
9292       tree typeinit;
9293       tree field;
9294       tree varinits;
9295       static int mynumber = 0;
9296
9297       var = build_decl (VAR_DECL,
9298                         ffecom_get_invented_identifier ("__g77_vardesc_%d",
9299                                                         mynumber++),
9300                         vardesctype);
9301       TREE_STATIC (var) = 1;
9302       DECL_INITIAL (var) = error_mark_node;
9303
9304       var = start_decl (var, FALSE);
9305
9306       /* Process inits.  */
9307
9308       nameinit = ffecom_build_f2c_string_ ((i = strlen (ffesymbol_text (s)))
9309                                            + 1,
9310                                            ffesymbol_text (s));
9311       TREE_TYPE (nameinit)
9312         = build_type_variant
9313         (build_array_type
9314          (char_type_node,
9315           build_range_type (integer_type_node,
9316                             integer_one_node,
9317                             build_int_2 (i, 0))),
9318          1, 0);
9319       TREE_CONSTANT (nameinit) = 1;
9320       TREE_STATIC (nameinit) = 1;
9321       nameinit = ffecom_1 (ADDR_EXPR,
9322                            build_pointer_type (TREE_TYPE (nameinit)),
9323                            nameinit);
9324
9325       addrinit = ffecom_arg_ptr_to_expr (expr, &typeinit);
9326
9327       dimsinit = ffecom_vardesc_dims_ (s);
9328
9329       if (typeinit == NULL_TREE)
9330         {
9331           ffeinfoBasictype bt = ffesymbol_basictype (s);
9332           ffeinfoKindtype kt = ffesymbol_kindtype (s);
9333           int tc = ffecom_f2c_typecode (bt, kt);
9334
9335           assert (tc != -1);
9336           typeinit = build_int_2 (tc, (tc < 0) ? -1 : 0);
9337         }
9338       else
9339         typeinit = ffecom_1 (NEGATE_EXPR, TREE_TYPE (typeinit), typeinit);
9340
9341       varinits = build_tree_list ((field = TYPE_FIELDS (vardesctype)),
9342                                   nameinit);
9343       TREE_CHAIN (varinits) = build_tree_list ((field = TREE_CHAIN (field)),
9344                                                addrinit);
9345       TREE_CHAIN (TREE_CHAIN (varinits))
9346         = build_tree_list ((field = TREE_CHAIN (field)), dimsinit);
9347       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (varinits)))
9348         = build_tree_list ((field = TREE_CHAIN (field)), typeinit);
9349
9350       varinits = build (CONSTRUCTOR, vardesctype, NULL_TREE, varinits);
9351       TREE_CONSTANT (varinits) = 1;
9352       TREE_STATIC (varinits) = 1;
9353
9354       finish_decl (var, varinits, FALSE);
9355
9356       var = ffecom_1 (ADDR_EXPR, build_pointer_type (vardesctype), var);
9357
9358       ffesymbol_hook (s).vardesc_tree = var;
9359     }
9360
9361   return ffesymbol_hook (s).vardesc_tree;
9362 }
9363
9364 static tree
9365 ffecom_vardesc_array_ (ffesymbol s)
9366 {
9367   ffebld b;
9368   tree list;
9369   tree item = NULL_TREE;
9370   tree var;
9371   int i;
9372   static int mynumber = 0;
9373
9374   for (i = 0, list = NULL_TREE, b = ffesymbol_namelist (s);
9375        b != NULL;
9376        b = ffebld_trail (b), ++i)
9377     {
9378       tree t;
9379
9380       t = ffecom_vardesc_ (ffebld_head (b));
9381
9382       if (list == NULL_TREE)
9383         list = item = build_tree_list (NULL_TREE, t);
9384       else
9385         {
9386           TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9387           item = TREE_CHAIN (item);
9388         }
9389     }
9390
9391   item = build_array_type (build_pointer_type (ffecom_type_vardesc_ ()),
9392                            build_range_type (integer_type_node,
9393                                              integer_one_node,
9394                                              build_int_2 (i, 0)));
9395   list = build (CONSTRUCTOR, item, NULL_TREE, list);
9396   TREE_CONSTANT (list) = 1;
9397   TREE_STATIC (list) = 1;
9398
9399   var = ffecom_get_invented_identifier ("__g77_vardesc_array_%d", mynumber++);
9400   var = build_decl (VAR_DECL, var, item);
9401   TREE_STATIC (var) = 1;
9402   DECL_INITIAL (var) = error_mark_node;
9403   var = start_decl (var, FALSE);
9404   finish_decl (var, list, FALSE);
9405
9406   return var;
9407 }
9408
9409 static tree
9410 ffecom_vardesc_dims_ (ffesymbol s)
9411 {
9412   if (ffesymbol_dims (s) == NULL)
9413     return convert (ffecom_f2c_ptr_to_ftnlen_type_node,
9414                     integer_zero_node);
9415
9416   {
9417     ffebld b;
9418     ffebld e;
9419     tree list;
9420     tree backlist;
9421     tree item = NULL_TREE;
9422     tree var;
9423     tree numdim;
9424     tree numelem;
9425     tree baseoff = NULL_TREE;
9426     static int mynumber = 0;
9427
9428     numdim = build_int_2 ((int) ffesymbol_rank (s), 0);
9429     TREE_TYPE (numdim) = ffecom_f2c_ftnlen_type_node;
9430
9431     numelem = ffecom_expr (ffesymbol_arraysize (s));
9432     TREE_TYPE (numelem) = ffecom_f2c_ftnlen_type_node;
9433
9434     list = NULL_TREE;
9435     backlist = NULL_TREE;
9436     for (b = ffesymbol_dims (s), e = ffesymbol_extents (s);
9437          b != NULL;
9438          b = ffebld_trail (b), e = ffebld_trail (e))
9439       {
9440         tree t;
9441         tree low;
9442         tree back;
9443
9444         if (ffebld_trail (b) == NULL)
9445           t = NULL_TREE;
9446         else
9447           {
9448             t = convert (ffecom_f2c_ftnlen_type_node,
9449                          ffecom_expr (ffebld_head (e)));
9450
9451             if (list == NULL_TREE)
9452               list = item = build_tree_list (NULL_TREE, t);
9453             else
9454               {
9455                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9456                 item = TREE_CHAIN (item);
9457               }
9458           }
9459
9460         if (ffebld_left (ffebld_head (b)) == NULL)
9461           low = ffecom_integer_one_node;
9462         else
9463           low = ffecom_expr (ffebld_left (ffebld_head (b)));
9464         low = convert (ffecom_f2c_ftnlen_type_node, low);
9465
9466         back = build_tree_list (low, t);
9467         TREE_CHAIN (back) = backlist;
9468         backlist = back;
9469       }
9470
9471     for (item = backlist; item != NULL_TREE; item = TREE_CHAIN (item))
9472       {
9473         if (TREE_VALUE (item) == NULL_TREE)
9474           baseoff = TREE_PURPOSE (item);
9475         else
9476           baseoff = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
9477                               TREE_PURPOSE (item),
9478                               ffecom_2 (MULT_EXPR,
9479                                         ffecom_f2c_ftnlen_type_node,
9480                                         TREE_VALUE (item),
9481                                         baseoff));
9482       }
9483
9484     /* backlist now dead, along with all TREE_PURPOSEs on it.  */
9485
9486     baseoff = build_tree_list (NULL_TREE, baseoff);
9487     TREE_CHAIN (baseoff) = list;
9488
9489     numelem = build_tree_list (NULL_TREE, numelem);
9490     TREE_CHAIN (numelem) = baseoff;
9491
9492     numdim = build_tree_list (NULL_TREE, numdim);
9493     TREE_CHAIN (numdim) = numelem;
9494
9495     item = build_array_type (ffecom_f2c_ftnlen_type_node,
9496                              build_range_type (integer_type_node,
9497                                                integer_zero_node,
9498                                                build_int_2
9499                                                ((int) ffesymbol_rank (s)
9500                                                 + 2, 0)));
9501     list = build (CONSTRUCTOR, item, NULL_TREE, numdim);
9502     TREE_CONSTANT (list) = 1;
9503     TREE_STATIC (list) = 1;
9504
9505     var = ffecom_get_invented_identifier ("__g77_dims_%d", mynumber++);
9506     var = build_decl (VAR_DECL, var, item);
9507     TREE_STATIC (var) = 1;
9508     DECL_INITIAL (var) = error_mark_node;
9509     var = start_decl (var, FALSE);
9510     finish_decl (var, list, FALSE);
9511
9512     var = ffecom_1 (ADDR_EXPR, build_pointer_type (item), var);
9513
9514     return var;
9515   }
9516 }
9517
9518 /* Essentially does a "fold (build1 (code, type, node))" while checking
9519    for certain housekeeping things.
9520
9521    NOTE: for building an ADDR_EXPR around a FUNCTION_DECL, use
9522    ffecom_1_fn instead.  */
9523
9524 tree
9525 ffecom_1 (enum tree_code code, tree type, tree node)
9526 {
9527   tree item;
9528
9529   if ((node == error_mark_node)
9530       || (type == error_mark_node))
9531     return error_mark_node;
9532
9533   if (code == ADDR_EXPR)
9534     {
9535       if (!ffe_mark_addressable (node))
9536         assert ("can't mark_addressable this node!" == NULL);
9537     }
9538
9539   switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9540     {
9541       tree realtype;
9542
9543     case REALPART_EXPR:
9544       item = build (COMPONENT_REF, type, node, TYPE_FIELDS (TREE_TYPE (node)));
9545       break;
9546
9547     case IMAGPART_EXPR:
9548       item = build (COMPONENT_REF, type, node, TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (node))));
9549       break;
9550
9551
9552     case NEGATE_EXPR:
9553       if (TREE_CODE (type) != RECORD_TYPE)
9554         {
9555           item = build1 (code, type, node);
9556           break;
9557         }
9558       node = ffecom_stabilize_aggregate_ (node);
9559       realtype = TREE_TYPE (TYPE_FIELDS (type));
9560       item =
9561         ffecom_2 (COMPLEX_EXPR, type,
9562                   ffecom_1 (NEGATE_EXPR, realtype,
9563                             ffecom_1 (REALPART_EXPR, realtype,
9564                                       node)),
9565                   ffecom_1 (NEGATE_EXPR, realtype,
9566                             ffecom_1 (IMAGPART_EXPR, realtype,
9567                                       node)));
9568       break;
9569
9570     default:
9571       item = build1 (code, type, node);
9572       break;
9573     }
9574
9575   if (TREE_SIDE_EFFECTS (node))
9576     TREE_SIDE_EFFECTS (item) = 1;
9577   if (code == ADDR_EXPR && staticp (node))
9578     TREE_CONSTANT (item) = 1;
9579   else if (code == INDIRECT_REF)
9580     TREE_READONLY (item) = TYPE_READONLY (type);
9581   return fold (item);
9582 }
9583
9584 /* Like ffecom_1 (ADDR_EXPR, TREE_TYPE (node), node), except
9585    handles TREE_CODE (node) == FUNCTION_DECL.  In particular,
9586    does not set TREE_ADDRESSABLE (because calling an inline
9587    function does not mean the function needs to be separately
9588    compiled).  */
9589
9590 tree
9591 ffecom_1_fn (tree node)
9592 {
9593   tree item;
9594   tree type;
9595
9596   if (node == error_mark_node)
9597     return error_mark_node;
9598
9599   type = build_type_variant (TREE_TYPE (node),
9600                              TREE_READONLY (node),
9601                              TREE_THIS_VOLATILE (node));
9602   item = build1 (ADDR_EXPR,
9603                  build_pointer_type (type), node);
9604   if (TREE_SIDE_EFFECTS (node))
9605     TREE_SIDE_EFFECTS (item) = 1;
9606   if (staticp (node))
9607     TREE_CONSTANT (item) = 1;
9608   return fold (item);
9609 }
9610
9611 /* Essentially does a "fold (build (code, type, node1, node2))" while
9612    checking for certain housekeeping things.  */
9613
9614 tree
9615 ffecom_2 (enum tree_code code, tree type, tree node1,
9616           tree node2)
9617 {
9618   tree item;
9619
9620   if ((node1 == error_mark_node)
9621       || (node2 == error_mark_node)
9622       || (type == error_mark_node))
9623     return error_mark_node;
9624
9625   switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9626     {
9627       tree a, b, c, d, realtype;
9628
9629     case CONJ_EXPR:
9630       assert ("no CONJ_EXPR support yet" == NULL);
9631       return error_mark_node;
9632
9633     case COMPLEX_EXPR:
9634       item = build_tree_list (TYPE_FIELDS (type), node1);
9635       TREE_CHAIN (item) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), node2);
9636       item = build (CONSTRUCTOR, type, NULL_TREE, item);
9637       break;
9638
9639     case PLUS_EXPR:
9640       if (TREE_CODE (type) != RECORD_TYPE)
9641         {
9642           item = build (code, type, node1, node2);
9643           break;
9644         }
9645       node1 = ffecom_stabilize_aggregate_ (node1);
9646       node2 = ffecom_stabilize_aggregate_ (node2);
9647       realtype = TREE_TYPE (TYPE_FIELDS (type));
9648       item =
9649         ffecom_2 (COMPLEX_EXPR, type,
9650                   ffecom_2 (PLUS_EXPR, realtype,
9651                             ffecom_1 (REALPART_EXPR, realtype,
9652                                       node1),
9653                             ffecom_1 (REALPART_EXPR, realtype,
9654                                       node2)),
9655                   ffecom_2 (PLUS_EXPR, realtype,
9656                             ffecom_1 (IMAGPART_EXPR, realtype,
9657                                       node1),
9658                             ffecom_1 (IMAGPART_EXPR, realtype,
9659                                       node2)));
9660       break;
9661
9662     case MINUS_EXPR:
9663       if (TREE_CODE (type) != RECORD_TYPE)
9664         {
9665           item = build (code, type, node1, node2);
9666           break;
9667         }
9668       node1 = ffecom_stabilize_aggregate_ (node1);
9669       node2 = ffecom_stabilize_aggregate_ (node2);
9670       realtype = TREE_TYPE (TYPE_FIELDS (type));
9671       item =
9672         ffecom_2 (COMPLEX_EXPR, type,
9673                   ffecom_2 (MINUS_EXPR, realtype,
9674                             ffecom_1 (REALPART_EXPR, realtype,
9675                                       node1),
9676                             ffecom_1 (REALPART_EXPR, realtype,
9677                                       node2)),
9678                   ffecom_2 (MINUS_EXPR, realtype,
9679                             ffecom_1 (IMAGPART_EXPR, realtype,
9680                                       node1),
9681                             ffecom_1 (IMAGPART_EXPR, realtype,
9682                                       node2)));
9683       break;
9684
9685     case MULT_EXPR:
9686       if (TREE_CODE (type) != RECORD_TYPE)
9687         {
9688           item = build (code, type, node1, node2);
9689           break;
9690         }
9691       node1 = ffecom_stabilize_aggregate_ (node1);
9692       node2 = ffecom_stabilize_aggregate_ (node2);
9693       realtype = TREE_TYPE (TYPE_FIELDS (type));
9694       a = save_expr (ffecom_1 (REALPART_EXPR, realtype,
9695                                node1));
9696       b = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
9697                                node1));
9698       c = save_expr (ffecom_1 (REALPART_EXPR, realtype,
9699                                node2));
9700       d = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
9701                                node2));
9702       item =
9703         ffecom_2 (COMPLEX_EXPR, type,
9704                   ffecom_2 (MINUS_EXPR, realtype,
9705                             ffecom_2 (MULT_EXPR, realtype,
9706                                       a,
9707                                       c),
9708                             ffecom_2 (MULT_EXPR, realtype,
9709                                       b,
9710                                       d)),
9711                   ffecom_2 (PLUS_EXPR, realtype,
9712                             ffecom_2 (MULT_EXPR, realtype,
9713                                       a,
9714                                       d),
9715                             ffecom_2 (MULT_EXPR, realtype,
9716                                       c,
9717                                       b)));
9718       break;
9719
9720     case EQ_EXPR:
9721       if ((TREE_CODE (node1) != RECORD_TYPE)
9722           && (TREE_CODE (node2) != RECORD_TYPE))
9723         {
9724           item = build (code, type, node1, node2);
9725           break;
9726         }
9727       assert (TREE_CODE (node1) == RECORD_TYPE);
9728       assert (TREE_CODE (node2) == RECORD_TYPE);
9729       node1 = ffecom_stabilize_aggregate_ (node1);
9730       node2 = ffecom_stabilize_aggregate_ (node2);
9731       realtype = TREE_TYPE (TYPE_FIELDS (type));
9732       item =
9733         ffecom_2 (TRUTH_ANDIF_EXPR, type,
9734                   ffecom_2 (code, type,
9735                             ffecom_1 (REALPART_EXPR, realtype,
9736                                       node1),
9737                             ffecom_1 (REALPART_EXPR, realtype,
9738                                       node2)),
9739                   ffecom_2 (code, type,
9740                             ffecom_1 (IMAGPART_EXPR, realtype,
9741                                       node1),
9742                             ffecom_1 (IMAGPART_EXPR, realtype,
9743                                       node2)));
9744       break;
9745
9746     case NE_EXPR:
9747       if ((TREE_CODE (node1) != RECORD_TYPE)
9748           && (TREE_CODE (node2) != RECORD_TYPE))
9749         {
9750           item = build (code, type, node1, node2);
9751           break;
9752         }
9753       assert (TREE_CODE (node1) == RECORD_TYPE);
9754       assert (TREE_CODE (node2) == RECORD_TYPE);
9755       node1 = ffecom_stabilize_aggregate_ (node1);
9756       node2 = ffecom_stabilize_aggregate_ (node2);
9757       realtype = TREE_TYPE (TYPE_FIELDS (type));
9758       item =
9759         ffecom_2 (TRUTH_ORIF_EXPR, type,
9760                   ffecom_2 (code, type,
9761                             ffecom_1 (REALPART_EXPR, realtype,
9762                                       node1),
9763                             ffecom_1 (REALPART_EXPR, realtype,
9764                                       node2)),
9765                   ffecom_2 (code, type,
9766                             ffecom_1 (IMAGPART_EXPR, realtype,
9767                                       node1),
9768                             ffecom_1 (IMAGPART_EXPR, realtype,
9769                                       node2)));
9770       break;
9771
9772     default:
9773       item = build (code, type, node1, node2);
9774       break;
9775     }
9776
9777   if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2))
9778     TREE_SIDE_EFFECTS (item) = 1;
9779   return fold (item);
9780 }
9781
9782 /* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint
9783
9784    ffesymbol s;  // the ENTRY point itself
9785    if (ffecom_2pass_advise_entrypoint(s))
9786        // the ENTRY point has been accepted
9787
9788    Does whatever compiler needs to do when it learns about the entrypoint,
9789    like determine the return type of the master function, count the
9790    number of entrypoints, etc.  Returns FALSE if the return type is
9791    not compatible with the return type(s) of other entrypoint(s).
9792
9793    NOTE: for every call to this fn that returns TRUE, _do_entrypoint must
9794    later (after _finish_progunit) be called with the same entrypoint(s)
9795    as passed to this fn for which TRUE was returned.
9796
9797    03-Jan-92  JCB  2.0
9798       Return FALSE if the return type conflicts with previous entrypoints.  */
9799
9800 bool
9801 ffecom_2pass_advise_entrypoint (ffesymbol entry)
9802 {
9803   ffebld list;                  /* opITEM. */
9804   ffebld mlist;                 /* opITEM. */
9805   ffebld plist;                 /* opITEM. */
9806   ffebld arg;                   /* ffebld_head(opITEM). */
9807   ffebld item;                  /* opITEM. */
9808   ffesymbol s;                  /* ffebld_symter(arg). */
9809   ffeinfoBasictype bt = ffesymbol_basictype (entry);
9810   ffeinfoKindtype kt = ffesymbol_kindtype (entry);
9811   ffetargetCharacterSize size = ffesymbol_size (entry);
9812   bool ok;
9813
9814   if (ffecom_num_entrypoints_ == 0)
9815     {                           /* First entrypoint, make list of main
9816                                    arglist's dummies. */
9817       assert (ffecom_primary_entry_ != NULL);
9818
9819       ffecom_master_bt_ = ffesymbol_basictype (ffecom_primary_entry_);
9820       ffecom_master_kt_ = ffesymbol_kindtype (ffecom_primary_entry_);
9821       ffecom_master_size_ = ffesymbol_size (ffecom_primary_entry_);
9822
9823       for (plist = NULL, list = ffesymbol_dummyargs (ffecom_primary_entry_);
9824            list != NULL;
9825            list = ffebld_trail (list))
9826         {
9827           arg = ffebld_head (list);
9828           if (ffebld_op (arg) != FFEBLD_opSYMTER)
9829             continue;           /* Alternate return or some such thing. */
9830           item = ffebld_new_item (arg, NULL);
9831           if (plist == NULL)
9832             ffecom_master_arglist_ = item;
9833           else
9834             ffebld_set_trail (plist, item);
9835           plist = item;
9836         }
9837     }
9838
9839   /* If necessary, scan entry arglist for alternate returns.  Do this scan
9840      apparently redundantly (it's done below to UNIONize the arglists) so
9841      that we don't complain about RETURN 1 if an offending ENTRY is the only
9842      one with an alternate return.  */
9843
9844   if (!ffecom_is_altreturning_)
9845     {
9846       for (list = ffesymbol_dummyargs (entry);
9847            list != NULL;
9848            list = ffebld_trail (list))
9849         {
9850           arg = ffebld_head (list);
9851           if (ffebld_op (arg) == FFEBLD_opSTAR)
9852             {
9853               ffecom_is_altreturning_ = TRUE;
9854               break;
9855             }
9856         }
9857     }
9858
9859   /* Now check type compatibility. */
9860
9861   switch (ffecom_master_bt_)
9862     {
9863     case FFEINFO_basictypeNONE:
9864       ok = (bt != FFEINFO_basictypeCHARACTER);
9865       break;
9866
9867     case FFEINFO_basictypeCHARACTER:
9868       ok
9869         = (bt == FFEINFO_basictypeCHARACTER)
9870         && (kt == ffecom_master_kt_)
9871         && (size == ffecom_master_size_);
9872       break;
9873
9874     case FFEINFO_basictypeANY:
9875       return FALSE;             /* Just don't bother. */
9876
9877     default:
9878       if (bt == FFEINFO_basictypeCHARACTER)
9879         {
9880           ok = FALSE;
9881           break;
9882         }
9883       ok = TRUE;
9884       if ((bt != ffecom_master_bt_) || (kt != ffecom_master_kt_))
9885         {
9886           ffecom_master_bt_ = FFEINFO_basictypeNONE;
9887           ffecom_master_kt_ = FFEINFO_kindtypeNONE;
9888         }
9889       break;
9890     }
9891
9892   if (!ok)
9893     {
9894       ffebad_start (FFEBAD_ENTRY_CONFLICTS);
9895       ffest_ffebad_here_current_stmt (0);
9896       ffebad_finish ();
9897       return FALSE;             /* Can't handle entrypoint. */
9898     }
9899
9900   /* Entrypoint type compatible with previous types. */
9901
9902   ++ffecom_num_entrypoints_;
9903
9904   /* Master-arg-list = UNION(Master-arg-list,entry-arg-list). */
9905
9906   for (list = ffesymbol_dummyargs (entry);
9907        list != NULL;
9908        list = ffebld_trail (list))
9909     {
9910       arg = ffebld_head (list);
9911       if (ffebld_op (arg) != FFEBLD_opSYMTER)
9912         continue;               /* Alternate return or some such thing. */
9913       s = ffebld_symter (arg);
9914       for (plist = NULL, mlist = ffecom_master_arglist_;
9915            mlist != NULL;
9916            plist = mlist, mlist = ffebld_trail (mlist))
9917         {                       /* plist points to previous item for easy
9918                                    appending of arg. */
9919           if (ffebld_symter (ffebld_head (mlist)) == s)
9920             break;              /* Already have this arg in the master list. */
9921         }
9922       if (mlist != NULL)
9923         continue;               /* Already have this arg in the master list. */
9924
9925       /* Append this arg to the master list. */
9926
9927       item = ffebld_new_item (arg, NULL);
9928       if (plist == NULL)
9929         ffecom_master_arglist_ = item;
9930       else
9931         ffebld_set_trail (plist, item);
9932     }
9933
9934   return TRUE;
9935 }
9936
9937 /* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint
9938
9939    ffesymbol s;  // the ENTRY point itself
9940    ffecom_2pass_do_entrypoint(s);
9941
9942    Does whatever compiler needs to do to make the entrypoint actually
9943    happen.  Must be called for each entrypoint after
9944    ffecom_finish_progunit is called.  */
9945
9946 void
9947 ffecom_2pass_do_entrypoint (ffesymbol entry)
9948 {
9949   static int mfn_num = 0;
9950   static int ent_num;
9951
9952   if (mfn_num != ffecom_num_fns_)
9953     {                           /* First entrypoint for this program unit. */
9954       ent_num = 1;
9955       mfn_num = ffecom_num_fns_;
9956       ffecom_do_entry_ (ffecom_primary_entry_, 0);
9957     }
9958   else
9959     ++ent_num;
9960
9961   --ffecom_num_entrypoints_;
9962
9963   ffecom_do_entry_ (entry, ent_num);
9964 }
9965
9966 /* Essentially does a "fold (build (code, type, node1, node2))" while
9967    checking for certain housekeeping things.  Always sets
9968    TREE_SIDE_EFFECTS.  */
9969
9970 tree
9971 ffecom_2s (enum tree_code code, tree type, tree node1,
9972            tree node2)
9973 {
9974   tree item;
9975
9976   if ((node1 == error_mark_node)
9977       || (node2 == error_mark_node)
9978       || (type == error_mark_node))
9979     return error_mark_node;
9980
9981   item = build (code, type, node1, node2);
9982   TREE_SIDE_EFFECTS (item) = 1;
9983   return fold (item);
9984 }
9985
9986 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
9987    checking for certain housekeeping things.  */
9988
9989 tree
9990 ffecom_3 (enum tree_code code, tree type, tree node1,
9991           tree node2, tree node3)
9992 {
9993   tree item;
9994
9995   if ((node1 == error_mark_node)
9996       || (node2 == error_mark_node)
9997       || (node3 == error_mark_node)
9998       || (type == error_mark_node))
9999     return error_mark_node;
10000
10001   item = build (code, type, node1, node2, node3);
10002   if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2)
10003       || (node3 != NULL_TREE && TREE_SIDE_EFFECTS (node3)))
10004     TREE_SIDE_EFFECTS (item) = 1;
10005   return fold (item);
10006 }
10007
10008 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10009    checking for certain housekeeping things.  Always sets
10010    TREE_SIDE_EFFECTS.  */
10011
10012 tree
10013 ffecom_3s (enum tree_code code, tree type, tree node1,
10014            tree node2, tree node3)
10015 {
10016   tree item;
10017
10018   if ((node1 == error_mark_node)
10019       || (node2 == error_mark_node)
10020       || (node3 == error_mark_node)
10021       || (type == error_mark_node))
10022     return error_mark_node;
10023
10024   item = build (code, type, node1, node2, node3);
10025   TREE_SIDE_EFFECTS (item) = 1;
10026   return fold (item);
10027 }
10028
10029 /* ffecom_arg_expr -- Transform argument expr into gcc tree
10030
10031    See use by ffecom_list_expr.
10032
10033    If expression is NULL, returns an integer zero tree.  If it is not
10034    a CHARACTER expression, returns whatever ffecom_expr
10035    returns and sets the length return value to NULL_TREE.  Otherwise
10036    generates code to evaluate the character expression, returns the proper
10037    pointer to the result, but does NOT set the length return value to a tree
10038    that specifies the length of the result.  (In other words, the length
10039    variable is always set to NULL_TREE, because a length is never passed.)
10040
10041    21-Dec-91  JCB  1.1
10042       Don't set returned length, since nobody needs it (yet; someday if
10043       we allow CHARACTER*(*) dummies to statement functions, we'll need
10044       it).  */
10045
10046 tree
10047 ffecom_arg_expr (ffebld expr, tree *length)
10048 {
10049   tree ign;
10050
10051   *length = NULL_TREE;
10052
10053   if (expr == NULL)
10054     return integer_zero_node;
10055
10056   if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10057     return ffecom_expr (expr);
10058
10059   return ffecom_arg_ptr_to_expr (expr, &ign);
10060 }
10061
10062 /* Transform expression into constant argument-pointer-to-expression tree.
10063
10064    If the expression can be transformed into a argument-pointer-to-expression
10065    tree that is constant, that is done, and the tree returned.  Else
10066    NULL_TREE is returned.
10067
10068    That way, a caller can attempt to provide compile-time initialization
10069    of a variable and, if that fails, *then* choose to start a new block
10070    and resort to using temporaries, as appropriate.  */
10071
10072 tree
10073 ffecom_arg_ptr_to_const_expr (ffebld expr, tree *length)
10074 {
10075   if (! expr)
10076     return integer_zero_node;
10077
10078   if (ffebld_op (expr) == FFEBLD_opANY)
10079     {
10080       if (length)
10081         *length = error_mark_node;
10082       return error_mark_node;
10083     }
10084
10085   if (ffebld_arity (expr) == 0
10086       && (ffebld_op (expr) != FFEBLD_opSYMTER
10087           || ffebld_where (expr) == FFEINFO_whereCOMMON
10088           || ffebld_where (expr) == FFEINFO_whereGLOBAL
10089           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10090     {
10091       tree t;
10092
10093       t = ffecom_arg_ptr_to_expr (expr, length);
10094       assert (TREE_CONSTANT (t));
10095       assert (! length || TREE_CONSTANT (*length));
10096       return t;
10097     }
10098
10099   if (length
10100       && ffebld_size (expr) != FFETARGET_charactersizeNONE)
10101     *length = build_int_2 (ffebld_size (expr), 0);
10102   else if (length)
10103     *length = NULL_TREE;
10104   return NULL_TREE;
10105 }
10106
10107 /* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree
10108
10109    See use by ffecom_list_ptr_to_expr.
10110
10111    If expression is NULL, returns an integer zero tree.  If it is not
10112    a CHARACTER expression, returns whatever ffecom_ptr_to_expr
10113    returns and sets the length return value to NULL_TREE.  Otherwise
10114    generates code to evaluate the character expression, returns the proper
10115    pointer to the result, AND sets the length return value to a tree that
10116    specifies the length of the result.
10117
10118    If the length argument is NULL, this is a slightly special
10119    case of building a FORMAT expression, that is, an expression that
10120    will be used at run time without regard to length.  For the current
10121    implementation, which uses the libf2c library, this means it is nice
10122    to append a null byte to the end of the expression, where feasible,
10123    to make sure any diagnostic about the FORMAT string terminates at
10124    some useful point.
10125
10126    For now, treat %REF(char-expr) as the same as char-expr with a NULL
10127    length argument.  This might even be seen as a feature, if a null
10128    byte can always be appended.  */
10129
10130 tree
10131 ffecom_arg_ptr_to_expr (ffebld expr, tree *length)
10132 {
10133   tree item;
10134   tree ign_length;
10135   ffecomConcatList_ catlist;
10136
10137   if (length != NULL)
10138     *length = NULL_TREE;
10139
10140   if (expr == NULL)
10141     return integer_zero_node;
10142
10143   switch (ffebld_op (expr))
10144     {
10145     case FFEBLD_opPERCENT_VAL:
10146       if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10147         return ffecom_expr (ffebld_left (expr));
10148       {
10149         tree temp_exp;
10150         tree temp_length;
10151
10152         temp_exp = ffecom_arg_ptr_to_expr (ffebld_left (expr), &temp_length);
10153         if (temp_exp == error_mark_node)
10154           return error_mark_node;
10155
10156         return ffecom_1 (INDIRECT_REF, TREE_TYPE (TREE_TYPE (temp_exp)),
10157                          temp_exp);
10158       }
10159
10160     case FFEBLD_opPERCENT_REF:
10161       if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10162         return ffecom_ptr_to_expr (ffebld_left (expr));
10163       if (length != NULL)
10164         {
10165           ign_length = NULL_TREE;
10166           length = &ign_length;
10167         }
10168       expr = ffebld_left (expr);
10169       break;
10170
10171     case FFEBLD_opPERCENT_DESCR:
10172       switch (ffeinfo_basictype (ffebld_info (expr)))
10173         {
10174 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10175         case FFEINFO_basictypeHOLLERITH:
10176 #endif
10177         case FFEINFO_basictypeCHARACTER:
10178           break;                /* Passed by descriptor anyway. */
10179
10180         default:
10181           item = ffecom_ptr_to_expr (expr);
10182           if (item != error_mark_node)
10183             *length = TYPE_SIZE (TREE_TYPE (TREE_TYPE (item)));
10184           break;
10185         }
10186       break;
10187
10188     default:
10189       break;
10190     }
10191
10192 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10193   if ((ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeHOLLERITH)
10194       && (length != NULL))
10195     {                           /* Pass Hollerith by descriptor. */
10196       ffetargetHollerith h;
10197
10198       assert (ffebld_op (expr) == FFEBLD_opCONTER);
10199       h = ffebld_cu_val_hollerith (ffebld_constant_union
10200                                    (ffebld_conter (expr)));
10201       *length
10202         = build_int_2 (h.length, 0);
10203       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10204     }
10205 #endif
10206
10207   if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10208     return ffecom_ptr_to_expr (expr);
10209
10210   assert (ffeinfo_kindtype (ffebld_info (expr))
10211           == FFEINFO_kindtypeCHARACTER1);
10212
10213   while (ffebld_op (expr) == FFEBLD_opPAREN)
10214     expr = ffebld_left (expr);
10215
10216   catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
10217   switch (ffecom_concat_list_count_ (catlist))
10218     {
10219     case 0:                     /* Shouldn't happen, but in case it does... */
10220       if (length != NULL)
10221         {
10222           *length = ffecom_f2c_ftnlen_zero_node;
10223           TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10224         }
10225       ffecom_concat_list_kill_ (catlist);
10226       return null_pointer_node;
10227
10228     case 1:                     /* The (fairly) easy case. */
10229       if (length == NULL)
10230         ffecom_char_args_with_null_ (&item, &ign_length,
10231                                      ffecom_concat_list_expr_ (catlist, 0));
10232       else
10233         ffecom_char_args_ (&item, length,
10234                            ffecom_concat_list_expr_ (catlist, 0));
10235       ffecom_concat_list_kill_ (catlist);
10236       assert (item != NULL_TREE);
10237       return item;
10238
10239     default:                    /* Must actually concatenate things. */
10240       break;
10241     }
10242
10243   {
10244     int count = ffecom_concat_list_count_ (catlist);
10245     int i;
10246     tree lengths;
10247     tree items;
10248     tree length_array;
10249     tree item_array;
10250     tree citem;
10251     tree clength;
10252     tree temporary;
10253     tree num;
10254     tree known_length;
10255     ffetargetCharacterSize sz;
10256
10257     sz = ffecom_concat_list_maxlen_ (catlist);
10258     /* ~~Kludge! */
10259     assert (sz != FFETARGET_charactersizeNONE);
10260
10261 #ifdef HOHO
10262     length_array
10263       = lengths
10264       = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
10265                              FFETARGET_charactersizeNONE, count, TRUE);
10266     item_array
10267       = items
10268       = ffecom_push_tempvar (ffecom_f2c_address_type_node,
10269                              FFETARGET_charactersizeNONE, count, TRUE);
10270     temporary = ffecom_push_tempvar (char_type_node,
10271                                      sz, -1, TRUE);
10272 #else
10273     {
10274       tree hook;
10275
10276       hook = ffebld_nonter_hook (expr);
10277       assert (hook);
10278       assert (TREE_CODE (hook) == TREE_VEC);
10279       assert (TREE_VEC_LENGTH (hook) == 3);
10280       length_array = lengths = TREE_VEC_ELT (hook, 0);
10281       item_array = items = TREE_VEC_ELT (hook, 1);
10282       temporary = TREE_VEC_ELT (hook, 2);
10283     }
10284 #endif
10285
10286     known_length = ffecom_f2c_ftnlen_zero_node;
10287
10288     for (i = 0; i < count; ++i)
10289       {
10290         if ((i == count)
10291             && (length == NULL))
10292           ffecom_char_args_with_null_ (&citem, &clength,
10293                                        ffecom_concat_list_expr_ (catlist, i));
10294         else
10295           ffecom_char_args_ (&citem, &clength,
10296                              ffecom_concat_list_expr_ (catlist, i));
10297         if ((citem == error_mark_node)
10298             || (clength == error_mark_node))
10299           {
10300             ffecom_concat_list_kill_ (catlist);
10301             *length = error_mark_node;
10302             return error_mark_node;
10303           }
10304
10305         items
10306           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
10307                       ffecom_modify (void_type_node,
10308                                      ffecom_2 (ARRAY_REF,
10309                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
10310                                                item_array,
10311                                                build_int_2 (i, 0)),
10312                                      citem),
10313                       items);
10314         clength = ffecom_save_tree (clength);
10315         if (length != NULL)
10316           known_length
10317             = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
10318                         known_length,
10319                         clength);
10320         lengths
10321           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
10322                       ffecom_modify (void_type_node,
10323                                      ffecom_2 (ARRAY_REF,
10324                    TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
10325                                                length_array,
10326                                                build_int_2 (i, 0)),
10327                                      clength),
10328                       lengths);
10329       }
10330
10331     temporary = ffecom_1 (ADDR_EXPR,
10332                           build_pointer_type (TREE_TYPE (temporary)),
10333                           temporary);
10334
10335     item = build_tree_list (NULL_TREE, temporary);
10336     TREE_CHAIN (item)
10337       = build_tree_list (NULL_TREE,
10338                          ffecom_1 (ADDR_EXPR,
10339                                    build_pointer_type (TREE_TYPE (items)),
10340                                    items));
10341     TREE_CHAIN (TREE_CHAIN (item))
10342       = build_tree_list (NULL_TREE,
10343                          ffecom_1 (ADDR_EXPR,
10344                                    build_pointer_type (TREE_TYPE (lengths)),
10345                                    lengths));
10346     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
10347       = build_tree_list
10348         (NULL_TREE,
10349          ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
10350                    convert (ffecom_f2c_ftnlen_type_node,
10351                             build_int_2 (count, 0))));
10352     num = build_int_2 (sz, 0);
10353     TREE_TYPE (num) = ffecom_f2c_ftnlen_type_node;
10354     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item))))
10355       = build_tree_list (NULL_TREE, num);
10356
10357     item = ffecom_call_gfrt (FFECOM_gfrtCAT, item, NULL_TREE);
10358     TREE_SIDE_EFFECTS (item) = 1;
10359     item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (temporary),
10360                      item,
10361                      temporary);
10362
10363     if (length != NULL)
10364       *length = known_length;
10365   }
10366
10367   ffecom_concat_list_kill_ (catlist);
10368   assert (item != NULL_TREE);
10369   return item;
10370 }
10371
10372 /* Generate call to run-time function.
10373
10374    The first arg is the GNU Fortran Run-Time function index, the second
10375    arg is the list of arguments to pass to it.  Returned is the expression
10376    (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the
10377    result (which may be void).  */
10378
10379 tree
10380 ffecom_call_gfrt (ffecomGfrt ix, tree args, tree hook)
10381 {
10382   return ffecom_call_ (ffecom_gfrt_tree_ (ix),
10383                        ffecom_gfrt_kindtype (ix),
10384                        ffe_is_f2c_library () && ffecom_gfrt_complex_[ix],
10385                        NULL_TREE, args, NULL_TREE, NULL,
10386                        NULL, NULL_TREE, TRUE, hook);
10387 }
10388
10389 /* Transform constant-union to tree.  */
10390
10391 tree
10392 ffecom_constantunion (ffebldConstantUnion *cu, ffeinfoBasictype bt,
10393                       ffeinfoKindtype kt, tree tree_type)
10394 {
10395   tree item;
10396
10397   switch (bt)
10398     {
10399     case FFEINFO_basictypeINTEGER:
10400       {
10401         int val;
10402
10403         switch (kt)
10404           {
10405 #if FFETARGET_okINTEGER1
10406           case FFEINFO_kindtypeINTEGER1:
10407             val = ffebld_cu_val_integer1 (*cu);
10408             break;
10409 #endif
10410
10411 #if FFETARGET_okINTEGER2
10412           case FFEINFO_kindtypeINTEGER2:
10413             val = ffebld_cu_val_integer2 (*cu);
10414             break;
10415 #endif
10416
10417 #if FFETARGET_okINTEGER3
10418           case FFEINFO_kindtypeINTEGER3:
10419             val = ffebld_cu_val_integer3 (*cu);
10420             break;
10421 #endif
10422
10423 #if FFETARGET_okINTEGER4
10424           case FFEINFO_kindtypeINTEGER4:
10425             val = ffebld_cu_val_integer4 (*cu);
10426             break;
10427 #endif
10428
10429           default:
10430             assert ("bad INTEGER constant kind type" == NULL);
10431             /* Fall through. */
10432           case FFEINFO_kindtypeANY:
10433             return error_mark_node;
10434           }
10435         item = build_int_2 (val, (val < 0) ? -1 : 0);
10436         TREE_TYPE (item) = tree_type;
10437       }
10438       break;
10439
10440     case FFEINFO_basictypeLOGICAL:
10441       {
10442         int val;
10443
10444         switch (kt)
10445           {
10446 #if FFETARGET_okLOGICAL1
10447           case FFEINFO_kindtypeLOGICAL1:
10448             val = ffebld_cu_val_logical1 (*cu);
10449             break;
10450 #endif
10451
10452 #if FFETARGET_okLOGICAL2
10453           case FFEINFO_kindtypeLOGICAL2:
10454             val = ffebld_cu_val_logical2 (*cu);
10455             break;
10456 #endif
10457
10458 #if FFETARGET_okLOGICAL3
10459           case FFEINFO_kindtypeLOGICAL3:
10460             val = ffebld_cu_val_logical3 (*cu);
10461             break;
10462 #endif
10463
10464 #if FFETARGET_okLOGICAL4
10465           case FFEINFO_kindtypeLOGICAL4:
10466             val = ffebld_cu_val_logical4 (*cu);
10467             break;
10468 #endif
10469
10470           default:
10471             assert ("bad LOGICAL constant kind type" == NULL);
10472             /* Fall through. */
10473           case FFEINFO_kindtypeANY:
10474             return error_mark_node;
10475           }
10476         item = build_int_2 (val, (val < 0) ? -1 : 0);
10477         TREE_TYPE (item) = tree_type;
10478       }
10479       break;
10480
10481     case FFEINFO_basictypeREAL:
10482       {
10483         REAL_VALUE_TYPE val;
10484
10485         switch (kt)
10486           {
10487 #if FFETARGET_okREAL1
10488           case FFEINFO_kindtypeREAL1:
10489             val = ffetarget_value_real1 (ffebld_cu_val_real1 (*cu));
10490             break;
10491 #endif
10492
10493 #if FFETARGET_okREAL2
10494           case FFEINFO_kindtypeREAL2:
10495             val = ffetarget_value_real2 (ffebld_cu_val_real2 (*cu));
10496             break;
10497 #endif
10498
10499 #if FFETARGET_okREAL3
10500           case FFEINFO_kindtypeREAL3:
10501             val = ffetarget_value_real3 (ffebld_cu_val_real3 (*cu));
10502             break;
10503 #endif
10504
10505 #if FFETARGET_okREAL4
10506           case FFEINFO_kindtypeREAL4:
10507             val = ffetarget_value_real4 (ffebld_cu_val_real4 (*cu));
10508             break;
10509 #endif
10510
10511           default:
10512             assert ("bad REAL constant kind type" == NULL);
10513             /* Fall through. */
10514           case FFEINFO_kindtypeANY:
10515             return error_mark_node;
10516           }
10517         item = build_real (tree_type, val);
10518       }
10519       break;
10520
10521     case FFEINFO_basictypeCOMPLEX:
10522       {
10523         REAL_VALUE_TYPE real;
10524         REAL_VALUE_TYPE imag;
10525         tree el_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
10526
10527         switch (kt)
10528           {
10529 #if FFETARGET_okCOMPLEX1
10530           case FFEINFO_kindtypeREAL1:
10531             real = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).real);
10532             imag = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).imaginary);
10533             break;
10534 #endif
10535
10536 #if FFETARGET_okCOMPLEX2
10537           case FFEINFO_kindtypeREAL2:
10538             real = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).real);
10539             imag = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).imaginary);
10540             break;
10541 #endif
10542
10543 #if FFETARGET_okCOMPLEX3
10544           case FFEINFO_kindtypeREAL3:
10545             real = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).real);
10546             imag = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).imaginary);
10547             break;
10548 #endif
10549
10550 #if FFETARGET_okCOMPLEX4
10551           case FFEINFO_kindtypeREAL4:
10552             real = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).real);
10553             imag = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).imaginary);
10554             break;
10555 #endif
10556
10557           default:
10558             assert ("bad REAL constant kind type" == NULL);
10559             /* Fall through. */
10560           case FFEINFO_kindtypeANY:
10561             return error_mark_node;
10562           }
10563         item = ffecom_build_complex_constant_ (tree_type,
10564                                                build_real (el_type, real),
10565                                                build_real (el_type, imag));
10566       }
10567       break;
10568
10569     case FFEINFO_basictypeCHARACTER:
10570       {                         /* Happens only in DATA and similar contexts. */
10571         ffetargetCharacter1 val;
10572
10573         switch (kt)
10574           {
10575 #if FFETARGET_okCHARACTER1
10576           case FFEINFO_kindtypeLOGICAL1:
10577             val = ffebld_cu_val_character1 (*cu);
10578             break;
10579 #endif
10580
10581           default:
10582             assert ("bad CHARACTER constant kind type" == NULL);
10583             /* Fall through. */
10584           case FFEINFO_kindtypeANY:
10585             return error_mark_node;
10586           }
10587         item = build_string (ffetarget_length_character1 (val),
10588                              ffetarget_text_character1 (val));
10589         TREE_TYPE (item)
10590           = build_type_variant (build_array_type (char_type_node,
10591                                                   build_range_type
10592                                                   (integer_type_node,
10593                                                    integer_one_node,
10594                                                    build_int_2
10595                                                 (ffetarget_length_character1
10596                                                  (val), 0))),
10597                                 1, 0);
10598       }
10599       break;
10600
10601     case FFEINFO_basictypeHOLLERITH:
10602       {
10603         ffetargetHollerith h;
10604
10605         h = ffebld_cu_val_hollerith (*cu);
10606
10607         /* If not at least as wide as default INTEGER, widen it.  */
10608         if (h.length >= FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE)
10609           item = build_string (h.length, h.text);
10610         else
10611           {
10612             char str[FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE];
10613
10614             memcpy (str, h.text, h.length);
10615             memset (&str[h.length], ' ',
10616                     FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE
10617                     - h.length);
10618             item = build_string (FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE,
10619                                  str);
10620           }
10621         TREE_TYPE (item)
10622           = build_type_variant (build_array_type (char_type_node,
10623                                                   build_range_type
10624                                                   (integer_type_node,
10625                                                    integer_one_node,
10626                                                    build_int_2
10627                                                    (h.length, 0))),
10628                                 1, 0);
10629       }
10630       break;
10631
10632     case FFEINFO_basictypeTYPELESS:
10633       {
10634         ffetargetInteger1 ival;
10635         ffetargetTypeless tless;
10636         ffebad error;
10637
10638         tless = ffebld_cu_val_typeless (*cu);
10639         error = ffetarget_convert_integer1_typeless (&ival, tless);
10640         assert (error == FFEBAD);
10641
10642         item = build_int_2 ((int) ival, 0);
10643       }
10644       break;
10645
10646     default:
10647       assert ("not yet on constant type" == NULL);
10648       /* Fall through. */
10649     case FFEINFO_basictypeANY:
10650       return error_mark_node;
10651     }
10652
10653   TREE_CONSTANT (item) = 1;
10654
10655   return item;
10656 }
10657
10658 /* Transform expression into constant tree.
10659
10660    If the expression can be transformed into a tree that is constant,
10661    that is done, and the tree returned.  Else NULL_TREE is returned.
10662
10663    That way, a caller can attempt to provide compile-time initialization
10664    of a variable and, if that fails, *then* choose to start a new block
10665    and resort to using temporaries, as appropriate.  */
10666
10667 tree
10668 ffecom_const_expr (ffebld expr)
10669 {
10670   if (! expr)
10671     return integer_zero_node;
10672
10673   if (ffebld_op (expr) == FFEBLD_opANY)
10674     return error_mark_node;
10675
10676   if (ffebld_arity (expr) == 0
10677       && (ffebld_op (expr) != FFEBLD_opSYMTER
10678 #if NEWCOMMON
10679           /* ~~Enable once common/equivalence is handled properly?  */
10680           || ffebld_where (expr) == FFEINFO_whereCOMMON
10681 #endif
10682           || ffebld_where (expr) == FFEINFO_whereGLOBAL
10683           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10684     {
10685       tree t;
10686
10687       t = ffecom_expr (expr);
10688       assert (TREE_CONSTANT (t));
10689       return t;
10690     }
10691
10692   return NULL_TREE;
10693 }
10694
10695 /* Handy way to make a field in a struct/union.  */
10696
10697 tree
10698 ffecom_decl_field (tree context, tree prevfield,
10699                    const char *name, tree type)
10700 {
10701   tree field;
10702
10703   field = build_decl (FIELD_DECL, get_identifier (name), type);
10704   DECL_CONTEXT (field) = context;
10705   DECL_ALIGN (field) = 0;
10706   DECL_USER_ALIGN (field) = 0;
10707   if (prevfield != NULL_TREE)
10708     TREE_CHAIN (prevfield) = field;
10709
10710   return field;
10711 }
10712
10713 void
10714 ffecom_close_include (FILE *f)
10715 {
10716   ffecom_close_include_ (f);
10717 }
10718
10719 int
10720 ffecom_decode_include_option (char *spec)
10721 {
10722   return ffecom_decode_include_option_ (spec);
10723 }
10724
10725 /* End a compound statement (block).  */
10726
10727 tree
10728 ffecom_end_compstmt (void)
10729 {
10730   return bison_rule_compstmt_ ();
10731 }
10732
10733 /* ffecom_end_transition -- Perform end transition on all symbols
10734
10735    ffecom_end_transition();
10736
10737    Calls ffecom_sym_end_transition for each global and local symbol.  */
10738
10739 void
10740 ffecom_end_transition ()
10741 {
10742   ffebld item;
10743
10744   if (ffe_is_ffedebug ())
10745     fprintf (dmpout, "; end_stmt_transition\n");
10746
10747   ffecom_list_blockdata_ = NULL;
10748   ffecom_list_common_ = NULL;
10749
10750   ffesymbol_drive (ffecom_sym_end_transition);
10751   if (ffe_is_ffedebug ())
10752     {
10753       ffestorag_report ();
10754     }
10755
10756   ffecom_start_progunit_ ();
10757
10758   for (item = ffecom_list_blockdata_;
10759        item != NULL;
10760        item = ffebld_trail (item))
10761     {
10762       ffebld callee;
10763       ffesymbol s;
10764       tree dt;
10765       tree t;
10766       tree var;
10767       static int number = 0;
10768
10769       callee = ffebld_head (item);
10770       s = ffebld_symter (callee);
10771       t = ffesymbol_hook (s).decl_tree;
10772       if (t == NULL_TREE)
10773         {
10774           s = ffecom_sym_transform_ (s);
10775           t = ffesymbol_hook (s).decl_tree;
10776         }
10777
10778       dt = build_pointer_type (TREE_TYPE (t));
10779
10780       var = build_decl (VAR_DECL,
10781                         ffecom_get_invented_identifier ("__g77_forceload_%d",
10782                                                         number++),
10783                         dt);
10784       DECL_EXTERNAL (var) = 0;
10785       TREE_STATIC (var) = 1;
10786       TREE_PUBLIC (var) = 0;
10787       DECL_INITIAL (var) = error_mark_node;
10788       TREE_USED (var) = 1;
10789
10790       var = start_decl (var, FALSE);
10791
10792       t = ffecom_1 (ADDR_EXPR, dt, t);
10793
10794       finish_decl (var, t, FALSE);
10795     }
10796
10797   /* This handles any COMMON areas that weren't referenced but have, for
10798      example, important initial data.  */
10799
10800   for (item = ffecom_list_common_;
10801        item != NULL;
10802        item = ffebld_trail (item))
10803     ffecom_transform_common_ (ffebld_symter (ffebld_head (item)));
10804
10805   ffecom_list_common_ = NULL;
10806 }
10807
10808 /* ffecom_exec_transition -- Perform exec transition on all symbols
10809
10810    ffecom_exec_transition();
10811
10812    Calls ffecom_sym_exec_transition for each global and local symbol.
10813    Make sure error updating not inhibited.  */
10814
10815 void
10816 ffecom_exec_transition ()
10817 {
10818   bool inhibited;
10819
10820   if (ffe_is_ffedebug ())
10821     fprintf (dmpout, "; exec_stmt_transition\n");
10822
10823   inhibited = ffebad_inhibit ();
10824   ffebad_set_inhibit (FALSE);
10825
10826   ffesymbol_drive (ffecom_sym_exec_transition); /* Don't retract! */
10827   ffeequiv_exec_transition ();  /* Handle all pending EQUIVALENCEs. */
10828   if (ffe_is_ffedebug ())
10829     {
10830       ffestorag_report ();
10831     }
10832
10833   if (inhibited)
10834     ffebad_set_inhibit (TRUE);
10835 }
10836
10837 /* Handle assignment statement.
10838
10839    Convert dest and source using ffecom_expr, then join them
10840    with an ASSIGN op and pass the whole thing to expand_expr_stmt.  */
10841
10842 void
10843 ffecom_expand_let_stmt (ffebld dest, ffebld source)
10844 {
10845   tree dest_tree;
10846   tree dest_length;
10847   tree source_tree;
10848   tree expr_tree;
10849
10850   if (ffeinfo_basictype (ffebld_info (dest)) != FFEINFO_basictypeCHARACTER)
10851     {
10852       bool dest_used;
10853       tree assign_temp;
10854
10855       /* This attempts to replicate the test below, but must not be
10856          true when the test below is false.  (Always err on the side
10857          of creating unused temporaries, to avoid ICEs.)  */
10858       if (ffebld_op (dest) != FFEBLD_opSYMTER
10859           || ((dest_tree = ffesymbol_hook (ffebld_symter (dest)).decl_tree)
10860               && (TREE_CODE (dest_tree) != VAR_DECL
10861                   || TREE_ADDRESSABLE (dest_tree))))
10862         {
10863           ffecom_prepare_expr_ (source, dest);
10864           dest_used = TRUE;
10865         }
10866       else
10867         {
10868           ffecom_prepare_expr_ (source, NULL);
10869           dest_used = FALSE;
10870         }
10871
10872       ffecom_prepare_expr_w (NULL_TREE, dest);
10873
10874       /* For COMPLEX assignment like C1=C2, if partial overlap is possible,
10875          create a temporary through which the assignment is to take place,
10876          since MODIFY_EXPR doesn't handle partial overlap properly.  */
10877       if (ffebld_basictype (dest) == FFEINFO_basictypeCOMPLEX
10878           && ffecom_possible_partial_overlap_ (dest, source))
10879         {
10880           assign_temp = ffecom_make_tempvar ("complex_let",
10881                                              ffecom_tree_type
10882                                              [ffebld_basictype (dest)]
10883                                              [ffebld_kindtype (dest)],
10884                                              FFETARGET_charactersizeNONE,
10885                                              -1);
10886         }
10887       else
10888         assign_temp = NULL_TREE;
10889
10890       ffecom_prepare_end ();
10891
10892       dest_tree = ffecom_expr_w (NULL_TREE, dest);
10893       if (dest_tree == error_mark_node)
10894         return;
10895
10896       if ((TREE_CODE (dest_tree) != VAR_DECL)
10897           || TREE_ADDRESSABLE (dest_tree))
10898         source_tree = ffecom_expr_ (source, dest_tree, dest, &dest_used,
10899                                     FALSE, FALSE);
10900       else
10901         {
10902           assert (! dest_used);
10903           dest_used = FALSE;
10904           source_tree = ffecom_expr (source);
10905         }
10906       if (source_tree == error_mark_node)
10907         return;
10908
10909       if (dest_used)
10910         expr_tree = source_tree;
10911       else if (assign_temp)
10912         {
10913 #ifdef MOVE_EXPR
10914           /* The back end understands a conceptual move (evaluate source;
10915              store into dest), so use that, in case it can determine
10916              that it is going to use, say, two registers as temporaries
10917              anyway.  So don't use the temp (and someday avoid generating
10918              it, once this code starts triggering regularly).  */
10919           expr_tree = ffecom_2s (MOVE_EXPR, void_type_node,
10920                                  dest_tree,
10921                                  source_tree);
10922 #else
10923           expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
10924                                  assign_temp,
10925                                  source_tree);
10926           expand_expr_stmt (expr_tree);
10927           expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
10928                                  dest_tree,
10929                                  assign_temp);
10930 #endif
10931         }
10932       else
10933         expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
10934                                dest_tree,
10935                                source_tree);
10936
10937       expand_expr_stmt (expr_tree);
10938       return;
10939     }
10940
10941   ffecom_prepare_let_char_ (ffebld_size_known (dest), source);
10942   ffecom_prepare_expr_w (NULL_TREE, dest);
10943
10944   ffecom_prepare_end ();
10945
10946   ffecom_char_args_ (&dest_tree, &dest_length, dest);
10947   ffecom_let_char_ (dest_tree, dest_length, ffebld_size_known (dest),
10948                     source);
10949 }
10950
10951 /* ffecom_expr -- Transform expr into gcc tree
10952
10953    tree t;
10954    ffebld expr;  // FFE expression.
10955    tree = ffecom_expr(expr);
10956
10957    Recursive descent on expr while making corresponding tree nodes and
10958    attaching type info and such.  */
10959
10960 tree
10961 ffecom_expr (ffebld expr)
10962 {
10963   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, FALSE, FALSE);
10964 }
10965
10966 /* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT.  */
10967
10968 tree
10969 ffecom_expr_assign (ffebld expr)
10970 {
10971   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
10972 }
10973
10974 /* Like ffecom_expr_rw, but return tree usable for ASSIGN.  */
10975
10976 tree
10977 ffecom_expr_assign_w (ffebld expr)
10978 {
10979   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
10980 }
10981
10982 /* Transform expr for use as into read/write tree and stabilize the
10983    reference.  Not for use on CHARACTER expressions.
10984
10985    Recursive descent on expr while making corresponding tree nodes and
10986    attaching type info and such.  */
10987
10988 tree
10989 ffecom_expr_rw (tree type, ffebld expr)
10990 {
10991   assert (expr != NULL);
10992   /* Different target types not yet supported.  */
10993   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
10994
10995   return stabilize_reference (ffecom_expr (expr));
10996 }
10997
10998 /* Transform expr for use as into write tree and stabilize the
10999    reference.  Not for use on CHARACTER expressions.
11000
11001    Recursive descent on expr while making corresponding tree nodes and
11002    attaching type info and such.  */
11003
11004 tree
11005 ffecom_expr_w (tree type, ffebld expr)
11006 {
11007   assert (expr != NULL);
11008   /* Different target types not yet supported.  */
11009   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
11010
11011   return stabilize_reference (ffecom_expr (expr));
11012 }
11013
11014 /* Do global stuff.  */
11015
11016 void
11017 ffecom_finish_compile ()
11018 {
11019   assert (ffecom_outer_function_decl_ == NULL_TREE);
11020   assert (current_function_decl == NULL_TREE);
11021
11022   ffeglobal_drive (ffecom_finish_global_);
11023 }
11024
11025 /* Public entry point for front end to access finish_decl.  */
11026
11027 void
11028 ffecom_finish_decl (tree decl, tree init, bool is_top_level)
11029 {
11030   assert (!is_top_level);
11031   finish_decl (decl, init, FALSE);
11032 }
11033
11034 /* Finish a program unit.  */
11035
11036 void
11037 ffecom_finish_progunit ()
11038 {
11039   ffecom_end_compstmt ();
11040
11041   ffecom_previous_function_decl_ = current_function_decl;
11042   ffecom_which_entrypoint_decl_ = NULL_TREE;
11043
11044   finish_function (0);
11045 }
11046
11047 /* Wrapper for get_identifier.  pattern is sprintf-like.  */
11048
11049 tree
11050 ffecom_get_invented_identifier (const char *pattern, ...)
11051 {
11052   tree decl;
11053   char *nam;
11054   va_list ap;
11055
11056   va_start (ap, pattern);
11057   if (vasprintf (&nam, pattern, ap) == 0)
11058     abort ();
11059   va_end (ap);
11060   decl = get_identifier (nam);
11061   free (nam);
11062   IDENTIFIER_INVENTED (decl) = 1;
11063   return decl;
11064 }
11065
11066 ffeinfoBasictype
11067 ffecom_gfrt_basictype (ffecomGfrt gfrt)
11068 {
11069   assert (gfrt < FFECOM_gfrt);
11070
11071   switch (ffecom_gfrt_type_[gfrt])
11072     {
11073     case FFECOM_rttypeVOID_:
11074     case FFECOM_rttypeVOIDSTAR_:
11075       return FFEINFO_basictypeNONE;
11076
11077     case FFECOM_rttypeFTNINT_:
11078       return FFEINFO_basictypeINTEGER;
11079
11080     case FFECOM_rttypeINTEGER_:
11081       return FFEINFO_basictypeINTEGER;
11082
11083     case FFECOM_rttypeLONGINT_:
11084       return FFEINFO_basictypeINTEGER;
11085
11086     case FFECOM_rttypeLOGICAL_:
11087       return FFEINFO_basictypeLOGICAL;
11088
11089     case FFECOM_rttypeREAL_F2C_:
11090     case FFECOM_rttypeREAL_GNU_:
11091       return FFEINFO_basictypeREAL;
11092
11093     case FFECOM_rttypeCOMPLEX_F2C_:
11094     case FFECOM_rttypeCOMPLEX_GNU_:
11095       return FFEINFO_basictypeCOMPLEX;
11096
11097     case FFECOM_rttypeDOUBLE_:
11098     case FFECOM_rttypeDOUBLEREAL_:
11099       return FFEINFO_basictypeREAL;
11100
11101     case FFECOM_rttypeDBLCMPLX_F2C_:
11102     case FFECOM_rttypeDBLCMPLX_GNU_:
11103       return FFEINFO_basictypeCOMPLEX;
11104
11105     case FFECOM_rttypeCHARACTER_:
11106       return FFEINFO_basictypeCHARACTER;
11107
11108     default:
11109       return FFEINFO_basictypeANY;
11110     }
11111 }
11112
11113 ffeinfoKindtype
11114 ffecom_gfrt_kindtype (ffecomGfrt gfrt)
11115 {
11116   assert (gfrt < FFECOM_gfrt);
11117
11118   switch (ffecom_gfrt_type_[gfrt])
11119     {
11120     case FFECOM_rttypeVOID_:
11121     case FFECOM_rttypeVOIDSTAR_:
11122       return FFEINFO_kindtypeNONE;
11123
11124     case FFECOM_rttypeFTNINT_:
11125       return FFEINFO_kindtypeINTEGER1;
11126
11127     case FFECOM_rttypeINTEGER_:
11128       return FFEINFO_kindtypeINTEGER1;
11129
11130     case FFECOM_rttypeLONGINT_:
11131       return FFEINFO_kindtypeINTEGER4;
11132
11133     case FFECOM_rttypeLOGICAL_:
11134       return FFEINFO_kindtypeLOGICAL1;
11135
11136     case FFECOM_rttypeREAL_F2C_:
11137     case FFECOM_rttypeREAL_GNU_:
11138       return FFEINFO_kindtypeREAL1;
11139
11140     case FFECOM_rttypeCOMPLEX_F2C_:
11141     case FFECOM_rttypeCOMPLEX_GNU_:
11142       return FFEINFO_kindtypeREAL1;
11143
11144     case FFECOM_rttypeDOUBLE_:
11145     case FFECOM_rttypeDOUBLEREAL_:
11146       return FFEINFO_kindtypeREAL2;
11147
11148     case FFECOM_rttypeDBLCMPLX_F2C_:
11149     case FFECOM_rttypeDBLCMPLX_GNU_:
11150       return FFEINFO_kindtypeREAL2;
11151
11152     case FFECOM_rttypeCHARACTER_:
11153       return FFEINFO_kindtypeCHARACTER1;
11154
11155     default:
11156       return FFEINFO_kindtypeANY;
11157     }
11158 }
11159
11160 void
11161 ffecom_init_0 ()
11162 {
11163   tree endlink;
11164   int i;
11165   int j;
11166   tree t;
11167   tree field;
11168   ffetype type;
11169   ffetype base_type;
11170   tree double_ftype_double;
11171   tree float_ftype_float;
11172   tree ldouble_ftype_ldouble;
11173   tree ffecom_tree_ptr_to_fun_type_void;
11174
11175   /* This block of code comes from the now-obsolete cktyps.c.  It checks
11176      whether the compiler environment is buggy in known ways, some of which
11177      would, if not explicitly checked here, result in subtle bugs in g77.  */
11178
11179   if (ffe_is_do_internal_checks ())
11180     {
11181       static const char names[][12]
11182         =
11183       {"bar", "bletch", "foo", "foobar"};
11184       const char *name;
11185       unsigned long ul;
11186       double fl;
11187
11188       name = bsearch ("foo", &names[0], ARRAY_SIZE (names), sizeof (names[0]),
11189                       (int (*)(const void *, const void *)) strcmp);
11190       if (name != &names[0][2])
11191         {
11192           assert ("bsearch doesn't work, #define FFEPROJ_BSEARCH 0 in proj.h"
11193                   == NULL);
11194           abort ();
11195         }
11196
11197       ul = strtoul ("123456789", NULL, 10);
11198       if (ul != 123456789L)
11199         {
11200           assert ("strtoul doesn't have enough range, #define FFEPROJ_STRTOUL 0\
11201  in proj.h" == NULL);
11202           abort ();
11203         }
11204
11205       fl = atof ("56.789");
11206       if ((fl < 56.788) || (fl > 56.79))
11207         {
11208           assert ("atof not type double, fix your #include <stdio.h>"
11209                   == NULL);
11210           abort ();
11211         }
11212     }
11213
11214   ffecom_outer_function_decl_ = NULL_TREE;
11215   current_function_decl = NULL_TREE;
11216   named_labels = NULL_TREE;
11217   current_binding_level = NULL_BINDING_LEVEL;
11218   free_binding_level = NULL_BINDING_LEVEL;
11219   /* Make the binding_level structure for global names.  */
11220   pushlevel (0);
11221   global_binding_level = current_binding_level;
11222   current_binding_level->prep_state = 2;
11223
11224   build_common_tree_nodes (1);
11225
11226   /* Define `int' and `char' first so that dbx will output them first.  */
11227   pushdecl (build_decl (TYPE_DECL, get_identifier ("int"),
11228                         integer_type_node));
11229   /* CHARACTER*1 is unsigned in ICHAR contexts.  */
11230   char_type_node = make_unsigned_type (CHAR_TYPE_SIZE);
11231   pushdecl (build_decl (TYPE_DECL, get_identifier ("char"),
11232                         char_type_node));
11233   pushdecl (build_decl (TYPE_DECL, get_identifier ("long int"),
11234                         long_integer_type_node));
11235   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned int"),
11236                         unsigned_type_node));
11237   pushdecl (build_decl (TYPE_DECL, get_identifier ("long unsigned int"),
11238                         long_unsigned_type_node));
11239   pushdecl (build_decl (TYPE_DECL, get_identifier ("long long int"),
11240                         long_long_integer_type_node));
11241   pushdecl (build_decl (TYPE_DECL, get_identifier ("long long unsigned int"),
11242                         long_long_unsigned_type_node));
11243   pushdecl (build_decl (TYPE_DECL, get_identifier ("short int"),
11244                         short_integer_type_node));
11245   pushdecl (build_decl (TYPE_DECL, get_identifier ("short unsigned int"),
11246                         short_unsigned_type_node));
11247
11248   /* Set the sizetype before we make other types.  This *should* be the
11249      first type we create.  */
11250
11251   set_sizetype
11252     (TREE_TYPE (IDENTIFIER_GLOBAL_VALUE (get_identifier (SIZE_TYPE))));
11253   ffecom_typesize_pointer_
11254     = TREE_INT_CST_LOW (TYPE_SIZE (sizetype)) / BITS_PER_UNIT;
11255
11256   build_common_tree_nodes_2 (0);
11257
11258   /* Define both `signed char' and `unsigned char'.  */
11259   pushdecl (build_decl (TYPE_DECL, get_identifier ("signed char"),
11260                         signed_char_type_node));
11261
11262   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned char"),
11263                         unsigned_char_type_node));
11264
11265   pushdecl (build_decl (TYPE_DECL, get_identifier ("float"),
11266                         float_type_node));
11267   pushdecl (build_decl (TYPE_DECL, get_identifier ("double"),
11268                         double_type_node));
11269   pushdecl (build_decl (TYPE_DECL, get_identifier ("long double"),
11270                         long_double_type_node));
11271
11272   /* For now, override what build_common_tree_nodes has done.  */
11273   complex_integer_type_node = ffecom_make_complex_type_ (integer_type_node);
11274   complex_float_type_node = ffecom_make_complex_type_ (float_type_node);
11275   complex_double_type_node = ffecom_make_complex_type_ (double_type_node);
11276   complex_long_double_type_node
11277     = ffecom_make_complex_type_ (long_double_type_node);
11278
11279   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex int"),
11280                         complex_integer_type_node));
11281   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex float"),
11282                         complex_float_type_node));
11283   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex double"),
11284                         complex_double_type_node));
11285   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex long double"),
11286                         complex_long_double_type_node));
11287
11288   pushdecl (build_decl (TYPE_DECL, get_identifier ("void"),
11289                         void_type_node));
11290   /* We are not going to have real types in C with less than byte alignment,
11291      so we might as well not have any types that claim to have it.  */
11292   TYPE_ALIGN (void_type_node) = BITS_PER_UNIT;
11293   TYPE_USER_ALIGN (void_type_node) = 0;
11294
11295   string_type_node = build_pointer_type (char_type_node);
11296
11297   ffecom_tree_fun_type_void
11298     = build_function_type (void_type_node, NULL_TREE);
11299
11300   ffecom_tree_ptr_to_fun_type_void
11301     = build_pointer_type (ffecom_tree_fun_type_void);
11302
11303   endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE);
11304
11305   float_ftype_float
11306     = build_function_type (float_type_node,
11307                            tree_cons (NULL_TREE, float_type_node, endlink));
11308
11309   double_ftype_double
11310     = build_function_type (double_type_node,
11311                            tree_cons (NULL_TREE, double_type_node, endlink));
11312
11313   ldouble_ftype_ldouble
11314     = build_function_type (long_double_type_node,
11315                            tree_cons (NULL_TREE, long_double_type_node,
11316                                       endlink));
11317
11318   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11319     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11320       {
11321         ffecom_tree_type[i][j] = NULL_TREE;
11322         ffecom_tree_fun_type[i][j] = NULL_TREE;
11323         ffecom_tree_ptr_to_fun_type[i][j] = NULL_TREE;
11324         ffecom_f2c_typecode_[i][j] = -1;
11325       }
11326
11327   /* Set up standard g77 types.  Note that INTEGER and LOGICAL are set
11328      to size FLOAT_TYPE_SIZE because they have to be the same size as
11329      REAL, which also is FLOAT_TYPE_SIZE, according to the standard.
11330      Compiler options and other such stuff that change the ways these
11331      types are set should not affect this particular setup.  */
11332
11333   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1]
11334     = t = make_signed_type (FLOAT_TYPE_SIZE);
11335   pushdecl (build_decl (TYPE_DECL, get_identifier ("integer"),
11336                         t));
11337   type = ffetype_new ();
11338   base_type = type;
11339   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER1,
11340                     type);
11341   ffetype_set_ams (type,
11342                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11343                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11344   ffetype_set_star (base_type,
11345                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11346                     type);
11347   ffetype_set_kind (base_type, 1, type);
11348   ffecom_typesize_integer1_ = ffetype_size (type);
11349   assert (ffetype_size (type) == sizeof (ffetargetInteger1));
11350
11351   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER1]
11352     = t = make_unsigned_type (FLOAT_TYPE_SIZE); /* HOLLERITH means unsigned. */
11353   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned"),
11354                         t));
11355
11356   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER2]
11357     = t = make_signed_type (CHAR_TYPE_SIZE);
11358   pushdecl (build_decl (TYPE_DECL, get_identifier ("byte"),
11359                         t));
11360   type = ffetype_new ();
11361   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER2,
11362                     type);
11363   ffetype_set_ams (type,
11364                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11365                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11366   ffetype_set_star (base_type,
11367                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11368                     type);
11369   ffetype_set_kind (base_type, 3, type);
11370   assert (ffetype_size (type) == sizeof (ffetargetInteger2));
11371
11372   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER2]
11373     = t = make_unsigned_type (CHAR_TYPE_SIZE);
11374   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned byte"),
11375                         t));
11376
11377   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER3]
11378     = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11379   pushdecl (build_decl (TYPE_DECL, get_identifier ("word"),
11380                         t));
11381   type = ffetype_new ();
11382   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER3,
11383                     type);
11384   ffetype_set_ams (type,
11385                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11386                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11387   ffetype_set_star (base_type,
11388                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11389                     type);
11390   ffetype_set_kind (base_type, 6, type);
11391   assert (ffetype_size (type) == sizeof (ffetargetInteger3));
11392
11393   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER3]
11394     = t = make_unsigned_type (CHAR_TYPE_SIZE * 2);
11395   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned word"),
11396                         t));
11397
11398   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER4]
11399     = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11400   pushdecl (build_decl (TYPE_DECL, get_identifier ("integer4"),
11401                         t));
11402   type = ffetype_new ();
11403   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER4,
11404                     type);
11405   ffetype_set_ams (type,
11406                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11407                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11408   ffetype_set_star (base_type,
11409                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11410                     type);
11411   ffetype_set_kind (base_type, 2, type);
11412   assert (ffetype_size (type) == sizeof (ffetargetInteger4));
11413
11414   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER4]
11415     = t = make_unsigned_type (FLOAT_TYPE_SIZE * 2);
11416   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned4"),
11417                         t));
11418
11419 #if 0
11420   if (ffe_is_do_internal_checks ()
11421       && LONG_TYPE_SIZE != FLOAT_TYPE_SIZE
11422       && LONG_TYPE_SIZE != CHAR_TYPE_SIZE
11423       && LONG_TYPE_SIZE != SHORT_TYPE_SIZE
11424       && LONG_TYPE_SIZE != LONG_LONG_TYPE_SIZE)
11425     {
11426       fprintf (stderr, "Sorry, no g77 support for LONG_TYPE_SIZE (%d bits) yet.\n",
11427                LONG_TYPE_SIZE);
11428     }
11429 #endif
11430
11431   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL1]
11432     = t = make_signed_type (FLOAT_TYPE_SIZE);
11433   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical"),
11434                         t));
11435   type = ffetype_new ();
11436   base_type = type;
11437   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL1,
11438                     type);
11439   ffetype_set_ams (type,
11440                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11441                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11442   ffetype_set_star (base_type,
11443                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11444                     type);
11445   ffetype_set_kind (base_type, 1, type);
11446   assert (ffetype_size (type) == sizeof (ffetargetLogical1));
11447
11448   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL2]
11449     = t = make_signed_type (CHAR_TYPE_SIZE);
11450   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical2"),
11451                         t));
11452   type = ffetype_new ();
11453   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL2,
11454                     type);
11455   ffetype_set_ams (type,
11456                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11457                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11458   ffetype_set_star (base_type,
11459                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11460                     type);
11461   ffetype_set_kind (base_type, 3, type);
11462   assert (ffetype_size (type) == sizeof (ffetargetLogical2));
11463
11464   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL3]
11465     = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11466   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical3"),
11467                         t));
11468   type = ffetype_new ();
11469   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL3,
11470                     type);
11471   ffetype_set_ams (type,
11472                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11473                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11474   ffetype_set_star (base_type,
11475                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11476                     type);
11477   ffetype_set_kind (base_type, 6, type);
11478   assert (ffetype_size (type) == sizeof (ffetargetLogical3));
11479
11480   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL4]
11481     = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11482   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical4"),
11483                         t));
11484   type = ffetype_new ();
11485   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL4,
11486                     type);
11487   ffetype_set_ams (type,
11488                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11489                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11490   ffetype_set_star (base_type,
11491                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11492                     type);
11493   ffetype_set_kind (base_type, 2, type);
11494   assert (ffetype_size (type) == sizeof (ffetargetLogical4));
11495
11496   ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11497     = t = make_node (REAL_TYPE);
11498   TYPE_PRECISION (t) = FLOAT_TYPE_SIZE;
11499   pushdecl (build_decl (TYPE_DECL, get_identifier ("real"),
11500                         t));
11501   layout_type (t);
11502   type = ffetype_new ();
11503   base_type = type;
11504   ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL1,
11505                     type);
11506   ffetype_set_ams (type,
11507                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11508                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11509   ffetype_set_star (base_type,
11510                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11511                     type);
11512   ffetype_set_kind (base_type, 1, type);
11513   ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11514     = FFETARGET_f2cTYREAL;
11515   assert (ffetype_size (type) == sizeof (ffetargetReal1));
11516
11517   ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREALDOUBLE]
11518     = t = make_node (REAL_TYPE);
11519   TYPE_PRECISION (t) = FLOAT_TYPE_SIZE * 2;     /* Always twice REAL. */
11520   pushdecl (build_decl (TYPE_DECL, get_identifier ("double precision"),
11521                         t));
11522   layout_type (t);
11523   type = ffetype_new ();
11524   ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE,
11525                     type);
11526   ffetype_set_ams (type,
11527                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11528                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11529   ffetype_set_star (base_type,
11530                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11531                     type);
11532   ffetype_set_kind (base_type, 2, type);
11533   ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]
11534     = FFETARGET_f2cTYDREAL;
11535   assert (ffetype_size (type) == sizeof (ffetargetReal2));
11536
11537   ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11538     = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]);
11539   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex"),
11540                         t));
11541   type = ffetype_new ();
11542   base_type = type;
11543   ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL1,
11544                     type);
11545   ffetype_set_ams (type,
11546                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11547                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11548   ffetype_set_star (base_type,
11549                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11550                     type);
11551   ffetype_set_kind (base_type, 1, type);
11552   ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11553     = FFETARGET_f2cTYCOMPLEX;
11554   assert (ffetype_size (type) == sizeof (ffetargetComplex1));
11555
11556   ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREALDOUBLE]
11557     = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]);
11558   pushdecl (build_decl (TYPE_DECL, get_identifier ("double complex"),
11559                         t));
11560   type = ffetype_new ();
11561   ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREALDOUBLE,
11562                     type);
11563   ffetype_set_ams (type,
11564                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11565                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11566   ffetype_set_star (base_type,
11567                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11568                     type);
11569   ffetype_set_kind (base_type, 2,
11570                     type);
11571   ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL2]
11572     = FFETARGET_f2cTYDCOMPLEX;
11573   assert (ffetype_size (type) == sizeof (ffetargetComplex2));
11574
11575   /* Make function and ptr-to-function types for non-CHARACTER types. */
11576
11577   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11578     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11579       {
11580         if ((t = ffecom_tree_type[i][j]) != NULL_TREE)
11581           {
11582             if (i == FFEINFO_basictypeINTEGER)
11583               {
11584                 /* Figure out the smallest INTEGER type that can hold
11585                    a pointer on this machine. */
11586                 if (GET_MODE_SIZE (TYPE_MODE (t))
11587                     >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
11588                   {
11589                     if ((ffecom_pointer_kind_ == FFEINFO_kindtypeNONE)
11590                         || (GET_MODE_SIZE (TYPE_MODE (ffecom_tree_type[i][ffecom_pointer_kind_]))
11591                             > GET_MODE_SIZE (TYPE_MODE (t))))
11592                       ffecom_pointer_kind_ = j;
11593                   }
11594               }
11595             else if (i == FFEINFO_basictypeCOMPLEX)
11596               t = void_type_node;
11597             /* For f2c compatibility, REAL functions are really
11598                implemented as DOUBLE PRECISION.  */
11599             else if ((i == FFEINFO_basictypeREAL)
11600                      && (j == FFEINFO_kindtypeREAL1))
11601               t = ffecom_tree_type
11602                 [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2];
11603
11604             t = ffecom_tree_fun_type[i][j] = build_function_type (t,
11605                                                                   NULL_TREE);
11606             ffecom_tree_ptr_to_fun_type[i][j] = build_pointer_type (t);
11607           }
11608       }
11609
11610   /* Set up pointer types.  */
11611
11612   if (ffecom_pointer_kind_ == FFEINFO_basictypeNONE)
11613     fatal_error ("no INTEGER type can hold a pointer on this configuration");
11614   else if (0 && ffe_is_do_internal_checks ())
11615     fprintf (stderr, "Pointer type kt=%d\n", ffecom_pointer_kind_);
11616   ffetype_set_kind (ffeinfo_type (FFEINFO_basictypeINTEGER,
11617                                   FFEINFO_kindtypeINTEGERDEFAULT),
11618                     7,
11619                     ffeinfo_type (FFEINFO_basictypeINTEGER,
11620                                   ffecom_pointer_kind_));
11621
11622   if (ffe_is_ugly_assign ())
11623     ffecom_label_kind_ = ffecom_pointer_kind_;  /* Require ASSIGN etc to this. */
11624   else
11625     ffecom_label_kind_ = FFEINFO_kindtypeINTEGERDEFAULT;
11626   if (0 && ffe_is_do_internal_checks ())
11627     fprintf (stderr, "Label type kt=%d\n", ffecom_label_kind_);
11628
11629   ffecom_integer_type_node
11630     = ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1];
11631   ffecom_integer_zero_node = convert (ffecom_integer_type_node,
11632                                       integer_zero_node);
11633   ffecom_integer_one_node = convert (ffecom_integer_type_node,
11634                                      integer_one_node);
11635
11636   /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional.
11637      Turns out that by TYLONG, runtime/libI77/lio.h really means
11638      "whatever size an ftnint is".  For consistency and sanity,
11639      com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen
11640      all are INTEGER, which we also make out of whatever back-end
11641      integer type is FLOAT_TYPE_SIZE bits wide.  This change, from
11642      LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to
11643      accommodate machines like the Alpha.  Note that this suggests
11644      f2c and libf2c are missing a distinction perhaps needed on
11645      some machines between "int" and "long int".  -- burley 0.5.5 950215 */
11646
11647   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, FLOAT_TYPE_SIZE,
11648                             FFETARGET_f2cTYLONG);
11649   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, SHORT_TYPE_SIZE,
11650                             FFETARGET_f2cTYSHORT);
11651   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, CHAR_TYPE_SIZE,
11652                             FFETARGET_f2cTYINT1);
11653   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, LONG_LONG_TYPE_SIZE,
11654                             FFETARGET_f2cTYQUAD);
11655   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, FLOAT_TYPE_SIZE,
11656                             FFETARGET_f2cTYLOGICAL);
11657   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, SHORT_TYPE_SIZE,
11658                             FFETARGET_f2cTYLOGICAL2);
11659   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, CHAR_TYPE_SIZE,
11660                             FFETARGET_f2cTYLOGICAL1);
11661   /* ~~~Not really such a type in libf2c, e.g. I/O support?  */
11662   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, LONG_LONG_TYPE_SIZE,
11663                             FFETARGET_f2cTYQUAD);
11664
11665   /* CHARACTER stuff is all special-cased, so it is not handled in the above
11666      loop.  CHARACTER items are built as arrays of unsigned char.  */
11667
11668   ffecom_tree_type[FFEINFO_basictypeCHARACTER]
11669     [FFEINFO_kindtypeCHARACTER1] = t = char_type_node;
11670   type = ffetype_new ();
11671   base_type = type;
11672   ffeinfo_set_type (FFEINFO_basictypeCHARACTER,
11673                     FFEINFO_kindtypeCHARACTER1,
11674                     type);
11675   ffetype_set_ams (type,
11676                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11677                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11678   ffetype_set_kind (base_type, 1, type);
11679   assert (ffetype_size (type)
11680           == sizeof (((ffetargetCharacter1) { 0, NULL }).text[0]));
11681
11682   ffecom_tree_fun_type[FFEINFO_basictypeCHARACTER]
11683     [FFEINFO_kindtypeCHARACTER1] = ffecom_tree_fun_type_void;
11684   ffecom_tree_ptr_to_fun_type[FFEINFO_basictypeCHARACTER]
11685     [FFEINFO_kindtypeCHARACTER1]
11686     = ffecom_tree_ptr_to_fun_type_void;
11687   ffecom_f2c_typecode_[FFEINFO_basictypeCHARACTER][FFEINFO_kindtypeCHARACTER1]
11688     = FFETARGET_f2cTYCHAR;
11689
11690   ffecom_f2c_typecode_[FFEINFO_basictypeANY][FFEINFO_kindtypeANY]
11691     = 0;
11692
11693   /* Make multi-return-value type and fields. */
11694
11695   ffecom_multi_type_node_ = make_node (UNION_TYPE);
11696
11697   field = NULL_TREE;
11698
11699   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11700     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11701       {
11702         char name[30];
11703
11704         if (ffecom_tree_type[i][j] == NULL_TREE)
11705           continue;             /* Not supported. */
11706         sprintf (&name[0], "bt_%s_kt_%s",
11707                  ffeinfo_basictype_string ((ffeinfoBasictype) i),
11708                  ffeinfo_kindtype_string ((ffeinfoKindtype) j));
11709         ffecom_multi_fields_[i][j] = build_decl (FIELD_DECL,
11710                                                  get_identifier (name),
11711                                                  ffecom_tree_type[i][j]);
11712         DECL_CONTEXT (ffecom_multi_fields_[i][j])
11713           = ffecom_multi_type_node_;
11714         DECL_ALIGN (ffecom_multi_fields_[i][j]) = 0;
11715         DECL_USER_ALIGN (ffecom_multi_fields_[i][j]) = 0;
11716         TREE_CHAIN (ffecom_multi_fields_[i][j]) = field;
11717         field = ffecom_multi_fields_[i][j];
11718       }
11719
11720   TYPE_FIELDS (ffecom_multi_type_node_) = field;
11721   layout_type (ffecom_multi_type_node_);
11722
11723   /* Subroutines usually return integer because they might have alternate
11724      returns. */
11725
11726   ffecom_tree_subr_type
11727     = build_function_type (integer_type_node, NULL_TREE);
11728   ffecom_tree_ptr_to_subr_type
11729     = build_pointer_type (ffecom_tree_subr_type);
11730   ffecom_tree_blockdata_type
11731     = build_function_type (void_type_node, NULL_TREE);
11732
11733   builtin_function ("__builtin_sqrtf", float_ftype_float,
11734                     BUILT_IN_SQRTF, BUILT_IN_NORMAL, "sqrtf");
11735   builtin_function ("__builtin_sqrt", double_ftype_double,
11736                     BUILT_IN_SQRT, BUILT_IN_NORMAL, "sqrt");
11737   builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble,
11738                     BUILT_IN_SQRTL, BUILT_IN_NORMAL, "sqrtl");
11739   builtin_function ("__builtin_sinf", float_ftype_float,
11740                     BUILT_IN_SINF, BUILT_IN_NORMAL, "sinf");
11741   builtin_function ("__builtin_sin", double_ftype_double,
11742                     BUILT_IN_SIN, BUILT_IN_NORMAL, "sin");
11743   builtin_function ("__builtin_sinl", ldouble_ftype_ldouble,
11744                     BUILT_IN_SINL, BUILT_IN_NORMAL, "sinl");
11745   builtin_function ("__builtin_cosf", float_ftype_float,
11746                     BUILT_IN_COSF, BUILT_IN_NORMAL, "cosf");
11747   builtin_function ("__builtin_cos", double_ftype_double,
11748                     BUILT_IN_COS, BUILT_IN_NORMAL, "cos");
11749   builtin_function ("__builtin_cosl", ldouble_ftype_ldouble,
11750                     BUILT_IN_COSL, BUILT_IN_NORMAL, "cosl");
11751
11752   pedantic_lvalues = FALSE;
11753
11754   ffecom_f2c_make_type_ (&ffecom_f2c_integer_type_node,
11755                          FFECOM_f2cINTEGER,
11756                          "integer");
11757   ffecom_f2c_make_type_ (&ffecom_f2c_address_type_node,
11758                          FFECOM_f2cADDRESS,
11759                          "address");
11760   ffecom_f2c_make_type_ (&ffecom_f2c_real_type_node,
11761                          FFECOM_f2cREAL,
11762                          "real");
11763   ffecom_f2c_make_type_ (&ffecom_f2c_doublereal_type_node,
11764                          FFECOM_f2cDOUBLEREAL,
11765                          "doublereal");
11766   ffecom_f2c_make_type_ (&ffecom_f2c_complex_type_node,
11767                          FFECOM_f2cCOMPLEX,
11768                          "complex");
11769   ffecom_f2c_make_type_ (&ffecom_f2c_doublecomplex_type_node,
11770                          FFECOM_f2cDOUBLECOMPLEX,
11771                          "doublecomplex");
11772   ffecom_f2c_make_type_ (&ffecom_f2c_longint_type_node,
11773                          FFECOM_f2cLONGINT,
11774                          "longint");
11775   ffecom_f2c_make_type_ (&ffecom_f2c_logical_type_node,
11776                          FFECOM_f2cLOGICAL,
11777                          "logical");
11778   ffecom_f2c_make_type_ (&ffecom_f2c_flag_type_node,
11779                          FFECOM_f2cFLAG,
11780                          "flag");
11781   ffecom_f2c_make_type_ (&ffecom_f2c_ftnlen_type_node,
11782                          FFECOM_f2cFTNLEN,
11783                          "ftnlen");
11784   ffecom_f2c_make_type_ (&ffecom_f2c_ftnint_type_node,
11785                          FFECOM_f2cFTNINT,
11786                          "ftnint");
11787
11788   ffecom_f2c_ftnlen_zero_node
11789     = convert (ffecom_f2c_ftnlen_type_node, integer_zero_node);
11790
11791   ffecom_f2c_ftnlen_one_node
11792     = convert (ffecom_f2c_ftnlen_type_node, integer_one_node);
11793
11794   ffecom_f2c_ftnlen_two_node = build_int_2 (2, 0);
11795   TREE_TYPE (ffecom_f2c_ftnlen_two_node) = ffecom_integer_type_node;
11796
11797   ffecom_f2c_ptr_to_ftnlen_type_node
11798     = build_pointer_type (ffecom_f2c_ftnlen_type_node);
11799
11800   ffecom_f2c_ptr_to_ftnint_type_node
11801     = build_pointer_type (ffecom_f2c_ftnint_type_node);
11802
11803   ffecom_f2c_ptr_to_integer_type_node
11804     = build_pointer_type (ffecom_f2c_integer_type_node);
11805
11806   ffecom_f2c_ptr_to_real_type_node
11807     = build_pointer_type (ffecom_f2c_real_type_node);
11808
11809   ffecom_float_zero_ = build_real (float_type_node, dconst0);
11810   ffecom_double_zero_ = build_real (double_type_node, dconst0);
11811   {
11812     REAL_VALUE_TYPE point_5;
11813
11814     REAL_ARITHMETIC (point_5, RDIV_EXPR, dconst1, dconst2);
11815     ffecom_float_half_ = build_real (float_type_node, point_5);
11816     ffecom_double_half_ = build_real (double_type_node, point_5);
11817   }
11818
11819   /* Do "extern int xargc;".  */
11820
11821   ffecom_tree_xargc_ = build_decl (VAR_DECL,
11822                                    get_identifier ("f__xargc"),
11823                                    integer_type_node);
11824   DECL_EXTERNAL (ffecom_tree_xargc_) = 1;
11825   TREE_STATIC (ffecom_tree_xargc_) = 1;
11826   TREE_PUBLIC (ffecom_tree_xargc_) = 1;
11827   ffecom_tree_xargc_ = start_decl (ffecom_tree_xargc_, FALSE);
11828   finish_decl (ffecom_tree_xargc_, NULL_TREE, FALSE);
11829
11830 #if 0   /* This is being fixed, and seems to be working now. */
11831   if ((FLOAT_TYPE_SIZE != 32)
11832       || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))) != 32))
11833     {
11834       warning ("configuration: REAL, INTEGER, and LOGICAL are %d bits wide,",
11835                (int) FLOAT_TYPE_SIZE);
11836       warning ("and pointers are %d bits wide, but g77 doesn't yet work",
11837           (int) TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))));
11838       warning ("properly unless they all are 32 bits wide");
11839       warning ("Please keep this in mind before you report bugs.");
11840     }
11841 #endif
11842
11843 #if 0   /* Code in ste.c that would crash has been commented out. */
11844   if (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)
11845       < TYPE_PRECISION (string_type_node))
11846     /* I/O will probably crash.  */
11847     warning ("configuration: char * holds %d bits, but ftnlen only %d",
11848              TYPE_PRECISION (string_type_node),
11849              TYPE_PRECISION (ffecom_f2c_ftnlen_type_node));
11850 #endif
11851
11852 #if 0   /* ASSIGN-related stuff has been changed to accommodate this. */
11853   if (TYPE_PRECISION (ffecom_integer_type_node)
11854       < TYPE_PRECISION (string_type_node))
11855     /* ASSIGN 10 TO I will crash.  */
11856     warning ("configuration: char * holds %d bits, but INTEGER only %d --\n\
11857  ASSIGN statement might fail",
11858              TYPE_PRECISION (string_type_node),
11859              TYPE_PRECISION (ffecom_integer_type_node));
11860 #endif
11861 }
11862
11863 /* ffecom_init_2 -- Initialize
11864
11865    ffecom_init_2();  */
11866
11867 void
11868 ffecom_init_2 ()
11869 {
11870   assert (ffecom_outer_function_decl_ == NULL_TREE);
11871   assert (current_function_decl == NULL_TREE);
11872   assert (ffecom_which_entrypoint_decl_ == NULL_TREE);
11873
11874   ffecom_master_arglist_ = NULL;
11875   ++ffecom_num_fns_;
11876   ffecom_primary_entry_ = NULL;
11877   ffecom_is_altreturning_ = FALSE;
11878   ffecom_func_result_ = NULL_TREE;
11879   ffecom_multi_retval_ = NULL_TREE;
11880 }
11881
11882 /* ffecom_list_expr -- Transform list of exprs into gcc tree
11883
11884    tree t;
11885    ffebld expr;  // FFE opITEM list.
11886    tree = ffecom_list_expr(expr);
11887
11888    List of actual args is transformed into corresponding gcc backend list.  */
11889
11890 tree
11891 ffecom_list_expr (ffebld expr)
11892 {
11893   tree list;
11894   tree *plist = &list;
11895   tree trail = NULL_TREE;       /* Append char length args here. */
11896   tree *ptrail = &trail;
11897   tree length;
11898
11899   while (expr != NULL)
11900     {
11901       tree texpr = ffecom_arg_expr (ffebld_head (expr), &length);
11902
11903       if (texpr == error_mark_node)
11904         return error_mark_node;
11905
11906       *plist = build_tree_list (NULL_TREE, texpr);
11907       plist = &TREE_CHAIN (*plist);
11908       expr = ffebld_trail (expr);
11909       if (length != NULL_TREE)
11910         {
11911           *ptrail = build_tree_list (NULL_TREE, length);
11912           ptrail = &TREE_CHAIN (*ptrail);
11913         }
11914     }
11915
11916   *plist = trail;
11917
11918   return list;
11919 }
11920
11921 /* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree
11922
11923    tree t;
11924    ffebld expr;  // FFE opITEM list.
11925    tree = ffecom_list_ptr_to_expr(expr);
11926
11927    List of actual args is transformed into corresponding gcc backend list for
11928    use in calling an external procedure (vs. a statement function).  */
11929
11930 tree
11931 ffecom_list_ptr_to_expr (ffebld expr)
11932 {
11933   tree list;
11934   tree *plist = &list;
11935   tree trail = NULL_TREE;       /* Append char length args here. */
11936   tree *ptrail = &trail;
11937   tree length;
11938
11939   while (expr != NULL)
11940     {
11941       tree texpr = ffecom_arg_ptr_to_expr (ffebld_head (expr), &length);
11942
11943       if (texpr == error_mark_node)
11944         return error_mark_node;
11945
11946       *plist = build_tree_list (NULL_TREE, texpr);
11947       plist = &TREE_CHAIN (*plist);
11948       expr = ffebld_trail (expr);
11949       if (length != NULL_TREE)
11950         {
11951           *ptrail = build_tree_list (NULL_TREE, length);
11952           ptrail = &TREE_CHAIN (*ptrail);
11953         }
11954     }
11955
11956   *plist = trail;
11957
11958   return list;
11959 }
11960
11961 /* Obtain gcc's LABEL_DECL tree for label.  */
11962
11963 tree
11964 ffecom_lookup_label (ffelab label)
11965 {
11966   tree glabel;
11967
11968   if (ffelab_hook (label) == NULL_TREE)
11969     {
11970       char labelname[16];
11971
11972       switch (ffelab_type (label))
11973         {
11974         case FFELAB_typeLOOPEND:
11975         case FFELAB_typeNOTLOOP:
11976         case FFELAB_typeENDIF:
11977           sprintf (labelname, "%" ffelabValue_f "u", ffelab_value (label));
11978           glabel = build_decl (LABEL_DECL, get_identifier (labelname),
11979                                void_type_node);
11980           DECL_CONTEXT (glabel) = current_function_decl;
11981           DECL_MODE (glabel) = VOIDmode;
11982           break;
11983
11984         case FFELAB_typeFORMAT:
11985           glabel = build_decl (VAR_DECL,
11986                                ffecom_get_invented_identifier
11987                                ("__g77_format_%d", (int) ffelab_value (label)),
11988                                build_type_variant (build_array_type
11989                                                    (char_type_node,
11990                                                     NULL_TREE),
11991                                                    1, 0));
11992           TREE_CONSTANT (glabel) = 1;
11993           TREE_STATIC (glabel) = 1;
11994           DECL_CONTEXT (glabel) = current_function_decl;
11995           DECL_INITIAL (glabel) = NULL;
11996           make_decl_rtl (glabel, NULL);
11997           expand_decl (glabel);
11998
11999           ffecom_save_tree_forever (glabel);
12000
12001           break;
12002
12003         case FFELAB_typeANY:
12004           glabel = error_mark_node;
12005           break;
12006
12007         default:
12008           assert ("bad label type" == NULL);
12009           glabel = NULL;
12010           break;
12011         }
12012       ffelab_set_hook (label, glabel);
12013     }
12014   else
12015     {
12016       glabel = ffelab_hook (label);
12017     }
12018
12019   return glabel;
12020 }
12021
12022 /* Stabilizes the arguments.  Don't use this if the lhs and rhs come from
12023    a single source specification (as in the fourth argument of MVBITS).
12024    If the type is NULL_TREE, the type of lhs is used to make the type of
12025    the MODIFY_EXPR.  */
12026
12027 tree
12028 ffecom_modify (tree newtype, tree lhs,
12029                tree rhs)
12030 {
12031   if (lhs == error_mark_node || rhs == error_mark_node)
12032     return error_mark_node;
12033
12034   if (newtype == NULL_TREE)
12035     newtype = TREE_TYPE (lhs);
12036
12037   if (TREE_SIDE_EFFECTS (lhs))
12038     lhs = stabilize_reference (lhs);
12039
12040   return ffecom_2s (MODIFY_EXPR, newtype, lhs, rhs);
12041 }
12042
12043 /* Register source file name.  */
12044
12045 void
12046 ffecom_file (const char *name)
12047 {
12048   ffecom_file_ (name);
12049 }
12050
12051 /* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed
12052
12053    ffestorag st;
12054    ffecom_notify_init_storage(st);
12055
12056    Gets called when all possible units in an aggregate storage area (a LOCAL
12057    with equivalences or a COMMON) have been initialized.  The initialization
12058    info either is in ffestorag_init or, if that is NULL,
12059    ffestorag_accretion:
12060
12061    ffestorag_init may contain an opCONTER or opARRTER.  opCONTER may occur
12062    even for an array if the array is one element in length!
12063
12064    ffestorag_accretion will contain an opACCTER.  It is much like an
12065    opARRTER except it has an ffebit object in it instead of just a size.
12066    The back end can use the info in the ffebit object, if it wants, to
12067    reduce the amount of actual initialization, but in any case it should
12068    kill the ffebit object when done.  Also, set accretion to NULL but
12069    init to a non-NULL value.
12070
12071    After performing initialization, DO NOT set init to NULL, because that'll
12072    tell the front end it is ok for more initialization to happen.  Instead,
12073    set init to an opANY expression or some such thing that you can use to
12074    tell that you've already initialized the object.
12075
12076    27-Oct-91  JCB  1.1
12077       Support two-pass FFE.  */
12078
12079 void
12080 ffecom_notify_init_storage (ffestorag st)
12081 {
12082   ffebld init;                  /* The initialization expression. */
12083
12084   if (ffestorag_init (st) == NULL)
12085     {
12086       init = ffestorag_accretion (st);
12087       assert (init != NULL);
12088       ffestorag_set_accretion (st, NULL);
12089       ffestorag_set_accretes (st, 0);
12090       ffestorag_set_init (st, init);
12091     }
12092 }
12093
12094 /* ffecom_notify_init_symbol -- A symbol is now fully init'ed
12095
12096    ffesymbol s;
12097    ffecom_notify_init_symbol(s);
12098
12099    Gets called when all possible units in a symbol (not placed in COMMON
12100    or involved in EQUIVALENCE, unless it as yet has no ffestorag object)
12101    have been initialized.  The initialization info either is in
12102    ffesymbol_init or, if that is NULL, ffesymbol_accretion:
12103
12104    ffesymbol_init may contain an opCONTER or opARRTER.  opCONTER may occur
12105    even for an array if the array is one element in length!
12106
12107    ffesymbol_accretion will contain an opACCTER.  It is much like an
12108    opARRTER except it has an ffebit object in it instead of just a size.
12109    The back end can use the info in the ffebit object, if it wants, to
12110    reduce the amount of actual initialization, but in any case it should
12111    kill the ffebit object when done.  Also, set accretion to NULL but
12112    init to a non-NULL value.
12113
12114    After performing initialization, DO NOT set init to NULL, because that'll
12115    tell the front end it is ok for more initialization to happen.  Instead,
12116    set init to an opANY expression or some such thing that you can use to
12117    tell that you've already initialized the object.
12118
12119    27-Oct-91  JCB  1.1
12120       Support two-pass FFE.  */
12121
12122 void
12123 ffecom_notify_init_symbol (ffesymbol s)
12124 {
12125   ffebld init;                  /* The initialization expression. */
12126
12127   if (ffesymbol_storage (s) == NULL)
12128     return;                     /* Do nothing until COMMON/EQUIVALENCE
12129                                    possibilities checked. */
12130
12131   if ((ffesymbol_init (s) == NULL)
12132       && ((init = ffesymbol_accretion (s)) != NULL))
12133     {
12134       ffesymbol_set_accretion (s, NULL);
12135       ffesymbol_set_accretes (s, 0);
12136       ffesymbol_set_init (s, init);
12137     }
12138 }
12139
12140 /* ffecom_notify_primary_entry -- Learn which is the primary entry point
12141
12142    ffesymbol s;
12143    ffecom_notify_primary_entry(s);
12144
12145    Gets called when implicit or explicit PROGRAM statement seen or when
12146    FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary
12147    global symbol that serves as the entry point.  */
12148
12149 void
12150 ffecom_notify_primary_entry (ffesymbol s)
12151 {
12152   ffecom_primary_entry_ = s;
12153   ffecom_primary_entry_kind_ = ffesymbol_kind (s);
12154
12155   if ((ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
12156       || (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE))
12157     ffecom_primary_entry_is_proc_ = TRUE;
12158   else
12159     ffecom_primary_entry_is_proc_ = FALSE;
12160
12161   if (!ffe_is_silent ())
12162     {
12163       if (ffecom_primary_entry_kind_ == FFEINFO_kindPROGRAM)
12164         fprintf (stderr, "%s:\n", ffesymbol_text (s));
12165       else
12166         fprintf (stderr, "  %s:\n", ffesymbol_text (s));
12167     }
12168
12169   if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
12170     {
12171       ffebld list;
12172       ffebld arg;
12173
12174       for (list = ffesymbol_dummyargs (s);
12175            list != NULL;
12176            list = ffebld_trail (list))
12177         {
12178           arg = ffebld_head (list);
12179           if (ffebld_op (arg) == FFEBLD_opSTAR)
12180             {
12181               ffecom_is_altreturning_ = TRUE;
12182               break;
12183             }
12184         }
12185     }
12186 }
12187
12188 FILE *
12189 ffecom_open_include (char *name, ffewhereLine l, ffewhereColumn c)
12190 {
12191   return ffecom_open_include_ (name, l, c);
12192 }
12193
12194 /* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front
12195
12196    tree t;
12197    ffebld expr;  // FFE expression.
12198    tree = ffecom_ptr_to_expr(expr);
12199
12200    Like ffecom_expr, but sticks address-of in front of most things.  */
12201
12202 tree
12203 ffecom_ptr_to_expr (ffebld expr)
12204 {
12205   tree item;
12206   ffeinfoBasictype bt;
12207   ffeinfoKindtype kt;
12208   ffesymbol s;
12209
12210   assert (expr != NULL);
12211
12212   switch (ffebld_op (expr))
12213     {
12214     case FFEBLD_opSYMTER:
12215       s = ffebld_symter (expr);
12216       if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
12217         {
12218           ffecomGfrt ix;
12219
12220           ix = ffeintrin_gfrt_indirect (ffebld_symter_implementation (expr));
12221           assert (ix != FFECOM_gfrt);
12222           if ((item = ffecom_gfrt_[ix]) == NULL_TREE)
12223             {
12224               ffecom_make_gfrt_ (ix);
12225               item = ffecom_gfrt_[ix];
12226             }
12227         }
12228       else
12229         {
12230           item = ffesymbol_hook (s).decl_tree;
12231           if (item == NULL_TREE)
12232             {
12233               s = ffecom_sym_transform_ (s);
12234               item = ffesymbol_hook (s).decl_tree;
12235             }
12236         }
12237       assert (item != NULL);
12238       if (item == error_mark_node)
12239         return item;
12240       if (!ffesymbol_hook (s).addr)
12241         item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12242                          item);
12243       return item;
12244
12245     case FFEBLD_opARRAYREF:
12246       return ffecom_arrayref_ (NULL_TREE, expr, 1);
12247
12248     case FFEBLD_opCONTER:
12249
12250       bt = ffeinfo_basictype (ffebld_info (expr));
12251       kt = ffeinfo_kindtype (ffebld_info (expr));
12252
12253       item = ffecom_constantunion (&ffebld_constant_union
12254                                    (ffebld_conter (expr)), bt, kt,
12255                                    ffecom_tree_type[bt][kt]);
12256       if (item == error_mark_node)
12257         return error_mark_node;
12258       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12259                        item);
12260       return item;
12261
12262     case FFEBLD_opANY:
12263       return error_mark_node;
12264
12265     default:
12266       bt = ffeinfo_basictype (ffebld_info (expr));
12267       kt = ffeinfo_kindtype (ffebld_info (expr));
12268
12269       item = ffecom_expr (expr);
12270       if (item == error_mark_node)
12271         return error_mark_node;
12272
12273       /* The back end currently optimizes a bit too zealously for us, in that
12274          we fail JCB001 if the following block of code is omitted.  It checks
12275          to see if the transformed expression is a symbol or array reference,
12276          and encloses it in a SAVE_EXPR if that is the case.  */
12277
12278       STRIP_NOPS (item);
12279       if ((TREE_CODE (item) == VAR_DECL)
12280           || (TREE_CODE (item) == PARM_DECL)
12281           || (TREE_CODE (item) == RESULT_DECL)
12282           || (TREE_CODE (item) == INDIRECT_REF)
12283           || (TREE_CODE (item) == ARRAY_REF)
12284           || (TREE_CODE (item) == COMPONENT_REF)
12285 #ifdef OFFSET_REF
12286           || (TREE_CODE (item) == OFFSET_REF)
12287 #endif
12288           || (TREE_CODE (item) == BUFFER_REF)
12289           || (TREE_CODE (item) == REALPART_EXPR)
12290           || (TREE_CODE (item) == IMAGPART_EXPR))
12291         {
12292           item = ffecom_save_tree (item);
12293         }
12294
12295       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12296                        item);
12297       return item;
12298     }
12299
12300   assert ("fall-through error" == NULL);
12301   return error_mark_node;
12302 }
12303
12304 /* Obtain a temp var with given data type.
12305
12306    size is FFETARGET_charactersizeNONE for a non-CHARACTER type
12307    or >= 0 for a CHARACTER type.
12308
12309    elements is -1 for a scalar or > 0 for an array of type.  */
12310
12311 tree
12312 ffecom_make_tempvar (const char *commentary, tree type,
12313                      ffetargetCharacterSize size, int elements)
12314 {
12315   tree t;
12316   static int mynumber;
12317
12318   assert (current_binding_level->prep_state < 2);
12319
12320   if (type == error_mark_node)
12321     return error_mark_node;
12322
12323   if (size != FFETARGET_charactersizeNONE)
12324     type = build_array_type (type,
12325                              build_range_type (ffecom_f2c_ftnlen_type_node,
12326                                                ffecom_f2c_ftnlen_one_node,
12327                                                build_int_2 (size, 0)));
12328   if (elements != -1)
12329     type = build_array_type (type,
12330                              build_range_type (integer_type_node,
12331                                                integer_zero_node,
12332                                                build_int_2 (elements - 1,
12333                                                             0)));
12334   t = build_decl (VAR_DECL,
12335                   ffecom_get_invented_identifier ("__g77_%s_%d",
12336                                                   commentary,
12337                                                   mynumber++),
12338                   type);
12339
12340   t = start_decl (t, FALSE);
12341   finish_decl (t, NULL_TREE, FALSE);
12342
12343   return t;
12344 }
12345
12346 /* Prepare argument pointer to expression.
12347
12348    Like ffecom_prepare_expr, except for expressions to be evaluated
12349    via ffecom_arg_ptr_to_expr.  */
12350
12351 void
12352 ffecom_prepare_arg_ptr_to_expr (ffebld expr)
12353 {
12354   /* ~~For now, it seems to be the same thing.  */
12355   ffecom_prepare_expr (expr);
12356   return;
12357 }
12358
12359 /* End of preparations.  */
12360
12361 bool
12362 ffecom_prepare_end (void)
12363 {
12364   int prep_state = current_binding_level->prep_state;
12365
12366   assert (prep_state < 2);
12367   current_binding_level->prep_state = 2;
12368
12369   return (prep_state == 1) ? TRUE : FALSE;
12370 }
12371
12372 /* Prepare expression.
12373
12374    This is called before any code is generated for the current block.
12375    It scans the expression, declares any temporaries that might be needed
12376    during evaluation of the expression, and stores those temporaries in
12377    the appropriate "hook" fields of the expression.  `dest', if not NULL,
12378    specifies the destination that ffecom_expr_ will see, in case that
12379    helps avoid generating unused temporaries.
12380
12381    ~~Improve to avoid allocating unused temporaries by taking `dest'
12382    into account vis-a-vis aliasing requirements of complex/character
12383    functions.  */
12384
12385 void
12386 ffecom_prepare_expr_ (ffebld expr, ffebld dest UNUSED)
12387 {
12388   ffeinfoBasictype bt;
12389   ffeinfoKindtype kt;
12390   ffetargetCharacterSize sz;
12391   tree tempvar = NULL_TREE;
12392
12393   assert (current_binding_level->prep_state < 2);
12394
12395   if (! expr)
12396     return;
12397
12398   bt = ffeinfo_basictype (ffebld_info (expr));
12399   kt = ffeinfo_kindtype (ffebld_info (expr));
12400   sz = ffeinfo_size (ffebld_info (expr));
12401
12402   /* Generate whatever temporaries are needed to represent the result
12403      of the expression.  */
12404
12405   if (bt == FFEINFO_basictypeCHARACTER)
12406     {
12407       while (ffebld_op (expr) == FFEBLD_opPAREN)
12408         expr = ffebld_left (expr);
12409     }
12410
12411   switch (ffebld_op (expr))
12412     {
12413     default:
12414       /* Don't make temps for SYMTER, CONTER, etc.  */
12415       if (ffebld_arity (expr) == 0)
12416         break;
12417
12418       switch (bt)
12419         {
12420         case FFEINFO_basictypeCOMPLEX:
12421           if (ffebld_op (expr) == FFEBLD_opFUNCREF)
12422             {
12423               ffesymbol s;
12424
12425               if (ffebld_op (ffebld_left (expr)) != FFEBLD_opSYMTER)
12426                 break;
12427
12428               s = ffebld_symter (ffebld_left (expr));
12429               if (ffesymbol_where (s) == FFEINFO_whereCONSTANT
12430                   || (ffesymbol_where (s) != FFEINFO_whereINTRINSIC
12431                       && ! ffesymbol_is_f2c (s))
12432                   || (ffesymbol_where (s) == FFEINFO_whereINTRINSIC
12433                       && ! ffe_is_f2c_library ()))
12434                 break;
12435             }
12436           else if (ffebld_op (expr) == FFEBLD_opPOWER)
12437             {
12438               /* Requires special treatment.  There's no POW_CC function
12439                  in libg2c, so POW_ZZ is used, which means we always
12440                  need a double-complex temp, not a single-complex.  */
12441               kt = FFEINFO_kindtypeREAL2;
12442             }
12443           else if (ffebld_op (expr) != FFEBLD_opDIVIDE)
12444             /* The other ops don't need temps for complex operands.  */
12445             break;
12446
12447           /* ~~~Avoid making temps for some intrinsics, such as AIMAG(C),
12448              REAL(C).  See 19990325-0.f, routine `check', for cases.  */
12449           tempvar = ffecom_make_tempvar ("complex",
12450                                          ffecom_tree_type
12451                                          [FFEINFO_basictypeCOMPLEX][kt],
12452                                          FFETARGET_charactersizeNONE,
12453                                          -1);
12454           break;
12455
12456         case FFEINFO_basictypeCHARACTER:
12457           if (ffebld_op (expr) != FFEBLD_opFUNCREF)
12458             break;
12459
12460           if (sz == FFETARGET_charactersizeNONE)
12461             /* ~~Kludge alert!  This should someday be fixed. */
12462             sz = 24;
12463
12464           tempvar = ffecom_make_tempvar ("char", char_type_node, sz, -1);
12465           break;
12466
12467         default:
12468           break;
12469         }
12470       break;
12471
12472 #ifdef HAHA
12473     case FFEBLD_opPOWER:
12474       {
12475         tree rtype, ltype;
12476         tree rtmp, ltmp, result;
12477
12478         ltype = ffecom_type_expr (ffebld_left (expr));
12479         rtype = ffecom_type_expr (ffebld_right (expr));
12480
12481         rtmp = ffecom_make_tempvar (rtype, FFETARGET_charactersizeNONE, -1);
12482         ltmp = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
12483         result = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
12484
12485         tempvar = make_tree_vec (3);
12486         TREE_VEC_ELT (tempvar, 0) = rtmp;
12487         TREE_VEC_ELT (tempvar, 1) = ltmp;
12488         TREE_VEC_ELT (tempvar, 2) = result;
12489       }
12490       break;
12491 #endif  /* HAHA */
12492
12493     case FFEBLD_opCONCATENATE:
12494       {
12495         /* This gets special handling, because only one set of temps
12496            is needed for a tree of these -- the tree is treated as
12497            a flattened list of concatenations when generating code.  */
12498
12499         ffecomConcatList_ catlist;
12500         tree ltmp, itmp, result;
12501         int count;
12502         int i;
12503
12504         catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
12505         count = ffecom_concat_list_count_ (catlist);
12506
12507         if (count >= 2)
12508           {
12509             ltmp
12510               = ffecom_make_tempvar ("concat_len",
12511                                      ffecom_f2c_ftnlen_type_node,
12512                                      FFETARGET_charactersizeNONE, count);
12513             itmp
12514               = ffecom_make_tempvar ("concat_item",
12515                                      ffecom_f2c_address_type_node,
12516                                      FFETARGET_charactersizeNONE, count);
12517             result
12518               = ffecom_make_tempvar ("concat_res",
12519                                      char_type_node,
12520                                      ffecom_concat_list_maxlen_ (catlist),
12521                                      -1);
12522
12523             tempvar = make_tree_vec (3);
12524             TREE_VEC_ELT (tempvar, 0) = ltmp;
12525             TREE_VEC_ELT (tempvar, 1) = itmp;
12526             TREE_VEC_ELT (tempvar, 2) = result;
12527           }
12528
12529         for (i = 0; i < count; ++i)
12530           ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist,
12531                                                                     i));
12532
12533         ffecom_concat_list_kill_ (catlist);
12534
12535         if (tempvar)
12536           {
12537             ffebld_nonter_set_hook (expr, tempvar);
12538             current_binding_level->prep_state = 1;
12539           }
12540       }
12541       return;
12542
12543     case FFEBLD_opCONVERT:
12544       if (bt == FFEINFO_basictypeCHARACTER
12545           && ((ffebld_size_known (ffebld_left (expr))
12546                == FFETARGET_charactersizeNONE)
12547               || (ffebld_size_known (ffebld_left (expr)) >= sz)))
12548         tempvar = ffecom_make_tempvar ("convert", char_type_node, sz, -1);
12549       break;
12550     }
12551
12552   if (tempvar)
12553     {
12554       ffebld_nonter_set_hook (expr, tempvar);
12555       current_binding_level->prep_state = 1;
12556     }
12557
12558   /* Prepare subexpressions for this expr.  */
12559
12560   switch (ffebld_op (expr))
12561     {
12562     case FFEBLD_opPERCENT_LOC:
12563       ffecom_prepare_ptr_to_expr (ffebld_left (expr));
12564       break;
12565
12566     case FFEBLD_opPERCENT_VAL:
12567     case FFEBLD_opPERCENT_REF:
12568       ffecom_prepare_expr (ffebld_left (expr));
12569       break;
12570
12571     case FFEBLD_opPERCENT_DESCR:
12572       ffecom_prepare_arg_ptr_to_expr (ffebld_left (expr));
12573       break;
12574
12575     case FFEBLD_opITEM:
12576       {
12577         ffebld item;
12578
12579         for (item = expr;
12580              item != NULL;
12581              item = ffebld_trail (item))
12582           if (ffebld_head (item) != NULL)
12583             ffecom_prepare_expr (ffebld_head (item));
12584       }
12585       break;
12586
12587     default:
12588       /* Need to handle character conversion specially.  */
12589       switch (ffebld_arity (expr))
12590         {
12591         case 2:
12592           ffecom_prepare_expr (ffebld_left (expr));
12593           ffecom_prepare_expr (ffebld_right (expr));
12594           break;
12595
12596         case 1:
12597           ffecom_prepare_expr (ffebld_left (expr));
12598           break;
12599
12600         default:
12601           break;
12602         }
12603     }
12604
12605   return;
12606 }
12607
12608 /* Prepare expression for reading and writing.
12609
12610    Like ffecom_prepare_expr, except for expressions to be evaluated
12611    via ffecom_expr_rw.  */
12612
12613 void
12614 ffecom_prepare_expr_rw (tree type, ffebld expr)
12615 {
12616   /* This is all we support for now.  */
12617   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
12618
12619   /* ~~For now, it seems to be the same thing.  */
12620   ffecom_prepare_expr (expr);
12621   return;
12622 }
12623
12624 /* Prepare expression for writing.
12625
12626    Like ffecom_prepare_expr, except for expressions to be evaluated
12627    via ffecom_expr_w.  */
12628
12629 void
12630 ffecom_prepare_expr_w (tree type, ffebld expr)
12631 {
12632   /* This is all we support for now.  */
12633   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
12634
12635   /* ~~For now, it seems to be the same thing.  */
12636   ffecom_prepare_expr (expr);
12637   return;
12638 }
12639
12640 /* Prepare expression for returning.
12641
12642    Like ffecom_prepare_expr, except for expressions to be evaluated
12643    via ffecom_return_expr.  */
12644
12645 void
12646 ffecom_prepare_return_expr (ffebld expr)
12647 {
12648   assert (current_binding_level->prep_state < 2);
12649
12650   if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE
12651       && ffecom_is_altreturning_
12652       && expr != NULL)
12653     ffecom_prepare_expr (expr);
12654 }
12655
12656 /* Prepare pointer to expression.
12657
12658    Like ffecom_prepare_expr, except for expressions to be evaluated
12659    via ffecom_ptr_to_expr.  */
12660
12661 void
12662 ffecom_prepare_ptr_to_expr (ffebld expr)
12663 {
12664   /* ~~For now, it seems to be the same thing.  */
12665   ffecom_prepare_expr (expr);
12666   return;
12667 }
12668
12669 /* Transform expression into constant pointer-to-expression tree.
12670
12671    If the expression can be transformed into a pointer-to-expression tree
12672    that is constant, that is done, and the tree returned.  Else NULL_TREE
12673    is returned.
12674
12675    That way, a caller can attempt to provide compile-time initialization
12676    of a variable and, if that fails, *then* choose to start a new block
12677    and resort to using temporaries, as appropriate.  */
12678
12679 tree
12680 ffecom_ptr_to_const_expr (ffebld expr)
12681 {
12682   if (! expr)
12683     return integer_zero_node;
12684
12685   if (ffebld_op (expr) == FFEBLD_opANY)
12686     return error_mark_node;
12687
12688   if (ffebld_arity (expr) == 0
12689       && (ffebld_op (expr) != FFEBLD_opSYMTER
12690           || ffebld_where (expr) == FFEINFO_whereCOMMON
12691           || ffebld_where (expr) == FFEINFO_whereGLOBAL
12692           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
12693     {
12694       tree t;
12695
12696       t = ffecom_ptr_to_expr (expr);
12697       assert (TREE_CONSTANT (t));
12698       return t;
12699     }
12700
12701   return NULL_TREE;
12702 }
12703
12704 /* ffecom_return_expr -- Returns return-value expr given alt return expr
12705
12706    tree rtn;  // NULL_TREE means use expand_null_return()
12707    ffebld expr;  // NULL if no alt return expr to RETURN stmt
12708    rtn = ffecom_return_expr(expr);
12709
12710    Based on the program unit type and other info (like return function
12711    type, return master function type when alternate ENTRY points,
12712    whether subroutine has any alternate RETURN points, etc), returns the
12713    appropriate expression to be returned to the caller, or NULL_TREE
12714    meaning no return value or the caller expects it to be returned somewhere
12715    else (which is handled by other parts of this module).  */
12716
12717 tree
12718 ffecom_return_expr (ffebld expr)
12719 {
12720   tree rtn;
12721
12722   switch (ffecom_primary_entry_kind_)
12723     {
12724     case FFEINFO_kindPROGRAM:
12725     case FFEINFO_kindBLOCKDATA:
12726       rtn = NULL_TREE;
12727       break;
12728
12729     case FFEINFO_kindSUBROUTINE:
12730       if (!ffecom_is_altreturning_)
12731         rtn = NULL_TREE;        /* No alt returns, never an expr. */
12732       else if (expr == NULL)
12733         rtn = integer_zero_node;
12734       else
12735         rtn = ffecom_expr (expr);
12736       break;
12737
12738     case FFEINFO_kindFUNCTION:
12739       if ((ffecom_multi_retval_ != NULL_TREE)
12740           || (ffesymbol_basictype (ffecom_primary_entry_)
12741               == FFEINFO_basictypeCHARACTER)
12742           || ((ffesymbol_basictype (ffecom_primary_entry_)
12743                == FFEINFO_basictypeCOMPLEX)
12744               && (ffecom_num_entrypoints_ == 0)
12745               && ffesymbol_is_f2c (ffecom_primary_entry_)))
12746         {                       /* Value is returned by direct assignment
12747                                    into (implicit) dummy. */
12748           rtn = NULL_TREE;
12749           break;
12750         }
12751       rtn = ffecom_func_result_;
12752 #if 0
12753       /* Spurious error if RETURN happens before first reference!  So elide
12754          this code.  In particular, for debugging registry, rtn should always
12755          be non-null after all, but TREE_USED won't be set until we encounter
12756          a reference in the code.  Perfectly okay (but weird) code that,
12757          e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in
12758          this diagnostic for no reason.  Have people use -O -Wuninitialized
12759          and leave it to the back end to find obviously weird cases.  */
12760
12761       /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid
12762          situation; if the return value has never been referenced, it won't
12763          have a tree under 2pass mode. */
12764       if ((rtn == NULL_TREE)
12765           || !TREE_USED (rtn))
12766         {
12767           ffebad_start (FFEBAD_RETURN_VALUE_UNSET);
12768           ffebad_here (0, ffesymbol_where_line (ffecom_primary_entry_),
12769                        ffesymbol_where_column (ffecom_primary_entry_));
12770           ffebad_string (ffesymbol_text (ffesymbol_funcresult
12771                                          (ffecom_primary_entry_)));
12772           ffebad_finish ();
12773         }
12774 #endif
12775       break;
12776
12777     default:
12778       assert ("bad unit kind" == NULL);
12779     case FFEINFO_kindANY:
12780       rtn = error_mark_node;
12781       break;
12782     }
12783
12784   return rtn;
12785 }
12786
12787 /* Do save_expr only if tree is not error_mark_node.  */
12788
12789 tree
12790 ffecom_save_tree (tree t)
12791 {
12792   return save_expr (t);
12793 }
12794
12795 /* Start a compound statement (block).  */
12796
12797 void
12798 ffecom_start_compstmt (void)
12799 {
12800   bison_rule_pushlevel_ ();
12801 }
12802
12803 /* Public entry point for front end to access start_decl.  */
12804
12805 tree
12806 ffecom_start_decl (tree decl, bool is_initialized)
12807 {
12808   DECL_INITIAL (decl) = is_initialized ? error_mark_node : NULL_TREE;
12809   return start_decl (decl, FALSE);
12810 }
12811
12812 /* ffecom_sym_commit -- Symbol's state being committed to reality
12813
12814    ffesymbol s;
12815    ffecom_sym_commit(s);
12816
12817    Does whatever the backend needs when a symbol is committed after having
12818    been backtrackable for a period of time.  */
12819
12820 void
12821 ffecom_sym_commit (ffesymbol s UNUSED)
12822 {
12823   assert (!ffesymbol_retractable ());
12824 }
12825
12826 /* ffecom_sym_end_transition -- Perform end transition on all symbols
12827
12828    ffecom_sym_end_transition();
12829
12830    Does backend-specific stuff and also calls ffest_sym_end_transition
12831    to do the necessary FFE stuff.
12832
12833    Backtracking is never enabled when this fn is called, so don't worry
12834    about it.  */
12835
12836 ffesymbol
12837 ffecom_sym_end_transition (ffesymbol s)
12838 {
12839   ffestorag st;
12840
12841   assert (!ffesymbol_retractable ());
12842
12843   s = ffest_sym_end_transition (s);
12844
12845   if ((ffesymbol_kind (s) == FFEINFO_kindBLOCKDATA)
12846       && (ffesymbol_where (s) == FFEINFO_whereGLOBAL))
12847     {
12848       ffecom_list_blockdata_
12849         = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
12850                                               FFEINTRIN_specNONE,
12851                                               FFEINTRIN_impNONE),
12852                            ffecom_list_blockdata_);
12853     }
12854
12855   /* This is where we finally notice that a symbol has partial initialization
12856      and finalize it. */
12857
12858   if (ffesymbol_accretion (s) != NULL)
12859     {
12860       assert (ffesymbol_init (s) == NULL);
12861       ffecom_notify_init_symbol (s);
12862     }
12863   else if (((st = ffesymbol_storage (s)) != NULL)
12864            && ((st = ffestorag_parent (st)) != NULL)
12865            && (ffestorag_accretion (st) != NULL))
12866     {
12867       assert (ffestorag_init (st) == NULL);
12868       ffecom_notify_init_storage (st);
12869     }
12870
12871   if ((ffesymbol_kind (s) == FFEINFO_kindCOMMON)
12872       && (ffesymbol_where (s) == FFEINFO_whereLOCAL)
12873       && (ffesymbol_storage (s) != NULL))
12874     {
12875       ffecom_list_common_
12876         = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
12877                                               FFEINTRIN_specNONE,
12878                                               FFEINTRIN_impNONE),
12879                            ffecom_list_common_);
12880     }
12881
12882   return s;
12883 }
12884
12885 /* ffecom_sym_exec_transition -- Perform exec transition on all symbols
12886
12887    ffecom_sym_exec_transition();
12888
12889    Does backend-specific stuff and also calls ffest_sym_exec_transition
12890    to do the necessary FFE stuff.
12891
12892    See the long-winded description in ffecom_sym_learned for info
12893    on handling the situation where backtracking is inhibited.  */
12894
12895 ffesymbol
12896 ffecom_sym_exec_transition (ffesymbol s)
12897 {
12898   s = ffest_sym_exec_transition (s);
12899
12900   return s;
12901 }
12902
12903 /* ffecom_sym_learned -- Initial or more info gained on symbol after exec
12904
12905    ffesymbol s;
12906    s = ffecom_sym_learned(s);
12907
12908    Called when a new symbol is seen after the exec transition or when more
12909    info (perhaps) is gained for an UNCERTAIN symbol.  The symbol state when
12910    it arrives here is that all its latest info is updated already, so its
12911    state may be UNCERTAIN or UNDERSTOOD, it might already have the hook
12912    field filled in if its gone through here or exec_transition first, and
12913    so on.
12914
12915    The backend probably wants to check ffesymbol_retractable() to see if
12916    backtracking is in effect.  If so, the FFE's changes to the symbol may
12917    be retracted (undone) or committed (ratified), at which time the
12918    appropriate ffecom_sym_retract or _commit function will be called
12919    for that function.
12920
12921    If the backend has its own backtracking mechanism, great, use it so that
12922    committal is a simple operation.  Though it doesn't make much difference,
12923    I suppose: the reason for tentative symbol evolution in the FFE is to
12924    enable error detection in weird incorrect statements early and to disable
12925    incorrect error detection on a correct statement.  The backend is not
12926    likely to introduce any information that'll get involved in these
12927    considerations, so it is probably just fine that the implementation
12928    model for this fn and for _exec_transition is to not do anything
12929    (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE
12930    and instead wait until ffecom_sym_commit is called (which it never
12931    will be as long as we're using ambiguity-detecting statement analysis in
12932    the FFE, which we are initially to shake out the code, but don't depend
12933    on this), otherwise go ahead and do whatever is needed.
12934
12935    In essence, then, when this fn and _exec_transition get called while
12936    backtracking is enabled, a general mechanism would be to flag which (or
12937    both) of these were called (and in what order? neat question as to what
12938    might happen that I'm too lame to think through right now) and then when
12939    _commit is called reproduce the original calling sequence, if any, for
12940    the two fns (at which point backtracking will, of course, be disabled).  */
12941
12942 ffesymbol
12943 ffecom_sym_learned (ffesymbol s)
12944 {
12945   ffestorag_exec_layout (s);
12946
12947   return s;
12948 }
12949
12950 /* ffecom_sym_retract -- Symbol's state being retracted from reality
12951
12952    ffesymbol s;
12953    ffecom_sym_retract(s);
12954
12955    Does whatever the backend needs when a symbol is retracted after having
12956    been backtrackable for a period of time.  */
12957
12958 void
12959 ffecom_sym_retract (ffesymbol s UNUSED)
12960 {
12961   assert (!ffesymbol_retractable ());
12962
12963 #if 0                           /* GCC doesn't commit any backtrackable sins,
12964                                    so nothing needed here. */
12965   switch (ffesymbol_hook (s).state)
12966     {
12967     case 0:                     /* nothing happened yet. */
12968       break;
12969
12970     case 1:                     /* exec transition happened. */
12971       break;
12972
12973     case 2:                     /* learned happened. */
12974       break;
12975
12976     case 3:                     /* learned then exec. */
12977       break;
12978
12979     case 4:                     /* exec then learned. */
12980       break;
12981
12982     default:
12983       assert ("bad hook state" == NULL);
12984       break;
12985     }
12986 #endif
12987 }
12988
12989 /* Create temporary gcc label.  */
12990
12991 tree
12992 ffecom_temp_label ()
12993 {
12994   tree glabel;
12995   static int mynumber = 0;
12996
12997   glabel = build_decl (LABEL_DECL,
12998                        ffecom_get_invented_identifier ("__g77_label_%d",
12999                                                        mynumber++),
13000                        void_type_node);
13001   DECL_CONTEXT (glabel) = current_function_decl;
13002   DECL_MODE (glabel) = VOIDmode;
13003
13004   return glabel;
13005 }
13006
13007 /* Return an expression that is usable as an arg in a conditional context
13008    (IF, DO WHILE, .NOT., and so on).
13009
13010    Use the one provided for the back end as of >2.6.0.  */
13011
13012 tree
13013 ffecom_truth_value (tree expr)
13014 {
13015   return ffe_truthvalue_conversion (expr);
13016 }
13017
13018 /* Return the inversion of a truth value (the inversion of what
13019    ffecom_truth_value builds).
13020
13021    Apparently invert_truthvalue, which is properly in the back end, is
13022    enough for now, so just use it.  */
13023
13024 tree
13025 ffecom_truth_value_invert (tree expr)
13026 {
13027   return invert_truthvalue (ffecom_truth_value (expr));
13028 }
13029
13030 /* Return the tree that is the type of the expression, as would be
13031    returned in TREE_TYPE(ffecom_expr(expr)), without otherwise
13032    transforming the expression, generating temporaries, etc.  */
13033
13034 tree
13035 ffecom_type_expr (ffebld expr)
13036 {
13037   ffeinfoBasictype bt;
13038   ffeinfoKindtype kt;
13039   tree tree_type;
13040
13041   assert (expr != NULL);
13042
13043   bt = ffeinfo_basictype (ffebld_info (expr));
13044   kt = ffeinfo_kindtype (ffebld_info (expr));
13045   tree_type = ffecom_tree_type[bt][kt];
13046
13047   switch (ffebld_op (expr))
13048     {
13049     case FFEBLD_opCONTER:
13050     case FFEBLD_opSYMTER:
13051     case FFEBLD_opARRAYREF:
13052     case FFEBLD_opUPLUS:
13053     case FFEBLD_opPAREN:
13054     case FFEBLD_opUMINUS:
13055     case FFEBLD_opADD:
13056     case FFEBLD_opSUBTRACT:
13057     case FFEBLD_opMULTIPLY:
13058     case FFEBLD_opDIVIDE:
13059     case FFEBLD_opPOWER:
13060     case FFEBLD_opNOT:
13061     case FFEBLD_opFUNCREF:
13062     case FFEBLD_opSUBRREF:
13063     case FFEBLD_opAND:
13064     case FFEBLD_opOR:
13065     case FFEBLD_opXOR:
13066     case FFEBLD_opNEQV:
13067     case FFEBLD_opEQV:
13068     case FFEBLD_opCONVERT:
13069     case FFEBLD_opLT:
13070     case FFEBLD_opLE:
13071     case FFEBLD_opEQ:
13072     case FFEBLD_opNE:
13073     case FFEBLD_opGT:
13074     case FFEBLD_opGE:
13075     case FFEBLD_opPERCENT_LOC:
13076       return tree_type;
13077
13078     case FFEBLD_opACCTER:
13079     case FFEBLD_opARRTER:
13080     case FFEBLD_opITEM:
13081     case FFEBLD_opSTAR:
13082     case FFEBLD_opBOUNDS:
13083     case FFEBLD_opREPEAT:
13084     case FFEBLD_opLABTER:
13085     case FFEBLD_opLABTOK:
13086     case FFEBLD_opIMPDO:
13087     case FFEBLD_opCONCATENATE:
13088     case FFEBLD_opSUBSTR:
13089     default:
13090       assert ("bad op for ffecom_type_expr" == NULL);
13091       /* Fall through. */
13092     case FFEBLD_opANY:
13093       return error_mark_node;
13094     }
13095 }
13096
13097 /* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points
13098
13099    If the PARM_DECL already exists, return it, else create it.  It's an
13100    integer_type_node argument for the master function that implements a
13101    subroutine or function with more than one entrypoint and is bound at
13102    run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for
13103    first ENTRY statement, and so on).  */
13104
13105 tree
13106 ffecom_which_entrypoint_decl ()
13107 {
13108   assert (ffecom_which_entrypoint_decl_ != NULL_TREE);
13109
13110   return ffecom_which_entrypoint_decl_;
13111 }
13112 \f
13113 /* The following sections consists of private and public functions
13114    that have the same names and perform roughly the same functions
13115    as counterparts in the C front end.  Changes in the C front end
13116    might affect how things should be done here.  Only functions
13117    needed by the back end should be public here; the rest should
13118    be private (static in the C sense).  Functions needed by other
13119    g77 front-end modules should be accessed by them via public
13120    ffecom_* names, which should themselves call private versions
13121    in this section so the private versions are easy to recognize
13122    when upgrading to a new gcc and finding interesting changes
13123    in the front end.
13124
13125    Functions named after rule "foo:" in c-parse.y are named
13126    "bison_rule_foo_" so they are easy to find.  */
13127
13128 static void
13129 bison_rule_pushlevel_ ()
13130 {
13131   emit_line_note (input_filename, lineno);
13132   pushlevel (0);
13133   clear_last_expr ();
13134   expand_start_bindings (0);
13135 }
13136
13137 static tree
13138 bison_rule_compstmt_ ()
13139 {
13140   tree t;
13141   int keep = kept_level_p ();
13142
13143   /* Make the temps go away.  */
13144   if (! keep)
13145     current_binding_level->names = NULL_TREE;
13146
13147   emit_line_note (input_filename, lineno);
13148   expand_end_bindings (getdecls (), keep, 0);
13149   t = poplevel (keep, 1, 0);
13150
13151   return t;
13152 }
13153
13154 /* Return a definition for a builtin function named NAME and whose data type
13155    is TYPE.  TYPE should be a function type with argument types.
13156    FUNCTION_CODE tells later passes how to compile calls to this function.
13157    See tree.h for its possible values.
13158
13159    If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
13160    the name to be called if we can't opencode the function.  */
13161
13162 tree
13163 builtin_function (const char *name, tree type, int function_code,
13164                   enum built_in_class class,
13165                   const char *library_name)
13166 {
13167   tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type);
13168   DECL_EXTERNAL (decl) = 1;
13169   TREE_PUBLIC (decl) = 1;
13170   if (library_name)
13171     SET_DECL_ASSEMBLER_NAME (decl, get_identifier (library_name));
13172   make_decl_rtl (decl, NULL);
13173   pushdecl (decl);
13174   DECL_BUILT_IN_CLASS (decl) = class;
13175   DECL_FUNCTION_CODE (decl) = function_code;
13176
13177   return decl;
13178 }
13179
13180 /* Handle when a new declaration NEWDECL
13181    has the same name as an old one OLDDECL
13182    in the same binding contour.
13183    Prints an error message if appropriate.
13184
13185    If safely possible, alter OLDDECL to look like NEWDECL, and return 1.
13186    Otherwise, return 0.  */
13187
13188 static int
13189 duplicate_decls (tree newdecl, tree olddecl)
13190 {
13191   int types_match = 1;
13192   int new_is_definition = (TREE_CODE (newdecl) == FUNCTION_DECL
13193                            && DECL_INITIAL (newdecl) != 0);
13194   tree oldtype = TREE_TYPE (olddecl);
13195   tree newtype = TREE_TYPE (newdecl);
13196
13197   if (olddecl == newdecl)
13198     return 1;
13199
13200   if (TREE_CODE (newtype) == ERROR_MARK
13201       || TREE_CODE (oldtype) == ERROR_MARK)
13202     types_match = 0;
13203
13204   /* New decl is completely inconsistent with the old one =>
13205      tell caller to replace the old one.
13206      This is always an error except in the case of shadowing a builtin.  */
13207   if (TREE_CODE (olddecl) != TREE_CODE (newdecl))
13208     return 0;
13209
13210   /* For real parm decl following a forward decl,
13211      return 1 so old decl will be reused.  */
13212   if (types_match && TREE_CODE (newdecl) == PARM_DECL
13213       && TREE_ASM_WRITTEN (olddecl) && ! TREE_ASM_WRITTEN (newdecl))
13214     return 1;
13215
13216   /* The new declaration is the same kind of object as the old one.
13217      The declarations may partially match.  Print warnings if they don't
13218      match enough.  Ultimately, copy most of the information from the new
13219      decl to the old one, and keep using the old one.  */
13220
13221   if (TREE_CODE (olddecl) == FUNCTION_DECL
13222       && DECL_BUILT_IN (olddecl))
13223     {
13224       /* A function declaration for a built-in function.  */
13225       if (!TREE_PUBLIC (newdecl))
13226         return 0;
13227       else if (!types_match)
13228         {
13229           /* Accept the return type of the new declaration if same modes.  */
13230           tree oldreturntype = TREE_TYPE (TREE_TYPE (olddecl));
13231           tree newreturntype = TREE_TYPE (TREE_TYPE (newdecl));
13232
13233           if (TYPE_MODE (oldreturntype) == TYPE_MODE (newreturntype))
13234             {
13235               /* Function types may be shared, so we can't just modify
13236                  the return type of olddecl's function type.  */
13237               tree newtype
13238                 = build_function_type (newreturntype,
13239                                        TYPE_ARG_TYPES (TREE_TYPE (olddecl)));
13240
13241               types_match = 1;
13242               if (types_match)
13243                 TREE_TYPE (olddecl) = newtype;
13244             }
13245         }
13246       if (!types_match)
13247         return 0;
13248     }
13249   else if (TREE_CODE (olddecl) == FUNCTION_DECL
13250            && DECL_SOURCE_LINE (olddecl) == 0)
13251     {
13252       /* A function declaration for a predeclared function
13253          that isn't actually built in.  */
13254       if (!TREE_PUBLIC (newdecl))
13255         return 0;
13256       else if (!types_match)
13257         {
13258           /* If the types don't match, preserve volatility indication.
13259              Later on, we will discard everything else about the
13260              default declaration.  */
13261           TREE_THIS_VOLATILE (newdecl) |= TREE_THIS_VOLATILE (olddecl);
13262         }
13263     }
13264
13265   /* Copy all the DECL_... slots specified in the new decl
13266      except for any that we copy here from the old type.
13267
13268      Past this point, we don't change OLDTYPE and NEWTYPE
13269      even if we change the types of NEWDECL and OLDDECL.  */
13270
13271   if (types_match)
13272     {
13273       /* Merge the data types specified in the two decls.  */
13274       if (TREE_CODE (newdecl) != FUNCTION_DECL || !DECL_BUILT_IN (olddecl))
13275         TREE_TYPE (newdecl)
13276           = TREE_TYPE (olddecl)
13277             = TREE_TYPE (newdecl);
13278
13279       /* Lay the type out, unless already done.  */
13280       if (oldtype != TREE_TYPE (newdecl))
13281         {
13282           if (TREE_TYPE (newdecl) != error_mark_node)
13283             layout_type (TREE_TYPE (newdecl));
13284           if (TREE_CODE (newdecl) != FUNCTION_DECL
13285               && TREE_CODE (newdecl) != TYPE_DECL
13286               && TREE_CODE (newdecl) != CONST_DECL)
13287             layout_decl (newdecl, 0);
13288         }
13289       else
13290         {
13291           /* Since the type is OLDDECL's, make OLDDECL's size go with.  */
13292           DECL_SIZE (newdecl) = DECL_SIZE (olddecl);
13293           DECL_SIZE_UNIT (newdecl) = DECL_SIZE_UNIT (olddecl);
13294           if (TREE_CODE (olddecl) != FUNCTION_DECL)
13295             if (DECL_ALIGN (olddecl) > DECL_ALIGN (newdecl))
13296               {
13297                 DECL_ALIGN (newdecl) = DECL_ALIGN (olddecl);
13298                 DECL_USER_ALIGN (newdecl) |= DECL_USER_ALIGN (olddecl);
13299               }
13300         }
13301
13302       /* Keep the old rtl since we can safely use it.  */
13303       COPY_DECL_RTL (olddecl, newdecl);
13304
13305       /* Merge the type qualifiers.  */
13306       if (DECL_BUILT_IN_NONANSI (olddecl) && TREE_THIS_VOLATILE (olddecl)
13307           && !TREE_THIS_VOLATILE (newdecl))
13308         TREE_THIS_VOLATILE (olddecl) = 0;
13309       if (TREE_READONLY (newdecl))
13310         TREE_READONLY (olddecl) = 1;
13311       if (TREE_THIS_VOLATILE (newdecl))
13312         {
13313           TREE_THIS_VOLATILE (olddecl) = 1;
13314           if (TREE_CODE (newdecl) == VAR_DECL)
13315             make_var_volatile (newdecl);
13316         }
13317
13318       /* Keep source location of definition rather than declaration.
13319          Likewise, keep decl at outer scope.  */
13320       if ((DECL_INITIAL (newdecl) == 0 && DECL_INITIAL (olddecl) != 0)
13321           || (DECL_CONTEXT (newdecl) != 0 && DECL_CONTEXT (olddecl) == 0))
13322         {
13323           DECL_SOURCE_LINE (newdecl) = DECL_SOURCE_LINE (olddecl);
13324           DECL_SOURCE_FILE (newdecl) = DECL_SOURCE_FILE (olddecl);
13325
13326           if (DECL_CONTEXT (olddecl) == 0
13327               && TREE_CODE (newdecl) != FUNCTION_DECL)
13328             DECL_CONTEXT (newdecl) = 0;
13329         }
13330
13331       /* Merge the unused-warning information.  */
13332       if (DECL_IN_SYSTEM_HEADER (olddecl))
13333         DECL_IN_SYSTEM_HEADER (newdecl) = 1;
13334       else if (DECL_IN_SYSTEM_HEADER (newdecl))
13335         DECL_IN_SYSTEM_HEADER (olddecl) = 1;
13336
13337       /* Merge the initialization information.  */
13338       if (DECL_INITIAL (newdecl) == 0)
13339         DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13340
13341       /* Merge the section attribute.
13342          We want to issue an error if the sections conflict but that must be
13343          done later in decl_attributes since we are called before attributes
13344          are assigned.  */
13345       if (DECL_SECTION_NAME (newdecl) == NULL_TREE)
13346         DECL_SECTION_NAME (newdecl) = DECL_SECTION_NAME (olddecl);
13347
13348       if (TREE_CODE (newdecl) == FUNCTION_DECL)
13349         {
13350           DECL_STATIC_CONSTRUCTOR(newdecl) |= DECL_STATIC_CONSTRUCTOR(olddecl);
13351           DECL_STATIC_DESTRUCTOR (newdecl) |= DECL_STATIC_DESTRUCTOR (olddecl);
13352         }
13353     }
13354   /* If cannot merge, then use the new type and qualifiers,
13355      and don't preserve the old rtl.  */
13356   else
13357     {
13358       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13359       TREE_READONLY (olddecl) = TREE_READONLY (newdecl);
13360       TREE_THIS_VOLATILE (olddecl) = TREE_THIS_VOLATILE (newdecl);
13361       TREE_SIDE_EFFECTS (olddecl) = TREE_SIDE_EFFECTS (newdecl);
13362     }
13363
13364   /* Merge the storage class information.  */
13365   /* For functions, static overrides non-static.  */
13366   if (TREE_CODE (newdecl) == FUNCTION_DECL)
13367     {
13368       TREE_PUBLIC (newdecl) &= TREE_PUBLIC (olddecl);
13369       /* This is since we don't automatically
13370          copy the attributes of NEWDECL into OLDDECL.  */
13371       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13372       /* If this clears `static', clear it in the identifier too.  */
13373       if (! TREE_PUBLIC (olddecl))
13374         TREE_PUBLIC (DECL_NAME (olddecl)) = 0;
13375     }
13376   if (DECL_EXTERNAL (newdecl))
13377     {
13378       TREE_STATIC (newdecl) = TREE_STATIC (olddecl);
13379       DECL_EXTERNAL (newdecl) = DECL_EXTERNAL (olddecl);
13380       /* An extern decl does not override previous storage class.  */
13381       TREE_PUBLIC (newdecl) = TREE_PUBLIC (olddecl);
13382     }
13383   else
13384     {
13385       TREE_STATIC (olddecl) = TREE_STATIC (newdecl);
13386       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13387     }
13388
13389   /* If either decl says `inline', this fn is inline,
13390      unless its definition was passed already.  */
13391   if (DECL_INLINE (newdecl) && DECL_INITIAL (olddecl) == 0)
13392     DECL_INLINE (olddecl) = 1;
13393   DECL_INLINE (newdecl) = DECL_INLINE (olddecl);
13394
13395   /* Get rid of any built-in function if new arg types don't match it
13396      or if we have a function definition.  */
13397   if (TREE_CODE (newdecl) == FUNCTION_DECL
13398       && DECL_BUILT_IN (olddecl)
13399       && (!types_match || new_is_definition))
13400     {
13401       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13402       DECL_BUILT_IN_CLASS (olddecl) = NOT_BUILT_IN;
13403     }
13404
13405   /* If redeclaring a builtin function, and not a definition,
13406      it stays built in.
13407      Also preserve various other info from the definition.  */
13408   if (TREE_CODE (newdecl) == FUNCTION_DECL && !new_is_definition)
13409     {
13410       if (DECL_BUILT_IN (olddecl))
13411         {
13412           DECL_BUILT_IN_CLASS (newdecl) = DECL_BUILT_IN_CLASS (olddecl);
13413           DECL_FUNCTION_CODE (newdecl) = DECL_FUNCTION_CODE (olddecl);
13414         }
13415
13416       DECL_RESULT (newdecl) = DECL_RESULT (olddecl);
13417       DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13418       DECL_SAVED_INSNS (newdecl) = DECL_SAVED_INSNS (olddecl);
13419       DECL_ARGUMENTS (newdecl) = DECL_ARGUMENTS (olddecl);
13420     }
13421
13422   /* Copy most of the decl-specific fields of NEWDECL into OLDDECL.
13423      But preserve olddecl's DECL_UID.  */
13424   {
13425     register unsigned olddecl_uid = DECL_UID (olddecl);
13426
13427     memcpy ((char *) olddecl + sizeof (struct tree_common),
13428             (char *) newdecl + sizeof (struct tree_common),
13429             sizeof (struct tree_decl) - sizeof (struct tree_common));
13430     DECL_UID (olddecl) = olddecl_uid;
13431   }
13432
13433   return 1;
13434 }
13435
13436 /* Finish processing of a declaration;
13437    install its initial value.
13438    If the length of an array type is not known before,
13439    it must be determined now, from the initial value, or it is an error.  */
13440
13441 static void
13442 finish_decl (tree decl, tree init, bool is_top_level)
13443 {
13444   register tree type = TREE_TYPE (decl);
13445   int was_incomplete = (DECL_SIZE (decl) == 0);
13446   bool at_top_level = (current_binding_level == global_binding_level);
13447   bool top_level = is_top_level || at_top_level;
13448
13449   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13450      level anyway.  */
13451   assert (!is_top_level || !at_top_level);
13452
13453   if (TREE_CODE (decl) == PARM_DECL)
13454     assert (init == NULL_TREE);
13455   /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it
13456      overlaps DECL_ARG_TYPE.  */
13457   else if (init == NULL_TREE)
13458     assert (DECL_INITIAL (decl) == NULL_TREE);
13459   else
13460     assert (DECL_INITIAL (decl) == error_mark_node);
13461
13462   if (init != NULL_TREE)
13463     {
13464       if (TREE_CODE (decl) != TYPE_DECL)
13465         DECL_INITIAL (decl) = init;
13466       else
13467         {
13468           /* typedef foo = bar; store the type of bar as the type of foo.  */
13469           TREE_TYPE (decl) = TREE_TYPE (init);
13470           DECL_INITIAL (decl) = init = 0;
13471         }
13472     }
13473
13474   /* Deduce size of array from initialization, if not already known */
13475
13476   if (TREE_CODE (type) == ARRAY_TYPE
13477       && TYPE_DOMAIN (type) == 0
13478       && TREE_CODE (decl) != TYPE_DECL)
13479     {
13480       assert (top_level);
13481       assert (was_incomplete);
13482
13483       layout_decl (decl, 0);
13484     }
13485
13486   if (TREE_CODE (decl) == VAR_DECL)
13487     {
13488       if (DECL_SIZE (decl) == NULL_TREE
13489           && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
13490         layout_decl (decl, 0);
13491
13492       if (DECL_SIZE (decl) == NULL_TREE
13493           && (TREE_STATIC (decl)
13494               ?
13495       /* A static variable with an incomplete type is an error if it is
13496          initialized. Also if it is not file scope. Otherwise, let it
13497          through, but if it is not `extern' then it may cause an error
13498          message later.  */
13499               (DECL_INITIAL (decl) != 0 || DECL_CONTEXT (decl) != 0)
13500               :
13501       /* An automatic variable with an incomplete type is an error.  */
13502               !DECL_EXTERNAL (decl)))
13503         {
13504           assert ("storage size not known" == NULL);
13505           abort ();
13506         }
13507
13508       if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl))
13509           && (DECL_SIZE (decl) != 0)
13510           && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST))
13511         {
13512           assert ("storage size not constant" == NULL);
13513           abort ();
13514         }
13515     }
13516
13517   /* Output the assembler code and/or RTL code for variables and functions,
13518      unless the type is an undefined structure or union. If not, it will get
13519      done when the type is completed.  */
13520
13521   if (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == FUNCTION_DECL)
13522     {
13523       rest_of_decl_compilation (decl, NULL,
13524                                 DECL_CONTEXT (decl) == 0,
13525                                 0);
13526
13527       if (DECL_CONTEXT (decl) != 0)
13528         {
13529           /* Recompute the RTL of a local array now if it used to be an
13530              incomplete type.  */
13531           if (was_incomplete
13532               && !TREE_STATIC (decl) && !DECL_EXTERNAL (decl))
13533             {
13534               /* If we used it already as memory, it must stay in memory.  */
13535               TREE_ADDRESSABLE (decl) = TREE_USED (decl);
13536               /* If it's still incomplete now, no init will save it.  */
13537               if (DECL_SIZE (decl) == 0)
13538                 DECL_INITIAL (decl) = 0;
13539               expand_decl (decl);
13540             }
13541           /* Compute and store the initial value.  */
13542           if (TREE_CODE (decl) != FUNCTION_DECL)
13543             expand_decl_init (decl);
13544         }
13545     }
13546   else if (TREE_CODE (decl) == TYPE_DECL)
13547     {
13548       rest_of_decl_compilation (decl, NULL,
13549                                 DECL_CONTEXT (decl) == 0,
13550                                 0);
13551     }
13552
13553   /* At the end of a declaration, throw away any variable type sizes of types
13554      defined inside that declaration.  There is no use computing them in the
13555      following function definition.  */
13556   if (current_binding_level == global_binding_level)
13557     get_pending_sizes ();
13558 }
13559
13560 /* Finish up a function declaration and compile that function
13561    all the way to assembler language output.  The free the storage
13562    for the function definition.
13563
13564    This is called after parsing the body of the function definition.
13565
13566    NESTED is nonzero if the function being finished is nested in another.  */
13567
13568 static void
13569 finish_function (int nested)
13570 {
13571   register tree fndecl = current_function_decl;
13572
13573   assert (fndecl != NULL_TREE);
13574   if (TREE_CODE (fndecl) != ERROR_MARK)
13575     {
13576       if (nested)
13577         assert (DECL_CONTEXT (fndecl) != NULL_TREE);
13578       else
13579         assert (DECL_CONTEXT (fndecl) == NULL_TREE);
13580     }
13581
13582 /*  TREE_READONLY (fndecl) = 1;
13583     This caused &foo to be of type ptr-to-const-function
13584     which then got a warning when stored in a ptr-to-function variable.  */
13585
13586   poplevel (1, 0, 1);
13587
13588   if (TREE_CODE (fndecl) != ERROR_MARK)
13589     {
13590       BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
13591
13592       /* Must mark the RESULT_DECL as being in this function.  */
13593
13594       DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl;
13595
13596       /* Obey `register' declarations if `setjmp' is called in this fn.  */
13597       /* Generate rtl for function exit.  */
13598       expand_function_end (input_filename, lineno, 0);
13599
13600       /* If this is a nested function, protect the local variables in the stack
13601          above us from being collected while we're compiling this function.  */
13602       if (nested)
13603         ggc_push_context ();
13604
13605       /* Run the optimizers and output the assembler code for this function.  */
13606       rest_of_compilation (fndecl);
13607
13608       /* Undo the GC context switch.  */
13609       if (nested)
13610         ggc_pop_context ();
13611     }
13612
13613   if (TREE_CODE (fndecl) != ERROR_MARK
13614       && !nested
13615       && DECL_SAVED_INSNS (fndecl) == 0)
13616     {
13617       /* Stop pointing to the local nodes about to be freed.  */
13618       /* But DECL_INITIAL must remain nonzero so we know this was an actual
13619          function definition.  */
13620       /* For a nested function, this is done in pop_f_function_context.  */
13621       /* If rest_of_compilation set this to 0, leave it 0.  */
13622       if (DECL_INITIAL (fndecl) != 0)
13623         DECL_INITIAL (fndecl) = error_mark_node;
13624       DECL_ARGUMENTS (fndecl) = 0;
13625     }
13626
13627   if (!nested)
13628     {
13629       /* Let the error reporting routines know that we're outside a function.
13630          For a nested function, this value is used in pop_c_function_context
13631          and then reset via pop_function_context.  */
13632       ffecom_outer_function_decl_ = current_function_decl = NULL;
13633     }
13634 }
13635
13636 /* Plug-in replacement for identifying the name of a decl and, for a
13637    function, what we call it in diagnostics.  For now, "program unit"
13638    should suffice, since it's a bit of a hassle to figure out which
13639    of several kinds of things it is.  Note that it could conceivably
13640    be a statement function, which probably isn't really a program unit
13641    per se, but if that comes up, it should be easy to check (being a
13642    nested function and all).  */
13643
13644 static const char *
13645 ffe_printable_name (tree decl, int v)
13646 {
13647   /* Just to keep GCC quiet about the unused variable.
13648      In theory, differing values of V should produce different
13649      output.  */
13650   switch (v)
13651     {
13652     default:
13653       if (TREE_CODE (decl) == ERROR_MARK)
13654         return "erroneous code";
13655       return IDENTIFIER_POINTER (DECL_NAME (decl));
13656     }
13657 }
13658
13659 /* g77's function to print out name of current function that caused
13660    an error.  */
13661
13662 static void
13663 ffe_print_error_function (diagnostic_context *context __attribute__((unused)),
13664                           const char *file)
13665 {
13666   static ffeglobal last_g = NULL;
13667   static ffesymbol last_s = NULL;
13668   ffeglobal g;
13669   ffesymbol s;
13670   const char *kind;
13671
13672   if ((ffecom_primary_entry_ == NULL)
13673       || (ffesymbol_global (ffecom_primary_entry_) == NULL))
13674     {
13675       g = NULL;
13676       s = NULL;
13677       kind = NULL;
13678     }
13679   else
13680     {
13681       g = ffesymbol_global (ffecom_primary_entry_);
13682       if (ffecom_nested_entry_ == NULL)
13683         {
13684           s = ffecom_primary_entry_;
13685           kind = _(ffeinfo_kind_message (ffesymbol_kind (s)));
13686         }
13687       else
13688         {
13689           s = ffecom_nested_entry_;
13690           kind = _("In statement function");
13691         }
13692     }
13693
13694   if ((last_g != g) || (last_s != s))
13695     {
13696       if (file)
13697         fprintf (stderr, "%s: ", file);
13698
13699       if (s == NULL)
13700         fprintf (stderr, _("Outside of any program unit:\n"));
13701       else
13702         {
13703           const char *name = ffesymbol_text (s);
13704
13705           fprintf (stderr, "%s `%s':\n", kind, name);
13706         }
13707
13708       last_g = g;
13709       last_s = s;
13710     }
13711 }
13712
13713 /* Similar to `lookup_name' but look only at current binding level.  */
13714
13715 static tree
13716 lookup_name_current_level (tree name)
13717 {
13718   register tree t;
13719
13720   if (current_binding_level == global_binding_level)
13721     return IDENTIFIER_GLOBAL_VALUE (name);
13722
13723   if (IDENTIFIER_LOCAL_VALUE (name) == 0)
13724     return 0;
13725
13726   for (t = current_binding_level->names; t; t = TREE_CHAIN (t))
13727     if (DECL_NAME (t) == name)
13728       break;
13729
13730   return t;
13731 }
13732
13733 /* Create a new `struct f_binding_level'.  */
13734
13735 static struct f_binding_level *
13736 make_binding_level ()
13737 {
13738   /* NOSTRICT */
13739   return ggc_alloc (sizeof (struct f_binding_level));
13740 }
13741
13742 /* Save and restore the variables in this file and elsewhere
13743    that keep track of the progress of compilation of the current function.
13744    Used for nested functions.  */
13745
13746 struct f_function
13747 {
13748   struct f_function *next;
13749   tree named_labels;
13750   tree shadowed_labels;
13751   struct f_binding_level *binding_level;
13752 };
13753
13754 struct f_function *f_function_chain;
13755
13756 /* Restore the variables used during compilation of a C function.  */
13757
13758 static void
13759 pop_f_function_context ()
13760 {
13761   struct f_function *p = f_function_chain;
13762   tree link;
13763
13764   /* Bring back all the labels that were shadowed.  */
13765   for (link = shadowed_labels; link; link = TREE_CHAIN (link))
13766     if (DECL_NAME (TREE_VALUE (link)) != 0)
13767       IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link)))
13768         = TREE_VALUE (link);
13769
13770   if (current_function_decl != error_mark_node
13771       && DECL_SAVED_INSNS (current_function_decl) == 0)
13772     {
13773       /* Stop pointing to the local nodes about to be freed.  */
13774       /* But DECL_INITIAL must remain nonzero so we know this was an actual
13775          function definition.  */
13776       DECL_INITIAL (current_function_decl) = error_mark_node;
13777       DECL_ARGUMENTS (current_function_decl) = 0;
13778     }
13779
13780   pop_function_context ();
13781
13782   f_function_chain = p->next;
13783
13784   named_labels = p->named_labels;
13785   shadowed_labels = p->shadowed_labels;
13786   current_binding_level = p->binding_level;
13787
13788   free (p);
13789 }
13790
13791 /* Save and reinitialize the variables
13792    used during compilation of a C function.  */
13793
13794 static void
13795 push_f_function_context ()
13796 {
13797   struct f_function *p
13798   = (struct f_function *) xmalloc (sizeof (struct f_function));
13799
13800   push_function_context ();
13801
13802   p->next = f_function_chain;
13803   f_function_chain = p;
13804
13805   p->named_labels = named_labels;
13806   p->shadowed_labels = shadowed_labels;
13807   p->binding_level = current_binding_level;
13808 }
13809
13810 static void
13811 push_parm_decl (tree parm)
13812 {
13813   int old_immediate_size_expand = immediate_size_expand;
13814
13815   /* Don't try computing parm sizes now -- wait till fn is called.  */
13816
13817   immediate_size_expand = 0;
13818
13819   /* Fill in arg stuff.  */
13820
13821   DECL_ARG_TYPE (parm) = TREE_TYPE (parm);
13822   DECL_ARG_TYPE_AS_WRITTEN (parm) = TREE_TYPE (parm);
13823   TREE_READONLY (parm) = 1;     /* All implementation args are read-only. */
13824
13825   parm = pushdecl (parm);
13826
13827   immediate_size_expand = old_immediate_size_expand;
13828
13829   finish_decl (parm, NULL_TREE, FALSE);
13830 }
13831
13832 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate.  */
13833
13834 static tree
13835 pushdecl_top_level (x)
13836      tree x;
13837 {
13838   register tree t;
13839   register struct f_binding_level *b = current_binding_level;
13840   register tree f = current_function_decl;
13841
13842   current_binding_level = global_binding_level;
13843   current_function_decl = NULL_TREE;
13844   t = pushdecl (x);
13845   current_binding_level = b;
13846   current_function_decl = f;
13847   return t;
13848 }
13849
13850 /* Store the list of declarations of the current level.
13851    This is done for the parameter declarations of a function being defined,
13852    after they are modified in the light of any missing parameters.  */
13853
13854 static tree
13855 storedecls (decls)
13856      tree decls;
13857 {
13858   return current_binding_level->names = decls;
13859 }
13860
13861 /* Store the parameter declarations into the current function declaration.
13862    This is called after parsing the parameter declarations, before
13863    digesting the body of the function.
13864
13865    For an old-style definition, modify the function's type
13866    to specify at least the number of arguments.  */
13867
13868 static void
13869 store_parm_decls (int is_main_program UNUSED)
13870 {
13871   register tree fndecl = current_function_decl;
13872
13873   if (fndecl == error_mark_node)
13874     return;
13875
13876   /* This is a chain of PARM_DECLs from old-style parm declarations.  */
13877   DECL_ARGUMENTS (fndecl) = storedecls (nreverse (getdecls ()));
13878
13879   /* Initialize the RTL code for the function.  */
13880
13881   init_function_start (fndecl, input_filename, lineno);
13882
13883   /* Set up parameters and prepare for return, for the function.  */
13884
13885   expand_function_start (fndecl, 0);
13886 }
13887
13888 static tree
13889 start_decl (tree decl, bool is_top_level)
13890 {
13891   register tree tem;
13892   bool at_top_level = (current_binding_level == global_binding_level);
13893   bool top_level = is_top_level || at_top_level;
13894
13895   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13896      level anyway.  */
13897   assert (!is_top_level || !at_top_level);
13898
13899   if (DECL_INITIAL (decl) != NULL_TREE)
13900     {
13901       assert (DECL_INITIAL (decl) == error_mark_node);
13902       assert (!DECL_EXTERNAL (decl));
13903     }
13904   else if (top_level)
13905     assert ((TREE_STATIC (decl) == 1) || DECL_EXTERNAL (decl) == 1);
13906
13907   /* For Fortran, we by default put things in .common when possible.  */
13908   DECL_COMMON (decl) = 1;
13909
13910   /* Add this decl to the current binding level. TEM may equal DECL or it may
13911      be a previous decl of the same name.  */
13912   if (is_top_level)
13913     tem = pushdecl_top_level (decl);
13914   else
13915     tem = pushdecl (decl);
13916
13917   /* For a local variable, define the RTL now.  */
13918   if (!top_level
13919   /* But not if this is a duplicate decl and we preserved the rtl from the
13920      previous one (which may or may not happen).  */
13921       && !DECL_RTL_SET_P (tem))
13922     {
13923       if (TYPE_SIZE (TREE_TYPE (tem)) != 0)
13924         expand_decl (tem);
13925       else if (TREE_CODE (TREE_TYPE (tem)) == ARRAY_TYPE
13926                && DECL_INITIAL (tem) != 0)
13927         expand_decl (tem);
13928     }
13929
13930   return tem;
13931 }
13932
13933 /* Create the FUNCTION_DECL for a function definition.
13934    DECLSPECS and DECLARATOR are the parts of the declaration;
13935    they describe the function's name and the type it returns,
13936    but twisted together in a fashion that parallels the syntax of C.
13937
13938    This function creates a binding context for the function body
13939    as well as setting up the FUNCTION_DECL in current_function_decl.
13940
13941    Returns 1 on success.  If the DECLARATOR is not suitable for a function
13942    (it defines a datum instead), we return 0, which tells
13943    ffe_parse_file to report a parse error.
13944
13945    NESTED is nonzero for a function nested within another function.  */
13946
13947 static void
13948 start_function (tree name, tree type, int nested, int public)
13949 {
13950   tree decl1;
13951   tree restype;
13952   int old_immediate_size_expand = immediate_size_expand;
13953
13954   named_labels = 0;
13955   shadowed_labels = 0;
13956
13957   /* Don't expand any sizes in the return type of the function.  */
13958   immediate_size_expand = 0;
13959
13960   if (nested)
13961     {
13962       assert (!public);
13963       assert (current_function_decl != NULL_TREE);
13964       assert (DECL_CONTEXT (current_function_decl) == NULL_TREE);
13965     }
13966   else
13967     {
13968       assert (current_function_decl == NULL_TREE);
13969     }
13970
13971   if (TREE_CODE (type) == ERROR_MARK)
13972     decl1 = current_function_decl = error_mark_node;
13973   else
13974     {
13975       decl1 = build_decl (FUNCTION_DECL,
13976                           name,
13977                           type);
13978       TREE_PUBLIC (decl1) = public ? 1 : 0;
13979       if (nested)
13980         DECL_INLINE (decl1) = 1;
13981       TREE_STATIC (decl1) = 1;
13982       DECL_EXTERNAL (decl1) = 0;
13983
13984       announce_function (decl1);
13985
13986       /* Make the init_value nonzero so pushdecl knows this is not tentative.
13987          error_mark_node is replaced below (in poplevel) with the BLOCK.  */
13988       DECL_INITIAL (decl1) = error_mark_node;
13989
13990       /* Record the decl so that the function name is defined. If we already have
13991          a decl for this name, and it is a FUNCTION_DECL, use the old decl.  */
13992
13993       current_function_decl = pushdecl (decl1);
13994     }
13995
13996   if (!nested)
13997     ffecom_outer_function_decl_ = current_function_decl;
13998
13999   pushlevel (0);
14000   current_binding_level->prep_state = 2;
14001
14002   if (TREE_CODE (current_function_decl) != ERROR_MARK)
14003     {
14004       make_decl_rtl (current_function_decl, NULL);
14005
14006       restype = TREE_TYPE (TREE_TYPE (current_function_decl));
14007       DECL_RESULT (current_function_decl)
14008         = build_decl (RESULT_DECL, NULL_TREE, restype);
14009     }
14010
14011   if (!nested && (TREE_CODE (current_function_decl) != ERROR_MARK))
14012     TREE_ADDRESSABLE (current_function_decl) = 1;
14013
14014   immediate_size_expand = old_immediate_size_expand;
14015 }
14016 \f
14017 /* Here are the public functions the GNU back end needs.  */
14018
14019 tree
14020 convert (type, expr)
14021      tree type, expr;
14022 {
14023   register tree e = expr;
14024   register enum tree_code code = TREE_CODE (type);
14025
14026   if (type == TREE_TYPE (e)
14027       || TREE_CODE (e) == ERROR_MARK)
14028     return e;
14029   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
14030     return fold (build1 (NOP_EXPR, type, e));
14031   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
14032       || code == ERROR_MARK)
14033     return error_mark_node;
14034   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
14035     {
14036       assert ("void value not ignored as it ought to be" == NULL);
14037       return error_mark_node;
14038     }
14039   if (code == VOID_TYPE)
14040     return build1 (CONVERT_EXPR, type, e);
14041   if ((code != RECORD_TYPE)
14042       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
14043     e = ffecom_1 (REALPART_EXPR, TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e))),
14044                   e);
14045   if (code == INTEGER_TYPE || code == ENUMERAL_TYPE)
14046     return fold (convert_to_integer (type, e));
14047   if (code == POINTER_TYPE)
14048     return fold (convert_to_pointer (type, e));
14049   if (code == REAL_TYPE)
14050     return fold (convert_to_real (type, e));
14051   if (code == COMPLEX_TYPE)
14052     return fold (convert_to_complex (type, e));
14053   if (code == RECORD_TYPE)
14054     return fold (ffecom_convert_to_complex_ (type, e));
14055
14056   assert ("conversion to non-scalar type requested" == NULL);
14057   return error_mark_node;
14058 }
14059
14060 /* Return the list of declarations of the current level.
14061    Note that this list is in reverse order unless/until
14062    you nreverse it; and when you do nreverse it, you must
14063    store the result back using `storedecls' or you will lose.  */
14064
14065 tree
14066 getdecls ()
14067 {
14068   return current_binding_level->names;
14069 }
14070
14071 /* Nonzero if we are currently in the global binding level.  */
14072
14073 int
14074 global_bindings_p ()
14075 {
14076   return current_binding_level == global_binding_level;
14077 }
14078
14079 static void
14080 ffecom_init_decl_processing ()
14081 {
14082   malloc_init ();
14083
14084   ffe_init_0 ();
14085 }
14086
14087 /* Delete the node BLOCK from the current binding level.
14088    This is used for the block inside a stmt expr ({...})
14089    so that the block can be reinserted where appropriate.  */
14090
14091 static void
14092 delete_block (block)
14093      tree block;
14094 {
14095   tree t;
14096   if (current_binding_level->blocks == block)
14097     current_binding_level->blocks = TREE_CHAIN (block);
14098   for (t = current_binding_level->blocks; t;)
14099     {
14100       if (TREE_CHAIN (t) == block)
14101         TREE_CHAIN (t) = TREE_CHAIN (block);
14102       else
14103         t = TREE_CHAIN (t);
14104     }
14105   TREE_CHAIN (block) = NULL;
14106   /* Clear TREE_USED which is always set by poplevel.
14107      The flag is set again if insert_block is called.  */
14108   TREE_USED (block) = 0;
14109 }
14110
14111 void
14112 insert_block (block)
14113      tree block;
14114 {
14115   TREE_USED (block) = 1;
14116   current_binding_level->blocks
14117     = chainon (current_binding_level->blocks, block);
14118 }
14119
14120 /* Each front end provides its own.  */
14121 static const char *ffe_init PARAMS ((const char *));
14122 static void ffe_finish PARAMS ((void));
14123 static void ffe_init_options PARAMS ((void));
14124 static void ffe_print_identifier PARAMS ((FILE *, tree, int));
14125
14126 struct language_function GTY(())
14127 {
14128   int unused;
14129 };
14130
14131 #undef  LANG_HOOKS_NAME
14132 #define LANG_HOOKS_NAME                 "GNU F77"
14133 #undef  LANG_HOOKS_INIT
14134 #define LANG_HOOKS_INIT                 ffe_init
14135 #undef  LANG_HOOKS_FINISH
14136 #define LANG_HOOKS_FINISH               ffe_finish
14137 #undef  LANG_HOOKS_INIT_OPTIONS
14138 #define LANG_HOOKS_INIT_OPTIONS         ffe_init_options
14139 #undef  LANG_HOOKS_DECODE_OPTION
14140 #define LANG_HOOKS_DECODE_OPTION        ffe_decode_option
14141 #undef  LANG_HOOKS_PARSE_FILE
14142 #define LANG_HOOKS_PARSE_FILE           ffe_parse_file
14143 #undef  LANG_HOOKS_MARK_ADDRESSABLE
14144 #define LANG_HOOKS_MARK_ADDRESSABLE     ffe_mark_addressable
14145 #undef  LANG_HOOKS_PRINT_IDENTIFIER
14146 #define LANG_HOOKS_PRINT_IDENTIFIER     ffe_print_identifier
14147 #undef  LANG_HOOKS_DECL_PRINTABLE_NAME
14148 #define LANG_HOOKS_DECL_PRINTABLE_NAME  ffe_printable_name
14149 #undef  LANG_HOOKS_PRINT_ERROR_FUNCTION
14150 #define LANG_HOOKS_PRINT_ERROR_FUNCTION ffe_print_error_function
14151 #undef  LANG_HOOKS_TRUTHVALUE_CONVERSION
14152 #define LANG_HOOKS_TRUTHVALUE_CONVERSION ffe_truthvalue_conversion
14153
14154 #undef  LANG_HOOKS_TYPE_FOR_MODE
14155 #define LANG_HOOKS_TYPE_FOR_MODE        ffe_type_for_mode
14156 #undef  LANG_HOOKS_TYPE_FOR_SIZE
14157 #define LANG_HOOKS_TYPE_FOR_SIZE        ffe_type_for_size
14158 #undef  LANG_HOOKS_SIGNED_TYPE
14159 #define LANG_HOOKS_SIGNED_TYPE          ffe_signed_type
14160 #undef  LANG_HOOKS_UNSIGNED_TYPE
14161 #define LANG_HOOKS_UNSIGNED_TYPE        ffe_unsigned_type
14162 #undef  LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE
14163 #define LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE ffe_signed_or_unsigned_type
14164
14165 /* We do not wish to use alias-set based aliasing at all.  Used in the
14166    extreme (every object with its own set, with equivalences recorded) it
14167    might be helpful, but there are problems when it comes to inlining.  We
14168    get on ok with flag_argument_noalias, and alias-set aliasing does
14169    currently limit how stack slots can be reused, which is a lose.  */
14170 #undef LANG_HOOKS_GET_ALIAS_SET
14171 #define LANG_HOOKS_GET_ALIAS_SET hook_get_alias_set_0
14172
14173 const struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER;
14174
14175 /* Table indexed by tree code giving a string containing a character
14176    classifying the tree code.  Possibilities are
14177    t, d, s, c, r, <, 1, 2 and e.  See tree.def for details.  */
14178
14179 #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) TYPE,
14180
14181 const char tree_code_type[] = {
14182 #include "tree.def"
14183 };
14184 #undef DEFTREECODE
14185
14186 /* Table indexed by tree code giving number of expression
14187    operands beyond the fixed part of the node structure.
14188    Not used for types or decls.  */
14189
14190 #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) LENGTH,
14191
14192 const unsigned char tree_code_length[] = {
14193 #include "tree.def"
14194 };
14195 #undef DEFTREECODE
14196
14197 /* Names of tree components.
14198    Used for printing out the tree and error messages.  */
14199 #define DEFTREECODE(SYM, NAME, TYPE, LEN) NAME,
14200
14201 const char *const tree_code_name[] = {
14202 #include "tree.def"
14203 };
14204 #undef DEFTREECODE
14205
14206 static const char *
14207 ffe_init (filename)
14208      const char *filename;
14209 {
14210   /* Open input file.  */
14211   if (filename == 0 || !strcmp (filename, "-"))
14212     {
14213       finput = stdin;
14214       filename = "stdin";
14215     }
14216   else
14217     finput = fopen (filename, "r");
14218   if (finput == 0)
14219     fatal_io_error ("can't open %s", filename);
14220
14221 #ifdef IO_BUFFER_SIZE
14222   setvbuf (finput, (char *) xmalloc (IO_BUFFER_SIZE), _IOFBF, IO_BUFFER_SIZE);
14223 #endif
14224
14225   ffecom_init_decl_processing ();
14226
14227   /* If the file is output from cpp, it should contain a first line
14228      `# 1 "real-filename"', and the current design of gcc (toplev.c
14229      in particular and the way it sets up information relied on by
14230      INCLUDE) requires that we read this now, and store the
14231      "real-filename" info in master_input_filename.  Ask the lexer
14232      to try doing this.  */
14233   ffelex_hash_kludge (finput);
14234
14235   /* FIXME: The ffelex_hash_kludge code needs to be cleaned up to
14236      return the new file name.  */
14237   if (main_input_filename)
14238     filename = main_input_filename;
14239
14240   return filename;
14241 }
14242
14243 static void
14244 ffe_finish ()
14245 {
14246   ffe_terminate_0 ();
14247
14248   if (ffe_is_ffedebug ())
14249     malloc_pool_display (malloc_pool_image ());
14250
14251   fclose (finput);
14252 }
14253
14254 static void
14255 ffe_init_options ()
14256 {
14257   /* Set default options for Fortran.  */
14258   flag_move_all_movables = 1;
14259   flag_reduce_all_givs = 1;
14260   flag_argument_noalias = 2;
14261   flag_merge_constants = 2;
14262   flag_errno_math = 0;
14263   flag_complex_divide_method = 1;
14264 }
14265
14266 static bool
14267 ffe_mark_addressable (exp)
14268      tree exp;
14269 {
14270   register tree x = exp;
14271   while (1)
14272     switch (TREE_CODE (x))
14273       {
14274       case ADDR_EXPR:
14275       case COMPONENT_REF:
14276       case ARRAY_REF:
14277         x = TREE_OPERAND (x, 0);
14278         break;
14279
14280       case CONSTRUCTOR:
14281         TREE_ADDRESSABLE (x) = 1;
14282         return true;
14283
14284       case VAR_DECL:
14285       case CONST_DECL:
14286       case PARM_DECL:
14287       case RESULT_DECL:
14288         if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x)
14289             && DECL_NONLOCAL (x))
14290           {
14291             if (TREE_PUBLIC (x))
14292               {
14293                 assert ("address of global register var requested" == NULL);
14294                 return false;
14295               }
14296             assert ("address of register variable requested" == NULL);
14297           }
14298         else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x))
14299           {
14300             if (TREE_PUBLIC (x))
14301               {
14302                 assert ("address of global register var requested" == NULL);
14303                 return false;
14304               }
14305             assert ("address of register var requested" == NULL);
14306           }
14307         put_var_into_stack (x);
14308
14309         /* drops in */
14310       case FUNCTION_DECL:
14311         TREE_ADDRESSABLE (x) = 1;
14312 #if 0                           /* poplevel deals with this now.  */
14313         if (DECL_CONTEXT (x) == 0)
14314           TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x)) = 1;
14315 #endif
14316
14317       default:
14318         return true;
14319       }
14320 }
14321
14322 /* Exit a binding level.
14323    Pop the level off, and restore the state of the identifier-decl mappings
14324    that were in effect when this level was entered.
14325
14326    If KEEP is nonzero, this level had explicit declarations, so
14327    and create a "block" (a BLOCK node) for the level
14328    to record its declarations and subblocks for symbol table output.
14329
14330    If FUNCTIONBODY is nonzero, this level is the body of a function,
14331    so create a block as if KEEP were set and also clear out all
14332    label names.
14333
14334    If REVERSE is nonzero, reverse the order of decls before putting
14335    them into the BLOCK.  */
14336
14337 tree
14338 poplevel (keep, reverse, functionbody)
14339      int keep;
14340      int reverse;
14341      int functionbody;
14342 {
14343   register tree link;
14344   /* The chain of decls was accumulated in reverse order.
14345      Put it into forward order, just for cleanliness.  */
14346   tree decls;
14347   tree subblocks = current_binding_level->blocks;
14348   tree block = 0;
14349   tree decl;
14350   int block_previously_created;
14351
14352   /* Get the decls in the order they were written.
14353      Usually current_binding_level->names is in reverse order.
14354      But parameter decls were previously put in forward order.  */
14355
14356   if (reverse)
14357     current_binding_level->names
14358       = decls = nreverse (current_binding_level->names);
14359   else
14360     decls = current_binding_level->names;
14361
14362   /* Output any nested inline functions within this block
14363      if they weren't already output.  */
14364
14365   for (decl = decls; decl; decl = TREE_CHAIN (decl))
14366     if (TREE_CODE (decl) == FUNCTION_DECL
14367         && ! TREE_ASM_WRITTEN (decl)
14368         && DECL_INITIAL (decl) != 0
14369         && TREE_ADDRESSABLE (decl))
14370       {
14371         /* If this decl was copied from a file-scope decl
14372            on account of a block-scope extern decl,
14373            propagate TREE_ADDRESSABLE to the file-scope decl.
14374
14375            DECL_ABSTRACT_ORIGIN can be set to itself if warn_return_type is
14376            true, since then the decl goes through save_for_inline_copying.  */
14377         if (DECL_ABSTRACT_ORIGIN (decl) != 0
14378             && DECL_ABSTRACT_ORIGIN (decl) != decl)
14379           TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl)) = 1;
14380         else if (DECL_SAVED_INSNS (decl) != 0)
14381           {
14382             push_function_context ();
14383             output_inline_function (decl);
14384             pop_function_context ();
14385           }
14386       }
14387
14388   /* If there were any declarations or structure tags in that level,
14389      or if this level is a function body,
14390      create a BLOCK to record them for the life of this function.  */
14391
14392   block = 0;
14393   block_previously_created = (current_binding_level->this_block != 0);
14394   if (block_previously_created)
14395     block = current_binding_level->this_block;
14396   else if (keep || functionbody)
14397     block = make_node (BLOCK);
14398   if (block != 0)
14399     {
14400       BLOCK_VARS (block) = decls;
14401       BLOCK_SUBBLOCKS (block) = subblocks;
14402     }
14403
14404   /* In each subblock, record that this is its superior.  */
14405
14406   for (link = subblocks; link; link = TREE_CHAIN (link))
14407     BLOCK_SUPERCONTEXT (link) = block;
14408
14409   /* Clear out the meanings of the local variables of this level.  */
14410
14411   for (link = decls; link; link = TREE_CHAIN (link))
14412     {
14413       if (DECL_NAME (link) != 0)
14414         {
14415           /* If the ident. was used or addressed via a local extern decl,
14416              don't forget that fact.  */
14417           if (DECL_EXTERNAL (link))
14418             {
14419               if (TREE_USED (link))
14420                 TREE_USED (DECL_NAME (link)) = 1;
14421               if (TREE_ADDRESSABLE (link))
14422                 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (link)) = 1;
14423             }
14424           IDENTIFIER_LOCAL_VALUE (DECL_NAME (link)) = 0;
14425         }
14426     }
14427
14428   /* If the level being exited is the top level of a function,
14429      check over all the labels, and clear out the current
14430      (function local) meanings of their names.  */
14431
14432   if (functionbody)
14433     {
14434       /* If this is the top level block of a function,
14435          the vars are the function's parameters.
14436          Don't leave them in the BLOCK because they are
14437          found in the FUNCTION_DECL instead.  */
14438
14439       BLOCK_VARS (block) = 0;
14440     }
14441
14442   /* Pop the current level, and free the structure for reuse.  */
14443
14444   {
14445     register struct f_binding_level *level = current_binding_level;
14446     current_binding_level = current_binding_level->level_chain;
14447
14448     level->level_chain = free_binding_level;
14449     free_binding_level = level;
14450   }
14451
14452   /* Dispose of the block that we just made inside some higher level.  */
14453   if (functionbody
14454       && current_function_decl != error_mark_node)
14455     DECL_INITIAL (current_function_decl) = block;
14456   else if (block)
14457     {
14458       if (!block_previously_created)
14459         current_binding_level->blocks
14460           = chainon (current_binding_level->blocks, block);
14461     }
14462   /* If we did not make a block for the level just exited,
14463      any blocks made for inner levels
14464      (since they cannot be recorded as subblocks in that level)
14465      must be carried forward so they will later become subblocks
14466      of something else.  */
14467   else if (subblocks)
14468     current_binding_level->blocks
14469       = chainon (current_binding_level->blocks, subblocks);
14470
14471   if (block)
14472     TREE_USED (block) = 1;
14473   return block;
14474 }
14475
14476 static void
14477 ffe_print_identifier (file, node, indent)
14478      FILE *file;
14479      tree node;
14480      int indent;
14481 {
14482   print_node (file, "global", IDENTIFIER_GLOBAL_VALUE (node), indent + 4);
14483   print_node (file, "local", IDENTIFIER_LOCAL_VALUE (node), indent + 4);
14484 }
14485
14486 /* Record a decl-node X as belonging to the current lexical scope.
14487    Check for errors (such as an incompatible declaration for the same
14488    name already seen in the same scope).
14489
14490    Returns either X or an old decl for the same name.
14491    If an old decl is returned, it may have been smashed
14492    to agree with what X says.  */
14493
14494 tree
14495 pushdecl (x)
14496      tree x;
14497 {
14498   register tree t;
14499   register tree name = DECL_NAME (x);
14500   register struct f_binding_level *b = current_binding_level;
14501
14502   if ((TREE_CODE (x) == FUNCTION_DECL)
14503       && (DECL_INITIAL (x) == 0)
14504       && DECL_EXTERNAL (x))
14505     DECL_CONTEXT (x) = NULL_TREE;
14506   else
14507     DECL_CONTEXT (x) = current_function_decl;
14508
14509   if (name)
14510     {
14511       if (IDENTIFIER_INVENTED (name))
14512         {
14513           DECL_ARTIFICIAL (x) = 1;
14514           DECL_IN_SYSTEM_HEADER (x) = 1;
14515         }
14516
14517       t = lookup_name_current_level (name);
14518
14519       assert ((t == NULL_TREE) || (DECL_CONTEXT (x) == NULL_TREE));
14520
14521       /* Don't push non-parms onto list for parms until we understand
14522          why we're doing this and whether it works.  */
14523
14524       assert ((b == global_binding_level)
14525               || !ffecom_transform_only_dummies_
14526               || TREE_CODE (x) == PARM_DECL);
14527
14528       if ((t != NULL_TREE) && duplicate_decls (x, t))
14529         return t;
14530
14531       /* If we are processing a typedef statement, generate a whole new
14532          ..._TYPE node (which will be just an variant of the existing
14533          ..._TYPE node with identical properties) and then install the
14534          TYPE_DECL node generated to represent the typedef name as the
14535          TYPE_NAME of this brand new (duplicate) ..._TYPE node.
14536
14537          The whole point here is to end up with a situation where each and every
14538          ..._TYPE node the compiler creates will be uniquely associated with
14539          AT MOST one node representing a typedef name. This way, even though
14540          the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL
14541          (i.e. "typedef name") nodes very early on, later parts of the
14542          compiler can always do the reverse translation and get back the
14543          corresponding typedef name.  For example, given:
14544
14545          typedef struct S MY_TYPE; MY_TYPE object;
14546
14547          Later parts of the compiler might only know that `object' was of type
14548          `struct S' if it were not for code just below.  With this code
14549          however, later parts of the compiler see something like:
14550
14551          struct S' == struct S typedef struct S' MY_TYPE; struct S' object;
14552
14553          And they can then deduce (from the node for type struct S') that the
14554          original object declaration was:
14555
14556          MY_TYPE object;
14557
14558          Being able to do this is important for proper support of protoize, and
14559          also for generating precise symbolic debugging information which
14560          takes full account of the programmer's (typedef) vocabulary.
14561
14562          Obviously, we don't want to generate a duplicate ..._TYPE node if the
14563          TYPE_DECL node that we are now processing really represents a
14564          standard built-in type.
14565
14566          Since all standard types are effectively declared at line zero in the
14567          source file, we can easily check to see if we are working on a
14568          standard type by checking the current value of lineno.  */
14569
14570       if (TREE_CODE (x) == TYPE_DECL)
14571         {
14572           if (DECL_SOURCE_LINE (x) == 0)
14573             {
14574               if (TYPE_NAME (TREE_TYPE (x)) == 0)
14575                 TYPE_NAME (TREE_TYPE (x)) = x;
14576             }
14577           else if (TREE_TYPE (x) != error_mark_node)
14578             {
14579               tree tt = TREE_TYPE (x);
14580
14581               tt = build_type_copy (tt);
14582               TYPE_NAME (tt) = x;
14583               TREE_TYPE (x) = tt;
14584             }
14585         }
14586
14587       /* This name is new in its binding level. Install the new declaration
14588          and return it.  */
14589       if (b == global_binding_level)
14590         IDENTIFIER_GLOBAL_VALUE (name) = x;
14591       else
14592         IDENTIFIER_LOCAL_VALUE (name) = x;
14593     }
14594
14595   /* Put decls on list in reverse order. We will reverse them later if
14596      necessary.  */
14597   TREE_CHAIN (x) = b->names;
14598   b->names = x;
14599
14600   return x;
14601 }
14602
14603 /* Nonzero if the current level needs to have a BLOCK made.  */
14604
14605 static int
14606 kept_level_p ()
14607 {
14608   tree decl;
14609
14610   for (decl = current_binding_level->names;
14611        decl;
14612        decl = TREE_CHAIN (decl))
14613     {
14614       if (TREE_USED (decl) || TREE_CODE (decl) != VAR_DECL
14615           || (DECL_NAME (decl) && ! DECL_ARTIFICIAL (decl)))
14616         /* Currently, there aren't supposed to be non-artificial names
14617            at other than the top block for a function -- they're
14618            believed to always be temps.  But it's wise to check anyway.  */
14619         return 1;
14620     }
14621   return 0;
14622 }
14623
14624 /* Enter a new binding level.
14625    If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
14626    not for that of tags.  */
14627
14628 void
14629 pushlevel (tag_transparent)
14630      int tag_transparent;
14631 {
14632   register struct f_binding_level *newlevel = NULL_BINDING_LEVEL;
14633
14634   assert (! tag_transparent);
14635
14636   if (current_binding_level == global_binding_level)
14637     {
14638       named_labels = 0;
14639     }
14640
14641   /* Reuse or create a struct for this binding level.  */
14642
14643   if (free_binding_level)
14644     {
14645       newlevel = free_binding_level;
14646       free_binding_level = free_binding_level->level_chain;
14647     }
14648   else
14649     {
14650       newlevel = make_binding_level ();
14651     }
14652
14653   /* Add this level to the front of the chain (stack) of levels that
14654      are active.  */
14655
14656   *newlevel = clear_binding_level;
14657   newlevel->level_chain = current_binding_level;
14658   current_binding_level = newlevel;
14659 }
14660
14661 /* Set the BLOCK node for the innermost scope
14662    (the one we are currently in).  */
14663
14664 void
14665 set_block (block)
14666      register tree block;
14667 {
14668   current_binding_level->this_block = block;
14669   current_binding_level->names = chainon (current_binding_level->names,
14670                                           BLOCK_VARS (block));
14671   current_binding_level->blocks = chainon (current_binding_level->blocks,
14672                                            BLOCK_SUBBLOCKS (block));
14673 }
14674
14675 static tree
14676 ffe_signed_or_unsigned_type (unsignedp, type)
14677      int unsignedp;
14678      tree type;
14679 {
14680   tree type2;
14681
14682   if (! INTEGRAL_TYPE_P (type))
14683     return type;
14684   if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node))
14685     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
14686   if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node))
14687     return unsignedp ? unsigned_type_node : integer_type_node;
14688   if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node))
14689     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
14690   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node))
14691     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
14692   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node))
14693     return (unsignedp ? long_long_unsigned_type_node
14694             : long_long_integer_type_node);
14695
14696   type2 = ffe_type_for_size (TYPE_PRECISION (type), unsignedp);
14697   if (type2 == NULL_TREE)
14698     return type;
14699
14700   return type2;
14701 }
14702
14703 static tree
14704 ffe_signed_type (type)
14705      tree type;
14706 {
14707   tree type1 = TYPE_MAIN_VARIANT (type);
14708   ffeinfoKindtype kt;
14709   tree type2;
14710
14711   if (type1 == unsigned_char_type_node || type1 == char_type_node)
14712     return signed_char_type_node;
14713   if (type1 == unsigned_type_node)
14714     return integer_type_node;
14715   if (type1 == short_unsigned_type_node)
14716     return short_integer_type_node;
14717   if (type1 == long_unsigned_type_node)
14718     return long_integer_type_node;
14719   if (type1 == long_long_unsigned_type_node)
14720     return long_long_integer_type_node;
14721 #if 0   /* gcc/c-* files only */
14722   if (type1 == unsigned_intDI_type_node)
14723     return intDI_type_node;
14724   if (type1 == unsigned_intSI_type_node)
14725     return intSI_type_node;
14726   if (type1 == unsigned_intHI_type_node)
14727     return intHI_type_node;
14728   if (type1 == unsigned_intQI_type_node)
14729     return intQI_type_node;
14730 #endif
14731
14732   type2 = ffe_type_for_size (TYPE_PRECISION (type1), 0);
14733   if (type2 != NULL_TREE)
14734     return type2;
14735
14736   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
14737     {
14738       type2 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
14739
14740       if (type1 == type2)
14741         return ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
14742     }
14743
14744   return type;
14745 }
14746
14747 /* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
14748    or validate its data type for an `if' or `while' statement or ?..: exp.
14749
14750    This preparation consists of taking the ordinary
14751    representation of an expression expr and producing a valid tree
14752    boolean expression describing whether expr is nonzero.  We could
14753    simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
14754    but we optimize comparisons, &&, ||, and !.
14755
14756    The resulting type should always be `integer_type_node'.  */
14757
14758 static tree
14759 ffe_truthvalue_conversion (expr)
14760      tree expr;
14761 {
14762   if (TREE_CODE (expr) == ERROR_MARK)
14763     return expr;
14764
14765 #if 0 /* This appears to be wrong for C++.  */
14766   /* These really should return error_mark_node after 2.4 is stable.
14767      But not all callers handle ERROR_MARK properly.  */
14768   switch (TREE_CODE (TREE_TYPE (expr)))
14769     {
14770     case RECORD_TYPE:
14771       error ("struct type value used where scalar is required");
14772       return integer_zero_node;
14773
14774     case UNION_TYPE:
14775       error ("union type value used where scalar is required");
14776       return integer_zero_node;
14777
14778     case ARRAY_TYPE:
14779       error ("array type value used where scalar is required");
14780       return integer_zero_node;
14781
14782     default:
14783       break;
14784     }
14785 #endif /* 0 */
14786
14787   switch (TREE_CODE (expr))
14788     {
14789       /* It is simpler and generates better code to have only TRUTH_*_EXPR
14790          or comparison expressions as truth values at this level.  */
14791 #if 0
14792     case COMPONENT_REF:
14793       /* A one-bit unsigned bit-field is already acceptable.  */
14794       if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr, 1)))
14795           && TREE_UNSIGNED (TREE_OPERAND (expr, 1)))
14796         return expr;
14797       break;
14798 #endif
14799
14800     case EQ_EXPR:
14801       /* It is simpler and generates better code to have only TRUTH_*_EXPR
14802          or comparison expressions as truth values at this level.  */
14803 #if 0
14804       if (integer_zerop (TREE_OPERAND (expr, 1)))
14805         return build_unary_op (TRUTH_NOT_EXPR, TREE_OPERAND (expr, 0), 0);
14806 #endif
14807     case NE_EXPR: case LE_EXPR: case GE_EXPR: case LT_EXPR: case GT_EXPR:
14808     case TRUTH_ANDIF_EXPR:
14809     case TRUTH_ORIF_EXPR:
14810     case TRUTH_AND_EXPR:
14811     case TRUTH_OR_EXPR:
14812     case TRUTH_XOR_EXPR:
14813       TREE_TYPE (expr) = integer_type_node;
14814       return expr;
14815
14816     case ERROR_MARK:
14817       return expr;
14818
14819     case INTEGER_CST:
14820       return integer_zerop (expr) ? integer_zero_node : integer_one_node;
14821
14822     case REAL_CST:
14823       return real_zerop (expr) ? integer_zero_node : integer_one_node;
14824
14825     case ADDR_EXPR:
14826       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 0)))
14827         return build (COMPOUND_EXPR, integer_type_node,
14828                       TREE_OPERAND (expr, 0), integer_one_node);
14829       else
14830         return integer_one_node;
14831
14832     case COMPLEX_EXPR:
14833       return ffecom_2 ((TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1))
14834                         ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
14835                        integer_type_node,
14836                        ffe_truthvalue_conversion (TREE_OPERAND (expr, 0)),
14837                        ffe_truthvalue_conversion (TREE_OPERAND (expr, 1)));
14838
14839     case NEGATE_EXPR:
14840     case ABS_EXPR:
14841     case FLOAT_EXPR:
14842     case FFS_EXPR:
14843       /* These don't change whether an object is non-zero or zero.  */
14844       return ffe_truthvalue_conversion (TREE_OPERAND (expr, 0));
14845
14846     case LROTATE_EXPR:
14847     case RROTATE_EXPR:
14848       /* These don't change whether an object is zero or non-zero, but
14849          we can't ignore them if their second arg has side-effects.  */
14850       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1)))
14851         return build (COMPOUND_EXPR, integer_type_node, TREE_OPERAND (expr, 1),
14852                       ffe_truthvalue_conversion (TREE_OPERAND (expr, 0)));
14853       else
14854         return ffe_truthvalue_conversion (TREE_OPERAND (expr, 0));
14855
14856     case COND_EXPR:
14857       /* Distribute the conversion into the arms of a COND_EXPR.  */
14858       return fold (build (COND_EXPR, integer_type_node, TREE_OPERAND (expr, 0),
14859                           ffe_truthvalue_conversion (TREE_OPERAND (expr, 1)),
14860                           ffe_truthvalue_conversion (TREE_OPERAND (expr, 2))));
14861
14862     case CONVERT_EXPR:
14863       /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
14864          since that affects how `default_conversion' will behave.  */
14865       if (TREE_CODE (TREE_TYPE (expr)) == REFERENCE_TYPE
14866           || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) == REFERENCE_TYPE)
14867         break;
14868       /* fall through... */
14869     case NOP_EXPR:
14870       /* If this is widening the argument, we can ignore it.  */
14871       if (TYPE_PRECISION (TREE_TYPE (expr))
14872           >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr, 0))))
14873         return ffe_truthvalue_conversion (TREE_OPERAND (expr, 0));
14874       break;
14875
14876     case MINUS_EXPR:
14877       /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize
14878          this case.  */
14879       if (TARGET_FLOAT_FORMAT == IEEE_FLOAT_FORMAT
14880           && TREE_CODE (TREE_TYPE (expr)) == REAL_TYPE)
14881         break;
14882       /* fall through... */
14883     case BIT_XOR_EXPR:
14884       /* This and MINUS_EXPR can be changed into a comparison of the
14885          two objects.  */
14886       if (TREE_TYPE (TREE_OPERAND (expr, 0))
14887           == TREE_TYPE (TREE_OPERAND (expr, 1)))
14888         return ffecom_2 (NE_EXPR, integer_type_node,
14889                          TREE_OPERAND (expr, 0),
14890                          TREE_OPERAND (expr, 1));
14891       return ffecom_2 (NE_EXPR, integer_type_node,
14892                        TREE_OPERAND (expr, 0),
14893                        fold (build1 (NOP_EXPR,
14894                                      TREE_TYPE (TREE_OPERAND (expr, 0)),
14895                                      TREE_OPERAND (expr, 1))));
14896
14897     case BIT_AND_EXPR:
14898       if (integer_onep (TREE_OPERAND (expr, 1)))
14899         return expr;
14900       break;
14901
14902     case MODIFY_EXPR:
14903 #if 0                           /* No such thing in Fortran. */
14904       if (warn_parentheses && C_EXP_ORIGINAL_CODE (expr) == MODIFY_EXPR)
14905         warning ("suggest parentheses around assignment used as truth value");
14906 #endif
14907       break;
14908
14909     default:
14910       break;
14911     }
14912
14913   if (TREE_CODE (TREE_TYPE (expr)) == COMPLEX_TYPE)
14914     return (ffecom_2
14915             ((TREE_SIDE_EFFECTS (expr)
14916               ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
14917              integer_type_node,
14918              ffe_truthvalue_conversion (ffecom_1 (REALPART_EXPR,
14919                                                   TREE_TYPE (TREE_TYPE (expr)),
14920                                                   expr)),
14921              ffe_truthvalue_conversion (ffecom_1 (IMAGPART_EXPR,
14922                                                   TREE_TYPE (TREE_TYPE (expr)),
14923                                                   expr))));
14924
14925   return ffecom_2 (NE_EXPR, integer_type_node,
14926                    expr,
14927                    convert (TREE_TYPE (expr), integer_zero_node));
14928 }
14929
14930 static tree
14931 ffe_type_for_mode (mode, unsignedp)
14932      enum machine_mode mode;
14933      int unsignedp;
14934 {
14935   int i;
14936   int j;
14937   tree t;
14938
14939   if (mode == TYPE_MODE (integer_type_node))
14940     return unsignedp ? unsigned_type_node : integer_type_node;
14941
14942   if (mode == TYPE_MODE (signed_char_type_node))
14943     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
14944
14945   if (mode == TYPE_MODE (short_integer_type_node))
14946     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
14947
14948   if (mode == TYPE_MODE (long_integer_type_node))
14949     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
14950
14951   if (mode == TYPE_MODE (long_long_integer_type_node))
14952     return unsignedp ? long_long_unsigned_type_node : long_long_integer_type_node;
14953
14954 #if HOST_BITS_PER_WIDE_INT >= 64
14955   if (mode == TYPE_MODE (intTI_type_node))
14956     return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
14957 #endif
14958
14959   if (mode == TYPE_MODE (float_type_node))
14960     return float_type_node;
14961
14962   if (mode == TYPE_MODE (double_type_node))
14963     return double_type_node;
14964
14965   if (mode == TYPE_MODE (build_pointer_type (char_type_node)))
14966     return build_pointer_type (char_type_node);
14967
14968   if (mode == TYPE_MODE (build_pointer_type (integer_type_node)))
14969     return build_pointer_type (integer_type_node);
14970
14971   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
14972     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
14973       {
14974         if (((t = ffecom_tree_type[i][j]) != NULL_TREE)
14975             && (mode == TYPE_MODE (t)))
14976           {
14977             if ((i == FFEINFO_basictypeINTEGER) && unsignedp)
14978               return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][j];
14979             else
14980               return t;
14981           }
14982       }
14983
14984   return 0;
14985 }
14986
14987 static tree
14988 ffe_type_for_size (bits, unsignedp)
14989      unsigned bits;
14990      int unsignedp;
14991 {
14992   ffeinfoKindtype kt;
14993   tree type_node;
14994
14995   if (bits == TYPE_PRECISION (integer_type_node))
14996     return unsignedp ? unsigned_type_node : integer_type_node;
14997
14998   if (bits == TYPE_PRECISION (signed_char_type_node))
14999     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15000
15001   if (bits == TYPE_PRECISION (short_integer_type_node))
15002     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15003
15004   if (bits == TYPE_PRECISION (long_integer_type_node))
15005     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15006
15007   if (bits == TYPE_PRECISION (long_long_integer_type_node))
15008     return (unsignedp ? long_long_unsigned_type_node
15009             : long_long_integer_type_node);
15010
15011   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15012     {
15013       type_node = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15014
15015       if ((type_node != NULL_TREE) && (bits == TYPE_PRECISION (type_node)))
15016         return unsignedp ? ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]
15017           : type_node;
15018     }
15019
15020   return 0;
15021 }
15022
15023 static tree
15024 ffe_unsigned_type (type)
15025      tree type;
15026 {
15027   tree type1 = TYPE_MAIN_VARIANT (type);
15028   ffeinfoKindtype kt;
15029   tree type2;
15030
15031   if (type1 == signed_char_type_node || type1 == char_type_node)
15032     return unsigned_char_type_node;
15033   if (type1 == integer_type_node)
15034     return unsigned_type_node;
15035   if (type1 == short_integer_type_node)
15036     return short_unsigned_type_node;
15037   if (type1 == long_integer_type_node)
15038     return long_unsigned_type_node;
15039   if (type1 == long_long_integer_type_node)
15040     return long_long_unsigned_type_node;
15041 #if 0   /* gcc/c-* files only */
15042   if (type1 == intDI_type_node)
15043     return unsigned_intDI_type_node;
15044   if (type1 == intSI_type_node)
15045     return unsigned_intSI_type_node;
15046   if (type1 == intHI_type_node)
15047     return unsigned_intHI_type_node;
15048   if (type1 == intQI_type_node)
15049     return unsigned_intQI_type_node;
15050 #endif
15051
15052   type2 = ffe_type_for_size (TYPE_PRECISION (type1), 1);
15053   if (type2 != NULL_TREE)
15054     return type2;
15055
15056   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15057     {
15058       type2 = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15059
15060       if (type1 == type2)
15061         return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
15062     }
15063
15064   return type;
15065 }
15066 \f
15067 /* From gcc/cccp.c, the code to handle -I.  */
15068
15069 /* Skip leading "./" from a directory name.
15070    This may yield the empty string, which represents the current directory.  */
15071
15072 static const char *
15073 skip_redundant_dir_prefix (const char *dir)
15074 {
15075   while (dir[0] == '.' && dir[1] == '/')
15076     for (dir += 2; *dir == '/'; dir++)
15077       continue;
15078   if (dir[0] == '.' && !dir[1])
15079     dir++;
15080   return dir;
15081 }
15082
15083 /* The file_name_map structure holds a mapping of file names for a
15084    particular directory.  This mapping is read from the file named
15085    FILE_NAME_MAP_FILE in that directory.  Such a file can be used to
15086    map filenames on a file system with severe filename restrictions,
15087    such as DOS.  The format of the file name map file is just a series
15088    of lines with two tokens on each line.  The first token is the name
15089    to map, and the second token is the actual name to use.  */
15090
15091 struct file_name_map
15092 {
15093   struct file_name_map *map_next;
15094   char *map_from;
15095   char *map_to;
15096 };
15097
15098 #define FILE_NAME_MAP_FILE "header.gcc"
15099
15100 /* Current maximum length of directory names in the search path
15101    for include files.  (Altered as we get more of them.)  */
15102
15103 static int max_include_len = 0;
15104
15105 struct file_name_list
15106   {
15107     struct file_name_list *next;
15108     char *fname;
15109     /* Mapping of file names for this directory.  */
15110     struct file_name_map *name_map;
15111     /* Non-zero if name_map is valid.  */
15112     int got_name_map;
15113   };
15114
15115 static struct file_name_list *include = NULL;   /* First dir to search */
15116 static struct file_name_list *last_include = NULL;      /* Last in chain */
15117
15118 /* I/O buffer structure.
15119    The `fname' field is nonzero for source files and #include files
15120    and for the dummy text used for -D and -U.
15121    It is zero for rescanning results of macro expansion
15122    and for expanding macro arguments.  */
15123 #define INPUT_STACK_MAX 400
15124 static struct file_buf {
15125   const char *fname;
15126   /* Filename specified with #line command.  */
15127   const char *nominal_fname;
15128   /* Record where in the search path this file was found.
15129      For #include_next.  */
15130   struct file_name_list *dir;
15131   ffewhereLine line;
15132   ffewhereColumn column;
15133 } instack[INPUT_STACK_MAX];
15134
15135 static int last_error_tick = 0;    /* Incremented each time we print it.  */
15136 static int input_file_stack_tick = 0;  /* Incremented when status changes.  */
15137
15138 /* Current nesting level of input sources.
15139    `instack[indepth]' is the level currently being read.  */
15140 static int indepth = -1;
15141
15142 typedef struct file_buf FILE_BUF;
15143
15144 /* Nonzero means -I- has been seen,
15145    so don't look for #include "foo" the source-file directory.  */
15146 static int ignore_srcdir;
15147
15148 #ifndef INCLUDE_LEN_FUDGE
15149 #define INCLUDE_LEN_FUDGE 0
15150 #endif
15151
15152 static void append_include_chain (struct file_name_list *first,
15153                                   struct file_name_list *last);
15154 static FILE *open_include_file (char *filename,
15155                                 struct file_name_list *searchptr);
15156 static void print_containing_files (ffebadSeverity sev);
15157 static char *read_filename_string (int ch, FILE *f);
15158 static struct file_name_map *read_name_map (const char *dirname);
15159
15160 /* Append a chain of `struct file_name_list's
15161    to the end of the main include chain.
15162    FIRST is the beginning of the chain to append, and LAST is the end.  */
15163
15164 static void
15165 append_include_chain (first, last)
15166      struct file_name_list *first, *last;
15167 {
15168   struct file_name_list *dir;
15169
15170   if (!first || !last)
15171     return;
15172
15173   if (include == 0)
15174     include = first;
15175   else
15176     last_include->next = first;
15177
15178   for (dir = first; ; dir = dir->next) {
15179     int len = strlen (dir->fname) + INCLUDE_LEN_FUDGE;
15180     if (len > max_include_len)
15181       max_include_len = len;
15182     if (dir == last)
15183       break;
15184   }
15185
15186   last->next = NULL;
15187   last_include = last;
15188 }
15189
15190 /* Try to open include file FILENAME.  SEARCHPTR is the directory
15191    being tried from the include file search path.  This function maps
15192    filenames on file systems based on information read by
15193    read_name_map.  */
15194
15195 static FILE *
15196 open_include_file (filename, searchptr)
15197      char *filename;
15198      struct file_name_list *searchptr;
15199 {
15200   register struct file_name_map *map;
15201   register char *from;
15202   char *p, *dir;
15203
15204   if (searchptr && ! searchptr->got_name_map)
15205     {
15206       searchptr->name_map = read_name_map (searchptr->fname
15207                                            ? searchptr->fname : ".");
15208       searchptr->got_name_map = 1;
15209     }
15210
15211   /* First check the mapping for the directory we are using.  */
15212   if (searchptr && searchptr->name_map)
15213     {
15214       from = filename;
15215       if (searchptr->fname)
15216         from += strlen (searchptr->fname) + 1;
15217       for (map = searchptr->name_map; map; map = map->map_next)
15218         {
15219           if (! strcmp (map->map_from, from))
15220             {
15221               /* Found a match.  */
15222               return fopen (map->map_to, "r");
15223             }
15224         }
15225     }
15226
15227   /* Try to find a mapping file for the particular directory we are
15228      looking in.  Thus #include <sys/types.h> will look up sys/types.h
15229      in /usr/include/header.gcc and look up types.h in
15230      /usr/include/sys/header.gcc.  */
15231   p = strrchr (filename, '/');
15232 #ifdef DIR_SEPARATOR
15233   if (! p) p = strrchr (filename, DIR_SEPARATOR);
15234   else {
15235     char *tmp = strrchr (filename, DIR_SEPARATOR);
15236     if (tmp != NULL && tmp > p) p = tmp;
15237   }
15238 #endif
15239   if (! p)
15240     p = filename;
15241   if (searchptr
15242       && searchptr->fname
15243       && strlen (searchptr->fname) == (size_t) (p - filename)
15244       && ! strncmp (searchptr->fname, filename, (int) (p - filename)))
15245     {
15246       /* FILENAME is in SEARCHPTR, which we've already checked.  */
15247       return fopen (filename, "r");
15248     }
15249
15250   if (p == filename)
15251     {
15252       from = filename;
15253       map = read_name_map (".");
15254     }
15255   else
15256     {
15257       dir = (char *) xmalloc (p - filename + 1);
15258       memcpy (dir, filename, p - filename);
15259       dir[p - filename] = '\0';
15260       from = p + 1;
15261       map = read_name_map (dir);
15262       free (dir);
15263     }
15264   for (; map; map = map->map_next)
15265     if (! strcmp (map->map_from, from))
15266       return fopen (map->map_to, "r");
15267
15268   return fopen (filename, "r");
15269 }
15270
15271 /* Print the file names and line numbers of the #include
15272    commands which led to the current file.  */
15273
15274 static void
15275 print_containing_files (ffebadSeverity sev)
15276 {
15277   FILE_BUF *ip = NULL;
15278   int i;
15279   int first = 1;
15280   const char *str1;
15281   const char *str2;
15282
15283   /* If stack of files hasn't changed since we last printed
15284      this info, don't repeat it.  */
15285   if (last_error_tick == input_file_stack_tick)
15286     return;
15287
15288   for (i = indepth; i >= 0; i--)
15289     if (instack[i].fname != NULL) {
15290       ip = &instack[i];
15291       break;
15292     }
15293
15294   /* Give up if we don't find a source file.  */
15295   if (ip == NULL)
15296     return;
15297
15298   /* Find the other, outer source files.  */
15299   for (i--; i >= 0; i--)
15300     if (instack[i].fname != NULL)
15301       {
15302         ip = &instack[i];
15303         if (first)
15304           {
15305             first = 0;
15306             str1 = "In file included";
15307           }
15308         else
15309           {
15310             str1 = "...          ...";
15311           }
15312
15313         if (i == 1)
15314           str2 = ":";
15315         else
15316           str2 = "";
15317
15318         /* xgettext:no-c-format */
15319         ffebad_start_msg ("%A from %B at %0%C", sev);
15320         ffebad_here (0, ip->line, ip->column);
15321         ffebad_string (str1);
15322         ffebad_string (ip->nominal_fname);
15323         ffebad_string (str2);
15324         ffebad_finish ();
15325       }
15326
15327   /* Record we have printed the status as of this time.  */
15328   last_error_tick = input_file_stack_tick;
15329 }
15330
15331 /* Read a space delimited string of unlimited length from a stdio
15332    file.  */
15333
15334 static char *
15335 read_filename_string (ch, f)
15336      int ch;
15337      FILE *f;
15338 {
15339   char *alloc, *set;
15340   int len;
15341
15342   len = 20;
15343   set = alloc = xmalloc (len + 1);
15344   if (! ISSPACE (ch))
15345     {
15346       *set++ = ch;
15347       while ((ch = getc (f)) != EOF && ! ISSPACE (ch))
15348         {
15349           if (set - alloc == len)
15350             {
15351               len *= 2;
15352               alloc = xrealloc (alloc, len + 1);
15353               set = alloc + len / 2;
15354             }
15355           *set++ = ch;
15356         }
15357     }
15358   *set = '\0';
15359   ungetc (ch, f);
15360   return alloc;
15361 }
15362
15363 /* Read the file name map file for DIRNAME.  */
15364
15365 static struct file_name_map *
15366 read_name_map (dirname)
15367      const char *dirname;
15368 {
15369   /* This structure holds a linked list of file name maps, one per
15370      directory.  */
15371   struct file_name_map_list
15372     {
15373       struct file_name_map_list *map_list_next;
15374       char *map_list_name;
15375       struct file_name_map *map_list_map;
15376     };
15377   static struct file_name_map_list *map_list;
15378   register struct file_name_map_list *map_list_ptr;
15379   char *name;
15380   FILE *f;
15381   size_t dirlen;
15382   int separator_needed;
15383
15384   dirname = skip_redundant_dir_prefix (dirname);
15385
15386   for (map_list_ptr = map_list; map_list_ptr;
15387        map_list_ptr = map_list_ptr->map_list_next)
15388     if (! strcmp (map_list_ptr->map_list_name, dirname))
15389       return map_list_ptr->map_list_map;
15390
15391   map_list_ptr = ((struct file_name_map_list *)
15392                   xmalloc (sizeof (struct file_name_map_list)));
15393   map_list_ptr->map_list_name = xstrdup (dirname);
15394   map_list_ptr->map_list_map = NULL;
15395
15396   dirlen = strlen (dirname);
15397   separator_needed = dirlen != 0 && dirname[dirlen - 1] != '/';
15398   name = (char *) xmalloc (dirlen + strlen (FILE_NAME_MAP_FILE) + 2);
15399   strcpy (name, dirname);
15400   name[dirlen] = '/';
15401   strcpy (name + dirlen + separator_needed, FILE_NAME_MAP_FILE);
15402   f = fopen (name, "r");
15403   free (name);
15404   if (!f)
15405     map_list_ptr->map_list_map = NULL;
15406   else
15407     {
15408       int ch;
15409
15410       while ((ch = getc (f)) != EOF)
15411         {
15412           char *from, *to;
15413           struct file_name_map *ptr;
15414
15415           if (ISSPACE (ch))
15416             continue;
15417           from = read_filename_string (ch, f);
15418           while ((ch = getc (f)) != EOF && ISSPACE (ch) && ch != '\n')
15419             ;
15420           to = read_filename_string (ch, f);
15421
15422           ptr = ((struct file_name_map *)
15423                  xmalloc (sizeof (struct file_name_map)));
15424           ptr->map_from = from;
15425
15426           /* Make the real filename absolute.  */
15427           if (*to == '/')
15428             ptr->map_to = to;
15429           else
15430             {
15431               ptr->map_to = xmalloc (dirlen + strlen (to) + 2);
15432               strcpy (ptr->map_to, dirname);
15433               ptr->map_to[dirlen] = '/';
15434               strcpy (ptr->map_to + dirlen + separator_needed, to);
15435               free (to);
15436             }
15437
15438           ptr->map_next = map_list_ptr->map_list_map;
15439           map_list_ptr->map_list_map = ptr;
15440
15441           while ((ch = getc (f)) != '\n')
15442             if (ch == EOF)
15443               break;
15444         }
15445       fclose (f);
15446     }
15447
15448   map_list_ptr->map_list_next = map_list;
15449   map_list = map_list_ptr;
15450
15451   return map_list_ptr->map_list_map;
15452 }
15453
15454 static void
15455 ffecom_file_ (const char *name)
15456 {
15457   FILE_BUF *fp;
15458
15459   /* Do partial setup of input buffer for the sake of generating
15460      early #line directives (when -g is in effect).  */
15461
15462   fp = &instack[++indepth];
15463   memset ((char *) fp, 0, sizeof (FILE_BUF));
15464   if (name == NULL)
15465     name = "";
15466   fp->nominal_fname = fp->fname = name;
15467 }
15468
15469 static void
15470 ffecom_close_include_ (FILE *f)
15471 {
15472   fclose (f);
15473
15474   indepth--;
15475   input_file_stack_tick++;
15476
15477   ffewhere_line_kill (instack[indepth].line);
15478   ffewhere_column_kill (instack[indepth].column);
15479 }
15480
15481 static int
15482 ffecom_decode_include_option_ (char *spec)
15483 {
15484   struct file_name_list *dirtmp;
15485
15486   if (! ignore_srcdir && !strcmp (spec, "-"))
15487     ignore_srcdir = 1;
15488   else
15489     {
15490       dirtmp = (struct file_name_list *)
15491         xmalloc (sizeof (struct file_name_list));
15492       dirtmp->next = 0;         /* New one goes on the end */
15493       dirtmp->fname = spec;
15494       dirtmp->got_name_map = 0;
15495       if (spec[0] == 0)
15496         error ("directory name must immediately follow -I");
15497       else
15498         append_include_chain (dirtmp, dirtmp);
15499     }
15500   return 1;
15501 }
15502
15503 /* Open INCLUDEd file.  */
15504
15505 static FILE *
15506 ffecom_open_include_ (char *name, ffewhereLine l, ffewhereColumn c)
15507 {
15508   char *fbeg = name;
15509   size_t flen = strlen (fbeg);
15510   struct file_name_list *search_start = include; /* Chain of dirs to search */
15511   struct file_name_list dsp[1]; /* First in chain, if #include "..." */
15512   struct file_name_list *searchptr = 0;
15513   char *fname;          /* Dynamically allocated fname buffer */
15514   FILE *f;
15515   FILE_BUF *fp;
15516
15517   if (flen == 0)
15518     return NULL;
15519
15520   dsp[0].fname = NULL;
15521
15522   /* If -I- was specified, don't search current dir, only spec'd ones. */
15523   if (!ignore_srcdir)
15524     {
15525       for (fp = &instack[indepth]; fp >= instack; fp--)
15526         {
15527           int n;
15528           char *ep;
15529           const char *nam;
15530
15531           if ((nam = fp->nominal_fname) != NULL)
15532             {
15533               /* Found a named file.  Figure out dir of the file,
15534                  and put it in front of the search list.  */
15535               dsp[0].next = search_start;
15536               search_start = dsp;
15537 #ifndef VMS
15538               ep = strrchr (nam, '/');
15539 #ifdef DIR_SEPARATOR
15540             if (ep == NULL) ep = strrchr (nam, DIR_SEPARATOR);
15541             else {
15542               char *tmp = strrchr (nam, DIR_SEPARATOR);
15543               if (tmp != NULL && tmp > ep) ep = tmp;
15544             }
15545 #endif
15546 #else                           /* VMS */
15547               ep = strrchr (nam, ']');
15548               if (ep == NULL) ep = strrchr (nam, '>');
15549               if (ep == NULL) ep = strrchr (nam, ':');
15550               if (ep != NULL) ep++;
15551 #endif                          /* VMS */
15552               if (ep != NULL)
15553                 {
15554                   n = ep - nam;
15555                   dsp[0].fname = (char *) xmalloc (n + 1);
15556                   strncpy (dsp[0].fname, nam, n);
15557                   dsp[0].fname[n] = '\0';
15558                   if (n + INCLUDE_LEN_FUDGE > max_include_len)
15559                     max_include_len = n + INCLUDE_LEN_FUDGE;
15560                 }
15561               else
15562                 dsp[0].fname = NULL; /* Current directory */
15563               dsp[0].got_name_map = 0;
15564               break;
15565             }
15566         }
15567     }
15568
15569   /* Allocate this permanently, because it gets stored in the definitions
15570      of macros.  */
15571   fname = xmalloc (max_include_len + flen + 4);
15572   /* + 2 above for slash and terminating null.  */
15573   /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED
15574      for g77 yet).  */
15575
15576   /* If specified file name is absolute, just open it.  */
15577
15578   if (*fbeg == '/'
15579 #ifdef DIR_SEPARATOR
15580       || *fbeg == DIR_SEPARATOR
15581 #endif
15582       )
15583     {
15584       strncpy (fname, (char *) fbeg, flen);
15585       fname[flen] = 0;
15586       f = open_include_file (fname, NULL);
15587     }
15588   else
15589     {
15590       f = NULL;
15591
15592       /* Search directory path, trying to open the file.
15593          Copy each filename tried into FNAME.  */
15594
15595       for (searchptr = search_start; searchptr; searchptr = searchptr->next)
15596         {
15597           if (searchptr->fname)
15598             {
15599               /* The empty string in a search path is ignored.
15600                  This makes it possible to turn off entirely
15601                  a standard piece of the list.  */
15602               if (searchptr->fname[0] == 0)
15603                 continue;
15604               strcpy (fname, skip_redundant_dir_prefix (searchptr->fname));
15605               if (fname[0] && fname[strlen (fname) - 1] != '/')
15606                 strcat (fname, "/");
15607               fname[strlen (fname) + flen] = 0;
15608             }
15609           else
15610             fname[0] = 0;
15611
15612           strncat (fname, fbeg, flen);
15613 #ifdef VMS
15614           /* Change this 1/2 Unix 1/2 VMS file specification into a
15615              full VMS file specification */
15616           if (searchptr->fname && (searchptr->fname[0] != 0))
15617             {
15618               /* Fix up the filename */
15619               hack_vms_include_specification (fname);
15620             }
15621           else
15622             {
15623               /* This is a normal VMS filespec, so use it unchanged.  */
15624               strncpy (fname, (char *) fbeg, flen);
15625               fname[flen] = 0;
15626 #if 0   /* Not for g77.  */
15627               /* if it's '#include filename', add the missing .h */
15628               if (strchr (fname, '.') == NULL)
15629                 strcat (fname, ".h");
15630 #endif
15631             }
15632 #endif /* VMS */
15633           f = open_include_file (fname, searchptr);
15634 #ifdef EACCES
15635           if (f == NULL && errno == EACCES)
15636             {
15637               print_containing_files (FFEBAD_severityWARNING);
15638               /* xgettext:no-c-format */
15639               ffebad_start_msg ("At %0, INCLUDE file %A exists, but is not readable",
15640                                 FFEBAD_severityWARNING);
15641               ffebad_string (fname);
15642               ffebad_here (0, l, c);
15643               ffebad_finish ();
15644             }
15645 #endif
15646           if (f != NULL)
15647             break;
15648         }
15649     }
15650
15651   if (f == NULL)
15652     {
15653       /* A file that was not found.  */
15654
15655       strncpy (fname, (char *) fbeg, flen);
15656       fname[flen] = 0;
15657       print_containing_files (ffebad_severity (FFEBAD_OPEN_INCLUDE));
15658       ffebad_start (FFEBAD_OPEN_INCLUDE);
15659       ffebad_here (0, l, c);
15660       ffebad_string (fname);
15661       ffebad_finish ();
15662     }
15663
15664   if (dsp[0].fname != NULL)
15665     free (dsp[0].fname);
15666
15667   if (f == NULL)
15668     return NULL;
15669
15670   if (indepth >= (INPUT_STACK_MAX - 1))
15671     {
15672       print_containing_files (FFEBAD_severityFATAL);
15673       /* xgettext:no-c-format */
15674       ffebad_start_msg ("At %0, INCLUDE nesting too deep",
15675                         FFEBAD_severityFATAL);
15676       ffebad_string (fname);
15677       ffebad_here (0, l, c);
15678       ffebad_finish ();
15679       return NULL;
15680     }
15681
15682   instack[indepth].line = ffewhere_line_use (l);
15683   instack[indepth].column = ffewhere_column_use (c);
15684
15685   fp = &instack[indepth + 1];
15686   memset ((char *) fp, 0, sizeof (FILE_BUF));
15687   fp->nominal_fname = fp->fname = fname;
15688   fp->dir = searchptr;
15689
15690   indepth++;
15691   input_file_stack_tick++;
15692
15693   return f;
15694 }
15695
15696 /**INDENT* (Do not reformat this comment even with -fca option.)
15697    Data-gathering files: Given the source file listed below, compiled with
15698    f2c I obtained the output file listed after that, and from the output
15699    file I derived the above code.
15700
15701 -------- (begin input file to f2c)
15702         implicit none
15703         character*10 A1,A2
15704         complex C1,C2
15705         integer I1,I2
15706         real R1,R2
15707         double precision D1,D2
15708 C
15709         call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2)
15710 c /
15711         call fooI(I1/I2)
15712         call fooR(R1/I1)
15713         call fooD(D1/I1)
15714         call fooC(C1/I1)
15715         call fooR(R1/R2)
15716         call fooD(R1/D1)
15717         call fooD(D1/D2)
15718         call fooD(D1/R1)
15719         call fooC(C1/C2)
15720         call fooC(C1/R1)
15721         call fooZ(C1/D1)
15722 c **
15723         call fooI(I1**I2)
15724         call fooR(R1**I1)
15725         call fooD(D1**I1)
15726         call fooC(C1**I1)
15727         call fooR(R1**R2)
15728         call fooD(R1**D1)
15729         call fooD(D1**D2)
15730         call fooD(D1**R1)
15731         call fooC(C1**C2)
15732         call fooC(C1**R1)
15733         call fooZ(C1**D1)
15734 c FFEINTRIN_impABS
15735         call fooR(ABS(R1))
15736 c FFEINTRIN_impACOS
15737         call fooR(ACOS(R1))
15738 c FFEINTRIN_impAIMAG
15739         call fooR(AIMAG(C1))
15740 c FFEINTRIN_impAINT
15741         call fooR(AINT(R1))
15742 c FFEINTRIN_impALOG
15743         call fooR(ALOG(R1))
15744 c FFEINTRIN_impALOG10
15745         call fooR(ALOG10(R1))
15746 c FFEINTRIN_impAMAX0
15747         call fooR(AMAX0(I1,I2))
15748 c FFEINTRIN_impAMAX1
15749         call fooR(AMAX1(R1,R2))
15750 c FFEINTRIN_impAMIN0
15751         call fooR(AMIN0(I1,I2))
15752 c FFEINTRIN_impAMIN1
15753         call fooR(AMIN1(R1,R2))
15754 c FFEINTRIN_impAMOD
15755         call fooR(AMOD(R1,R2))
15756 c FFEINTRIN_impANINT
15757         call fooR(ANINT(R1))
15758 c FFEINTRIN_impASIN
15759         call fooR(ASIN(R1))
15760 c FFEINTRIN_impATAN
15761         call fooR(ATAN(R1))
15762 c FFEINTRIN_impATAN2
15763         call fooR(ATAN2(R1,R2))
15764 c FFEINTRIN_impCABS
15765         call fooR(CABS(C1))
15766 c FFEINTRIN_impCCOS
15767         call fooC(CCOS(C1))
15768 c FFEINTRIN_impCEXP
15769         call fooC(CEXP(C1))
15770 c FFEINTRIN_impCHAR
15771         call fooA(CHAR(I1))
15772 c FFEINTRIN_impCLOG
15773         call fooC(CLOG(C1))
15774 c FFEINTRIN_impCONJG
15775         call fooC(CONJG(C1))
15776 c FFEINTRIN_impCOS
15777         call fooR(COS(R1))
15778 c FFEINTRIN_impCOSH
15779         call fooR(COSH(R1))
15780 c FFEINTRIN_impCSIN
15781         call fooC(CSIN(C1))
15782 c FFEINTRIN_impCSQRT
15783         call fooC(CSQRT(C1))
15784 c FFEINTRIN_impDABS
15785         call fooD(DABS(D1))
15786 c FFEINTRIN_impDACOS
15787         call fooD(DACOS(D1))
15788 c FFEINTRIN_impDASIN
15789         call fooD(DASIN(D1))
15790 c FFEINTRIN_impDATAN
15791         call fooD(DATAN(D1))
15792 c FFEINTRIN_impDATAN2
15793         call fooD(DATAN2(D1,D2))
15794 c FFEINTRIN_impDCOS
15795         call fooD(DCOS(D1))
15796 c FFEINTRIN_impDCOSH
15797         call fooD(DCOSH(D1))
15798 c FFEINTRIN_impDDIM
15799         call fooD(DDIM(D1,D2))
15800 c FFEINTRIN_impDEXP
15801         call fooD(DEXP(D1))
15802 c FFEINTRIN_impDIM
15803         call fooR(DIM(R1,R2))
15804 c FFEINTRIN_impDINT
15805         call fooD(DINT(D1))
15806 c FFEINTRIN_impDLOG
15807         call fooD(DLOG(D1))
15808 c FFEINTRIN_impDLOG10
15809         call fooD(DLOG10(D1))
15810 c FFEINTRIN_impDMAX1
15811         call fooD(DMAX1(D1,D2))
15812 c FFEINTRIN_impDMIN1
15813         call fooD(DMIN1(D1,D2))
15814 c FFEINTRIN_impDMOD
15815         call fooD(DMOD(D1,D2))
15816 c FFEINTRIN_impDNINT
15817         call fooD(DNINT(D1))
15818 c FFEINTRIN_impDPROD
15819         call fooD(DPROD(R1,R2))
15820 c FFEINTRIN_impDSIGN
15821         call fooD(DSIGN(D1,D2))
15822 c FFEINTRIN_impDSIN
15823         call fooD(DSIN(D1))
15824 c FFEINTRIN_impDSINH
15825         call fooD(DSINH(D1))
15826 c FFEINTRIN_impDSQRT
15827         call fooD(DSQRT(D1))
15828 c FFEINTRIN_impDTAN
15829         call fooD(DTAN(D1))
15830 c FFEINTRIN_impDTANH
15831         call fooD(DTANH(D1))
15832 c FFEINTRIN_impEXP
15833         call fooR(EXP(R1))
15834 c FFEINTRIN_impIABS
15835         call fooI(IABS(I1))
15836 c FFEINTRIN_impICHAR
15837         call fooI(ICHAR(A1))
15838 c FFEINTRIN_impIDIM
15839         call fooI(IDIM(I1,I2))
15840 c FFEINTRIN_impIDNINT
15841         call fooI(IDNINT(D1))
15842 c FFEINTRIN_impINDEX
15843         call fooI(INDEX(A1,A2))
15844 c FFEINTRIN_impISIGN
15845         call fooI(ISIGN(I1,I2))
15846 c FFEINTRIN_impLEN
15847         call fooI(LEN(A1))
15848 c FFEINTRIN_impLGE
15849         call fooL(LGE(A1,A2))
15850 c FFEINTRIN_impLGT
15851         call fooL(LGT(A1,A2))
15852 c FFEINTRIN_impLLE
15853         call fooL(LLE(A1,A2))
15854 c FFEINTRIN_impLLT
15855         call fooL(LLT(A1,A2))
15856 c FFEINTRIN_impMAX0
15857         call fooI(MAX0(I1,I2))
15858 c FFEINTRIN_impMAX1
15859         call fooI(MAX1(R1,R2))
15860 c FFEINTRIN_impMIN0
15861         call fooI(MIN0(I1,I2))
15862 c FFEINTRIN_impMIN1
15863         call fooI(MIN1(R1,R2))
15864 c FFEINTRIN_impMOD
15865         call fooI(MOD(I1,I2))
15866 c FFEINTRIN_impNINT
15867         call fooI(NINT(R1))
15868 c FFEINTRIN_impSIGN
15869         call fooR(SIGN(R1,R2))
15870 c FFEINTRIN_impSIN
15871         call fooR(SIN(R1))
15872 c FFEINTRIN_impSINH
15873         call fooR(SINH(R1))
15874 c FFEINTRIN_impSQRT
15875         call fooR(SQRT(R1))
15876 c FFEINTRIN_impTAN
15877         call fooR(TAN(R1))
15878 c FFEINTRIN_impTANH
15879         call fooR(TANH(R1))
15880 c FFEINTRIN_imp_CMPLX_C
15881         call fooC(cmplx(C1,C2))
15882 c FFEINTRIN_imp_CMPLX_D
15883         call fooZ(cmplx(D1,D2))
15884 c FFEINTRIN_imp_CMPLX_I
15885         call fooC(cmplx(I1,I2))
15886 c FFEINTRIN_imp_CMPLX_R
15887         call fooC(cmplx(R1,R2))
15888 c FFEINTRIN_imp_DBLE_C
15889         call fooD(dble(C1))
15890 c FFEINTRIN_imp_DBLE_D
15891         call fooD(dble(D1))
15892 c FFEINTRIN_imp_DBLE_I
15893         call fooD(dble(I1))
15894 c FFEINTRIN_imp_DBLE_R
15895         call fooD(dble(R1))
15896 c FFEINTRIN_imp_INT_C
15897         call fooI(int(C1))
15898 c FFEINTRIN_imp_INT_D
15899         call fooI(int(D1))
15900 c FFEINTRIN_imp_INT_I
15901         call fooI(int(I1))
15902 c FFEINTRIN_imp_INT_R
15903         call fooI(int(R1))
15904 c FFEINTRIN_imp_REAL_C
15905         call fooR(real(C1))
15906 c FFEINTRIN_imp_REAL_D
15907         call fooR(real(D1))
15908 c FFEINTRIN_imp_REAL_I
15909         call fooR(real(I1))
15910 c FFEINTRIN_imp_REAL_R
15911         call fooR(real(R1))
15912 c
15913 c FFEINTRIN_imp_INT_D:
15914 c
15915 c FFEINTRIN_specIDINT
15916         call fooI(IDINT(D1))
15917 c
15918 c FFEINTRIN_imp_INT_R:
15919 c
15920 c FFEINTRIN_specIFIX
15921         call fooI(IFIX(R1))
15922 c FFEINTRIN_specINT
15923         call fooI(INT(R1))
15924 c
15925 c FFEINTRIN_imp_REAL_D:
15926 c
15927 c FFEINTRIN_specSNGL
15928         call fooR(SNGL(D1))
15929 c
15930 c FFEINTRIN_imp_REAL_I:
15931 c
15932 c FFEINTRIN_specFLOAT
15933         call fooR(FLOAT(I1))
15934 c FFEINTRIN_specREAL
15935         call fooR(REAL(I1))
15936 c
15937         end
15938 -------- (end input file to f2c)
15939
15940 -------- (begin output from providing above input file as input to:
15941 --------  `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
15942 --------     -e "s:^#.*$::g"')
15943
15944 //  -- translated by f2c (version 19950223).
15945    You must link the resulting object file with the libraries:
15946         -lf2c -lm   (in that order)
15947 //
15948
15949
15950 // f2c.h  --  Standard Fortran to C header file //
15951
15952 ///  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
15953
15954         - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
15955
15956
15957
15958
15959 // F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems //
15960 // we assume short, float are OK //
15961 typedef long int // long int // integer;
15962 typedef char *address;
15963 typedef short int shortint;
15964 typedef float real;
15965 typedef double doublereal;
15966 typedef struct { real r, i; } complex;
15967 typedef struct { doublereal r, i; } doublecomplex;
15968 typedef long int // long int // logical;
15969 typedef short int shortlogical;
15970 typedef char logical1;
15971 typedef char integer1;
15972 // typedef long long longint; // // system-dependent //
15973
15974
15975
15976
15977 // Extern is for use with -E //
15978
15979
15980
15981
15982 // I/O stuff //
15983
15984
15985
15986
15987
15988
15989
15990
15991 typedef long int // int or long int // flag;
15992 typedef long int // int or long int // ftnlen;
15993 typedef long int // int or long int // ftnint;
15994
15995
15996 //external read, write//
15997 typedef struct
15998 {       flag cierr;
15999         ftnint ciunit;
16000         flag ciend;
16001         char *cifmt;
16002         ftnint cirec;
16003 } cilist;
16004
16005 //internal read, write//
16006 typedef struct
16007 {       flag icierr;
16008         char *iciunit;
16009         flag iciend;
16010         char *icifmt;
16011         ftnint icirlen;
16012         ftnint icirnum;
16013 } icilist;
16014
16015 //open//
16016 typedef struct
16017 {       flag oerr;
16018         ftnint ounit;
16019         char *ofnm;
16020         ftnlen ofnmlen;
16021         char *osta;
16022         char *oacc;
16023         char *ofm;
16024         ftnint orl;
16025         char *oblnk;
16026 } olist;
16027
16028 //close//
16029 typedef struct
16030 {       flag cerr;
16031         ftnint cunit;
16032         char *csta;
16033 } cllist;
16034
16035 //rewind, backspace, endfile//
16036 typedef struct
16037 {       flag aerr;
16038         ftnint aunit;
16039 } alist;
16040
16041 // inquire //
16042 typedef struct
16043 {       flag inerr;
16044         ftnint inunit;
16045         char *infile;
16046         ftnlen infilen;
16047         ftnint  *inex;  //parameters in standard's order//
16048         ftnint  *inopen;
16049         ftnint  *innum;
16050         ftnint  *innamed;
16051         char    *inname;
16052         ftnlen  innamlen;
16053         char    *inacc;
16054         ftnlen  inacclen;
16055         char    *inseq;
16056         ftnlen  inseqlen;
16057         char    *indir;
16058         ftnlen  indirlen;
16059         char    *infmt;
16060         ftnlen  infmtlen;
16061         char    *inform;
16062         ftnint  informlen;
16063         char    *inunf;
16064         ftnlen  inunflen;
16065         ftnint  *inrecl;
16066         ftnint  *innrec;
16067         char    *inblank;
16068         ftnlen  inblanklen;
16069 } inlist;
16070
16071
16072
16073 union Multitype {       // for multiple entry points //
16074         integer1 g;
16075         shortint h;
16076         integer i;
16077         // longint j; //
16078         real r;
16079         doublereal d;
16080         complex c;
16081         doublecomplex z;
16082         };
16083
16084 typedef union Multitype Multitype;
16085
16086 typedef long Long;      // No longer used; formerly in Namelist //
16087
16088 struct Vardesc {        // for Namelist //
16089         char *name;
16090         char *addr;
16091         ftnlen *dims;
16092         int  type;
16093         };
16094 typedef struct Vardesc Vardesc;
16095
16096 struct Namelist {
16097         char *name;
16098         Vardesc **vars;
16099         int nvars;
16100         };
16101 typedef struct Namelist Namelist;
16102
16103
16104
16105
16106
16107
16108
16109
16110 // procedure parameter types for -A and -C++ //
16111
16112
16113
16114
16115 typedef int // Unknown procedure type // (*U_fp)();
16116 typedef shortint (*J_fp)();
16117 typedef integer (*I_fp)();
16118 typedef real (*R_fp)();
16119 typedef doublereal (*D_fp)(), (*E_fp)();
16120 typedef // Complex // void  (*C_fp)();
16121 typedef // Double Complex // void  (*Z_fp)();
16122 typedef logical (*L_fp)();
16123 typedef shortlogical (*K_fp)();
16124 typedef // Character // void  (*H_fp)();
16125 typedef // Subroutine // int (*S_fp)();
16126
16127 // E_fp is for real functions when -R is not specified //
16128 typedef void  C_f;      // complex function //
16129 typedef void  H_f;      // character function //
16130 typedef void  Z_f;      // double complex function //
16131 typedef doublereal E_f; // real function with -R not specified //
16132
16133 // undef any lower-case symbols that your C compiler predefines, e.g.: //
16134
16135
16136 // (No such symbols should be defined in a strict ANSI C compiler.
16137    We can avoid trouble with f2c-translated code by using
16138    gcc -ansi.) //
16139
16140
16141
16142
16143
16144
16145
16146
16147
16148
16149
16150
16151
16152
16153
16154
16155
16156
16157
16158
16159
16160
16161
16162 // Main program // MAIN__()
16163 {
16164     // System generated locals //
16165     integer i__1;
16166     real r__1, r__2;
16167     doublereal d__1, d__2;
16168     complex q__1;
16169     doublecomplex z__1, z__2, z__3;
16170     logical L__1;
16171     char ch__1[1];
16172
16173     // Builtin functions //
16174     void c_div();
16175     integer pow_ii();
16176     double pow_ri(), pow_di();
16177     void pow_ci();
16178     double pow_dd();
16179     void pow_zz();
16180     double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
16181             asin(), atan(), atan2(), c_abs();
16182     void c_cos(), c_exp(), c_log(), r_cnjg();
16183     double cos(), cosh();
16184     void c_sin(), c_sqrt();
16185     double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
16186             d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
16187     integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
16188     logical l_ge(), l_gt(), l_le(), l_lt();
16189     integer i_nint();
16190     double r_sign();
16191
16192     // Local variables //
16193     extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
16194             fool_(), fooz_(), getem_();
16195     static char a1[10], a2[10];
16196     static complex c1, c2;
16197     static doublereal d1, d2;
16198     static integer i1, i2;
16199     static real r1, r2;
16200
16201
16202     getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L);
16203 // / //
16204     i__1 = i1 / i2;
16205     fooi_(&i__1);
16206     r__1 = r1 / i1;
16207     foor_(&r__1);
16208     d__1 = d1 / i1;
16209     food_(&d__1);
16210     d__1 = (doublereal) i1;
16211     q__1.r = c1.r / d__1, q__1.i = c1.i / d__1;
16212     fooc_(&q__1);
16213     r__1 = r1 / r2;
16214     foor_(&r__1);
16215     d__1 = r1 / d1;
16216     food_(&d__1);
16217     d__1 = d1 / d2;
16218     food_(&d__1);
16219     d__1 = d1 / r1;
16220     food_(&d__1);
16221     c_div(&q__1, &c1, &c2);
16222     fooc_(&q__1);
16223     q__1.r = c1.r / r1, q__1.i = c1.i / r1;
16224     fooc_(&q__1);
16225     z__1.r = c1.r / d1, z__1.i = c1.i / d1;
16226     fooz_(&z__1);
16227 // ** //
16228     i__1 = pow_ii(&i1, &i2);
16229     fooi_(&i__1);
16230     r__1 = pow_ri(&r1, &i1);
16231     foor_(&r__1);
16232     d__1 = pow_di(&d1, &i1);
16233     food_(&d__1);
16234     pow_ci(&q__1, &c1, &i1);
16235     fooc_(&q__1);
16236     d__1 = (doublereal) r1;
16237     d__2 = (doublereal) r2;
16238     r__1 = pow_dd(&d__1, &d__2);
16239     foor_(&r__1);
16240     d__2 = (doublereal) r1;
16241     d__1 = pow_dd(&d__2, &d1);
16242     food_(&d__1);
16243     d__1 = pow_dd(&d1, &d2);
16244     food_(&d__1);
16245     d__2 = (doublereal) r1;
16246     d__1 = pow_dd(&d1, &d__2);
16247     food_(&d__1);
16248     z__2.r = c1.r, z__2.i = c1.i;
16249     z__3.r = c2.r, z__3.i = c2.i;
16250     pow_zz(&z__1, &z__2, &z__3);
16251     q__1.r = z__1.r, q__1.i = z__1.i;
16252     fooc_(&q__1);
16253     z__2.r = c1.r, z__2.i = c1.i;
16254     z__3.r = r1, z__3.i = 0.;
16255     pow_zz(&z__1, &z__2, &z__3);
16256     q__1.r = z__1.r, q__1.i = z__1.i;
16257     fooc_(&q__1);
16258     z__2.r = c1.r, z__2.i = c1.i;
16259     z__3.r = d1, z__3.i = 0.;
16260     pow_zz(&z__1, &z__2, &z__3);
16261     fooz_(&z__1);
16262 // FFEINTRIN_impABS //
16263     r__1 = (doublereal)((  r1  ) >= 0 ? (  r1  ) : -(  r1  ))  ;
16264     foor_(&r__1);
16265 // FFEINTRIN_impACOS //
16266     r__1 = acos(r1);
16267     foor_(&r__1);
16268 // FFEINTRIN_impAIMAG //
16269     r__1 = r_imag(&c1);
16270     foor_(&r__1);
16271 // FFEINTRIN_impAINT //
16272     r__1 = r_int(&r1);
16273     foor_(&r__1);
16274 // FFEINTRIN_impALOG //
16275     r__1 = log(r1);
16276     foor_(&r__1);
16277 // FFEINTRIN_impALOG10 //
16278     r__1 = r_lg10(&r1);
16279     foor_(&r__1);
16280 // FFEINTRIN_impAMAX0 //
16281     r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16282     foor_(&r__1);
16283 // FFEINTRIN_impAMAX1 //
16284     r__1 = (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16285     foor_(&r__1);
16286 // FFEINTRIN_impAMIN0 //
16287     r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16288     foor_(&r__1);
16289 // FFEINTRIN_impAMIN1 //
16290     r__1 = (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16291     foor_(&r__1);
16292 // FFEINTRIN_impAMOD //
16293     r__1 = r_mod(&r1, &r2);
16294     foor_(&r__1);
16295 // FFEINTRIN_impANINT //
16296     r__1 = r_nint(&r1);
16297     foor_(&r__1);
16298 // FFEINTRIN_impASIN //
16299     r__1 = asin(r1);
16300     foor_(&r__1);
16301 // FFEINTRIN_impATAN //
16302     r__1 = atan(r1);
16303     foor_(&r__1);
16304 // FFEINTRIN_impATAN2 //
16305     r__1 = atan2(r1, r2);
16306     foor_(&r__1);
16307 // FFEINTRIN_impCABS //
16308     r__1 = c_abs(&c1);
16309     foor_(&r__1);
16310 // FFEINTRIN_impCCOS //
16311     c_cos(&q__1, &c1);
16312     fooc_(&q__1);
16313 // FFEINTRIN_impCEXP //
16314     c_exp(&q__1, &c1);
16315     fooc_(&q__1);
16316 // FFEINTRIN_impCHAR //
16317     *(unsigned char *)&ch__1[0] = i1;
16318     fooa_(ch__1, 1L);
16319 // FFEINTRIN_impCLOG //
16320     c_log(&q__1, &c1);
16321     fooc_(&q__1);
16322 // FFEINTRIN_impCONJG //
16323     r_cnjg(&q__1, &c1);
16324     fooc_(&q__1);
16325 // FFEINTRIN_impCOS //
16326     r__1 = cos(r1);
16327     foor_(&r__1);
16328 // FFEINTRIN_impCOSH //
16329     r__1 = cosh(r1);
16330     foor_(&r__1);
16331 // FFEINTRIN_impCSIN //
16332     c_sin(&q__1, &c1);
16333     fooc_(&q__1);
16334 // FFEINTRIN_impCSQRT //
16335     c_sqrt(&q__1, &c1);
16336     fooc_(&q__1);
16337 // FFEINTRIN_impDABS //
16338     d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ;
16339     food_(&d__1);
16340 // FFEINTRIN_impDACOS //
16341     d__1 = acos(d1);
16342     food_(&d__1);
16343 // FFEINTRIN_impDASIN //
16344     d__1 = asin(d1);
16345     food_(&d__1);
16346 // FFEINTRIN_impDATAN //
16347     d__1 = atan(d1);
16348     food_(&d__1);
16349 // FFEINTRIN_impDATAN2 //
16350     d__1 = atan2(d1, d2);
16351     food_(&d__1);
16352 // FFEINTRIN_impDCOS //
16353     d__1 = cos(d1);
16354     food_(&d__1);
16355 // FFEINTRIN_impDCOSH //
16356     d__1 = cosh(d1);
16357     food_(&d__1);
16358 // FFEINTRIN_impDDIM //
16359     d__1 = d_dim(&d1, &d2);
16360     food_(&d__1);
16361 // FFEINTRIN_impDEXP //
16362     d__1 = exp(d1);
16363     food_(&d__1);
16364 // FFEINTRIN_impDIM //
16365     r__1 = r_dim(&r1, &r2);
16366     foor_(&r__1);
16367 // FFEINTRIN_impDINT //
16368     d__1 = d_int(&d1);
16369     food_(&d__1);
16370 // FFEINTRIN_impDLOG //
16371     d__1 = log(d1);
16372     food_(&d__1);
16373 // FFEINTRIN_impDLOG10 //
16374     d__1 = d_lg10(&d1);
16375     food_(&d__1);
16376 // FFEINTRIN_impDMAX1 //
16377     d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ;
16378     food_(&d__1);
16379 // FFEINTRIN_impDMIN1 //
16380     d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ;
16381     food_(&d__1);
16382 // FFEINTRIN_impDMOD //
16383     d__1 = d_mod(&d1, &d2);
16384     food_(&d__1);
16385 // FFEINTRIN_impDNINT //
16386     d__1 = d_nint(&d1);
16387     food_(&d__1);
16388 // FFEINTRIN_impDPROD //
16389     d__1 = (doublereal) r1 * r2;
16390     food_(&d__1);
16391 // FFEINTRIN_impDSIGN //
16392     d__1 = d_sign(&d1, &d2);
16393     food_(&d__1);
16394 // FFEINTRIN_impDSIN //
16395     d__1 = sin(d1);
16396     food_(&d__1);
16397 // FFEINTRIN_impDSINH //
16398     d__1 = sinh(d1);
16399     food_(&d__1);
16400 // FFEINTRIN_impDSQRT //
16401     d__1 = sqrt(d1);
16402     food_(&d__1);
16403 // FFEINTRIN_impDTAN //
16404     d__1 = tan(d1);
16405     food_(&d__1);
16406 // FFEINTRIN_impDTANH //
16407     d__1 = tanh(d1);
16408     food_(&d__1);
16409 // FFEINTRIN_impEXP //
16410     r__1 = exp(r1);
16411     foor_(&r__1);
16412 // FFEINTRIN_impIABS //
16413     i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ;
16414     fooi_(&i__1);
16415 // FFEINTRIN_impICHAR //
16416     i__1 = *(unsigned char *)a1;
16417     fooi_(&i__1);
16418 // FFEINTRIN_impIDIM //
16419     i__1 = i_dim(&i1, &i2);
16420     fooi_(&i__1);
16421 // FFEINTRIN_impIDNINT //
16422     i__1 = i_dnnt(&d1);
16423     fooi_(&i__1);
16424 // FFEINTRIN_impINDEX //
16425     i__1 = i_indx(a1, a2, 10L, 10L);
16426     fooi_(&i__1);
16427 // FFEINTRIN_impISIGN //
16428     i__1 = i_sign(&i1, &i2);
16429     fooi_(&i__1);
16430 // FFEINTRIN_impLEN //
16431     i__1 = i_len(a1, 10L);
16432     fooi_(&i__1);
16433 // FFEINTRIN_impLGE //
16434     L__1 = l_ge(a1, a2, 10L, 10L);
16435     fool_(&L__1);
16436 // FFEINTRIN_impLGT //
16437     L__1 = l_gt(a1, a2, 10L, 10L);
16438     fool_(&L__1);
16439 // FFEINTRIN_impLLE //
16440     L__1 = l_le(a1, a2, 10L, 10L);
16441     fool_(&L__1);
16442 // FFEINTRIN_impLLT //
16443     L__1 = l_lt(a1, a2, 10L, 10L);
16444     fool_(&L__1);
16445 // FFEINTRIN_impMAX0 //
16446     i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16447     fooi_(&i__1);
16448 // FFEINTRIN_impMAX1 //
16449     i__1 = (integer) (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16450     fooi_(&i__1);
16451 // FFEINTRIN_impMIN0 //
16452     i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16453     fooi_(&i__1);
16454 // FFEINTRIN_impMIN1 //
16455     i__1 = (integer) (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16456     fooi_(&i__1);
16457 // FFEINTRIN_impMOD //
16458     i__1 = i1 % i2;
16459     fooi_(&i__1);
16460 // FFEINTRIN_impNINT //
16461     i__1 = i_nint(&r1);
16462     fooi_(&i__1);
16463 // FFEINTRIN_impSIGN //
16464     r__1 = r_sign(&r1, &r2);
16465     foor_(&r__1);
16466 // FFEINTRIN_impSIN //
16467     r__1 = sin(r1);
16468     foor_(&r__1);
16469 // FFEINTRIN_impSINH //
16470     r__1 = sinh(r1);
16471     foor_(&r__1);
16472 // FFEINTRIN_impSQRT //
16473     r__1 = sqrt(r1);
16474     foor_(&r__1);
16475 // FFEINTRIN_impTAN //
16476     r__1 = tan(r1);
16477     foor_(&r__1);
16478 // FFEINTRIN_impTANH //
16479     r__1 = tanh(r1);
16480     foor_(&r__1);
16481 // FFEINTRIN_imp_CMPLX_C //
16482     r__1 = c1.r;
16483     r__2 = c2.r;
16484     q__1.r = r__1, q__1.i = r__2;
16485     fooc_(&q__1);
16486 // FFEINTRIN_imp_CMPLX_D //
16487     z__1.r = d1, z__1.i = d2;
16488     fooz_(&z__1);
16489 // FFEINTRIN_imp_CMPLX_I //
16490     r__1 = (real) i1;
16491     r__2 = (real) i2;
16492     q__1.r = r__1, q__1.i = r__2;
16493     fooc_(&q__1);
16494 // FFEINTRIN_imp_CMPLX_R //
16495     q__1.r = r1, q__1.i = r2;
16496     fooc_(&q__1);
16497 // FFEINTRIN_imp_DBLE_C //
16498     d__1 = (doublereal) c1.r;
16499     food_(&d__1);
16500 // FFEINTRIN_imp_DBLE_D //
16501     d__1 = d1;
16502     food_(&d__1);
16503 // FFEINTRIN_imp_DBLE_I //
16504     d__1 = (doublereal) i1;
16505     food_(&d__1);
16506 // FFEINTRIN_imp_DBLE_R //
16507     d__1 = (doublereal) r1;
16508     food_(&d__1);
16509 // FFEINTRIN_imp_INT_C //
16510     i__1 = (integer) c1.r;
16511     fooi_(&i__1);
16512 // FFEINTRIN_imp_INT_D //
16513     i__1 = (integer) d1;
16514     fooi_(&i__1);
16515 // FFEINTRIN_imp_INT_I //
16516     i__1 = i1;
16517     fooi_(&i__1);
16518 // FFEINTRIN_imp_INT_R //
16519     i__1 = (integer) r1;
16520     fooi_(&i__1);
16521 // FFEINTRIN_imp_REAL_C //
16522     r__1 = c1.r;
16523     foor_(&r__1);
16524 // FFEINTRIN_imp_REAL_D //
16525     r__1 = (real) d1;
16526     foor_(&r__1);
16527 // FFEINTRIN_imp_REAL_I //
16528     r__1 = (real) i1;
16529     foor_(&r__1);
16530 // FFEINTRIN_imp_REAL_R //
16531     r__1 = r1;
16532     foor_(&r__1);
16533
16534 // FFEINTRIN_imp_INT_D: //
16535
16536 // FFEINTRIN_specIDINT //
16537     i__1 = (integer) d1;
16538     fooi_(&i__1);
16539
16540 // FFEINTRIN_imp_INT_R: //
16541
16542 // FFEINTRIN_specIFIX //
16543     i__1 = (integer) r1;
16544     fooi_(&i__1);
16545 // FFEINTRIN_specINT //
16546     i__1 = (integer) r1;
16547     fooi_(&i__1);
16548
16549 // FFEINTRIN_imp_REAL_D: //
16550
16551 // FFEINTRIN_specSNGL //
16552     r__1 = (real) d1;
16553     foor_(&r__1);
16554
16555 // FFEINTRIN_imp_REAL_I: //
16556
16557 // FFEINTRIN_specFLOAT //
16558     r__1 = (real) i1;
16559     foor_(&r__1);
16560 // FFEINTRIN_specREAL //
16561     r__1 = (real) i1;
16562     foor_(&r__1);
16563
16564 } // MAIN__ //
16565
16566 -------- (end output file from f2c)
16567
16568 */
16569
16570 #include "gt-f-com.h"
16571 #include "gtype-f.h"