gcc/f/com.c

   1 /* com.c -- Implementation File (module.c template V1.0)
   2    Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001
   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 "rtl.h"
  86 #include "toplev.h"
  87 #include "tree.h"
  88 #include "output.h"  /* Must follow tree.h so TREE_CODE is defined! */
  89 #include "convert.h"
  90 #include "ggc.h"
  91 #include "diagnostic.h"
  92 #include "langhooks.h"
  93
  94 /* VMS-specific definitions */
  95 #ifdef VMS
  96 #include <descrip.h>
  97 #define O_RDONLY        0       /* Open arg for Read/Only  */
  98 #define O_WRONLY        1       /* Open arg for Write/Only */
  99 #define read(fd,buf,size)       VMS_read (fd,buf,size)
 100 #define write(fd,buf,size)      VMS_write (fd,buf,size)
 101 #define open(fname,mode,prot)   VMS_open (fname,mode,prot)
 102 #define fopen(fname,mode)       VMS_fopen (fname,mode)
 103 #define freopen(fname,mode,ofile) VMS_freopen (fname,mode,ofile)
 104 #define strncat(dst,src,cnt) VMS_strncat (dst,src,cnt)
 105 #define fstat(fd,stbuf)         VMS_fstat (fd,stbuf)
 106 static int VMS_fstat (), VMS_stat ();
 107 static char * VMS_strncat ();
 108 static int VMS_read ();
 109 static int VMS_write ();
 110 static int VMS_open ();
 111 static FILE * VMS_fopen ();
 112 static FILE * VMS_freopen ();
 113 static void hack_vms_include_specification ();
 114 typedef struct { unsigned :16, :16, :16; } vms_ino_t;
 115 #define ino_t vms_ino_t
 116 #define INCLUDE_LEN_FUDGE 10    /* leave room for VMS syntax conversion */
 117 #endif /* VMS */
 118
 119 #define FFECOM_DETERMINE_TYPES 1 /* for com.h */
 120 #include "com.h"
 121 #include "bad.h"
 122 #include "bld.h"
 123 #include "equiv.h"
 124 #include "expr.h"
 125 #include "implic.h"
 126 #include "info.h"
 127 #include "malloc.h"
 128 #include "src.h"
 129 #include "st.h"
 130 #include "storag.h"
 131 #include "symbol.h"
 132 #include "target.h"
 133 #include "top.h"
 134 #include "type.h"
 135
 136 /* Externals defined here.  */
 137
 138 /* ~~gcc/tree.h *should* declare this, because toplev.c and dwarfout.c
 139    reference it.  */
 140
 141 const char * const language_string = "GNU F77";
 142
 143 /* Stream for reading from the input file.  */
 144 FILE *finput;
 145
 146 /* These definitions parallel those in c-decl.c so that code from that
 147    module can be used pretty much as is.  Much of these defs aren't
 148    otherwise used, i.e. by g77 code per se, except some of them are used
 149    to build some of them that are.  The ones that are global (i.e. not
 150    "static") are those that ste.c and such might use (directly
 151    or by using com macros that reference them in their definitions).  */
 152
 153 tree string_type_node;
 154
 155 /* The rest of these are inventions for g77, though there might be
 156    similar things in the C front end.  As they are found, these
 157    inventions should be renamed to be canonical.  Note that only
 158    the ones currently required to be global are so.  */
 159
 160 static tree ffecom_tree_fun_type_void;
 161
 162 tree ffecom_integer_type_node;  /* Abbrev for _tree_type[blah][blah]. */
 163 tree ffecom_integer_zero_node;  /* Like *_*_* with g77's integer type. */
 164 tree ffecom_integer_one_node;   /* " */
 165 tree ffecom_tree_type[FFEINFO_basictype][FFEINFO_kindtype];
 166
 167 /* _fun_type things are the f2c-specific versions.  For -fno-f2c,
 168    just use build_function_type and build_pointer_type on the
 169    appropriate _tree_type array element.  */
 170
 171 static tree ffecom_tree_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
 172 static tree ffecom_tree_ptr_to_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
 173 static tree ffecom_tree_subr_type;
 174 static tree ffecom_tree_ptr_to_subr_type;
 175 static tree ffecom_tree_blockdata_type;
 176
 177 static 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 tree ffecom_f2c_ptr_to_integer_type_node;
 194 tree ffecom_f2c_address_type_node;
 195 tree ffecom_f2c_real_type_node;
 196 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 ffecom_arglist_expr_ (const char *argstring, ffebld args);
 268 static tree ffecom_widest_expr_type_ (ffebld list);
 269 static bool ffecom_overlap_ (tree dest_decl, tree dest_offset,
 270                              tree dest_size, tree source_tree,
 271                              ffebld source, bool scalar_arg);
 272 static bool ffecom_args_overlapping_ (tree dest_tree, ffebld dest,
 273                                       tree args, tree callee_commons,
 274                                       bool scalar_args);
 275 static tree ffecom_build_f2c_string_ (int i, const char *s);
 276 static tree ffecom_call_ (tree fn, ffeinfoKindtype kt,
 277                           bool is_f2c_complex, tree type,
 278                           tree args, tree dest_tree,
 279                           ffebld dest, bool *dest_used,
 280                           tree callee_commons, bool scalar_args, tree hook);
 281 static tree ffecom_call_binop_ (tree fn, ffeinfoKindtype kt,
 282                                 bool is_f2c_complex, tree type,
 283                                 ffebld left, ffebld right,
 284                                 tree dest_tree, ffebld dest,
 285                                 bool *dest_used, tree callee_commons,
 286                                 bool scalar_args, bool ref, tree hook);
 287 static void ffecom_char_args_x_ (tree *xitem, tree *length,
 288                                  ffebld expr, bool with_null);
 289 static tree ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy);
 290 static tree ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s);
 291 static ffecomConcatList_
 292   ffecom_concat_list_gather_ (ffecomConcatList_ catlist,
 293                               ffebld expr,
 294                               ffetargetCharacterSize max);
 295 static void ffecom_concat_list_kill_ (ffecomConcatList_ catlist);
 296 static ffecomConcatList_ ffecom_concat_list_new_ (ffebld expr,
 297                                                 ffetargetCharacterSize max);
 298 static void ffecom_debug_kludge_ (tree aggr, const char *aggr_type,
 299                                   ffesymbol member, tree member_type,
 300                                   ffetargetOffset offset);
 301 static void ffecom_do_entry_ (ffesymbol fn, int entrynum);
 302 static tree ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
 303                           bool *dest_used, bool assignp, bool widenp);
 304 static tree ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
 305                                     ffebld dest, bool *dest_used);
 306 static tree ffecom_expr_power_integer_ (ffebld expr);
 307 static void ffecom_expr_transform_ (ffebld expr);
 308 static void ffecom_f2c_make_type_ (tree *type, int tcode, const char *name);
 309 static void ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
 310                                       int code);
 311 static ffeglobal ffecom_finish_global_ (ffeglobal global);
 312 static ffesymbol ffecom_finish_symbol_transform_ (ffesymbol s);
 313 static tree ffecom_get_appended_identifier_ (char us, const char *text);
 314 static tree ffecom_get_external_identifier_ (ffesymbol s);
 315 static tree ffecom_get_identifier_ (const char *text);
 316 static tree ffecom_gen_sfuncdef_ (ffesymbol s,
 317                                   ffeinfoBasictype bt,
 318                                   ffeinfoKindtype kt);
 319 static const char *ffecom_gfrt_args_ (ffecomGfrt ix);
 320 static tree ffecom_gfrt_tree_ (ffecomGfrt ix);
 321 static tree ffecom_init_zero_ (tree decl);
 322 static tree ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
 323                                      tree *maybe_tree);
 324 static tree ffecom_intrinsic_len_ (ffebld expr);
 325 static void ffecom_let_char_ (tree dest_tree,
 326                               tree dest_length,
 327                               ffetargetCharacterSize dest_size,
 328                               ffebld source);
 329 static void ffecom_make_gfrt_ (ffecomGfrt ix);
 330 static void ffecom_member_phase1_ (ffestorag mst, ffestorag st);
 331 static void ffecom_member_phase2_ (ffestorag mst, ffestorag st);
 332 static void ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size,
 333                                       ffebld source);
 334 static void ffecom_push_dummy_decls_ (ffebld dumlist,
 335                                       bool stmtfunc);
 336 static void ffecom_start_progunit_ (void);
 337 static ffesymbol ffecom_sym_transform_ (ffesymbol s);
 338 static ffesymbol ffecom_sym_transform_assign_ (ffesymbol s);
 339 static void ffecom_transform_common_ (ffesymbol s);
 340 static void ffecom_transform_equiv_ (ffestorag st);
 341 static tree ffecom_transform_namelist_ (ffesymbol s);
 342 static void ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
 343                                        tree t);
 344 static void ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
 345                                        tree *size, tree tree);
 346 static tree ffecom_tree_divide_ (tree tree_type, tree left, tree right,
 347                                  tree dest_tree, ffebld dest,
 348                                  bool *dest_used, tree hook);
 349 static tree ffecom_type_localvar_ (ffesymbol s,
 350                                    ffeinfoBasictype bt,
 351                                    ffeinfoKindtype kt);
 352 static tree ffecom_type_namelist_ (void);
 353 static tree ffecom_type_vardesc_ (void);
 354 static tree ffecom_vardesc_ (ffebld expr);
 355 static tree ffecom_vardesc_array_ (ffesymbol s);
 356 static tree ffecom_vardesc_dims_ (ffesymbol s);
 357 static tree ffecom_convert_narrow_ (tree type, tree expr);
 358 static tree ffecom_convert_widen_ (tree type, tree expr);
 359
 360 /* These are static functions that parallel those found in the C front
 361    end and thus have the same names.  */
 362
 363 static tree bison_rule_compstmt_ (void);
 364 static void bison_rule_pushlevel_ (void);
 365 static void delete_block (tree block);
 366 static int duplicate_decls (tree newdecl, tree olddecl);
 367 static void finish_decl (tree decl, tree init, bool is_top_level);
 368 static void finish_function (int nested);
 369 static const char *lang_printable_name (tree decl, int v);
 370 static tree lookup_name_current_level (tree name);
 371 static struct binding_level *make_binding_level (void);
 372 static void pop_f_function_context (void);
 373 static void push_f_function_context (void);
 374 static void push_parm_decl (tree parm);
 375 static tree pushdecl_top_level (tree decl);
 376 static int kept_level_p (void);
 377 static tree storedecls (tree decls);
 378 static void store_parm_decls (int is_main_program);
 379 static tree start_decl (tree decl, bool is_top_level);
 380 static void start_function (tree name, tree type, int nested, int public);
 381 static void ffecom_file_ (const char *name);
 382 static void ffecom_initialize_char_syntax_ (void);
 383 static void ffecom_close_include_ (FILE *f);
 384 static int ffecom_decode_include_option_ (char *spec);
 385 static FILE *ffecom_open_include_ (char *name, ffewhereLine l,
 386                                    ffewhereColumn c);
 387
 388 /* Static objects accessed by functions in this module. */
 389
 390 static ffesymbol ffecom_primary_entry_ = NULL;
 391 static ffesymbol ffecom_nested_entry_ = NULL;
 392 static ffeinfoKind ffecom_primary_entry_kind_;
 393 static bool ffecom_primary_entry_is_proc_;
 394 static tree ffecom_outer_function_decl_;
 395 static tree ffecom_previous_function_decl_;
 396 static tree ffecom_which_entrypoint_decl_;
 397 static tree ffecom_float_zero_ = NULL_TREE;
 398 static tree ffecom_float_half_ = NULL_TREE;
 399 static tree ffecom_double_zero_ = NULL_TREE;
 400 static tree ffecom_double_half_ = NULL_TREE;
 401 static tree ffecom_func_result_;/* For functions. */
 402 static tree ffecom_func_length_;/* For CHARACTER fns. */
 403 static ffebld ffecom_list_blockdata_;
 404 static ffebld ffecom_list_common_;
 405 static ffebld ffecom_master_arglist_;
 406 static ffeinfoBasictype ffecom_master_bt_;
 407 static ffeinfoKindtype ffecom_master_kt_;
 408 static ffetargetCharacterSize ffecom_master_size_;
 409 static int ffecom_num_fns_ = 0;
 410 static int ffecom_num_entrypoints_ = 0;
 411 static bool ffecom_is_altreturning_ = FALSE;
 412 static tree ffecom_multi_type_node_;
 413 static tree ffecom_multi_retval_;
 414 static tree
 415   ffecom_multi_fields_[FFEINFO_basictype][FFEINFO_kindtype];
 416 static bool ffecom_member_namelisted_;  /* _member_phase1_ namelisted? */
 417 static bool ffecom_doing_entry_ = FALSE;
 418 static bool ffecom_transform_only_dummies_ = FALSE;
 419 static int ffecom_typesize_pointer_;
 420 static int ffecom_typesize_integer1_;
 421
 422 /* Holds pointer-to-function expressions.  */
 423
 424 static tree ffecom_gfrt_[FFECOM_gfrt]
 425 =
 426 {
 427 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NULL_TREE,
 428 #include "com-rt.def"
 429 #undef DEFGFRT
 430 };
 431
 432 /* Holds the external names of the functions.  */
 433
 434 static const char *const ffecom_gfrt_name_[FFECOM_gfrt]
 435 =
 436 {
 437 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NAME,
 438 #include "com-rt.def"
 439 #undef DEFGFRT
 440 };
 441
 442 /* Whether the function returns.  */
 443
 444 static bool ffecom_gfrt_volatile_[FFECOM_gfrt]
 445 =
 446 {
 447 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) VOLATILE,
 448 #include "com-rt.def"
 449 #undef DEFGFRT
 450 };
 451
 452 /* Whether the function returns type complex.  */
 453
 454 static bool ffecom_gfrt_complex_[FFECOM_gfrt]
 455 =
 456 {
 457 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) COMPLEX,
 458 #include "com-rt.def"
 459 #undef DEFGFRT
 460 };
 461
 462 /* Whether the function is const
 463    (i.e., has no side effects and only depends on its arguments).  */
 464
 465 static bool ffecom_gfrt_const_[FFECOM_gfrt]
 466 =
 467 {
 468 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) CONST,
 469 #include "com-rt.def"
 470 #undef DEFGFRT
 471 };
 472
 473 /* Type code for the function return value.  */
 474
 475 static ffecomRttype_ ffecom_gfrt_type_[FFECOM_gfrt]
 476 =
 477 {
 478 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) TYPE,
 479 #include "com-rt.def"
 480 #undef DEFGFRT
 481 };
 482
 483 /* String of codes for the function's arguments.  */
 484
 485 static const char *const ffecom_gfrt_argstring_[FFECOM_gfrt]
 486 =
 487 {
 488 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) ARGS,
 489 #include "com-rt.def"
 490 #undef DEFGFRT
 491 };
 492
 493 /* Internal macros. */
 494
 495 /* We let tm.h override the types used here, to handle trivial differences
 496    such as the choice of unsigned int or long unsigned int for size_t.
 497    When machines start needing nontrivial differences in the size type,
 498    it would be best to do something here to figure out automatically
 499    from other information what type to use.  */
 500
 501 #ifndef SIZE_TYPE
 502 #define SIZE_TYPE "long unsigned int"
 503 #endif
 504
 505 #define ffecom_concat_list_count_(catlist) ((catlist).count)
 506 #define ffecom_concat_list_expr_(catlist,i) ((catlist).exprs[(i)])
 507 #define ffecom_concat_list_maxlen_(catlist) ((catlist).maxlen)
 508 #define ffecom_concat_list_minlen_(catlist) ((catlist).minlen)
 509
 510 #define ffecom_char_args_(i,l,e) ffecom_char_args_x_((i),(l),(e),FALSE)
 511 #define ffecom_char_args_with_null_(i,l,e) ffecom_char_args_x_((i),(l),(e),TRUE)
 512
 513 /* For each binding contour we allocate a binding_level structure
 514  * which records the names defined in that contour.
 515  * Contours include:
 516  *  0) the global one
 517  *  1) one for each function definition,
 518  *     where internal declarations of the parameters appear.
 519  *
 520  * The current meaning of a name can be found by searching the levels from
 521  * the current one out to the global one.
 522  */
 523
 524 /* Note that the information in the `names' component of the global contour
 525    is duplicated in the IDENTIFIER_GLOBAL_VALUEs of all identifiers.  */
 526
 527 struct binding_level
 528   {
 529     /* A chain of _DECL nodes for all variables, constants, functions,
 530        and typedef types.  These are in the reverse of the order supplied.
 531      */
 532     tree names;
 533
 534     /* For each level (except not the global one),
 535        a chain of BLOCK nodes for all the levels
 536        that were entered and exited one level down.  */
 537     tree blocks;
 538
 539     /* The BLOCK node for this level, if one has been preallocated.
 540        If 0, the BLOCK is allocated (if needed) when the level is popped.  */
 541     tree this_block;
 542
 543     /* The binding level which this one is contained in (inherits from).  */
 544     struct binding_level *level_chain;
 545
 546     /* 0: no ffecom_prepare_* functions called at this level yet;
 547        1: ffecom_prepare* functions called, except not ffecom_prepare_end;
 548        2: ffecom_prepare_end called.  */
 549     int prep_state;
 550   };
 551
 552 #define NULL_BINDING_LEVEL (struct binding_level *) NULL
 553
 554 /* The binding level currently in effect.  */
 555
 556 static struct binding_level *current_binding_level;
 557
 558 /* A chain of binding_level structures awaiting reuse.  */
 559
 560 static struct binding_level *free_binding_level;
 561
 562 /* The outermost binding level, for names of file scope.
 563    This is created when the compiler is started and exists
 564    through the entire run.  */
 565
 566 static struct binding_level *global_binding_level;
 567
 568 /* Binding level structures are initialized by copying this one.  */
 569
 570 static struct binding_level clear_binding_level
 571 =
 572 {NULL, NULL, NULL, NULL_BINDING_LEVEL, 0};
 573
 574 /* Language-dependent contents of an identifier.  */
 575
 576 struct lang_identifier
 577   {
 578     struct tree_identifier ignore;
 579     tree global_value, local_value, label_value;
 580     bool invented;
 581   };
 582
 583 /* Macros for access to language-specific slots in an identifier.  */
 584 /* Each of these slots contains a DECL node or null.  */
 585
 586 /* This represents the value which the identifier has in the
 587    file-scope namespace.  */
 588 #define IDENTIFIER_GLOBAL_VALUE(NODE)   \
 589   (((struct lang_identifier *)(NODE))->global_value)
 590 /* This represents the value which the identifier has in the current
 591    scope.  */
 592 #define IDENTIFIER_LOCAL_VALUE(NODE)    \
 593   (((struct lang_identifier *)(NODE))->local_value)
 594 /* This represents the value which the identifier has as a label in
 595    the current label scope.  */
 596 #define IDENTIFIER_LABEL_VALUE(NODE)    \
 597   (((struct lang_identifier *)(NODE))->label_value)
 598 /* This is nonzero if the identifier was "made up" by g77 code.  */
 599 #define IDENTIFIER_INVENTED(NODE)       \
 600   (((struct lang_identifier *)(NODE))->invented)
 601
 602 /* In identifiers, C uses the following fields in a special way:
 603    TREE_PUBLIC        to record that there was a previous local extern decl.
 604    TREE_USED          to record that such a decl was used.
 605    TREE_ADDRESSABLE   to record that the address of such a decl was used.  */
 606
 607 /* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function
 608    that have names.  Here so we can clear out their names' definitions
 609    at the end of the function.  */
 610
 611 static tree named_labels;
 612
 613 /* A list of LABEL_DECLs from outer contexts that are currently shadowed.  */
 614
 615 static tree shadowed_labels;
 616 \f
 617 /* Return the subscript expression, modified to do range-checking.
 618
 619    `array' is the array to be checked against.
 620    `element' is the subscript expression to check.
 621    `dim' is the dimension number (starting at 0).
 622    `total_dims' is the total number of dimensions (0 for CHARACTER substring).
 623 */
 624
 625 static tree
 626 ffecom_subscript_check_ (tree array, tree element, int dim, int total_dims,
 627                          const char *array_name)
 628 {
 629   tree low = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
 630   tree high = TYPE_MAX_VALUE (TYPE_DOMAIN (array));
 631   tree cond;
 632   tree die;
 633   tree args;
 634
 635   if (element == error_mark_node)
 636     return element;
 637
 638   if (TREE_TYPE (low) != TREE_TYPE (element))
 639     {
 640       if (TYPE_PRECISION (TREE_TYPE (low))
 641           > TYPE_PRECISION (TREE_TYPE (element)))
 642         element = convert (TREE_TYPE (low), element);
 643       else
 644         {
 645           low = convert (TREE_TYPE (element), low);
 646           if (high)
 647             high = convert (TREE_TYPE (element), high);
 648         }
 649     }
 650
 651   element = ffecom_save_tree (element);
 652   if (total_dims == 0)
 653     {
 654       /* Special handling for substring range checks.  Fortran allows the
 655          end subscript < begin subscript, which means that expressions like
 656        string(1:0) are valid (and yield a null string).  In view of this,
 657        enforce two simpler conditions:
 658           1) element<=high for end-substring;
 659           2) element>=low for start-substring.
 660        Run-time character movement will enforce remaining conditions.
 661
 662        More complicated checks would be better, but present structure only
 663        provides one index element at a time, so it is not possible to
 664        enforce a check of both i and j in string(i:j).  If it were, the
 665        complete set of rules would read,
 666          if ( ((j<i) && ((low<=i<=high) || (low<=j<=high))) ||
 667               ((low<=i<=high) && (low<=j<=high)) )
 668            ok ;
 669          else
 670            range error ;
 671       */
 672       if (dim)
 673         cond = ffecom_2 (LE_EXPR, integer_type_node, element, high);
 674       else
 675         cond = ffecom_2 (LE_EXPR, integer_type_node, low, element);
 676     }
 677   else
 678     {
 679       /* Array reference substring range checking.  */
 680
 681       cond = ffecom_2 (LE_EXPR, integer_type_node,
 682                      low,
 683                      element);
 684       if (high)
 685         {
 686           cond = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
 687                          cond,
 688                          ffecom_2 (LE_EXPR, integer_type_node,
 689                                    element,
 690                                    high));
 691         }
 692     }
 693
 694   {
 695     int len;
 696     char *proc;
 697     char *var;
 698     tree arg3;
 699     tree arg2;
 700     tree arg1;
 701     tree arg4;
 702
 703     switch (total_dims)
 704       {
 705       case 0:
 706         var = concat (array_name, "[", (dim ? "end" : "start"),
 707                       "-substring]", NULL);
 708         len = strlen (var) + 1;
 709         arg1 = build_string (len, var);
 710         free (var);
 711         break;
 712
 713       case 1:
 714         len = strlen (array_name) + 1;
 715         arg1 = build_string (len, array_name);
 716         break;
 717
 718       default:
 719         var = xmalloc (strlen (array_name) + 40);
 720         sprintf (var, "%s[subscript-%d-of-%d]",
 721                  array_name,
 722                  dim + 1, total_dims);
 723         len = strlen (var) + 1;
 724         arg1 = build_string (len, var);
 725         free (var);
 726         break;
 727       }
 728
 729     TREE_TYPE (arg1)
 730       = build_type_variant (build_array_type (char_type_node,
 731                                               build_range_type
 732                                               (integer_type_node,
 733                                                integer_one_node,
 734                                                build_int_2 (len, 0))),
 735                             1, 0);
 736     TREE_CONSTANT (arg1) = 1;
 737     TREE_STATIC (arg1) = 1;
 738     arg1 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg1)),
 739                      arg1);
 740
 741     /* s_rnge adds one to the element to print it, so bias against
 742        that -- want to print a faithful *subscript* value.  */
 743     arg2 = convert (ffecom_f2c_ftnint_type_node,
 744                     ffecom_2 (MINUS_EXPR,
 745                               TREE_TYPE (element),
 746                               element,
 747                               convert (TREE_TYPE (element),
 748                                        integer_one_node)));
 749
 750     proc = concat (input_filename, "/",
 751                    IDENTIFIER_POINTER (DECL_NAME (current_function_decl)),
 752                    NULL);
 753     len = strlen (proc) + 1;
 754     arg3 = build_string (len, proc);
 755
 756     free (proc);
 757
 758     TREE_TYPE (arg3)
 759       = build_type_variant (build_array_type (char_type_node,
 760                                               build_range_type
 761                                               (integer_type_node,
 762                                                integer_one_node,
 763                                                build_int_2 (len, 0))),
 764                             1, 0);
 765     TREE_CONSTANT (arg3) = 1;
 766     TREE_STATIC (arg3) = 1;
 767     arg3 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg3)),
 768                      arg3);
 769
 770     arg4 = convert (ffecom_f2c_ftnint_type_node,
 771                     build_int_2 (lineno, 0));
 772
 773     arg1 = build_tree_list (NULL_TREE, arg1);
 774     arg2 = build_tree_list (NULL_TREE, arg2);
 775     arg3 = build_tree_list (NULL_TREE, arg3);
 776     arg4 = build_tree_list (NULL_TREE, arg4);
 777     TREE_CHAIN (arg3) = arg4;
 778     TREE_CHAIN (arg2) = arg3;
 779     TREE_CHAIN (arg1) = arg2;
 780
 781     args = arg1;
 782   }
 783   die = ffecom_call_gfrt (FFECOM_gfrtRANGE,
 784                           args, NULL_TREE);
 785   TREE_SIDE_EFFECTS (die) = 1;
 786
 787   element = ffecom_3 (COND_EXPR,
 788                       TREE_TYPE (element),
 789                       cond,
 790                       element,
 791                       die);
 792
 793   return element;
 794 }
 795
 796 /* Return the computed element of an array reference.
 797
 798    `item' is NULL_TREE, or the transformed pointer to the array.
 799    `expr' is the original opARRAYREF expression, which is transformed
 800      if `item' is NULL_TREE.
 801    `want_ptr' is non-zero if a pointer to the element, instead of
 802      the element itself, is to be returned.  */
 803
 804 static tree
 805 ffecom_arrayref_ (tree item, ffebld expr, int want_ptr)
 806 {
 807   ffebld dims[FFECOM_dimensionsMAX];
 808   int i;
 809   int total_dims;
 810   int flatten = ffe_is_flatten_arrays ();
 811   int need_ptr;
 812   tree array;
 813   tree element;
 814   tree tree_type;
 815   tree tree_type_x;
 816   const char *array_name;
 817   ffetype type;
 818   ffebld list;
 819
 820   if (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER)
 821     array_name = ffesymbol_text (ffebld_symter (ffebld_left (expr)));
 822   else
 823     array_name = "[expr?]";
 824
 825   /* Build up ARRAY_REFs in reverse order (since we're column major
 826      here in Fortran land). */
 827
 828   for (i = 0, list = ffebld_right (expr);
 829        list != NULL;
 830        ++i, list = ffebld_trail (list))
 831     {
 832       dims[i] = ffebld_head (list);
 833       type = ffeinfo_type (ffebld_basictype (dims[i]),
 834                            ffebld_kindtype (dims[i]));
 835       if (! flatten
 836           && ffecom_typesize_pointer_ > ffecom_typesize_integer1_
 837           && ffetype_size (type) > ffecom_typesize_integer1_)
 838         /* E.g. ARRAY(INDEX), given INTEGER*8 INDEX, on a system with 64-bit
 839            pointers and 32-bit integers.  Do the full 64-bit pointer
 840            arithmetic, for codes using arrays for nonstandard heap-like
 841            work.  */
 842         flatten = 1;
 843     }
 844
 845   total_dims = i;
 846
 847   need_ptr = want_ptr || flatten;
 848
 849   if (! item)
 850     {
 851       if (need_ptr)
 852         item = ffecom_ptr_to_expr (ffebld_left (expr));
 853       else
 854         item = ffecom_expr (ffebld_left (expr));
 855
 856       if (item == error_mark_node)
 857         return item;
 858
 859       if (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereFLEETING
 860           && ! mark_addressable (item))
 861         return error_mark_node;
 862     }
 863
 864   if (item == error_mark_node)
 865     return item;
 866
 867   if (need_ptr)
 868     {
 869       tree min;
 870
 871       for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
 872            i >= 0;
 873            --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array)))
 874         {
 875           min = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
 876           element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
 877           if (flag_bounds_check)
 878             element = ffecom_subscript_check_ (array, element, i, total_dims,
 879                                                array_name);
 880           if (element == error_mark_node)
 881             return element;
 882
 883           /* Widen integral arithmetic as desired while preserving
 884              signedness.  */
 885           tree_type = TREE_TYPE (element);
 886           tree_type_x = tree_type;
 887           if (tree_type
 888               && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
 889               && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
 890             tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
 891
 892           if (TREE_TYPE (min) != tree_type_x)
 893             min = convert (tree_type_x, min);
 894           if (TREE_TYPE (element) != tree_type_x)
 895             element = convert (tree_type_x, element);
 896
 897           item = ffecom_2 (PLUS_EXPR,
 898                            build_pointer_type (TREE_TYPE (array)),
 899                            item,
 900                            size_binop (MULT_EXPR,
 901                                        size_in_bytes (TREE_TYPE (array)),
 902                                        convert (sizetype,
 903                                                 fold (build (MINUS_EXPR,
 904                                                              tree_type_x,
 905                                                              element, min)))));
 906         }
 907       if (! want_ptr)
 908         {
 909           item = ffecom_1 (INDIRECT_REF,
 910                            TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
 911                            item);
 912         }
 913     }
 914   else
 915     {
 916       for (--i;
 917            i >= 0;
 918            --i)
 919         {
 920           array = TYPE_MAIN_VARIANT (TREE_TYPE (item));
 921
 922           element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
 923           if (flag_bounds_check)
 924             element = ffecom_subscript_check_ (array, element, i, total_dims,
 925                                                array_name);
 926           if (element == error_mark_node)
 927             return element;
 928
 929           /* Widen integral arithmetic as desired while preserving
 930              signedness.  */
 931           tree_type = TREE_TYPE (element);
 932           tree_type_x = tree_type;
 933           if (tree_type
 934               && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
 935               && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
 936             tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
 937
 938           element = convert (tree_type_x, element);
 939
 940           item = ffecom_2 (ARRAY_REF,
 941                            TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
 942                            item,
 943                            element);
 944         }
 945     }
 946
 947   return item;
 948 }
 949
 950 /* This is like gcc's stabilize_reference -- in fact, most of the code
 951    comes from that -- but it handles the situation where the reference
 952    is going to have its subparts picked at, and it shouldn't change
 953    (or trigger extra invocations of functions in the subtrees) due to
 954    this.  save_expr is a bit overzealous, because we don't need the
 955    entire thing calculated and saved like a temp.  So, for DECLs, no
 956    change is needed, because these are stable aggregates, and ARRAY_REF
 957    and such might well be stable too, but for things like calculations,
 958    we do need to calculate a snapshot of a value before picking at it.  */
 959
 960 static tree
 961 ffecom_stabilize_aggregate_ (tree ref)
 962 {
 963   tree result;
 964   enum tree_code code = TREE_CODE (ref);
 965
 966   switch (code)
 967     {
 968     case VAR_DECL:
 969     case PARM_DECL:
 970     case RESULT_DECL:
 971       /* No action is needed in this case.  */
 972       return ref;
 973
 974     case NOP_EXPR:
 975     case CONVERT_EXPR:
 976     case FLOAT_EXPR:
 977     case FIX_TRUNC_EXPR:
 978     case FIX_FLOOR_EXPR:
 979     case FIX_ROUND_EXPR:
 980     case FIX_CEIL_EXPR:
 981       result = build_nt (code, stabilize_reference (TREE_OPERAND (ref, 0)));
 982       break;
 983
 984     case INDIRECT_REF:
 985       result = build_nt (INDIRECT_REF,
 986                          stabilize_reference_1 (TREE_OPERAND (ref, 0)));
 987       break;
 988
 989     case COMPONENT_REF:
 990       result = build_nt (COMPONENT_REF,
 991                          stabilize_reference (TREE_OPERAND (ref, 0)),
 992                          TREE_OPERAND (ref, 1));
 993       break;
 994
 995     case BIT_FIELD_REF:
 996       result = build_nt (BIT_FIELD_REF,
 997                          stabilize_reference (TREE_OPERAND (ref, 0)),
 998                          stabilize_reference_1 (TREE_OPERAND (ref, 1)),
 999                          stabilize_reference_1 (TREE_OPERAND (ref, 2)));
1000       break;
1001
1002     case ARRAY_REF:
1003       result = build_nt (ARRAY_REF,
1004                          stabilize_reference (TREE_OPERAND (ref, 0)),
1005                          stabilize_reference_1 (TREE_OPERAND (ref, 1)));
1006       break;
1007
1008     case COMPOUND_EXPR:
1009       result = build_nt (COMPOUND_EXPR,
1010                          stabilize_reference_1 (TREE_OPERAND (ref, 0)),
1011                          stabilize_reference (TREE_OPERAND (ref, 1)));
1012       break;
1013
1014     case RTL_EXPR:
1015       abort ();
1016
1017
1018     default:
1019       return save_expr (ref);
1020
1021     case ERROR_MARK:
1022       return error_mark_node;
1023     }
1024
1025   TREE_TYPE (result) = TREE_TYPE (ref);
1026   TREE_READONLY (result) = TREE_READONLY (ref);
1027   TREE_SIDE_EFFECTS (result) = TREE_SIDE_EFFECTS (ref);
1028   TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref);
1029
1030   return result;
1031 }
1032
1033 /* A rip-off of gcc's convert.c convert_to_complex function,
1034    reworked to handle complex implemented as C structures
1035    (RECORD_TYPE with two fields, real and imaginary `r' and `i').  */
1036
1037 static tree
1038 ffecom_convert_to_complex_ (tree type, tree expr)
1039 {
1040   register enum tree_code form = TREE_CODE (TREE_TYPE (expr));
1041   tree subtype;
1042
1043   assert (TREE_CODE (type) == RECORD_TYPE);
1044
1045   subtype = TREE_TYPE (TYPE_FIELDS (type));
1046
1047   if (form == REAL_TYPE || form == INTEGER_TYPE || form == ENUMERAL_TYPE)
1048     {
1049       expr = convert (subtype, expr);
1050       return ffecom_2 (COMPLEX_EXPR, type, expr,
1051                        convert (subtype, integer_zero_node));
1052     }
1053
1054   if (form == RECORD_TYPE)
1055     {
1056       tree elt_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr)));
1057       if (TYPE_MAIN_VARIANT (elt_type) == TYPE_MAIN_VARIANT (subtype))
1058         return expr;
1059       else
1060         {
1061           expr = save_expr (expr);
1062           return ffecom_2 (COMPLEX_EXPR,
1063                            type,
1064                            convert (subtype,
1065                                     ffecom_1 (REALPART_EXPR,
1066                                               TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1067                                               expr)),
1068                            convert (subtype,
1069                                     ffecom_1 (IMAGPART_EXPR,
1070                                               TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1071                                               expr)));
1072         }
1073     }
1074
1075   if (form == POINTER_TYPE || form == REFERENCE_TYPE)
1076     error ("pointer value used where a complex was expected");
1077   else
1078     error ("aggregate value used where a complex was expected");
1079
1080   return ffecom_2 (COMPLEX_EXPR, type,
1081                    convert (subtype, integer_zero_node),
1082                    convert (subtype, integer_zero_node));
1083 }
1084
1085 /* Like gcc's convert(), but crashes if widening might happen.  */
1086
1087 static tree
1088 ffecom_convert_narrow_ (type, expr)
1089      tree type, expr;
1090 {
1091   register tree e = expr;
1092   register enum tree_code code = TREE_CODE (type);
1093
1094   if (type == TREE_TYPE (e)
1095       || TREE_CODE (e) == ERROR_MARK)
1096     return e;
1097   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1098     return fold (build1 (NOP_EXPR, type, e));
1099   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1100       || code == ERROR_MARK)
1101     return error_mark_node;
1102   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1103     {
1104       assert ("void value not ignored as it ought to be" == NULL);
1105       return error_mark_node;
1106     }
1107   assert (code != VOID_TYPE);
1108   if ((code != RECORD_TYPE)
1109       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1110     assert ("converting COMPLEX to REAL" == NULL);
1111   assert (code != ENUMERAL_TYPE);
1112   if (code == INTEGER_TYPE)
1113     {
1114       assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1115                && TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)))
1116               || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1117                   && (TYPE_PRECISION (type)
1118                       == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1119       return fold (convert_to_integer (type, e));
1120     }
1121   if (code == POINTER_TYPE)
1122     {
1123       assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1124       return fold (convert_to_pointer (type, e));
1125     }
1126   if (code == REAL_TYPE)
1127     {
1128       assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1129       assert (TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)));
1130       return fold (convert_to_real (type, e));
1131     }
1132   if (code == COMPLEX_TYPE)
1133     {
1134       assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1135       assert (TYPE_PRECISION (TREE_TYPE (type)) <= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1136       return fold (convert_to_complex (type, e));
1137     }
1138   if (code == RECORD_TYPE)
1139     {
1140       assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1141       /* Check that at least the first field name agrees.  */
1142       assert (DECL_NAME (TYPE_FIELDS (type))
1143               == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1144       assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1145               <= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1146       if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1147           == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1148         return e;
1149       return fold (ffecom_convert_to_complex_ (type, e));
1150     }
1151
1152   assert ("conversion to non-scalar type requested" == NULL);
1153   return error_mark_node;
1154 }
1155
1156 /* Like gcc's convert(), but crashes if narrowing might happen.  */
1157
1158 static tree
1159 ffecom_convert_widen_ (type, expr)
1160      tree type, expr;
1161 {
1162   register tree e = expr;
1163   register enum tree_code code = TREE_CODE (type);
1164
1165   if (type == TREE_TYPE (e)
1166       || TREE_CODE (e) == ERROR_MARK)
1167     return e;
1168   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1169     return fold (build1 (NOP_EXPR, type, e));
1170   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1171       || code == ERROR_MARK)
1172     return error_mark_node;
1173   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1174     {
1175       assert ("void value not ignored as it ought to be" == NULL);
1176       return error_mark_node;
1177     }
1178   assert (code != VOID_TYPE);
1179   if ((code != RECORD_TYPE)
1180       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1181     assert ("narrowing COMPLEX to REAL" == NULL);
1182   assert (code != ENUMERAL_TYPE);
1183   if (code == INTEGER_TYPE)
1184     {
1185       assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1186                && TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)))
1187               || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1188                   && (TYPE_PRECISION (type)
1189                       == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1190       return fold (convert_to_integer (type, e));
1191     }
1192   if (code == POINTER_TYPE)
1193     {
1194       assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1195       return fold (convert_to_pointer (type, e));
1196     }
1197   if (code == REAL_TYPE)
1198     {
1199       assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1200       assert (TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)));
1201       return fold (convert_to_real (type, e));
1202     }
1203   if (code == COMPLEX_TYPE)
1204     {
1205       assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1206       assert (TYPE_PRECISION (TREE_TYPE (type)) >= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1207       return fold (convert_to_complex (type, e));
1208     }
1209   if (code == RECORD_TYPE)
1210     {
1211       assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1212       /* Check that at least the first field name agrees.  */
1213       assert (DECL_NAME (TYPE_FIELDS (type))
1214               == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1215       assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1216               >= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1217       if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1218           == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1219         return e;
1220       return fold (ffecom_convert_to_complex_ (type, e));
1221     }
1222
1223   assert ("conversion to non-scalar type requested" == NULL);
1224   return error_mark_node;
1225 }
1226
1227 /* Handles making a COMPLEX type, either the standard
1228    (but buggy?) gbe way, or the safer (but less elegant?)
1229    f2c way.  */
1230
1231 static tree
1232 ffecom_make_complex_type_ (tree subtype)
1233 {
1234   tree type;
1235   tree realfield;
1236   tree imagfield;
1237
1238   if (ffe_is_emulate_complex ())
1239     {
1240       type = make_node (RECORD_TYPE);
1241       realfield = ffecom_decl_field (type, NULL_TREE, "r", subtype);
1242       imagfield = ffecom_decl_field (type, realfield, "i", subtype);
1243       TYPE_FIELDS (type) = realfield;
1244       layout_type (type);
1245     }
1246   else
1247     {
1248       type = make_node (COMPLEX_TYPE);
1249       TREE_TYPE (type) = subtype;
1250       layout_type (type);
1251     }
1252
1253   return type;
1254 }
1255
1256 /* Chooses either the gbe or the f2c way to build a
1257    complex constant.  */
1258
1259 static tree
1260 ffecom_build_complex_constant_ (tree type, tree realpart, tree imagpart)
1261 {
1262   tree bothparts;
1263
1264   if (ffe_is_emulate_complex ())
1265     {
1266       bothparts = build_tree_list (TYPE_FIELDS (type), realpart);
1267       TREE_CHAIN (bothparts) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), imagpart);
1268       bothparts = build (CONSTRUCTOR, type, NULL_TREE, bothparts);
1269     }
1270   else
1271     {
1272       bothparts = build_complex (type, realpart, imagpart);
1273     }
1274
1275   return bothparts;
1276 }
1277
1278 static tree
1279 ffecom_arglist_expr_ (const char *c, ffebld expr)
1280 {
1281   tree list;
1282   tree *plist = &list;
1283   tree trail = NULL_TREE;       /* Append char length args here. */
1284   tree *ptrail = &trail;
1285   tree length;
1286   ffebld exprh;
1287   tree item;
1288   bool ptr = FALSE;
1289   tree wanted = NULL_TREE;
1290   static char zed[] = "0";
1291
1292   if (c == NULL)
1293     c = &zed[0];
1294
1295   while (expr != NULL)
1296     {
1297       if (*c != '\0')
1298         {
1299           ptr = FALSE;
1300           if (*c == '&')
1301             {
1302               ptr = TRUE;
1303               ++c;
1304             }
1305           switch (*(c++))
1306             {
1307             case '\0':
1308               ptr = TRUE;
1309               wanted = NULL_TREE;
1310               break;
1311
1312             case 'a':
1313               assert (ptr);
1314               wanted = NULL_TREE;
1315               break;
1316
1317             case 'c':
1318               wanted = ffecom_f2c_complex_type_node;
1319               break;
1320
1321             case 'd':
1322               wanted = ffecom_f2c_doublereal_type_node;
1323               break;
1324
1325             case 'e':
1326               wanted = ffecom_f2c_doublecomplex_type_node;
1327               break;
1328
1329             case 'f':
1330               wanted = ffecom_f2c_real_type_node;
1331               break;
1332
1333             case 'i':
1334               wanted = ffecom_f2c_integer_type_node;
1335               break;
1336
1337             case 'j':
1338               wanted = ffecom_f2c_longint_type_node;
1339               break;
1340
1341             default:
1342               assert ("bad argstring code" == NULL);
1343               wanted = NULL_TREE;
1344               break;
1345             }
1346         }
1347
1348       exprh = ffebld_head (expr);
1349       if (exprh == NULL)
1350         wanted = NULL_TREE;
1351
1352       if ((wanted == NULL_TREE)
1353           || (ptr
1354               && (TYPE_MODE
1355                   (ffecom_tree_type[ffeinfo_basictype (ffebld_info (exprh))]
1356                    [ffeinfo_kindtype (ffebld_info (exprh))])
1357                    == TYPE_MODE (wanted))))
1358         *plist
1359           = build_tree_list (NULL_TREE,
1360                              ffecom_arg_ptr_to_expr (exprh,
1361                                                      &length));
1362       else
1363         {
1364           item = ffecom_arg_expr (exprh, &length);
1365           item = ffecom_convert_widen_ (wanted, item);
1366           if (ptr)
1367             {
1368               item = ffecom_1 (ADDR_EXPR,
1369                                build_pointer_type (TREE_TYPE (item)),
1370                                item);
1371             }
1372           *plist
1373             = build_tree_list (NULL_TREE,
1374                                item);
1375         }
1376
1377       plist = &TREE_CHAIN (*plist);
1378       expr = ffebld_trail (expr);
1379       if (length != NULL_TREE)
1380         {
1381           *ptrail = build_tree_list (NULL_TREE, length);
1382           ptrail = &TREE_CHAIN (*ptrail);
1383         }
1384     }
1385
1386   /* We've run out of args in the call; if the implementation expects
1387      more, supply null pointers for them, which the implementation can
1388      check to see if an arg was omitted. */
1389
1390   while (*c != '\0' && *c != '0')
1391     {
1392       if (*c == '&')
1393         ++c;
1394       else
1395         assert ("missing arg to run-time routine!" == NULL);
1396
1397       switch (*(c++))
1398         {
1399         case '\0':
1400         case 'a':
1401         case 'c':
1402         case 'd':
1403         case 'e':
1404         case 'f':
1405         case 'i':
1406         case 'j':
1407           break;
1408
1409         default:
1410           assert ("bad arg string code" == NULL);
1411           break;
1412         }
1413       *plist
1414         = build_tree_list (NULL_TREE,
1415                            null_pointer_node);
1416       plist = &TREE_CHAIN (*plist);
1417     }
1418
1419   *plist = trail;
1420
1421   return list;
1422 }
1423
1424 static tree
1425 ffecom_widest_expr_type_ (ffebld list)
1426 {
1427   ffebld item;
1428   ffebld widest = NULL;
1429   ffetype type;
1430   ffetype widest_type = NULL;
1431   tree t;
1432
1433   for (; list != NULL; list = ffebld_trail (list))
1434     {
1435       item = ffebld_head (list);
1436       if (item == NULL)
1437         continue;
1438       if ((widest != NULL)
1439           && (ffeinfo_basictype (ffebld_info (item))
1440               != ffeinfo_basictype (ffebld_info (widest))))
1441         continue;
1442       type = ffeinfo_type (ffeinfo_basictype (ffebld_info (item)),
1443                            ffeinfo_kindtype (ffebld_info (item)));
1444       if ((widest == FFEINFO_kindtypeNONE)
1445           || (ffetype_size (type)
1446               > ffetype_size (widest_type)))
1447         {
1448           widest = item;
1449           widest_type = type;
1450         }
1451     }
1452
1453   assert (widest != NULL);
1454   t = ffecom_tree_type[ffeinfo_basictype (ffebld_info (widest))]
1455     [ffeinfo_kindtype (ffebld_info (widest))];
1456   assert (t != NULL_TREE);
1457   return t;
1458 }
1459
1460 /* Check whether a partial overlap between two expressions is possible.
1461
1462    Can *starting* to write a portion of expr1 change the value
1463    computed (perhaps already, *partially*) by expr2?
1464
1465    Currently, this is a concern only for a COMPLEX expr1.  But if it
1466    isn't in COMMON or local EQUIVALENCE, since we don't support
1467    aliasing of arguments, it isn't a concern.  */
1468
1469 static bool
1470 ffecom_possible_partial_overlap_ (ffebld expr1, ffebld expr2 ATTRIBUTE_UNUSED)
1471 {
1472   ffesymbol sym;
1473   ffestorag st;
1474
1475   switch (ffebld_op (expr1))
1476     {
1477     case FFEBLD_opSYMTER:
1478       sym = ffebld_symter (expr1);
1479       break;
1480
1481     case FFEBLD_opARRAYREF:
1482       if (ffebld_op (ffebld_left (expr1)) != FFEBLD_opSYMTER)
1483         return FALSE;
1484       sym = ffebld_symter (ffebld_left (expr1));
1485       break;
1486
1487     default:
1488       return FALSE;
1489     }
1490
1491   if (ffesymbol_where (sym) != FFEINFO_whereCOMMON
1492       && (ffesymbol_where (sym) != FFEINFO_whereLOCAL
1493           || ! (st = ffesymbol_storage (sym))
1494           || ! ffestorag_parent (st)))
1495     return FALSE;
1496
1497   /* It's in COMMON or local EQUIVALENCE.  */
1498
1499   return TRUE;
1500 }
1501
1502 /* Check whether dest and source might overlap.  ffebld versions of these
1503    might or might not be passed, will be NULL if not.
1504
1505    The test is really whether source_tree is modifiable and, if modified,
1506    might overlap destination such that the value(s) in the destination might
1507    change before it is finally modified.  dest_* are the canonized
1508    destination itself.  */
1509
1510 static bool
1511 ffecom_overlap_ (tree dest_decl, tree dest_offset, tree dest_size,
1512                  tree source_tree, ffebld source UNUSED,
1513                  bool scalar_arg)
1514 {
1515   tree source_decl;
1516   tree source_offset;
1517   tree source_size;
1518   tree t;
1519
1520   if (source_tree == NULL_TREE)
1521     return FALSE;
1522
1523   switch (TREE_CODE (source_tree))
1524     {
1525     case ERROR_MARK:
1526     case IDENTIFIER_NODE:
1527     case INTEGER_CST:
1528     case REAL_CST:
1529     case COMPLEX_CST:
1530     case STRING_CST:
1531     case CONST_DECL:
1532     case VAR_DECL:
1533     case RESULT_DECL:
1534     case FIELD_DECL:
1535     case MINUS_EXPR:
1536     case MULT_EXPR:
1537     case TRUNC_DIV_EXPR:
1538     case CEIL_DIV_EXPR:
1539     case FLOOR_DIV_EXPR:
1540     case ROUND_DIV_EXPR:
1541     case TRUNC_MOD_EXPR:
1542     case CEIL_MOD_EXPR:
1543     case FLOOR_MOD_EXPR:
1544     case ROUND_MOD_EXPR:
1545     case RDIV_EXPR:
1546     case EXACT_DIV_EXPR:
1547     case FIX_TRUNC_EXPR:
1548     case FIX_CEIL_EXPR:
1549     case FIX_FLOOR_EXPR:
1550     case FIX_ROUND_EXPR:
1551     case FLOAT_EXPR:
1552     case NEGATE_EXPR:
1553     case MIN_EXPR:
1554     case MAX_EXPR:
1555     case ABS_EXPR:
1556     case FFS_EXPR:
1557     case LSHIFT_EXPR:
1558     case RSHIFT_EXPR:
1559     case LROTATE_EXPR:
1560     case RROTATE_EXPR:
1561     case BIT_IOR_EXPR:
1562     case BIT_XOR_EXPR:
1563     case BIT_AND_EXPR:
1564     case BIT_ANDTC_EXPR:
1565     case BIT_NOT_EXPR:
1566     case TRUTH_ANDIF_EXPR:
1567     case TRUTH_ORIF_EXPR:
1568     case TRUTH_AND_EXPR:
1569     case TRUTH_OR_EXPR:
1570     case TRUTH_XOR_EXPR:
1571     case TRUTH_NOT_EXPR:
1572     case LT_EXPR:
1573     case LE_EXPR:
1574     case GT_EXPR:
1575     case GE_EXPR:
1576     case EQ_EXPR:
1577     case NE_EXPR:
1578     case COMPLEX_EXPR:
1579     case CONJ_EXPR:
1580     case REALPART_EXPR:
1581     case IMAGPART_EXPR:
1582     case LABEL_EXPR:
1583     case COMPONENT_REF:
1584       return FALSE;
1585
1586     case COMPOUND_EXPR:
1587       return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1588                               TREE_OPERAND (source_tree, 1), NULL,
1589                               scalar_arg);
1590
1591     case MODIFY_EXPR:
1592       return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1593                               TREE_OPERAND (source_tree, 0), NULL,
1594                               scalar_arg);
1595
1596     case CONVERT_EXPR:
1597     case NOP_EXPR:
1598     case NON_LVALUE_EXPR:
1599     case PLUS_EXPR:
1600       if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1601         return TRUE;
1602
1603       ffecom_tree_canonize_ptr_ (&source_decl, &source_offset,
1604                                  source_tree);
1605       source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1606       break;
1607
1608     case COND_EXPR:
1609       return
1610         ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1611                          TREE_OPERAND (source_tree, 1), NULL,
1612                          scalar_arg)
1613           || ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1614                               TREE_OPERAND (source_tree, 2), NULL,
1615                               scalar_arg);
1616
1617
1618     case ADDR_EXPR:
1619       ffecom_tree_canonize_ref_ (&source_decl, &source_offset,
1620                                  &source_size,
1621                                  TREE_OPERAND (source_tree, 0));
1622       break;
1623
1624     case PARM_DECL:
1625       if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1626         return TRUE;
1627
1628       source_decl = source_tree;
1629       source_offset = bitsize_zero_node;
1630       source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1631       break;
1632
1633     case SAVE_EXPR:
1634     case REFERENCE_EXPR:
1635     case PREDECREMENT_EXPR:
1636     case PREINCREMENT_EXPR:
1637     case POSTDECREMENT_EXPR:
1638     case POSTINCREMENT_EXPR:
1639     case INDIRECT_REF:
1640     case ARRAY_REF:
1641     case CALL_EXPR:
1642     default:
1643       return TRUE;
1644     }
1645
1646   /* Come here when source_decl, source_offset, and source_size filled
1647      in appropriately.  */
1648
1649   if (source_decl == NULL_TREE)
1650     return FALSE;               /* No decl involved, so no overlap. */
1651
1652   if (source_decl != dest_decl)
1653     return FALSE;               /* Different decl, no overlap. */
1654
1655   if (TREE_CODE (dest_size) == ERROR_MARK)
1656     return TRUE;                /* Assignment into entire assumed-size
1657                                    array?  Shouldn't happen.... */
1658
1659   t = ffecom_2 (LE_EXPR, integer_type_node,
1660                 ffecom_2 (PLUS_EXPR, TREE_TYPE (dest_offset),
1661                           dest_offset,
1662                           convert (TREE_TYPE (dest_offset),
1663                                    dest_size)),
1664                 convert (TREE_TYPE (dest_offset),
1665                          source_offset));
1666
1667   if (integer_onep (t))
1668     return FALSE;               /* Destination precedes source. */
1669
1670   if (!scalar_arg
1671       || (source_size == NULL_TREE)
1672       || (TREE_CODE (source_size) == ERROR_MARK)
1673       || integer_zerop (source_size))
1674     return TRUE;                /* No way to tell if dest follows source. */
1675
1676   t = ffecom_2 (LE_EXPR, integer_type_node,
1677                 ffecom_2 (PLUS_EXPR, TREE_TYPE (source_offset),
1678                           source_offset,
1679                           convert (TREE_TYPE (source_offset),
1680                                    source_size)),
1681                 convert (TREE_TYPE (source_offset),
1682                          dest_offset));
1683
1684   if (integer_onep (t))
1685     return FALSE;               /* Destination follows source. */
1686
1687   return TRUE;          /* Destination and source overlap. */
1688 }
1689
1690 /* Check whether dest might overlap any of a list of arguments or is
1691    in a COMMON area the callee might know about (and thus modify).  */
1692
1693 static bool
1694 ffecom_args_overlapping_ (tree dest_tree, ffebld dest UNUSED,
1695                           tree args, tree callee_commons,
1696                           bool scalar_args)
1697 {
1698   tree arg;
1699   tree dest_decl;
1700   tree dest_offset;
1701   tree dest_size;
1702
1703   ffecom_tree_canonize_ref_ (&dest_decl, &dest_offset, &dest_size,
1704                              dest_tree);
1705
1706   if (dest_decl == NULL_TREE)
1707     return FALSE;               /* Seems unlikely! */
1708
1709   /* If the decl cannot be determined reliably, or if its in COMMON
1710      and the callee isn't known to not futz with COMMON via other
1711      means, overlap might happen.  */
1712
1713   if ((TREE_CODE (dest_decl) == ERROR_MARK)
1714       || ((callee_commons != NULL_TREE)
1715           && TREE_PUBLIC (dest_decl)))
1716     return TRUE;
1717
1718   for (; args != NULL_TREE; args = TREE_CHAIN (args))
1719     {
1720       if (((arg = TREE_VALUE (args)) != NULL_TREE)
1721           && ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1722                               arg, NULL, scalar_args))
1723         return TRUE;
1724     }
1725
1726   return FALSE;
1727 }
1728
1729 /* Build a string for a variable name as used by NAMELIST.  This means that
1730    if we're using the f2c library, we build an uppercase string, since
1731    f2c does this.  */
1732
1733 static tree
1734 ffecom_build_f2c_string_ (int i, const char *s)
1735 {
1736   if (!ffe_is_f2c_library ())
1737     return build_string (i, s);
1738
1739   {
1740     char *tmp;
1741     const char *p;
1742     char *q;
1743     char space[34];
1744     tree t;
1745
1746     if (((size_t) i) > ARRAY_SIZE (space))
1747       tmp = malloc_new_ks (malloc_pool_image (), "f2c_string", i);
1748     else
1749       tmp = &space[0];
1750
1751     for (p = s, q = tmp; *p != '\0'; ++p, ++q)
1752       *q = TOUPPER (*p);
1753     *q = '\0';
1754
1755     t = build_string (i, tmp);
1756
1757     if (((size_t) i) > ARRAY_SIZE (space))
1758       malloc_kill_ks (malloc_pool_image (), tmp, i);
1759
1760     return t;
1761   }
1762 }
1763
1764 /* Returns CALL_EXPR or equivalent with given type (pass NULL_TREE for
1765    type to just get whatever the function returns), handling the
1766    f2c value-returning convention, if required, by prepending
1767    to the arglist a pointer to a temporary to receive the return value.  */
1768
1769 static tree
1770 ffecom_call_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1771               tree type, tree args, tree dest_tree,
1772               ffebld dest, bool *dest_used, tree callee_commons,
1773               bool scalar_args, tree hook)
1774 {
1775   tree item;
1776   tree tempvar;
1777
1778   if (dest_used != NULL)
1779     *dest_used = FALSE;
1780
1781   if (is_f2c_complex)
1782     {
1783       if ((dest_used == NULL)
1784           || (dest == NULL)
1785           || (ffeinfo_basictype (ffebld_info (dest))
1786               != FFEINFO_basictypeCOMPLEX)
1787           || (ffeinfo_kindtype (ffebld_info (dest)) != kt)
1788           || ((type != NULL_TREE) && (TREE_TYPE (dest_tree) != type))
1789           || ffecom_args_overlapping_ (dest_tree, dest, args,
1790                                        callee_commons,
1791                                        scalar_args))
1792         {
1793 #ifdef HOHO
1794           tempvar = ffecom_make_tempvar (ffecom_tree_type
1795                                          [FFEINFO_basictypeCOMPLEX][kt],
1796                                          FFETARGET_charactersizeNONE,
1797                                          -1);
1798 #else
1799           tempvar = hook;
1800           assert (tempvar);
1801 #endif
1802         }
1803       else
1804         {
1805           *dest_used = TRUE;
1806           tempvar = dest_tree;
1807           type = NULL_TREE;
1808         }
1809
1810       item
1811         = build_tree_list (NULL_TREE,
1812                            ffecom_1 (ADDR_EXPR,
1813                                      build_pointer_type (TREE_TYPE (tempvar)),
1814                                      tempvar));
1815       TREE_CHAIN (item) = args;
1816
1817       item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1818                         item, NULL_TREE);
1819
1820       if (tempvar != dest_tree)
1821         item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item, tempvar);
1822     }
1823   else
1824     item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1825                       args, NULL_TREE);
1826
1827   if ((type != NULL_TREE) && (TREE_TYPE (item) != type))
1828     item = ffecom_convert_narrow_ (type, item);
1829
1830   return item;
1831 }
1832
1833 /* Given two arguments, transform them and make a call to the given
1834    function via ffecom_call_.  */
1835
1836 static tree
1837 ffecom_call_binop_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1838                     tree type, ffebld left, ffebld right,
1839                     tree dest_tree, ffebld dest, bool *dest_used,
1840                     tree callee_commons, bool scalar_args, bool ref, tree hook)
1841 {
1842   tree left_tree;
1843   tree right_tree;
1844   tree left_length;
1845   tree right_length;
1846
1847   if (ref)
1848     {
1849       /* Pass arguments by reference.  */
1850       left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
1851       right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
1852     }
1853   else
1854     {
1855       /* Pass arguments by value.  */
1856       left_tree = ffecom_arg_expr (left, &left_length);
1857       right_tree = ffecom_arg_expr (right, &right_length);
1858     }
1859
1860
1861   left_tree = build_tree_list (NULL_TREE, left_tree);
1862   right_tree = build_tree_list (NULL_TREE, right_tree);
1863   TREE_CHAIN (left_tree) = right_tree;
1864
1865   if (left_length != NULL_TREE)
1866     {
1867       left_length = build_tree_list (NULL_TREE, left_length);
1868       TREE_CHAIN (right_tree) = left_length;
1869     }
1870
1871   if (right_length != NULL_TREE)
1872     {
1873       right_length = build_tree_list (NULL_TREE, right_length);
1874       if (left_length != NULL_TREE)
1875         TREE_CHAIN (left_length) = right_length;
1876       else
1877         TREE_CHAIN (right_tree) = right_length;
1878     }
1879
1880   return ffecom_call_ (fn, kt, is_f2c_complex, type, left_tree,
1881                        dest_tree, dest, dest_used, callee_commons,
1882                        scalar_args, hook);
1883 }
1884
1885 /* Return ptr/length args for char subexpression
1886
1887    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
1888    subexpressions by constructing the appropriate trees for the ptr-to-
1889    character-text and length-of-character-text arguments in a calling
1890    sequence.
1891
1892    Note that if with_null is TRUE, and the expression is an opCONTER,
1893    a null byte is appended to the string.  */
1894
1895 static void
1896 ffecom_char_args_x_ (tree *xitem, tree *length, ffebld expr, bool with_null)
1897 {
1898   tree item;
1899   tree high;
1900   ffetargetCharacter1 val;
1901   ffetargetCharacterSize newlen;
1902
1903   switch (ffebld_op (expr))
1904     {
1905     case FFEBLD_opCONTER:
1906       val = ffebld_constant_character1 (ffebld_conter (expr));
1907       newlen = ffetarget_length_character1 (val);
1908       if (with_null)
1909         {
1910           /* Begin FFETARGET-NULL-KLUDGE.  */
1911           if (newlen != 0)
1912             ++newlen;
1913         }
1914       *length = build_int_2 (newlen, 0);
1915       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
1916       high = build_int_2 (newlen, 0);
1917       TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
1918       item = build_string (newlen,
1919                            ffetarget_text_character1 (val));
1920       /* End FFETARGET-NULL-KLUDGE.  */
1921       TREE_TYPE (item)
1922         = build_type_variant
1923           (build_array_type
1924            (char_type_node,
1925             build_range_type
1926             (ffecom_f2c_ftnlen_type_node,
1927              ffecom_f2c_ftnlen_one_node,
1928              high)),
1929            1, 0);
1930       TREE_CONSTANT (item) = 1;
1931       TREE_STATIC (item) = 1;
1932       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
1933                        item);
1934       break;
1935
1936     case FFEBLD_opSYMTER:
1937       {
1938         ffesymbol s = ffebld_symter (expr);
1939
1940         item = ffesymbol_hook (s).decl_tree;
1941         if (item == NULL_TREE)
1942           {
1943             s = ffecom_sym_transform_ (s);
1944             item = ffesymbol_hook (s).decl_tree;
1945           }
1946         if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
1947           {
1948             if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
1949               *length = ffesymbol_hook (s).length_tree;
1950             else
1951               {
1952                 *length = build_int_2 (ffesymbol_size (s), 0);
1953                 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
1954               }
1955           }
1956         else if (item == error_mark_node)
1957           *length = error_mark_node;
1958         else
1959           /* FFEINFO_kindFUNCTION.  */
1960           *length = NULL_TREE;
1961         if (!ffesymbol_hook (s).addr
1962             && (item != error_mark_node))
1963           item = ffecom_1 (ADDR_EXPR,
1964                            build_pointer_type (TREE_TYPE (item)),
1965                            item);
1966       }
1967       break;
1968
1969     case FFEBLD_opARRAYREF:
1970       {
1971         ffecom_char_args_ (&item, length, ffebld_left (expr));
1972
1973         if (item == error_mark_node || *length == error_mark_node)
1974           {
1975             item = *length = error_mark_node;
1976             break;
1977           }
1978
1979         item = ffecom_arrayref_ (item, expr, 1);
1980       }
1981       break;
1982
1983     case FFEBLD_opSUBSTR:
1984       {
1985         ffebld start;
1986         ffebld end;
1987         ffebld thing = ffebld_right (expr);
1988         tree start_tree;
1989         tree end_tree;
1990         const char *char_name;
1991         ffebld left_symter;
1992         tree array;
1993
1994         assert (ffebld_op (thing) == FFEBLD_opITEM);
1995         start = ffebld_head (thing);
1996         thing = ffebld_trail (thing);
1997         assert (ffebld_trail (thing) == NULL);
1998         end = ffebld_head (thing);
1999
2000         /* Determine name for pretty-printing range-check errors.  */
2001         for (left_symter = ffebld_left (expr);
2002              left_symter && ffebld_op (left_symter) == FFEBLD_opARRAYREF;
2003              left_symter = ffebld_left (left_symter))
2004           ;
2005         if (ffebld_op (left_symter) == FFEBLD_opSYMTER)
2006           char_name = ffesymbol_text (ffebld_symter (left_symter));
2007         else
2008           char_name = "[expr?]";
2009
2010         ffecom_char_args_ (&item, length, ffebld_left (expr));
2011
2012         if (item == error_mark_node || *length == error_mark_node)
2013           {
2014             item = *length = error_mark_node;
2015             break;
2016           }
2017
2018         array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
2019
2020         /* ~~~~Handle INTEGER*8 start/end, a la FFEBLD_opARRAYREF.  */
2021
2022         if (start == NULL)
2023           {
2024             if (end == NULL)
2025               ;
2026             else
2027               {
2028                 end_tree = ffecom_expr (end);
2029                 if (flag_bounds_check)
2030                   end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2031                                                       char_name);
2032                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2033                                     end_tree);
2034
2035                 if (end_tree == error_mark_node)
2036                   {
2037                     item = *length = error_mark_node;
2038                     break;
2039                   }
2040
2041                 *length = end_tree;
2042               }
2043           }
2044         else
2045           {
2046             start_tree = ffecom_expr (start);
2047             if (flag_bounds_check)
2048               start_tree = ffecom_subscript_check_ (array, start_tree, 0, 0,
2049                                                     char_name);
2050             start_tree = convert (ffecom_f2c_ftnlen_type_node,
2051                                   start_tree);
2052
2053             if (start_tree == error_mark_node)
2054               {
2055                 item = *length = error_mark_node;
2056                 break;
2057               }
2058
2059             start_tree = ffecom_save_tree (start_tree);
2060
2061             item = ffecom_2 (PLUS_EXPR, TREE_TYPE (item),
2062                              item,
2063                              ffecom_2 (MINUS_EXPR,
2064                                        TREE_TYPE (start_tree),
2065                                        start_tree,
2066                                        ffecom_f2c_ftnlen_one_node));
2067
2068             if (end == NULL)
2069               {
2070                 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2071                                     ffecom_f2c_ftnlen_one_node,
2072                                     ffecom_2 (MINUS_EXPR,
2073                                               ffecom_f2c_ftnlen_type_node,
2074                                               *length,
2075                                               start_tree));
2076               }
2077             else
2078               {
2079                 end_tree = ffecom_expr (end);
2080                 if (flag_bounds_check)
2081                   end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2082                                                       char_name);
2083                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2084                                     end_tree);
2085
2086                 if (end_tree == error_mark_node)
2087                   {
2088                     item = *length = error_mark_node;
2089                     break;
2090                   }
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                                               end_tree, start_tree));
2097               }
2098           }
2099       }
2100       break;
2101
2102     case FFEBLD_opFUNCREF:
2103       {
2104         ffesymbol s = ffebld_symter (ffebld_left (expr));
2105         tree tempvar;
2106         tree args;
2107         ffetargetCharacterSize size = ffeinfo_size (ffebld_info (expr));
2108         ffecomGfrt ix;
2109
2110         if (size == FFETARGET_charactersizeNONE)
2111           /* ~~Kludge alert!  This should someday be fixed. */
2112           size = 24;
2113
2114         *length = build_int_2 (size, 0);
2115         TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2116
2117         if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
2118             == FFEINFO_whereINTRINSIC)
2119           {
2120             if (size == 1)
2121               {
2122                 /* Invocation of an intrinsic returning CHARACTER*1.  */
2123                 item = ffecom_expr_intrinsic_ (expr, NULL_TREE,
2124                                                NULL, NULL);
2125                 break;
2126               }
2127             ix = ffeintrin_gfrt_direct (ffebld_symter_implementation (ffebld_left (expr)));
2128             assert (ix != FFECOM_gfrt);
2129             item = ffecom_gfrt_tree_ (ix);
2130           }
2131         else
2132           {
2133             ix = FFECOM_gfrt;
2134             item = ffesymbol_hook (s).decl_tree;
2135             if (item == NULL_TREE)
2136               {
2137                 s = ffecom_sym_transform_ (s);
2138                 item = ffesymbol_hook (s).decl_tree;
2139               }
2140             if (item == error_mark_node)
2141               {
2142                 item = *length = error_mark_node;
2143                 break;
2144               }
2145
2146             if (!ffesymbol_hook (s).addr)
2147               item = ffecom_1_fn (item);
2148           }
2149
2150 #ifdef HOHO
2151         tempvar = ffecom_push_tempvar (char_type_node, size, -1, TRUE);
2152 #else
2153         tempvar = ffebld_nonter_hook (expr);
2154         assert (tempvar);
2155 #endif
2156         tempvar = ffecom_1 (ADDR_EXPR,
2157                             build_pointer_type (TREE_TYPE (tempvar)),
2158                             tempvar);
2159
2160         args = build_tree_list (NULL_TREE, tempvar);
2161
2162         if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)       /* Sfunc args by value. */
2163           TREE_CHAIN (args) = ffecom_list_expr (ffebld_right (expr));
2164         else
2165           {
2166             TREE_CHAIN (args) = build_tree_list (NULL_TREE, *length);
2167             if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
2168               {
2169                 TREE_CHAIN (TREE_CHAIN (args))
2170                   = ffecom_arglist_expr_ (ffecom_gfrt_args_ (ix),
2171                                           ffebld_right (expr));
2172               }
2173             else
2174               {
2175                 TREE_CHAIN (TREE_CHAIN (args))
2176                   = ffecom_list_ptr_to_expr (ffebld_right (expr));
2177               }
2178           }
2179
2180         item = ffecom_3s (CALL_EXPR,
2181                           TREE_TYPE (TREE_TYPE (TREE_TYPE (item))),
2182                           item, args, NULL_TREE);
2183         item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item,
2184                          tempvar);
2185       }
2186       break;
2187
2188     case FFEBLD_opCONVERT:
2189
2190       ffecom_char_args_ (&item, length, ffebld_left (expr));
2191
2192       if (item == error_mark_node || *length == error_mark_node)
2193         {
2194           item = *length = error_mark_node;
2195           break;
2196         }
2197
2198       if ((ffebld_size_known (ffebld_left (expr))
2199            == FFETARGET_charactersizeNONE)
2200           || (ffebld_size_known (ffebld_left (expr)) < (ffebld_size (expr))))
2201         {                       /* Possible blank-padding needed, copy into
2202                                    temporary. */
2203           tree tempvar;
2204           tree args;
2205           tree newlen;
2206
2207 #ifdef HOHO
2208           tempvar = ffecom_make_tempvar (char_type_node,
2209                                          ffebld_size (expr), -1);
2210 #else
2211           tempvar = ffebld_nonter_hook (expr);
2212           assert (tempvar);
2213 #endif
2214           tempvar = ffecom_1 (ADDR_EXPR,
2215                               build_pointer_type (TREE_TYPE (tempvar)),
2216                               tempvar);
2217
2218           newlen = build_int_2 (ffebld_size (expr), 0);
2219           TREE_TYPE (newlen) = ffecom_f2c_ftnlen_type_node;
2220
2221           args = build_tree_list (NULL_TREE, tempvar);
2222           TREE_CHAIN (args) = build_tree_list (NULL_TREE, item);
2223           TREE_CHAIN (TREE_CHAIN (args)) = build_tree_list (NULL_TREE, newlen);
2224           TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (args)))
2225             = build_tree_list (NULL_TREE, *length);
2226
2227           item = ffecom_call_gfrt (FFECOM_gfrtCOPY, args, NULL_TREE);
2228           TREE_SIDE_EFFECTS (item) = 1;
2229           item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), fold (item),
2230                            tempvar);
2231           *length = newlen;
2232         }
2233       else
2234         {                       /* Just truncate the length. */
2235           *length = build_int_2 (ffebld_size (expr), 0);
2236           TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2237         }
2238       break;
2239
2240     default:
2241       assert ("bad op for single char arg expr" == NULL);
2242       item = NULL_TREE;
2243       break;
2244     }
2245
2246   *xitem = item;
2247 }
2248
2249 /* Check the size of the type to be sure it doesn't overflow the
2250    "portable" capacities of the compiler back end.  `dummy' types
2251    can generally overflow the normal sizes as long as the computations
2252    themselves don't overflow.  A particular target of the back end
2253    must still enforce its size requirements, though, and the back
2254    end takes care of this in stor-layout.c.  */
2255
2256 static tree
2257 ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy)
2258 {
2259   if (TREE_CODE (type) == ERROR_MARK)
2260     return type;
2261
2262   if (TYPE_SIZE (type) == NULL_TREE)
2263     return type;
2264
2265   if (TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST)
2266     return type;
2267
2268   if ((tree_int_cst_sgn (TYPE_SIZE (type)) < 0)
2269       || (!dummy && TREE_OVERFLOW (TYPE_SIZE (type))))
2270     {
2271       ffebad_start (FFEBAD_ARRAY_LARGE);
2272       ffebad_string (ffesymbol_text (s));
2273       ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s));
2274       ffebad_finish ();
2275
2276       return error_mark_node;
2277     }
2278
2279   return type;
2280 }
2281
2282 /* Builds a length argument (PARM_DECL).  Also wraps type in an array type
2283    where the dimension info is (1:size) where <size> is ffesymbol_size(s) if
2284    known, length_arg if not known (FFETARGET_charactersizeNONE).  */
2285
2286 static tree
2287 ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s)
2288 {
2289   ffetargetCharacterSize sz = ffesymbol_size (s);
2290   tree highval;
2291   tree tlen;
2292   tree type = *xtype;
2293
2294   if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
2295     tlen = NULL_TREE;           /* A statement function, no length passed. */
2296   else
2297     {
2298       if (ffesymbol_where (s) == FFEINFO_whereDUMMY)
2299         tlen = ffecom_get_invented_identifier ("__g77_length_%s",
2300                                                ffesymbol_text (s));
2301       else
2302         tlen = ffecom_get_invented_identifier ("__g77_%s", "length");
2303       tlen = build_decl (PARM_DECL, tlen, ffecom_f2c_ftnlen_type_node);
2304       DECL_ARTIFICIAL (tlen) = 1;
2305     }
2306
2307   if (sz == FFETARGET_charactersizeNONE)
2308     {
2309       assert (tlen != NULL_TREE);
2310       highval = variable_size (tlen);
2311     }
2312   else
2313     {
2314       highval = build_int_2 (sz, 0);
2315       TREE_TYPE (highval) = ffecom_f2c_ftnlen_type_node;
2316     }
2317
2318   type = build_array_type (type,
2319                            build_range_type (ffecom_f2c_ftnlen_type_node,
2320                                              ffecom_f2c_ftnlen_one_node,
2321                                              highval));
2322
2323   *xtype = type;
2324   return tlen;
2325 }
2326
2327 /* ffecom_concat_list_gather_ -- Gather list of concatenated string exprs
2328
2329    ffecomConcatList_ catlist;
2330    ffebld expr;  // expr of CHARACTER basictype.
2331    ffetargetCharacterSize max;  // max chars to gather or _...NONE if no max
2332    catlist = ffecom_concat_list_gather_(catlist,expr,max);
2333
2334    Scans expr for character subexpressions, updates and returns catlist
2335    accordingly.  */
2336
2337 static ffecomConcatList_
2338 ffecom_concat_list_gather_ (ffecomConcatList_ catlist, ffebld expr,
2339                             ffetargetCharacterSize max)
2340 {
2341   ffetargetCharacterSize sz;
2342
2343  recurse:
2344
2345   if (expr == NULL)
2346     return catlist;
2347
2348   if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen >= max))
2349     return catlist;             /* Don't append any more items. */
2350
2351   switch (ffebld_op (expr))
2352     {
2353     case FFEBLD_opCONTER:
2354     case FFEBLD_opSYMTER:
2355     case FFEBLD_opARRAYREF:
2356     case FFEBLD_opFUNCREF:
2357     case FFEBLD_opSUBSTR:
2358     case FFEBLD_opCONVERT:      /* Callers should strip this off beforehand
2359                                    if they don't need to preserve it. */
2360       if (catlist.count == catlist.max)
2361         {                       /* Make a (larger) list. */
2362           ffebld *newx;
2363           int newmax;
2364
2365           newmax = (catlist.max == 0) ? 8 : catlist.max * 2;
2366           newx = malloc_new_ks (malloc_pool_image (), "catlist",
2367                                 newmax * sizeof (newx[0]));
2368           if (catlist.max != 0)
2369             {
2370               memcpy (newx, catlist.exprs, catlist.max * sizeof (newx[0]));
2371               malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2372                               catlist.max * sizeof (newx[0]));
2373             }
2374           catlist.max = newmax;
2375           catlist.exprs = newx;
2376         }
2377       if ((sz = ffebld_size_known (expr)) != FFETARGET_charactersizeNONE)
2378         catlist.minlen += sz;
2379       else
2380         ++catlist.minlen;       /* Not true for F90; can be 0 length. */
2381       if ((sz = ffebld_size_max (expr)) == FFETARGET_charactersizeNONE)
2382         catlist.maxlen = sz;
2383       else
2384         catlist.maxlen += sz;
2385       if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen > max))
2386         {                       /* This item overlaps (or is beyond) the end
2387                                    of the destination. */
2388           switch (ffebld_op (expr))
2389             {
2390             case FFEBLD_opCONTER:
2391             case FFEBLD_opSYMTER:
2392             case FFEBLD_opARRAYREF:
2393             case FFEBLD_opFUNCREF:
2394             case FFEBLD_opSUBSTR:
2395               /* ~~Do useful truncations here. */
2396               break;
2397
2398             default:
2399               assert ("op changed or inconsistent switches!" == NULL);
2400               break;
2401             }
2402         }
2403       catlist.exprs[catlist.count++] = expr;
2404       return catlist;
2405
2406     case FFEBLD_opPAREN:
2407       expr = ffebld_left (expr);
2408       goto recurse;             /* :::::::::::::::::::: */
2409
2410     case FFEBLD_opCONCATENATE:
2411       catlist = ffecom_concat_list_gather_ (catlist, ffebld_left (expr), max);
2412       expr = ffebld_right (expr);
2413       goto recurse;             /* :::::::::::::::::::: */
2414
2415 #if 0                           /* Breaks passing small actual arg to larger
2416                                    dummy arg of sfunc */
2417     case FFEBLD_opCONVERT:
2418       expr = ffebld_left (expr);
2419       {
2420         ffetargetCharacterSize cmax;
2421
2422         cmax = catlist.len + ffebld_size_known (expr);
2423
2424         if ((max == FFETARGET_charactersizeNONE) || (max > cmax))
2425           max = cmax;
2426       }
2427       goto recurse;             /* :::::::::::::::::::: */
2428 #endif
2429
2430     case FFEBLD_opANY:
2431       return catlist;
2432
2433     default:
2434       assert ("bad op in _gather_" == NULL);
2435       return catlist;
2436     }
2437 }
2438
2439 /* ffecom_concat_list_kill_ -- Kill list of concatenated string exprs
2440
2441    ffecomConcatList_ catlist;
2442    ffecom_concat_list_kill_(catlist);
2443
2444    Anything allocated within the list info is deallocated.  */
2445
2446 static void
2447 ffecom_concat_list_kill_ (ffecomConcatList_ catlist)
2448 {
2449   if (catlist.max != 0)
2450     malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2451                     catlist.max * sizeof (catlist.exprs[0]));
2452 }
2453
2454 /* Make list of concatenated string exprs.
2455
2456    Returns a flattened list of concatenated subexpressions given a
2457    tree of such expressions.  */
2458
2459 static ffecomConcatList_
2460 ffecom_concat_list_new_ (ffebld expr, ffetargetCharacterSize max)
2461 {
2462   ffecomConcatList_ catlist;
2463
2464   catlist.maxlen = catlist.minlen = catlist.max = catlist.count = 0;
2465   return ffecom_concat_list_gather_ (catlist, expr, max);
2466 }
2467
2468 /* Provide some kind of useful info on member of aggregate area,
2469    since current g77/gcc technology does not provide debug info
2470    on these members.  */
2471
2472 static void
2473 ffecom_debug_kludge_ (tree aggr, const char *aggr_type, ffesymbol member,
2474                       tree member_type UNUSED, ffetargetOffset offset)
2475 {
2476   tree value;
2477   tree decl;
2478   int len;
2479   char *buff;
2480   char space[120];
2481 #if 0
2482   tree type_id;
2483
2484   for (type_id = member_type;
2485        TREE_CODE (type_id) != IDENTIFIER_NODE;
2486        )
2487     {
2488       switch (TREE_CODE (type_id))
2489         {
2490         case INTEGER_TYPE:
2491         case REAL_TYPE:
2492           type_id = TYPE_NAME (type_id);
2493           break;
2494
2495         case ARRAY_TYPE:
2496         case COMPLEX_TYPE:
2497           type_id = TREE_TYPE (type_id);
2498           break;
2499
2500         default:
2501           assert ("no IDENTIFIER_NODE for type!" == NULL);
2502           type_id = error_mark_node;
2503           break;
2504         }
2505     }
2506 #endif
2507
2508   if (ffecom_transform_only_dummies_
2509       || !ffe_is_debug_kludge ())
2510     return;     /* Can't do this yet, maybe later. */
2511
2512   len = 60
2513     + strlen (aggr_type)
2514     + IDENTIFIER_LENGTH (DECL_NAME (aggr));
2515 #if 0
2516     + IDENTIFIER_LENGTH (type_id);
2517 #endif
2518
2519   if (((size_t) len) >= ARRAY_SIZE (space))
2520     buff = malloc_new_ks (malloc_pool_image (), "debug_kludge", len + 1);
2521   else
2522     buff = &space[0];
2523
2524   sprintf (&buff[0], "At (%s) `%s' plus %ld bytes",
2525            aggr_type,
2526            IDENTIFIER_POINTER (DECL_NAME (aggr)),
2527            (long int) offset);
2528
2529   value = build_string (len, buff);
2530   TREE_TYPE (value)
2531     = build_type_variant (build_array_type (char_type_node,
2532                                             build_range_type
2533                                             (integer_type_node,
2534                                              integer_one_node,
2535                                              build_int_2 (strlen (buff), 0))),
2536                           1, 0);
2537   decl = build_decl (VAR_DECL,
2538                      ffecom_get_identifier_ (ffesymbol_text (member)),
2539                      TREE_TYPE (value));
2540   TREE_CONSTANT (decl) = 1;
2541   TREE_STATIC (decl) = 1;
2542   DECL_INITIAL (decl) = error_mark_node;
2543   DECL_IN_SYSTEM_HEADER (decl) = 1;     /* Don't let -Wunused complain. */
2544   decl = start_decl (decl, FALSE);
2545   finish_decl (decl, value, FALSE);
2546
2547   if (buff != &space[0])
2548     malloc_kill_ks (malloc_pool_image (), buff, len + 1);
2549 }
2550
2551 /* ffecom_do_entry_ -- Do compilation of a particular entrypoint
2552
2553    ffesymbol fn;  // the SUBROUTINE, FUNCTION, or ENTRY symbol itself
2554    int i;  // entry# for this entrypoint (used by master fn)
2555    ffecom_do_entrypoint_(s,i);
2556
2557    Makes a public entry point that calls our private master fn (already
2558    compiled).  */
2559
2560 static void
2561 ffecom_do_entry_ (ffesymbol fn, int entrynum)
2562 {
2563   ffebld item;
2564   tree type;                    /* Type of function. */
2565   tree multi_retval;            /* Var holding return value (union). */
2566   tree result;                  /* Var holding result. */
2567   ffeinfoBasictype bt;
2568   ffeinfoKindtype kt;
2569   ffeglobal g;
2570   ffeglobalType gt;
2571   bool charfunc;                /* All entry points return same type
2572                                    CHARACTER. */
2573   bool cmplxfunc;               /* Use f2c way of returning COMPLEX. */
2574   bool multi;                   /* Master fn has multiple return types. */
2575   bool altreturning = FALSE;    /* This entry point has alternate returns. */
2576   int old_lineno = lineno;
2577   const char *old_input_filename = input_filename;
2578
2579   input_filename = ffesymbol_where_filename (fn);
2580   lineno = ffesymbol_where_filelinenum (fn);
2581
2582   ffecom_doing_entry_ = TRUE;   /* Don't bother with array dimensions. */
2583
2584   switch (ffecom_primary_entry_kind_)
2585     {
2586     case FFEINFO_kindFUNCTION:
2587
2588       /* Determine actual return type for function. */
2589
2590       gt = FFEGLOBAL_typeFUNC;
2591       bt = ffesymbol_basictype (fn);
2592       kt = ffesymbol_kindtype (fn);
2593       if (bt == FFEINFO_basictypeNONE)
2594         {
2595           ffeimplic_establish_symbol (fn);
2596           if (ffesymbol_funcresult (fn) != NULL)
2597             ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
2598           bt = ffesymbol_basictype (fn);
2599           kt = ffesymbol_kindtype (fn);
2600         }
2601
2602       if (bt == FFEINFO_basictypeCHARACTER)
2603         charfunc = TRUE, cmplxfunc = FALSE;
2604       else if ((bt == FFEINFO_basictypeCOMPLEX)
2605                && ffesymbol_is_f2c (fn))
2606         charfunc = FALSE, cmplxfunc = TRUE;
2607       else
2608         charfunc = cmplxfunc = FALSE;
2609
2610       if (charfunc)
2611         type = ffecom_tree_fun_type_void;
2612       else if (ffesymbol_is_f2c (fn))
2613         type = ffecom_tree_fun_type[bt][kt];
2614       else
2615         type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
2616
2617       if ((type == NULL_TREE)
2618           || (TREE_TYPE (type) == NULL_TREE))
2619         type = ffecom_tree_fun_type_void;       /* _sym_exec_transition. */
2620
2621       multi = (ffecom_master_bt_ == FFEINFO_basictypeNONE);
2622       break;
2623
2624     case FFEINFO_kindSUBROUTINE:
2625       gt = FFEGLOBAL_typeSUBR;
2626       bt = FFEINFO_basictypeNONE;
2627       kt = FFEINFO_kindtypeNONE;
2628       if (ffecom_is_altreturning_)
2629         {                       /* Am _I_ altreturning? */
2630           for (item = ffesymbol_dummyargs (fn);
2631                item != NULL;
2632                item = ffebld_trail (item))
2633             {
2634               if (ffebld_op (ffebld_head (item)) == FFEBLD_opSTAR)
2635                 {
2636                   altreturning = TRUE;
2637                   break;
2638                 }
2639             }
2640           if (altreturning)
2641             type = ffecom_tree_subr_type;
2642           else
2643             type = ffecom_tree_fun_type_void;
2644         }
2645       else
2646         type = ffecom_tree_fun_type_void;
2647       charfunc = FALSE;
2648       cmplxfunc = FALSE;
2649       multi = FALSE;
2650       break;
2651
2652     default:
2653       assert ("say what??" == NULL);
2654       /* Fall through. */
2655     case FFEINFO_kindANY:
2656       gt = FFEGLOBAL_typeANY;
2657       bt = FFEINFO_basictypeNONE;
2658       kt = FFEINFO_kindtypeNONE;
2659       type = error_mark_node;
2660       charfunc = FALSE;
2661       cmplxfunc = FALSE;
2662       multi = FALSE;
2663       break;
2664     }
2665
2666   /* build_decl uses the current lineno and input_filename to set the decl
2667      source info.  So, I've putzed with ffestd and ffeste code to update that
2668      source info to point to the appropriate statement just before calling
2669      ffecom_do_entrypoint (which calls this fn).  */
2670
2671   start_function (ffecom_get_external_identifier_ (fn),
2672                   type,
2673                   0,            /* nested/inline */
2674                   1);           /* TREE_PUBLIC */
2675
2676   if (((g = ffesymbol_global (fn)) != NULL)
2677       && ((ffeglobal_type (g) == gt)
2678           || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
2679     {
2680       ffeglobal_set_hook (g, current_function_decl);
2681     }
2682
2683   /* Reset args in master arg list so they get retransitioned. */
2684
2685   for (item = ffecom_master_arglist_;
2686        item != NULL;
2687        item = ffebld_trail (item))
2688     {
2689       ffebld arg;
2690       ffesymbol s;
2691
2692       arg = ffebld_head (item);
2693       if (ffebld_op (arg) != FFEBLD_opSYMTER)
2694         continue;               /* Alternate return or some such thing. */
2695       s = ffebld_symter (arg);
2696       ffesymbol_hook (s).decl_tree = NULL_TREE;
2697       ffesymbol_hook (s).length_tree = NULL_TREE;
2698     }
2699
2700   /* Build dummy arg list for this entry point. */
2701
2702   if (charfunc || cmplxfunc)
2703     {                           /* Prepend arg for where result goes. */
2704       tree type;
2705       tree length;
2706
2707       if (charfunc)
2708         type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
2709       else
2710         type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
2711
2712       result = ffecom_get_invented_identifier ("__g77_%s", "result");
2713
2714       /* Make length arg _and_ enhance type info for CHAR arg itself.  */
2715
2716       if (charfunc)
2717         length = ffecom_char_enhance_arg_ (&type, fn);
2718       else
2719         length = NULL_TREE;     /* Not ref'd if !charfunc. */
2720
2721       type = build_pointer_type (type);
2722       result = build_decl (PARM_DECL, result, type);
2723
2724       push_parm_decl (result);
2725       ffecom_func_result_ = result;
2726
2727       if (charfunc)
2728         {
2729           push_parm_decl (length);
2730           ffecom_func_length_ = length;
2731         }
2732     }
2733   else
2734     result = DECL_RESULT (current_function_decl);
2735
2736   ffecom_push_dummy_decls_ (ffesymbol_dummyargs (fn), FALSE);
2737
2738   store_parm_decls (0);
2739
2740   ffecom_start_compstmt ();
2741   /* Disallow temp vars at this level.  */
2742   current_binding_level->prep_state = 2;
2743
2744   /* Make local var to hold return type for multi-type master fn. */
2745
2746   if (multi)
2747     {
2748       multi_retval = ffecom_get_invented_identifier ("__g77_%s",
2749                                                      "multi_retval");
2750       multi_retval = build_decl (VAR_DECL, multi_retval,
2751                                  ffecom_multi_type_node_);
2752       multi_retval = start_decl (multi_retval, FALSE);
2753       finish_decl (multi_retval, NULL_TREE, FALSE);
2754     }
2755   else
2756     multi_retval = NULL_TREE;   /* Not actually ref'd if !multi. */
2757
2758   /* Here we emit the actual code for the entry point. */
2759
2760   {
2761     ffebld list;
2762     ffebld arg;
2763     ffesymbol s;
2764     tree arglist = NULL_TREE;
2765     tree *plist = &arglist;
2766     tree prepend;
2767     tree call;
2768     tree actarg;
2769     tree master_fn;
2770
2771     /* Prepare actual arg list based on master arg list. */
2772
2773     for (list = ffecom_master_arglist_;
2774          list != NULL;
2775          list = ffebld_trail (list))
2776       {
2777         arg = ffebld_head (list);
2778         if (ffebld_op (arg) != FFEBLD_opSYMTER)
2779           continue;
2780         s = ffebld_symter (arg);
2781         if (ffesymbol_hook (s).decl_tree == NULL_TREE
2782             || ffesymbol_hook (s).decl_tree == error_mark_node)
2783           actarg = null_pointer_node;   /* We don't have this arg. */
2784         else
2785           actarg = ffesymbol_hook (s).decl_tree;
2786         *plist = build_tree_list (NULL_TREE, actarg);
2787         plist = &TREE_CHAIN (*plist);
2788       }
2789
2790     /* This code appends the length arguments for character
2791        variables/arrays.  */
2792
2793     for (list = ffecom_master_arglist_;
2794          list != NULL;
2795          list = ffebld_trail (list))
2796       {
2797         arg = ffebld_head (list);
2798         if (ffebld_op (arg) != FFEBLD_opSYMTER)
2799           continue;
2800         s = ffebld_symter (arg);
2801         if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
2802           continue;             /* Only looking for CHARACTER arguments. */
2803         if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
2804           continue;             /* Only looking for variables and arrays. */
2805         if (ffesymbol_hook (s).length_tree == NULL_TREE
2806             || ffesymbol_hook (s).length_tree == error_mark_node)
2807           actarg = ffecom_f2c_ftnlen_zero_node; /* We don't have this arg. */
2808         else
2809           actarg = ffesymbol_hook (s).length_tree;
2810         *plist = build_tree_list (NULL_TREE, actarg);
2811         plist = &TREE_CHAIN (*plist);
2812       }
2813
2814     /* Prepend character-value return info to actual arg list. */
2815
2816     if (charfunc)
2817       {
2818         prepend = build_tree_list (NULL_TREE, ffecom_func_result_);
2819         TREE_CHAIN (prepend)
2820           = build_tree_list (NULL_TREE, ffecom_func_length_);
2821         TREE_CHAIN (TREE_CHAIN (prepend)) = arglist;
2822         arglist = prepend;
2823       }
2824
2825     /* Prepend multi-type return value to actual arg list. */
2826
2827     if (multi)
2828       {
2829         prepend
2830           = build_tree_list (NULL_TREE,
2831                              ffecom_1 (ADDR_EXPR,
2832                               build_pointer_type (TREE_TYPE (multi_retval)),
2833                                        multi_retval));
2834         TREE_CHAIN (prepend) = arglist;
2835         arglist = prepend;
2836       }
2837
2838     /* Prepend my entry-point number to the actual arg list. */
2839
2840     prepend = build_tree_list (NULL_TREE, build_int_2 (entrynum, 0));
2841     TREE_CHAIN (prepend) = arglist;
2842     arglist = prepend;
2843
2844     /* Build the call to the master function. */
2845
2846     master_fn = ffecom_1_fn (ffecom_previous_function_decl_);
2847     call = ffecom_3s (CALL_EXPR,
2848                       TREE_TYPE (TREE_TYPE (TREE_TYPE (master_fn))),
2849                       master_fn, arglist, NULL_TREE);
2850
2851     /* Decide whether the master function is a function or subroutine, and
2852        handle the return value for my entry point. */
2853
2854     if (charfunc || ((ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
2855                      && !altreturning))
2856       {
2857         expand_expr_stmt (call);
2858         expand_null_return ();
2859       }
2860     else if (multi && cmplxfunc)
2861       {
2862         expand_expr_stmt (call);
2863         result
2864           = ffecom_1 (INDIRECT_REF,
2865                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
2866                       result);
2867         result = ffecom_modify (NULL_TREE, result,
2868                                 ffecom_2 (COMPONENT_REF, TREE_TYPE (result),
2869                                           multi_retval,
2870                                           ffecom_multi_fields_[bt][kt]));
2871         expand_expr_stmt (result);
2872         expand_null_return ();
2873       }
2874     else if (multi)
2875       {
2876         expand_expr_stmt (call);
2877         result
2878           = ffecom_modify (NULL_TREE, result,
2879                            convert (TREE_TYPE (result),
2880                                     ffecom_2 (COMPONENT_REF,
2881                                               ffecom_tree_type[bt][kt],
2882                                               multi_retval,
2883                                               ffecom_multi_fields_[bt][kt])));
2884         expand_return (result);
2885       }
2886     else if (cmplxfunc)
2887       {
2888         result
2889           = ffecom_1 (INDIRECT_REF,
2890                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
2891                       result);
2892         result = ffecom_modify (NULL_TREE, result, call);
2893         expand_expr_stmt (result);
2894         expand_null_return ();
2895       }
2896     else
2897       {
2898         result = ffecom_modify (NULL_TREE,
2899                                 result,
2900                                 convert (TREE_TYPE (result),
2901                                          call));
2902         expand_return (result);
2903       }
2904   }
2905
2906   ffecom_end_compstmt ();
2907
2908   finish_function (0);
2909
2910   lineno = old_lineno;
2911   input_filename = old_input_filename;
2912
2913   ffecom_doing_entry_ = FALSE;
2914 }
2915
2916 /* Transform expr into gcc tree with possible destination
2917
2918    Recursive descent on expr while making corresponding tree nodes and
2919    attaching type info and such.  If destination supplied and compatible
2920    with temporary that would be made in certain cases, temporary isn't
2921    made, destination used instead, and dest_used flag set TRUE.  */
2922
2923 static tree
2924 ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
2925               bool *dest_used, bool assignp, bool widenp)
2926 {
2927   tree item;
2928   tree list;
2929   tree args;
2930   ffeinfoBasictype bt;
2931   ffeinfoKindtype kt;
2932   tree t;
2933   tree dt;                      /* decl_tree for an ffesymbol. */
2934   tree tree_type, tree_type_x;
2935   tree left, right;
2936   ffesymbol s;
2937   enum tree_code code;
2938
2939   assert (expr != NULL);
2940
2941   if (dest_used != NULL)
2942     *dest_used = FALSE;
2943
2944   bt = ffeinfo_basictype (ffebld_info (expr));
2945   kt = ffeinfo_kindtype (ffebld_info (expr));
2946   tree_type = ffecom_tree_type[bt][kt];
2947
2948   /* Widen integral arithmetic as desired while preserving signedness.  */
2949   tree_type_x = NULL_TREE;
2950   if (widenp && tree_type
2951       && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
2952       && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
2953     tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
2954
2955   switch (ffebld_op (expr))
2956     {
2957     case FFEBLD_opACCTER:
2958       {
2959         ffebitCount i;
2960         ffebit bits = ffebld_accter_bits (expr);
2961         ffetargetOffset source_offset = 0;
2962         ffetargetOffset dest_offset = ffebld_accter_pad (expr);
2963         tree purpose;
2964
2965         assert (dest_offset == 0
2966                 || (bt == FFEINFO_basictypeCHARACTER
2967                     && kt == FFEINFO_kindtypeCHARACTER1));
2968
2969         list = item = NULL;
2970         for (;;)
2971           {
2972             ffebldConstantUnion cu;
2973             ffebitCount length;
2974             bool value;
2975             ffebldConstantArray ca = ffebld_accter (expr);
2976
2977             ffebit_test (bits, source_offset, &value, &length);
2978             if (length == 0)
2979               break;
2980
2981             if (value)
2982               {
2983                 for (i = 0; i < length; ++i)
2984                   {
2985                     cu = ffebld_constantarray_get (ca, bt, kt,
2986                                                    source_offset + i);
2987
2988                     t = ffecom_constantunion (&cu, bt, kt, tree_type);
2989
2990                     if (i == 0
2991                         && dest_offset != 0)
2992                       purpose = build_int_2 (dest_offset, 0);
2993                     else
2994                       purpose = NULL_TREE;
2995
2996                     if (list == NULL_TREE)
2997                       list = item = build_tree_list (purpose, t);
2998                     else
2999                       {
3000                         TREE_CHAIN (item) = build_tree_list (purpose, t);
3001                         item = TREE_CHAIN (item);
3002                       }
3003                   }
3004               }
3005             source_offset += length;
3006             dest_offset += length;
3007           }
3008       }
3009
3010       item = build_int_2 ((ffebld_accter_size (expr)
3011                            + ffebld_accter_pad (expr)) - 1, 0);
3012       ffebit_kill (ffebld_accter_bits (expr));
3013       TREE_TYPE (item) = ffecom_integer_type_node;
3014       item
3015         = build_array_type
3016           (tree_type,
3017            build_range_type (ffecom_integer_type_node,
3018                              ffecom_integer_zero_node,
3019                              item));
3020       list = build (CONSTRUCTOR, item, NULL_TREE, list);
3021       TREE_CONSTANT (list) = 1;
3022       TREE_STATIC (list) = 1;
3023       return list;
3024
3025     case FFEBLD_opARRTER:
3026       {
3027         ffetargetOffset i;
3028
3029         list = NULL_TREE;
3030         if (ffebld_arrter_pad (expr) == 0)
3031           item = NULL_TREE;
3032         else
3033           {
3034             assert (bt == FFEINFO_basictypeCHARACTER
3035                     && kt == FFEINFO_kindtypeCHARACTER1);
3036
3037             /* Becomes PURPOSE first time through loop.  */
3038             item = build_int_2 (ffebld_arrter_pad (expr), 0);
3039           }
3040
3041         for (i = 0; i < ffebld_arrter_size (expr); ++i)
3042           {
3043             ffebldConstantUnion cu
3044             = ffebld_constantarray_get (ffebld_arrter (expr), bt, kt, i);
3045
3046             t = ffecom_constantunion (&cu, bt, kt, tree_type);
3047
3048             if (list == NULL_TREE)
3049               /* Assume item is PURPOSE first time through loop.  */
3050               list = item = build_tree_list (item, t);
3051             else
3052               {
3053                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
3054                 item = TREE_CHAIN (item);
3055               }
3056           }
3057       }
3058
3059       item = build_int_2 ((ffebld_arrter_size (expr)
3060                           + ffebld_arrter_pad (expr)) - 1, 0);
3061       TREE_TYPE (item) = ffecom_integer_type_node;
3062       item
3063         = build_array_type
3064           (tree_type,
3065            build_range_type (ffecom_integer_type_node,
3066                              ffecom_integer_zero_node,
3067                              item));
3068       list = build (CONSTRUCTOR, item, NULL_TREE, list);
3069       TREE_CONSTANT (list) = 1;
3070       TREE_STATIC (list) = 1;
3071       return list;
3072
3073     case FFEBLD_opCONTER:
3074       assert (ffebld_conter_pad (expr) == 0);
3075       item
3076         = ffecom_constantunion (&ffebld_constant_union (ffebld_conter (expr)),
3077                                 bt, kt, tree_type);
3078       return item;
3079
3080     case FFEBLD_opSYMTER:
3081       if ((ffebld_symter_generic (expr) != FFEINTRIN_genNONE)
3082           || (ffebld_symter_specific (expr) != FFEINTRIN_specNONE))
3083         return ffecom_ptr_to_expr (expr);       /* Same as %REF(intrinsic). */
3084       s = ffebld_symter (expr);
3085       t = ffesymbol_hook (s).decl_tree;
3086
3087       if (assignp)
3088         {                       /* ASSIGN'ed-label expr. */
3089           if (ffe_is_ugly_assign ())
3090             {
3091               /* User explicitly wants ASSIGN'ed variables to be at the same
3092                  memory address as the variables when used in non-ASSIGN
3093                  contexts.  That can make old, arcane, non-standard code
3094                  work, but don't try to do it when a pointer wouldn't fit
3095                  in the normal variable (take other approach, and warn,
3096                  instead).  */
3097
3098               if (t == NULL_TREE)
3099                 {
3100                   s = ffecom_sym_transform_ (s);
3101                   t = ffesymbol_hook (s).decl_tree;
3102                   assert (t != NULL_TREE);
3103                 }
3104
3105               if (t == error_mark_node)
3106                 return t;
3107
3108               if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t)))
3109                   >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
3110                 {
3111                   if (ffesymbol_hook (s).addr)
3112                     t = ffecom_1 (INDIRECT_REF,
3113                                   TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3114                   return t;
3115                 }
3116
3117               if (ffesymbol_hook (s).assign_tree == NULL_TREE)
3118                 {
3119                   ffebad_start_msg ("ASSIGN'ed label cannot fit into `%A' at %0 -- using wider sibling",
3120                                     FFEBAD_severityWARNING);
3121                   ffebad_string (ffesymbol_text (s));
3122                   ffebad_here (0, ffesymbol_where_line (s),
3123                                ffesymbol_where_column (s));
3124                   ffebad_finish ();
3125                 }
3126             }
3127
3128           /* Don't use the normal variable's tree for ASSIGN, though mark
3129              it as in the system header (housekeeping).  Use an explicit,
3130              specially created sibling that is known to be wide enough
3131              to hold pointers to labels.  */
3132
3133           if (t != NULL_TREE
3134               && TREE_CODE (t) == VAR_DECL)
3135             DECL_IN_SYSTEM_HEADER (t) = 1;      /* Don't let -Wunused complain. */
3136
3137           t = ffesymbol_hook (s).assign_tree;
3138           if (t == NULL_TREE)
3139             {
3140               s = ffecom_sym_transform_assign_ (s);
3141               t = ffesymbol_hook (s).assign_tree;
3142               assert (t != NULL_TREE);
3143             }
3144         }
3145       else
3146         {
3147           if (t == NULL_TREE)
3148             {
3149               s = ffecom_sym_transform_ (s);
3150               t = ffesymbol_hook (s).decl_tree;
3151               assert (t != NULL_TREE);
3152             }
3153           if (ffesymbol_hook (s).addr)
3154             t = ffecom_1 (INDIRECT_REF,
3155                           TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3156         }
3157       return t;
3158
3159     case FFEBLD_opARRAYREF:
3160       return ffecom_arrayref_ (NULL_TREE, expr, 0);
3161
3162     case FFEBLD_opUPLUS:
3163       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3164       return ffecom_1 (NOP_EXPR, tree_type, left);
3165
3166     case FFEBLD_opPAREN:
3167       /* ~~~Make sure Fortran rules respected here */
3168       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3169       return ffecom_1 (NOP_EXPR, tree_type, left);
3170
3171     case FFEBLD_opUMINUS:
3172       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3173       if (tree_type_x)
3174         {
3175           tree_type = tree_type_x;
3176           left = convert (tree_type, left);
3177         }
3178       return ffecom_1 (NEGATE_EXPR, tree_type, left);
3179
3180     case FFEBLD_opADD:
3181       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3182       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3183       if (tree_type_x)
3184         {
3185           tree_type = tree_type_x;
3186           left = convert (tree_type, left);
3187           right = convert (tree_type, right);
3188         }
3189       return ffecom_2 (PLUS_EXPR, tree_type, left, right);
3190
3191     case FFEBLD_opSUBTRACT:
3192       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3193       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3194       if (tree_type_x)
3195         {
3196           tree_type = tree_type_x;
3197           left = convert (tree_type, left);
3198           right = convert (tree_type, right);
3199         }
3200       return ffecom_2 (MINUS_EXPR, tree_type, left, right);
3201
3202     case FFEBLD_opMULTIPLY:
3203       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3204       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3205       if (tree_type_x)
3206         {
3207           tree_type = tree_type_x;
3208           left = convert (tree_type, left);
3209           right = convert (tree_type, right);
3210         }
3211       return ffecom_2 (MULT_EXPR, tree_type, left, right);
3212
3213     case FFEBLD_opDIVIDE:
3214       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3215       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3216       if (tree_type_x)
3217         {
3218           tree_type = tree_type_x;
3219           left = convert (tree_type, left);
3220           right = convert (tree_type, right);
3221         }
3222       return ffecom_tree_divide_ (tree_type, left, right,
3223                                   dest_tree, dest, dest_used,
3224                                   ffebld_nonter_hook (expr));
3225
3226     case FFEBLD_opPOWER:
3227       {
3228         ffebld left = ffebld_left (expr);
3229         ffebld right = ffebld_right (expr);
3230         ffecomGfrt code;
3231         ffeinfoKindtype rtkt;
3232         ffeinfoKindtype ltkt;
3233         bool ref = TRUE;
3234
3235         switch (ffeinfo_basictype (ffebld_info (right)))
3236           {
3237
3238           case FFEINFO_basictypeINTEGER:
3239             if (1 || optimize)
3240               {
3241                 item = ffecom_expr_power_integer_ (expr);
3242                 if (item != NULL_TREE)
3243                   return item;
3244               }
3245
3246             rtkt = FFEINFO_kindtypeINTEGER1;
3247             switch (ffeinfo_basictype (ffebld_info (left)))
3248               {
3249               case FFEINFO_basictypeINTEGER:
3250                 if ((ffeinfo_kindtype (ffebld_info (left))
3251                     == FFEINFO_kindtypeINTEGER4)
3252                     || (ffeinfo_kindtype (ffebld_info (right))
3253                         == FFEINFO_kindtypeINTEGER4))
3254                   {
3255                     code = FFECOM_gfrtPOW_QQ;
3256                     ltkt = FFEINFO_kindtypeINTEGER4;
3257                     rtkt = FFEINFO_kindtypeINTEGER4;
3258                   }
3259                 else
3260                   {
3261                     code = FFECOM_gfrtPOW_II;
3262                     ltkt = FFEINFO_kindtypeINTEGER1;
3263                   }
3264                 break;
3265
3266               case FFEINFO_basictypeREAL:
3267                 if (ffeinfo_kindtype (ffebld_info (left))
3268                     == FFEINFO_kindtypeREAL1)
3269                   {
3270                     code = FFECOM_gfrtPOW_RI;
3271                     ltkt = FFEINFO_kindtypeREAL1;
3272                   }
3273                 else
3274                   {
3275                     code = FFECOM_gfrtPOW_DI;
3276                     ltkt = FFEINFO_kindtypeREAL2;
3277                   }
3278                 break;
3279
3280               case FFEINFO_basictypeCOMPLEX:
3281                 if (ffeinfo_kindtype (ffebld_info (left))
3282                     == FFEINFO_kindtypeREAL1)
3283                   {
3284                     code = FFECOM_gfrtPOW_CI;   /* Overlapping result okay. */
3285                     ltkt = FFEINFO_kindtypeREAL1;
3286                   }
3287                 else
3288                   {
3289                     code = FFECOM_gfrtPOW_ZI;   /* Overlapping result okay. */
3290                     ltkt = FFEINFO_kindtypeREAL2;
3291                   }
3292                 break;
3293
3294               default:
3295                 assert ("bad pow_*i" == NULL);
3296                 code = FFECOM_gfrtPOW_CI;       /* Overlapping result okay. */
3297                 ltkt = FFEINFO_kindtypeREAL1;
3298                 break;
3299               }
3300             if (ffeinfo_kindtype (ffebld_info (left)) != ltkt)
3301               left = ffeexpr_convert (left, NULL, NULL,
3302                                       ffeinfo_basictype (ffebld_info (left)),
3303                                       ltkt, 0,
3304                                       FFETARGET_charactersizeNONE,
3305                                       FFEEXPR_contextLET);
3306             if (ffeinfo_kindtype (ffebld_info (right)) != rtkt)
3307               right = ffeexpr_convert (right, NULL, NULL,
3308                                        FFEINFO_basictypeINTEGER,
3309                                        rtkt, 0,
3310                                        FFETARGET_charactersizeNONE,
3311                                        FFEEXPR_contextLET);
3312             break;
3313
3314           case FFEINFO_basictypeREAL:
3315             if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3316               left = ffeexpr_convert (left, NULL, NULL, FFEINFO_basictypeREAL,
3317                                       FFEINFO_kindtypeREALDOUBLE, 0,
3318                                       FFETARGET_charactersizeNONE,
3319                                       FFEEXPR_contextLET);
3320             if (ffeinfo_kindtype (ffebld_info (right))
3321                 == FFEINFO_kindtypeREAL1)
3322               right = ffeexpr_convert (right, NULL, NULL,
3323                                        FFEINFO_basictypeREAL,
3324                                        FFEINFO_kindtypeREALDOUBLE, 0,
3325                                        FFETARGET_charactersizeNONE,
3326                                        FFEEXPR_contextLET);
3327             /* We used to call FFECOM_gfrtPOW_DD here,
3328                which passes arguments by reference.  */
3329             code = FFECOM_gfrtL_POW;
3330             /* Pass arguments by value. */
3331             ref  = FALSE;
3332             break;
3333
3334           case FFEINFO_basictypeCOMPLEX:
3335             if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3336               left = ffeexpr_convert (left, NULL, NULL,
3337                                       FFEINFO_basictypeCOMPLEX,
3338                                       FFEINFO_kindtypeREALDOUBLE, 0,
3339                                       FFETARGET_charactersizeNONE,
3340                                       FFEEXPR_contextLET);
3341             if (ffeinfo_kindtype (ffebld_info (right))
3342                 == FFEINFO_kindtypeREAL1)
3343               right = ffeexpr_convert (right, NULL, NULL,
3344                                        FFEINFO_basictypeCOMPLEX,
3345                                        FFEINFO_kindtypeREALDOUBLE, 0,
3346                                        FFETARGET_charactersizeNONE,
3347                                        FFEEXPR_contextLET);
3348             code = FFECOM_gfrtPOW_ZZ;   /* Overlapping result okay. */
3349             ref = TRUE;                 /* Pass arguments by reference. */
3350             break;
3351
3352           default:
3353             assert ("bad pow_x*" == NULL);
3354             code = FFECOM_gfrtPOW_II;
3355             break;
3356           }
3357         return ffecom_call_binop_ (ffecom_gfrt_tree_ (code),
3358                                    ffecom_gfrt_kindtype (code),
3359                                    (ffe_is_f2c_library ()
3360                                     && ffecom_gfrt_complex_[code]),
3361                                    tree_type, left, right,
3362                                    dest_tree, dest, dest_used,
3363                                    NULL_TREE, FALSE, ref,
3364                                    ffebld_nonter_hook (expr));
3365       }
3366
3367     case FFEBLD_opNOT:
3368       switch (bt)
3369         {
3370         case FFEINFO_basictypeLOGICAL:
3371           item = ffecom_truth_value_invert (ffecom_expr (ffebld_left (expr)));
3372           return convert (tree_type, item);
3373
3374         case FFEINFO_basictypeINTEGER:
3375           return ffecom_1 (BIT_NOT_EXPR, tree_type,
3376                            ffecom_expr (ffebld_left (expr)));
3377
3378         default:
3379           assert ("NOT bad basictype" == NULL);
3380           /* Fall through. */
3381         case FFEINFO_basictypeANY:
3382           return error_mark_node;
3383         }
3384       break;
3385
3386     case FFEBLD_opFUNCREF:
3387       assert (ffeinfo_basictype (ffebld_info (expr))
3388               != FFEINFO_basictypeCHARACTER);
3389       /* Fall through.   */
3390     case FFEBLD_opSUBRREF:
3391       if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
3392           == FFEINFO_whereINTRINSIC)
3393         {                       /* Invocation of an intrinsic. */
3394           item = ffecom_expr_intrinsic_ (expr, dest_tree, dest,
3395                                          dest_used);
3396           return item;
3397         }
3398       s = ffebld_symter (ffebld_left (expr));
3399       dt = ffesymbol_hook (s).decl_tree;
3400       if (dt == NULL_TREE)
3401         {
3402           s = ffecom_sym_transform_ (s);
3403           dt = ffesymbol_hook (s).decl_tree;
3404         }
3405       if (dt == error_mark_node)
3406         return dt;
3407
3408       if (ffesymbol_hook (s).addr)
3409         item = dt;
3410       else
3411         item = ffecom_1_fn (dt);
3412
3413       if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
3414         args = ffecom_list_expr (ffebld_right (expr));
3415       else
3416         args = ffecom_list_ptr_to_expr (ffebld_right (expr));
3417
3418       if (args == error_mark_node)
3419         return error_mark_node;
3420
3421       item = ffecom_call_ (item, kt,
3422                            ffesymbol_is_f2c (s)
3423                            && (bt == FFEINFO_basictypeCOMPLEX)
3424                            && (ffesymbol_where (s)
3425                                != FFEINFO_whereCONSTANT),
3426                            tree_type,
3427                            args,
3428                            dest_tree, dest, dest_used,
3429                            error_mark_node, FALSE,
3430                            ffebld_nonter_hook (expr));
3431       TREE_SIDE_EFFECTS (item) = 1;
3432       return item;
3433
3434     case FFEBLD_opAND:
3435       switch (bt)
3436         {
3437         case FFEINFO_basictypeLOGICAL:
3438           item
3439             = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3440                        ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3441                      ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3442           return convert (tree_type, item);
3443
3444         case FFEINFO_basictypeINTEGER:
3445           return ffecom_2 (BIT_AND_EXPR, tree_type,
3446                            ffecom_expr (ffebld_left (expr)),
3447                            ffecom_expr (ffebld_right (expr)));
3448
3449         default:
3450           assert ("AND bad basictype" == NULL);
3451           /* Fall through. */
3452         case FFEINFO_basictypeANY:
3453           return error_mark_node;
3454         }
3455       break;
3456
3457     case FFEBLD_opOR:
3458       switch (bt)
3459         {
3460         case FFEINFO_basictypeLOGICAL:
3461           item
3462             = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
3463                        ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3464                      ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3465           return convert (tree_type, item);
3466
3467         case FFEINFO_basictypeINTEGER:
3468           return ffecom_2 (BIT_IOR_EXPR, tree_type,
3469                            ffecom_expr (ffebld_left (expr)),
3470                            ffecom_expr (ffebld_right (expr)));
3471
3472         default:
3473           assert ("OR bad basictype" == NULL);
3474           /* Fall through. */
3475         case FFEINFO_basictypeANY:
3476           return error_mark_node;
3477         }
3478       break;
3479
3480     case FFEBLD_opXOR:
3481     case FFEBLD_opNEQV:
3482       switch (bt)
3483         {
3484         case FFEINFO_basictypeLOGICAL:
3485           item
3486             = ffecom_2 (NE_EXPR, integer_type_node,
3487                         ffecom_expr (ffebld_left (expr)),
3488                         ffecom_expr (ffebld_right (expr)));
3489           return convert (tree_type, ffecom_truth_value (item));
3490
3491         case FFEINFO_basictypeINTEGER:
3492           return ffecom_2 (BIT_XOR_EXPR, tree_type,
3493                            ffecom_expr (ffebld_left (expr)),
3494                            ffecom_expr (ffebld_right (expr)));
3495
3496         default:
3497           assert ("XOR/NEQV bad basictype" == NULL);
3498           /* Fall through. */
3499         case FFEINFO_basictypeANY:
3500           return error_mark_node;
3501         }
3502       break;
3503
3504     case FFEBLD_opEQV:
3505       switch (bt)
3506         {
3507         case FFEINFO_basictypeLOGICAL:
3508           item
3509             = ffecom_2 (EQ_EXPR, integer_type_node,
3510                         ffecom_expr (ffebld_left (expr)),
3511                         ffecom_expr (ffebld_right (expr)));
3512           return convert (tree_type, ffecom_truth_value (item));
3513
3514         case FFEINFO_basictypeINTEGER:
3515           return
3516             ffecom_1 (BIT_NOT_EXPR, tree_type,
3517                       ffecom_2 (BIT_XOR_EXPR, tree_type,
3518                                 ffecom_expr (ffebld_left (expr)),
3519                                 ffecom_expr (ffebld_right (expr))));
3520
3521         default:
3522           assert ("EQV bad basictype" == NULL);
3523           /* Fall through. */
3524         case FFEINFO_basictypeANY:
3525           return error_mark_node;
3526         }
3527       break;
3528
3529     case FFEBLD_opCONVERT:
3530       if (ffebld_op (ffebld_left (expr)) == FFEBLD_opANY)
3531         return error_mark_node;
3532
3533       switch (bt)
3534         {
3535         case FFEINFO_basictypeLOGICAL:
3536         case FFEINFO_basictypeINTEGER:
3537         case FFEINFO_basictypeREAL:
3538           return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3539
3540         case FFEINFO_basictypeCOMPLEX:
3541           switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3542             {
3543             case FFEINFO_basictypeINTEGER:
3544             case FFEINFO_basictypeLOGICAL:
3545             case FFEINFO_basictypeREAL:
3546               item = ffecom_expr (ffebld_left (expr));
3547               if (item == error_mark_node)
3548                 return error_mark_node;
3549               /* convert() takes care of converting to the subtype first,
3550                  at least in gcc-2.7.2. */
3551               item = convert (tree_type, item);
3552               return item;
3553
3554             case FFEINFO_basictypeCOMPLEX:
3555               return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3556
3557             default:
3558               assert ("CONVERT COMPLEX bad basictype" == NULL);
3559               /* Fall through. */
3560             case FFEINFO_basictypeANY:
3561               return error_mark_node;
3562             }
3563           break;
3564
3565         default:
3566           assert ("CONVERT bad basictype" == NULL);
3567           /* Fall through. */
3568         case FFEINFO_basictypeANY:
3569           return error_mark_node;
3570         }
3571       break;
3572
3573     case FFEBLD_opLT:
3574       code = LT_EXPR;
3575       goto relational;          /* :::::::::::::::::::: */
3576
3577     case FFEBLD_opLE:
3578       code = LE_EXPR;
3579       goto relational;          /* :::::::::::::::::::: */
3580
3581     case FFEBLD_opEQ:
3582       code = EQ_EXPR;
3583       goto relational;          /* :::::::::::::::::::: */
3584
3585     case FFEBLD_opNE:
3586       code = NE_EXPR;
3587       goto relational;          /* :::::::::::::::::::: */
3588
3589     case FFEBLD_opGT:
3590       code = GT_EXPR;
3591       goto relational;          /* :::::::::::::::::::: */
3592
3593     case FFEBLD_opGE:
3594       code = GE_EXPR;
3595
3596     relational:         /* :::::::::::::::::::: */
3597       switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3598         {
3599         case FFEINFO_basictypeLOGICAL:
3600         case FFEINFO_basictypeINTEGER:
3601         case FFEINFO_basictypeREAL:
3602           item = ffecom_2 (code, integer_type_node,
3603                            ffecom_expr (ffebld_left (expr)),
3604                            ffecom_expr (ffebld_right (expr)));
3605           return convert (tree_type, item);
3606
3607         case FFEINFO_basictypeCOMPLEX:
3608           assert (code == EQ_EXPR || code == NE_EXPR);
3609           {
3610             tree real_type;
3611             tree arg1 = ffecom_expr (ffebld_left (expr));
3612             tree arg2 = ffecom_expr (ffebld_right (expr));
3613
3614             if (arg1 == error_mark_node || arg2 == error_mark_node)
3615               return error_mark_node;
3616
3617             arg1 = ffecom_save_tree (arg1);
3618             arg2 = ffecom_save_tree (arg2);
3619
3620             if (TREE_CODE (TREE_TYPE (arg1)) == COMPLEX_TYPE)
3621               {
3622                 real_type = TREE_TYPE (TREE_TYPE (arg1));
3623                 assert (real_type == TREE_TYPE (TREE_TYPE (arg2)));
3624               }
3625             else
3626               {
3627                 real_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg1)));
3628                 assert (real_type == TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg2))));
3629               }
3630
3631             item
3632               = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3633                           ffecom_2 (EQ_EXPR, integer_type_node,
3634                                   ffecom_1 (REALPART_EXPR, real_type, arg1),
3635                                  ffecom_1 (REALPART_EXPR, real_type, arg2)),
3636                           ffecom_2 (EQ_EXPR, integer_type_node,
3637                                   ffecom_1 (IMAGPART_EXPR, real_type, arg1),
3638                                     ffecom_1 (IMAGPART_EXPR, real_type,
3639                                               arg2)));
3640             if (code == EQ_EXPR)
3641               item = ffecom_truth_value (item);
3642             else
3643               item = ffecom_truth_value_invert (item);
3644             return convert (tree_type, item);
3645           }
3646
3647         case FFEINFO_basictypeCHARACTER:
3648           {
3649             ffebld left = ffebld_left (expr);
3650             ffebld right = ffebld_right (expr);
3651             tree left_tree;
3652             tree right_tree;
3653             tree left_length;
3654             tree right_length;
3655
3656             /* f2c run-time functions do the implicit blank-padding for us,
3657                so we don't usually have to implement blank-padding ourselves.
3658                (The exception is when we pass an argument to a separately
3659                compiled statement function -- if we know the arg is not the
3660                same length as the dummy, we must truncate or extend it.  If
3661                we "inline" statement functions, that necessity goes away as
3662                well.)
3663
3664                Strip off the CONVERT operators that blank-pad.  (Truncation by
3665                CONVERT shouldn't happen here, but it can happen in
3666                assignments.) */
3667
3668             while (ffebld_op (left) == FFEBLD_opCONVERT)
3669               left = ffebld_left (left);
3670             while (ffebld_op (right) == FFEBLD_opCONVERT)
3671               right = ffebld_left (right);
3672
3673             left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
3674             right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
3675
3676             if (left_tree == error_mark_node || left_length == error_mark_node
3677                 || right_tree == error_mark_node
3678                 || right_length == error_mark_node)
3679               return error_mark_node;
3680
3681             if ((ffebld_size_known (left) == 1)
3682                 && (ffebld_size_known (right) == 1))
3683               {
3684                 left_tree
3685                   = ffecom_1 (INDIRECT_REF,
3686                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3687                               left_tree);
3688                 right_tree
3689                   = ffecom_1 (INDIRECT_REF,
3690                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3691                               right_tree);
3692
3693                 item
3694                   = ffecom_2 (code, integer_type_node,
3695                               ffecom_2 (ARRAY_REF,
3696                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3697                                         left_tree,
3698                                         integer_one_node),
3699                               ffecom_2 (ARRAY_REF,
3700                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3701                                         right_tree,
3702                                         integer_one_node));
3703               }
3704             else
3705               {
3706                 item = build_tree_list (NULL_TREE, left_tree);
3707                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, right_tree);
3708                 TREE_CHAIN (TREE_CHAIN (item)) = build_tree_list (NULL_TREE,
3709                                                                left_length);
3710                 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
3711                   = build_tree_list (NULL_TREE, right_length);
3712                 item = ffecom_call_gfrt (FFECOM_gfrtCMP, item, NULL_TREE);
3713                 item = ffecom_2 (code, integer_type_node,
3714                                  item,
3715                                  convert (TREE_TYPE (item),
3716                                           integer_zero_node));
3717               }
3718             item = convert (tree_type, item);
3719           }
3720
3721           return item;
3722
3723         default:
3724           assert ("relational bad basictype" == NULL);
3725           /* Fall through. */
3726         case FFEINFO_basictypeANY:
3727           return error_mark_node;
3728         }
3729       break;
3730
3731     case FFEBLD_opPERCENT_LOC:
3732       item = ffecom_arg_ptr_to_expr (ffebld_left (expr), &list);
3733       return convert (tree_type, item);
3734
3735     case FFEBLD_opITEM:
3736     case FFEBLD_opSTAR:
3737     case FFEBLD_opBOUNDS:
3738     case FFEBLD_opREPEAT:
3739     case FFEBLD_opLABTER:
3740     case FFEBLD_opLABTOK:
3741     case FFEBLD_opIMPDO:
3742     case FFEBLD_opCONCATENATE:
3743     case FFEBLD_opSUBSTR:
3744     default:
3745       assert ("bad op" == NULL);
3746       /* Fall through. */
3747     case FFEBLD_opANY:
3748       return error_mark_node;
3749     }
3750
3751 #if 1
3752   assert ("didn't think anything got here anymore!!" == NULL);
3753 #else
3754   switch (ffebld_arity (expr))
3755     {
3756     case 2:
3757       TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3758       TREE_OPERAND (item, 1) = ffecom_expr (ffebld_right (expr));
3759       if (TREE_OPERAND (item, 0) == error_mark_node
3760           || TREE_OPERAND (item, 1) == error_mark_node)
3761         return error_mark_node;
3762       break;
3763
3764     case 1:
3765       TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3766       if (TREE_OPERAND (item, 0) == error_mark_node)
3767         return error_mark_node;
3768       break;
3769
3770     default:
3771       break;
3772     }
3773
3774   return fold (item);
3775 #endif
3776 }
3777
3778 /* Returns the tree that does the intrinsic invocation.
3779
3780    Note: this function applies only to intrinsics returning
3781    CHARACTER*1 or non-CHARACTER results, and to intrinsic
3782    subroutines.  */
3783
3784 static tree
3785 ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
3786                         ffebld dest, bool *dest_used)
3787 {
3788   tree expr_tree;
3789   tree saved_expr1;             /* For those who need it. */
3790   tree saved_expr2;             /* For those who need it. */
3791   ffeinfoBasictype bt;
3792   ffeinfoKindtype kt;
3793   tree tree_type;
3794   tree arg1_type;
3795   tree real_type;               /* REAL type corresponding to COMPLEX. */
3796   tree tempvar;
3797   ffebld list = ffebld_right (expr);    /* List of (some) args. */
3798   ffebld arg1;                  /* For handy reference. */
3799   ffebld arg2;
3800   ffebld arg3;
3801   ffeintrinImp codegen_imp;
3802   ffecomGfrt gfrt;
3803
3804   assert (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER);
3805
3806   if (dest_used != NULL)
3807     *dest_used = FALSE;
3808
3809   bt = ffeinfo_basictype (ffebld_info (expr));
3810   kt = ffeinfo_kindtype (ffebld_info (expr));
3811   tree_type = ffecom_tree_type[bt][kt];
3812
3813   if (list != NULL)
3814     {
3815       arg1 = ffebld_head (list);
3816       if (arg1 != NULL && ffebld_op (arg1) == FFEBLD_opANY)
3817         return error_mark_node;
3818       if ((list = ffebld_trail (list)) != NULL)
3819         {
3820           arg2 = ffebld_head (list);
3821           if (arg2 != NULL && ffebld_op (arg2) == FFEBLD_opANY)
3822             return error_mark_node;
3823           if ((list = ffebld_trail (list)) != NULL)
3824             {
3825               arg3 = ffebld_head (list);
3826               if (arg3 != NULL && ffebld_op (arg3) == FFEBLD_opANY)
3827                 return error_mark_node;
3828             }
3829           else
3830             arg3 = NULL;
3831         }
3832       else
3833         arg2 = arg3 = NULL;
3834     }
3835   else
3836     arg1 = arg2 = arg3 = NULL;
3837
3838   /* <list> ends up at the opITEM of the 3rd arg, or NULL if there are < 3
3839      args.  This is used by the MAX/MIN expansions. */
3840
3841   if (arg1 != NULL)
3842     arg1_type = ffecom_tree_type
3843       [ffeinfo_basictype (ffebld_info (arg1))]
3844       [ffeinfo_kindtype (ffebld_info (arg1))];
3845   else
3846     arg1_type = NULL_TREE;      /* Really not needed, but might catch bugs
3847                                    here. */
3848
3849   /* There are several ways for each of the cases in the following switch
3850      statements to exit (from simplest to use to most complicated):
3851
3852      break;  (when expr_tree == NULL)
3853
3854      A standard call is made to the specific intrinsic just as if it had been
3855      passed in as a dummy procedure and called as any old procedure.  This
3856      method can produce slower code but in some cases it's the easiest way for
3857      now.  However, if a (presumably faster) direct call is available,
3858      that is used, so this is the easiest way in many more cases now.
3859
3860      gfrt = FFECOM_gfrtWHATEVER;
3861      break;
3862
3863      gfrt contains the gfrt index of a library function to call, passing the
3864      argument(s) by value rather than by reference.  Used when a more
3865      careful choice of library function is needed than that provided
3866      by the vanilla `break;'.
3867
3868      return expr_tree;
3869
3870      The expr_tree has been completely set up and is ready to be returned
3871      as is.  No further actions are taken.  Use this when the tree is not
3872      in the simple form for one of the arity_n labels.   */
3873
3874   /* For info on how the switch statement cases were written, see the files
3875      enclosed in comments below the switch statement. */
3876
3877   codegen_imp = ffebld_symter_implementation (ffebld_left (expr));
3878   gfrt = ffeintrin_gfrt_direct (codegen_imp);
3879   if (gfrt == FFECOM_gfrt)
3880     gfrt = ffeintrin_gfrt_indirect (codegen_imp);
3881
3882   switch (codegen_imp)
3883     {
3884     case FFEINTRIN_impABS:
3885     case FFEINTRIN_impCABS:
3886     case FFEINTRIN_impCDABS:
3887     case FFEINTRIN_impDABS:
3888     case FFEINTRIN_impIABS:
3889       if (ffeinfo_basictype (ffebld_info (arg1))
3890           == FFEINFO_basictypeCOMPLEX)
3891         {
3892           if (kt == FFEINFO_kindtypeREAL1)
3893             gfrt = FFECOM_gfrtCABS;
3894           else if (kt == FFEINFO_kindtypeREAL2)
3895             gfrt = FFECOM_gfrtCDABS;
3896           break;
3897         }
3898       return ffecom_1 (ABS_EXPR, tree_type,
3899                        convert (tree_type, ffecom_expr (arg1)));
3900
3901     case FFEINTRIN_impACOS:
3902     case FFEINTRIN_impDACOS:
3903       break;
3904
3905     case FFEINTRIN_impAIMAG:
3906     case FFEINTRIN_impDIMAG:
3907     case FFEINTRIN_impIMAGPART:
3908       if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
3909         arg1_type = TREE_TYPE (arg1_type);
3910       else
3911         arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
3912
3913       return
3914         convert (tree_type,
3915                  ffecom_1 (IMAGPART_EXPR, arg1_type,
3916                            ffecom_expr (arg1)));
3917
3918     case FFEINTRIN_impAINT:
3919     case FFEINTRIN_impDINT:
3920 #if 0
3921       /* ~~Someday implement FIX_TRUNC_EXPR yielding same type as arg.  */
3922       return ffecom_1 (FIX_TRUNC_EXPR, tree_type, ffecom_expr (arg1));
3923 #else /* in the meantime, must use floor to avoid range problems with ints */
3924       /* r__1 = r1 >= 0 ? floor(r1) : -floor(-r1); */
3925       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
3926       return
3927         convert (tree_type,
3928                  ffecom_3 (COND_EXPR, double_type_node,
3929                            ffecom_truth_value
3930                            (ffecom_2 (GE_EXPR, integer_type_node,
3931                                       saved_expr1,
3932                                       convert (arg1_type,
3933                                                ffecom_float_zero_))),
3934                            ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
3935                                              build_tree_list (NULL_TREE,
3936                                                   convert (double_type_node,
3937                                                            saved_expr1)),
3938                                              NULL_TREE),
3939                            ffecom_1 (NEGATE_EXPR, double_type_node,
3940                                      ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
3941                                                  build_tree_list (NULL_TREE,
3942                                                   convert (double_type_node,
3943                                                       ffecom_1 (NEGATE_EXPR,
3944                                                                 arg1_type,
3945                                                                saved_expr1))),
3946                                                        NULL_TREE)
3947                                      ))
3948                  );
3949 #endif
3950
3951     case FFEINTRIN_impANINT:
3952     case FFEINTRIN_impDNINT:
3953 #if 0                           /* This way of doing it won't handle real
3954                                    numbers of large magnitudes. */
3955       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
3956       expr_tree = convert (tree_type,
3957                            convert (integer_type_node,
3958                                     ffecom_3 (COND_EXPR, tree_type,
3959                                               ffecom_truth_value
3960                                               (ffecom_2 (GE_EXPR,
3961                                                          integer_type_node,
3962                                                          saved_expr1,
3963                                                        ffecom_float_zero_)),
3964                                               ffecom_2 (PLUS_EXPR,
3965                                                         tree_type,
3966                                                         saved_expr1,
3967                                                         ffecom_float_half_),
3968                                               ffecom_2 (MINUS_EXPR,
3969                                                         tree_type,
3970                                                         saved_expr1,
3971                                                      ffecom_float_half_))));
3972       return expr_tree;
3973 #else /* So we instead call floor. */
3974       /* r__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1) */
3975       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
3976       return
3977         convert (tree_type,
3978                  ffecom_3 (COND_EXPR, double_type_node,
3979                            ffecom_truth_value
3980                            (ffecom_2 (GE_EXPR, integer_type_node,
3981                                       saved_expr1,
3982                                       convert (arg1_type,
3983                                                ffecom_float_zero_))),
3984                            ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
3985                                              build_tree_list (NULL_TREE,
3986                                                   convert (double_type_node,
3987                                                            ffecom_2 (PLUS_EXPR,
3988                                                                      arg1_type,
3989                                                                      saved_expr1,
3990                                                                      convert (arg1_type,
3991                                                                               ffecom_float_half_)))),
3992                                              NULL_TREE),
3993                            ffecom_1 (NEGATE_EXPR, double_type_node,
3994                                      ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
3995                                                        build_tree_list (NULL_TREE,
3996                                                                         convert (double_type_node,
3997                                                                                  ffecom_2 (MINUS_EXPR,
3998                                                                                            arg1_type,
3999                                                                                            convert (arg1_type,
4000                                                                                                     ffecom_float_half_),
4001                                                                                            saved_expr1))),
4002                                                        NULL_TREE))
4003                            )
4004                  );
4005 #endif
4006
4007     case FFEINTRIN_impASIN:
4008     case FFEINTRIN_impDASIN:
4009     case FFEINTRIN_impATAN:
4010     case FFEINTRIN_impDATAN:
4011     case FFEINTRIN_impATAN2:
4012     case FFEINTRIN_impDATAN2:
4013       break;
4014
4015     case FFEINTRIN_impCHAR:
4016     case FFEINTRIN_impACHAR:
4017 #ifdef HOHO
4018       tempvar = ffecom_make_tempvar (char_type_node, 1, -1);
4019 #else
4020       tempvar = ffebld_nonter_hook (expr);
4021       assert (tempvar);
4022 #endif
4023       {
4024         tree tmv = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (tempvar)));
4025
4026         expr_tree = ffecom_modify (tmv,
4027                                    ffecom_2 (ARRAY_REF, tmv, tempvar,
4028                                              integer_one_node),
4029                                    convert (tmv, ffecom_expr (arg1)));
4030       }
4031       expr_tree = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar),
4032                             expr_tree,
4033                             tempvar);
4034       expr_tree = ffecom_1 (ADDR_EXPR,
4035                             build_pointer_type (TREE_TYPE (expr_tree)),
4036                             expr_tree);
4037       return expr_tree;
4038
4039     case FFEINTRIN_impCMPLX:
4040     case FFEINTRIN_impDCMPLX:
4041       if (arg2 == NULL)
4042         return
4043           convert (tree_type, ffecom_expr (arg1));
4044
4045       real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4046       return
4047         ffecom_2 (COMPLEX_EXPR, tree_type,
4048                   convert (real_type, ffecom_expr (arg1)),
4049                   convert (real_type,
4050                            ffecom_expr (arg2)));
4051
4052     case FFEINTRIN_impCOMPLEX:
4053       return
4054         ffecom_2 (COMPLEX_EXPR, tree_type,
4055                   ffecom_expr (arg1),
4056                   ffecom_expr (arg2));
4057
4058     case FFEINTRIN_impCONJG:
4059     case FFEINTRIN_impDCONJG:
4060       {
4061         tree arg1_tree;
4062
4063         real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4064         arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4065         return
4066           ffecom_2 (COMPLEX_EXPR, tree_type,
4067                     ffecom_1 (REALPART_EXPR, real_type, arg1_tree),
4068                     ffecom_1 (NEGATE_EXPR, real_type,
4069                               ffecom_1 (IMAGPART_EXPR, real_type, arg1_tree)));
4070       }
4071
4072     case FFEINTRIN_impCOS:
4073     case FFEINTRIN_impCCOS:
4074     case FFEINTRIN_impCDCOS:
4075     case FFEINTRIN_impDCOS:
4076       if (bt == FFEINFO_basictypeCOMPLEX)
4077         {
4078           if (kt == FFEINFO_kindtypeREAL1)
4079             gfrt = FFECOM_gfrtCCOS;     /* Overlapping result okay. */
4080           else if (kt == FFEINFO_kindtypeREAL2)
4081             gfrt = FFECOM_gfrtCDCOS;    /* Overlapping result okay. */
4082         }
4083       break;
4084
4085     case FFEINTRIN_impCOSH:
4086     case FFEINTRIN_impDCOSH:
4087       break;
4088
4089     case FFEINTRIN_impDBLE:
4090     case FFEINTRIN_impDFLOAT:
4091     case FFEINTRIN_impDREAL:
4092     case FFEINTRIN_impFLOAT:
4093     case FFEINTRIN_impIDINT:
4094     case FFEINTRIN_impIFIX:
4095     case FFEINTRIN_impINT2:
4096     case FFEINTRIN_impINT8:
4097     case FFEINTRIN_impINT:
4098     case FFEINTRIN_impLONG:
4099     case FFEINTRIN_impREAL:
4100     case FFEINTRIN_impSHORT:
4101     case FFEINTRIN_impSNGL:
4102       return convert (tree_type, ffecom_expr (arg1));
4103
4104     case FFEINTRIN_impDIM:
4105     case FFEINTRIN_impDDIM:
4106     case FFEINTRIN_impIDIM:
4107       saved_expr1 = ffecom_save_tree (convert (tree_type,
4108                                                ffecom_expr (arg1)));
4109       saved_expr2 = ffecom_save_tree (convert (tree_type,
4110                                                ffecom_expr (arg2)));
4111       return
4112         ffecom_3 (COND_EXPR, tree_type,
4113                   ffecom_truth_value
4114                   (ffecom_2 (GT_EXPR, integer_type_node,
4115                              saved_expr1,
4116                              saved_expr2)),
4117                   ffecom_2 (MINUS_EXPR, tree_type,
4118                             saved_expr1,
4119                             saved_expr2),
4120                   convert (tree_type, ffecom_float_zero_));
4121
4122     case FFEINTRIN_impDPROD:
4123       return
4124         ffecom_2 (MULT_EXPR, tree_type,
4125                   convert (tree_type, ffecom_expr (arg1)),
4126                   convert (tree_type, ffecom_expr (arg2)));
4127
4128     case FFEINTRIN_impEXP:
4129     case FFEINTRIN_impCDEXP:
4130     case FFEINTRIN_impCEXP:
4131     case FFEINTRIN_impDEXP:
4132       if (bt == FFEINFO_basictypeCOMPLEX)
4133         {
4134           if (kt == FFEINFO_kindtypeREAL1)
4135             gfrt = FFECOM_gfrtCEXP;     /* Overlapping result okay. */
4136           else if (kt == FFEINFO_kindtypeREAL2)
4137             gfrt = FFECOM_gfrtCDEXP;    /* Overlapping result okay. */
4138         }
4139       break;
4140
4141     case FFEINTRIN_impICHAR:
4142     case FFEINTRIN_impIACHAR:
4143 #if 0                           /* The simple approach. */
4144       ffecom_char_args_ (&expr_tree, &saved_expr1 /* Ignored */ , arg1);
4145       expr_tree
4146         = ffecom_1 (INDIRECT_REF,
4147                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4148                     expr_tree);
4149       expr_tree
4150         = ffecom_2 (ARRAY_REF,
4151                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4152                     expr_tree,
4153                     integer_one_node);
4154       return convert (tree_type, expr_tree);
4155 #else /* The more interesting (and more optimal) approach. */
4156       expr_tree = ffecom_intrinsic_ichar_ (tree_type, arg1, &saved_expr1);
4157       expr_tree = ffecom_3 (COND_EXPR, tree_type,
4158                             saved_expr1,
4159                             expr_tree,
4160                             convert (tree_type, integer_zero_node));
4161       return expr_tree;
4162 #endif
4163
4164     case FFEINTRIN_impINDEX:
4165       break;
4166
4167     case FFEINTRIN_impLEN:
4168 #if 0
4169       break;                                    /* The simple approach. */
4170 #else
4171       return ffecom_intrinsic_len_ (arg1);      /* The more optimal approach. */
4172 #endif
4173
4174     case FFEINTRIN_impLGE:
4175     case FFEINTRIN_impLGT:
4176     case FFEINTRIN_impLLE:
4177     case FFEINTRIN_impLLT:
4178       break;
4179
4180     case FFEINTRIN_impLOG:
4181     case FFEINTRIN_impALOG:
4182     case FFEINTRIN_impCDLOG:
4183     case FFEINTRIN_impCLOG:
4184     case FFEINTRIN_impDLOG:
4185       if (bt == FFEINFO_basictypeCOMPLEX)
4186         {
4187           if (kt == FFEINFO_kindtypeREAL1)
4188             gfrt = FFECOM_gfrtCLOG;     /* Overlapping result okay. */
4189           else if (kt == FFEINFO_kindtypeREAL2)
4190             gfrt = FFECOM_gfrtCDLOG;    /* Overlapping result okay. */
4191         }
4192       break;
4193
4194     case FFEINTRIN_impLOG10:
4195     case FFEINTRIN_impALOG10:
4196     case FFEINTRIN_impDLOG10:
4197       if (gfrt != FFECOM_gfrt)
4198         break;  /* Already picked one, stick with it. */
4199
4200       if (kt == FFEINFO_kindtypeREAL1)
4201         /* We used to call FFECOM_gfrtALOG10 here.  */
4202         gfrt = FFECOM_gfrtL_LOG10;
4203       else if (kt == FFEINFO_kindtypeREAL2)
4204         /* We used to call FFECOM_gfrtDLOG10 here.  */
4205         gfrt = FFECOM_gfrtL_LOG10;
4206       break;
4207
4208     case FFEINTRIN_impMAX:
4209     case FFEINTRIN_impAMAX0:
4210     case FFEINTRIN_impAMAX1:
4211     case FFEINTRIN_impDMAX1:
4212     case FFEINTRIN_impMAX0:
4213     case FFEINTRIN_impMAX1:
4214       if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4215         arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4216       else
4217         arg1_type = tree_type;
4218       expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4219                             convert (arg1_type, ffecom_expr (arg1)),
4220                             convert (arg1_type, ffecom_expr (arg2)));
4221       for (; list != NULL; list = ffebld_trail (list))
4222         {
4223           if ((ffebld_head (list) == NULL)
4224               || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4225             continue;
4226           expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4227                                 expr_tree,
4228                                 convert (arg1_type,
4229                                          ffecom_expr (ffebld_head (list))));
4230         }
4231       return convert (tree_type, expr_tree);
4232
4233     case FFEINTRIN_impMIN:
4234     case FFEINTRIN_impAMIN0:
4235     case FFEINTRIN_impAMIN1:
4236     case FFEINTRIN_impDMIN1:
4237     case FFEINTRIN_impMIN0:
4238     case FFEINTRIN_impMIN1:
4239       if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4240         arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4241       else
4242         arg1_type = tree_type;
4243       expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4244                             convert (arg1_type, ffecom_expr (arg1)),
4245                             convert (arg1_type, ffecom_expr (arg2)));
4246       for (; list != NULL; list = ffebld_trail (list))
4247         {
4248           if ((ffebld_head (list) == NULL)
4249               || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4250             continue;
4251           expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4252                                 expr_tree,
4253                                 convert (arg1_type,
4254                                          ffecom_expr (ffebld_head (list))));
4255         }
4256       return convert (tree_type, expr_tree);
4257
4258     case FFEINTRIN_impMOD:
4259     case FFEINTRIN_impAMOD:
4260     case FFEINTRIN_impDMOD:
4261       if (bt != FFEINFO_basictypeREAL)
4262         return ffecom_2 (TRUNC_MOD_EXPR, tree_type,
4263                          convert (tree_type, ffecom_expr (arg1)),
4264                          convert (tree_type, ffecom_expr (arg2)));
4265
4266       if (kt == FFEINFO_kindtypeREAL1)
4267         /* We used to call FFECOM_gfrtAMOD here.  */
4268         gfrt = FFECOM_gfrtL_FMOD;
4269       else if (kt == FFEINFO_kindtypeREAL2)
4270         /* We used to call FFECOM_gfrtDMOD here.  */
4271         gfrt = FFECOM_gfrtL_FMOD;
4272       break;
4273
4274     case FFEINTRIN_impNINT:
4275     case FFEINTRIN_impIDNINT:
4276 #if 0
4277       /* ~~Ideally FIX_ROUND_EXPR would be implemented, but it ain't yet.  */
4278       return ffecom_1 (FIX_ROUND_EXPR, tree_type, ffecom_expr (arg1));
4279 #else
4280       /* i__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1); */
4281       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4282       return
4283         convert (ffecom_integer_type_node,
4284                  ffecom_3 (COND_EXPR, arg1_type,
4285                            ffecom_truth_value
4286                            (ffecom_2 (GE_EXPR, integer_type_node,
4287                                       saved_expr1,
4288                                       convert (arg1_type,
4289                                                ffecom_float_zero_))),
4290                            ffecom_2 (PLUS_EXPR, arg1_type,
4291                                      saved_expr1,
4292                                      convert (arg1_type,
4293                                               ffecom_float_half_)),
4294                            ffecom_2 (MINUS_EXPR, arg1_type,
4295                                      saved_expr1,
4296                                      convert (arg1_type,
4297                                               ffecom_float_half_))));
4298 #endif
4299
4300     case FFEINTRIN_impSIGN:
4301     case FFEINTRIN_impDSIGN:
4302     case FFEINTRIN_impISIGN:
4303       {
4304         tree arg2_tree = ffecom_expr (arg2);
4305
4306         saved_expr1
4307           = ffecom_save_tree
4308           (ffecom_1 (ABS_EXPR, tree_type,
4309                      convert (tree_type,
4310                               ffecom_expr (arg1))));
4311         expr_tree
4312           = ffecom_3 (COND_EXPR, tree_type,
4313                       ffecom_truth_value
4314                       (ffecom_2 (GE_EXPR, integer_type_node,
4315                                  arg2_tree,
4316                                  convert (TREE_TYPE (arg2_tree),
4317                                           integer_zero_node))),
4318                       saved_expr1,
4319                       ffecom_1 (NEGATE_EXPR, tree_type, saved_expr1));
4320         /* Make sure SAVE_EXPRs get referenced early enough. */
4321         expr_tree
4322           = ffecom_2 (COMPOUND_EXPR, tree_type,
4323                       convert (void_type_node, saved_expr1),
4324                       expr_tree);
4325       }
4326       return expr_tree;
4327
4328     case FFEINTRIN_impSIN:
4329     case FFEINTRIN_impCDSIN:
4330     case FFEINTRIN_impCSIN:
4331     case FFEINTRIN_impDSIN:
4332       if (bt == FFEINFO_basictypeCOMPLEX)
4333         {
4334           if (kt == FFEINFO_kindtypeREAL1)
4335             gfrt = FFECOM_gfrtCSIN;     /* Overlapping result okay. */
4336           else if (kt == FFEINFO_kindtypeREAL2)
4337             gfrt = FFECOM_gfrtCDSIN;    /* Overlapping result okay. */
4338         }
4339       break;
4340
4341     case FFEINTRIN_impSINH:
4342     case FFEINTRIN_impDSINH:
4343       break;
4344
4345     case FFEINTRIN_impSQRT:
4346     case FFEINTRIN_impCDSQRT:
4347     case FFEINTRIN_impCSQRT:
4348     case FFEINTRIN_impDSQRT:
4349       if (bt == FFEINFO_basictypeCOMPLEX)
4350         {
4351           if (kt == FFEINFO_kindtypeREAL1)
4352             gfrt = FFECOM_gfrtCSQRT;    /* Overlapping result okay. */
4353           else if (kt == FFEINFO_kindtypeREAL2)
4354             gfrt = FFECOM_gfrtCDSQRT;   /* Overlapping result okay. */
4355         }
4356       break;
4357
4358     case FFEINTRIN_impTAN:
4359     case FFEINTRIN_impDTAN:
4360     case FFEINTRIN_impTANH:
4361     case FFEINTRIN_impDTANH:
4362       break;
4363
4364     case FFEINTRIN_impREALPART:
4365       if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
4366         arg1_type = TREE_TYPE (arg1_type);
4367       else
4368         arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
4369
4370       return
4371         convert (tree_type,
4372                  ffecom_1 (REALPART_EXPR, arg1_type,
4373                            ffecom_expr (arg1)));
4374
4375     case FFEINTRIN_impIAND:
4376     case FFEINTRIN_impAND:
4377       return ffecom_2 (BIT_AND_EXPR, tree_type,
4378                        convert (tree_type,
4379                                 ffecom_expr (arg1)),
4380                        convert (tree_type,
4381                                 ffecom_expr (arg2)));
4382
4383     case FFEINTRIN_impIOR:
4384     case FFEINTRIN_impOR:
4385       return ffecom_2 (BIT_IOR_EXPR, tree_type,
4386                        convert (tree_type,
4387                                 ffecom_expr (arg1)),
4388                        convert (tree_type,
4389                                 ffecom_expr (arg2)));
4390
4391     case FFEINTRIN_impIEOR:
4392     case FFEINTRIN_impXOR:
4393       return ffecom_2 (BIT_XOR_EXPR, tree_type,
4394                        convert (tree_type,
4395                                 ffecom_expr (arg1)),
4396                        convert (tree_type,
4397                                 ffecom_expr (arg2)));
4398
4399     case FFEINTRIN_impLSHIFT:
4400       return ffecom_2 (LSHIFT_EXPR, tree_type,
4401                        ffecom_expr (arg1),
4402                        convert (integer_type_node,
4403                                 ffecom_expr (arg2)));
4404
4405     case FFEINTRIN_impRSHIFT:
4406       return ffecom_2 (RSHIFT_EXPR, tree_type,
4407                        ffecom_expr (arg1),
4408                        convert (integer_type_node,
4409                                 ffecom_expr (arg2)));
4410
4411     case FFEINTRIN_impNOT:
4412       return ffecom_1 (BIT_NOT_EXPR, tree_type, ffecom_expr (arg1));
4413
4414     case FFEINTRIN_impBIT_SIZE:
4415       return convert (tree_type, TYPE_SIZE (arg1_type));
4416
4417     case FFEINTRIN_impBTEST:
4418       {
4419         ffetargetLogical1 target_true;
4420         ffetargetLogical1 target_false;
4421         tree true_tree;
4422         tree false_tree;
4423
4424         ffetarget_logical1 (&target_true, TRUE);
4425         ffetarget_logical1 (&target_false, FALSE);
4426         if (target_true == 1)
4427           true_tree = convert (tree_type, integer_one_node);
4428         else
4429           true_tree = convert (tree_type, build_int_2 (target_true, 0));
4430         if (target_false == 0)
4431           false_tree = convert (tree_type, integer_zero_node);
4432         else
4433           false_tree = convert (tree_type, build_int_2 (target_false, 0));
4434
4435         return
4436           ffecom_3 (COND_EXPR, tree_type,
4437                     ffecom_truth_value
4438                     (ffecom_2 (EQ_EXPR, integer_type_node,
4439                                ffecom_2 (BIT_AND_EXPR, arg1_type,
4440                                          ffecom_expr (arg1),
4441                                          ffecom_2 (LSHIFT_EXPR, arg1_type,
4442                                                    convert (arg1_type,
4443                                                           integer_one_node),
4444                                                    convert (integer_type_node,
4445                                                             ffecom_expr (arg2)))),
4446                                convert (arg1_type,
4447                                         integer_zero_node))),
4448                     false_tree,
4449                     true_tree);
4450       }
4451
4452     case FFEINTRIN_impIBCLR:
4453       return
4454         ffecom_2 (BIT_AND_EXPR, tree_type,
4455                   ffecom_expr (arg1),
4456                   ffecom_1 (BIT_NOT_EXPR, tree_type,
4457                             ffecom_2 (LSHIFT_EXPR, tree_type,
4458                                       convert (tree_type,
4459                                                integer_one_node),
4460                                       convert (integer_type_node,
4461                                                ffecom_expr (arg2)))));
4462
4463     case FFEINTRIN_impIBITS:
4464       {
4465         tree arg3_tree = ffecom_save_tree (convert (integer_type_node,
4466                                                     ffecom_expr (arg3)));
4467         tree uns_type
4468         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4469
4470         expr_tree
4471           = ffecom_2 (BIT_AND_EXPR, tree_type,
4472                       ffecom_2 (RSHIFT_EXPR, tree_type,
4473                                 ffecom_expr (arg1),
4474                                 convert (integer_type_node,
4475                                          ffecom_expr (arg2))),
4476                       convert (tree_type,
4477                                ffecom_2 (RSHIFT_EXPR, uns_type,
4478                                          ffecom_1 (BIT_NOT_EXPR,
4479                                                    uns_type,
4480                                                    convert (uns_type,
4481                                                         integer_zero_node)),
4482                                          ffecom_2 (MINUS_EXPR,
4483                                                    integer_type_node,
4484                                                    TYPE_SIZE (uns_type),
4485                                                    arg3_tree))));
4486         /* Fix up, because the RSHIFT_EXPR above can't shift over TYPE_SIZE.  */
4487         expr_tree
4488           = ffecom_3 (COND_EXPR, tree_type,
4489                       ffecom_truth_value
4490                       (ffecom_2 (NE_EXPR, integer_type_node,
4491                                  arg3_tree,
4492                                  integer_zero_node)),
4493                       expr_tree,
4494                       convert (tree_type, integer_zero_node));
4495       }
4496       return expr_tree;
4497
4498     case FFEINTRIN_impIBSET:
4499       return
4500         ffecom_2 (BIT_IOR_EXPR, tree_type,
4501                   ffecom_expr (arg1),
4502                   ffecom_2 (LSHIFT_EXPR, tree_type,
4503                             convert (tree_type, integer_one_node),
4504                             convert (integer_type_node,
4505                                      ffecom_expr (arg2))));
4506
4507     case FFEINTRIN_impISHFT:
4508       {
4509         tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4510         tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4511                                                     ffecom_expr (arg2)));
4512         tree uns_type
4513         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4514
4515         expr_tree
4516           = ffecom_3 (COND_EXPR, tree_type,
4517                       ffecom_truth_value
4518                       (ffecom_2 (GE_EXPR, integer_type_node,
4519                                  arg2_tree,
4520                                  integer_zero_node)),
4521                       ffecom_2 (LSHIFT_EXPR, tree_type,
4522                                 arg1_tree,
4523                                 arg2_tree),
4524                       convert (tree_type,
4525                                ffecom_2 (RSHIFT_EXPR, uns_type,
4526                                          convert (uns_type, arg1_tree),
4527                                          ffecom_1 (NEGATE_EXPR,
4528                                                    integer_type_node,
4529                                                    arg2_tree))));
4530         /* Fix up, because {L|R}SHIFT_EXPR don't go over TYPE_SIZE bounds.  */
4531         expr_tree
4532           = ffecom_3 (COND_EXPR, tree_type,
4533                       ffecom_truth_value
4534                       (ffecom_2 (NE_EXPR, integer_type_node,
4535                                  ffecom_1 (ABS_EXPR,
4536                                            integer_type_node,
4537                                            arg2_tree),
4538                                  TYPE_SIZE (uns_type))),
4539                       expr_tree,
4540                       convert (tree_type, integer_zero_node));
4541         /* Make sure SAVE_EXPRs get referenced early enough. */
4542         expr_tree
4543           = ffecom_2 (COMPOUND_EXPR, tree_type,
4544                       convert (void_type_node, arg1_tree),
4545                       ffecom_2 (COMPOUND_EXPR, tree_type,
4546                                 convert (void_type_node, arg2_tree),
4547                                 expr_tree));
4548       }
4549       return expr_tree;
4550
4551     case FFEINTRIN_impISHFTC:
4552       {
4553         tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4554         tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4555                                                     ffecom_expr (arg2)));
4556         tree arg3_tree = (arg3 == NULL) ? TYPE_SIZE (tree_type)
4557         : ffecom_save_tree (convert (integer_type_node, ffecom_expr (arg3)));
4558         tree shift_neg;
4559         tree shift_pos;
4560         tree mask_arg1;
4561         tree masked_arg1;
4562         tree uns_type
4563         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4564
4565         mask_arg1
4566           = ffecom_2 (LSHIFT_EXPR, tree_type,
4567                       ffecom_1 (BIT_NOT_EXPR, tree_type,
4568                                 convert (tree_type, integer_zero_node)),
4569                       arg3_tree);
4570         /* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE.  */
4571         mask_arg1
4572           = ffecom_3 (COND_EXPR, tree_type,
4573                       ffecom_truth_value
4574                       (ffecom_2 (NE_EXPR, integer_type_node,
4575                                  arg3_tree,
4576                                  TYPE_SIZE (uns_type))),
4577                       mask_arg1,
4578                       convert (tree_type, integer_zero_node));
4579         mask_arg1 = ffecom_save_tree (mask_arg1);
4580         masked_arg1
4581           = ffecom_2 (BIT_AND_EXPR, tree_type,
4582                       arg1_tree,
4583                       ffecom_1 (BIT_NOT_EXPR, tree_type,
4584                                 mask_arg1));
4585         masked_arg1 = ffecom_save_tree (masked_arg1);
4586         shift_neg
4587           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4588                       convert (tree_type,
4589                                ffecom_2 (RSHIFT_EXPR, uns_type,
4590                                          convert (uns_type, masked_arg1),
4591                                          ffecom_1 (NEGATE_EXPR,
4592                                                    integer_type_node,
4593                                                    arg2_tree))),
4594                       ffecom_2 (LSHIFT_EXPR, tree_type,
4595                                 arg1_tree,
4596                                 ffecom_2 (PLUS_EXPR, integer_type_node,
4597                                           arg2_tree,
4598                                           arg3_tree)));
4599         shift_pos
4600           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4601                       ffecom_2 (LSHIFT_EXPR, tree_type,
4602                                 arg1_tree,
4603                                 arg2_tree),
4604                       convert (tree_type,
4605                                ffecom_2 (RSHIFT_EXPR, uns_type,
4606                                          convert (uns_type, masked_arg1),
4607                                          ffecom_2 (MINUS_EXPR,
4608                                                    integer_type_node,
4609                                                    arg3_tree,
4610                                                    arg2_tree))));
4611         expr_tree
4612           = ffecom_3 (COND_EXPR, tree_type,
4613                       ffecom_truth_value
4614                       (ffecom_2 (LT_EXPR, integer_type_node,
4615                                  arg2_tree,
4616                                  integer_zero_node)),
4617                       shift_neg,
4618                       shift_pos);
4619         expr_tree
4620           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4621                       ffecom_2 (BIT_AND_EXPR, tree_type,
4622                                 mask_arg1,
4623                                 arg1_tree),
4624                       ffecom_2 (BIT_AND_EXPR, tree_type,
4625                                 ffecom_1 (BIT_NOT_EXPR, tree_type,
4626                                           mask_arg1),
4627                                 expr_tree));
4628         expr_tree
4629           = ffecom_3 (COND_EXPR, tree_type,
4630                       ffecom_truth_value
4631                       (ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
4632                                  ffecom_2 (EQ_EXPR, integer_type_node,
4633                                            ffecom_1 (ABS_EXPR,
4634                                                      integer_type_node,
4635                                                      arg2_tree),
4636                                            arg3_tree),
4637                                  ffecom_2 (EQ_EXPR, integer_type_node,
4638                                            arg2_tree,
4639                                            integer_zero_node))),
4640                       arg1_tree,
4641                       expr_tree);
4642         /* Make sure SAVE_EXPRs get referenced early enough. */
4643         expr_tree
4644           = ffecom_2 (COMPOUND_EXPR, tree_type,
4645                       convert (void_type_node, arg1_tree),
4646                       ffecom_2 (COMPOUND_EXPR, tree_type,
4647                                 convert (void_type_node, arg2_tree),
4648                                 ffecom_2 (COMPOUND_EXPR, tree_type,
4649                                           convert (void_type_node,
4650                                                    mask_arg1),
4651                                           ffecom_2 (COMPOUND_EXPR, tree_type,
4652                                                     convert (void_type_node,
4653                                                              masked_arg1),
4654                                                     expr_tree))));
4655         expr_tree
4656           = ffecom_2 (COMPOUND_EXPR, tree_type,
4657                       convert (void_type_node,
4658                                arg3_tree),
4659                       expr_tree);
4660       }
4661       return expr_tree;
4662
4663     case FFEINTRIN_impLOC:
4664       {
4665         tree arg1_tree = ffecom_expr (arg1);
4666
4667         expr_tree
4668           = convert (tree_type,
4669                      ffecom_1 (ADDR_EXPR,
4670                                build_pointer_type (TREE_TYPE (arg1_tree)),
4671                                arg1_tree));
4672       }
4673       return expr_tree;
4674
4675     case FFEINTRIN_impMVBITS:
4676       {
4677         tree arg1_tree;
4678         tree arg2_tree;
4679         tree arg3_tree;
4680         ffebld arg4 = ffebld_head (ffebld_trail (list));
4681         tree arg4_tree;
4682         tree arg4_type;
4683         ffebld arg5 = ffebld_head (ffebld_trail (ffebld_trail (list)));
4684         tree arg5_tree;
4685         tree prep_arg1;
4686         tree prep_arg4;
4687         tree arg5_plus_arg3;
4688
4689         arg2_tree = convert (integer_type_node,
4690                              ffecom_expr (arg2));
4691         arg3_tree = ffecom_save_tree (convert (integer_type_node,
4692                                                ffecom_expr (arg3)));
4693         arg4_tree = ffecom_expr_rw (NULL_TREE, arg4);
4694         arg4_type = TREE_TYPE (arg4_tree);
4695
4696         arg1_tree = ffecom_save_tree (convert (arg4_type,
4697                                                ffecom_expr (arg1)));
4698
4699         arg5_tree = ffecom_save_tree (convert (integer_type_node,
4700                                                ffecom_expr (arg5)));
4701
4702         prep_arg1
4703           = ffecom_2 (LSHIFT_EXPR, arg4_type,
4704                       ffecom_2 (BIT_AND_EXPR, arg4_type,
4705                                 ffecom_2 (RSHIFT_EXPR, arg4_type,
4706                                           arg1_tree,
4707                                           arg2_tree),
4708                                 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4709                                           ffecom_2 (LSHIFT_EXPR, arg4_type,
4710                                                     ffecom_1 (BIT_NOT_EXPR,
4711                                                               arg4_type,
4712                                                               convert
4713                                                               (arg4_type,
4714                                                         integer_zero_node)),
4715                                                     arg3_tree))),
4716                       arg5_tree);
4717         arg5_plus_arg3
4718           = ffecom_save_tree (ffecom_2 (PLUS_EXPR, arg4_type,
4719                                         arg5_tree,
4720                                         arg3_tree));
4721         prep_arg4
4722           = ffecom_2 (LSHIFT_EXPR, arg4_type,
4723                       ffecom_1 (BIT_NOT_EXPR, arg4_type,
4724                                 convert (arg4_type,
4725                                          integer_zero_node)),
4726                       arg5_plus_arg3);
4727         /* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE.  */
4728         prep_arg4
4729           = ffecom_3 (COND_EXPR, arg4_type,
4730                       ffecom_truth_value
4731                       (ffecom_2 (NE_EXPR, integer_type_node,
4732                                  arg5_plus_arg3,
4733                                  convert (TREE_TYPE (arg5_plus_arg3),
4734                                           TYPE_SIZE (arg4_type)))),
4735                       prep_arg4,
4736                       convert (arg4_type, integer_zero_node));
4737         prep_arg4
4738           = ffecom_2 (BIT_AND_EXPR, arg4_type,
4739                       arg4_tree,
4740                       ffecom_2 (BIT_IOR_EXPR, arg4_type,
4741                                 prep_arg4,
4742                                 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4743                                           ffecom_2 (LSHIFT_EXPR, arg4_type,
4744                                                     ffecom_1 (BIT_NOT_EXPR,
4745                                                               arg4_type,
4746                                                               convert
4747                                                               (arg4_type,
4748                                                         integer_zero_node)),
4749                                                     arg5_tree))));
4750         prep_arg1
4751           = ffecom_2 (BIT_IOR_EXPR, arg4_type,
4752                       prep_arg1,
4753                       prep_arg4);
4754         /* Fix up (twice), because LSHIFT_EXPR above
4755            can't shift over TYPE_SIZE.  */
4756         prep_arg1
4757           = ffecom_3 (COND_EXPR, arg4_type,
4758                       ffecom_truth_value
4759                       (ffecom_2 (NE_EXPR, integer_type_node,
4760                                  arg3_tree,
4761                                  convert (TREE_TYPE (arg3_tree),
4762                                           integer_zero_node))),
4763                       prep_arg1,
4764                       arg4_tree);
4765         prep_arg1
4766           = ffecom_3 (COND_EXPR, arg4_type,
4767                       ffecom_truth_value
4768                       (ffecom_2 (NE_EXPR, integer_type_node,
4769                                  arg3_tree,
4770                                  convert (TREE_TYPE (arg3_tree),
4771                                           TYPE_SIZE (arg4_type)))),
4772                       prep_arg1,
4773                       arg1_tree);
4774         expr_tree
4775           = ffecom_2s (MODIFY_EXPR, void_type_node,
4776                        arg4_tree,
4777                        prep_arg1);
4778         /* Make sure SAVE_EXPRs get referenced early enough. */
4779         expr_tree
4780           = ffecom_2 (COMPOUND_EXPR, void_type_node,
4781                       arg1_tree,
4782                       ffecom_2 (COMPOUND_EXPR, void_type_node,
4783                                 arg3_tree,
4784                                 ffecom_2 (COMPOUND_EXPR, void_type_node,
4785                                           arg5_tree,
4786                                           ffecom_2 (COMPOUND_EXPR, void_type_node,
4787                                                     arg5_plus_arg3,
4788                                                     expr_tree))));
4789         expr_tree
4790           = ffecom_2 (COMPOUND_EXPR, void_type_node,
4791                       arg4_tree,
4792                       expr_tree);
4793
4794       }
4795       return expr_tree;
4796
4797     case FFEINTRIN_impDERF:
4798     case FFEINTRIN_impERF:
4799     case FFEINTRIN_impDERFC:
4800     case FFEINTRIN_impERFC:
4801       break;
4802
4803     case FFEINTRIN_impIARGC:
4804       /* extern int xargc; i__1 = xargc - 1; */
4805       expr_tree = ffecom_2 (MINUS_EXPR, TREE_TYPE (ffecom_tree_xargc_),
4806                             ffecom_tree_xargc_,
4807                             convert (TREE_TYPE (ffecom_tree_xargc_),
4808                                      integer_one_node));
4809       return expr_tree;
4810
4811     case FFEINTRIN_impSIGNAL_func:
4812     case FFEINTRIN_impSIGNAL_subr:
4813       {
4814         tree arg1_tree;
4815         tree arg2_tree;
4816         tree arg3_tree;
4817
4818         arg1_tree = convert (ffecom_f2c_integer_type_node,
4819                              ffecom_expr (arg1));
4820         arg1_tree = ffecom_1 (ADDR_EXPR,
4821                               build_pointer_type (TREE_TYPE (arg1_tree)),
4822                               arg1_tree);
4823
4824         /* Pass procedure as a pointer to it, anything else by value.  */
4825         if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
4826           arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
4827         else
4828           arg2_tree = ffecom_ptr_to_expr (arg2);
4829         arg2_tree = convert (TREE_TYPE (null_pointer_node),
4830                              arg2_tree);
4831
4832         if (arg3 != NULL)
4833           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
4834         else
4835           arg3_tree = NULL_TREE;
4836
4837         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4838         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4839         TREE_CHAIN (arg1_tree) = arg2_tree;
4840
4841         expr_tree
4842           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4843                           ffecom_gfrt_kindtype (gfrt),
4844                           FALSE,
4845                           ((codegen_imp == FFEINTRIN_impSIGNAL_subr) ?
4846                            NULL_TREE :
4847                            tree_type),
4848                           arg1_tree,
4849                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4850                           ffebld_nonter_hook (expr));
4851
4852         if (arg3_tree != NULL_TREE)
4853           expr_tree
4854             = ffecom_modify (NULL_TREE, arg3_tree,
4855                              convert (TREE_TYPE (arg3_tree),
4856                                       expr_tree));
4857       }
4858       return expr_tree;
4859
4860     case FFEINTRIN_impALARM:
4861       {
4862         tree arg1_tree;
4863         tree arg2_tree;
4864         tree arg3_tree;
4865
4866         arg1_tree = convert (ffecom_f2c_integer_type_node,
4867                              ffecom_expr (arg1));
4868         arg1_tree = ffecom_1 (ADDR_EXPR,
4869                               build_pointer_type (TREE_TYPE (arg1_tree)),
4870                               arg1_tree);
4871
4872         /* Pass procedure as a pointer to it, anything else by value.  */
4873         if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
4874           arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
4875         else
4876           arg2_tree = ffecom_ptr_to_expr (arg2);
4877         arg2_tree = convert (TREE_TYPE (null_pointer_node),
4878                              arg2_tree);
4879
4880         if (arg3 != NULL)
4881           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
4882         else
4883           arg3_tree = NULL_TREE;
4884
4885         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4886         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4887         TREE_CHAIN (arg1_tree) = arg2_tree;
4888
4889         expr_tree
4890           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4891                           ffecom_gfrt_kindtype (gfrt),
4892                           FALSE,
4893                           NULL_TREE,
4894                           arg1_tree,
4895                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4896                           ffebld_nonter_hook (expr));
4897
4898         if (arg3_tree != NULL_TREE)
4899           expr_tree
4900             = ffecom_modify (NULL_TREE, arg3_tree,
4901                              convert (TREE_TYPE (arg3_tree),
4902                                       expr_tree));
4903       }
4904       return expr_tree;
4905
4906     case FFEINTRIN_impCHDIR_subr:
4907     case FFEINTRIN_impFDATE_subr:
4908     case FFEINTRIN_impFGET_subr:
4909     case FFEINTRIN_impFPUT_subr:
4910     case FFEINTRIN_impGETCWD_subr:
4911     case FFEINTRIN_impHOSTNM_subr:
4912     case FFEINTRIN_impSYSTEM_subr:
4913     case FFEINTRIN_impUNLINK_subr:
4914       {
4915         tree arg1_len = integer_zero_node;
4916         tree arg1_tree;
4917         tree arg2_tree;
4918
4919         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
4920
4921         if (arg2 != NULL)
4922           arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
4923         else
4924           arg2_tree = NULL_TREE;
4925
4926         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4927         arg1_len = build_tree_list (NULL_TREE, arg1_len);
4928         TREE_CHAIN (arg1_tree) = arg1_len;
4929
4930         expr_tree
4931           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4932                           ffecom_gfrt_kindtype (gfrt),
4933                           FALSE,
4934                           NULL_TREE,
4935                           arg1_tree,
4936                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4937                           ffebld_nonter_hook (expr));
4938
4939         if (arg2_tree != NULL_TREE)
4940           expr_tree
4941             = ffecom_modify (NULL_TREE, arg2_tree,
4942                              convert (TREE_TYPE (arg2_tree),
4943                                       expr_tree));
4944       }
4945       return expr_tree;
4946
4947     case FFEINTRIN_impEXIT:
4948       if (arg1 != NULL)
4949         break;
4950
4951       expr_tree = build_tree_list (NULL_TREE,
4952                                    ffecom_1 (ADDR_EXPR,
4953                                              build_pointer_type
4954                                              (ffecom_integer_type_node),
4955                                              integer_zero_node));
4956
4957       return
4958         ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4959                       ffecom_gfrt_kindtype (gfrt),
4960                       FALSE,
4961                       void_type_node,
4962                       expr_tree,
4963                       NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4964                       ffebld_nonter_hook (expr));
4965
4966     case FFEINTRIN_impFLUSH:
4967       if (arg1 == NULL)
4968         gfrt = FFECOM_gfrtFLUSH;
4969       else
4970         gfrt = FFECOM_gfrtFLUSH1;
4971       break;
4972
4973     case FFEINTRIN_impCHMOD_subr:
4974     case FFEINTRIN_impLINK_subr:
4975     case FFEINTRIN_impRENAME_subr:
4976     case FFEINTRIN_impSYMLNK_subr:
4977       {
4978         tree arg1_len = integer_zero_node;
4979         tree arg1_tree;
4980         tree arg2_len = integer_zero_node;
4981         tree arg2_tree;
4982         tree arg3_tree;
4983
4984         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
4985         arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
4986         if (arg3 != NULL)
4987           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
4988         else
4989           arg3_tree = NULL_TREE;
4990
4991         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4992         arg1_len = build_tree_list (NULL_TREE, arg1_len);
4993         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4994         arg2_len = build_tree_list (NULL_TREE, arg2_len);
4995         TREE_CHAIN (arg1_tree) = arg2_tree;
4996         TREE_CHAIN (arg2_tree) = arg1_len;
4997         TREE_CHAIN (arg1_len) = arg2_len;
4998         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4999                                   ffecom_gfrt_kindtype (gfrt),
5000                                   FALSE,
5001                                   NULL_TREE,
5002                                   arg1_tree,
5003                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5004                                   ffebld_nonter_hook (expr));
5005         if (arg3_tree != NULL_TREE)
5006           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5007                                      convert (TREE_TYPE (arg3_tree),
5008                                               expr_tree));
5009       }
5010       return expr_tree;
5011
5012     case FFEINTRIN_impLSTAT_subr:
5013     case FFEINTRIN_impSTAT_subr:
5014       {
5015         tree arg1_len = integer_zero_node;
5016         tree arg1_tree;
5017         tree arg2_tree;
5018         tree arg3_tree;
5019
5020         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5021
5022         arg2_tree = ffecom_ptr_to_expr (arg2);
5023
5024         if (arg3 != NULL)
5025           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5026         else
5027           arg3_tree = NULL_TREE;
5028
5029         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5030         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5031         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5032         TREE_CHAIN (arg1_tree) = arg2_tree;
5033         TREE_CHAIN (arg2_tree) = arg1_len;
5034         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5035                                   ffecom_gfrt_kindtype (gfrt),
5036                                   FALSE,
5037                                   NULL_TREE,
5038                                   arg1_tree,
5039                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5040                                   ffebld_nonter_hook (expr));
5041         if (arg3_tree != NULL_TREE)
5042           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5043                                      convert (TREE_TYPE (arg3_tree),
5044                                               expr_tree));
5045       }
5046       return expr_tree;
5047
5048     case FFEINTRIN_impFGETC_subr:
5049     case FFEINTRIN_impFPUTC_subr:
5050       {
5051         tree arg1_tree;
5052         tree arg2_tree;
5053         tree arg2_len = integer_zero_node;
5054         tree arg3_tree;
5055
5056         arg1_tree = convert (ffecom_f2c_integer_type_node,
5057                              ffecom_expr (arg1));
5058         arg1_tree = ffecom_1 (ADDR_EXPR,
5059                               build_pointer_type (TREE_TYPE (arg1_tree)),
5060                               arg1_tree);
5061
5062         arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
5063         if (arg3 != NULL)
5064           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5065         else
5066           arg3_tree = NULL_TREE;
5067
5068         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5069         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5070         arg2_len = build_tree_list (NULL_TREE, arg2_len);
5071         TREE_CHAIN (arg1_tree) = arg2_tree;
5072         TREE_CHAIN (arg2_tree) = arg2_len;
5073
5074         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5075                                   ffecom_gfrt_kindtype (gfrt),
5076                                   FALSE,
5077                                   NULL_TREE,
5078                                   arg1_tree,
5079                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5080                                   ffebld_nonter_hook (expr));
5081         if (arg3_tree != NULL_TREE)
5082           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5083                                      convert (TREE_TYPE (arg3_tree),
5084                                               expr_tree));
5085       }
5086       return expr_tree;
5087
5088     case FFEINTRIN_impFSTAT_subr:
5089       {
5090         tree arg1_tree;
5091         tree arg2_tree;
5092         tree arg3_tree;
5093
5094         arg1_tree = convert (ffecom_f2c_integer_type_node,
5095                              ffecom_expr (arg1));
5096         arg1_tree = ffecom_1 (ADDR_EXPR,
5097                               build_pointer_type (TREE_TYPE (arg1_tree)),
5098                               arg1_tree);
5099
5100         arg2_tree = convert (ffecom_f2c_ptr_to_integer_type_node,
5101                              ffecom_ptr_to_expr (arg2));
5102
5103         if (arg3 == NULL)
5104           arg3_tree = NULL_TREE;
5105         else
5106           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5107
5108         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5109         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5110         TREE_CHAIN (arg1_tree) = arg2_tree;
5111         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5112                                   ffecom_gfrt_kindtype (gfrt),
5113                                   FALSE,
5114                                   NULL_TREE,
5115                                   arg1_tree,
5116                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5117                                   ffebld_nonter_hook (expr));
5118         if (arg3_tree != NULL_TREE) {
5119           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5120                                      convert (TREE_TYPE (arg3_tree),
5121                                               expr_tree));
5122         }
5123       }
5124       return expr_tree;
5125
5126     case FFEINTRIN_impKILL_subr:
5127       {
5128         tree arg1_tree;
5129         tree arg2_tree;
5130         tree arg3_tree;
5131
5132         arg1_tree = convert (ffecom_f2c_integer_type_node,
5133                              ffecom_expr (arg1));
5134         arg1_tree = ffecom_1 (ADDR_EXPR,
5135                               build_pointer_type (TREE_TYPE (arg1_tree)),
5136                               arg1_tree);
5137
5138         arg2_tree = convert (ffecom_f2c_integer_type_node,
5139                              ffecom_expr (arg2));
5140         arg2_tree = ffecom_1 (ADDR_EXPR,
5141                               build_pointer_type (TREE_TYPE (arg2_tree)),
5142                               arg2_tree);
5143
5144         if (arg3 == NULL)
5145           arg3_tree = NULL_TREE;
5146         else
5147           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5148
5149         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5150         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5151         TREE_CHAIN (arg1_tree) = arg2_tree;
5152         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5153                                   ffecom_gfrt_kindtype (gfrt),
5154                                   FALSE,
5155                                   NULL_TREE,
5156                                   arg1_tree,
5157                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5158                                   ffebld_nonter_hook (expr));
5159         if (arg3_tree != NULL_TREE) {
5160           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5161                                      convert (TREE_TYPE (arg3_tree),
5162                                               expr_tree));
5163         }
5164       }
5165       return expr_tree;
5166
5167     case FFEINTRIN_impCTIME_subr:
5168     case FFEINTRIN_impTTYNAM_subr:
5169       {
5170         tree arg1_len = integer_zero_node;
5171         tree arg1_tree;
5172         tree arg2_tree;
5173
5174         arg1_tree = ffecom_arg_ptr_to_expr (arg2, &arg1_len);
5175
5176         arg2_tree = convert (((codegen_imp == FFEINTRIN_impCTIME_subr) ?
5177                               ffecom_f2c_longint_type_node :
5178                               ffecom_f2c_integer_type_node),
5179                              ffecom_expr (arg1));
5180         arg2_tree = ffecom_1 (ADDR_EXPR,
5181                               build_pointer_type (TREE_TYPE (arg2_tree)),
5182                               arg2_tree);
5183
5184         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5185         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5186         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5187         TREE_CHAIN (arg1_len) = arg2_tree;
5188         TREE_CHAIN (arg1_tree) = arg1_len;
5189
5190         expr_tree
5191           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5192                           ffecom_gfrt_kindtype (gfrt),
5193                           FALSE,
5194                           NULL_TREE,
5195                           arg1_tree,
5196                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5197                           ffebld_nonter_hook (expr));
5198         TREE_SIDE_EFFECTS (expr_tree) = 1;
5199       }
5200       return expr_tree;
5201
5202     case FFEINTRIN_impIRAND:
5203     case FFEINTRIN_impRAND:
5204       /* Arg defaults to 0 (normal random case) */
5205       {
5206         tree arg1_tree;
5207
5208         if (arg1 == NULL)
5209           arg1_tree = ffecom_integer_zero_node;
5210         else
5211           arg1_tree = ffecom_expr (arg1);
5212         arg1_tree = convert (ffecom_f2c_integer_type_node,
5213                              arg1_tree);
5214         arg1_tree = ffecom_1 (ADDR_EXPR,
5215                               build_pointer_type (TREE_TYPE (arg1_tree)),
5216                               arg1_tree);
5217         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5218
5219         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5220                                   ffecom_gfrt_kindtype (gfrt),
5221                                   FALSE,
5222                                   ((codegen_imp == FFEINTRIN_impIRAND) ?
5223                                    ffecom_f2c_integer_type_node :
5224                                    ffecom_f2c_real_type_node),
5225                                   arg1_tree,
5226                                   dest_tree, dest, dest_used,
5227                                   NULL_TREE, TRUE,
5228                                   ffebld_nonter_hook (expr));
5229       }
5230       return expr_tree;
5231
5232     case FFEINTRIN_impFTELL_subr:
5233     case FFEINTRIN_impUMASK_subr:
5234       {
5235         tree arg1_tree;
5236         tree arg2_tree;
5237
5238         arg1_tree = convert (ffecom_f2c_integer_type_node,
5239                              ffecom_expr (arg1));
5240         arg1_tree = ffecom_1 (ADDR_EXPR,
5241                               build_pointer_type (TREE_TYPE (arg1_tree)),
5242                               arg1_tree);
5243
5244         if (arg2 == NULL)
5245           arg2_tree = NULL_TREE;
5246         else
5247           arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
5248
5249         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5250                                   ffecom_gfrt_kindtype (gfrt),
5251                                   FALSE,
5252                                   NULL_TREE,
5253                                   build_tree_list (NULL_TREE, arg1_tree),
5254                                   NULL_TREE, NULL, NULL, NULL_TREE,
5255                                   TRUE,
5256                                   ffebld_nonter_hook (expr));
5257         if (arg2_tree != NULL_TREE) {
5258           expr_tree = ffecom_modify (NULL_TREE, arg2_tree,
5259                                      convert (TREE_TYPE (arg2_tree),
5260                                               expr_tree));
5261         }
5262       }
5263       return expr_tree;
5264
5265     case FFEINTRIN_impCPU_TIME:
5266     case FFEINTRIN_impSECOND_subr:
5267       {
5268         tree arg1_tree;
5269
5270         arg1_tree = ffecom_expr_w (NULL_TREE, arg1);
5271
5272         expr_tree
5273           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5274                           ffecom_gfrt_kindtype (gfrt),
5275                           FALSE,
5276                           NULL_TREE,
5277                           NULL_TREE,
5278                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5279                           ffebld_nonter_hook (expr));
5280
5281         expr_tree
5282           = ffecom_modify (NULL_TREE, arg1_tree,
5283                            convert (TREE_TYPE (arg1_tree),
5284                                     expr_tree));
5285       }
5286       return expr_tree;
5287
5288     case FFEINTRIN_impDTIME_subr:
5289     case FFEINTRIN_impETIME_subr:
5290       {
5291         tree arg1_tree;
5292         tree result_tree;
5293
5294         result_tree = ffecom_expr_w (NULL_TREE, arg2);
5295
5296         arg1_tree = ffecom_ptr_to_expr (arg1);
5297
5298         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5299                                   ffecom_gfrt_kindtype (gfrt),
5300                                   FALSE,
5301                                   NULL_TREE,
5302                                   build_tree_list (NULL_TREE, arg1_tree),
5303                                   NULL_TREE, NULL, NULL, NULL_TREE,
5304                                   TRUE,
5305                                   ffebld_nonter_hook (expr));
5306         expr_tree = ffecom_modify (NULL_TREE, result_tree,
5307                                    convert (TREE_TYPE (result_tree),
5308                                             expr_tree));
5309       }
5310       return expr_tree;
5311
5312       /* Straightforward calls of libf2c routines: */
5313     case FFEINTRIN_impABORT:
5314     case FFEINTRIN_impACCESS:
5315     case FFEINTRIN_impBESJ0:
5316     case FFEINTRIN_impBESJ1:
5317     case FFEINTRIN_impBESJN:
5318     case FFEINTRIN_impBESY0:
5319     case FFEINTRIN_impBESY1:
5320     case FFEINTRIN_impBESYN:
5321     case FFEINTRIN_impCHDIR_func:
5322     case FFEINTRIN_impCHMOD_func:
5323     case FFEINTRIN_impDATE:
5324     case FFEINTRIN_impDATE_AND_TIME:
5325     case FFEINTRIN_impDBESJ0:
5326     case FFEINTRIN_impDBESJ1:
5327     case FFEINTRIN_impDBESJN:
5328     case FFEINTRIN_impDBESY0:
5329     case FFEINTRIN_impDBESY1:
5330     case FFEINTRIN_impDBESYN:
5331     case FFEINTRIN_impDTIME_func:
5332     case FFEINTRIN_impETIME_func:
5333     case FFEINTRIN_impFGETC_func:
5334     case FFEINTRIN_impFGET_func:
5335     case FFEINTRIN_impFNUM:
5336     case FFEINTRIN_impFPUTC_func:
5337     case FFEINTRIN_impFPUT_func:
5338     case FFEINTRIN_impFSEEK:
5339     case FFEINTRIN_impFSTAT_func:
5340     case FFEINTRIN_impFTELL_func:
5341     case FFEINTRIN_impGERROR:
5342     case FFEINTRIN_impGETARG:
5343     case FFEINTRIN_impGETCWD_func:
5344     case FFEINTRIN_impGETENV:
5345     case FFEINTRIN_impGETGID:
5346     case FFEINTRIN_impGETLOG:
5347     case FFEINTRIN_impGETPID:
5348     case FFEINTRIN_impGETUID:
5349     case FFEINTRIN_impGMTIME:
5350     case FFEINTRIN_impHOSTNM_func:
5351     case FFEINTRIN_impIDATE_unix:
5352     case FFEINTRIN_impIDATE_vxt:
5353     case FFEINTRIN_impIERRNO:
5354     case FFEINTRIN_impISATTY:
5355     case FFEINTRIN_impITIME:
5356     case FFEINTRIN_impKILL_func:
5357     case FFEINTRIN_impLINK_func:
5358     case FFEINTRIN_impLNBLNK:
5359     case FFEINTRIN_impLSTAT_func:
5360     case FFEINTRIN_impLTIME:
5361     case FFEINTRIN_impMCLOCK8:
5362     case FFEINTRIN_impMCLOCK:
5363     case FFEINTRIN_impPERROR:
5364     case FFEINTRIN_impRENAME_func:
5365     case FFEINTRIN_impSECNDS:
5366     case FFEINTRIN_impSECOND_func:
5367     case FFEINTRIN_impSLEEP:
5368     case FFEINTRIN_impSRAND:
5369     case FFEINTRIN_impSTAT_func:
5370     case FFEINTRIN_impSYMLNK_func:
5371     case FFEINTRIN_impSYSTEM_CLOCK:
5372     case FFEINTRIN_impSYSTEM_func:
5373     case FFEINTRIN_impTIME8:
5374     case FFEINTRIN_impTIME_unix:
5375     case FFEINTRIN_impTIME_vxt:
5376     case FFEINTRIN_impUMASK_func:
5377     case FFEINTRIN_impUNLINK_func:
5378       break;
5379
5380     case FFEINTRIN_impCTIME_func:       /* CHARACTER functions not handled here. */
5381     case FFEINTRIN_impFDATE_func:       /* CHARACTER functions not handled here. */
5382     case FFEINTRIN_impTTYNAM_func:      /* CHARACTER functions not handled here. */
5383     case FFEINTRIN_impNONE:
5384     case FFEINTRIN_imp:         /* Hush up gcc warning. */
5385       fprintf (stderr, "No %s implementation.\n",
5386                ffeintrin_name_implementation (ffebld_symter_implementation (ffebld_left (expr))));
5387       assert ("unimplemented intrinsic" == NULL);
5388       return error_mark_node;
5389     }
5390
5391   assert (gfrt != FFECOM_gfrt); /* Must have an implementation! */
5392
5393   expr_tree = ffecom_arglist_expr_ (ffecom_gfrt_args_ (gfrt),
5394                                     ffebld_right (expr));
5395
5396   return ffecom_call_ (ffecom_gfrt_tree_ (gfrt), ffecom_gfrt_kindtype (gfrt),
5397                        (ffe_is_f2c_library () && ffecom_gfrt_complex_[gfrt]),
5398                        tree_type,
5399                        expr_tree, dest_tree, dest, dest_used,
5400                        NULL_TREE, TRUE,
5401                        ffebld_nonter_hook (expr));
5402
5403   /* See bottom of this file for f2c transforms used to determine
5404      many of the above implementations.  The info seems to confuse
5405      Emacs's C mode indentation, which is why it's been moved to
5406      the bottom of this source file.  */
5407 }
5408
5409 /* For power (exponentiation) where right-hand operand is type INTEGER,
5410    generate in-line code to do it the fast way (which, if the operand
5411    is a constant, might just mean a series of multiplies).  */
5412
5413 static tree
5414 ffecom_expr_power_integer_ (ffebld expr)
5415 {
5416   tree l = ffecom_expr (ffebld_left (expr));
5417   tree r = ffecom_expr (ffebld_right (expr));
5418   tree ltype = TREE_TYPE (l);
5419   tree rtype = TREE_TYPE (r);
5420   tree result = NULL_TREE;
5421
5422   if (l == error_mark_node
5423       || r == error_mark_node)
5424     return error_mark_node;
5425
5426   if (TREE_CODE (r) == INTEGER_CST)
5427     {
5428       int sgn = tree_int_cst_sgn (r);
5429
5430       if (sgn == 0)
5431         return convert (ltype, integer_one_node);
5432
5433       if ((TREE_CODE (ltype) == INTEGER_TYPE)
5434           && (sgn < 0))
5435         {
5436           /* Reciprocal of integer is either 0, -1, or 1, so after
5437              calculating that (which we leave to the back end to do
5438              or not do optimally), don't bother with any multiplying.  */
5439
5440           result = ffecom_tree_divide_ (ltype,
5441                                         convert (ltype, integer_one_node),
5442                                         l,
5443                                         NULL_TREE, NULL, NULL, NULL_TREE);
5444           r = ffecom_1 (NEGATE_EXPR,
5445                         rtype,
5446                         r);
5447           if ((TREE_INT_CST_LOW (r) & 1) == 0)
5448             result = ffecom_1 (ABS_EXPR, rtype,
5449                                result);
5450         }
5451
5452       /* Generate appropriate series of multiplies, preceded
5453          by divide if the exponent is negative.  */
5454
5455       l = save_expr (l);
5456
5457       if (sgn < 0)
5458         {
5459           l = ffecom_tree_divide_ (ltype,
5460                                    convert (ltype, integer_one_node),
5461                                    l,
5462                                    NULL_TREE, NULL, NULL,
5463                                    ffebld_nonter_hook (expr));
5464           r = ffecom_1 (NEGATE_EXPR, rtype, r);
5465           assert (TREE_CODE (r) == INTEGER_CST);
5466
5467           if (tree_int_cst_sgn (r) < 0)
5468             {                   /* The "most negative" number.  */
5469               r = ffecom_1 (NEGATE_EXPR, rtype,
5470                             ffecom_2 (RSHIFT_EXPR, rtype,
5471                                       r,
5472                                       integer_one_node));
5473               l = save_expr (l);
5474               l = ffecom_2 (MULT_EXPR, ltype,
5475                             l,
5476                             l);
5477             }
5478         }
5479
5480       for (;;)
5481         {
5482           if (TREE_INT_CST_LOW (r) & 1)
5483             {
5484               if (result == NULL_TREE)
5485                 result = l;
5486               else
5487                 result = ffecom_2 (MULT_EXPR, ltype,
5488                                    result,
5489                                    l);
5490             }
5491
5492           r = ffecom_2 (RSHIFT_EXPR, rtype,
5493                         r,
5494                         integer_one_node);
5495           if (integer_zerop (r))
5496             break;
5497           assert (TREE_CODE (r) == INTEGER_CST);
5498
5499           l = save_expr (l);
5500           l = ffecom_2 (MULT_EXPR, ltype,
5501                         l,
5502                         l);
5503         }
5504       return result;
5505     }
5506
5507   /* Though rhs isn't a constant, in-line code cannot be expanded
5508      while transforming dummies
5509      because the back end cannot be easily convinced to generate
5510      stores (MODIFY_EXPR), handle temporaries, and so on before
5511      all the appropriate rtx's have been generated for things like
5512      dummy args referenced in rhs -- which doesn't happen until
5513      store_parm_decls() is called (expand_function_start, I believe,
5514      does the actual rtx-stuffing of PARM_DECLs).
5515
5516      So, in this case, let the caller generate the call to the
5517      run-time-library function to evaluate the power for us.  */
5518
5519   if (ffecom_transform_only_dummies_)
5520     return NULL_TREE;
5521
5522   /* Right-hand operand not a constant, expand in-line code to figure
5523      out how to do the multiplies, &c.
5524
5525      The returned expression is expressed this way in GNU C, where l and
5526      r are the "inputs":
5527
5528      ({ typeof (r) rtmp = r;
5529         typeof (l) ltmp = l;
5530         typeof (l) result;
5531
5532         if (rtmp == 0)
5533           result = 1;
5534         else
5535           {
5536             if ((basetypeof (l) == basetypeof (int))
5537                 && (rtmp < 0))
5538               {
5539                 result = ((typeof (l)) 1) / ltmp;
5540                 if ((ltmp < 0) && (((-rtmp) & 1) == 0))
5541                   result = -result;
5542               }
5543             else
5544               {
5545                 result = 1;
5546                 if ((basetypeof (l) != basetypeof (int))
5547                     && (rtmp < 0))
5548                   {
5549                     ltmp = ((typeof (l)) 1) / ltmp;
5550                     rtmp = -rtmp;
5551                     if (rtmp < 0)
5552                       {
5553                         rtmp = -(rtmp >> 1);
5554                         ltmp *= ltmp;
5555                       }
5556                   }
5557                 for (;;)
5558                   {
5559                     if (rtmp & 1)
5560                       result *= ltmp;
5561                     if ((rtmp >>= 1) == 0)
5562                       break;
5563                     ltmp *= ltmp;
5564                   }
5565               }
5566           }
5567         result;
5568      })
5569
5570      Note that some of the above is compile-time collapsable, such as
5571      the first part of the if statements that checks the base type of
5572      l against int.  The if statements are phrased that way to suggest
5573      an easy way to generate the if/else constructs here, knowing that
5574      the back end should (and probably does) eliminate the resulting
5575      dead code (either the int case or the non-int case), something
5576      it couldn't do without the redundant phrasing, requiring explicit
5577      dead-code elimination here, which would be kind of difficult to
5578      read.  */
5579
5580   {
5581     tree rtmp;
5582     tree ltmp;
5583     tree divide;
5584     tree basetypeof_l_is_int;
5585     tree se;
5586     tree t;
5587
5588     basetypeof_l_is_int
5589       = build_int_2 ((TREE_CODE (ltype) == INTEGER_TYPE), 0);
5590
5591     se = expand_start_stmt_expr ();
5592
5593     ffecom_start_compstmt ();
5594
5595 #ifndef HAHA
5596     rtmp = ffecom_make_tempvar ("power_r", rtype,
5597                                 FFETARGET_charactersizeNONE, -1);
5598     ltmp = ffecom_make_tempvar ("power_l", ltype,
5599                                 FFETARGET_charactersizeNONE, -1);
5600     result = ffecom_make_tempvar ("power_res", ltype,
5601                                   FFETARGET_charactersizeNONE, -1);
5602     if (TREE_CODE (ltype) == COMPLEX_TYPE
5603         || TREE_CODE (ltype) == RECORD_TYPE)
5604       divide = ffecom_make_tempvar ("power_div", ltype,
5605                                     FFETARGET_charactersizeNONE, -1);
5606     else
5607       divide = NULL_TREE;
5608 #else  /* HAHA */
5609     {
5610       tree hook;
5611
5612       hook = ffebld_nonter_hook (expr);
5613       assert (hook);
5614       assert (TREE_CODE (hook) == TREE_VEC);
5615       assert (TREE_VEC_LENGTH (hook) == 4);
5616       rtmp = TREE_VEC_ELT (hook, 0);
5617       ltmp = TREE_VEC_ELT (hook, 1);
5618       result = TREE_VEC_ELT (hook, 2);
5619       divide = TREE_VEC_ELT (hook, 3);
5620       if (TREE_CODE (ltype) == COMPLEX_TYPE
5621           || TREE_CODE (ltype) == RECORD_TYPE)
5622         assert (divide);
5623       else
5624         assert (! divide);
5625     }
5626 #endif  /* HAHA */
5627
5628     expand_expr_stmt (ffecom_modify (void_type_node,
5629                                      rtmp,
5630                                      r));
5631     expand_expr_stmt (ffecom_modify (void_type_node,
5632                                      ltmp,
5633                                      l));
5634     expand_start_cond (ffecom_truth_value
5635                        (ffecom_2 (EQ_EXPR, integer_type_node,
5636                                   rtmp,
5637                                   convert (rtype, integer_zero_node))),
5638                        0);
5639     expand_expr_stmt (ffecom_modify (void_type_node,
5640                                      result,
5641                                      convert (ltype, integer_one_node)));
5642     expand_start_else ();
5643     if (! integer_zerop (basetypeof_l_is_int))
5644       {
5645         expand_start_cond (ffecom_2 (LT_EXPR, integer_type_node,
5646                                      rtmp,
5647                                      convert (rtype,
5648                                               integer_zero_node)),
5649                            0);
5650         expand_expr_stmt (ffecom_modify (void_type_node,
5651                                          result,
5652                                          ffecom_tree_divide_
5653                                          (ltype,
5654                                           convert (ltype, integer_one_node),
5655                                           ltmp,
5656                                           NULL_TREE, NULL, NULL,
5657                                           divide)));
5658         expand_start_cond (ffecom_truth_value
5659                            (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5660                                       ffecom_2 (LT_EXPR, integer_type_node,
5661                                                 ltmp,
5662                                                 convert (ltype,
5663                                                          integer_zero_node)),
5664                                       ffecom_2 (EQ_EXPR, integer_type_node,
5665                                                 ffecom_2 (BIT_AND_EXPR,
5666                                                           rtype,
5667                                                           ffecom_1 (NEGATE_EXPR,
5668                                                                     rtype,
5669                                                                     rtmp),
5670                                                           convert (rtype,
5671                                                                    integer_one_node)),
5672                                                 convert (rtype,
5673                                                          integer_zero_node)))),
5674                            0);
5675         expand_expr_stmt (ffecom_modify (void_type_node,
5676                                          result,
5677                                          ffecom_1 (NEGATE_EXPR,
5678                                                    ltype,
5679                                                    result)));
5680         expand_end_cond ();
5681         expand_start_else ();
5682       }
5683     expand_expr_stmt (ffecom_modify (void_type_node,
5684                                      result,
5685                                      convert (ltype, integer_one_node)));
5686     expand_start_cond (ffecom_truth_value
5687                        (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5688                                   ffecom_truth_value_invert
5689                                   (basetypeof_l_is_int),
5690                                   ffecom_2 (LT_EXPR, integer_type_node,
5691                                             rtmp,
5692                                             convert (rtype,
5693                                                      integer_zero_node)))),
5694                        0);
5695     expand_expr_stmt (ffecom_modify (void_type_node,
5696                                      ltmp,
5697                                      ffecom_tree_divide_
5698                                      (ltype,
5699                                       convert (ltype, integer_one_node),
5700                                       ltmp,
5701                                       NULL_TREE, NULL, NULL,
5702                                       divide)));
5703     expand_expr_stmt (ffecom_modify (void_type_node,
5704                                      rtmp,
5705                                      ffecom_1 (NEGATE_EXPR, rtype,
5706                                                rtmp)));
5707     expand_start_cond (ffecom_truth_value
5708                        (ffecom_2 (LT_EXPR, integer_type_node,
5709                                   rtmp,
5710                                   convert (rtype, integer_zero_node))),
5711                        0);
5712     expand_expr_stmt (ffecom_modify (void_type_node,
5713                                      rtmp,
5714                                      ffecom_1 (NEGATE_EXPR, rtype,
5715                                                ffecom_2 (RSHIFT_EXPR,
5716                                                          rtype,
5717                                                          rtmp,
5718                                                          integer_one_node))));
5719     expand_expr_stmt (ffecom_modify (void_type_node,
5720                                      ltmp,
5721                                      ffecom_2 (MULT_EXPR, ltype,
5722                                                ltmp,
5723                                                ltmp)));
5724     expand_end_cond ();
5725     expand_end_cond ();
5726     expand_start_loop (1);
5727     expand_start_cond (ffecom_truth_value
5728                        (ffecom_2 (BIT_AND_EXPR, rtype,
5729                                   rtmp,
5730                                   convert (rtype, integer_one_node))),
5731                        0);
5732     expand_expr_stmt (ffecom_modify (void_type_node,
5733                                      result,
5734                                      ffecom_2 (MULT_EXPR, ltype,
5735                                                result,
5736                                                ltmp)));
5737     expand_end_cond ();
5738     expand_exit_loop_if_false (NULL,
5739                                ffecom_truth_value
5740                                (ffecom_modify (rtype,
5741                                                rtmp,
5742                                                ffecom_2 (RSHIFT_EXPR,
5743                                                          rtype,
5744                                                          rtmp,
5745                                                          integer_one_node))));
5746     expand_expr_stmt (ffecom_modify (void_type_node,
5747                                      ltmp,
5748                                      ffecom_2 (MULT_EXPR, ltype,
5749                                                ltmp,
5750                                                ltmp)));
5751     expand_end_loop ();
5752     expand_end_cond ();
5753     if (!integer_zerop (basetypeof_l_is_int))
5754       expand_end_cond ();
5755     expand_expr_stmt (result);
5756
5757     t = ffecom_end_compstmt ();
5758
5759     result = expand_end_stmt_expr (se);
5760
5761     /* This code comes from c-parse.in, after its expand_end_stmt_expr.  */
5762
5763     if (TREE_CODE (t) == BLOCK)
5764       {
5765         /* Make a BIND_EXPR for the BLOCK already made.  */
5766         result = build (BIND_EXPR, TREE_TYPE (result),
5767                         NULL_TREE, result, t);
5768         /* Remove the block from the tree at this point.
5769            It gets put back at the proper place
5770            when the BIND_EXPR is expanded.  */
5771         delete_block (t);
5772       }
5773     else
5774       result = t;
5775   }
5776
5777   return result;
5778 }
5779
5780 /* ffecom_expr_transform_ -- Transform symbols in expr
5781
5782    ffebld expr;  // FFE expression.
5783    ffecom_expr_transform_ (expr);
5784
5785    Recursive descent on expr while transforming any untransformed SYMTERs.  */
5786
5787 static void
5788 ffecom_expr_transform_ (ffebld expr)
5789 {
5790   tree t;
5791   ffesymbol s;
5792
5793  tail_recurse:
5794
5795   if (expr == NULL)
5796     return;
5797
5798   switch (ffebld_op (expr))
5799     {
5800     case FFEBLD_opSYMTER:
5801       s = ffebld_symter (expr);
5802       t = ffesymbol_hook (s).decl_tree;
5803       if ((t == NULL_TREE)
5804           && ((ffesymbol_kind (s) != FFEINFO_kindNONE)
5805               || ((ffesymbol_where (s) != FFEINFO_whereNONE)
5806                   && (ffesymbol_where (s) != FFEINFO_whereINTRINSIC))))
5807         {
5808           s = ffecom_sym_transform_ (s);
5809           t = ffesymbol_hook (s).decl_tree;     /* Sfunc expr non-dummy,
5810                                                    DIMENSION expr? */
5811         }
5812       break;                    /* Ok if (t == NULL) here. */
5813
5814     case FFEBLD_opITEM:
5815       ffecom_expr_transform_ (ffebld_head (expr));
5816       expr = ffebld_trail (expr);
5817       goto tail_recurse;        /* :::::::::::::::::::: */
5818
5819     default:
5820       break;
5821     }
5822
5823   switch (ffebld_arity (expr))
5824     {
5825     case 2:
5826       ffecom_expr_transform_ (ffebld_left (expr));
5827       expr = ffebld_right (expr);
5828       goto tail_recurse;        /* :::::::::::::::::::: */
5829
5830     case 1:
5831       expr = ffebld_left (expr);
5832       goto tail_recurse;        /* :::::::::::::::::::: */
5833
5834     default:
5835       break;
5836     }
5837
5838   return;
5839 }
5840
5841 /* Make a type based on info in live f2c.h file.  */
5842
5843 static void
5844 ffecom_f2c_make_type_ (tree *type, int tcode, const char *name)
5845 {
5846   switch (tcode)
5847     {
5848     case FFECOM_f2ccodeCHAR:
5849       *type = make_signed_type (CHAR_TYPE_SIZE);
5850       break;
5851
5852     case FFECOM_f2ccodeSHORT:
5853       *type = make_signed_type (SHORT_TYPE_SIZE);
5854       break;
5855
5856     case FFECOM_f2ccodeINT:
5857       *type = make_signed_type (INT_TYPE_SIZE);
5858       break;
5859
5860     case FFECOM_f2ccodeLONG:
5861       *type = make_signed_type (LONG_TYPE_SIZE);
5862       break;
5863
5864     case FFECOM_f2ccodeLONGLONG:
5865       *type = make_signed_type (LONG_LONG_TYPE_SIZE);
5866       break;
5867
5868     case FFECOM_f2ccodeCHARPTR:
5869       *type = build_pointer_type (DEFAULT_SIGNED_CHAR
5870                                   ? signed_char_type_node
5871                                   : unsigned_char_type_node);
5872       break;
5873
5874     case FFECOM_f2ccodeFLOAT:
5875       *type = make_node (REAL_TYPE);
5876       TYPE_PRECISION (*type) = FLOAT_TYPE_SIZE;
5877       layout_type (*type);
5878       break;
5879
5880     case FFECOM_f2ccodeDOUBLE:
5881       *type = make_node (REAL_TYPE);
5882       TYPE_PRECISION (*type) = DOUBLE_TYPE_SIZE;
5883       layout_type (*type);
5884       break;
5885
5886     case FFECOM_f2ccodeLONGDOUBLE:
5887       *type = make_node (REAL_TYPE);
5888       TYPE_PRECISION (*type) = LONG_DOUBLE_TYPE_SIZE;
5889       layout_type (*type);
5890       break;
5891
5892     case FFECOM_f2ccodeTWOREALS:
5893       *type = ffecom_make_complex_type_ (ffecom_f2c_real_type_node);
5894       break;
5895
5896     case FFECOM_f2ccodeTWODOUBLEREALS:
5897       *type = ffecom_make_complex_type_ (ffecom_f2c_doublereal_type_node);
5898       break;
5899
5900     default:
5901       assert ("unexpected FFECOM_f2ccodeXYZZY!" == NULL);
5902       *type = error_mark_node;
5903       return;
5904     }
5905
5906   pushdecl (build_decl (TYPE_DECL,
5907                         ffecom_get_invented_identifier ("__g77_f2c_%s", name),
5908                         *type));
5909 }
5910
5911 /* Set the f2c list-directed-I/O code for whatever (integral) type has the
5912    given size.  */
5913
5914 static void
5915 ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
5916                           int code)
5917 {
5918   int j;
5919   tree t;
5920
5921   for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
5922     if ((t = ffecom_tree_type[bt][j]) != NULL_TREE
5923         && compare_tree_int (TYPE_SIZE (t), size) == 0)
5924       {
5925         assert (code != -1);
5926         ffecom_f2c_typecode_[bt][j] = code;
5927         code = -1;
5928       }
5929 }
5930
5931 /* Finish up globals after doing all program units in file
5932
5933    Need to handle only uninitialized COMMON areas.  */
5934
5935 static ffeglobal
5936 ffecom_finish_global_ (ffeglobal global)
5937 {
5938   tree cbtype;
5939   tree cbt;
5940   tree size;
5941
5942   if (ffeglobal_type (global) != FFEGLOBAL_typeCOMMON)
5943       return global;
5944
5945   if (ffeglobal_common_init (global))
5946       return global;
5947
5948   cbt = ffeglobal_hook (global);
5949   if ((cbt == NULL_TREE)
5950       || !ffeglobal_common_have_size (global))
5951     return global;              /* No need to make common, never ref'd. */
5952
5953   DECL_EXTERNAL (cbt) = 0;
5954
5955   /* Give the array a size now.  */
5956
5957   size = build_int_2 ((ffeglobal_common_size (global)
5958                       + ffeglobal_common_pad (global)) - 1,
5959                       0);
5960
5961   cbtype = TREE_TYPE (cbt);
5962   TYPE_DOMAIN (cbtype) = build_range_type (integer_type_node,
5963                                            integer_zero_node,
5964                                            size);
5965   if (!TREE_TYPE (size))
5966     TREE_TYPE (size) = TYPE_DOMAIN (cbtype);
5967   layout_type (cbtype);
5968
5969   cbt = start_decl (cbt, FALSE);
5970   assert (cbt == ffeglobal_hook (global));
5971
5972   finish_decl (cbt, NULL_TREE, FALSE);
5973
5974   return global;
5975 }
5976
5977 /* Finish up any untransformed symbols.  */
5978
5979 static ffesymbol
5980 ffecom_finish_symbol_transform_ (ffesymbol s)
5981 {
5982   if ((s == NULL) || (TREE_CODE (current_function_decl) == ERROR_MARK))
5983     return s;
5984
5985   /* It's easy to know to transform an untransformed symbol, to make sure
5986      we put out debugging info for it.  But COMMON variables, unlike
5987      EQUIVALENCE ones, aren't given declarations in addition to the
5988      tree expressions that specify offsets, because COMMON variables
5989      can be referenced in the outer scope where only dummy arguments
5990      (PARM_DECLs) should really be seen.  To be safe, just don't do any
5991      VAR_DECLs for COMMON variables when we transform them for real
5992      use, and therefore we do all the VAR_DECL creating here.  */
5993
5994   if (ffesymbol_hook (s).decl_tree == NULL_TREE)
5995     {
5996       if (ffesymbol_kind (s) != FFEINFO_kindNONE
5997           || (ffesymbol_where (s) != FFEINFO_whereNONE
5998               && ffesymbol_where (s) != FFEINFO_whereINTRINSIC
5999               && ffesymbol_where (s) != FFEINFO_whereDUMMY))
6000         /* Not transformed, and not CHARACTER*(*), and not a dummy
6001            argument, which can happen only if the entry point names
6002            it "rides in on" are all invalidated for other reasons.  */
6003         s = ffecom_sym_transform_ (s);
6004     }
6005
6006   if ((ffesymbol_where (s) == FFEINFO_whereCOMMON)
6007       && (ffesymbol_hook (s).decl_tree != error_mark_node))
6008     {
6009       /* This isn't working, at least for dbxout.  The .s file looks
6010          okay to me (burley), but in gdb 4.9 at least, the variables
6011          appear to reside somewhere outside of the common area, so
6012          it doesn't make sense to mislead anyone by generating the info
6013          on those variables until this is fixed.  NOTE: Same problem
6014          with EQUIVALENCE, sadly...see similar #if later.  */
6015       ffecom_member_phase2_ (ffesymbol_storage (ffesymbol_common (s)),
6016                              ffesymbol_storage (s));
6017     }
6018
6019   return s;
6020 }
6021
6022 /* Append underscore(s) to name before calling get_identifier.  "us"
6023    is nonzero if the name already contains an underscore and thus
6024    needs two underscores appended.  */
6025
6026 static tree
6027 ffecom_get_appended_identifier_ (char us, const char *name)
6028 {
6029   int i;
6030   char *newname;
6031   tree id;
6032
6033   newname = xmalloc ((i = strlen (name)) + 1
6034                      + ffe_is_underscoring ()
6035                      + us);
6036   memcpy (newname, name, i);
6037   newname[i] = '_';
6038   newname[i + us] = '_';
6039   newname[i + 1 + us] = '\0';
6040   id = get_identifier (newname);
6041
6042   free (newname);
6043
6044   return id;
6045 }
6046
6047 /* Decide whether to append underscore to name before calling
6048    get_identifier.  */
6049
6050 static tree
6051 ffecom_get_external_identifier_ (ffesymbol s)
6052 {
6053   char us;
6054   const char *name = ffesymbol_text (s);
6055
6056   /* If name is a built-in name, just return it as is.  */
6057
6058   if (!ffe_is_underscoring ()
6059       || (strcmp (name, FFETARGET_nameBLANK_COMMON) == 0)
6060 #if FFETARGET_isENFORCED_MAIN_NAME
6061       || (strcmp (name, FFETARGET_nameENFORCED_NAME) == 0)
6062 #else
6063       || (strcmp (name, FFETARGET_nameUNNAMED_MAIN) == 0)
6064 #endif
6065       || (strcmp (name, FFETARGET_nameUNNAMED_BLOCK_DATA) == 0))
6066     return get_identifier (name);
6067
6068   us = ffe_is_second_underscore ()
6069     ? (strchr (name, '_') != NULL)
6070       : 0;
6071
6072   return ffecom_get_appended_identifier_ (us, name);
6073 }
6074
6075 /* Decide whether to append underscore to internal name before calling
6076    get_identifier.
6077
6078    This is for non-external, top-function-context names only.  Transform
6079    identifier so it doesn't conflict with the transformed result
6080    of using a _different_ external name.  E.g. if "CALL FOO" is
6081    transformed into "FOO_();", then the variable in "FOO_ = 3"
6082    must be transformed into something that does not conflict, since
6083    these two things should be independent.
6084
6085    The transformation is as follows.  If the name does not contain
6086    an underscore, there is no possible conflict, so just return.
6087    If the name does contain an underscore, then transform it just
6088    like we transform an external identifier.  */
6089
6090 static tree
6091 ffecom_get_identifier_ (const char *name)
6092 {
6093   /* If name does not contain an underscore, just return it as is.  */
6094
6095   if (!ffe_is_underscoring ()
6096       || (strchr (name, '_') == NULL))
6097     return get_identifier (name);
6098
6099   return ffecom_get_appended_identifier_ (ffe_is_second_underscore (),
6100                                           name);
6101 }
6102
6103 /* ffecom_gen_sfuncdef_ -- Generate definition of statement function
6104
6105    tree t;
6106    ffesymbol s;  // kindFUNCTION, whereIMMEDIATE.
6107    t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s),
6108          ffesymbol_kindtype(s));
6109
6110    Call after setting up containing function and getting trees for all
6111    other symbols.  */
6112
6113 static tree
6114 ffecom_gen_sfuncdef_ (ffesymbol s, ffeinfoBasictype bt, ffeinfoKindtype kt)
6115 {
6116   ffebld expr = ffesymbol_sfexpr (s);
6117   tree type;
6118   tree func;
6119   tree result;
6120   bool charfunc = (bt == FFEINFO_basictypeCHARACTER);
6121   static bool recurse = FALSE;
6122   int old_lineno = lineno;
6123   const char *old_input_filename = input_filename;
6124
6125   ffecom_nested_entry_ = s;
6126
6127   /* For now, we don't have a handy pointer to where the sfunc is actually
6128      defined, though that should be easy to add to an ffesymbol. (The
6129      token/where info available might well point to the place where the type
6130      of the sfunc is declared, especially if that precedes the place where
6131      the sfunc itself is defined, which is typically the case.)  We should
6132      put out a null pointer rather than point somewhere wrong, but I want to
6133      see how it works at this point.  */
6134
6135   input_filename = ffesymbol_where_filename (s);
6136   lineno = ffesymbol_where_filelinenum (s);
6137
6138   /* Pretransform the expression so any newly discovered things belong to the
6139      outer program unit, not to the statement function. */
6140
6141   ffecom_expr_transform_ (expr);
6142
6143   /* Make sure no recursive invocation of this fn (a specific case of failing
6144      to pretransform an sfunc's expression, i.e. where its expression
6145      references another untransformed sfunc) happens. */
6146
6147   assert (!recurse);
6148   recurse = TRUE;
6149
6150   push_f_function_context ();
6151
6152   if (charfunc)
6153     type = void_type_node;
6154   else
6155     {
6156       type = ffecom_tree_type[bt][kt];
6157       if (type == NULL_TREE)
6158         type = integer_type_node;       /* _sym_exec_transition reports
6159                                            error. */
6160     }
6161
6162   start_function (ffecom_get_identifier_ (ffesymbol_text (s)),
6163                   build_function_type (type, NULL_TREE),
6164                   1,            /* nested/inline */
6165                   0);           /* TREE_PUBLIC */
6166
6167   /* We don't worry about COMPLEX return values here, because this is
6168      entirely internal to our code, and gcc has the ability to return COMPLEX
6169      directly as a value.  */
6170
6171   if (charfunc)
6172     {                           /* Prepend arg for where result goes. */
6173       tree type;
6174
6175       type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
6176
6177       result = ffecom_get_invented_identifier ("__g77_%s", "result");
6178
6179       ffecom_char_enhance_arg_ (&type, s);      /* Ignore returned length. */
6180
6181       type = build_pointer_type (type);
6182       result = build_decl (PARM_DECL, result, type);
6183
6184       push_parm_decl (result);
6185     }
6186   else
6187     result = NULL_TREE;         /* Not ref'd if !charfunc. */
6188
6189   ffecom_push_dummy_decls_ (ffesymbol_dummyargs (s), TRUE);
6190
6191   store_parm_decls (0);
6192
6193   ffecom_start_compstmt ();
6194
6195   if (expr != NULL)
6196     {
6197       if (charfunc)
6198         {
6199           ffetargetCharacterSize sz = ffesymbol_size (s);
6200           tree result_length;
6201
6202           result_length = build_int_2 (sz, 0);
6203           TREE_TYPE (result_length) = ffecom_f2c_ftnlen_type_node;
6204
6205           ffecom_prepare_let_char_ (sz, expr);
6206
6207           ffecom_prepare_end ();
6208
6209           ffecom_let_char_ (result, result_length, sz, expr);
6210           expand_null_return ();
6211         }
6212       else
6213         {
6214           ffecom_prepare_expr (expr);
6215
6216           ffecom_prepare_end ();
6217
6218           expand_return (ffecom_modify (NULL_TREE,
6219                                         DECL_RESULT (current_function_decl),
6220                                         ffecom_expr (expr)));
6221         }
6222     }
6223
6224   ffecom_end_compstmt ();
6225
6226   func = current_function_decl;
6227   finish_function (1);
6228
6229   pop_f_function_context ();
6230
6231   recurse = FALSE;
6232
6233   lineno = old_lineno;
6234   input_filename = old_input_filename;
6235
6236   ffecom_nested_entry_ = NULL;
6237
6238   return func;
6239 }
6240
6241 static const char *
6242 ffecom_gfrt_args_ (ffecomGfrt ix)
6243 {
6244   return ffecom_gfrt_argstring_[ix];
6245 }
6246
6247 static tree
6248 ffecom_gfrt_tree_ (ffecomGfrt ix)
6249 {
6250   if (ffecom_gfrt_[ix] == NULL_TREE)
6251     ffecom_make_gfrt_ (ix);
6252
6253   return ffecom_1 (ADDR_EXPR,
6254                    build_pointer_type (TREE_TYPE (ffecom_gfrt_[ix])),
6255                    ffecom_gfrt_[ix]);
6256 }
6257
6258 /* Return initialize-to-zero expression for this VAR_DECL.  */
6259
6260 /* A somewhat evil way to prevent the garbage collector
6261    from collecting 'tree' structures.  */
6262 #define NUM_TRACKED_CHUNK 63
6263 static struct tree_ggc_tracker
6264 {
6265   struct tree_ggc_tracker *next;
6266   tree trees[NUM_TRACKED_CHUNK];
6267 } *tracker_head = NULL;
6268
6269 static void
6270 mark_tracker_head (void *arg)
6271 {
6272   struct tree_ggc_tracker *head;
6273   int i;
6274
6275   for (head = * (struct tree_ggc_tracker **) arg;
6276        head != NULL;
6277        head = head->next)
6278   {
6279     ggc_mark (head);
6280     for (i = 0; i < NUM_TRACKED_CHUNK; i++)
6281       ggc_mark_tree (head->trees[i]);
6282   }
6283 }
6284
6285 void
6286 ffecom_save_tree_forever (tree t)
6287 {
6288   int i;
6289   if (tracker_head != NULL)
6290     for (i = 0; i < NUM_TRACKED_CHUNK; i++)
6291       if (tracker_head->trees[i] == NULL)
6292         {
6293           tracker_head->trees[i] = t;
6294           return;
6295         }
6296
6297   {
6298     /* Need to allocate a new block.  */
6299     struct tree_ggc_tracker *old_head = tracker_head;
6300
6301     tracker_head = ggc_alloc (sizeof (*tracker_head));
6302     tracker_head->next = old_head;
6303     tracker_head->trees[0] = t;
6304     for (i = 1; i < NUM_TRACKED_CHUNK; i++)
6305       tracker_head->trees[i] = NULL;
6306   }
6307 }
6308
6309 static tree
6310 ffecom_init_zero_ (tree decl)
6311 {
6312   tree init;
6313   int incremental = TREE_STATIC (decl);
6314   tree type = TREE_TYPE (decl);
6315
6316   if (incremental)
6317     {
6318       make_decl_rtl (decl, NULL);
6319       assemble_variable (decl, TREE_PUBLIC (decl) ? 1 : 0, 0, 1);
6320     }
6321
6322   if ((TREE_CODE (type) != ARRAY_TYPE)
6323       && (TREE_CODE (type) != RECORD_TYPE)
6324       && (TREE_CODE (type) != UNION_TYPE)
6325       && !incremental)
6326     init = convert (type, integer_zero_node);
6327   else if (!incremental)
6328     {
6329       init = build (CONSTRUCTOR, type, NULL_TREE, NULL_TREE);
6330       TREE_CONSTANT (init) = 1;
6331       TREE_STATIC (init) = 1;
6332     }
6333   else
6334     {
6335       assemble_zeros (int_size_in_bytes (type));
6336       init = error_mark_node;
6337     }
6338
6339   return init;
6340 }
6341
6342 static tree
6343 ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
6344                          tree *maybe_tree)
6345 {
6346   tree expr_tree;
6347   tree length_tree;
6348
6349   switch (ffebld_op (arg))
6350     {
6351     case FFEBLD_opCONTER:       /* For F90, check 0-length. */
6352       if (ffetarget_length_character1
6353           (ffebld_constant_character1
6354            (ffebld_conter (arg))) == 0)
6355         {
6356           *maybe_tree = integer_zero_node;
6357           return convert (tree_type, integer_zero_node);
6358         }
6359
6360       *maybe_tree = integer_one_node;
6361       expr_tree = build_int_2 (*ffetarget_text_character1
6362                                (ffebld_constant_character1
6363                                 (ffebld_conter (arg))),
6364                                0);
6365       TREE_TYPE (expr_tree) = tree_type;
6366       return expr_tree;
6367
6368     case FFEBLD_opSYMTER:
6369     case FFEBLD_opARRAYREF:
6370     case FFEBLD_opFUNCREF:
6371     case FFEBLD_opSUBSTR:
6372       ffecom_char_args_ (&expr_tree, &length_tree, arg);
6373
6374       if ((expr_tree == error_mark_node)
6375           || (length_tree == error_mark_node))
6376         {
6377           *maybe_tree = error_mark_node;
6378           return error_mark_node;
6379         }
6380
6381       if (integer_zerop (length_tree))
6382         {
6383           *maybe_tree = integer_zero_node;
6384           return convert (tree_type, integer_zero_node);
6385         }
6386
6387       expr_tree
6388         = ffecom_1 (INDIRECT_REF,
6389                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6390                     expr_tree);
6391       expr_tree
6392         = ffecom_2 (ARRAY_REF,
6393                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6394                     expr_tree,
6395                     integer_one_node);
6396       expr_tree = convert (tree_type, expr_tree);
6397
6398       if (TREE_CODE (length_tree) == INTEGER_CST)
6399         *maybe_tree = integer_one_node;
6400       else                      /* Must check length at run time.  */
6401         *maybe_tree
6402           = ffecom_truth_value
6403             (ffecom_2 (GT_EXPR, integer_type_node,
6404                        length_tree,
6405                        ffecom_f2c_ftnlen_zero_node));
6406       return expr_tree;
6407
6408     case FFEBLD_opPAREN:
6409     case FFEBLD_opCONVERT:
6410       if (ffeinfo_size (ffebld_info (arg)) == 0)
6411         {
6412           *maybe_tree = integer_zero_node;
6413           return convert (tree_type, integer_zero_node);
6414         }
6415       return ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6416                                       maybe_tree);
6417
6418     case FFEBLD_opCONCATENATE:
6419       {
6420         tree maybe_left;
6421         tree maybe_right;
6422         tree expr_left;
6423         tree expr_right;
6424
6425         expr_left = ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6426                                              &maybe_left);
6427         expr_right = ffecom_intrinsic_ichar_ (tree_type, ffebld_right (arg),
6428                                               &maybe_right);
6429         *maybe_tree = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
6430                                 maybe_left,
6431                                 maybe_right);
6432         expr_tree = ffecom_3 (COND_EXPR, tree_type,
6433                               maybe_left,
6434                               expr_left,
6435                               expr_right);
6436         return expr_tree;
6437       }
6438
6439     default:
6440       assert ("bad op in ICHAR" == NULL);
6441       return error_mark_node;
6442     }
6443 }
6444
6445 /* ffecom_intrinsic_len_ -- Return length info for char arg (LEN())
6446
6447    tree length_arg;
6448    ffebld expr;
6449    length_arg = ffecom_intrinsic_len_ (expr);
6450
6451    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
6452    subexpressions by constructing the appropriate tree for the
6453    length-of-character-text argument in a calling sequence.  */
6454
6455 static tree
6456 ffecom_intrinsic_len_ (ffebld expr)
6457 {
6458   ffetargetCharacter1 val;
6459   tree length;
6460
6461   switch (ffebld_op (expr))
6462     {
6463     case FFEBLD_opCONTER:
6464       val = ffebld_constant_character1 (ffebld_conter (expr));
6465       length = build_int_2 (ffetarget_length_character1 (val), 0);
6466       TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6467       break;
6468
6469     case FFEBLD_opSYMTER:
6470       {
6471         ffesymbol s = ffebld_symter (expr);
6472         tree item;
6473
6474         item = ffesymbol_hook (s).decl_tree;
6475         if (item == NULL_TREE)
6476           {
6477             s = ffecom_sym_transform_ (s);
6478             item = ffesymbol_hook (s).decl_tree;
6479           }
6480         if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
6481           {
6482             if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
6483               length = ffesymbol_hook (s).length_tree;
6484             else
6485               {
6486                 length = build_int_2 (ffesymbol_size (s), 0);
6487                 TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6488               }
6489           }
6490         else if (item == error_mark_node)
6491           length = error_mark_node;
6492         else                    /* FFEINFO_kindFUNCTION: */
6493           length = NULL_TREE;
6494       }
6495       break;
6496
6497     case FFEBLD_opARRAYREF:
6498       length = ffecom_intrinsic_len_ (ffebld_left (expr));
6499       break;
6500
6501     case FFEBLD_opSUBSTR:
6502       {
6503         ffebld start;
6504         ffebld end;
6505         ffebld thing = ffebld_right (expr);
6506         tree start_tree;
6507         tree end_tree;
6508
6509         assert (ffebld_op (thing) == FFEBLD_opITEM);
6510         start = ffebld_head (thing);
6511         thing = ffebld_trail (thing);
6512         assert (ffebld_trail (thing) == NULL);
6513         end = ffebld_head (thing);
6514
6515         length = ffecom_intrinsic_len_ (ffebld_left (expr));
6516
6517         if (length == error_mark_node)
6518           break;
6519
6520         if (start == NULL)
6521           {
6522             if (end == NULL)
6523               ;
6524             else
6525               {
6526                 length = convert (ffecom_f2c_ftnlen_type_node,
6527                                   ffecom_expr (end));
6528               }
6529           }
6530         else
6531           {
6532             start_tree = convert (ffecom_f2c_ftnlen_type_node,
6533                                   ffecom_expr (start));
6534
6535             if (start_tree == error_mark_node)
6536               {
6537                 length = error_mark_node;
6538                 break;
6539               }
6540
6541             if (end == NULL)
6542               {
6543                 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6544                                    ffecom_f2c_ftnlen_one_node,
6545                                    ffecom_2 (MINUS_EXPR,
6546                                              ffecom_f2c_ftnlen_type_node,
6547                                              length,
6548                                              start_tree));
6549               }
6550             else
6551               {
6552                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
6553                                     ffecom_expr (end));
6554
6555                 if (end_tree == error_mark_node)
6556                   {
6557                     length = error_mark_node;
6558                     break;
6559                   }
6560
6561                 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6562                                    ffecom_f2c_ftnlen_one_node,
6563                                    ffecom_2 (MINUS_EXPR,
6564                                              ffecom_f2c_ftnlen_type_node,
6565                                              end_tree, start_tree));
6566               }
6567           }
6568       }
6569       break;
6570
6571     case FFEBLD_opCONCATENATE:
6572       length
6573         = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6574                     ffecom_intrinsic_len_ (ffebld_left (expr)),
6575                     ffecom_intrinsic_len_ (ffebld_right (expr)));
6576       break;
6577
6578     case FFEBLD_opFUNCREF:
6579     case FFEBLD_opCONVERT:
6580       length = build_int_2 (ffebld_size (expr), 0);
6581       TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6582       break;
6583
6584     default:
6585       assert ("bad op for single char arg expr" == NULL);
6586       length = ffecom_f2c_ftnlen_zero_node;
6587       break;
6588     }
6589
6590   assert (length != NULL_TREE);
6591
6592   return length;
6593 }
6594
6595 /* Handle CHARACTER assignments.
6596
6597    Generates code to do the assignment.  Used by ordinary assignment
6598    statement handler ffecom_let_stmt and by statement-function
6599    handler to generate code for a statement function.  */
6600
6601 static void
6602 ffecom_let_char_ (tree dest_tree, tree dest_length,
6603                   ffetargetCharacterSize dest_size, ffebld source)
6604 {
6605   ffecomConcatList_ catlist;
6606   tree source_length;
6607   tree source_tree;
6608   tree expr_tree;
6609
6610   if ((dest_tree == error_mark_node)
6611       || (dest_length == error_mark_node))
6612     return;
6613
6614   assert (dest_tree != NULL_TREE);
6615   assert (dest_length != NULL_TREE);
6616
6617   /* Source might be an opCONVERT, which just means it is a different size
6618      than the destination.  Since the underlying implementation here handles
6619      that (directly or via the s_copy or s_cat run-time-library functions),
6620      we don't need the "convenience" of an opCONVERT that tells us to
6621      truncate or blank-pad, particularly since the resulting implementation
6622      would probably be slower than otherwise. */
6623
6624   while (ffebld_op (source) == FFEBLD_opCONVERT)
6625     source = ffebld_left (source);
6626
6627   catlist = ffecom_concat_list_new_ (source, dest_size);
6628   switch (ffecom_concat_list_count_ (catlist))
6629     {
6630     case 0:                     /* Shouldn't happen, but in case it does... */
6631       ffecom_concat_list_kill_ (catlist);
6632       source_tree = null_pointer_node;
6633       source_length = ffecom_f2c_ftnlen_zero_node;
6634       expr_tree = build_tree_list (NULL_TREE, dest_tree);
6635       TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6636       TREE_CHAIN (TREE_CHAIN (expr_tree))
6637         = build_tree_list (NULL_TREE, dest_length);
6638       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6639         = build_tree_list (NULL_TREE, source_length);
6640
6641       expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6642       TREE_SIDE_EFFECTS (expr_tree) = 1;
6643
6644       expand_expr_stmt (expr_tree);
6645
6646       return;
6647
6648     case 1:                     /* The (fairly) easy case. */
6649       ffecom_char_args_ (&source_tree, &source_length,
6650                          ffecom_concat_list_expr_ (catlist, 0));
6651       ffecom_concat_list_kill_ (catlist);
6652       assert (source_tree != NULL_TREE);
6653       assert (source_length != NULL_TREE);
6654
6655       if ((source_tree == error_mark_node)
6656           || (source_length == error_mark_node))
6657         return;
6658
6659       if (dest_size == 1)
6660         {
6661           dest_tree
6662             = ffecom_1 (INDIRECT_REF,
6663                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6664                                                       (dest_tree))),
6665                         dest_tree);
6666           dest_tree
6667             = ffecom_2 (ARRAY_REF,
6668                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6669                                                       (dest_tree))),
6670                         dest_tree,
6671                         integer_one_node);
6672           source_tree
6673             = ffecom_1 (INDIRECT_REF,
6674                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6675                                                       (source_tree))),
6676                         source_tree);
6677           source_tree
6678             = ffecom_2 (ARRAY_REF,
6679                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6680                                                       (source_tree))),
6681                         source_tree,
6682                         integer_one_node);
6683
6684           expr_tree = ffecom_modify (void_type_node, dest_tree, source_tree);
6685
6686           expand_expr_stmt (expr_tree);
6687
6688           return;
6689         }
6690
6691       expr_tree = build_tree_list (NULL_TREE, dest_tree);
6692       TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6693       TREE_CHAIN (TREE_CHAIN (expr_tree))
6694         = build_tree_list (NULL_TREE, dest_length);
6695       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6696         = build_tree_list (NULL_TREE, source_length);
6697
6698       expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6699       TREE_SIDE_EFFECTS (expr_tree) = 1;
6700
6701       expand_expr_stmt (expr_tree);
6702
6703       return;
6704
6705     default:                    /* Must actually concatenate things. */
6706       break;
6707     }
6708
6709   /* Heavy-duty concatenation. */
6710
6711   {
6712     int count = ffecom_concat_list_count_ (catlist);
6713     int i;
6714     tree lengths;
6715     tree items;
6716     tree length_array;
6717     tree item_array;
6718     tree citem;
6719     tree clength;
6720
6721 #ifdef HOHO
6722     length_array
6723       = lengths
6724       = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
6725                              FFETARGET_charactersizeNONE, count, TRUE);
6726     item_array = items = ffecom_push_tempvar (ffecom_f2c_address_type_node,
6727                                               FFETARGET_charactersizeNONE,
6728                                               count, TRUE);
6729 #else
6730     {
6731       tree hook;
6732
6733       hook = ffebld_nonter_hook (source);
6734       assert (hook);
6735       assert (TREE_CODE (hook) == TREE_VEC);
6736       assert (TREE_VEC_LENGTH (hook) == 2);
6737       length_array = lengths = TREE_VEC_ELT (hook, 0);
6738       item_array = items = TREE_VEC_ELT (hook, 1);
6739     }
6740 #endif
6741
6742     for (i = 0; i < count; ++i)
6743       {
6744         ffecom_char_args_ (&citem, &clength,
6745                            ffecom_concat_list_expr_ (catlist, i));
6746         if ((citem == error_mark_node)
6747             || (clength == error_mark_node))
6748           {
6749             ffecom_concat_list_kill_ (catlist);
6750             return;
6751           }
6752
6753         items
6754           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
6755                       ffecom_modify (void_type_node,
6756                                      ffecom_2 (ARRAY_REF,
6757                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
6758                                                item_array,
6759                                                build_int_2 (i, 0)),
6760                                      citem),
6761                       items);
6762         lengths
6763           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
6764                       ffecom_modify (void_type_node,
6765                                      ffecom_2 (ARRAY_REF,
6766                    TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
6767                                                length_array,
6768                                                build_int_2 (i, 0)),
6769                                      clength),
6770                       lengths);
6771       }
6772
6773     expr_tree = build_tree_list (NULL_TREE, dest_tree);
6774     TREE_CHAIN (expr_tree)
6775       = build_tree_list (NULL_TREE,
6776                          ffecom_1 (ADDR_EXPR,
6777                                    build_pointer_type (TREE_TYPE (items)),
6778                                    items));
6779     TREE_CHAIN (TREE_CHAIN (expr_tree))
6780       = build_tree_list (NULL_TREE,
6781                          ffecom_1 (ADDR_EXPR,
6782                                    build_pointer_type (TREE_TYPE (lengths)),
6783                                    lengths));
6784     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6785       = build_tree_list
6786         (NULL_TREE,
6787          ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
6788                    convert (ffecom_f2c_ftnlen_type_node,
6789                             build_int_2 (count, 0))));
6790     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree))))
6791       = build_tree_list (NULL_TREE, dest_length);
6792
6793     expr_tree = ffecom_call_gfrt (FFECOM_gfrtCAT, expr_tree, NULL_TREE);
6794     TREE_SIDE_EFFECTS (expr_tree) = 1;
6795
6796     expand_expr_stmt (expr_tree);
6797   }
6798
6799   ffecom_concat_list_kill_ (catlist);
6800 }
6801
6802 /* ffecom_make_gfrt_ -- Make initial info for run-time routine
6803
6804    ffecomGfrt ix;
6805    ffecom_make_gfrt_(ix);
6806
6807    Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL
6808    for the indicated run-time routine (ix).  */
6809
6810 static void
6811 ffecom_make_gfrt_ (ffecomGfrt ix)
6812 {
6813   tree t;
6814   tree ttype;
6815
6816   switch (ffecom_gfrt_type_[ix])
6817     {
6818     case FFECOM_rttypeVOID_:
6819       ttype = void_type_node;
6820       break;
6821
6822     case FFECOM_rttypeVOIDSTAR_:
6823       ttype = TREE_TYPE (null_pointer_node);    /* `void *'. */
6824       break;
6825
6826     case FFECOM_rttypeFTNINT_:
6827       ttype = ffecom_f2c_ftnint_type_node;
6828       break;
6829
6830     case FFECOM_rttypeINTEGER_:
6831       ttype = ffecom_f2c_integer_type_node;
6832       break;
6833
6834     case FFECOM_rttypeLONGINT_:
6835       ttype = ffecom_f2c_longint_type_node;
6836       break;
6837
6838     case FFECOM_rttypeLOGICAL_:
6839       ttype = ffecom_f2c_logical_type_node;
6840       break;
6841
6842     case FFECOM_rttypeREAL_F2C_:
6843       ttype = double_type_node;
6844       break;
6845
6846     case FFECOM_rttypeREAL_GNU_:
6847       ttype = float_type_node;
6848       break;
6849
6850     case FFECOM_rttypeCOMPLEX_F2C_:
6851       ttype = void_type_node;
6852       break;
6853
6854     case FFECOM_rttypeCOMPLEX_GNU_:
6855       ttype = ffecom_f2c_complex_type_node;
6856       break;
6857
6858     case FFECOM_rttypeDOUBLE_:
6859       ttype = double_type_node;
6860       break;
6861
6862     case FFECOM_rttypeDOUBLEREAL_:
6863       ttype = ffecom_f2c_doublereal_type_node;
6864       break;
6865
6866     case FFECOM_rttypeDBLCMPLX_F2C_:
6867       ttype = void_type_node;
6868       break;
6869
6870     case FFECOM_rttypeDBLCMPLX_GNU_:
6871       ttype = ffecom_f2c_doublecomplex_type_node;
6872       break;
6873
6874     case FFECOM_rttypeCHARACTER_:
6875       ttype = void_type_node;
6876       break;
6877
6878     default:
6879       ttype = NULL;
6880       assert ("bad rttype" == NULL);
6881       break;
6882     }
6883
6884   ttype = build_function_type (ttype, NULL_TREE);
6885   t = build_decl (FUNCTION_DECL,
6886                   get_identifier (ffecom_gfrt_name_[ix]),
6887                   ttype);
6888   DECL_EXTERNAL (t) = 1;
6889   TREE_READONLY (t) = ffecom_gfrt_const_[ix] ? 1 : 0;
6890   TREE_PUBLIC (t) = 1;
6891   TREE_THIS_VOLATILE (t) = ffecom_gfrt_volatile_[ix] ? 1 : 0;
6892
6893   /* Sanity check:  A function that's const cannot be volatile.  */
6894
6895   assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_volatile_[ix] : 1);
6896
6897   /* Sanity check: A function that's const cannot return complex.  */
6898
6899   assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_complex_[ix] : 1);
6900
6901   t = start_decl (t, TRUE);
6902
6903   finish_decl (t, NULL_TREE, TRUE);
6904
6905   ffecom_gfrt_[ix] = t;
6906 }
6907
6908 /* Phase 1 pass over each member of a COMMON/EQUIVALENCE group.  */
6909
6910 static void
6911 ffecom_member_phase1_ (ffestorag mst UNUSED, ffestorag st)
6912 {
6913   ffesymbol s = ffestorag_symbol (st);
6914
6915   if (ffesymbol_namelisted (s))
6916     ffecom_member_namelisted_ = TRUE;
6917 }
6918
6919 /* Phase 2 pass over each member of a COMMON/EQUIVALENCE group.  Declare
6920    the member so debugger will see it.  Otherwise nobody should be
6921    referencing the member.  */
6922
6923 static void
6924 ffecom_member_phase2_ (ffestorag mst, ffestorag st)
6925 {
6926   ffesymbol s;
6927   tree t;
6928   tree mt;
6929   tree type;
6930
6931   if ((mst == NULL)
6932       || ((mt = ffestorag_hook (mst)) == NULL)
6933       || (mt == error_mark_node))
6934     return;
6935
6936   if ((st == NULL)
6937       || ((s = ffestorag_symbol (st)) == NULL))
6938     return;
6939
6940   type = ffecom_type_localvar_ (s,
6941                                 ffesymbol_basictype (s),
6942                                 ffesymbol_kindtype (s));
6943   if (type == error_mark_node)
6944     return;
6945
6946   t = build_decl (VAR_DECL,
6947                   ffecom_get_identifier_ (ffesymbol_text (s)),
6948                   type);
6949
6950   TREE_STATIC (t) = TREE_STATIC (mt);
6951   DECL_INITIAL (t) = NULL_TREE;
6952   TREE_ASM_WRITTEN (t) = 1;
6953   TREE_USED (t) = 1;
6954
6955   SET_DECL_RTL (t,
6956                 gen_rtx (MEM, TYPE_MODE (type),
6957                          plus_constant (XEXP (DECL_RTL (mt), 0),
6958                                         ffestorag_modulo (mst)
6959                                         + ffestorag_offset (st)
6960                                         - ffestorag_offset (mst))));
6961
6962   t = start_decl (t, FALSE);
6963
6964   finish_decl (t, NULL_TREE, FALSE);
6965 }
6966
6967 /* Prepare source expression for assignment into a destination perhaps known
6968    to be of a specific size.  */
6969
6970 static void
6971 ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size, ffebld source)
6972 {
6973   ffecomConcatList_ catlist;
6974   int count;
6975   int i;
6976   tree ltmp;
6977   tree itmp;
6978   tree tempvar = NULL_TREE;
6979
6980   while (ffebld_op (source) == FFEBLD_opCONVERT)
6981     source = ffebld_left (source);
6982
6983   catlist = ffecom_concat_list_new_ (source, dest_size);
6984   count = ffecom_concat_list_count_ (catlist);
6985
6986   if (count >= 2)
6987     {
6988       ltmp
6989         = ffecom_make_tempvar ("let_char_len", ffecom_f2c_ftnlen_type_node,
6990                                FFETARGET_charactersizeNONE, count);
6991       itmp
6992         = ffecom_make_tempvar ("let_char_item", ffecom_f2c_address_type_node,
6993                                FFETARGET_charactersizeNONE, count);
6994
6995       tempvar = make_tree_vec (2);
6996       TREE_VEC_ELT (tempvar, 0) = ltmp;
6997       TREE_VEC_ELT (tempvar, 1) = itmp;
6998     }
6999
7000   for (i = 0; i < count; ++i)
7001     ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist, i));
7002
7003   ffecom_concat_list_kill_ (catlist);
7004
7005   if (tempvar)
7006     {
7007       ffebld_nonter_set_hook (source, tempvar);
7008       current_binding_level->prep_state = 1;
7009     }
7010 }
7011
7012 /* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order
7013
7014    Ignores STAR (alternate-return) dummies.  All other get exec-transitioned
7015    (which generates their trees) and then their trees get push_parm_decl'd.
7016
7017    The second arg is TRUE if the dummies are for a statement function, in
7018    which case lengths are not pushed for character arguments (since they are
7019    always known by both the caller and the callee, though the code allows
7020    for someday permitting CHAR*(*) stmtfunc dummies).  */
7021
7022 static void
7023 ffecom_push_dummy_decls_ (ffebld dummy_list, bool stmtfunc)
7024 {
7025   ffebld dummy;
7026   ffebld dumlist;
7027   ffesymbol s;
7028   tree parm;
7029
7030   ffecom_transform_only_dummies_ = TRUE;
7031
7032   /* First push the parms corresponding to actual dummy "contents".  */
7033
7034   for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7035     {
7036       dummy = ffebld_head (dumlist);
7037       switch (ffebld_op (dummy))
7038         {
7039         case FFEBLD_opSTAR:
7040         case FFEBLD_opANY:
7041           continue;             /* Forget alternate returns. */
7042
7043         default:
7044           break;
7045         }
7046       assert (ffebld_op (dummy) == FFEBLD_opSYMTER);
7047       s = ffebld_symter (dummy);
7048       parm = ffesymbol_hook (s).decl_tree;
7049       if (parm == NULL_TREE)
7050         {
7051           s = ffecom_sym_transform_ (s);
7052           parm = ffesymbol_hook (s).decl_tree;
7053           assert (parm != NULL_TREE);
7054         }
7055       if (parm != error_mark_node)
7056         push_parm_decl (parm);
7057     }
7058
7059   /* Then, for CHARACTER dummies, push the parms giving their lengths.  */
7060
7061   for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7062     {
7063       dummy = ffebld_head (dumlist);
7064       switch (ffebld_op (dummy))
7065         {
7066         case FFEBLD_opSTAR:
7067         case FFEBLD_opANY:
7068           continue;             /* Forget alternate returns, they mean
7069                                    NOTHING! */
7070
7071         default:
7072           break;
7073         }
7074       s = ffebld_symter (dummy);
7075       if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
7076         continue;               /* Only looking for CHARACTER arguments. */
7077       if (stmtfunc && (ffesymbol_size (s) != FFETARGET_charactersizeNONE))
7078         continue;               /* Stmtfunc arg with known size needs no
7079                                    length param. */
7080       if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
7081         continue;               /* Only looking for variables and arrays. */
7082       parm = ffesymbol_hook (s).length_tree;
7083       assert (parm != NULL_TREE);
7084       if (parm != error_mark_node)
7085         push_parm_decl (parm);
7086     }
7087
7088   ffecom_transform_only_dummies_ = FALSE;
7089 }
7090
7091 /* ffecom_start_progunit_ -- Beginning of program unit
7092
7093    Does GNU back end stuff necessary to teach it about the start of its
7094    equivalent of a Fortran program unit.  */
7095
7096 static void
7097 ffecom_start_progunit_ ()
7098 {
7099   ffesymbol fn = ffecom_primary_entry_;
7100   ffebld arglist;
7101   tree id;                      /* Identifier (name) of function. */
7102   tree type;                    /* Type of function. */
7103   tree result;                  /* Result of function. */
7104   ffeinfoBasictype bt;
7105   ffeinfoKindtype kt;
7106   ffeglobal g;
7107   ffeglobalType gt;
7108   ffeglobalType egt = FFEGLOBAL_type;
7109   bool charfunc;
7110   bool cmplxfunc;
7111   bool altentries = (ffecom_num_entrypoints_ != 0);
7112   bool multi
7113   = altentries
7114   && (ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
7115   && (ffecom_master_bt_ == FFEINFO_basictypeNONE);
7116   bool main_program = FALSE;
7117   int old_lineno = lineno;
7118   const char *old_input_filename = input_filename;
7119
7120   assert (fn != NULL);
7121   assert (ffesymbol_hook (fn).decl_tree == NULL_TREE);
7122
7123   input_filename = ffesymbol_where_filename (fn);
7124   lineno = ffesymbol_where_filelinenum (fn);
7125
7126   switch (ffecom_primary_entry_kind_)
7127     {
7128     case FFEINFO_kindPROGRAM:
7129       main_program = TRUE;
7130       gt = FFEGLOBAL_typeMAIN;
7131       bt = FFEINFO_basictypeNONE;
7132       kt = FFEINFO_kindtypeNONE;
7133       type = ffecom_tree_fun_type_void;
7134       charfunc = FALSE;
7135       cmplxfunc = FALSE;
7136       break;
7137
7138     case FFEINFO_kindBLOCKDATA:
7139       gt = FFEGLOBAL_typeBDATA;
7140       bt = FFEINFO_basictypeNONE;
7141       kt = FFEINFO_kindtypeNONE;
7142       type = ffecom_tree_fun_type_void;
7143       charfunc = FALSE;
7144       cmplxfunc = FALSE;
7145       break;
7146
7147     case FFEINFO_kindFUNCTION:
7148       gt = FFEGLOBAL_typeFUNC;
7149       egt = FFEGLOBAL_typeEXT;
7150       bt = ffesymbol_basictype (fn);
7151       kt = ffesymbol_kindtype (fn);
7152       if (bt == FFEINFO_basictypeNONE)
7153         {
7154           ffeimplic_establish_symbol (fn);
7155           if (ffesymbol_funcresult (fn) != NULL)
7156             ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
7157           bt = ffesymbol_basictype (fn);
7158           kt = ffesymbol_kindtype (fn);
7159         }
7160
7161       if (multi)
7162         charfunc = cmplxfunc = FALSE;
7163       else if (bt == FFEINFO_basictypeCHARACTER)
7164         charfunc = TRUE, cmplxfunc = FALSE;
7165       else if ((bt == FFEINFO_basictypeCOMPLEX)
7166                && ffesymbol_is_f2c (fn)
7167                && !altentries)
7168         charfunc = FALSE, cmplxfunc = TRUE;
7169       else
7170         charfunc = cmplxfunc = FALSE;
7171
7172       if (multi || charfunc)
7173         type = ffecom_tree_fun_type_void;
7174       else if (ffesymbol_is_f2c (fn) && !altentries)
7175         type = ffecom_tree_fun_type[bt][kt];
7176       else
7177         type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
7178
7179       if ((type == NULL_TREE)
7180           || (TREE_TYPE (type) == NULL_TREE))
7181         type = ffecom_tree_fun_type_void;       /* _sym_exec_transition. */
7182       break;
7183
7184     case FFEINFO_kindSUBROUTINE:
7185       gt = FFEGLOBAL_typeSUBR;
7186       egt = FFEGLOBAL_typeEXT;
7187       bt = FFEINFO_basictypeNONE;
7188       kt = FFEINFO_kindtypeNONE;
7189       if (ffecom_is_altreturning_)
7190         type = ffecom_tree_subr_type;
7191       else
7192         type = ffecom_tree_fun_type_void;
7193       charfunc = FALSE;
7194       cmplxfunc = FALSE;
7195       break;
7196
7197     default:
7198       assert ("say what??" == NULL);
7199       /* Fall through. */
7200     case FFEINFO_kindANY:
7201       gt = FFEGLOBAL_typeANY;
7202       bt = FFEINFO_basictypeNONE;
7203       kt = FFEINFO_kindtypeNONE;
7204       type = error_mark_node;
7205       charfunc = FALSE;
7206       cmplxfunc = FALSE;
7207       break;
7208     }
7209
7210   if (altentries)
7211     {
7212       id = ffecom_get_invented_identifier ("__g77_masterfun_%s",
7213                                            ffesymbol_text (fn));
7214     }
7215 #if FFETARGET_isENFORCED_MAIN
7216   else if (main_program)
7217     id = get_identifier (FFETARGET_nameENFORCED_MAIN_NAME);
7218 #endif
7219   else
7220     id = ffecom_get_external_identifier_ (fn);
7221
7222   start_function (id,
7223                   type,
7224                   0,            /* nested/inline */
7225                   !altentries); /* TREE_PUBLIC */
7226
7227   TREE_USED (current_function_decl) = 1;        /* Avoid spurious warning if altentries. */
7228
7229   if (!altentries
7230       && ((g = ffesymbol_global (fn)) != NULL)
7231       && ((ffeglobal_type (g) == gt)
7232           || (ffeglobal_type (g) == egt)))
7233     {
7234       ffeglobal_set_hook (g, current_function_decl);
7235     }
7236
7237   /* Arg handling needs exec-transitioned ffesymbols to work with.  But
7238      exec-transitioning needs current_function_decl to be filled in.  So we
7239      do these things in two phases. */
7240
7241   if (altentries)
7242     {                           /* 1st arg identifies which entrypoint. */
7243       ffecom_which_entrypoint_decl_
7244         = build_decl (PARM_DECL,
7245                       ffecom_get_invented_identifier ("__g77_%s",
7246                                                       "which_entrypoint"),
7247                       integer_type_node);
7248       push_parm_decl (ffecom_which_entrypoint_decl_);
7249     }
7250
7251   if (charfunc
7252       || cmplxfunc
7253       || multi)
7254     {                           /* Arg for result (return value). */
7255       tree type;
7256       tree length;
7257
7258       if (charfunc)
7259         type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
7260       else if (cmplxfunc)
7261         type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
7262       else
7263         type = ffecom_multi_type_node_;
7264
7265       result = ffecom_get_invented_identifier ("__g77_%s", "result");
7266
7267       /* Make length arg _and_ enhance type info for CHAR arg itself.  */
7268
7269       if (charfunc)
7270         length = ffecom_char_enhance_arg_ (&type, fn);
7271       else
7272         length = NULL_TREE;     /* Not ref'd if !charfunc. */
7273
7274       type = build_pointer_type (type);
7275       result = build_decl (PARM_DECL, result, type);
7276
7277       push_parm_decl (result);
7278       if (multi)
7279         ffecom_multi_retval_ = result;
7280       else
7281         ffecom_func_result_ = result;
7282
7283       if (charfunc)
7284         {
7285           push_parm_decl (length);
7286           ffecom_func_length_ = length;
7287         }
7288     }
7289
7290   if (ffecom_primary_entry_is_proc_)
7291     {
7292       if (altentries)
7293         arglist = ffecom_master_arglist_;
7294       else
7295         arglist = ffesymbol_dummyargs (fn);
7296       ffecom_push_dummy_decls_ (arglist, FALSE);
7297     }
7298
7299   if (TREE_CODE (current_function_decl) != ERROR_MARK)
7300     store_parm_decls (main_program ? 1 : 0);
7301
7302   ffecom_start_compstmt ();
7303   /* Disallow temp vars at this level.  */
7304   current_binding_level->prep_state = 2;
7305
7306   lineno = old_lineno;
7307   input_filename = old_input_filename;
7308
7309   /* This handles any symbols still untransformed, in case -g specified.
7310      This used to be done in ffecom_finish_progunit, but it turns out to
7311      be necessary to do it here so that statement functions are
7312      expanded before code.  But don't bother for BLOCK DATA.  */
7313
7314   if (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
7315     ffesymbol_drive (ffecom_finish_symbol_transform_);
7316 }
7317
7318 /* ffecom_sym_transform_ -- Transform FFE sym into backend sym
7319
7320    ffesymbol s;
7321    ffecom_sym_transform_(s);
7322
7323    The ffesymbol_hook info for s is updated with appropriate backend info
7324    on the symbol.  */
7325
7326 static ffesymbol
7327 ffecom_sym_transform_ (ffesymbol s)
7328 {
7329   tree t;                       /* Transformed thingy. */
7330   tree tlen;                    /* Length if CHAR*(*). */
7331   bool addr;                    /* Is t the address of the thingy? */
7332   ffeinfoBasictype bt;
7333   ffeinfoKindtype kt;
7334   ffeglobal g;
7335   int old_lineno = lineno;
7336   const char *old_input_filename = input_filename;
7337
7338   /* Must ensure special ASSIGN variables are declared at top of outermost
7339      block, else they'll end up in the innermost block when their first
7340      ASSIGN is seen, which leaves them out of scope when they're the
7341      subject of a GOTO or I/O statement.
7342
7343      We make this variable even if -fugly-assign.  Just let it go unused,
7344      in case it turns out there are cases where we really want to use this
7345      variable anyway (e.g. ASSIGN to INTEGER*2 variable).  */
7346
7347   if (! ffecom_transform_only_dummies_
7348       && ffesymbol_assigned (s)
7349       && ! ffesymbol_hook (s).assign_tree)
7350     s = ffecom_sym_transform_assign_ (s);
7351
7352   if (ffesymbol_sfdummyparent (s) == NULL)
7353     {
7354       input_filename = ffesymbol_where_filename (s);
7355       lineno = ffesymbol_where_filelinenum (s);
7356     }
7357   else
7358     {
7359       ffesymbol sf = ffesymbol_sfdummyparent (s);
7360
7361       input_filename = ffesymbol_where_filename (sf);
7362       lineno = ffesymbol_where_filelinenum (sf);
7363     }
7364
7365   bt = ffeinfo_basictype (ffebld_info (s));
7366   kt = ffeinfo_kindtype (ffebld_info (s));
7367
7368   t = NULL_TREE;
7369   tlen = NULL_TREE;
7370   addr = FALSE;
7371
7372   switch (ffesymbol_kind (s))
7373     {
7374     case FFEINFO_kindNONE:
7375       switch (ffesymbol_where (s))
7376         {
7377         case FFEINFO_whereDUMMY:        /* Subroutine or function. */
7378           assert (ffecom_transform_only_dummies_);
7379
7380           /* Before 0.4, this could be ENTITY/DUMMY, but see
7381              ffestu_sym_end_transition -- no longer true (in particular, if
7382              it could be an ENTITY, it _will_ be made one, so that
7383              possibility won't come through here).  So we never make length
7384              arg for CHARACTER type.  */
7385
7386           t = build_decl (PARM_DECL,
7387                           ffecom_get_identifier_ (ffesymbol_text (s)),
7388                           ffecom_tree_ptr_to_subr_type);
7389           DECL_ARTIFICIAL (t) = 1;
7390           addr = TRUE;
7391           break;
7392
7393         case FFEINFO_whereGLOBAL:       /* Subroutine or function. */
7394           assert (!ffecom_transform_only_dummies_);
7395
7396           if (((g = ffesymbol_global (s)) != NULL)
7397               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7398                   || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7399                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
7400               && (ffeglobal_hook (g) != NULL_TREE)
7401               && ffe_is_globals ())
7402             {
7403               t = ffeglobal_hook (g);
7404               break;
7405             }
7406
7407           t = build_decl (FUNCTION_DECL,
7408                           ffecom_get_external_identifier_ (s),
7409                           ffecom_tree_subr_type);       /* Assume subr. */
7410           DECL_EXTERNAL (t) = 1;
7411           TREE_PUBLIC (t) = 1;
7412
7413           t = start_decl (t, FALSE);
7414           finish_decl (t, NULL_TREE, FALSE);
7415
7416           if ((g != NULL)
7417               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7418                   || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7419                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
7420             ffeglobal_set_hook (g, t);
7421
7422           ffecom_save_tree_forever (t);
7423
7424           break;
7425
7426         default:
7427           assert ("NONE where unexpected" == NULL);
7428           /* Fall through. */
7429         case FFEINFO_whereANY:
7430           break;
7431         }
7432       break;
7433
7434     case FFEINFO_kindENTITY:
7435       switch (ffeinfo_where (ffesymbol_info (s)))
7436         {
7437
7438         case FFEINFO_whereCONSTANT:
7439           /* ~~Debugging info needed? */
7440           assert (!ffecom_transform_only_dummies_);
7441           t = error_mark_node;  /* Shouldn't ever see this in expr. */
7442           break;
7443
7444         case FFEINFO_whereLOCAL:
7445           assert (!ffecom_transform_only_dummies_);
7446
7447           {
7448             ffestorag st = ffesymbol_storage (s);
7449             tree type;
7450
7451             if ((st != NULL)
7452                 && (ffestorag_size (st) == 0))
7453               {
7454                 t = error_mark_node;
7455                 break;
7456               }
7457
7458             type = ffecom_type_localvar_ (s, bt, kt);
7459
7460             if (type == error_mark_node)
7461               {
7462                 t = error_mark_node;
7463                 break;
7464               }
7465
7466             if ((st != NULL)
7467                 && (ffestorag_parent (st) != NULL))
7468               {                 /* Child of EQUIVALENCE parent. */
7469                 ffestorag est;
7470                 tree et;
7471                 ffetargetOffset offset;
7472
7473                 est = ffestorag_parent (st);
7474                 ffecom_transform_equiv_ (est);
7475
7476                 et = ffestorag_hook (est);
7477                 assert (et != NULL_TREE);
7478
7479                 if (! TREE_STATIC (et))
7480                   put_var_into_stack (et);
7481
7482                 offset = ffestorag_modulo (est)
7483                   + ffestorag_offset (ffesymbol_storage (s))
7484                   - ffestorag_offset (est);
7485
7486                 ffecom_debug_kludge_ (et, "EQUIVALENCE", s, type, offset);
7487
7488                 /* (t_type *) (((char *) &et) + offset) */
7489
7490                 t = convert (string_type_node,  /* (char *) */
7491                              ffecom_1 (ADDR_EXPR,
7492                                        build_pointer_type (TREE_TYPE (et)),
7493                                        et));
7494                 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
7495                               t,
7496                               build_int_2 (offset, 0));
7497                 t = convert (build_pointer_type (type),
7498                              t);
7499                 TREE_CONSTANT (t) = staticp (et);
7500
7501                 addr = TRUE;
7502               }
7503             else
7504               {
7505                 tree initexpr;
7506                 bool init = ffesymbol_is_init (s);
7507
7508                 t = build_decl (VAR_DECL,
7509                                 ffecom_get_identifier_ (ffesymbol_text (s)),
7510                                 type);
7511
7512                 if (init
7513                     || ffesymbol_namelisted (s)
7514 #ifdef FFECOM_sizeMAXSTACKITEM
7515                     || ((st != NULL)
7516                         && (ffestorag_size (st) > FFECOM_sizeMAXSTACKITEM))
7517 #endif
7518                     || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
7519                         && (ffecom_primary_entry_kind_
7520                             != FFEINFO_kindBLOCKDATA)
7521                         && (ffesymbol_is_save (s) || ffe_is_saveall ())))
7522                   TREE_STATIC (t) = !ffesymbol_attr (s, FFESYMBOL_attrADJUSTABLE);
7523                 else
7524                   TREE_STATIC (t) = 0;  /* No need to make static. */
7525
7526                 if (init || ffe_is_init_local_zero ())
7527                   DECL_INITIAL (t) = error_mark_node;
7528
7529                 /* Keep -Wunused from complaining about var if it
7530                    is used as sfunc arg or DATA implied-DO.  */
7531                 if (ffesymbol_attrs (s) & FFESYMBOL_attrsSFARG)
7532                   DECL_IN_SYSTEM_HEADER (t) = 1;
7533
7534                 t = start_decl (t, FALSE);
7535
7536                 if (init)
7537                   {
7538                     if (ffesymbol_init (s) != NULL)
7539                       initexpr = ffecom_expr (ffesymbol_init (s));
7540                     else
7541                       initexpr = ffecom_init_zero_ (t);
7542                   }
7543                 else if (ffe_is_init_local_zero ())
7544                   initexpr = ffecom_init_zero_ (t);
7545                 else
7546                   initexpr = NULL_TREE; /* Not ref'd if !init. */
7547
7548                 finish_decl (t, initexpr, FALSE);
7549
7550                 if (st != NULL && DECL_SIZE (t) != error_mark_node)
7551                   {
7552                     assert (TREE_CODE (DECL_SIZE_UNIT (t)) == INTEGER_CST);
7553                     assert (0 == compare_tree_int (DECL_SIZE_UNIT (t),
7554                                                    ffestorag_size (st)));
7555                   }
7556               }
7557           }
7558           break;
7559
7560         case FFEINFO_whereRESULT:
7561           assert (!ffecom_transform_only_dummies_);
7562
7563           if (bt == FFEINFO_basictypeCHARACTER)
7564             {                   /* Result is already in list of dummies, use
7565                                    it (& length). */
7566               t = ffecom_func_result_;
7567               tlen = ffecom_func_length_;
7568               addr = TRUE;
7569               break;
7570             }
7571           if ((ffecom_num_entrypoints_ == 0)
7572               && (bt == FFEINFO_basictypeCOMPLEX)
7573               && (ffesymbol_is_f2c (ffecom_primary_entry_)))
7574             {                   /* Result is already in list of dummies, use
7575                                    it. */
7576               t = ffecom_func_result_;
7577               addr = TRUE;
7578               break;
7579             }
7580           if (ffecom_func_result_ != NULL_TREE)
7581             {
7582               t = ffecom_func_result_;
7583               break;
7584             }
7585           if ((ffecom_num_entrypoints_ != 0)
7586               && (ffecom_master_bt_ == FFEINFO_basictypeNONE))
7587             {
7588               assert (ffecom_multi_retval_ != NULL_TREE);
7589               t = ffecom_1 (INDIRECT_REF, ffecom_multi_type_node_,
7590                             ffecom_multi_retval_);
7591               t = ffecom_2 (COMPONENT_REF, ffecom_tree_type[bt][kt],
7592                             t, ffecom_multi_fields_[bt][kt]);
7593
7594               break;
7595             }
7596
7597           t = build_decl (VAR_DECL,
7598                           ffecom_get_identifier_ (ffesymbol_text (s)),
7599                           ffecom_tree_type[bt][kt]);
7600           TREE_STATIC (t) = 0;  /* Put result on stack. */
7601           t = start_decl (t, FALSE);
7602           finish_decl (t, NULL_TREE, FALSE);
7603
7604           ffecom_func_result_ = t;
7605
7606           break;
7607
7608         case FFEINFO_whereDUMMY:
7609           {
7610             tree type;
7611             ffebld dl;
7612             ffebld dim;
7613             tree low;
7614             tree high;
7615             tree old_sizes;
7616             bool adjustable = FALSE;    /* Conditionally adjustable? */
7617
7618             type = ffecom_tree_type[bt][kt];
7619             if (ffesymbol_sfdummyparent (s) != NULL)
7620               {
7621                 if (current_function_decl == ffecom_outer_function_decl_)
7622                   {                     /* Exec transition before sfunc
7623                                            context; get it later. */
7624                     break;
7625                   }
7626                 t = ffecom_get_identifier_ (ffesymbol_text
7627                                             (ffesymbol_sfdummyparent (s)));
7628               }
7629             else
7630               t = ffecom_get_identifier_ (ffesymbol_text (s));
7631
7632             assert (ffecom_transform_only_dummies_);
7633
7634             old_sizes = get_pending_sizes ();
7635             put_pending_sizes (old_sizes);
7636
7637             if (bt == FFEINFO_basictypeCHARACTER)
7638               tlen = ffecom_char_enhance_arg_ (&type, s);
7639             type = ffecom_check_size_overflow_ (s, type, TRUE);
7640
7641             for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
7642               {
7643                 if (type == error_mark_node)
7644                   break;
7645
7646                 dim = ffebld_head (dl);
7647                 assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
7648                 if ((ffebld_left (dim) == NULL) || ffecom_doing_entry_)
7649                   low = ffecom_integer_one_node;
7650                 else
7651                   low = ffecom_expr (ffebld_left (dim));
7652                 assert (ffebld_right (dim) != NULL);
7653                 if ((ffebld_op (ffebld_right (dim)) == FFEBLD_opSTAR)
7654                     || ffecom_doing_entry_)
7655                   {
7656                     /* Used to just do high=low.  But for ffecom_tree_
7657                        canonize_ref_, it probably is important to correctly
7658                        assess the size.  E.g. given COMPLEX C(*),CFUNC and
7659                        C(2)=CFUNC(C), overlap can happen, while it can't
7660                        for, say, C(1)=CFUNC(C(2)).  */
7661                     /* Even more recently used to set to INT_MAX, but that
7662                        broke when some overflow checking went into the back
7663                        end.  Now we just leave the upper bound unspecified.  */
7664                     high = NULL;
7665                   }
7666                 else
7667                   high = ffecom_expr (ffebld_right (dim));
7668
7669                 /* Determine whether array is conditionally adjustable,
7670                    to decide whether back-end magic is needed.
7671
7672                    Normally the front end uses the back-end function
7673                    variable_size to wrap SAVE_EXPR's around expressions
7674                    affecting the size/shape of an array so that the
7675                    size/shape info doesn't change during execution
7676                    of the compiled code even though variables and
7677                    functions referenced in those expressions might.
7678
7679                    variable_size also makes sure those saved expressions
7680                    get evaluated immediately upon entry to the
7681                    compiled procedure -- the front end normally doesn't
7682                    have to worry about that.
7683
7684                    However, there is a problem with this that affects
7685                    g77's implementation of entry points, and that is
7686                    that it is _not_ true that each invocation of the
7687                    compiled procedure is permitted to evaluate
7688                    array size/shape info -- because it is possible
7689                    that, for some invocations, that info is invalid (in
7690                    which case it is "promised" -- i.e. a violation of
7691                    the Fortran standard -- that the compiled code
7692                    won't reference the array or its size/shape
7693                    during that particular invocation).
7694
7695                    To phrase this in C terms, consider this gcc function:
7696
7697                      void foo (int *n, float (*a)[*n])
7698                      {
7699                        // a is "pointer to array ...", fyi.
7700                      }
7701
7702                    Suppose that, for some invocations, it is permitted
7703                    for a caller of foo to do this:
7704
7705                        foo (NULL, NULL);
7706
7707                    Now the _written_ code for foo can take such a call
7708                    into account by either testing explicitly for whether
7709                    (a == NULL) || (n == NULL) -- presumably it is
7710                    not permitted to reference *a in various fashions
7711                    if (n == NULL) I suppose -- or it can avoid it by
7712                    looking at other info (other arguments, static/global
7713                    data, etc.).
7714
7715                    However, this won't work in gcc 2.5.8 because it'll
7716                    automatically emit the code to save the "*n"
7717                    expression, which'll yield a NULL dereference for
7718                    the "foo (NULL, NULL)" call, something the code
7719                    for foo cannot prevent.
7720
7721                    g77 definitely needs to avoid executing such
7722                    code anytime the pointer to the adjustable array
7723                    is NULL, because even if its bounds expressions
7724                    don't have any references to possible "absent"
7725                    variables like "*n" -- say all variable references
7726                    are to COMMON variables, i.e. global (though in C,
7727                    local static could actually make sense) -- the
7728                    expressions could yield other run-time problems
7729                    for allowably "dead" values in those variables.
7730
7731                    For example, let's consider a more complicated
7732                    version of foo:
7733
7734                      extern int i;
7735                      extern int j;
7736
7737                      void foo (float (*a)[i/j])
7738                      {
7739                        ...
7740                      }
7741
7742                    The above is (essentially) quite valid for Fortran
7743                    but, again, for a call like "foo (NULL);", it is
7744                    permitted for i and j to be undefined when the
7745                    call is made.  If j happened to be zero, for
7746                    example, emitting the code to evaluate "i/j"
7747                    could result in a run-time error.
7748
7749                    Offhand, though I don't have my F77 or F90
7750                    standards handy, it might even be valid for a
7751                    bounds expression to contain a function reference,
7752                    in which case I doubt it is permitted for an
7753                    implementation to invoke that function in the
7754                    Fortran case involved here (invocation of an
7755                    alternate ENTRY point that doesn't have the adjustable
7756                    array as one of its arguments).
7757
7758                    So, the code that the compiler would normally emit
7759                    to preevaluate the size/shape info for an
7760                    adjustable array _must not_ be executed at run time
7761                    in certain cases.  Specifically, for Fortran,
7762                    the case is when the pointer to the adjustable
7763                    array == NULL.  (For gnu-ish C, it might be nice
7764                    for the source code itself to specify an expression
7765                    that, if TRUE, inhibits execution of the code.  Or
7766                    reverse the sense for elegance.)
7767
7768                    (Note that g77 could use a different test than NULL,
7769                    actually, since it happens to always pass an
7770                    integer to the called function that specifies which
7771                    entry point is being invoked.  Hmm, this might
7772                    solve the next problem.)
7773
7774                    One way a user could, I suppose, write "foo" so
7775                    it works is to insert COND_EXPR's for the
7776                    size/shape info so the dangerous stuff isn't
7777                    actually done, as in:
7778
7779                      void foo (int *n, float (*a)[(a == NULL) ? 0 : *n])
7780                      {
7781                        ...
7782                      }
7783
7784                    The next problem is that the front end needs to
7785                    be able to tell the back end about the array's
7786                    decl _before_ it tells it about the conditional
7787                    expression to inhibit evaluation of size/shape info,
7788                    as shown above.
7789
7790                    To solve this, the front end needs to be able
7791                    to give the back end the expression to inhibit
7792                    generation of the preevaluation code _after_
7793                    it makes the decl for the adjustable array.
7794
7795                    Until then, the above example using the COND_EXPR
7796                    doesn't pass muster with gcc because the "(a == NULL)"
7797                    part has a reference to "a", which is still
7798                    undefined at that point.
7799
7800                    g77 will therefore use a different mechanism in the
7801                    meantime.  */
7802
7803                 if (!adjustable
7804                     && ((TREE_CODE (low) != INTEGER_CST)
7805                         || (high && TREE_CODE (high) != INTEGER_CST)))
7806                   adjustable = TRUE;
7807
7808 #if 0                           /* Old approach -- see below. */
7809                 if (TREE_CODE (low) != INTEGER_CST)
7810                   low = ffecom_3 (COND_EXPR, integer_type_node,
7811                                   ffecom_adjarray_passed_ (s),
7812                                   low,
7813                                   ffecom_integer_zero_node);
7814
7815                 if (high && TREE_CODE (high) != INTEGER_CST)
7816                   high = ffecom_3 (COND_EXPR, integer_type_node,
7817                                    ffecom_adjarray_passed_ (s),
7818                                    high,
7819                                    ffecom_integer_zero_node);
7820 #endif
7821
7822                 /* ~~~gcc/stor-layout.c (layout_type) should do this,
7823                    probably.  Fixes 950302-1.f.  */
7824
7825                 if (TREE_CODE (low) != INTEGER_CST)
7826                   low = variable_size (low);
7827
7828                 /* ~~~Similarly, this fixes dumb0.f.  The C front end
7829                    does this, which is why dumb0.c would work.  */
7830
7831                 if (high && TREE_CODE (high) != INTEGER_CST)
7832                   high = variable_size (high);
7833
7834                 type
7835                   = build_array_type
7836                     (type,
7837                      build_range_type (ffecom_integer_type_node,
7838                                        low, high));
7839                 type = ffecom_check_size_overflow_ (s, type, TRUE);
7840               }
7841
7842             if (type == error_mark_node)
7843               {
7844                 t = error_mark_node;
7845                 break;
7846               }
7847
7848             if ((ffesymbol_sfdummyparent (s) == NULL)
7849                  || (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER))
7850               {
7851                 type = build_pointer_type (type);
7852                 addr = TRUE;
7853               }
7854
7855             t = build_decl (PARM_DECL, t, type);
7856             DECL_ARTIFICIAL (t) = 1;
7857
7858             /* If this arg is present in every entry point's list of
7859                dummy args, then we're done.  */
7860
7861             if (ffesymbol_numentries (s)
7862                 == (ffecom_num_entrypoints_ + 1))
7863               break;
7864
7865 #if 1
7866
7867             /* If variable_size in stor-layout has been called during
7868                the above, then get_pending_sizes should have the
7869                yet-to-be-evaluated saved expressions pending.
7870                Make the whole lot of them get emitted, conditionally
7871                on whether the array decl ("t" above) is not NULL.  */
7872
7873             {
7874               tree sizes = get_pending_sizes ();
7875               tree tem;
7876
7877               for (tem = sizes;
7878                    tem != old_sizes;
7879                    tem = TREE_CHAIN (tem))
7880                 {
7881                   tree temv = TREE_VALUE (tem);
7882
7883                   if (sizes == tem)
7884                     sizes = temv;
7885                   else
7886                     sizes
7887                       = ffecom_2 (COMPOUND_EXPR,
7888                                   TREE_TYPE (sizes),
7889                                   temv,
7890                                   sizes);
7891                 }
7892
7893               if (sizes != tem)
7894                 {
7895                   sizes
7896                     = ffecom_3 (COND_EXPR,
7897                                 TREE_TYPE (sizes),
7898                                 ffecom_2 (NE_EXPR,
7899                                           integer_type_node,
7900                                           t,
7901                                           null_pointer_node),
7902                                 sizes,
7903                                 convert (TREE_TYPE (sizes),
7904                                          integer_zero_node));
7905                   sizes = ffecom_save_tree (sizes);
7906
7907                   sizes
7908                     = tree_cons (NULL_TREE, sizes, tem);
7909                 }
7910
7911               if (sizes)
7912                 put_pending_sizes (sizes);
7913             }
7914
7915 #else
7916 #if 0
7917             if (adjustable
7918                 && (ffesymbol_numentries (s)
7919                     != ffecom_num_entrypoints_ + 1))
7920               DECL_SOMETHING (t)
7921                 = ffecom_2 (NE_EXPR, integer_type_node,
7922                             t,
7923                             null_pointer_node);
7924 #else
7925 #if 0
7926             if (adjustable
7927                 && (ffesymbol_numentries (s)
7928                     != ffecom_num_entrypoints_ + 1))
7929               {
7930                 ffebad_start (FFEBAD_MISSING_ADJARRAY_UNSUPPORTED);
7931                 ffebad_here (0, ffesymbol_where_line (s),
7932                              ffesymbol_where_column (s));
7933                 ffebad_string (ffesymbol_text (s));
7934                 ffebad_finish ();
7935               }
7936 #endif
7937 #endif
7938 #endif
7939           }
7940           break;
7941
7942         case FFEINFO_whereCOMMON:
7943           {
7944             ffesymbol cs;
7945             ffeglobal cg;
7946             tree ct;
7947             ffestorag st = ffesymbol_storage (s);
7948             tree type;
7949
7950             cs = ffesymbol_common (s);  /* The COMMON area itself.  */
7951             if (st != NULL)     /* Else not laid out. */
7952               {
7953                 ffecom_transform_common_ (cs);
7954                 st = ffesymbol_storage (s);
7955               }
7956
7957             type = ffecom_type_localvar_ (s, bt, kt);
7958
7959             cg = ffesymbol_global (cs); /* The global COMMON info.  */
7960             if ((cg == NULL)
7961                 || (ffeglobal_type (cg) != FFEGLOBAL_typeCOMMON))
7962               ct = NULL_TREE;
7963             else
7964               ct = ffeglobal_hook (cg); /* The common area's tree.  */
7965
7966             if ((ct == NULL_TREE)
7967                 || (st == NULL)
7968                 || (type == error_mark_node))
7969               t = error_mark_node;
7970             else
7971               {
7972                 ffetargetOffset offset;
7973                 ffestorag cst;
7974
7975                 cst = ffestorag_parent (st);
7976                 assert (cst == ffesymbol_storage (cs));
7977
7978                 offset = ffestorag_modulo (cst)
7979                   + ffestorag_offset (st)
7980                   - ffestorag_offset (cst);
7981
7982                 ffecom_debug_kludge_ (ct, "COMMON", s, type, offset);
7983
7984                 /* (t_type *) (((char *) &ct) + offset) */
7985
7986                 t = convert (string_type_node,  /* (char *) */
7987                              ffecom_1 (ADDR_EXPR,
7988                                        build_pointer_type (TREE_TYPE (ct)),
7989                                        ct));
7990                 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
7991                               t,
7992                               build_int_2 (offset, 0));
7993                 t = convert (build_pointer_type (type),
7994                              t);
7995                 TREE_CONSTANT (t) = 1;
7996
7997                 addr = TRUE;
7998               }
7999           }
8000           break;
8001
8002         case FFEINFO_whereIMMEDIATE:
8003         case FFEINFO_whereGLOBAL:
8004         case FFEINFO_whereFLEETING:
8005         case FFEINFO_whereFLEETING_CADDR:
8006         case FFEINFO_whereFLEETING_IADDR:
8007         case FFEINFO_whereINTRINSIC:
8008         case FFEINFO_whereCONSTANT_SUBOBJECT:
8009         default:
8010           assert ("ENTITY where unheard of" == NULL);
8011           /* Fall through. */
8012         case FFEINFO_whereANY:
8013           t = error_mark_node;
8014           break;
8015         }
8016       break;
8017
8018     case FFEINFO_kindFUNCTION:
8019       switch (ffeinfo_where (ffesymbol_info (s)))
8020         {
8021         case FFEINFO_whereLOCAL:        /* Me. */
8022           assert (!ffecom_transform_only_dummies_);
8023           t = current_function_decl;
8024           break;
8025
8026         case FFEINFO_whereGLOBAL:
8027           assert (!ffecom_transform_only_dummies_);
8028
8029           if (((g = ffesymbol_global (s)) != NULL)
8030               && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8031                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8032               && (ffeglobal_hook (g) != NULL_TREE)
8033               && ffe_is_globals ())
8034             {
8035               t = ffeglobal_hook (g);
8036               break;
8037             }
8038
8039           if (ffesymbol_is_f2c (s)
8040               && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8041             t = ffecom_tree_fun_type[bt][kt];
8042           else
8043             t = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
8044
8045           t = build_decl (FUNCTION_DECL,
8046                           ffecom_get_external_identifier_ (s),
8047                           t);
8048           DECL_EXTERNAL (t) = 1;
8049           TREE_PUBLIC (t) = 1;
8050
8051           t = start_decl (t, FALSE);
8052           finish_decl (t, NULL_TREE, FALSE);
8053
8054           if ((g != NULL)
8055               && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8056                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8057             ffeglobal_set_hook (g, t);
8058
8059           ffecom_save_tree_forever (t);
8060
8061           break;
8062
8063         case FFEINFO_whereDUMMY:
8064           assert (ffecom_transform_only_dummies_);
8065
8066           if (ffesymbol_is_f2c (s)
8067               && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8068             t = ffecom_tree_ptr_to_fun_type[bt][kt];
8069           else
8070             t = build_pointer_type
8071               (build_function_type (ffecom_tree_type[bt][kt], NULL_TREE));
8072
8073           t = build_decl (PARM_DECL,
8074                           ffecom_get_identifier_ (ffesymbol_text (s)),
8075                           t);
8076           DECL_ARTIFICIAL (t) = 1;
8077           addr = TRUE;
8078           break;
8079
8080         case FFEINFO_whereCONSTANT:     /* Statement function. */
8081           assert (!ffecom_transform_only_dummies_);
8082           t = ffecom_gen_sfuncdef_ (s, bt, kt);
8083           break;
8084
8085         case FFEINFO_whereINTRINSIC:
8086           assert (!ffecom_transform_only_dummies_);
8087           break;                /* Let actual references generate their
8088                                    decls. */
8089
8090         default:
8091           assert ("FUNCTION where unheard of" == NULL);
8092           /* Fall through. */
8093         case FFEINFO_whereANY:
8094           t = error_mark_node;
8095           break;
8096         }
8097       break;
8098
8099     case FFEINFO_kindSUBROUTINE:
8100       switch (ffeinfo_where (ffesymbol_info (s)))
8101         {
8102         case FFEINFO_whereLOCAL:        /* Me. */
8103           assert (!ffecom_transform_only_dummies_);
8104           t = current_function_decl;
8105           break;
8106
8107         case FFEINFO_whereGLOBAL:
8108           assert (!ffecom_transform_only_dummies_);
8109
8110           if (((g = ffesymbol_global (s)) != NULL)
8111               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8112                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8113               && (ffeglobal_hook (g) != NULL_TREE)
8114               && ffe_is_globals ())
8115             {
8116               t = ffeglobal_hook (g);
8117               break;
8118             }
8119
8120           t = build_decl (FUNCTION_DECL,
8121                           ffecom_get_external_identifier_ (s),
8122                           ffecom_tree_subr_type);
8123           DECL_EXTERNAL (t) = 1;
8124           TREE_PUBLIC (t) = 1;
8125
8126           t = start_decl (t, FALSE);
8127           finish_decl (t, NULL_TREE, FALSE);
8128
8129           if ((g != NULL)
8130               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8131                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8132             ffeglobal_set_hook (g, t);
8133
8134           ffecom_save_tree_forever (t);
8135
8136           break;
8137
8138         case FFEINFO_whereDUMMY:
8139           assert (ffecom_transform_only_dummies_);
8140
8141           t = build_decl (PARM_DECL,
8142                           ffecom_get_identifier_ (ffesymbol_text (s)),
8143                           ffecom_tree_ptr_to_subr_type);
8144           DECL_ARTIFICIAL (t) = 1;
8145           addr = TRUE;
8146           break;
8147
8148         case FFEINFO_whereINTRINSIC:
8149           assert (!ffecom_transform_only_dummies_);
8150           break;                /* Let actual references generate their
8151                                    decls. */
8152
8153         default:
8154           assert ("SUBROUTINE where unheard of" == NULL);
8155           /* Fall through. */
8156         case FFEINFO_whereANY:
8157           t = error_mark_node;
8158           break;
8159         }
8160       break;
8161
8162     case FFEINFO_kindPROGRAM:
8163       switch (ffeinfo_where (ffesymbol_info (s)))
8164         {
8165         case FFEINFO_whereLOCAL:        /* Me. */
8166           assert (!ffecom_transform_only_dummies_);
8167           t = current_function_decl;
8168           break;
8169
8170         case FFEINFO_whereCOMMON:
8171         case FFEINFO_whereDUMMY:
8172         case FFEINFO_whereGLOBAL:
8173         case FFEINFO_whereRESULT:
8174         case FFEINFO_whereFLEETING:
8175         case FFEINFO_whereFLEETING_CADDR:
8176         case FFEINFO_whereFLEETING_IADDR:
8177         case FFEINFO_whereIMMEDIATE:
8178         case FFEINFO_whereINTRINSIC:
8179         case FFEINFO_whereCONSTANT:
8180         case FFEINFO_whereCONSTANT_SUBOBJECT:
8181         default:
8182           assert ("PROGRAM where unheard of" == NULL);
8183           /* Fall through. */
8184         case FFEINFO_whereANY:
8185           t = error_mark_node;
8186           break;
8187         }
8188       break;
8189
8190     case FFEINFO_kindBLOCKDATA:
8191       switch (ffeinfo_where (ffesymbol_info (s)))
8192         {
8193         case FFEINFO_whereLOCAL:        /* Me. */
8194           assert (!ffecom_transform_only_dummies_);
8195           t = current_function_decl;
8196           break;
8197
8198         case FFEINFO_whereGLOBAL:
8199           assert (!ffecom_transform_only_dummies_);
8200
8201           t = build_decl (FUNCTION_DECL,
8202                           ffecom_get_external_identifier_ (s),
8203                           ffecom_tree_blockdata_type);
8204           DECL_EXTERNAL (t) = 1;
8205           TREE_PUBLIC (t) = 1;
8206
8207           t = start_decl (t, FALSE);
8208           finish_decl (t, NULL_TREE, FALSE);
8209
8210           ffecom_save_tree_forever (t);
8211
8212           break;
8213
8214         case FFEINFO_whereCOMMON:
8215         case FFEINFO_whereDUMMY:
8216         case FFEINFO_whereRESULT:
8217         case FFEINFO_whereFLEETING:
8218         case FFEINFO_whereFLEETING_CADDR:
8219         case FFEINFO_whereFLEETING_IADDR:
8220         case FFEINFO_whereIMMEDIATE:
8221         case FFEINFO_whereINTRINSIC:
8222         case FFEINFO_whereCONSTANT:
8223         case FFEINFO_whereCONSTANT_SUBOBJECT:
8224         default:
8225           assert ("BLOCKDATA where unheard of" == NULL);
8226           /* Fall through. */
8227         case FFEINFO_whereANY:
8228           t = error_mark_node;
8229           break;
8230         }
8231       break;
8232
8233     case FFEINFO_kindCOMMON:
8234       switch (ffeinfo_where (ffesymbol_info (s)))
8235         {
8236         case FFEINFO_whereLOCAL:
8237           assert (!ffecom_transform_only_dummies_);
8238           ffecom_transform_common_ (s);
8239           break;
8240
8241         case FFEINFO_whereNONE:
8242         case FFEINFO_whereCOMMON:
8243         case FFEINFO_whereDUMMY:
8244         case FFEINFO_whereGLOBAL:
8245         case FFEINFO_whereRESULT:
8246         case FFEINFO_whereFLEETING:
8247         case FFEINFO_whereFLEETING_CADDR:
8248         case FFEINFO_whereFLEETING_IADDR:
8249         case FFEINFO_whereIMMEDIATE:
8250         case FFEINFO_whereINTRINSIC:
8251         case FFEINFO_whereCONSTANT:
8252         case FFEINFO_whereCONSTANT_SUBOBJECT:
8253         default:
8254           assert ("COMMON where unheard of" == NULL);
8255           /* Fall through. */
8256         case FFEINFO_whereANY:
8257           t = error_mark_node;
8258           break;
8259         }
8260       break;
8261
8262     case FFEINFO_kindCONSTRUCT:
8263       switch (ffeinfo_where (ffesymbol_info (s)))
8264         {
8265         case FFEINFO_whereLOCAL:
8266           assert (!ffecom_transform_only_dummies_);
8267           break;
8268
8269         case FFEINFO_whereNONE:
8270         case FFEINFO_whereCOMMON:
8271         case FFEINFO_whereDUMMY:
8272         case FFEINFO_whereGLOBAL:
8273         case FFEINFO_whereRESULT:
8274         case FFEINFO_whereFLEETING:
8275         case FFEINFO_whereFLEETING_CADDR:
8276         case FFEINFO_whereFLEETING_IADDR:
8277         case FFEINFO_whereIMMEDIATE:
8278         case FFEINFO_whereINTRINSIC:
8279         case FFEINFO_whereCONSTANT:
8280         case FFEINFO_whereCONSTANT_SUBOBJECT:
8281         default:
8282           assert ("CONSTRUCT where unheard of" == NULL);
8283           /* Fall through. */
8284         case FFEINFO_whereANY:
8285           t = error_mark_node;
8286           break;
8287         }
8288       break;
8289
8290     case FFEINFO_kindNAMELIST:
8291       switch (ffeinfo_where (ffesymbol_info (s)))
8292         {
8293         case FFEINFO_whereLOCAL:
8294           assert (!ffecom_transform_only_dummies_);
8295           t = ffecom_transform_namelist_ (s);
8296           break;
8297
8298         case FFEINFO_whereNONE:
8299         case FFEINFO_whereCOMMON:
8300         case FFEINFO_whereDUMMY:
8301         case FFEINFO_whereGLOBAL:
8302         case FFEINFO_whereRESULT:
8303         case FFEINFO_whereFLEETING:
8304         case FFEINFO_whereFLEETING_CADDR:
8305         case FFEINFO_whereFLEETING_IADDR:
8306         case FFEINFO_whereIMMEDIATE:
8307         case FFEINFO_whereINTRINSIC:
8308         case FFEINFO_whereCONSTANT:
8309         case FFEINFO_whereCONSTANT_SUBOBJECT:
8310         default:
8311           assert ("NAMELIST where unheard of" == NULL);
8312           /* Fall through. */
8313         case FFEINFO_whereANY:
8314           t = error_mark_node;
8315           break;
8316         }
8317       break;
8318
8319     default:
8320       assert ("kind unheard of" == NULL);
8321       /* Fall through. */
8322     case FFEINFO_kindANY:
8323       t = error_mark_node;
8324       break;
8325     }
8326
8327   ffesymbol_hook (s).decl_tree = t;
8328   ffesymbol_hook (s).length_tree = tlen;
8329   ffesymbol_hook (s).addr = addr;
8330
8331   lineno = old_lineno;
8332   input_filename = old_input_filename;
8333
8334   return s;
8335 }
8336
8337 /* Transform into ASSIGNable symbol.
8338
8339    Symbol has already been transformed, but for whatever reason, the
8340    resulting decl_tree has been deemed not usable for an ASSIGN target.
8341    (E.g. it isn't wide enough to hold a pointer.)  So, here we invent
8342    another local symbol of type void * and stuff that in the assign_tree
8343    argument.  The F77/F90 standards allow this implementation.  */
8344
8345 static ffesymbol
8346 ffecom_sym_transform_assign_ (ffesymbol s)
8347 {
8348   tree t;                       /* Transformed thingy. */
8349   int old_lineno = lineno;
8350   const char *old_input_filename = input_filename;
8351
8352   if (ffesymbol_sfdummyparent (s) == NULL)
8353     {
8354       input_filename = ffesymbol_where_filename (s);
8355       lineno = ffesymbol_where_filelinenum (s);
8356     }
8357   else
8358     {
8359       ffesymbol sf = ffesymbol_sfdummyparent (s);
8360
8361       input_filename = ffesymbol_where_filename (sf);
8362       lineno = ffesymbol_where_filelinenum (sf);
8363     }
8364
8365   assert (!ffecom_transform_only_dummies_);
8366
8367   t = build_decl (VAR_DECL,
8368                   ffecom_get_invented_identifier ("__g77_ASSIGN_%s",
8369                                                    ffesymbol_text (s)),
8370                   TREE_TYPE (null_pointer_node));
8371
8372   switch (ffesymbol_where (s))
8373     {
8374     case FFEINFO_whereLOCAL:
8375       /* Unlike for regular vars, SAVE status is easy to determine for
8376          ASSIGNed vars, since there's no initialization, there's no
8377          effective storage association (so "SAVE J" does not apply to
8378          K even given "EQUIVALENCE (J,K)"), there's no size issue
8379          to worry about, etc.  */
8380       if ((ffesymbol_is_save (s) || ffe_is_saveall ())
8381           && (ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8382           && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA))
8383         TREE_STATIC (t) = 1;    /* SAVEd in proc, make static. */
8384       else
8385         TREE_STATIC (t) = 0;    /* No need to make static. */
8386       break;
8387
8388     case FFEINFO_whereCOMMON:
8389       TREE_STATIC (t) = 1;      /* Assume COMMONs always SAVEd. */
8390       break;
8391
8392     case FFEINFO_whereDUMMY:
8393       /* Note that twinning a DUMMY means the caller won't see
8394          the ASSIGNed value.  But both F77 and F90 allow implementations
8395          to do this, i.e. disallow Fortran code that would try and
8396          take advantage of actually putting a label into a variable
8397          via a dummy argument (or any other storage association, for
8398          that matter).  */
8399       TREE_STATIC (t) = 0;
8400       break;
8401
8402     default:
8403       TREE_STATIC (t) = 0;
8404       break;
8405     }
8406
8407   t = start_decl (t, FALSE);
8408   finish_decl (t, NULL_TREE, FALSE);
8409
8410   ffesymbol_hook (s).assign_tree = t;
8411
8412   lineno = old_lineno;
8413   input_filename = old_input_filename;
8414
8415   return s;
8416 }
8417
8418 /* Implement COMMON area in back end.
8419
8420    Because COMMON-based variables can be referenced in the dimension
8421    expressions of dummy (adjustable) arrays, and because dummies
8422    (in the gcc back end) need to be put in the outer binding level
8423    of a function (which has two binding levels, the outer holding
8424    the dummies and the inner holding the other vars), special care
8425    must be taken to handle COMMON areas.
8426
8427    The current strategy is basically to always tell the back end about
8428    the COMMON area as a top-level external reference to just a block
8429    of storage of the master type of that area (e.g. integer, real,
8430    character, whatever -- not a structure).  As a distinct action,
8431    if initial values are provided, tell the back end about the area
8432    as a top-level non-external (initialized) area and remember not to
8433    allow further initialization or expansion of the area.  Meanwhile,
8434    if no initialization happens at all, tell the back end about
8435    the largest size we've seen declared so the space does get reserved.
8436    (This function doesn't handle all that stuff, but it does some
8437    of the important things.)
8438
8439    Meanwhile, for COMMON variables themselves, just keep creating
8440    references like *((float *) (&common_area + offset)) each time
8441    we reference the variable.  In other words, don't make a VAR_DECL
8442    or any kind of component reference (like we used to do before 0.4),
8443    though we might do that as well just for debugging purposes (and
8444    stuff the rtl with the appropriate offset expression).  */
8445
8446 static void
8447 ffecom_transform_common_ (ffesymbol s)
8448 {
8449   ffestorag st = ffesymbol_storage (s);
8450   ffeglobal g = ffesymbol_global (s);
8451   tree cbt;
8452   tree cbtype;
8453   tree init;
8454   tree high;
8455   bool is_init = ffestorag_is_init (st);
8456
8457   assert (st != NULL);
8458
8459   if ((g == NULL)
8460       || (ffeglobal_type (g) != FFEGLOBAL_typeCOMMON))
8461     return;
8462
8463   /* First update the size of the area in global terms.  */
8464
8465   ffeglobal_size_common (s, ffestorag_size (st));
8466
8467   if (!ffeglobal_common_init (g))
8468     is_init = FALSE;    /* No explicit init, don't let erroneous joins init. */
8469
8470   cbt = ffeglobal_hook (g);
8471
8472   /* If we already have declared this common block for a previous program
8473      unit, and either we already initialized it or we don't have new
8474      initialization for it, just return what we have without changing it.  */
8475
8476   if ((cbt != NULL_TREE)
8477       && (!is_init
8478           || !DECL_EXTERNAL (cbt)))
8479     {
8480       if (st->hook == NULL) ffestorag_set_hook (st, cbt);
8481       return;
8482     }
8483
8484   /* Process inits.  */
8485
8486   if (is_init)
8487     {
8488       if (ffestorag_init (st) != NULL)
8489         {
8490           ffebld sexp;
8491
8492           /* Set the padding for the expression, so ffecom_expr
8493              knows to insert that many zeros.  */
8494           switch (ffebld_op (sexp = ffestorag_init (st)))
8495             {
8496             case FFEBLD_opCONTER:
8497               ffebld_conter_set_pad (sexp, ffestorag_modulo (st));
8498               break;
8499
8500             case FFEBLD_opARRTER:
8501               ffebld_arrter_set_pad (sexp, ffestorag_modulo (st));
8502               break;
8503
8504             case FFEBLD_opACCTER:
8505               ffebld_accter_set_pad (sexp, ffestorag_modulo (st));
8506               break;
8507
8508             default:
8509               assert ("bad op for cmn init (pad)" == NULL);
8510               break;
8511             }
8512
8513           init = ffecom_expr (sexp);
8514           if (init == error_mark_node)
8515             {                   /* Hopefully the back end complained! */
8516               init = NULL_TREE;
8517               if (cbt != NULL_TREE)
8518                 return;
8519             }
8520         }
8521       else
8522         init = error_mark_node;
8523     }
8524   else
8525     init = NULL_TREE;
8526
8527   /* cbtype must be permanently allocated!  */
8528
8529   /* Allocate the MAX of the areas so far, seen filewide.  */
8530   high = build_int_2 ((ffeglobal_common_size (g)
8531                        + ffeglobal_common_pad (g)) - 1, 0);
8532   TREE_TYPE (high) = ffecom_integer_type_node;
8533
8534   if (init)
8535     cbtype = build_array_type (char_type_node,
8536                                build_range_type (integer_type_node,
8537                                                  integer_zero_node,
8538                                                  high));
8539   else
8540     cbtype = build_array_type (char_type_node, NULL_TREE);
8541
8542   if (cbt == NULL_TREE)
8543     {
8544       cbt
8545         = build_decl (VAR_DECL,
8546                       ffecom_get_external_identifier_ (s),
8547                       cbtype);
8548       TREE_STATIC (cbt) = 1;
8549       TREE_PUBLIC (cbt) = 1;
8550     }
8551   else
8552     {
8553       assert (is_init);
8554       TREE_TYPE (cbt) = cbtype;
8555     }
8556   DECL_EXTERNAL (cbt) = init ? 0 : 1;
8557   DECL_INITIAL (cbt) = init ? error_mark_node : NULL_TREE;
8558
8559   cbt = start_decl (cbt, TRUE);
8560   if (ffeglobal_hook (g) != NULL)
8561     assert (cbt == ffeglobal_hook (g));
8562
8563   assert (!init || !DECL_EXTERNAL (cbt));
8564
8565   /* Make sure that any type can live in COMMON and be referenced
8566      without getting a bus error.  We could pick the most restrictive
8567      alignment of all entities actually placed in the COMMON, but
8568      this seems easy enough.  */
8569
8570   DECL_ALIGN (cbt) = BIGGEST_ALIGNMENT;
8571   DECL_USER_ALIGN (cbt) = 0;
8572
8573   if (is_init && (ffestorag_init (st) == NULL))
8574     init = ffecom_init_zero_ (cbt);
8575
8576   finish_decl (cbt, init, TRUE);
8577
8578   if (is_init)
8579     ffestorag_set_init (st, ffebld_new_any ());
8580
8581   if (init)
8582     {
8583       assert (DECL_SIZE_UNIT (cbt) != NULL_TREE);
8584       assert (TREE_CODE (DECL_SIZE_UNIT (cbt)) == INTEGER_CST);
8585       assert (0 == compare_tree_int (DECL_SIZE_UNIT (cbt),
8586                                      (ffeglobal_common_size (g)
8587                                       + ffeglobal_common_pad (g))));
8588     }
8589
8590   ffeglobal_set_hook (g, cbt);
8591
8592   ffestorag_set_hook (st, cbt);
8593
8594   ffecom_save_tree_forever (cbt);
8595 }
8596
8597 /* Make master area for local EQUIVALENCE.  */
8598
8599 static void
8600 ffecom_transform_equiv_ (ffestorag eqst)
8601 {
8602   tree eqt;
8603   tree eqtype;
8604   tree init;
8605   tree high;
8606   bool is_init = ffestorag_is_init (eqst);
8607
8608   assert (eqst != NULL);
8609
8610   eqt = ffestorag_hook (eqst);
8611
8612   if (eqt != NULL_TREE)
8613     return;
8614
8615   /* Process inits.  */
8616
8617   if (is_init)
8618     {
8619       if (ffestorag_init (eqst) != NULL)
8620         {
8621           ffebld sexp;
8622
8623           /* Set the padding for the expression, so ffecom_expr
8624              knows to insert that many zeros.  */
8625           switch (ffebld_op (sexp = ffestorag_init (eqst)))
8626             {
8627             case FFEBLD_opCONTER:
8628               ffebld_conter_set_pad (sexp, ffestorag_modulo (eqst));
8629               break;
8630
8631             case FFEBLD_opARRTER:
8632               ffebld_arrter_set_pad (sexp, ffestorag_modulo (eqst));
8633               break;
8634
8635             case FFEBLD_opACCTER:
8636               ffebld_accter_set_pad (sexp, ffestorag_modulo (eqst));
8637               break;
8638
8639             default:
8640               assert ("bad op for eqv init (pad)" == NULL);
8641               break;
8642             }
8643
8644           init = ffecom_expr (sexp);
8645           if (init == error_mark_node)
8646             init = NULL_TREE;   /* Hopefully the back end complained! */
8647         }
8648       else
8649         init = error_mark_node;
8650     }
8651   else if (ffe_is_init_local_zero ())
8652     init = error_mark_node;
8653   else
8654     init = NULL_TREE;
8655
8656   ffecom_member_namelisted_ = FALSE;
8657   ffestorag_drive (ffestorag_list_equivs (eqst),
8658                    &ffecom_member_phase1_,
8659                    eqst);
8660
8661   high = build_int_2 ((ffestorag_size (eqst)
8662                        + ffestorag_modulo (eqst)) - 1, 0);
8663   TREE_TYPE (high) = ffecom_integer_type_node;
8664
8665   eqtype = build_array_type (char_type_node,
8666                              build_range_type (ffecom_integer_type_node,
8667                                                ffecom_integer_zero_node,
8668                                                high));
8669
8670   eqt = build_decl (VAR_DECL,
8671                     ffecom_get_invented_identifier ("__g77_equiv_%s",
8672                                                     ffesymbol_text
8673                                                     (ffestorag_symbol (eqst))),
8674                     eqtype);
8675   DECL_EXTERNAL (eqt) = 0;
8676   if (is_init
8677       || ffecom_member_namelisted_
8678 #ifdef FFECOM_sizeMAXSTACKITEM
8679       || (ffestorag_size (eqst) > FFECOM_sizeMAXSTACKITEM)
8680 #endif
8681       || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8682           && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
8683           && (ffestorag_is_save (eqst) || ffe_is_saveall ())))
8684     TREE_STATIC (eqt) = 1;
8685   else
8686     TREE_STATIC (eqt) = 0;
8687   TREE_PUBLIC (eqt) = 0;
8688   TREE_ADDRESSABLE (eqt) = 1;  /* Ensure non-register allocation */
8689   DECL_CONTEXT (eqt) = current_function_decl;
8690   if (init)
8691     DECL_INITIAL (eqt) = error_mark_node;
8692   else
8693     DECL_INITIAL (eqt) = NULL_TREE;
8694
8695   eqt = start_decl (eqt, FALSE);
8696
8697   /* Make sure that any type can live in EQUIVALENCE and be referenced
8698      without getting a bus error.  We could pick the most restrictive
8699      alignment of all entities actually placed in the EQUIVALENCE, but
8700      this seems easy enough.  */
8701
8702   DECL_ALIGN (eqt) = BIGGEST_ALIGNMENT;
8703   DECL_USER_ALIGN (eqt) = 0;
8704
8705   if ((!is_init && ffe_is_init_local_zero ())
8706       || (is_init && (ffestorag_init (eqst) == NULL)))
8707     init = ffecom_init_zero_ (eqt);
8708
8709   finish_decl (eqt, init, FALSE);
8710
8711   if (is_init)
8712     ffestorag_set_init (eqst, ffebld_new_any ());
8713
8714   {
8715     assert (TREE_CODE (DECL_SIZE_UNIT (eqt)) == INTEGER_CST);
8716     assert (0 == compare_tree_int (DECL_SIZE_UNIT (eqt),
8717                                    (ffestorag_size (eqst)
8718                                     + ffestorag_modulo (eqst))));
8719   }
8720
8721   ffestorag_set_hook (eqst, eqt);
8722
8723   ffestorag_drive (ffestorag_list_equivs (eqst),
8724                    &ffecom_member_phase2_,
8725                    eqst);
8726 }
8727
8728 /* Implement NAMELIST in back end.  See f2c/format.c for more info.  */
8729
8730 static tree
8731 ffecom_transform_namelist_ (ffesymbol s)
8732 {
8733   tree nmlt;
8734   tree nmltype = ffecom_type_namelist_ ();
8735   tree nmlinits;
8736   tree nameinit;
8737   tree varsinit;
8738   tree nvarsinit;
8739   tree field;
8740   tree high;
8741   int i;
8742   static int mynumber = 0;
8743
8744   nmlt = build_decl (VAR_DECL,
8745                      ffecom_get_invented_identifier ("__g77_namelist_%d",
8746                                                      mynumber++),
8747                      nmltype);
8748   TREE_STATIC (nmlt) = 1;
8749   DECL_INITIAL (nmlt) = error_mark_node;
8750
8751   nmlt = start_decl (nmlt, FALSE);
8752
8753   /* Process inits.  */
8754
8755   i = strlen (ffesymbol_text (s));
8756
8757   high = build_int_2 (i, 0);
8758   TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
8759
8760   nameinit = ffecom_build_f2c_string_ (i + 1,
8761                                        ffesymbol_text (s));
8762   TREE_TYPE (nameinit)
8763     = build_type_variant
8764     (build_array_type
8765      (char_type_node,
8766       build_range_type (ffecom_f2c_ftnlen_type_node,
8767                         ffecom_f2c_ftnlen_one_node,
8768                         high)),
8769      1, 0);
8770   TREE_CONSTANT (nameinit) = 1;
8771   TREE_STATIC (nameinit) = 1;
8772   nameinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (nameinit)),
8773                        nameinit);
8774
8775   varsinit = ffecom_vardesc_array_ (s);
8776   varsinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (varsinit)),
8777                        varsinit);
8778   TREE_CONSTANT (varsinit) = 1;
8779   TREE_STATIC (varsinit) = 1;
8780
8781   {
8782     ffebld b;
8783
8784     for (i = 0, b = ffesymbol_namelist (s); b != NULL; b = ffebld_trail (b))
8785       ++i;
8786   }
8787   nvarsinit = build_int_2 (i, 0);
8788   TREE_TYPE (nvarsinit) = integer_type_node;
8789   TREE_CONSTANT (nvarsinit) = 1;
8790   TREE_STATIC (nvarsinit) = 1;
8791
8792   nmlinits = build_tree_list ((field = TYPE_FIELDS (nmltype)), nameinit);
8793   TREE_CHAIN (nmlinits) = build_tree_list ((field = TREE_CHAIN (field)),
8794                                            varsinit);
8795   TREE_CHAIN (TREE_CHAIN (nmlinits))
8796     = build_tree_list ((field = TREE_CHAIN (field)), nvarsinit);
8797
8798   nmlinits = build (CONSTRUCTOR, nmltype, NULL_TREE, nmlinits);
8799   TREE_CONSTANT (nmlinits) = 1;
8800   TREE_STATIC (nmlinits) = 1;
8801
8802   finish_decl (nmlt, nmlinits, FALSE);
8803
8804   nmlt = ffecom_1 (ADDR_EXPR, build_pointer_type (nmltype), nmlt);
8805
8806   return nmlt;
8807 }
8808
8809 /* A subroutine of ffecom_tree_canonize_ref_.  The incoming tree is
8810    analyzed on the assumption it is calculating a pointer to be
8811    indirected through.  It must return the proper decl and offset,
8812    taking into account different units of measurements for offsets.  */
8813
8814 static void
8815 ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
8816                            tree t)
8817 {
8818   switch (TREE_CODE (t))
8819     {
8820     case NOP_EXPR:
8821     case CONVERT_EXPR:
8822     case NON_LVALUE_EXPR:
8823       ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
8824       break;
8825
8826     case PLUS_EXPR:
8827       ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
8828       if ((*decl == NULL_TREE)
8829           || (*decl == error_mark_node))
8830         break;
8831
8832       if (TREE_CODE (TREE_OPERAND (t, 1)) == INTEGER_CST)
8833         {
8834           /* An offset into COMMON.  */
8835           *offset = fold (build (PLUS_EXPR, TREE_TYPE (*offset),
8836                                  *offset, TREE_OPERAND (t, 1)));
8837           /* Convert offset (presumably in bytes) into canonical units
8838              (presumably bits).  */
8839           *offset = size_binop (MULT_EXPR,
8840                                 convert (bitsizetype, *offset),
8841                                 TYPE_SIZE (TREE_TYPE (TREE_TYPE (t))));
8842           break;
8843         }
8844       /* Not a COMMON reference, so an unrecognized pattern.  */
8845       *decl = error_mark_node;
8846       break;
8847
8848     case PARM_DECL:
8849       *decl = t;
8850       *offset = bitsize_zero_node;
8851       break;
8852
8853     case ADDR_EXPR:
8854       if (TREE_CODE (TREE_OPERAND (t, 0)) == VAR_DECL)
8855         {
8856           /* A reference to COMMON.  */
8857           *decl = TREE_OPERAND (t, 0);
8858           *offset = bitsize_zero_node;
8859           break;
8860         }
8861       /* Fall through.  */
8862     default:
8863       /* Not a COMMON reference, so an unrecognized pattern.  */
8864       *decl = error_mark_node;
8865       break;
8866     }
8867 }
8868
8869 /* Given a tree that is possibly intended for use as an lvalue, return
8870    information representing a canonical view of that tree as a decl, an
8871    offset into that decl, and a size for the lvalue.
8872
8873    If there's no applicable decl, NULL_TREE is returned for the decl,
8874    and the other fields are left undefined.
8875
8876    If the tree doesn't fit the recognizable forms, an ERROR_MARK node
8877    is returned for the decl, and the other fields are left undefined.
8878
8879    Otherwise, the decl returned currently is either a VAR_DECL or a
8880    PARM_DECL.
8881
8882    The offset returned is always valid, but of course not necessarily
8883    a constant, and not necessarily converted into the appropriate
8884    type, leaving that up to the caller (so as to avoid that overhead
8885    if the decls being looked at are different anyway).
8886
8887    If the size cannot be determined (e.g. an adjustable array),
8888    an ERROR_MARK node is returned for the size.  Otherwise, the
8889    size returned is valid, not necessarily a constant, and not
8890    necessarily converted into the appropriate type as with the
8891    offset.
8892
8893    Note that the offset and size expressions are expressed in the
8894    base storage units (usually bits) rather than in the units of
8895    the type of the decl, because two decls with different types
8896    might overlap but with apparently non-overlapping array offsets,
8897    whereas converting the array offsets to consistant offsets will
8898    reveal the overlap.  */
8899
8900 static void
8901 ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
8902                            tree *size, tree t)
8903 {
8904   /* The default path is to report a nonexistant decl.  */
8905   *decl = NULL_TREE;
8906
8907   if (t == NULL_TREE)
8908     return;
8909
8910   switch (TREE_CODE (t))
8911     {
8912     case ERROR_MARK:
8913     case IDENTIFIER_NODE:
8914     case INTEGER_CST:
8915     case REAL_CST:
8916     case COMPLEX_CST:
8917     case STRING_CST:
8918     case CONST_DECL:
8919     case PLUS_EXPR:
8920     case MINUS_EXPR:
8921     case MULT_EXPR:
8922     case TRUNC_DIV_EXPR:
8923     case CEIL_DIV_EXPR:
8924     case FLOOR_DIV_EXPR:
8925     case ROUND_DIV_EXPR:
8926     case TRUNC_MOD_EXPR:
8927     case CEIL_MOD_EXPR:
8928     case FLOOR_MOD_EXPR:
8929     case ROUND_MOD_EXPR:
8930     case RDIV_EXPR:
8931     case EXACT_DIV_EXPR:
8932     case FIX_TRUNC_EXPR:
8933     case FIX_CEIL_EXPR:
8934     case FIX_FLOOR_EXPR:
8935     case FIX_ROUND_EXPR:
8936     case FLOAT_EXPR:
8937     case NEGATE_EXPR:
8938     case MIN_EXPR:
8939     case MAX_EXPR:
8940     case ABS_EXPR:
8941     case FFS_EXPR:
8942     case LSHIFT_EXPR:
8943     case RSHIFT_EXPR:
8944     case LROTATE_EXPR:
8945     case RROTATE_EXPR:
8946     case BIT_IOR_EXPR:
8947     case BIT_XOR_EXPR:
8948     case BIT_AND_EXPR:
8949     case BIT_ANDTC_EXPR:
8950     case BIT_NOT_EXPR:
8951     case TRUTH_ANDIF_EXPR:
8952     case TRUTH_ORIF_EXPR:
8953     case TRUTH_AND_EXPR:
8954     case TRUTH_OR_EXPR:
8955     case TRUTH_XOR_EXPR:
8956     case TRUTH_NOT_EXPR:
8957     case LT_EXPR:
8958     case LE_EXPR:
8959     case GT_EXPR:
8960     case GE_EXPR:
8961     case EQ_EXPR:
8962     case NE_EXPR:
8963     case COMPLEX_EXPR:
8964     case CONJ_EXPR:
8965     case REALPART_EXPR:
8966     case IMAGPART_EXPR:
8967     case LABEL_EXPR:
8968     case COMPONENT_REF:
8969     case COMPOUND_EXPR:
8970     case ADDR_EXPR:
8971       return;
8972
8973     case VAR_DECL:
8974     case PARM_DECL:
8975       *decl = t;
8976       *offset = bitsize_zero_node;
8977       *size = TYPE_SIZE (TREE_TYPE (t));
8978       return;
8979
8980     case ARRAY_REF:
8981       {
8982         tree array = TREE_OPERAND (t, 0);
8983         tree element = TREE_OPERAND (t, 1);
8984         tree init_offset;
8985
8986         if ((array == NULL_TREE)
8987             || (element == NULL_TREE))
8988           {
8989             *decl = error_mark_node;
8990             return;
8991           }
8992
8993         ffecom_tree_canonize_ref_ (decl, &init_offset, size,
8994                                    array);
8995         if ((*decl == NULL_TREE)
8996             || (*decl == error_mark_node))
8997           return;
8998
8999         /* Calculate ((element - base) * NBBY) + init_offset.  */
9000         *offset = fold (build (MINUS_EXPR, TREE_TYPE (element),
9001                                element,
9002                                TYPE_MIN_VALUE (TYPE_DOMAIN
9003                                                (TREE_TYPE (array)))));
9004
9005         *offset = size_binop (MULT_EXPR,
9006                               convert (bitsizetype, *offset),
9007                               TYPE_SIZE (TREE_TYPE (TREE_TYPE (array))));
9008
9009         *offset = size_binop (PLUS_EXPR, init_offset, *offset);
9010
9011         *size = TYPE_SIZE (TREE_TYPE (t));
9012         return;
9013       }
9014
9015     case INDIRECT_REF:
9016
9017       /* Most of this code is to handle references to COMMON.  And so
9018          far that is useful only for calling library functions, since
9019          external (user) functions might reference common areas.  But
9020          even calling an external function, it's worthwhile to decode
9021          COMMON references because if not storing into COMMON, we don't
9022          want COMMON-based arguments to gratuitously force use of a
9023          temporary.  */
9024
9025       *size = TYPE_SIZE (TREE_TYPE (t));
9026
9027       ffecom_tree_canonize_ptr_ (decl, offset,
9028                                  TREE_OPERAND (t, 0));
9029
9030       return;
9031
9032     case CONVERT_EXPR:
9033     case NOP_EXPR:
9034     case MODIFY_EXPR:
9035     case NON_LVALUE_EXPR:
9036     case RESULT_DECL:
9037     case FIELD_DECL:
9038     case COND_EXPR:             /* More cases than we can handle. */
9039     case SAVE_EXPR:
9040     case REFERENCE_EXPR:
9041     case PREDECREMENT_EXPR:
9042     case PREINCREMENT_EXPR:
9043     case POSTDECREMENT_EXPR:
9044     case POSTINCREMENT_EXPR:
9045     case CALL_EXPR:
9046     default:
9047       *decl = error_mark_node;
9048       return;
9049     }
9050 }
9051
9052 /* Do divide operation appropriate to type of operands.  */
9053
9054 static tree
9055 ffecom_tree_divide_ (tree tree_type, tree left, tree right,
9056                      tree dest_tree, ffebld dest, bool *dest_used,
9057                      tree hook)
9058 {
9059   if ((left == error_mark_node)
9060       || (right == error_mark_node))
9061     return error_mark_node;
9062
9063   switch (TREE_CODE (tree_type))
9064     {
9065     case INTEGER_TYPE:
9066       return ffecom_2 (TRUNC_DIV_EXPR, tree_type,
9067                        left,
9068                        right);
9069
9070     case COMPLEX_TYPE:
9071       if (! optimize_size)
9072         return ffecom_2 (RDIV_EXPR, tree_type,
9073                          left,
9074                          right);
9075       {
9076         ffecomGfrt ix;
9077
9078         if (TREE_TYPE (tree_type)
9079             == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9080           ix = FFECOM_gfrtDIV_CC;       /* Overlapping result okay. */
9081         else
9082           ix = FFECOM_gfrtDIV_ZZ;       /* Overlapping result okay. */
9083
9084         left = ffecom_1 (ADDR_EXPR,
9085                          build_pointer_type (TREE_TYPE (left)),
9086                          left);
9087         left = build_tree_list (NULL_TREE, left);
9088         right = ffecom_1 (ADDR_EXPR,
9089                           build_pointer_type (TREE_TYPE (right)),
9090                           right);
9091         right = build_tree_list (NULL_TREE, right);
9092         TREE_CHAIN (left) = right;
9093
9094         return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9095                              ffecom_gfrt_kindtype (ix),
9096                              ffe_is_f2c_library (),
9097                              tree_type,
9098                              left,
9099                              dest_tree, dest, dest_used,
9100                              NULL_TREE, TRUE, hook);
9101       }
9102       break;
9103
9104     case RECORD_TYPE:
9105       {
9106         ffecomGfrt ix;
9107
9108         if (TREE_TYPE (TYPE_FIELDS (tree_type))
9109             == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9110           ix = FFECOM_gfrtDIV_CC;       /* Overlapping result okay. */
9111         else
9112           ix = FFECOM_gfrtDIV_ZZ;       /* Overlapping result okay. */
9113
9114         left = ffecom_1 (ADDR_EXPR,
9115                          build_pointer_type (TREE_TYPE (left)),
9116                          left);
9117         left = build_tree_list (NULL_TREE, left);
9118         right = ffecom_1 (ADDR_EXPR,
9119                           build_pointer_type (TREE_TYPE (right)),
9120                           right);
9121         right = build_tree_list (NULL_TREE, right);
9122         TREE_CHAIN (left) = right;
9123
9124         return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9125                              ffecom_gfrt_kindtype (ix),
9126                              ffe_is_f2c_library (),
9127                              tree_type,
9128                              left,
9129                              dest_tree, dest, dest_used,
9130                              NULL_TREE, TRUE, hook);
9131       }
9132       break;
9133
9134     default:
9135       return ffecom_2 (RDIV_EXPR, tree_type,
9136                        left,
9137                        right);
9138     }
9139 }
9140
9141 /* Build type info for non-dummy variable.  */
9142
9143 static tree
9144 ffecom_type_localvar_ (ffesymbol s, ffeinfoBasictype bt,
9145                        ffeinfoKindtype kt)
9146 {
9147   tree type;
9148   ffebld dl;
9149   ffebld dim;
9150   tree lowt;
9151   tree hight;
9152
9153   type = ffecom_tree_type[bt][kt];
9154   if (bt == FFEINFO_basictypeCHARACTER)
9155     {
9156       hight = build_int_2 (ffesymbol_size (s), 0);
9157       TREE_TYPE (hight) = ffecom_f2c_ftnlen_type_node;
9158
9159       type
9160         = build_array_type
9161           (type,
9162            build_range_type (ffecom_f2c_ftnlen_type_node,
9163                              ffecom_f2c_ftnlen_one_node,
9164                              hight));
9165       type = ffecom_check_size_overflow_ (s, type, FALSE);
9166     }
9167
9168   for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
9169     {
9170       if (type == error_mark_node)
9171         break;
9172
9173       dim = ffebld_head (dl);
9174       assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
9175
9176       if (ffebld_left (dim) == NULL)
9177         lowt = integer_one_node;
9178       else
9179         lowt = ffecom_expr (ffebld_left (dim));
9180
9181       if (TREE_CODE (lowt) != INTEGER_CST)
9182         lowt = variable_size (lowt);
9183
9184       assert (ffebld_right (dim) != NULL);
9185       hight = ffecom_expr (ffebld_right (dim));
9186
9187       if (TREE_CODE (hight) != INTEGER_CST)
9188         hight = variable_size (hight);
9189
9190       type = build_array_type (type,
9191                                build_range_type (ffecom_integer_type_node,
9192                                                  lowt, hight));
9193       type = ffecom_check_size_overflow_ (s, type, FALSE);
9194     }
9195
9196   return type;
9197 }
9198
9199 /* Build Namelist type.  */
9200
9201 static tree
9202 ffecom_type_namelist_ ()
9203 {
9204   static tree type = NULL_TREE;
9205
9206   if (type == NULL_TREE)
9207     {
9208       static tree namefield, varsfield, nvarsfield;
9209       tree vardesctype;
9210
9211       vardesctype = ffecom_type_vardesc_ ();
9212
9213       type = make_node (RECORD_TYPE);
9214
9215       vardesctype = build_pointer_type (build_pointer_type (vardesctype));
9216
9217       namefield = ffecom_decl_field (type, NULL_TREE, "name",
9218                                      string_type_node);
9219       varsfield = ffecom_decl_field (type, namefield, "vars", vardesctype);
9220       nvarsfield = ffecom_decl_field (type, varsfield, "nvars",
9221                                       integer_type_node);
9222
9223       TYPE_FIELDS (type) = namefield;
9224       layout_type (type);
9225
9226       ggc_add_tree_root (&type, 1);
9227     }
9228
9229   return type;
9230 }
9231
9232 /* Build Vardesc type.  */
9233
9234 static tree
9235 ffecom_type_vardesc_ ()
9236 {
9237   static tree type = NULL_TREE;
9238   static tree namefield, addrfield, dimsfield, typefield;
9239
9240   if (type == NULL_TREE)
9241     {
9242       type = make_node (RECORD_TYPE);
9243
9244       namefield = ffecom_decl_field (type, NULL_TREE, "name",
9245                                      string_type_node);
9246       addrfield = ffecom_decl_field (type, namefield, "addr",
9247                                      string_type_node);
9248       dimsfield = ffecom_decl_field (type, addrfield, "dims",
9249                                      ffecom_f2c_ptr_to_ftnlen_type_node);
9250       typefield = ffecom_decl_field (type, dimsfield, "type",
9251                                      integer_type_node);
9252
9253       TYPE_FIELDS (type) = namefield;
9254       layout_type (type);
9255
9256       ggc_add_tree_root (&type, 1);
9257     }
9258
9259   return type;
9260 }
9261
9262 static tree
9263 ffecom_vardesc_ (ffebld expr)
9264 {
9265   ffesymbol s;
9266
9267   assert (ffebld_op (expr) == FFEBLD_opSYMTER);
9268   s = ffebld_symter (expr);
9269
9270   if (ffesymbol_hook (s).vardesc_tree == NULL_TREE)
9271     {
9272       int i;
9273       tree vardesctype = ffecom_type_vardesc_ ();
9274       tree var;
9275       tree nameinit;
9276       tree dimsinit;
9277       tree addrinit;
9278       tree typeinit;
9279       tree field;
9280       tree varinits;
9281       static int mynumber = 0;
9282
9283       var = build_decl (VAR_DECL,
9284                         ffecom_get_invented_identifier ("__g77_vardesc_%d",
9285                                                         mynumber++),
9286                         vardesctype);
9287       TREE_STATIC (var) = 1;
9288       DECL_INITIAL (var) = error_mark_node;
9289
9290       var = start_decl (var, FALSE);
9291
9292       /* Process inits.  */
9293
9294       nameinit = ffecom_build_f2c_string_ ((i = strlen (ffesymbol_text (s)))
9295                                            + 1,
9296                                            ffesymbol_text (s));
9297       TREE_TYPE (nameinit)
9298         = build_type_variant
9299         (build_array_type
9300          (char_type_node,
9301           build_range_type (integer_type_node,
9302                             integer_one_node,
9303                             build_int_2 (i, 0))),
9304          1, 0);
9305       TREE_CONSTANT (nameinit) = 1;
9306       TREE_STATIC (nameinit) = 1;
9307       nameinit = ffecom_1 (ADDR_EXPR,
9308                            build_pointer_type (TREE_TYPE (nameinit)),
9309                            nameinit);
9310
9311       addrinit = ffecom_arg_ptr_to_expr (expr, &typeinit);
9312
9313       dimsinit = ffecom_vardesc_dims_ (s);
9314
9315       if (typeinit == NULL_TREE)
9316         {
9317           ffeinfoBasictype bt = ffesymbol_basictype (s);
9318           ffeinfoKindtype kt = ffesymbol_kindtype (s);
9319           int tc = ffecom_f2c_typecode (bt, kt);
9320
9321           assert (tc != -1);
9322           typeinit = build_int_2 (tc, (tc < 0) ? -1 : 0);
9323         }
9324       else
9325         typeinit = ffecom_1 (NEGATE_EXPR, TREE_TYPE (typeinit), typeinit);
9326
9327       varinits = build_tree_list ((field = TYPE_FIELDS (vardesctype)),
9328                                   nameinit);
9329       TREE_CHAIN (varinits) = build_tree_list ((field = TREE_CHAIN (field)),
9330                                                addrinit);
9331       TREE_CHAIN (TREE_CHAIN (varinits))
9332         = build_tree_list ((field = TREE_CHAIN (field)), dimsinit);
9333       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (varinits)))
9334         = build_tree_list ((field = TREE_CHAIN (field)), typeinit);
9335
9336       varinits = build (CONSTRUCTOR, vardesctype, NULL_TREE, varinits);
9337       TREE_CONSTANT (varinits) = 1;
9338       TREE_STATIC (varinits) = 1;
9339
9340       finish_decl (var, varinits, FALSE);
9341
9342       var = ffecom_1 (ADDR_EXPR, build_pointer_type (vardesctype), var);
9343
9344       ffesymbol_hook (s).vardesc_tree = var;
9345     }
9346
9347   return ffesymbol_hook (s).vardesc_tree;
9348 }
9349
9350 static tree
9351 ffecom_vardesc_array_ (ffesymbol s)
9352 {
9353   ffebld b;
9354   tree list;
9355   tree item = NULL_TREE;
9356   tree var;
9357   int i;
9358   static int mynumber = 0;
9359
9360   for (i = 0, list = NULL_TREE, b = ffesymbol_namelist (s);
9361        b != NULL;
9362        b = ffebld_trail (b), ++i)
9363     {
9364       tree t;
9365
9366       t = ffecom_vardesc_ (ffebld_head (b));
9367
9368       if (list == NULL_TREE)
9369         list = item = build_tree_list (NULL_TREE, t);
9370       else
9371         {
9372           TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9373           item = TREE_CHAIN (item);
9374         }
9375     }
9376
9377   item = build_array_type (build_pointer_type (ffecom_type_vardesc_ ()),
9378                            build_range_type (integer_type_node,
9379                                              integer_one_node,
9380                                              build_int_2 (i, 0)));
9381   list = build (CONSTRUCTOR, item, NULL_TREE, list);
9382   TREE_CONSTANT (list) = 1;
9383   TREE_STATIC (list) = 1;
9384
9385   var = ffecom_get_invented_identifier ("__g77_vardesc_array_%d", mynumber++);
9386   var = build_decl (VAR_DECL, var, item);
9387   TREE_STATIC (var) = 1;
9388   DECL_INITIAL (var) = error_mark_node;
9389   var = start_decl (var, FALSE);
9390   finish_decl (var, list, FALSE);
9391
9392   return var;
9393 }
9394
9395 static tree
9396 ffecom_vardesc_dims_ (ffesymbol s)
9397 {
9398   if (ffesymbol_dims (s) == NULL)
9399     return convert (ffecom_f2c_ptr_to_ftnlen_type_node,
9400                     integer_zero_node);
9401
9402   {
9403     ffebld b;
9404     ffebld e;
9405     tree list;
9406     tree backlist;
9407     tree item = NULL_TREE;
9408     tree var;
9409     tree numdim;
9410     tree numelem;
9411     tree baseoff = NULL_TREE;
9412     static int mynumber = 0;
9413
9414     numdim = build_int_2 ((int) ffesymbol_rank (s), 0);
9415     TREE_TYPE (numdim) = ffecom_f2c_ftnlen_type_node;
9416
9417     numelem = ffecom_expr (ffesymbol_arraysize (s));
9418     TREE_TYPE (numelem) = ffecom_f2c_ftnlen_type_node;
9419
9420     list = NULL_TREE;
9421     backlist = NULL_TREE;
9422     for (b = ffesymbol_dims (s), e = ffesymbol_extents (s);
9423          b != NULL;
9424          b = ffebld_trail (b), e = ffebld_trail (e))
9425       {
9426         tree t;
9427         tree low;
9428         tree back;
9429
9430         if (ffebld_trail (b) == NULL)
9431           t = NULL_TREE;
9432         else
9433           {
9434             t = convert (ffecom_f2c_ftnlen_type_node,
9435                          ffecom_expr (ffebld_head (e)));
9436
9437             if (list == NULL_TREE)
9438               list = item = build_tree_list (NULL_TREE, t);
9439             else
9440               {
9441                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9442                 item = TREE_CHAIN (item);
9443               }
9444           }
9445
9446         if (ffebld_left (ffebld_head (b)) == NULL)
9447           low = ffecom_integer_one_node;
9448         else
9449           low = ffecom_expr (ffebld_left (ffebld_head (b)));
9450         low = convert (ffecom_f2c_ftnlen_type_node, low);
9451
9452         back = build_tree_list (low, t);
9453         TREE_CHAIN (back) = backlist;
9454         backlist = back;
9455       }
9456
9457     for (item = backlist; item != NULL_TREE; item = TREE_CHAIN (item))
9458       {
9459         if (TREE_VALUE (item) == NULL_TREE)
9460           baseoff = TREE_PURPOSE (item);
9461         else
9462           baseoff = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
9463                               TREE_PURPOSE (item),
9464                               ffecom_2 (MULT_EXPR,
9465                                         ffecom_f2c_ftnlen_type_node,
9466                                         TREE_VALUE (item),
9467                                         baseoff));
9468       }
9469
9470     /* backlist now dead, along with all TREE_PURPOSEs on it.  */
9471
9472     baseoff = build_tree_list (NULL_TREE, baseoff);
9473     TREE_CHAIN (baseoff) = list;
9474
9475     numelem = build_tree_list (NULL_TREE, numelem);
9476     TREE_CHAIN (numelem) = baseoff;
9477
9478     numdim = build_tree_list (NULL_TREE, numdim);
9479     TREE_CHAIN (numdim) = numelem;
9480
9481     item = build_array_type (ffecom_f2c_ftnlen_type_node,
9482                              build_range_type (integer_type_node,
9483                                                integer_zero_node,
9484                                                build_int_2
9485                                                ((int) ffesymbol_rank (s)
9486                                                 + 2, 0)));
9487     list = build (CONSTRUCTOR, item, NULL_TREE, numdim);
9488     TREE_CONSTANT (list) = 1;
9489     TREE_STATIC (list) = 1;
9490
9491     var = ffecom_get_invented_identifier ("__g77_dims_%d", mynumber++);
9492     var = build_decl (VAR_DECL, var, item);
9493     TREE_STATIC (var) = 1;
9494     DECL_INITIAL (var) = error_mark_node;
9495     var = start_decl (var, FALSE);
9496     finish_decl (var, list, FALSE);
9497
9498     var = ffecom_1 (ADDR_EXPR, build_pointer_type (item), var);
9499
9500     return var;
9501   }
9502 }
9503
9504 /* Essentially does a "fold (build1 (code, type, node))" while checking
9505    for certain housekeeping things.
9506
9507    NOTE: for building an ADDR_EXPR around a FUNCTION_DECL, use
9508    ffecom_1_fn instead.  */
9509
9510 tree
9511 ffecom_1 (enum tree_code code, tree type, tree node)
9512 {
9513   tree item;
9514
9515   if ((node == error_mark_node)
9516       || (type == error_mark_node))
9517     return error_mark_node;
9518
9519   if (code == ADDR_EXPR)
9520     {
9521       if (!mark_addressable (node))
9522         assert ("can't mark_addressable this node!" == NULL);
9523     }
9524
9525   switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9526     {
9527       tree realtype;
9528
9529     case REALPART_EXPR:
9530       item = build (COMPONENT_REF, type, node, TYPE_FIELDS (TREE_TYPE (node)));
9531       break;
9532
9533     case IMAGPART_EXPR:
9534       item = build (COMPONENT_REF, type, node, TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (node))));
9535       break;
9536
9537
9538     case NEGATE_EXPR:
9539       if (TREE_CODE (type) != RECORD_TYPE)
9540         {
9541           item = build1 (code, type, node);
9542           break;
9543         }
9544       node = ffecom_stabilize_aggregate_ (node);
9545       realtype = TREE_TYPE (TYPE_FIELDS (type));
9546       item =
9547         ffecom_2 (COMPLEX_EXPR, type,
9548                   ffecom_1 (NEGATE_EXPR, realtype,
9549                             ffecom_1 (REALPART_EXPR, realtype,
9550                                       node)),
9551                   ffecom_1 (NEGATE_EXPR, realtype,
9552                             ffecom_1 (IMAGPART_EXPR, realtype,
9553                                       node)));
9554       break;
9555
9556     default:
9557       item = build1 (code, type, node);
9558       break;
9559     }
9560
9561   if (TREE_SIDE_EFFECTS (node))
9562     TREE_SIDE_EFFECTS (item) = 1;
9563   if ((code == ADDR_EXPR) && staticp (node))
9564     TREE_CONSTANT (item) = 1;
9565   return fold (item);
9566 }
9567
9568 /* Like ffecom_1 (ADDR_EXPR, TREE_TYPE (node), node), except
9569    handles TREE_CODE (node) == FUNCTION_DECL.  In particular,
9570    does not set TREE_ADDRESSABLE (because calling an inline
9571    function does not mean the function needs to be separately
9572    compiled).  */
9573
9574 tree
9575 ffecom_1_fn (tree node)
9576 {
9577   tree item;
9578   tree type;
9579
9580   if (node == error_mark_node)
9581     return error_mark_node;
9582
9583   type = build_type_variant (TREE_TYPE (node),
9584                              TREE_READONLY (node),
9585                              TREE_THIS_VOLATILE (node));
9586   item = build1 (ADDR_EXPR,
9587                  build_pointer_type (type), node);
9588   if (TREE_SIDE_EFFECTS (node))
9589     TREE_SIDE_EFFECTS (item) = 1;
9590   if (staticp (node))
9591     TREE_CONSTANT (item) = 1;
9592   return fold (item);
9593 }
9594
9595 /* Essentially does a "fold (build (code, type, node1, node2))" while
9596    checking for certain housekeeping things.  */
9597
9598 tree
9599 ffecom_2 (enum tree_code code, tree type, tree node1,
9600           tree node2)
9601 {
9602   tree item;
9603
9604   if ((node1 == error_mark_node)
9605       || (node2 == error_mark_node)
9606       || (type == error_mark_node))
9607     return error_mark_node;
9608
9609   switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9610     {
9611       tree a, b, c, d, realtype;
9612
9613     case CONJ_EXPR:
9614       assert ("no CONJ_EXPR support yet" == NULL);
9615       return error_mark_node;
9616
9617     case COMPLEX_EXPR:
9618       item = build_tree_list (TYPE_FIELDS (type), node1);
9619       TREE_CHAIN (item) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), node2);
9620       item = build (CONSTRUCTOR, type, NULL_TREE, item);
9621       break;
9622
9623     case PLUS_EXPR:
9624       if (TREE_CODE (type) != RECORD_TYPE)
9625         {
9626           item = build (code, type, node1, node2);
9627           break;
9628         }
9629       node1 = ffecom_stabilize_aggregate_ (node1);
9630       node2 = ffecom_stabilize_aggregate_ (node2);
9631       realtype = TREE_TYPE (TYPE_FIELDS (type));
9632       item =
9633         ffecom_2 (COMPLEX_EXPR, type,
9634                   ffecom_2 (PLUS_EXPR, realtype,
9635                             ffecom_1 (REALPART_EXPR, realtype,
9636                                       node1),
9637                             ffecom_1 (REALPART_EXPR, realtype,
9638                                       node2)),
9639                   ffecom_2 (PLUS_EXPR, realtype,
9640                             ffecom_1 (IMAGPART_EXPR, realtype,
9641                                       node1),
9642                             ffecom_1 (IMAGPART_EXPR, realtype,
9643                                       node2)));
9644       break;
9645
9646     case MINUS_EXPR:
9647       if (TREE_CODE (type) != RECORD_TYPE)
9648         {
9649           item = build (code, type, node1, node2);
9650           break;
9651         }
9652       node1 = ffecom_stabilize_aggregate_ (node1);
9653       node2 = ffecom_stabilize_aggregate_ (node2);
9654       realtype = TREE_TYPE (TYPE_FIELDS (type));
9655       item =
9656         ffecom_2 (COMPLEX_EXPR, type,
9657                   ffecom_2 (MINUS_EXPR, realtype,
9658                             ffecom_1 (REALPART_EXPR, realtype,
9659                                       node1),
9660                             ffecom_1 (REALPART_EXPR, realtype,
9661                                       node2)),
9662                   ffecom_2 (MINUS_EXPR, realtype,
9663                             ffecom_1 (IMAGPART_EXPR, realtype,
9664                                       node1),
9665                             ffecom_1 (IMAGPART_EXPR, realtype,
9666                                       node2)));
9667       break;
9668
9669     case MULT_EXPR:
9670       if (TREE_CODE (type) != RECORD_TYPE)
9671         {
9672           item = build (code, type, node1, node2);
9673           break;
9674         }
9675       node1 = ffecom_stabilize_aggregate_ (node1);
9676       node2 = ffecom_stabilize_aggregate_ (node2);
9677       realtype = TREE_TYPE (TYPE_FIELDS (type));
9678       a = save_expr (ffecom_1 (REALPART_EXPR, realtype,
9679                                node1));
9680       b = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
9681                                node1));
9682       c = save_expr (ffecom_1 (REALPART_EXPR, realtype,
9683                                node2));
9684       d = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
9685                                node2));
9686       item =
9687         ffecom_2 (COMPLEX_EXPR, type,
9688                   ffecom_2 (MINUS_EXPR, realtype,
9689                             ffecom_2 (MULT_EXPR, realtype,
9690                                       a,
9691                                       c),
9692                             ffecom_2 (MULT_EXPR, realtype,
9693                                       b,
9694                                       d)),
9695                   ffecom_2 (PLUS_EXPR, realtype,
9696                             ffecom_2 (MULT_EXPR, realtype,
9697                                       a,
9698                                       d),
9699                             ffecom_2 (MULT_EXPR, realtype,
9700                                       c,
9701                                       b)));
9702       break;
9703
9704     case EQ_EXPR:
9705       if ((TREE_CODE (node1) != RECORD_TYPE)
9706           && (TREE_CODE (node2) != RECORD_TYPE))
9707         {
9708           item = build (code, type, node1, node2);
9709           break;
9710         }
9711       assert (TREE_CODE (node1) == RECORD_TYPE);
9712       assert (TREE_CODE (node2) == RECORD_TYPE);
9713       node1 = ffecom_stabilize_aggregate_ (node1);
9714       node2 = ffecom_stabilize_aggregate_ (node2);
9715       realtype = TREE_TYPE (TYPE_FIELDS (type));
9716       item =
9717         ffecom_2 (TRUTH_ANDIF_EXPR, type,
9718                   ffecom_2 (code, type,
9719                             ffecom_1 (REALPART_EXPR, realtype,
9720                                       node1),
9721                             ffecom_1 (REALPART_EXPR, realtype,
9722                                       node2)),
9723                   ffecom_2 (code, type,
9724                             ffecom_1 (IMAGPART_EXPR, realtype,
9725                                       node1),
9726                             ffecom_1 (IMAGPART_EXPR, realtype,
9727                                       node2)));
9728       break;
9729
9730     case NE_EXPR:
9731       if ((TREE_CODE (node1) != RECORD_TYPE)
9732           && (TREE_CODE (node2) != RECORD_TYPE))
9733         {
9734           item = build (code, type, node1, node2);
9735           break;
9736         }
9737       assert (TREE_CODE (node1) == RECORD_TYPE);
9738       assert (TREE_CODE (node2) == RECORD_TYPE);
9739       node1 = ffecom_stabilize_aggregate_ (node1);
9740       node2 = ffecom_stabilize_aggregate_ (node2);
9741       realtype = TREE_TYPE (TYPE_FIELDS (type));
9742       item =
9743         ffecom_2 (TRUTH_ORIF_EXPR, type,
9744                   ffecom_2 (code, type,
9745                             ffecom_1 (REALPART_EXPR, realtype,
9746                                       node1),
9747                             ffecom_1 (REALPART_EXPR, realtype,
9748                                       node2)),
9749                   ffecom_2 (code, type,
9750                             ffecom_1 (IMAGPART_EXPR, realtype,
9751                                       node1),
9752                             ffecom_1 (IMAGPART_EXPR, realtype,
9753                                       node2)));
9754       break;
9755
9756     default:
9757       item = build (code, type, node1, node2);
9758       break;
9759     }
9760
9761   if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2))
9762     TREE_SIDE_EFFECTS (item) = 1;
9763   return fold (item);
9764 }
9765
9766 /* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint
9767
9768    ffesymbol s;  // the ENTRY point itself
9769    if (ffecom_2pass_advise_entrypoint(s))
9770        // the ENTRY point has been accepted
9771
9772    Does whatever compiler needs to do when it learns about the entrypoint,
9773    like determine the return type of the master function, count the
9774    number of entrypoints, etc.  Returns FALSE if the return type is
9775    not compatible with the return type(s) of other entrypoint(s).
9776
9777    NOTE: for every call to this fn that returns TRUE, _do_entrypoint must
9778    later (after _finish_progunit) be called with the same entrypoint(s)
9779    as passed to this fn for which TRUE was returned.
9780
9781    03-Jan-92  JCB  2.0
9782       Return FALSE if the return type conflicts with previous entrypoints.  */
9783
9784 bool
9785 ffecom_2pass_advise_entrypoint (ffesymbol entry)
9786 {
9787   ffebld list;                  /* opITEM. */
9788   ffebld mlist;                 /* opITEM. */
9789   ffebld plist;                 /* opITEM. */
9790   ffebld arg;                   /* ffebld_head(opITEM). */
9791   ffebld item;                  /* opITEM. */
9792   ffesymbol s;                  /* ffebld_symter(arg). */
9793   ffeinfoBasictype bt = ffesymbol_basictype (entry);
9794   ffeinfoKindtype kt = ffesymbol_kindtype (entry);
9795   ffetargetCharacterSize size = ffesymbol_size (entry);
9796   bool ok;
9797
9798   if (ffecom_num_entrypoints_ == 0)
9799     {                           /* First entrypoint, make list of main
9800                                    arglist's dummies. */
9801       assert (ffecom_primary_entry_ != NULL);
9802
9803       ffecom_master_bt_ = ffesymbol_basictype (ffecom_primary_entry_);
9804       ffecom_master_kt_ = ffesymbol_kindtype (ffecom_primary_entry_);
9805       ffecom_master_size_ = ffesymbol_size (ffecom_primary_entry_);
9806
9807       for (plist = NULL, list = ffesymbol_dummyargs (ffecom_primary_entry_);
9808            list != NULL;
9809            list = ffebld_trail (list))
9810         {
9811           arg = ffebld_head (list);
9812           if (ffebld_op (arg) != FFEBLD_opSYMTER)
9813             continue;           /* Alternate return or some such thing. */
9814           item = ffebld_new_item (arg, NULL);
9815           if (plist == NULL)
9816             ffecom_master_arglist_ = item;
9817           else
9818             ffebld_set_trail (plist, item);
9819           plist = item;
9820         }
9821     }
9822
9823   /* If necessary, scan entry arglist for alternate returns.  Do this scan
9824      apparently redundantly (it's done below to UNIONize the arglists) so
9825      that we don't complain about RETURN 1 if an offending ENTRY is the only
9826      one with an alternate return.  */
9827
9828   if (!ffecom_is_altreturning_)
9829     {
9830       for (list = ffesymbol_dummyargs (entry);
9831            list != NULL;
9832            list = ffebld_trail (list))
9833         {
9834           arg = ffebld_head (list);
9835           if (ffebld_op (arg) == FFEBLD_opSTAR)
9836             {
9837               ffecom_is_altreturning_ = TRUE;
9838               break;
9839             }
9840         }
9841     }
9842
9843   /* Now check type compatibility. */
9844
9845   switch (ffecom_master_bt_)
9846     {
9847     case FFEINFO_basictypeNONE:
9848       ok = (bt != FFEINFO_basictypeCHARACTER);
9849       break;
9850
9851     case FFEINFO_basictypeCHARACTER:
9852       ok
9853         = (bt == FFEINFO_basictypeCHARACTER)
9854         && (kt == ffecom_master_kt_)
9855         && (size == ffecom_master_size_);
9856       break;
9857
9858     case FFEINFO_basictypeANY:
9859       return FALSE;             /* Just don't bother. */
9860
9861     default:
9862       if (bt == FFEINFO_basictypeCHARACTER)
9863         {
9864           ok = FALSE;
9865           break;
9866         }
9867       ok = TRUE;
9868       if ((bt != ffecom_master_bt_) || (kt != ffecom_master_kt_))
9869         {
9870           ffecom_master_bt_ = FFEINFO_basictypeNONE;
9871           ffecom_master_kt_ = FFEINFO_kindtypeNONE;
9872         }
9873       break;
9874     }
9875
9876   if (!ok)
9877     {
9878       ffebad_start (FFEBAD_ENTRY_CONFLICTS);
9879       ffest_ffebad_here_current_stmt (0);
9880       ffebad_finish ();
9881       return FALSE;             /* Can't handle entrypoint. */
9882     }
9883
9884   /* Entrypoint type compatible with previous types. */
9885
9886   ++ffecom_num_entrypoints_;
9887
9888   /* Master-arg-list = UNION(Master-arg-list,entry-arg-list). */
9889
9890   for (list = ffesymbol_dummyargs (entry);
9891        list != NULL;
9892        list = ffebld_trail (list))
9893     {
9894       arg = ffebld_head (list);
9895       if (ffebld_op (arg) != FFEBLD_opSYMTER)
9896         continue;               /* Alternate return or some such thing. */
9897       s = ffebld_symter (arg);
9898       for (plist = NULL, mlist = ffecom_master_arglist_;
9899            mlist != NULL;
9900            plist = mlist, mlist = ffebld_trail (mlist))
9901         {                       /* plist points to previous item for easy
9902                                    appending of arg. */
9903           if (ffebld_symter (ffebld_head (mlist)) == s)
9904             break;              /* Already have this arg in the master list. */
9905         }
9906       if (mlist != NULL)
9907         continue;               /* Already have this arg in the master list. */
9908
9909       /* Append this arg to the master list. */
9910
9911       item = ffebld_new_item (arg, NULL);
9912       if (plist == NULL)
9913         ffecom_master_arglist_ = item;
9914       else
9915         ffebld_set_trail (plist, item);
9916     }
9917
9918   return TRUE;
9919 }
9920
9921 /* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint
9922
9923    ffesymbol s;  // the ENTRY point itself
9924    ffecom_2pass_do_entrypoint(s);
9925
9926    Does whatever compiler needs to do to make the entrypoint actually
9927    happen.  Must be called for each entrypoint after
9928    ffecom_finish_progunit is called.  */
9929
9930 void
9931 ffecom_2pass_do_entrypoint (ffesymbol entry)
9932 {
9933   static int mfn_num = 0;
9934   static int ent_num;
9935
9936   if (mfn_num != ffecom_num_fns_)
9937     {                           /* First entrypoint for this program unit. */
9938       ent_num = 1;
9939       mfn_num = ffecom_num_fns_;
9940       ffecom_do_entry_ (ffecom_primary_entry_, 0);
9941     }
9942   else
9943     ++ent_num;
9944
9945   --ffecom_num_entrypoints_;
9946
9947   ffecom_do_entry_ (entry, ent_num);
9948 }
9949
9950 /* Essentially does a "fold (build (code, type, node1, node2))" while
9951    checking for certain housekeeping things.  Always sets
9952    TREE_SIDE_EFFECTS.  */
9953
9954 tree
9955 ffecom_2s (enum tree_code code, tree type, tree node1,
9956            tree node2)
9957 {
9958   tree item;
9959
9960   if ((node1 == error_mark_node)
9961       || (node2 == error_mark_node)
9962       || (type == error_mark_node))
9963     return error_mark_node;
9964
9965   item = build (code, type, node1, node2);
9966   TREE_SIDE_EFFECTS (item) = 1;
9967   return fold (item);
9968 }
9969
9970 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
9971    checking for certain housekeeping things.  */
9972
9973 tree
9974 ffecom_3 (enum tree_code code, tree type, tree node1,
9975           tree node2, tree node3)
9976 {
9977   tree item;
9978
9979   if ((node1 == error_mark_node)
9980       || (node2 == error_mark_node)
9981       || (node3 == error_mark_node)
9982       || (type == error_mark_node))
9983     return error_mark_node;
9984
9985   item = build (code, type, node1, node2, node3);
9986   if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2)
9987       || (node3 != NULL_TREE && TREE_SIDE_EFFECTS (node3)))
9988     TREE_SIDE_EFFECTS (item) = 1;
9989   return fold (item);
9990 }
9991
9992 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
9993    checking for certain housekeeping things.  Always sets
9994    TREE_SIDE_EFFECTS.  */
9995
9996 tree
9997 ffecom_3s (enum tree_code code, tree type, tree node1,
9998            tree node2, tree node3)
9999 {
10000   tree item;
10001
10002   if ((node1 == error_mark_node)
10003       || (node2 == error_mark_node)
10004       || (node3 == error_mark_node)
10005       || (type == error_mark_node))
10006     return error_mark_node;
10007
10008   item = build (code, type, node1, node2, node3);
10009   TREE_SIDE_EFFECTS (item) = 1;
10010   return fold (item);
10011 }
10012
10013 /* ffecom_arg_expr -- Transform argument expr into gcc tree
10014
10015    See use by ffecom_list_expr.
10016
10017    If expression is NULL, returns an integer zero tree.  If it is not
10018    a CHARACTER expression, returns whatever ffecom_expr
10019    returns and sets the length return value to NULL_TREE.  Otherwise
10020    generates code to evaluate the character expression, returns the proper
10021    pointer to the result, but does NOT set the length return value to a tree
10022    that specifies the length of the result.  (In other words, the length
10023    variable is always set to NULL_TREE, because a length is never passed.)
10024
10025    21-Dec-91  JCB  1.1
10026       Don't set returned length, since nobody needs it (yet; someday if
10027       we allow CHARACTER*(*) dummies to statement functions, we'll need
10028       it).  */
10029
10030 tree
10031 ffecom_arg_expr (ffebld expr, tree *length)
10032 {
10033   tree ign;
10034
10035   *length = NULL_TREE;
10036
10037   if (expr == NULL)
10038     return integer_zero_node;
10039
10040   if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10041     return ffecom_expr (expr);
10042
10043   return ffecom_arg_ptr_to_expr (expr, &ign);
10044 }
10045
10046 /* Transform expression into constant argument-pointer-to-expression tree.
10047
10048    If the expression can be transformed into a argument-pointer-to-expression
10049    tree that is constant, that is done, and the tree returned.  Else
10050    NULL_TREE is returned.
10051
10052    That way, a caller can attempt to provide compile-time initialization
10053    of a variable and, if that fails, *then* choose to start a new block
10054    and resort to using temporaries, as appropriate.  */
10055
10056 tree
10057 ffecom_arg_ptr_to_const_expr (ffebld expr, tree *length)
10058 {
10059   if (! expr)
10060     return integer_zero_node;
10061
10062   if (ffebld_op (expr) == FFEBLD_opANY)
10063     {
10064       if (length)
10065         *length = error_mark_node;
10066       return error_mark_node;
10067     }
10068
10069   if (ffebld_arity (expr) == 0
10070       && (ffebld_op (expr) != FFEBLD_opSYMTER
10071           || ffebld_where (expr) == FFEINFO_whereCOMMON
10072           || ffebld_where (expr) == FFEINFO_whereGLOBAL
10073           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10074     {
10075       tree t;
10076
10077       t = ffecom_arg_ptr_to_expr (expr, length);
10078       assert (TREE_CONSTANT (t));
10079       assert (! length || TREE_CONSTANT (*length));
10080       return t;
10081     }
10082
10083   if (length
10084       && ffebld_size (expr) != FFETARGET_charactersizeNONE)
10085     *length = build_int_2 (ffebld_size (expr), 0);
10086   else if (length)
10087     *length = NULL_TREE;
10088   return NULL_TREE;
10089 }
10090
10091 /* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree
10092
10093    See use by ffecom_list_ptr_to_expr.
10094
10095    If expression is NULL, returns an integer zero tree.  If it is not
10096    a CHARACTER expression, returns whatever ffecom_ptr_to_expr
10097    returns and sets the length return value to NULL_TREE.  Otherwise
10098    generates code to evaluate the character expression, returns the proper
10099    pointer to the result, AND sets the length return value to a tree that
10100    specifies the length of the result.
10101
10102    If the length argument is NULL, this is a slightly special
10103    case of building a FORMAT expression, that is, an expression that
10104    will be used at run time without regard to length.  For the current
10105    implementation, which uses the libf2c library, this means it is nice
10106    to append a null byte to the end of the expression, where feasible,
10107    to make sure any diagnostic about the FORMAT string terminates at
10108    some useful point.
10109
10110    For now, treat %REF(char-expr) as the same as char-expr with a NULL
10111    length argument.  This might even be seen as a feature, if a null
10112    byte can always be appended.  */
10113
10114 tree
10115 ffecom_arg_ptr_to_expr (ffebld expr, tree *length)
10116 {
10117   tree item;
10118   tree ign_length;
10119   ffecomConcatList_ catlist;
10120
10121   if (length != NULL)
10122     *length = NULL_TREE;
10123
10124   if (expr == NULL)
10125     return integer_zero_node;
10126
10127   switch (ffebld_op (expr))
10128     {
10129     case FFEBLD_opPERCENT_VAL:
10130       if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10131         return ffecom_expr (ffebld_left (expr));
10132       {
10133         tree temp_exp;
10134         tree temp_length;
10135
10136         temp_exp = ffecom_arg_ptr_to_expr (ffebld_left (expr), &temp_length);
10137         if (temp_exp == error_mark_node)
10138           return error_mark_node;
10139
10140         return ffecom_1 (INDIRECT_REF, TREE_TYPE (TREE_TYPE (temp_exp)),
10141                          temp_exp);
10142       }
10143
10144     case FFEBLD_opPERCENT_REF:
10145       if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10146         return ffecom_ptr_to_expr (ffebld_left (expr));
10147       if (length != NULL)
10148         {
10149           ign_length = NULL_TREE;
10150           length = &ign_length;
10151         }
10152       expr = ffebld_left (expr);
10153       break;
10154
10155     case FFEBLD_opPERCENT_DESCR:
10156       switch (ffeinfo_basictype (ffebld_info (expr)))
10157         {
10158 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10159         case FFEINFO_basictypeHOLLERITH:
10160 #endif
10161         case FFEINFO_basictypeCHARACTER:
10162           break;                /* Passed by descriptor anyway. */
10163
10164         default:
10165           item = ffecom_ptr_to_expr (expr);
10166           if (item != error_mark_node)
10167             *length = TYPE_SIZE (TREE_TYPE (TREE_TYPE (item)));
10168           break;
10169         }
10170       break;
10171
10172     default:
10173       break;
10174     }
10175
10176 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10177   if ((ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeHOLLERITH)
10178       && (length != NULL))
10179     {                           /* Pass Hollerith by descriptor. */
10180       ffetargetHollerith h;
10181
10182       assert (ffebld_op (expr) == FFEBLD_opCONTER);
10183       h = ffebld_cu_val_hollerith (ffebld_constant_union
10184                                    (ffebld_conter (expr)));
10185       *length
10186         = build_int_2 (h.length, 0);
10187       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10188     }
10189 #endif
10190
10191   if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10192     return ffecom_ptr_to_expr (expr);
10193
10194   assert (ffeinfo_kindtype (ffebld_info (expr))
10195           == FFEINFO_kindtypeCHARACTER1);
10196
10197   while (ffebld_op (expr) == FFEBLD_opPAREN)
10198     expr = ffebld_left (expr);
10199
10200   catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
10201   switch (ffecom_concat_list_count_ (catlist))
10202     {
10203     case 0:                     /* Shouldn't happen, but in case it does... */
10204       if (length != NULL)
10205         {
10206           *length = ffecom_f2c_ftnlen_zero_node;
10207           TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10208         }
10209       ffecom_concat_list_kill_ (catlist);
10210       return null_pointer_node;
10211
10212     case 1:                     /* The (fairly) easy case. */
10213       if (length == NULL)
10214         ffecom_char_args_with_null_ (&item, &ign_length,
10215                                      ffecom_concat_list_expr_ (catlist, 0));
10216       else
10217         ffecom_char_args_ (&item, length,
10218                            ffecom_concat_list_expr_ (catlist, 0));
10219       ffecom_concat_list_kill_ (catlist);
10220       assert (item != NULL_TREE);
10221       return item;
10222
10223     default:                    /* Must actually concatenate things. */
10224       break;
10225     }
10226
10227   {
10228     int count = ffecom_concat_list_count_ (catlist);
10229     int i;
10230     tree lengths;
10231     tree items;
10232     tree length_array;
10233     tree item_array;
10234     tree citem;
10235     tree clength;
10236     tree temporary;
10237     tree num;
10238     tree known_length;
10239     ffetargetCharacterSize sz;
10240
10241     sz = ffecom_concat_list_maxlen_ (catlist);
10242     /* ~~Kludge! */
10243     assert (sz != FFETARGET_charactersizeNONE);
10244
10245 #ifdef HOHO
10246     length_array
10247       = lengths
10248       = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
10249                              FFETARGET_charactersizeNONE, count, TRUE);
10250     item_array
10251       = items
10252       = ffecom_push_tempvar (ffecom_f2c_address_type_node,
10253                              FFETARGET_charactersizeNONE, count, TRUE);
10254     temporary = ffecom_push_tempvar (char_type_node,
10255                                      sz, -1, TRUE);
10256 #else
10257     {
10258       tree hook;
10259
10260       hook = ffebld_nonter_hook (expr);
10261       assert (hook);
10262       assert (TREE_CODE (hook) == TREE_VEC);
10263       assert (TREE_VEC_LENGTH (hook) == 3);
10264       length_array = lengths = TREE_VEC_ELT (hook, 0);
10265       item_array = items = TREE_VEC_ELT (hook, 1);
10266       temporary = TREE_VEC_ELT (hook, 2);
10267     }
10268 #endif
10269
10270     known_length = ffecom_f2c_ftnlen_zero_node;
10271
10272     for (i = 0; i < count; ++i)
10273       {
10274         if ((i == count)
10275             && (length == NULL))
10276           ffecom_char_args_with_null_ (&citem, &clength,
10277                                        ffecom_concat_list_expr_ (catlist, i));
10278         else
10279           ffecom_char_args_ (&citem, &clength,
10280                              ffecom_concat_list_expr_ (catlist, i));
10281         if ((citem == error_mark_node)
10282             || (clength == error_mark_node))
10283           {
10284             ffecom_concat_list_kill_ (catlist);
10285             *length = error_mark_node;
10286             return error_mark_node;
10287           }
10288
10289         items
10290           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
10291                       ffecom_modify (void_type_node,
10292                                      ffecom_2 (ARRAY_REF,
10293                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
10294                                                item_array,
10295                                                build_int_2 (i, 0)),
10296                                      citem),
10297                       items);
10298         clength = ffecom_save_tree (clength);
10299         if (length != NULL)
10300           known_length
10301             = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
10302                         known_length,
10303                         clength);
10304         lengths
10305           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
10306                       ffecom_modify (void_type_node,
10307                                      ffecom_2 (ARRAY_REF,
10308                    TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
10309                                                length_array,
10310                                                build_int_2 (i, 0)),
10311                                      clength),
10312                       lengths);
10313       }
10314
10315     temporary = ffecom_1 (ADDR_EXPR,
10316                           build_pointer_type (TREE_TYPE (temporary)),
10317                           temporary);
10318
10319     item = build_tree_list (NULL_TREE, temporary);
10320     TREE_CHAIN (item)
10321       = build_tree_list (NULL_TREE,
10322                          ffecom_1 (ADDR_EXPR,
10323                                    build_pointer_type (TREE_TYPE (items)),
10324                                    items));
10325     TREE_CHAIN (TREE_CHAIN (item))
10326       = build_tree_list (NULL_TREE,
10327                          ffecom_1 (ADDR_EXPR,
10328                                    build_pointer_type (TREE_TYPE (lengths)),
10329                                    lengths));
10330     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
10331       = build_tree_list
10332         (NULL_TREE,
10333          ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
10334                    convert (ffecom_f2c_ftnlen_type_node,
10335                             build_int_2 (count, 0))));
10336     num = build_int_2 (sz, 0);
10337     TREE_TYPE (num) = ffecom_f2c_ftnlen_type_node;
10338     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item))))
10339       = build_tree_list (NULL_TREE, num);
10340
10341     item = ffecom_call_gfrt (FFECOM_gfrtCAT, item, NULL_TREE);
10342     TREE_SIDE_EFFECTS (item) = 1;
10343     item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (temporary),
10344                      item,
10345                      temporary);
10346
10347     if (length != NULL)
10348       *length = known_length;
10349   }
10350
10351   ffecom_concat_list_kill_ (catlist);
10352   assert (item != NULL_TREE);
10353   return item;
10354 }
10355
10356 /* Generate call to run-time function.
10357
10358    The first arg is the GNU Fortran Run-Time function index, the second
10359    arg is the list of arguments to pass to it.  Returned is the expression
10360    (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the
10361    result (which may be void).  */
10362
10363 tree
10364 ffecom_call_gfrt (ffecomGfrt ix, tree args, tree hook)
10365 {
10366   return ffecom_call_ (ffecom_gfrt_tree_ (ix),
10367                        ffecom_gfrt_kindtype (ix),
10368                        ffe_is_f2c_library () && ffecom_gfrt_complex_[ix],
10369                        NULL_TREE, args, NULL_TREE, NULL,
10370                        NULL, NULL_TREE, TRUE, hook);
10371 }
10372
10373 /* Transform constant-union to tree.  */
10374
10375 tree
10376 ffecom_constantunion (ffebldConstantUnion *cu, ffeinfoBasictype bt,
10377                       ffeinfoKindtype kt, tree tree_type)
10378 {
10379   tree item;
10380
10381   switch (bt)
10382     {
10383     case FFEINFO_basictypeINTEGER:
10384       {
10385         int val;
10386
10387         switch (kt)
10388           {
10389 #if FFETARGET_okINTEGER1
10390           case FFEINFO_kindtypeINTEGER1:
10391             val = ffebld_cu_val_integer1 (*cu);
10392             break;
10393 #endif
10394
10395 #if FFETARGET_okINTEGER2
10396           case FFEINFO_kindtypeINTEGER2:
10397             val = ffebld_cu_val_integer2 (*cu);
10398             break;
10399 #endif
10400
10401 #if FFETARGET_okINTEGER3
10402           case FFEINFO_kindtypeINTEGER3:
10403             val = ffebld_cu_val_integer3 (*cu);
10404             break;
10405 #endif
10406
10407 #if FFETARGET_okINTEGER4
10408           case FFEINFO_kindtypeINTEGER4:
10409             val = ffebld_cu_val_integer4 (*cu);
10410             break;
10411 #endif
10412
10413           default:
10414             assert ("bad INTEGER constant kind type" == NULL);
10415             /* Fall through. */
10416           case FFEINFO_kindtypeANY:
10417             return error_mark_node;
10418           }
10419         item = build_int_2 (val, (val < 0) ? -1 : 0);
10420         TREE_TYPE (item) = tree_type;
10421       }
10422       break;
10423
10424     case FFEINFO_basictypeLOGICAL:
10425       {
10426         int val;
10427
10428         switch (kt)
10429           {
10430 #if FFETARGET_okLOGICAL1
10431           case FFEINFO_kindtypeLOGICAL1:
10432             val = ffebld_cu_val_logical1 (*cu);
10433             break;
10434 #endif
10435
10436 #if FFETARGET_okLOGICAL2
10437           case FFEINFO_kindtypeLOGICAL2:
10438             val = ffebld_cu_val_logical2 (*cu);
10439             break;
10440 #endif
10441
10442 #if FFETARGET_okLOGICAL3
10443           case FFEINFO_kindtypeLOGICAL3:
10444             val = ffebld_cu_val_logical3 (*cu);
10445             break;
10446 #endif
10447
10448 #if FFETARGET_okLOGICAL4
10449           case FFEINFO_kindtypeLOGICAL4:
10450             val = ffebld_cu_val_logical4 (*cu);
10451             break;
10452 #endif
10453
10454           default:
10455             assert ("bad LOGICAL constant kind type" == NULL);
10456             /* Fall through. */
10457           case FFEINFO_kindtypeANY:
10458             return error_mark_node;
10459           }
10460         item = build_int_2 (val, (val < 0) ? -1 : 0);
10461         TREE_TYPE (item) = tree_type;
10462       }
10463       break;
10464
10465     case FFEINFO_basictypeREAL:
10466       {
10467         REAL_VALUE_TYPE val;
10468
10469         switch (kt)
10470           {
10471 #if FFETARGET_okREAL1
10472           case FFEINFO_kindtypeREAL1:
10473             val = ffetarget_value_real1 (ffebld_cu_val_real1 (*cu));
10474             break;
10475 #endif
10476
10477 #if FFETARGET_okREAL2
10478           case FFEINFO_kindtypeREAL2:
10479             val = ffetarget_value_real2 (ffebld_cu_val_real2 (*cu));
10480             break;
10481 #endif
10482
10483 #if FFETARGET_okREAL3
10484           case FFEINFO_kindtypeREAL3:
10485             val = ffetarget_value_real3 (ffebld_cu_val_real3 (*cu));
10486             break;
10487 #endif
10488
10489 #if FFETARGET_okREAL4
10490           case FFEINFO_kindtypeREAL4:
10491             val = ffetarget_value_real4 (ffebld_cu_val_real4 (*cu));
10492             break;
10493 #endif
10494
10495           default:
10496             assert ("bad REAL constant kind type" == NULL);
10497             /* Fall through. */
10498           case FFEINFO_kindtypeANY:
10499             return error_mark_node;
10500           }
10501         item = build_real (tree_type, val);
10502       }
10503       break;
10504
10505     case FFEINFO_basictypeCOMPLEX:
10506       {
10507         REAL_VALUE_TYPE real;
10508         REAL_VALUE_TYPE imag;
10509         tree el_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
10510
10511         switch (kt)
10512           {
10513 #if FFETARGET_okCOMPLEX1
10514           case FFEINFO_kindtypeREAL1:
10515             real = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).real);
10516             imag = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).imaginary);
10517             break;
10518 #endif
10519
10520 #if FFETARGET_okCOMPLEX2
10521           case FFEINFO_kindtypeREAL2:
10522             real = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).real);
10523             imag = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).imaginary);
10524             break;
10525 #endif
10526
10527 #if FFETARGET_okCOMPLEX3
10528           case FFEINFO_kindtypeREAL3:
10529             real = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).real);
10530             imag = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).imaginary);
10531             break;
10532 #endif
10533
10534 #if FFETARGET_okCOMPLEX4
10535           case FFEINFO_kindtypeREAL4:
10536             real = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).real);
10537             imag = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).imaginary);
10538             break;
10539 #endif
10540
10541           default:
10542             assert ("bad REAL constant kind type" == NULL);
10543             /* Fall through. */
10544           case FFEINFO_kindtypeANY:
10545             return error_mark_node;
10546           }
10547         item = ffecom_build_complex_constant_ (tree_type,
10548                                                build_real (el_type, real),
10549                                                build_real (el_type, imag));
10550       }
10551       break;
10552
10553     case FFEINFO_basictypeCHARACTER:
10554       {                         /* Happens only in DATA and similar contexts. */
10555         ffetargetCharacter1 val;
10556
10557         switch (kt)
10558           {
10559 #if FFETARGET_okCHARACTER1
10560           case FFEINFO_kindtypeLOGICAL1:
10561             val = ffebld_cu_val_character1 (*cu);
10562             break;
10563 #endif
10564
10565           default:
10566             assert ("bad CHARACTER constant kind type" == NULL);
10567             /* Fall through. */
10568           case FFEINFO_kindtypeANY:
10569             return error_mark_node;
10570           }
10571         item = build_string (ffetarget_length_character1 (val),
10572                              ffetarget_text_character1 (val));
10573         TREE_TYPE (item)
10574           = build_type_variant (build_array_type (char_type_node,
10575                                                   build_range_type
10576                                                   (integer_type_node,
10577                                                    integer_one_node,
10578                                                    build_int_2
10579                                                 (ffetarget_length_character1
10580                                                  (val), 0))),
10581                                 1, 0);
10582       }
10583       break;
10584
10585     case FFEINFO_basictypeHOLLERITH:
10586       {
10587         ffetargetHollerith h;
10588
10589         h = ffebld_cu_val_hollerith (*cu);
10590
10591         /* If not at least as wide as default INTEGER, widen it.  */
10592         if (h.length >= FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE)
10593           item = build_string (h.length, h.text);
10594         else
10595           {
10596             char str[FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE];
10597
10598             memcpy (str, h.text, h.length);
10599             memset (&str[h.length], ' ',
10600                     FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE
10601                     - h.length);
10602             item = build_string (FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE,
10603                                  str);
10604           }
10605         TREE_TYPE (item)
10606           = build_type_variant (build_array_type (char_type_node,
10607                                                   build_range_type
10608                                                   (integer_type_node,
10609                                                    integer_one_node,
10610                                                    build_int_2
10611                                                    (h.length, 0))),
10612                                 1, 0);
10613       }
10614       break;
10615
10616     case FFEINFO_basictypeTYPELESS:
10617       {
10618         ffetargetInteger1 ival;
10619         ffetargetTypeless tless;
10620         ffebad error;
10621
10622         tless = ffebld_cu_val_typeless (*cu);
10623         error = ffetarget_convert_integer1_typeless (&ival, tless);
10624         assert (error == FFEBAD);
10625
10626         item = build_int_2 ((int) ival, 0);
10627       }
10628       break;
10629
10630     default:
10631       assert ("not yet on constant type" == NULL);
10632       /* Fall through. */
10633     case FFEINFO_basictypeANY:
10634       return error_mark_node;
10635     }
10636
10637   TREE_CONSTANT (item) = 1;
10638
10639   return item;
10640 }
10641
10642 /* Transform expression into constant tree.
10643
10644    If the expression can be transformed into a tree that is constant,
10645    that is done, and the tree returned.  Else NULL_TREE is returned.
10646
10647    That way, a caller can attempt to provide compile-time initialization
10648    of a variable and, if that fails, *then* choose to start a new block
10649    and resort to using temporaries, as appropriate.  */
10650
10651 tree
10652 ffecom_const_expr (ffebld expr)
10653 {
10654   if (! expr)
10655     return integer_zero_node;
10656
10657   if (ffebld_op (expr) == FFEBLD_opANY)
10658     return error_mark_node;
10659
10660   if (ffebld_arity (expr) == 0
10661       && (ffebld_op (expr) != FFEBLD_opSYMTER
10662 #if NEWCOMMON
10663           /* ~~Enable once common/equivalence is handled properly?  */
10664           || ffebld_where (expr) == FFEINFO_whereCOMMON
10665 #endif
10666           || ffebld_where (expr) == FFEINFO_whereGLOBAL
10667           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10668     {
10669       tree t;
10670
10671       t = ffecom_expr (expr);
10672       assert (TREE_CONSTANT (t));
10673       return t;
10674     }
10675
10676   return NULL_TREE;
10677 }
10678
10679 /* Handy way to make a field in a struct/union.  */
10680
10681 tree
10682 ffecom_decl_field (tree context, tree prevfield,
10683                    const char *name, tree type)
10684 {
10685   tree field;
10686
10687   field = build_decl (FIELD_DECL, get_identifier (name), type);
10688   DECL_CONTEXT (field) = context;
10689   DECL_ALIGN (field) = 0;
10690   DECL_USER_ALIGN (field) = 0;
10691   if (prevfield != NULL_TREE)
10692     TREE_CHAIN (prevfield) = field;
10693
10694   return field;
10695 }
10696
10697 void
10698 ffecom_close_include (FILE *f)
10699 {
10700   ffecom_close_include_ (f);
10701 }
10702
10703 int
10704 ffecom_decode_include_option (char *spec)
10705 {
10706   return ffecom_decode_include_option_ (spec);
10707 }
10708
10709 /* End a compound statement (block).  */
10710
10711 tree
10712 ffecom_end_compstmt (void)
10713 {
10714   return bison_rule_compstmt_ ();
10715 }
10716
10717 /* ffecom_end_transition -- Perform end transition on all symbols
10718
10719    ffecom_end_transition();
10720
10721    Calls ffecom_sym_end_transition for each global and local symbol.  */
10722
10723 void
10724 ffecom_end_transition ()
10725 {
10726   ffebld item;
10727
10728   if (ffe_is_ffedebug ())
10729     fprintf (dmpout, "; end_stmt_transition\n");
10730
10731   ffecom_list_blockdata_ = NULL;
10732   ffecom_list_common_ = NULL;
10733
10734   ffesymbol_drive (ffecom_sym_end_transition);
10735   if (ffe_is_ffedebug ())
10736     {
10737       ffestorag_report ();
10738     }
10739
10740   ffecom_start_progunit_ ();
10741
10742   for (item = ffecom_list_blockdata_;
10743        item != NULL;
10744        item = ffebld_trail (item))
10745     {
10746       ffebld callee;
10747       ffesymbol s;
10748       tree dt;
10749       tree t;
10750       tree var;
10751       static int number = 0;
10752
10753       callee = ffebld_head (item);
10754       s = ffebld_symter (callee);
10755       t = ffesymbol_hook (s).decl_tree;
10756       if (t == NULL_TREE)
10757         {
10758           s = ffecom_sym_transform_ (s);
10759           t = ffesymbol_hook (s).decl_tree;
10760         }
10761
10762       dt = build_pointer_type (TREE_TYPE (t));
10763
10764       var = build_decl (VAR_DECL,
10765                         ffecom_get_invented_identifier ("__g77_forceload_%d",
10766                                                         number++),
10767                         dt);
10768       DECL_EXTERNAL (var) = 0;
10769       TREE_STATIC (var) = 1;
10770       TREE_PUBLIC (var) = 0;
10771       DECL_INITIAL (var) = error_mark_node;
10772       TREE_USED (var) = 1;
10773
10774       var = start_decl (var, FALSE);
10775
10776       t = ffecom_1 (ADDR_EXPR, dt, t);
10777
10778       finish_decl (var, t, FALSE);
10779     }
10780
10781   /* This handles any COMMON areas that weren't referenced but have, for
10782      example, important initial data.  */
10783
10784   for (item = ffecom_list_common_;
10785        item != NULL;
10786        item = ffebld_trail (item))
10787     ffecom_transform_common_ (ffebld_symter (ffebld_head (item)));
10788
10789   ffecom_list_common_ = NULL;
10790 }
10791
10792 /* ffecom_exec_transition -- Perform exec transition on all symbols
10793
10794    ffecom_exec_transition();
10795
10796    Calls ffecom_sym_exec_transition for each global and local symbol.
10797    Make sure error updating not inhibited.  */
10798
10799 void
10800 ffecom_exec_transition ()
10801 {
10802   bool inhibited;
10803
10804   if (ffe_is_ffedebug ())
10805     fprintf (dmpout, "; exec_stmt_transition\n");
10806
10807   inhibited = ffebad_inhibit ();
10808   ffebad_set_inhibit (FALSE);
10809
10810   ffesymbol_drive (ffecom_sym_exec_transition); /* Don't retract! */
10811   ffeequiv_exec_transition ();  /* Handle all pending EQUIVALENCEs. */
10812   if (ffe_is_ffedebug ())
10813     {
10814       ffestorag_report ();
10815     }
10816
10817   if (inhibited)
10818     ffebad_set_inhibit (TRUE);
10819 }
10820
10821 /* Handle assignment statement.
10822
10823    Convert dest and source using ffecom_expr, then join them
10824    with an ASSIGN op and pass the whole thing to expand_expr_stmt.  */
10825
10826 void
10827 ffecom_expand_let_stmt (ffebld dest, ffebld source)
10828 {
10829   tree dest_tree;
10830   tree dest_length;
10831   tree source_tree;
10832   tree expr_tree;
10833
10834   if (ffeinfo_basictype (ffebld_info (dest)) != FFEINFO_basictypeCHARACTER)
10835     {
10836       bool dest_used;
10837       tree assign_temp;
10838
10839       /* This attempts to replicate the test below, but must not be
10840          true when the test below is false.  (Always err on the side
10841          of creating unused temporaries, to avoid ICEs.)  */
10842       if (ffebld_op (dest) != FFEBLD_opSYMTER
10843           || ((dest_tree = ffesymbol_hook (ffebld_symter (dest)).decl_tree)
10844               && (TREE_CODE (dest_tree) != VAR_DECL
10845                   || TREE_ADDRESSABLE (dest_tree))))
10846         {
10847           ffecom_prepare_expr_ (source, dest);
10848           dest_used = TRUE;
10849         }
10850       else
10851         {
10852           ffecom_prepare_expr_ (source, NULL);
10853           dest_used = FALSE;
10854         }
10855
10856       ffecom_prepare_expr_w (NULL_TREE, dest);
10857
10858       /* For COMPLEX assignment like C1=C2, if partial overlap is possible,
10859          create a temporary through which the assignment is to take place,
10860          since MODIFY_EXPR doesn't handle partial overlap properly.  */
10861       if (ffebld_basictype (dest) == FFEINFO_basictypeCOMPLEX
10862           && ffecom_possible_partial_overlap_ (dest, source))
10863         {
10864           assign_temp = ffecom_make_tempvar ("complex_let",
10865                                              ffecom_tree_type
10866                                              [ffebld_basictype (dest)]
10867                                              [ffebld_kindtype (dest)],
10868                                              FFETARGET_charactersizeNONE,
10869                                              -1);
10870         }
10871       else
10872         assign_temp = NULL_TREE;
10873
10874       ffecom_prepare_end ();
10875
10876       dest_tree = ffecom_expr_w (NULL_TREE, dest);
10877       if (dest_tree == error_mark_node)
10878         return;
10879
10880       if ((TREE_CODE (dest_tree) != VAR_DECL)
10881           || TREE_ADDRESSABLE (dest_tree))
10882         source_tree = ffecom_expr_ (source, dest_tree, dest, &dest_used,
10883                                     FALSE, FALSE);
10884       else
10885         {
10886           assert (! dest_used);
10887           dest_used = FALSE;
10888           source_tree = ffecom_expr (source);
10889         }
10890       if (source_tree == error_mark_node)
10891         return;
10892
10893       if (dest_used)
10894         expr_tree = source_tree;
10895       else if (assign_temp)
10896         {
10897 #ifdef MOVE_EXPR
10898           /* The back end understands a conceptual move (evaluate source;
10899              store into dest), so use that, in case it can determine
10900              that it is going to use, say, two registers as temporaries
10901              anyway.  So don't use the temp (and someday avoid generating
10902              it, once this code starts triggering regularly).  */
10903           expr_tree = ffecom_2s (MOVE_EXPR, void_type_node,
10904                                  dest_tree,
10905                                  source_tree);
10906 #else
10907           expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
10908                                  assign_temp,
10909                                  source_tree);
10910           expand_expr_stmt (expr_tree);
10911           expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
10912                                  dest_tree,
10913                                  assign_temp);
10914 #endif
10915         }
10916       else
10917         expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
10918                                dest_tree,
10919                                source_tree);
10920
10921       expand_expr_stmt (expr_tree);
10922       return;
10923     }
10924
10925   ffecom_prepare_let_char_ (ffebld_size_known (dest), source);
10926   ffecom_prepare_expr_w (NULL_TREE, dest);
10927
10928   ffecom_prepare_end ();
10929
10930   ffecom_char_args_ (&dest_tree, &dest_length, dest);
10931   ffecom_let_char_ (dest_tree, dest_length, ffebld_size_known (dest),
10932                     source);
10933 }
10934
10935 /* ffecom_expr -- Transform expr into gcc tree
10936
10937    tree t;
10938    ffebld expr;  // FFE expression.
10939    tree = ffecom_expr(expr);
10940
10941    Recursive descent on expr while making corresponding tree nodes and
10942    attaching type info and such.  */
10943
10944 tree
10945 ffecom_expr (ffebld expr)
10946 {
10947   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, FALSE, FALSE);
10948 }
10949
10950 /* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT.  */
10951
10952 tree
10953 ffecom_expr_assign (ffebld expr)
10954 {
10955   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
10956 }
10957
10958 /* Like ffecom_expr_rw, but return tree usable for ASSIGN.  */
10959
10960 tree
10961 ffecom_expr_assign_w (ffebld expr)
10962 {
10963   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
10964 }
10965
10966 /* Transform expr for use as into read/write tree and stabilize the
10967    reference.  Not for use on CHARACTER expressions.
10968
10969    Recursive descent on expr while making corresponding tree nodes and
10970    attaching type info and such.  */
10971
10972 tree
10973 ffecom_expr_rw (tree type, ffebld expr)
10974 {
10975   assert (expr != NULL);
10976   /* Different target types not yet supported.  */
10977   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
10978
10979   return stabilize_reference (ffecom_expr (expr));
10980 }
10981
10982 /* Transform expr for use as into 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_w (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 /* Do global stuff.  */
10999
11000 void
11001 ffecom_finish_compile ()
11002 {
11003   assert (ffecom_outer_function_decl_ == NULL_TREE);
11004   assert (current_function_decl == NULL_TREE);
11005
11006   ffeglobal_drive (ffecom_finish_global_);
11007 }
11008
11009 /* Public entry point for front end to access finish_decl.  */
11010
11011 void
11012 ffecom_finish_decl (tree decl, tree init, bool is_top_level)
11013 {
11014   assert (!is_top_level);
11015   finish_decl (decl, init, FALSE);
11016 }
11017
11018 /* Finish a program unit.  */
11019
11020 void
11021 ffecom_finish_progunit ()
11022 {
11023   ffecom_end_compstmt ();
11024
11025   ffecom_previous_function_decl_ = current_function_decl;
11026   ffecom_which_entrypoint_decl_ = NULL_TREE;
11027
11028   finish_function (0);
11029 }
11030
11031 /* Wrapper for get_identifier.  pattern is sprintf-like.  */
11032
11033 tree
11034 ffecom_get_invented_identifier (const char *pattern, ...)
11035 {
11036   tree decl;
11037   char *nam;
11038   va_list ap;
11039
11040   va_start (ap, pattern);
11041   if (vasprintf (&nam, pattern, ap) == 0)
11042     abort ();
11043   va_end (ap);
11044   decl = get_identifier (nam);
11045   free (nam);
11046   IDENTIFIER_INVENTED (decl) = 1;
11047   return decl;
11048 }
11049
11050 ffeinfoBasictype
11051 ffecom_gfrt_basictype (ffecomGfrt gfrt)
11052 {
11053   assert (gfrt < FFECOM_gfrt);
11054
11055   switch (ffecom_gfrt_type_[gfrt])
11056     {
11057     case FFECOM_rttypeVOID_:
11058     case FFECOM_rttypeVOIDSTAR_:
11059       return FFEINFO_basictypeNONE;
11060
11061     case FFECOM_rttypeFTNINT_:
11062       return FFEINFO_basictypeINTEGER;
11063
11064     case FFECOM_rttypeINTEGER_:
11065       return FFEINFO_basictypeINTEGER;
11066
11067     case FFECOM_rttypeLONGINT_:
11068       return FFEINFO_basictypeINTEGER;
11069
11070     case FFECOM_rttypeLOGICAL_:
11071       return FFEINFO_basictypeLOGICAL;
11072
11073     case FFECOM_rttypeREAL_F2C_:
11074     case FFECOM_rttypeREAL_GNU_:
11075       return FFEINFO_basictypeREAL;
11076
11077     case FFECOM_rttypeCOMPLEX_F2C_:
11078     case FFECOM_rttypeCOMPLEX_GNU_:
11079       return FFEINFO_basictypeCOMPLEX;
11080
11081     case FFECOM_rttypeDOUBLE_:
11082     case FFECOM_rttypeDOUBLEREAL_:
11083       return FFEINFO_basictypeREAL;
11084
11085     case FFECOM_rttypeDBLCMPLX_F2C_:
11086     case FFECOM_rttypeDBLCMPLX_GNU_:
11087       return FFEINFO_basictypeCOMPLEX;
11088
11089     case FFECOM_rttypeCHARACTER_:
11090       return FFEINFO_basictypeCHARACTER;
11091
11092     default:
11093       return FFEINFO_basictypeANY;
11094     }
11095 }
11096
11097 ffeinfoKindtype
11098 ffecom_gfrt_kindtype (ffecomGfrt gfrt)
11099 {
11100   assert (gfrt < FFECOM_gfrt);
11101
11102   switch (ffecom_gfrt_type_[gfrt])
11103     {
11104     case FFECOM_rttypeVOID_:
11105     case FFECOM_rttypeVOIDSTAR_:
11106       return FFEINFO_kindtypeNONE;
11107
11108     case FFECOM_rttypeFTNINT_:
11109       return FFEINFO_kindtypeINTEGER1;
11110
11111     case FFECOM_rttypeINTEGER_:
11112       return FFEINFO_kindtypeINTEGER1;
11113
11114     case FFECOM_rttypeLONGINT_:
11115       return FFEINFO_kindtypeINTEGER4;
11116
11117     case FFECOM_rttypeLOGICAL_:
11118       return FFEINFO_kindtypeLOGICAL1;
11119
11120     case FFECOM_rttypeREAL_F2C_:
11121     case FFECOM_rttypeREAL_GNU_:
11122       return FFEINFO_kindtypeREAL1;
11123
11124     case FFECOM_rttypeCOMPLEX_F2C_:
11125     case FFECOM_rttypeCOMPLEX_GNU_:
11126       return FFEINFO_kindtypeREAL1;
11127
11128     case FFECOM_rttypeDOUBLE_:
11129     case FFECOM_rttypeDOUBLEREAL_:
11130       return FFEINFO_kindtypeREAL2;
11131
11132     case FFECOM_rttypeDBLCMPLX_F2C_:
11133     case FFECOM_rttypeDBLCMPLX_GNU_:
11134       return FFEINFO_kindtypeREAL2;
11135
11136     case FFECOM_rttypeCHARACTER_:
11137       return FFEINFO_kindtypeCHARACTER1;
11138
11139     default:
11140       return FFEINFO_kindtypeANY;
11141     }
11142 }
11143
11144 void
11145 ffecom_init_0 ()
11146 {
11147   tree endlink;
11148   int i;
11149   int j;
11150   tree t;
11151   tree field;
11152   ffetype type;
11153   ffetype base_type;
11154   tree double_ftype_double;
11155   tree float_ftype_float;
11156   tree ldouble_ftype_ldouble;
11157   tree ffecom_tree_ptr_to_fun_type_void;
11158
11159   /* This block of code comes from the now-obsolete cktyps.c.  It checks
11160      whether the compiler environment is buggy in known ways, some of which
11161      would, if not explicitly checked here, result in subtle bugs in g77.  */
11162
11163   if (ffe_is_do_internal_checks ())
11164     {
11165       static const char names[][12]
11166         =
11167       {"bar", "bletch", "foo", "foobar"};
11168       const char *name;
11169       unsigned long ul;
11170       double fl;
11171
11172       name = bsearch ("foo", &names[0], ARRAY_SIZE (names), sizeof (names[0]),
11173                       (int (*)(const void *, const void *)) strcmp);
11174       if (name != &names[0][2])
11175         {
11176           assert ("bsearch doesn't work, #define FFEPROJ_BSEARCH 0 in proj.h"
11177                   == NULL);
11178           abort ();
11179         }
11180
11181       ul = strtoul ("123456789", NULL, 10);
11182       if (ul != 123456789L)
11183         {
11184           assert ("strtoul doesn't have enough range, #define FFEPROJ_STRTOUL 0\
11185  in proj.h" == NULL);
11186           abort ();
11187         }
11188
11189       fl = atof ("56.789");
11190       if ((fl < 56.788) || (fl > 56.79))
11191         {
11192           assert ("atof not type double, fix your #include <stdio.h>"
11193                   == NULL);
11194           abort ();
11195         }
11196     }
11197
11198   ffecom_initialize_char_syntax_ ();
11199
11200   ffecom_outer_function_decl_ = NULL_TREE;
11201   current_function_decl = NULL_TREE;
11202   named_labels = NULL_TREE;
11203   current_binding_level = NULL_BINDING_LEVEL;
11204   free_binding_level = NULL_BINDING_LEVEL;
11205   /* Make the binding_level structure for global names.  */
11206   pushlevel (0);
11207   global_binding_level = current_binding_level;
11208   current_binding_level->prep_state = 2;
11209
11210   build_common_tree_nodes (1);
11211
11212   /* Define `int' and `char' first so that dbx will output them first.  */
11213   pushdecl (build_decl (TYPE_DECL, get_identifier ("int"),
11214                         integer_type_node));
11215   /* CHARACTER*1 is unsigned in ICHAR contexts.  */
11216   char_type_node = make_unsigned_type (CHAR_TYPE_SIZE);
11217   pushdecl (build_decl (TYPE_DECL, get_identifier ("char"),
11218                         char_type_node));
11219   pushdecl (build_decl (TYPE_DECL, get_identifier ("long int"),
11220                         long_integer_type_node));
11221   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned int"),
11222                         unsigned_type_node));
11223   pushdecl (build_decl (TYPE_DECL, get_identifier ("long unsigned int"),
11224                         long_unsigned_type_node));
11225   pushdecl (build_decl (TYPE_DECL, get_identifier ("long long int"),
11226                         long_long_integer_type_node));
11227   pushdecl (build_decl (TYPE_DECL, get_identifier ("long long unsigned int"),
11228                         long_long_unsigned_type_node));
11229   pushdecl (build_decl (TYPE_DECL, get_identifier ("short int"),
11230                         short_integer_type_node));
11231   pushdecl (build_decl (TYPE_DECL, get_identifier ("short unsigned int"),
11232                         short_unsigned_type_node));
11233
11234   /* Set the sizetype before we make other types.  This *should* be the
11235      first type we create.  */
11236
11237   set_sizetype
11238     (TREE_TYPE (IDENTIFIER_GLOBAL_VALUE (get_identifier (SIZE_TYPE))));
11239   ffecom_typesize_pointer_
11240     = TREE_INT_CST_LOW (TYPE_SIZE (sizetype)) / BITS_PER_UNIT;
11241
11242   build_common_tree_nodes_2 (0);
11243
11244   /* Define both `signed char' and `unsigned char'.  */
11245   pushdecl (build_decl (TYPE_DECL, get_identifier ("signed char"),
11246                         signed_char_type_node));
11247
11248   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned char"),
11249                         unsigned_char_type_node));
11250
11251   pushdecl (build_decl (TYPE_DECL, get_identifier ("float"),
11252                         float_type_node));
11253   pushdecl (build_decl (TYPE_DECL, get_identifier ("double"),
11254                         double_type_node));
11255   pushdecl (build_decl (TYPE_DECL, get_identifier ("long double"),
11256                         long_double_type_node));
11257
11258   /* For now, override what build_common_tree_nodes has done.  */
11259   complex_integer_type_node = ffecom_make_complex_type_ (integer_type_node);
11260   complex_float_type_node = ffecom_make_complex_type_ (float_type_node);
11261   complex_double_type_node = ffecom_make_complex_type_ (double_type_node);
11262   complex_long_double_type_node
11263     = ffecom_make_complex_type_ (long_double_type_node);
11264
11265   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex int"),
11266                         complex_integer_type_node));
11267   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex float"),
11268                         complex_float_type_node));
11269   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex double"),
11270                         complex_double_type_node));
11271   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex long double"),
11272                         complex_long_double_type_node));
11273
11274   pushdecl (build_decl (TYPE_DECL, get_identifier ("void"),
11275                         void_type_node));
11276   /* We are not going to have real types in C with less than byte alignment,
11277      so we might as well not have any types that claim to have it.  */
11278   TYPE_ALIGN (void_type_node) = BITS_PER_UNIT;
11279   TYPE_USER_ALIGN (void_type_node) = 0;
11280
11281   string_type_node = build_pointer_type (char_type_node);
11282
11283   ffecom_tree_fun_type_void
11284     = build_function_type (void_type_node, NULL_TREE);
11285
11286   ffecom_tree_ptr_to_fun_type_void
11287     = build_pointer_type (ffecom_tree_fun_type_void);
11288
11289   endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE);
11290
11291   float_ftype_float
11292     = build_function_type (float_type_node,
11293                            tree_cons (NULL_TREE, float_type_node, endlink));
11294
11295   double_ftype_double
11296     = build_function_type (double_type_node,
11297                            tree_cons (NULL_TREE, double_type_node, endlink));
11298
11299   ldouble_ftype_ldouble
11300     = build_function_type (long_double_type_node,
11301                            tree_cons (NULL_TREE, long_double_type_node,
11302                                       endlink));
11303
11304   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11305     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11306       {
11307         ffecom_tree_type[i][j] = NULL_TREE;
11308         ffecom_tree_fun_type[i][j] = NULL_TREE;
11309         ffecom_tree_ptr_to_fun_type[i][j] = NULL_TREE;
11310         ffecom_f2c_typecode_[i][j] = -1;
11311       }
11312
11313   /* Set up standard g77 types.  Note that INTEGER and LOGICAL are set
11314      to size FLOAT_TYPE_SIZE because they have to be the same size as
11315      REAL, which also is FLOAT_TYPE_SIZE, according to the standard.
11316      Compiler options and other such stuff that change the ways these
11317      types are set should not affect this particular setup.  */
11318
11319   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1]
11320     = t = make_signed_type (FLOAT_TYPE_SIZE);
11321   pushdecl (build_decl (TYPE_DECL, get_identifier ("integer"),
11322                         t));
11323   type = ffetype_new ();
11324   base_type = type;
11325   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER1,
11326                     type);
11327   ffetype_set_ams (type,
11328                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11329                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11330   ffetype_set_star (base_type,
11331                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11332                     type);
11333   ffetype_set_kind (base_type, 1, type);
11334   ffecom_typesize_integer1_ = ffetype_size (type);
11335   assert (ffetype_size (type) == sizeof (ffetargetInteger1));
11336
11337   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER1]
11338     = t = make_unsigned_type (FLOAT_TYPE_SIZE); /* HOLLERITH means unsigned. */
11339   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned"),
11340                         t));
11341
11342   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER2]
11343     = t = make_signed_type (CHAR_TYPE_SIZE);
11344   pushdecl (build_decl (TYPE_DECL, get_identifier ("byte"),
11345                         t));
11346   type = ffetype_new ();
11347   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER2,
11348                     type);
11349   ffetype_set_ams (type,
11350                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11351                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11352   ffetype_set_star (base_type,
11353                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11354                     type);
11355   ffetype_set_kind (base_type, 3, type);
11356   assert (ffetype_size (type) == sizeof (ffetargetInteger2));
11357
11358   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER2]
11359     = t = make_unsigned_type (CHAR_TYPE_SIZE);
11360   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned byte"),
11361                         t));
11362
11363   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER3]
11364     = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11365   pushdecl (build_decl (TYPE_DECL, get_identifier ("word"),
11366                         t));
11367   type = ffetype_new ();
11368   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER3,
11369                     type);
11370   ffetype_set_ams (type,
11371                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11372                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11373   ffetype_set_star (base_type,
11374                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11375                     type);
11376   ffetype_set_kind (base_type, 6, type);
11377   assert (ffetype_size (type) == sizeof (ffetargetInteger3));
11378
11379   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER3]
11380     = t = make_unsigned_type (CHAR_TYPE_SIZE * 2);
11381   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned word"),
11382                         t));
11383
11384   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER4]
11385     = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11386   pushdecl (build_decl (TYPE_DECL, get_identifier ("integer4"),
11387                         t));
11388   type = ffetype_new ();
11389   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER4,
11390                     type);
11391   ffetype_set_ams (type,
11392                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11393                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11394   ffetype_set_star (base_type,
11395                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11396                     type);
11397   ffetype_set_kind (base_type, 2, type);
11398   assert (ffetype_size (type) == sizeof (ffetargetInteger4));
11399
11400   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER4]
11401     = t = make_unsigned_type (FLOAT_TYPE_SIZE * 2);
11402   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned4"),
11403                         t));
11404
11405 #if 0
11406   if (ffe_is_do_internal_checks ()
11407       && LONG_TYPE_SIZE != FLOAT_TYPE_SIZE
11408       && LONG_TYPE_SIZE != CHAR_TYPE_SIZE
11409       && LONG_TYPE_SIZE != SHORT_TYPE_SIZE
11410       && LONG_TYPE_SIZE != LONG_LONG_TYPE_SIZE)
11411     {
11412       fprintf (stderr, "Sorry, no g77 support for LONG_TYPE_SIZE (%d bits) yet.\n",
11413                LONG_TYPE_SIZE);
11414     }
11415 #endif
11416
11417   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL1]
11418     = t = make_signed_type (FLOAT_TYPE_SIZE);
11419   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical"),
11420                         t));
11421   type = ffetype_new ();
11422   base_type = type;
11423   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL1,
11424                     type);
11425   ffetype_set_ams (type,
11426                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11427                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11428   ffetype_set_star (base_type,
11429                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11430                     type);
11431   ffetype_set_kind (base_type, 1, type);
11432   assert (ffetype_size (type) == sizeof (ffetargetLogical1));
11433
11434   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL2]
11435     = t = make_signed_type (CHAR_TYPE_SIZE);
11436   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical2"),
11437                         t));
11438   type = ffetype_new ();
11439   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL2,
11440                     type);
11441   ffetype_set_ams (type,
11442                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11443                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11444   ffetype_set_star (base_type,
11445                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11446                     type);
11447   ffetype_set_kind (base_type, 3, type);
11448   assert (ffetype_size (type) == sizeof (ffetargetLogical2));
11449
11450   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL3]
11451     = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11452   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical3"),
11453                         t));
11454   type = ffetype_new ();
11455   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL3,
11456                     type);
11457   ffetype_set_ams (type,
11458                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11459                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11460   ffetype_set_star (base_type,
11461                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11462                     type);
11463   ffetype_set_kind (base_type, 6, type);
11464   assert (ffetype_size (type) == sizeof (ffetargetLogical3));
11465
11466   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL4]
11467     = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11468   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical4"),
11469                         t));
11470   type = ffetype_new ();
11471   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL4,
11472                     type);
11473   ffetype_set_ams (type,
11474                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11475                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11476   ffetype_set_star (base_type,
11477                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11478                     type);
11479   ffetype_set_kind (base_type, 2, type);
11480   assert (ffetype_size (type) == sizeof (ffetargetLogical4));
11481
11482   ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11483     = t = make_node (REAL_TYPE);
11484   TYPE_PRECISION (t) = FLOAT_TYPE_SIZE;
11485   pushdecl (build_decl (TYPE_DECL, get_identifier ("real"),
11486                         t));
11487   layout_type (t);
11488   type = ffetype_new ();
11489   base_type = type;
11490   ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL1,
11491                     type);
11492   ffetype_set_ams (type,
11493                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11494                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11495   ffetype_set_star (base_type,
11496                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11497                     type);
11498   ffetype_set_kind (base_type, 1, type);
11499   ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11500     = FFETARGET_f2cTYREAL;
11501   assert (ffetype_size (type) == sizeof (ffetargetReal1));
11502
11503   ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREALDOUBLE]
11504     = t = make_node (REAL_TYPE);
11505   TYPE_PRECISION (t) = FLOAT_TYPE_SIZE * 2;     /* Always twice REAL. */
11506   pushdecl (build_decl (TYPE_DECL, get_identifier ("double precision"),
11507                         t));
11508   layout_type (t);
11509   type = ffetype_new ();
11510   ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE,
11511                     type);
11512   ffetype_set_ams (type,
11513                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11514                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11515   ffetype_set_star (base_type,
11516                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11517                     type);
11518   ffetype_set_kind (base_type, 2, type);
11519   ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]
11520     = FFETARGET_f2cTYDREAL;
11521   assert (ffetype_size (type) == sizeof (ffetargetReal2));
11522
11523   ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11524     = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]);
11525   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex"),
11526                         t));
11527   type = ffetype_new ();
11528   base_type = type;
11529   ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL1,
11530                     type);
11531   ffetype_set_ams (type,
11532                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11533                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11534   ffetype_set_star (base_type,
11535                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11536                     type);
11537   ffetype_set_kind (base_type, 1, type);
11538   ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11539     = FFETARGET_f2cTYCOMPLEX;
11540   assert (ffetype_size (type) == sizeof (ffetargetComplex1));
11541
11542   ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREALDOUBLE]
11543     = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]);
11544   pushdecl (build_decl (TYPE_DECL, get_identifier ("double complex"),
11545                         t));
11546   type = ffetype_new ();
11547   ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREALDOUBLE,
11548                     type);
11549   ffetype_set_ams (type,
11550                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11551                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11552   ffetype_set_star (base_type,
11553                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11554                     type);
11555   ffetype_set_kind (base_type, 2,
11556                     type);
11557   ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL2]
11558     = FFETARGET_f2cTYDCOMPLEX;
11559   assert (ffetype_size (type) == sizeof (ffetargetComplex2));
11560
11561   /* Make function and ptr-to-function types for non-CHARACTER types. */
11562
11563   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11564     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11565       {
11566         if ((t = ffecom_tree_type[i][j]) != NULL_TREE)
11567           {
11568             if (i == FFEINFO_basictypeINTEGER)
11569               {
11570                 /* Figure out the smallest INTEGER type that can hold
11571                    a pointer on this machine. */
11572                 if (GET_MODE_SIZE (TYPE_MODE (t))
11573                     >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
11574                   {
11575                     if ((ffecom_pointer_kind_ == FFEINFO_kindtypeNONE)
11576                         || (GET_MODE_SIZE (TYPE_MODE (ffecom_tree_type[i][ffecom_pointer_kind_]))
11577                             > GET_MODE_SIZE (TYPE_MODE (t))))
11578                       ffecom_pointer_kind_ = j;
11579                   }
11580               }
11581             else if (i == FFEINFO_basictypeCOMPLEX)
11582               t = void_type_node;
11583             /* For f2c compatibility, REAL functions are really
11584                implemented as DOUBLE PRECISION.  */
11585             else if ((i == FFEINFO_basictypeREAL)
11586                      && (j == FFEINFO_kindtypeREAL1))
11587               t = ffecom_tree_type
11588                 [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2];
11589
11590             t = ffecom_tree_fun_type[i][j] = build_function_type (t,
11591                                                                   NULL_TREE);
11592             ffecom_tree_ptr_to_fun_type[i][j] = build_pointer_type (t);
11593           }
11594       }
11595
11596   /* Set up pointer types.  */
11597
11598   if (ffecom_pointer_kind_ == FFEINFO_basictypeNONE)
11599     fatal_error ("no INTEGER type can hold a pointer on this configuration");
11600   else if (0 && ffe_is_do_internal_checks ())
11601     fprintf (stderr, "Pointer type kt=%d\n", ffecom_pointer_kind_);
11602   ffetype_set_kind (ffeinfo_type (FFEINFO_basictypeINTEGER,
11603                                   FFEINFO_kindtypeINTEGERDEFAULT),
11604                     7,
11605                     ffeinfo_type (FFEINFO_basictypeINTEGER,
11606                                   ffecom_pointer_kind_));
11607
11608   if (ffe_is_ugly_assign ())
11609     ffecom_label_kind_ = ffecom_pointer_kind_;  /* Require ASSIGN etc to this. */
11610   else
11611     ffecom_label_kind_ = FFEINFO_kindtypeINTEGERDEFAULT;
11612   if (0 && ffe_is_do_internal_checks ())
11613     fprintf (stderr, "Label type kt=%d\n", ffecom_label_kind_);
11614
11615   ffecom_integer_type_node
11616     = ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1];
11617   ffecom_integer_zero_node = convert (ffecom_integer_type_node,
11618                                       integer_zero_node);
11619   ffecom_integer_one_node = convert (ffecom_integer_type_node,
11620                                      integer_one_node);
11621
11622   /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional.
11623      Turns out that by TYLONG, runtime/libI77/lio.h really means
11624      "whatever size an ftnint is".  For consistency and sanity,
11625      com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen
11626      all are INTEGER, which we also make out of whatever back-end
11627      integer type is FLOAT_TYPE_SIZE bits wide.  This change, from
11628      LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to
11629      accommodate machines like the Alpha.  Note that this suggests
11630      f2c and libf2c are missing a distinction perhaps needed on
11631      some machines between "int" and "long int".  -- burley 0.5.5 950215 */
11632
11633   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, FLOAT_TYPE_SIZE,
11634                             FFETARGET_f2cTYLONG);
11635   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, SHORT_TYPE_SIZE,
11636                             FFETARGET_f2cTYSHORT);
11637   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, CHAR_TYPE_SIZE,
11638                             FFETARGET_f2cTYINT1);
11639   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, LONG_LONG_TYPE_SIZE,
11640                             FFETARGET_f2cTYQUAD);
11641   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, FLOAT_TYPE_SIZE,
11642                             FFETARGET_f2cTYLOGICAL);
11643   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, SHORT_TYPE_SIZE,
11644                             FFETARGET_f2cTYLOGICAL2);
11645   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, CHAR_TYPE_SIZE,
11646                             FFETARGET_f2cTYLOGICAL1);
11647   /* ~~~Not really such a type in libf2c, e.g. I/O support?  */
11648   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, LONG_LONG_TYPE_SIZE,
11649                             FFETARGET_f2cTYQUAD);
11650
11651   /* CHARACTER stuff is all special-cased, so it is not handled in the above
11652      loop.  CHARACTER items are built as arrays of unsigned char.  */
11653
11654   ffecom_tree_type[FFEINFO_basictypeCHARACTER]
11655     [FFEINFO_kindtypeCHARACTER1] = t = char_type_node;
11656   type = ffetype_new ();
11657   base_type = type;
11658   ffeinfo_set_type (FFEINFO_basictypeCHARACTER,
11659                     FFEINFO_kindtypeCHARACTER1,
11660                     type);
11661   ffetype_set_ams (type,
11662                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11663                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11664   ffetype_set_kind (base_type, 1, type);
11665   assert (ffetype_size (type)
11666           == sizeof (((ffetargetCharacter1) { 0, NULL }).text[0]));
11667
11668   ffecom_tree_fun_type[FFEINFO_basictypeCHARACTER]
11669     [FFEINFO_kindtypeCHARACTER1] = ffecom_tree_fun_type_void;
11670   ffecom_tree_ptr_to_fun_type[FFEINFO_basictypeCHARACTER]
11671     [FFEINFO_kindtypeCHARACTER1]
11672     = ffecom_tree_ptr_to_fun_type_void;
11673   ffecom_f2c_typecode_[FFEINFO_basictypeCHARACTER][FFEINFO_kindtypeCHARACTER1]
11674     = FFETARGET_f2cTYCHAR;
11675
11676   ffecom_f2c_typecode_[FFEINFO_basictypeANY][FFEINFO_kindtypeANY]
11677     = 0;
11678
11679   /* Make multi-return-value type and fields. */
11680
11681   ffecom_multi_type_node_ = make_node (UNION_TYPE);
11682
11683   field = NULL_TREE;
11684
11685   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11686     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11687       {
11688         char name[30];
11689
11690         if (ffecom_tree_type[i][j] == NULL_TREE)
11691           continue;             /* Not supported. */
11692         sprintf (&name[0], "bt_%s_kt_%s",
11693                  ffeinfo_basictype_string ((ffeinfoBasictype) i),
11694                  ffeinfo_kindtype_string ((ffeinfoKindtype) j));
11695         ffecom_multi_fields_[i][j] = build_decl (FIELD_DECL,
11696                                                  get_identifier (name),
11697                                                  ffecom_tree_type[i][j]);
11698         DECL_CONTEXT (ffecom_multi_fields_[i][j])
11699           = ffecom_multi_type_node_;
11700         DECL_ALIGN (ffecom_multi_fields_[i][j]) = 0;
11701         DECL_USER_ALIGN (ffecom_multi_fields_[i][j]) = 0;
11702         TREE_CHAIN (ffecom_multi_fields_[i][j]) = field;
11703         field = ffecom_multi_fields_[i][j];
11704       }
11705
11706   TYPE_FIELDS (ffecom_multi_type_node_) = field;
11707   layout_type (ffecom_multi_type_node_);
11708
11709   /* Subroutines usually return integer because they might have alternate
11710      returns. */
11711
11712   ffecom_tree_subr_type
11713     = build_function_type (integer_type_node, NULL_TREE);
11714   ffecom_tree_ptr_to_subr_type
11715     = build_pointer_type (ffecom_tree_subr_type);
11716   ffecom_tree_blockdata_type
11717     = build_function_type (void_type_node, NULL_TREE);
11718
11719   builtin_function ("__builtin_sqrtf", float_ftype_float,
11720                     BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrtf");
11721   builtin_function ("__builtin_fsqrt", double_ftype_double,
11722                     BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrt");
11723   builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble,
11724                     BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrtl");
11725   builtin_function ("__builtin_sinf", float_ftype_float,
11726                     BUILT_IN_SIN, BUILT_IN_NORMAL, "sinf");
11727   builtin_function ("__builtin_sin", double_ftype_double,
11728                     BUILT_IN_SIN, BUILT_IN_NORMAL, "sin");
11729   builtin_function ("__builtin_sinl", ldouble_ftype_ldouble,
11730                     BUILT_IN_SIN, BUILT_IN_NORMAL, "sinl");
11731   builtin_function ("__builtin_cosf", float_ftype_float,
11732                     BUILT_IN_COS, BUILT_IN_NORMAL, "cosf");
11733   builtin_function ("__builtin_cos", double_ftype_double,
11734                     BUILT_IN_COS, BUILT_IN_NORMAL, "cos");
11735   builtin_function ("__builtin_cosl", ldouble_ftype_ldouble,
11736                     BUILT_IN_COS, BUILT_IN_NORMAL, "cosl");
11737
11738   pedantic_lvalues = FALSE;
11739
11740   ffecom_f2c_make_type_ (&ffecom_f2c_integer_type_node,
11741                          FFECOM_f2cINTEGER,
11742                          "integer");
11743   ffecom_f2c_make_type_ (&ffecom_f2c_address_type_node,
11744                          FFECOM_f2cADDRESS,
11745                          "address");
11746   ffecom_f2c_make_type_ (&ffecom_f2c_real_type_node,
11747                          FFECOM_f2cREAL,
11748                          "real");
11749   ffecom_f2c_make_type_ (&ffecom_f2c_doublereal_type_node,
11750                          FFECOM_f2cDOUBLEREAL,
11751                          "doublereal");
11752   ffecom_f2c_make_type_ (&ffecom_f2c_complex_type_node,
11753                          FFECOM_f2cCOMPLEX,
11754                          "complex");
11755   ffecom_f2c_make_type_ (&ffecom_f2c_doublecomplex_type_node,
11756                          FFECOM_f2cDOUBLECOMPLEX,
11757                          "doublecomplex");
11758   ffecom_f2c_make_type_ (&ffecom_f2c_longint_type_node,
11759                          FFECOM_f2cLONGINT,
11760                          "longint");
11761   ffecom_f2c_make_type_ (&ffecom_f2c_logical_type_node,
11762                          FFECOM_f2cLOGICAL,
11763                          "logical");
11764   ffecom_f2c_make_type_ (&ffecom_f2c_flag_type_node,
11765                          FFECOM_f2cFLAG,
11766                          "flag");
11767   ffecom_f2c_make_type_ (&ffecom_f2c_ftnlen_type_node,
11768                          FFECOM_f2cFTNLEN,
11769                          "ftnlen");
11770   ffecom_f2c_make_type_ (&ffecom_f2c_ftnint_type_node,
11771                          FFECOM_f2cFTNINT,
11772                          "ftnint");
11773
11774   ffecom_f2c_ftnlen_zero_node
11775     = convert (ffecom_f2c_ftnlen_type_node, integer_zero_node);
11776
11777   ffecom_f2c_ftnlen_one_node
11778     = convert (ffecom_f2c_ftnlen_type_node, integer_one_node);
11779
11780   ffecom_f2c_ftnlen_two_node = build_int_2 (2, 0);
11781   TREE_TYPE (ffecom_f2c_ftnlen_two_node) = ffecom_integer_type_node;
11782
11783   ffecom_f2c_ptr_to_ftnlen_type_node
11784     = build_pointer_type (ffecom_f2c_ftnlen_type_node);
11785
11786   ffecom_f2c_ptr_to_ftnint_type_node
11787     = build_pointer_type (ffecom_f2c_ftnint_type_node);
11788
11789   ffecom_f2c_ptr_to_integer_type_node
11790     = build_pointer_type (ffecom_f2c_integer_type_node);
11791
11792   ffecom_f2c_ptr_to_real_type_node
11793     = build_pointer_type (ffecom_f2c_real_type_node);
11794
11795   ffecom_float_zero_ = build_real (float_type_node, dconst0);
11796   ffecom_double_zero_ = build_real (double_type_node, dconst0);
11797   {
11798     REAL_VALUE_TYPE point_5;
11799
11800 #ifdef REAL_ARITHMETIC
11801     REAL_ARITHMETIC (point_5, RDIV_EXPR, dconst1, dconst2);
11802 #else
11803     point_5 = .5;
11804 #endif
11805     ffecom_float_half_ = build_real (float_type_node, point_5);
11806     ffecom_double_half_ = build_real (double_type_node, point_5);
11807   }
11808
11809   /* Do "extern int xargc;".  */
11810
11811   ffecom_tree_xargc_ = build_decl (VAR_DECL,
11812                                    get_identifier ("f__xargc"),
11813                                    integer_type_node);
11814   DECL_EXTERNAL (ffecom_tree_xargc_) = 1;
11815   TREE_STATIC (ffecom_tree_xargc_) = 1;
11816   TREE_PUBLIC (ffecom_tree_xargc_) = 1;
11817   ffecom_tree_xargc_ = start_decl (ffecom_tree_xargc_, FALSE);
11818   finish_decl (ffecom_tree_xargc_, NULL_TREE, FALSE);
11819
11820 #if 0   /* This is being fixed, and seems to be working now. */
11821   if ((FLOAT_TYPE_SIZE != 32)
11822       || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))) != 32))
11823     {
11824       warning ("configuration: REAL, INTEGER, and LOGICAL are %d bits wide,",
11825                (int) FLOAT_TYPE_SIZE);
11826       warning ("and pointers are %d bits wide, but g77 doesn't yet work",
11827           (int) TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))));
11828       warning ("properly unless they all are 32 bits wide.");
11829       warning ("Please keep this in mind before you report bugs.  g77 should");
11830       warning ("support non-32-bit machines better as of version 0.6.");
11831     }
11832 #endif
11833
11834 #if 0   /* Code in ste.c that would crash has been commented out. */
11835   if (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)
11836       < TYPE_PRECISION (string_type_node))
11837     /* I/O will probably crash.  */
11838     warning ("configuration: char * holds %d bits, but ftnlen only %d",
11839              TYPE_PRECISION (string_type_node),
11840              TYPE_PRECISION (ffecom_f2c_ftnlen_type_node));
11841 #endif
11842
11843 #if 0   /* ASSIGN-related stuff has been changed to accommodate this. */
11844   if (TYPE_PRECISION (ffecom_integer_type_node)
11845       < TYPE_PRECISION (string_type_node))
11846     /* ASSIGN 10 TO I will crash.  */
11847     warning ("configuration: char * holds %d bits, but INTEGER only %d --\n\
11848  ASSIGN statement might fail",
11849              TYPE_PRECISION (string_type_node),
11850              TYPE_PRECISION (ffecom_integer_type_node));
11851 #endif
11852 }
11853
11854 /* ffecom_init_2 -- Initialize
11855
11856    ffecom_init_2();  */
11857
11858 void
11859 ffecom_init_2 ()
11860 {
11861   assert (ffecom_outer_function_decl_ == NULL_TREE);
11862   assert (current_function_decl == NULL_TREE);
11863   assert (ffecom_which_entrypoint_decl_ == NULL_TREE);
11864
11865   ffecom_master_arglist_ = NULL;
11866   ++ffecom_num_fns_;
11867   ffecom_primary_entry_ = NULL;
11868   ffecom_is_altreturning_ = FALSE;
11869   ffecom_func_result_ = NULL_TREE;
11870   ffecom_multi_retval_ = NULL_TREE;
11871 }
11872
11873 /* ffecom_list_expr -- Transform list of exprs into gcc tree
11874
11875    tree t;
11876    ffebld expr;  // FFE opITEM list.
11877    tree = ffecom_list_expr(expr);
11878
11879    List of actual args is transformed into corresponding gcc backend list.  */
11880
11881 tree
11882 ffecom_list_expr (ffebld expr)
11883 {
11884   tree list;
11885   tree *plist = &list;
11886   tree trail = NULL_TREE;       /* Append char length args here. */
11887   tree *ptrail = &trail;
11888   tree length;
11889
11890   while (expr != NULL)
11891     {
11892       tree texpr = ffecom_arg_expr (ffebld_head (expr), &length);
11893
11894       if (texpr == error_mark_node)
11895         return error_mark_node;
11896
11897       *plist = build_tree_list (NULL_TREE, texpr);
11898       plist = &TREE_CHAIN (*plist);
11899       expr = ffebld_trail (expr);
11900       if (length != NULL_TREE)
11901         {
11902           *ptrail = build_tree_list (NULL_TREE, length);
11903           ptrail = &TREE_CHAIN (*ptrail);
11904         }
11905     }
11906
11907   *plist = trail;
11908
11909   return list;
11910 }
11911
11912 /* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree
11913
11914    tree t;
11915    ffebld expr;  // FFE opITEM list.
11916    tree = ffecom_list_ptr_to_expr(expr);
11917
11918    List of actual args is transformed into corresponding gcc backend list for
11919    use in calling an external procedure (vs. a statement function).  */
11920
11921 tree
11922 ffecom_list_ptr_to_expr (ffebld expr)
11923 {
11924   tree list;
11925   tree *plist = &list;
11926   tree trail = NULL_TREE;       /* Append char length args here. */
11927   tree *ptrail = &trail;
11928   tree length;
11929
11930   while (expr != NULL)
11931     {
11932       tree texpr = ffecom_arg_ptr_to_expr (ffebld_head (expr), &length);
11933
11934       if (texpr == error_mark_node)
11935         return error_mark_node;
11936
11937       *plist = build_tree_list (NULL_TREE, texpr);
11938       plist = &TREE_CHAIN (*plist);
11939       expr = ffebld_trail (expr);
11940       if (length != NULL_TREE)
11941         {
11942           *ptrail = build_tree_list (NULL_TREE, length);
11943           ptrail = &TREE_CHAIN (*ptrail);
11944         }
11945     }
11946
11947   *plist = trail;
11948
11949   return list;
11950 }
11951
11952 /* Obtain gcc's LABEL_DECL tree for label.  */
11953
11954 tree
11955 ffecom_lookup_label (ffelab label)
11956 {
11957   tree glabel;
11958
11959   if (ffelab_hook (label) == NULL_TREE)
11960     {
11961       char labelname[16];
11962
11963       switch (ffelab_type (label))
11964         {
11965         case FFELAB_typeLOOPEND:
11966         case FFELAB_typeNOTLOOP:
11967         case FFELAB_typeENDIF:
11968           sprintf (labelname, "%" ffelabValue_f "u", ffelab_value (label));
11969           glabel = build_decl (LABEL_DECL, get_identifier (labelname),
11970                                void_type_node);
11971           DECL_CONTEXT (glabel) = current_function_decl;
11972           DECL_MODE (glabel) = VOIDmode;
11973           break;
11974
11975         case FFELAB_typeFORMAT:
11976           glabel = build_decl (VAR_DECL,
11977                                ffecom_get_invented_identifier
11978                                ("__g77_format_%d", (int) ffelab_value (label)),
11979                                build_type_variant (build_array_type
11980                                                    (char_type_node,
11981                                                     NULL_TREE),
11982                                                    1, 0));
11983           TREE_CONSTANT (glabel) = 1;
11984           TREE_STATIC (glabel) = 1;
11985           DECL_CONTEXT (glabel) = current_function_decl;
11986           DECL_INITIAL (glabel) = NULL;
11987           make_decl_rtl (glabel, NULL);
11988           expand_decl (glabel);
11989
11990           ffecom_save_tree_forever (glabel);
11991
11992           break;
11993
11994         case FFELAB_typeANY:
11995           glabel = error_mark_node;
11996           break;
11997
11998         default:
11999           assert ("bad label type" == NULL);
12000           glabel = NULL;
12001           break;
12002         }
12003       ffelab_set_hook (label, glabel);
12004     }
12005   else
12006     {
12007       glabel = ffelab_hook (label);
12008     }
12009
12010   return glabel;
12011 }
12012
12013 /* Stabilizes the arguments.  Don't use this if the lhs and rhs come from
12014    a single source specification (as in the fourth argument of MVBITS).
12015    If the type is NULL_TREE, the type of lhs is used to make the type of
12016    the MODIFY_EXPR.  */
12017
12018 tree
12019 ffecom_modify (tree newtype, tree lhs,
12020                tree rhs)
12021 {
12022   if (lhs == error_mark_node || rhs == error_mark_node)
12023     return error_mark_node;
12024
12025   if (newtype == NULL_TREE)
12026     newtype = TREE_TYPE (lhs);
12027
12028   if (TREE_SIDE_EFFECTS (lhs))
12029     lhs = stabilize_reference (lhs);
12030
12031   return ffecom_2s (MODIFY_EXPR, newtype, lhs, rhs);
12032 }
12033
12034 /* Register source file name.  */
12035
12036 void
12037 ffecom_file (const char *name)
12038 {
12039   ffecom_file_ (name);
12040 }
12041
12042 /* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed
12043
12044    ffestorag st;
12045    ffecom_notify_init_storage(st);
12046
12047    Gets called when all possible units in an aggregate storage area (a LOCAL
12048    with equivalences or a COMMON) have been initialized.  The initialization
12049    info either is in ffestorag_init or, if that is NULL,
12050    ffestorag_accretion:
12051
12052    ffestorag_init may contain an opCONTER or opARRTER.  opCONTER may occur
12053    even for an array if the array is one element in length!
12054
12055    ffestorag_accretion will contain an opACCTER.  It is much like an
12056    opARRTER except it has an ffebit object in it instead of just a size.
12057    The back end can use the info in the ffebit object, if it wants, to
12058    reduce the amount of actual initialization, but in any case it should
12059    kill the ffebit object when done.  Also, set accretion to NULL but
12060    init to a non-NULL value.
12061
12062    After performing initialization, DO NOT set init to NULL, because that'll
12063    tell the front end it is ok for more initialization to happen.  Instead,
12064    set init to an opANY expression or some such thing that you can use to
12065    tell that you've already initialized the object.
12066
12067    27-Oct-91  JCB  1.1
12068       Support two-pass FFE.  */
12069
12070 void
12071 ffecom_notify_init_storage (ffestorag st)
12072 {
12073   ffebld init;                  /* The initialization expression. */
12074
12075   if (ffestorag_init (st) == NULL)
12076     {
12077       init = ffestorag_accretion (st);
12078       assert (init != NULL);
12079       ffestorag_set_accretion (st, NULL);
12080       ffestorag_set_accretes (st, 0);
12081       ffestorag_set_init (st, init);
12082     }
12083 }
12084
12085 /* ffecom_notify_init_symbol -- A symbol is now fully init'ed
12086
12087    ffesymbol s;
12088    ffecom_notify_init_symbol(s);
12089
12090    Gets called when all possible units in a symbol (not placed in COMMON
12091    or involved in EQUIVALENCE, unless it as yet has no ffestorag object)
12092    have been initialized.  The initialization info either is in
12093    ffesymbol_init or, if that is NULL, ffesymbol_accretion:
12094
12095    ffesymbol_init may contain an opCONTER or opARRTER.  opCONTER may occur
12096    even for an array if the array is one element in length!
12097
12098    ffesymbol_accretion will contain an opACCTER.  It is much like an
12099    opARRTER except it has an ffebit object in it instead of just a size.
12100    The back end can use the info in the ffebit object, if it wants, to
12101    reduce the amount of actual initialization, but in any case it should
12102    kill the ffebit object when done.  Also, set accretion to NULL but
12103    init to a non-NULL value.
12104
12105    After performing initialization, DO NOT set init to NULL, because that'll
12106    tell the front end it is ok for more initialization to happen.  Instead,
12107    set init to an opANY expression or some such thing that you can use to
12108    tell that you've already initialized the object.
12109
12110    27-Oct-91  JCB  1.1
12111       Support two-pass FFE.  */
12112
12113 void
12114 ffecom_notify_init_symbol (ffesymbol s)
12115 {
12116   ffebld init;                  /* The initialization expression. */
12117
12118   if (ffesymbol_storage (s) == NULL)
12119     return;                     /* Do nothing until COMMON/EQUIVALENCE
12120                                    possibilities checked. */
12121
12122   if ((ffesymbol_init (s) == NULL)
12123       && ((init = ffesymbol_accretion (s)) != NULL))
12124     {
12125       ffesymbol_set_accretion (s, NULL);
12126       ffesymbol_set_accretes (s, 0);
12127       ffesymbol_set_init (s, init);
12128     }
12129 }
12130
12131 /* ffecom_notify_primary_entry -- Learn which is the primary entry point
12132
12133    ffesymbol s;
12134    ffecom_notify_primary_entry(s);
12135
12136    Gets called when implicit or explicit PROGRAM statement seen or when
12137    FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary
12138    global symbol that serves as the entry point.  */
12139
12140 void
12141 ffecom_notify_primary_entry (ffesymbol s)
12142 {
12143   ffecom_primary_entry_ = s;
12144   ffecom_primary_entry_kind_ = ffesymbol_kind (s);
12145
12146   if ((ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
12147       || (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE))
12148     ffecom_primary_entry_is_proc_ = TRUE;
12149   else
12150     ffecom_primary_entry_is_proc_ = FALSE;
12151
12152   if (!ffe_is_silent ())
12153     {
12154       if (ffecom_primary_entry_kind_ == FFEINFO_kindPROGRAM)
12155         fprintf (stderr, "%s:\n", ffesymbol_text (s));
12156       else
12157         fprintf (stderr, "  %s:\n", ffesymbol_text (s));
12158     }
12159
12160   if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
12161     {
12162       ffebld list;
12163       ffebld arg;
12164
12165       for (list = ffesymbol_dummyargs (s);
12166            list != NULL;
12167            list = ffebld_trail (list))
12168         {
12169           arg = ffebld_head (list);
12170           if (ffebld_op (arg) == FFEBLD_opSTAR)
12171             {
12172               ffecom_is_altreturning_ = TRUE;
12173               break;
12174             }
12175         }
12176     }
12177 }
12178
12179 FILE *
12180 ffecom_open_include (char *name, ffewhereLine l, ffewhereColumn c)
12181 {
12182   return ffecom_open_include_ (name, l, c);
12183 }
12184
12185 /* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front
12186
12187    tree t;
12188    ffebld expr;  // FFE expression.
12189    tree = ffecom_ptr_to_expr(expr);
12190
12191    Like ffecom_expr, but sticks address-of in front of most things.  */
12192
12193 tree
12194 ffecom_ptr_to_expr (ffebld expr)
12195 {
12196   tree item;
12197   ffeinfoBasictype bt;
12198   ffeinfoKindtype kt;
12199   ffesymbol s;
12200
12201   assert (expr != NULL);
12202
12203   switch (ffebld_op (expr))
12204     {
12205     case FFEBLD_opSYMTER:
12206       s = ffebld_symter (expr);
12207       if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
12208         {
12209           ffecomGfrt ix;
12210
12211           ix = ffeintrin_gfrt_indirect (ffebld_symter_implementation (expr));
12212           assert (ix != FFECOM_gfrt);
12213           if ((item = ffecom_gfrt_[ix]) == NULL_TREE)
12214             {
12215               ffecom_make_gfrt_ (ix);
12216               item = ffecom_gfrt_[ix];
12217             }
12218         }
12219       else
12220         {
12221           item = ffesymbol_hook (s).decl_tree;
12222           if (item == NULL_TREE)
12223             {
12224               s = ffecom_sym_transform_ (s);
12225               item = ffesymbol_hook (s).decl_tree;
12226             }
12227         }
12228       assert (item != NULL);
12229       if (item == error_mark_node)
12230         return item;
12231       if (!ffesymbol_hook (s).addr)
12232         item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12233                          item);
12234       return item;
12235
12236     case FFEBLD_opARRAYREF:
12237       return ffecom_arrayref_ (NULL_TREE, expr, 1);
12238
12239     case FFEBLD_opCONTER:
12240
12241       bt = ffeinfo_basictype (ffebld_info (expr));
12242       kt = ffeinfo_kindtype (ffebld_info (expr));
12243
12244       item = ffecom_constantunion (&ffebld_constant_union
12245                                    (ffebld_conter (expr)), bt, kt,
12246                                    ffecom_tree_type[bt][kt]);
12247       if (item == error_mark_node)
12248         return error_mark_node;
12249       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12250                        item);
12251       return item;
12252
12253     case FFEBLD_opANY:
12254       return error_mark_node;
12255
12256     default:
12257       bt = ffeinfo_basictype (ffebld_info (expr));
12258       kt = ffeinfo_kindtype (ffebld_info (expr));
12259
12260       item = ffecom_expr (expr);
12261       if (item == error_mark_node)
12262         return error_mark_node;
12263
12264       /* The back end currently optimizes a bit too zealously for us, in that
12265          we fail JCB001 if the following block of code is omitted.  It checks
12266          to see if the transformed expression is a symbol or array reference,
12267          and encloses it in a SAVE_EXPR if that is the case.  */
12268
12269       STRIP_NOPS (item);
12270       if ((TREE_CODE (item) == VAR_DECL)
12271           || (TREE_CODE (item) == PARM_DECL)
12272           || (TREE_CODE (item) == RESULT_DECL)
12273           || (TREE_CODE (item) == INDIRECT_REF)
12274           || (TREE_CODE (item) == ARRAY_REF)
12275           || (TREE_CODE (item) == COMPONENT_REF)
12276 #ifdef OFFSET_REF
12277           || (TREE_CODE (item) == OFFSET_REF)
12278 #endif
12279           || (TREE_CODE (item) == BUFFER_REF)
12280           || (TREE_CODE (item) == REALPART_EXPR)
12281           || (TREE_CODE (item) == IMAGPART_EXPR))
12282         {
12283           item = ffecom_save_tree (item);
12284         }
12285
12286       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12287                        item);
12288       return item;
12289     }
12290
12291   assert ("fall-through error" == NULL);
12292   return error_mark_node;
12293 }
12294
12295 /* Obtain a temp var with given data type.
12296
12297    size is FFETARGET_charactersizeNONE for a non-CHARACTER type
12298    or >= 0 for a CHARACTER type.
12299
12300    elements is -1 for a scalar or > 0 for an array of type.  */
12301
12302 tree
12303 ffecom_make_tempvar (const char *commentary, tree type,
12304                      ffetargetCharacterSize size, int elements)
12305 {
12306   tree t;
12307   static int mynumber;
12308
12309   assert (current_binding_level->prep_state < 2);
12310
12311   if (type == error_mark_node)
12312     return error_mark_node;
12313
12314   if (size != FFETARGET_charactersizeNONE)
12315     type = build_array_type (type,
12316                              build_range_type (ffecom_f2c_ftnlen_type_node,
12317                                                ffecom_f2c_ftnlen_one_node,
12318                                                build_int_2 (size, 0)));
12319   if (elements != -1)
12320     type = build_array_type (type,
12321                              build_range_type (integer_type_node,
12322                                                integer_zero_node,
12323                                                build_int_2 (elements - 1,
12324                                                             0)));
12325   t = build_decl (VAR_DECL,
12326                   ffecom_get_invented_identifier ("__g77_%s_%d",
12327                                                   commentary,
12328                                                   mynumber++),
12329                   type);
12330
12331   t = start_decl (t, FALSE);
12332   finish_decl (t, NULL_TREE, FALSE);
12333
12334   return t;
12335 }
12336
12337 /* Prepare argument pointer to expression.
12338
12339    Like ffecom_prepare_expr, except for expressions to be evaluated
12340    via ffecom_arg_ptr_to_expr.  */
12341
12342 void
12343 ffecom_prepare_arg_ptr_to_expr (ffebld expr)
12344 {
12345   /* ~~For now, it seems to be the same thing.  */
12346   ffecom_prepare_expr (expr);
12347   return;
12348 }
12349
12350 /* End of preparations.  */
12351
12352 bool
12353 ffecom_prepare_end (void)
12354 {
12355   int prep_state = current_binding_level->prep_state;
12356
12357   assert (prep_state < 2);
12358   current_binding_level->prep_state = 2;
12359
12360   return (prep_state == 1) ? TRUE : FALSE;
12361 }
12362
12363 /* Prepare expression.
12364
12365    This is called before any code is generated for the current block.
12366    It scans the expression, declares any temporaries that might be needed
12367    during evaluation of the expression, and stores those temporaries in
12368    the appropriate "hook" fields of the expression.  `dest', if not NULL,
12369    specifies the destination that ffecom_expr_ will see, in case that
12370    helps avoid generating unused temporaries.
12371
12372    ~~Improve to avoid allocating unused temporaries by taking `dest'
12373    into account vis-a-vis aliasing requirements of complex/character
12374    functions.  */
12375
12376 void
12377 ffecom_prepare_expr_ (ffebld expr, ffebld dest UNUSED)
12378 {
12379   ffeinfoBasictype bt;
12380   ffeinfoKindtype kt;
12381   ffetargetCharacterSize sz;
12382   tree tempvar = NULL_TREE;
12383
12384   assert (current_binding_level->prep_state < 2);
12385
12386   if (! expr)
12387     return;
12388
12389   bt = ffeinfo_basictype (ffebld_info (expr));
12390   kt = ffeinfo_kindtype (ffebld_info (expr));
12391   sz = ffeinfo_size (ffebld_info (expr));
12392
12393   /* Generate whatever temporaries are needed to represent the result
12394      of the expression.  */
12395
12396   if (bt == FFEINFO_basictypeCHARACTER)
12397     {
12398       while (ffebld_op (expr) == FFEBLD_opPAREN)
12399         expr = ffebld_left (expr);
12400     }
12401
12402   switch (ffebld_op (expr))
12403     {
12404     default:
12405       /* Don't make temps for SYMTER, CONTER, etc.  */
12406       if (ffebld_arity (expr) == 0)
12407         break;
12408
12409       switch (bt)
12410         {
12411         case FFEINFO_basictypeCOMPLEX:
12412           if (ffebld_op (expr) == FFEBLD_opFUNCREF)
12413             {
12414               ffesymbol s;
12415
12416               if (ffebld_op (ffebld_left (expr)) != FFEBLD_opSYMTER)
12417                 break;
12418
12419               s = ffebld_symter (ffebld_left (expr));
12420               if (ffesymbol_where (s) == FFEINFO_whereCONSTANT
12421                   || (ffesymbol_where (s) != FFEINFO_whereINTRINSIC
12422                       && ! ffesymbol_is_f2c (s))
12423                   || (ffesymbol_where (s) == FFEINFO_whereINTRINSIC
12424                       && ! ffe_is_f2c_library ()))
12425                 break;
12426             }
12427           else if (ffebld_op (expr) == FFEBLD_opPOWER)
12428             {
12429               /* Requires special treatment.  There's no POW_CC function
12430                  in libg2c, so POW_ZZ is used, which means we always
12431                  need a double-complex temp, not a single-complex.  */
12432               kt = FFEINFO_kindtypeREAL2;
12433             }
12434           else if (ffebld_op (expr) != FFEBLD_opDIVIDE)
12435             /* The other ops don't need temps for complex operands.  */
12436             break;
12437
12438           /* ~~~Avoid making temps for some intrinsics, such as AIMAG(C),
12439              REAL(C).  See 19990325-0.f, routine `check', for cases.  */
12440           tempvar = ffecom_make_tempvar ("complex",
12441                                          ffecom_tree_type
12442                                          [FFEINFO_basictypeCOMPLEX][kt],
12443                                          FFETARGET_charactersizeNONE,
12444                                          -1);
12445           break;
12446
12447         case FFEINFO_basictypeCHARACTER:
12448           if (ffebld_op (expr) != FFEBLD_opFUNCREF)
12449             break;
12450
12451           if (sz == FFETARGET_charactersizeNONE)
12452             /* ~~Kludge alert!  This should someday be fixed. */
12453             sz = 24;
12454
12455           tempvar = ffecom_make_tempvar ("char", char_type_node, sz, -1);
12456           break;
12457
12458         default:
12459           break;
12460         }
12461       break;
12462
12463 #ifdef HAHA
12464     case FFEBLD_opPOWER:
12465       {
12466         tree rtype, ltype;
12467         tree rtmp, ltmp, result;
12468
12469         ltype = ffecom_type_expr (ffebld_left (expr));
12470         rtype = ffecom_type_expr (ffebld_right (expr));
12471
12472         rtmp = ffecom_make_tempvar (rtype, FFETARGET_charactersizeNONE, -1);
12473         ltmp = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
12474         result = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
12475
12476         tempvar = make_tree_vec (3);
12477         TREE_VEC_ELT (tempvar, 0) = rtmp;
12478         TREE_VEC_ELT (tempvar, 1) = ltmp;
12479         TREE_VEC_ELT (tempvar, 2) = result;
12480       }
12481       break;
12482 #endif  /* HAHA */
12483
12484     case FFEBLD_opCONCATENATE:
12485       {
12486         /* This gets special handling, because only one set of temps
12487            is needed for a tree of these -- the tree is treated as
12488            a flattened list of concatenations when generating code.  */
12489
12490         ffecomConcatList_ catlist;
12491         tree ltmp, itmp, result;
12492         int count;
12493         int i;
12494
12495         catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
12496         count = ffecom_concat_list_count_ (catlist);
12497
12498         if (count >= 2)
12499           {
12500             ltmp
12501               = ffecom_make_tempvar ("concat_len",
12502                                      ffecom_f2c_ftnlen_type_node,
12503                                      FFETARGET_charactersizeNONE, count);
12504             itmp
12505               = ffecom_make_tempvar ("concat_item",
12506                                      ffecom_f2c_address_type_node,
12507                                      FFETARGET_charactersizeNONE, count);
12508             result
12509               = ffecom_make_tempvar ("concat_res",
12510                                      char_type_node,
12511                                      ffecom_concat_list_maxlen_ (catlist),
12512                                      -1);
12513
12514             tempvar = make_tree_vec (3);
12515             TREE_VEC_ELT (tempvar, 0) = ltmp;
12516             TREE_VEC_ELT (tempvar, 1) = itmp;
12517             TREE_VEC_ELT (tempvar, 2) = result;
12518           }
12519
12520         for (i = 0; i < count; ++i)
12521           ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist,
12522                                                                     i));
12523
12524         ffecom_concat_list_kill_ (catlist);
12525
12526         if (tempvar)
12527           {
12528             ffebld_nonter_set_hook (expr, tempvar);
12529             current_binding_level->prep_state = 1;
12530           }
12531       }
12532       return;
12533
12534     case FFEBLD_opCONVERT:
12535       if (bt == FFEINFO_basictypeCHARACTER
12536           && ((ffebld_size_known (ffebld_left (expr))
12537                == FFETARGET_charactersizeNONE)
12538               || (ffebld_size_known (ffebld_left (expr)) >= sz)))
12539         tempvar = ffecom_make_tempvar ("convert", char_type_node, sz, -1);
12540       break;
12541     }
12542
12543   if (tempvar)
12544     {
12545       ffebld_nonter_set_hook (expr, tempvar);
12546       current_binding_level->prep_state = 1;
12547     }
12548
12549   /* Prepare subexpressions for this expr.  */
12550
12551   switch (ffebld_op (expr))
12552     {
12553     case FFEBLD_opPERCENT_LOC:
12554       ffecom_prepare_ptr_to_expr (ffebld_left (expr));
12555       break;
12556
12557     case FFEBLD_opPERCENT_VAL:
12558     case FFEBLD_opPERCENT_REF:
12559       ffecom_prepare_expr (ffebld_left (expr));
12560       break;
12561
12562     case FFEBLD_opPERCENT_DESCR:
12563       ffecom_prepare_arg_ptr_to_expr (ffebld_left (expr));
12564       break;
12565
12566     case FFEBLD_opITEM:
12567       {
12568         ffebld item;
12569
12570         for (item = expr;
12571              item != NULL;
12572              item = ffebld_trail (item))
12573           if (ffebld_head (item) != NULL)
12574             ffecom_prepare_expr (ffebld_head (item));
12575       }
12576       break;
12577
12578     default:
12579       /* Need to handle character conversion specially.  */
12580       switch (ffebld_arity (expr))
12581         {
12582         case 2:
12583           ffecom_prepare_expr (ffebld_left (expr));
12584           ffecom_prepare_expr (ffebld_right (expr));
12585           break;
12586
12587         case 1:
12588           ffecom_prepare_expr (ffebld_left (expr));
12589           break;
12590
12591         default:
12592           break;
12593         }
12594     }
12595
12596   return;
12597 }
12598
12599 /* Prepare expression for reading and writing.
12600
12601    Like ffecom_prepare_expr, except for expressions to be evaluated
12602    via ffecom_expr_rw.  */
12603
12604 void
12605 ffecom_prepare_expr_rw (tree type, ffebld expr)
12606 {
12607   /* This is all we support for now.  */
12608   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
12609
12610   /* ~~For now, it seems to be the same thing.  */
12611   ffecom_prepare_expr (expr);
12612   return;
12613 }
12614
12615 /* Prepare expression for writing.
12616
12617    Like ffecom_prepare_expr, except for expressions to be evaluated
12618    via ffecom_expr_w.  */
12619
12620 void
12621 ffecom_prepare_expr_w (tree type, ffebld expr)
12622 {
12623   /* This is all we support for now.  */
12624   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
12625
12626   /* ~~For now, it seems to be the same thing.  */
12627   ffecom_prepare_expr (expr);
12628   return;
12629 }
12630
12631 /* Prepare expression for returning.
12632
12633    Like ffecom_prepare_expr, except for expressions to be evaluated
12634    via ffecom_return_expr.  */
12635
12636 void
12637 ffecom_prepare_return_expr (ffebld expr)
12638 {
12639   assert (current_binding_level->prep_state < 2);
12640
12641   if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE
12642       && ffecom_is_altreturning_
12643       && expr != NULL)
12644     ffecom_prepare_expr (expr);
12645 }
12646
12647 /* Prepare pointer to expression.
12648
12649    Like ffecom_prepare_expr, except for expressions to be evaluated
12650    via ffecom_ptr_to_expr.  */
12651
12652 void
12653 ffecom_prepare_ptr_to_expr (ffebld expr)
12654 {
12655   /* ~~For now, it seems to be the same thing.  */
12656   ffecom_prepare_expr (expr);
12657   return;
12658 }
12659
12660 /* Transform expression into constant pointer-to-expression tree.
12661
12662    If the expression can be transformed into a pointer-to-expression tree
12663    that is constant, that is done, and the tree returned.  Else NULL_TREE
12664    is returned.
12665
12666    That way, a caller can attempt to provide compile-time initialization
12667    of a variable and, if that fails, *then* choose to start a new block
12668    and resort to using temporaries, as appropriate.  */
12669
12670 tree
12671 ffecom_ptr_to_const_expr (ffebld expr)
12672 {
12673   if (! expr)
12674     return integer_zero_node;
12675
12676   if (ffebld_op (expr) == FFEBLD_opANY)
12677     return error_mark_node;
12678
12679   if (ffebld_arity (expr) == 0
12680       && (ffebld_op (expr) != FFEBLD_opSYMTER
12681           || ffebld_where (expr) == FFEINFO_whereCOMMON
12682           || ffebld_where (expr) == FFEINFO_whereGLOBAL
12683           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
12684     {
12685       tree t;
12686
12687       t = ffecom_ptr_to_expr (expr);
12688       assert (TREE_CONSTANT (t));
12689       return t;
12690     }
12691
12692   return NULL_TREE;
12693 }
12694
12695 /* ffecom_return_expr -- Returns return-value expr given alt return expr
12696
12697    tree rtn;  // NULL_TREE means use expand_null_return()
12698    ffebld expr;  // NULL if no alt return expr to RETURN stmt
12699    rtn = ffecom_return_expr(expr);
12700
12701    Based on the program unit type and other info (like return function
12702    type, return master function type when alternate ENTRY points,
12703    whether subroutine has any alternate RETURN points, etc), returns the
12704    appropriate expression to be returned to the caller, or NULL_TREE
12705    meaning no return value or the caller expects it to be returned somewhere
12706    else (which is handled by other parts of this module).  */
12707
12708 tree
12709 ffecom_return_expr (ffebld expr)
12710 {
12711   tree rtn;
12712
12713   switch (ffecom_primary_entry_kind_)
12714     {
12715     case FFEINFO_kindPROGRAM:
12716     case FFEINFO_kindBLOCKDATA:
12717       rtn = NULL_TREE;
12718       break;
12719
12720     case FFEINFO_kindSUBROUTINE:
12721       if (!ffecom_is_altreturning_)
12722         rtn = NULL_TREE;        /* No alt returns, never an expr. */
12723       else if (expr == NULL)
12724         rtn = integer_zero_node;
12725       else
12726         rtn = ffecom_expr (expr);
12727       break;
12728
12729     case FFEINFO_kindFUNCTION:
12730       if ((ffecom_multi_retval_ != NULL_TREE)
12731           || (ffesymbol_basictype (ffecom_primary_entry_)
12732               == FFEINFO_basictypeCHARACTER)
12733           || ((ffesymbol_basictype (ffecom_primary_entry_)
12734                == FFEINFO_basictypeCOMPLEX)
12735               && (ffecom_num_entrypoints_ == 0)
12736               && ffesymbol_is_f2c (ffecom_primary_entry_)))
12737         {                       /* Value is returned by direct assignment
12738                                    into (implicit) dummy. */
12739           rtn = NULL_TREE;
12740           break;
12741         }
12742       rtn = ffecom_func_result_;
12743 #if 0
12744       /* Spurious error if RETURN happens before first reference!  So elide
12745          this code.  In particular, for debugging registry, rtn should always
12746          be non-null after all, but TREE_USED won't be set until we encounter
12747          a reference in the code.  Perfectly okay (but weird) code that,
12748          e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in
12749          this diagnostic for no reason.  Have people use -O -Wuninitialized
12750          and leave it to the back end to find obviously weird cases.  */
12751
12752       /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid
12753          situation; if the return value has never been referenced, it won't
12754          have a tree under 2pass mode. */
12755       if ((rtn == NULL_TREE)
12756           || !TREE_USED (rtn))
12757         {
12758           ffebad_start (FFEBAD_RETURN_VALUE_UNSET);
12759           ffebad_here (0, ffesymbol_where_line (ffecom_primary_entry_),
12760                        ffesymbol_where_column (ffecom_primary_entry_));
12761           ffebad_string (ffesymbol_text (ffesymbol_funcresult
12762                                          (ffecom_primary_entry_)));
12763           ffebad_finish ();
12764         }
12765 #endif
12766       break;
12767
12768     default:
12769       assert ("bad unit kind" == NULL);
12770     case FFEINFO_kindANY:
12771       rtn = error_mark_node;
12772       break;
12773     }
12774
12775   return rtn;
12776 }
12777
12778 /* Do save_expr only if tree is not error_mark_node.  */
12779
12780 tree
12781 ffecom_save_tree (tree t)
12782 {
12783   return save_expr (t);
12784 }
12785
12786 /* Start a compound statement (block).  */
12787
12788 void
12789 ffecom_start_compstmt (void)
12790 {
12791   bison_rule_pushlevel_ ();
12792 }
12793
12794 /* Public entry point for front end to access start_decl.  */
12795
12796 tree
12797 ffecom_start_decl (tree decl, bool is_initialized)
12798 {
12799   DECL_INITIAL (decl) = is_initialized ? error_mark_node : NULL_TREE;
12800   return start_decl (decl, FALSE);
12801 }
12802
12803 /* ffecom_sym_commit -- Symbol's state being committed to reality
12804
12805    ffesymbol s;
12806    ffecom_sym_commit(s);
12807
12808    Does whatever the backend needs when a symbol is committed after having
12809    been backtrackable for a period of time.  */
12810
12811 void
12812 ffecom_sym_commit (ffesymbol s UNUSED)
12813 {
12814   assert (!ffesymbol_retractable ());
12815 }
12816
12817 /* ffecom_sym_end_transition -- Perform end transition on all symbols
12818
12819    ffecom_sym_end_transition();
12820
12821    Does backend-specific stuff and also calls ffest_sym_end_transition
12822    to do the necessary FFE stuff.
12823
12824    Backtracking is never enabled when this fn is called, so don't worry
12825    about it.  */
12826
12827 ffesymbol
12828 ffecom_sym_end_transition (ffesymbol s)
12829 {
12830   ffestorag st;
12831
12832   assert (!ffesymbol_retractable ());
12833
12834   s = ffest_sym_end_transition (s);
12835
12836   if ((ffesymbol_kind (s) == FFEINFO_kindBLOCKDATA)
12837       && (ffesymbol_where (s) == FFEINFO_whereGLOBAL))
12838     {
12839       ffecom_list_blockdata_
12840         = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
12841                                               FFEINTRIN_specNONE,
12842                                               FFEINTRIN_impNONE),
12843                            ffecom_list_blockdata_);
12844     }
12845
12846   /* This is where we finally notice that a symbol has partial initialization
12847      and finalize it. */
12848
12849   if (ffesymbol_accretion (s) != NULL)
12850     {
12851       assert (ffesymbol_init (s) == NULL);
12852       ffecom_notify_init_symbol (s);
12853     }
12854   else if (((st = ffesymbol_storage (s)) != NULL)
12855            && ((st = ffestorag_parent (st)) != NULL)
12856            && (ffestorag_accretion (st) != NULL))
12857     {
12858       assert (ffestorag_init (st) == NULL);
12859       ffecom_notify_init_storage (st);
12860     }
12861
12862   if ((ffesymbol_kind (s) == FFEINFO_kindCOMMON)
12863       && (ffesymbol_where (s) == FFEINFO_whereLOCAL)
12864       && (ffesymbol_storage (s) != NULL))
12865     {
12866       ffecom_list_common_
12867         = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
12868                                               FFEINTRIN_specNONE,
12869                                               FFEINTRIN_impNONE),
12870                            ffecom_list_common_);
12871     }
12872
12873   return s;
12874 }
12875
12876 /* ffecom_sym_exec_transition -- Perform exec transition on all symbols
12877
12878    ffecom_sym_exec_transition();
12879
12880    Does backend-specific stuff and also calls ffest_sym_exec_transition
12881    to do the necessary FFE stuff.
12882
12883    See the long-winded description in ffecom_sym_learned for info
12884    on handling the situation where backtracking is inhibited.  */
12885
12886 ffesymbol
12887 ffecom_sym_exec_transition (ffesymbol s)
12888 {
12889   s = ffest_sym_exec_transition (s);
12890
12891   return s;
12892 }
12893
12894 /* ffecom_sym_learned -- Initial or more info gained on symbol after exec
12895
12896    ffesymbol s;
12897    s = ffecom_sym_learned(s);
12898
12899    Called when a new symbol is seen after the exec transition or when more
12900    info (perhaps) is gained for an UNCERTAIN symbol.  The symbol state when
12901    it arrives here is that all its latest info is updated already, so its
12902    state may be UNCERTAIN or UNDERSTOOD, it might already have the hook
12903    field filled in if its gone through here or exec_transition first, and
12904    so on.
12905
12906    The backend probably wants to check ffesymbol_retractable() to see if
12907    backtracking is in effect.  If so, the FFE's changes to the symbol may
12908    be retracted (undone) or committed (ratified), at which time the
12909    appropriate ffecom_sym_retract or _commit function will be called
12910    for that function.
12911
12912    If the backend has its own backtracking mechanism, great, use it so that
12913    committal is a simple operation.  Though it doesn't make much difference,
12914    I suppose: the reason for tentative symbol evolution in the FFE is to
12915    enable error detection in weird incorrect statements early and to disable
12916    incorrect error detection on a correct statement.  The backend is not
12917    likely to introduce any information that'll get involved in these
12918    considerations, so it is probably just fine that the implementation
12919    model for this fn and for _exec_transition is to not do anything
12920    (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE
12921    and instead wait until ffecom_sym_commit is called (which it never
12922    will be as long as we're using ambiguity-detecting statement analysis in
12923    the FFE, which we are initially to shake out the code, but don't depend
12924    on this), otherwise go ahead and do whatever is needed.
12925
12926    In essence, then, when this fn and _exec_transition get called while
12927    backtracking is enabled, a general mechanism would be to flag which (or
12928    both) of these were called (and in what order? neat question as to what
12929    might happen that I'm too lame to think through right now) and then when
12930    _commit is called reproduce the original calling sequence, if any, for
12931    the two fns (at which point backtracking will, of course, be disabled).  */
12932
12933 ffesymbol
12934 ffecom_sym_learned (ffesymbol s)
12935 {
12936   ffestorag_exec_layout (s);
12937
12938   return s;
12939 }
12940
12941 /* ffecom_sym_retract -- Symbol's state being retracted from reality
12942
12943    ffesymbol s;
12944    ffecom_sym_retract(s);
12945
12946    Does whatever the backend needs when a symbol is retracted after having
12947    been backtrackable for a period of time.  */
12948
12949 void
12950 ffecom_sym_retract (ffesymbol s UNUSED)
12951 {
12952   assert (!ffesymbol_retractable ());
12953
12954 #if 0                           /* GCC doesn't commit any backtrackable sins,
12955                                    so nothing needed here. */
12956   switch (ffesymbol_hook (s).state)
12957     {
12958     case 0:                     /* nothing happened yet. */
12959       break;
12960
12961     case 1:                     /* exec transition happened. */
12962       break;
12963
12964     case 2:                     /* learned happened. */
12965       break;
12966
12967     case 3:                     /* learned then exec. */
12968       break;
12969
12970     case 4:                     /* exec then learned. */
12971       break;
12972
12973     default:
12974       assert ("bad hook state" == NULL);
12975       break;
12976     }
12977 #endif
12978 }
12979
12980 /* Create temporary gcc label.  */
12981
12982 tree
12983 ffecom_temp_label ()
12984 {
12985   tree glabel;
12986   static int mynumber = 0;
12987
12988   glabel = build_decl (LABEL_DECL,
12989                        ffecom_get_invented_identifier ("__g77_label_%d",
12990                                                        mynumber++),
12991                        void_type_node);
12992   DECL_CONTEXT (glabel) = current_function_decl;
12993   DECL_MODE (glabel) = VOIDmode;
12994
12995   return glabel;
12996 }
12997
12998 /* Return an expression that is usable as an arg in a conditional context
12999    (IF, DO WHILE, .NOT., and so on).
13000
13001    Use the one provided for the back end as of >2.6.0.  */
13002
13003 tree
13004 ffecom_truth_value (tree expr)
13005 {
13006   return truthvalue_conversion (expr);
13007 }
13008
13009 /* Return the inversion of a truth value (the inversion of what
13010    ffecom_truth_value builds).
13011
13012    Apparently invert_truthvalue, which is properly in the back end, is
13013    enough for now, so just use it.  */
13014
13015 tree
13016 ffecom_truth_value_invert (tree expr)
13017 {
13018   return invert_truthvalue (ffecom_truth_value (expr));
13019 }
13020
13021 /* Return the tree that is the type of the expression, as would be
13022    returned in TREE_TYPE(ffecom_expr(expr)), without otherwise
13023    transforming the expression, generating temporaries, etc.  */
13024
13025 tree
13026 ffecom_type_expr (ffebld expr)
13027 {
13028   ffeinfoBasictype bt;
13029   ffeinfoKindtype kt;
13030   tree tree_type;
13031
13032   assert (expr != NULL);
13033
13034   bt = ffeinfo_basictype (ffebld_info (expr));
13035   kt = ffeinfo_kindtype (ffebld_info (expr));
13036   tree_type = ffecom_tree_type[bt][kt];
13037
13038   switch (ffebld_op (expr))
13039     {
13040     case FFEBLD_opCONTER:
13041     case FFEBLD_opSYMTER:
13042     case FFEBLD_opARRAYREF:
13043     case FFEBLD_opUPLUS:
13044     case FFEBLD_opPAREN:
13045     case FFEBLD_opUMINUS:
13046     case FFEBLD_opADD:
13047     case FFEBLD_opSUBTRACT:
13048     case FFEBLD_opMULTIPLY:
13049     case FFEBLD_opDIVIDE:
13050     case FFEBLD_opPOWER:
13051     case FFEBLD_opNOT:
13052     case FFEBLD_opFUNCREF:
13053     case FFEBLD_opSUBRREF:
13054     case FFEBLD_opAND:
13055     case FFEBLD_opOR:
13056     case FFEBLD_opXOR:
13057     case FFEBLD_opNEQV:
13058     case FFEBLD_opEQV:
13059     case FFEBLD_opCONVERT:
13060     case FFEBLD_opLT:
13061     case FFEBLD_opLE:
13062     case FFEBLD_opEQ:
13063     case FFEBLD_opNE:
13064     case FFEBLD_opGT:
13065     case FFEBLD_opGE:
13066     case FFEBLD_opPERCENT_LOC:
13067       return tree_type;
13068
13069     case FFEBLD_opACCTER:
13070     case FFEBLD_opARRTER:
13071     case FFEBLD_opITEM:
13072     case FFEBLD_opSTAR:
13073     case FFEBLD_opBOUNDS:
13074     case FFEBLD_opREPEAT:
13075     case FFEBLD_opLABTER:
13076     case FFEBLD_opLABTOK:
13077     case FFEBLD_opIMPDO:
13078     case FFEBLD_opCONCATENATE:
13079     case FFEBLD_opSUBSTR:
13080     default:
13081       assert ("bad op for ffecom_type_expr" == NULL);
13082       /* Fall through. */
13083     case FFEBLD_opANY:
13084       return error_mark_node;
13085     }
13086 }
13087
13088 /* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points
13089
13090    If the PARM_DECL already exists, return it, else create it.  It's an
13091    integer_type_node argument for the master function that implements a
13092    subroutine or function with more than one entrypoint and is bound at
13093    run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for
13094    first ENTRY statement, and so on).  */
13095
13096 tree
13097 ffecom_which_entrypoint_decl ()
13098 {
13099   assert (ffecom_which_entrypoint_decl_ != NULL_TREE);
13100
13101   return ffecom_which_entrypoint_decl_;
13102 }
13103 \f
13104 /* The following sections consists of private and public functions
13105    that have the same names and perform roughly the same functions
13106    as counterparts in the C front end.  Changes in the C front end
13107    might affect how things should be done here.  Only functions
13108    needed by the back end should be public here; the rest should
13109    be private (static in the C sense).  Functions needed by other
13110    g77 front-end modules should be accessed by them via public
13111    ffecom_* names, which should themselves call private versions
13112    in this section so the private versions are easy to recognize
13113    when upgrading to a new gcc and finding interesting changes
13114    in the front end.
13115
13116    Functions named after rule "foo:" in c-parse.y are named
13117    "bison_rule_foo_" so they are easy to find.  */
13118
13119 static void
13120 bison_rule_pushlevel_ ()
13121 {
13122   emit_line_note (input_filename, lineno);
13123   pushlevel (0);
13124   clear_last_expr ();
13125   expand_start_bindings (0);
13126 }
13127
13128 static tree
13129 bison_rule_compstmt_ ()
13130 {
13131   tree t;
13132   int keep = kept_level_p ();
13133
13134   /* Make the temps go away.  */
13135   if (! keep)
13136     current_binding_level->names = NULL_TREE;
13137
13138   emit_line_note (input_filename, lineno);
13139   expand_end_bindings (getdecls (), keep, 0);
13140   t = poplevel (keep, 1, 0);
13141
13142   return t;
13143 }
13144
13145 /* Return a definition for a builtin function named NAME and whose data type
13146    is TYPE.  TYPE should be a function type with argument types.
13147    FUNCTION_CODE tells later passes how to compile calls to this function.
13148    See tree.h for its possible values.
13149
13150    If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
13151    the name to be called if we can't opencode the function.  */
13152
13153 tree
13154 builtin_function (const char *name, tree type, int function_code,
13155                   enum built_in_class class,
13156                   const char *library_name)
13157 {
13158   tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type);
13159   DECL_EXTERNAL (decl) = 1;
13160   TREE_PUBLIC (decl) = 1;
13161   if (library_name)
13162     SET_DECL_ASSEMBLER_NAME (decl, get_identifier (library_name));
13163   make_decl_rtl (decl, NULL);
13164   pushdecl (decl);
13165   DECL_BUILT_IN_CLASS (decl) = class;
13166   DECL_FUNCTION_CODE (decl) = function_code;
13167
13168   return decl;
13169 }
13170
13171 /* Handle when a new declaration NEWDECL
13172    has the same name as an old one OLDDECL
13173    in the same binding contour.
13174    Prints an error message if appropriate.
13175
13176    If safely possible, alter OLDDECL to look like NEWDECL, and return 1.
13177    Otherwise, return 0.  */
13178
13179 static int
13180 duplicate_decls (tree newdecl, tree olddecl)
13181 {
13182   int types_match = 1;
13183   int new_is_definition = (TREE_CODE (newdecl) == FUNCTION_DECL
13184                            && DECL_INITIAL (newdecl) != 0);
13185   tree oldtype = TREE_TYPE (olddecl);
13186   tree newtype = TREE_TYPE (newdecl);
13187
13188   if (olddecl == newdecl)
13189     return 1;
13190
13191   if (TREE_CODE (newtype) == ERROR_MARK
13192       || TREE_CODE (oldtype) == ERROR_MARK)
13193     types_match = 0;
13194
13195   /* New decl is completely inconsistent with the old one =>
13196      tell caller to replace the old one.
13197      This is always an error except in the case of shadowing a builtin.  */
13198   if (TREE_CODE (olddecl) != TREE_CODE (newdecl))
13199     return 0;
13200
13201   /* For real parm decl following a forward decl,
13202      return 1 so old decl will be reused.  */
13203   if (types_match && TREE_CODE (newdecl) == PARM_DECL
13204       && TREE_ASM_WRITTEN (olddecl) && ! TREE_ASM_WRITTEN (newdecl))
13205     return 1;
13206
13207   /* The new declaration is the same kind of object as the old one.
13208      The declarations may partially match.  Print warnings if they don't
13209      match enough.  Ultimately, copy most of the information from the new
13210      decl to the old one, and keep using the old one.  */
13211
13212   if (TREE_CODE (olddecl) == FUNCTION_DECL
13213       && DECL_BUILT_IN (olddecl))
13214     {
13215       /* A function declaration for a built-in function.  */
13216       if (!TREE_PUBLIC (newdecl))
13217         return 0;
13218       else if (!types_match)
13219         {
13220           /* Accept the return type of the new declaration if same modes.  */
13221           tree oldreturntype = TREE_TYPE (TREE_TYPE (olddecl));
13222           tree newreturntype = TREE_TYPE (TREE_TYPE (newdecl));
13223
13224           if (TYPE_MODE (oldreturntype) == TYPE_MODE (newreturntype))
13225             {
13226               /* Function types may be shared, so we can't just modify
13227                  the return type of olddecl's function type.  */
13228               tree newtype
13229                 = build_function_type (newreturntype,
13230                                        TYPE_ARG_TYPES (TREE_TYPE (olddecl)));
13231
13232               types_match = 1;
13233               if (types_match)
13234                 TREE_TYPE (olddecl) = newtype;
13235             }
13236         }
13237       if (!types_match)
13238         return 0;
13239     }
13240   else if (TREE_CODE (olddecl) == FUNCTION_DECL
13241            && DECL_SOURCE_LINE (olddecl) == 0)
13242     {
13243       /* A function declaration for a predeclared function
13244          that isn't actually built in.  */
13245       if (!TREE_PUBLIC (newdecl))
13246         return 0;
13247       else if (!types_match)
13248         {
13249           /* If the types don't match, preserve volatility indication.
13250              Later on, we will discard everything else about the
13251              default declaration.  */
13252           TREE_THIS_VOLATILE (newdecl) |= TREE_THIS_VOLATILE (olddecl);
13253         }
13254     }
13255
13256   /* Copy all the DECL_... slots specified in the new decl
13257      except for any that we copy here from the old type.
13258
13259      Past this point, we don't change OLDTYPE and NEWTYPE
13260      even if we change the types of NEWDECL and OLDDECL.  */
13261
13262   if (types_match)
13263     {
13264       /* Merge the data types specified in the two decls.  */
13265       if (TREE_CODE (newdecl) != FUNCTION_DECL || !DECL_BUILT_IN (olddecl))
13266         TREE_TYPE (newdecl)
13267           = TREE_TYPE (olddecl)
13268             = TREE_TYPE (newdecl);
13269
13270       /* Lay the type out, unless already done.  */
13271       if (oldtype != TREE_TYPE (newdecl))
13272         {
13273           if (TREE_TYPE (newdecl) != error_mark_node)
13274             layout_type (TREE_TYPE (newdecl));
13275           if (TREE_CODE (newdecl) != FUNCTION_DECL
13276               && TREE_CODE (newdecl) != TYPE_DECL
13277               && TREE_CODE (newdecl) != CONST_DECL)
13278             layout_decl (newdecl, 0);
13279         }
13280       else
13281         {
13282           /* Since the type is OLDDECL's, make OLDDECL's size go with.  */
13283           DECL_SIZE (newdecl) = DECL_SIZE (olddecl);
13284           DECL_SIZE_UNIT (newdecl) = DECL_SIZE_UNIT (olddecl);
13285           if (TREE_CODE (olddecl) != FUNCTION_DECL)
13286             if (DECL_ALIGN (olddecl) > DECL_ALIGN (newdecl))
13287               {
13288                 DECL_ALIGN (newdecl) = DECL_ALIGN (olddecl);
13289                 DECL_USER_ALIGN (newdecl) |= DECL_USER_ALIGN (olddecl);
13290               }
13291         }
13292
13293       /* Keep the old rtl since we can safely use it.  */
13294       COPY_DECL_RTL (olddecl, newdecl);
13295
13296       /* Merge the type qualifiers.  */
13297       if (DECL_BUILT_IN_NONANSI (olddecl) && TREE_THIS_VOLATILE (olddecl)
13298           && !TREE_THIS_VOLATILE (newdecl))
13299         TREE_THIS_VOLATILE (olddecl) = 0;
13300       if (TREE_READONLY (newdecl))
13301         TREE_READONLY (olddecl) = 1;
13302       if (TREE_THIS_VOLATILE (newdecl))
13303         {
13304           TREE_THIS_VOLATILE (olddecl) = 1;
13305           if (TREE_CODE (newdecl) == VAR_DECL)
13306             make_var_volatile (newdecl);
13307         }
13308
13309       /* Keep source location of definition rather than declaration.
13310          Likewise, keep decl at outer scope.  */
13311       if ((DECL_INITIAL (newdecl) == 0 && DECL_INITIAL (olddecl) != 0)
13312           || (DECL_CONTEXT (newdecl) != 0 && DECL_CONTEXT (olddecl) == 0))
13313         {
13314           DECL_SOURCE_LINE (newdecl) = DECL_SOURCE_LINE (olddecl);
13315           DECL_SOURCE_FILE (newdecl) = DECL_SOURCE_FILE (olddecl);
13316
13317           if (DECL_CONTEXT (olddecl) == 0
13318               && TREE_CODE (newdecl) != FUNCTION_DECL)
13319             DECL_CONTEXT (newdecl) = 0;
13320         }
13321
13322       /* Merge the unused-warning information.  */
13323       if (DECL_IN_SYSTEM_HEADER (olddecl))
13324         DECL_IN_SYSTEM_HEADER (newdecl) = 1;
13325       else if (DECL_IN_SYSTEM_HEADER (newdecl))
13326         DECL_IN_SYSTEM_HEADER (olddecl) = 1;
13327
13328       /* Merge the initialization information.  */
13329       if (DECL_INITIAL (newdecl) == 0)
13330         DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13331
13332       /* Merge the section attribute.
13333          We want to issue an error if the sections conflict but that must be
13334          done later in decl_attributes since we are called before attributes
13335          are assigned.  */
13336       if (DECL_SECTION_NAME (newdecl) == NULL_TREE)
13337         DECL_SECTION_NAME (newdecl) = DECL_SECTION_NAME (olddecl);
13338
13339       if (TREE_CODE (newdecl) == FUNCTION_DECL)
13340         {
13341           DECL_STATIC_CONSTRUCTOR(newdecl) |= DECL_STATIC_CONSTRUCTOR(olddecl);
13342           DECL_STATIC_DESTRUCTOR (newdecl) |= DECL_STATIC_DESTRUCTOR (olddecl);
13343         }
13344     }
13345   /* If cannot merge, then use the new type and qualifiers,
13346      and don't preserve the old rtl.  */
13347   else
13348     {
13349       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13350       TREE_READONLY (olddecl) = TREE_READONLY (newdecl);
13351       TREE_THIS_VOLATILE (olddecl) = TREE_THIS_VOLATILE (newdecl);
13352       TREE_SIDE_EFFECTS (olddecl) = TREE_SIDE_EFFECTS (newdecl);
13353     }
13354
13355   /* Merge the storage class information.  */
13356   /* For functions, static overrides non-static.  */
13357   if (TREE_CODE (newdecl) == FUNCTION_DECL)
13358     {
13359       TREE_PUBLIC (newdecl) &= TREE_PUBLIC (olddecl);
13360       /* This is since we don't automatically
13361          copy the attributes of NEWDECL into OLDDECL.  */
13362       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13363       /* If this clears `static', clear it in the identifier too.  */
13364       if (! TREE_PUBLIC (olddecl))
13365         TREE_PUBLIC (DECL_NAME (olddecl)) = 0;
13366     }
13367   if (DECL_EXTERNAL (newdecl))
13368     {
13369       TREE_STATIC (newdecl) = TREE_STATIC (olddecl);
13370       DECL_EXTERNAL (newdecl) = DECL_EXTERNAL (olddecl);
13371       /* An extern decl does not override previous storage class.  */
13372       TREE_PUBLIC (newdecl) = TREE_PUBLIC (olddecl);
13373     }
13374   else
13375     {
13376       TREE_STATIC (olddecl) = TREE_STATIC (newdecl);
13377       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13378     }
13379
13380   /* If either decl says `inline', this fn is inline,
13381      unless its definition was passed already.  */
13382   if (DECL_INLINE (newdecl) && DECL_INITIAL (olddecl) == 0)
13383     DECL_INLINE (olddecl) = 1;
13384   DECL_INLINE (newdecl) = DECL_INLINE (olddecl);
13385
13386   /* Get rid of any built-in function if new arg types don't match it
13387      or if we have a function definition.  */
13388   if (TREE_CODE (newdecl) == FUNCTION_DECL
13389       && DECL_BUILT_IN (olddecl)
13390       && (!types_match || new_is_definition))
13391     {
13392       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13393       DECL_BUILT_IN_CLASS (olddecl) = NOT_BUILT_IN;
13394     }
13395
13396   /* If redeclaring a builtin function, and not a definition,
13397      it stays built in.
13398      Also preserve various other info from the definition.  */
13399   if (TREE_CODE (newdecl) == FUNCTION_DECL && !new_is_definition)
13400     {
13401       if (DECL_BUILT_IN (olddecl))
13402         {
13403           DECL_BUILT_IN_CLASS (newdecl) = DECL_BUILT_IN_CLASS (olddecl);
13404           DECL_FUNCTION_CODE (newdecl) = DECL_FUNCTION_CODE (olddecl);
13405         }
13406
13407       DECL_RESULT (newdecl) = DECL_RESULT (olddecl);
13408       DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13409       DECL_SAVED_INSNS (newdecl) = DECL_SAVED_INSNS (olddecl);
13410       DECL_ARGUMENTS (newdecl) = DECL_ARGUMENTS (olddecl);
13411     }
13412
13413   /* Copy most of the decl-specific fields of NEWDECL into OLDDECL.
13414      But preserve olddecl's DECL_UID.  */
13415   {
13416     register unsigned olddecl_uid = DECL_UID (olddecl);
13417
13418     memcpy ((char *) olddecl + sizeof (struct tree_common),
13419             (char *) newdecl + sizeof (struct tree_common),
13420             sizeof (struct tree_decl) - sizeof (struct tree_common));
13421     DECL_UID (olddecl) = olddecl_uid;
13422   }
13423
13424   return 1;
13425 }
13426
13427 /* Finish processing of a declaration;
13428    install its initial value.
13429    If the length of an array type is not known before,
13430    it must be determined now, from the initial value, or it is an error.  */
13431
13432 static void
13433 finish_decl (tree decl, tree init, bool is_top_level)
13434 {
13435   register tree type = TREE_TYPE (decl);
13436   int was_incomplete = (DECL_SIZE (decl) == 0);
13437   bool at_top_level = (current_binding_level == global_binding_level);
13438   bool top_level = is_top_level || at_top_level;
13439
13440   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13441      level anyway.  */
13442   assert (!is_top_level || !at_top_level);
13443
13444   if (TREE_CODE (decl) == PARM_DECL)
13445     assert (init == NULL_TREE);
13446   /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it
13447      overlaps DECL_ARG_TYPE.  */
13448   else if (init == NULL_TREE)
13449     assert (DECL_INITIAL (decl) == NULL_TREE);
13450   else
13451     assert (DECL_INITIAL (decl) == error_mark_node);
13452
13453   if (init != NULL_TREE)
13454     {
13455       if (TREE_CODE (decl) != TYPE_DECL)
13456         DECL_INITIAL (decl) = init;
13457       else
13458         {
13459           /* typedef foo = bar; store the type of bar as the type of foo.  */
13460           TREE_TYPE (decl) = TREE_TYPE (init);
13461           DECL_INITIAL (decl) = init = 0;
13462         }
13463     }
13464
13465   /* Deduce size of array from initialization, if not already known */
13466
13467   if (TREE_CODE (type) == ARRAY_TYPE
13468       && TYPE_DOMAIN (type) == 0
13469       && TREE_CODE (decl) != TYPE_DECL)
13470     {
13471       assert (top_level);
13472       assert (was_incomplete);
13473
13474       layout_decl (decl, 0);
13475     }
13476
13477   if (TREE_CODE (decl) == VAR_DECL)
13478     {
13479       if (DECL_SIZE (decl) == NULL_TREE
13480           && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
13481         layout_decl (decl, 0);
13482
13483       if (DECL_SIZE (decl) == NULL_TREE
13484           && (TREE_STATIC (decl)
13485               ?
13486       /* A static variable with an incomplete type is an error if it is
13487          initialized. Also if it is not file scope. Otherwise, let it
13488          through, but if it is not `extern' then it may cause an error
13489          message later.  */
13490               (DECL_INITIAL (decl) != 0 || DECL_CONTEXT (decl) != 0)
13491               :
13492       /* An automatic variable with an incomplete type is an error.  */
13493               !DECL_EXTERNAL (decl)))
13494         {
13495           assert ("storage size not known" == NULL);
13496           abort ();
13497         }
13498
13499       if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl))
13500           && (DECL_SIZE (decl) != 0)
13501           && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST))
13502         {
13503           assert ("storage size not constant" == NULL);
13504           abort ();
13505         }
13506     }
13507
13508   /* Output the assembler code and/or RTL code for variables and functions,
13509      unless the type is an undefined structure or union. If not, it will get
13510      done when the type is completed.  */
13511
13512   if (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == FUNCTION_DECL)
13513     {
13514       rest_of_decl_compilation (decl, NULL,
13515                                 DECL_CONTEXT (decl) == 0,
13516                                 0);
13517
13518       if (DECL_CONTEXT (decl) != 0)
13519         {
13520           /* Recompute the RTL of a local array now if it used to be an
13521              incomplete type.  */
13522           if (was_incomplete
13523               && !TREE_STATIC (decl) && !DECL_EXTERNAL (decl))
13524             {
13525               /* If we used it already as memory, it must stay in memory.  */
13526               TREE_ADDRESSABLE (decl) = TREE_USED (decl);
13527               /* If it's still incomplete now, no init will save it.  */
13528               if (DECL_SIZE (decl) == 0)
13529                 DECL_INITIAL (decl) = 0;
13530               expand_decl (decl);
13531             }
13532           /* Compute and store the initial value.  */
13533           if (TREE_CODE (decl) != FUNCTION_DECL)
13534             expand_decl_init (decl);
13535         }
13536     }
13537   else if (TREE_CODE (decl) == TYPE_DECL)
13538     {
13539       rest_of_decl_compilation (decl, NULL,
13540                                 DECL_CONTEXT (decl) == 0,
13541                                 0);
13542     }
13543
13544   /* At the end of a declaration, throw away any variable type sizes of types
13545      defined inside that declaration.  There is no use computing them in the
13546      following function definition.  */
13547   if (current_binding_level == global_binding_level)
13548     get_pending_sizes ();
13549 }
13550
13551 /* Finish up a function declaration and compile that function
13552    all the way to assembler language output.  The free the storage
13553    for the function definition.
13554
13555    This is called after parsing the body of the function definition.
13556
13557    NESTED is nonzero if the function being finished is nested in another.  */
13558
13559 static void
13560 finish_function (int nested)
13561 {
13562   register tree fndecl = current_function_decl;
13563
13564   assert (fndecl != NULL_TREE);
13565   if (TREE_CODE (fndecl) != ERROR_MARK)
13566     {
13567       if (nested)
13568         assert (DECL_CONTEXT (fndecl) != NULL_TREE);
13569       else
13570         assert (DECL_CONTEXT (fndecl) == NULL_TREE);
13571     }
13572
13573 /*  TREE_READONLY (fndecl) = 1;
13574     This caused &foo to be of type ptr-to-const-function
13575     which then got a warning when stored in a ptr-to-function variable.  */
13576
13577   poplevel (1, 0, 1);
13578
13579   if (TREE_CODE (fndecl) != ERROR_MARK)
13580     {
13581       BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
13582
13583       /* Must mark the RESULT_DECL as being in this function.  */
13584
13585       DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl;
13586
13587       /* Obey `register' declarations if `setjmp' is called in this fn.  */
13588       /* Generate rtl for function exit.  */
13589       expand_function_end (input_filename, lineno, 0);
13590
13591       /* If this is a nested function, protect the local variables in the stack
13592          above us from being collected while we're compiling this function.  */
13593       if (nested)
13594         ggc_push_context ();
13595
13596       /* Run the optimizers and output the assembler code for this function.  */
13597       rest_of_compilation (fndecl);
13598
13599       /* Undo the GC context switch.  */
13600       if (nested)
13601         ggc_pop_context ();
13602     }
13603
13604   if (TREE_CODE (fndecl) != ERROR_MARK
13605       && !nested
13606       && DECL_SAVED_INSNS (fndecl) == 0)
13607     {
13608       /* Stop pointing to the local nodes about to be freed.  */
13609       /* But DECL_INITIAL must remain nonzero so we know this was an actual
13610          function definition.  */
13611       /* For a nested function, this is done in pop_f_function_context.  */
13612       /* If rest_of_compilation set this to 0, leave it 0.  */
13613       if (DECL_INITIAL (fndecl) != 0)
13614         DECL_INITIAL (fndecl) = error_mark_node;
13615       DECL_ARGUMENTS (fndecl) = 0;
13616     }
13617
13618   if (!nested)
13619     {
13620       /* Let the error reporting routines know that we're outside a function.
13621          For a nested function, this value is used in pop_c_function_context
13622          and then reset via pop_function_context.  */
13623       ffecom_outer_function_decl_ = current_function_decl = NULL;
13624     }
13625 }
13626
13627 /* Plug-in replacement for identifying the name of a decl and, for a
13628    function, what we call it in diagnostics.  For now, "program unit"
13629    should suffice, since it's a bit of a hassle to figure out which
13630    of several kinds of things it is.  Note that it could conceivably
13631    be a statement function, which probably isn't really a program unit
13632    per se, but if that comes up, it should be easy to check (being a
13633    nested function and all).  */
13634
13635 static const char *
13636 lang_printable_name (tree decl, int v)
13637 {
13638   /* Just to keep GCC quiet about the unused variable.
13639      In theory, differing values of V should produce different
13640      output.  */
13641   switch (v)
13642     {
13643     default:
13644       if (TREE_CODE (decl) == ERROR_MARK)
13645         return "erroneous code";
13646       return IDENTIFIER_POINTER (DECL_NAME (decl));
13647     }
13648 }
13649
13650 /* g77's function to print out name of current function that caused
13651    an error.  */
13652
13653 static void
13654 lang_print_error_function (diagnostic_context *context __attribute__((unused)),
13655                            const char *file)
13656 {
13657   static ffeglobal last_g = NULL;
13658   static ffesymbol last_s = NULL;
13659   ffeglobal g;
13660   ffesymbol s;
13661   const char *kind;
13662
13663   if ((ffecom_primary_entry_ == NULL)
13664       || (ffesymbol_global (ffecom_primary_entry_) == NULL))
13665     {
13666       g = NULL;
13667       s = NULL;
13668       kind = NULL;
13669     }
13670   else
13671     {
13672       g = ffesymbol_global (ffecom_primary_entry_);
13673       if (ffecom_nested_entry_ == NULL)
13674         {
13675           s = ffecom_primary_entry_;
13676           switch (ffesymbol_kind (s))
13677             {
13678             case FFEINFO_kindFUNCTION:
13679               kind = "function";
13680               break;
13681
13682             case FFEINFO_kindSUBROUTINE:
13683               kind = "subroutine";
13684               break;
13685
13686             case FFEINFO_kindPROGRAM:
13687               kind = "program";
13688               break;
13689
13690             case FFEINFO_kindBLOCKDATA:
13691               kind = "block-data";
13692               break;
13693
13694             default:
13695               kind = ffeinfo_kind_message (ffesymbol_kind (s));
13696               break;
13697             }
13698         }
13699       else
13700         {
13701           s = ffecom_nested_entry_;
13702           kind = "statement function";
13703         }
13704     }
13705
13706   if ((last_g != g) || (last_s != s))
13707     {
13708       if (file)
13709         fprintf (stderr, "%s: ", file);
13710
13711       if (s == NULL)
13712         fprintf (stderr, "Outside of any program unit:\n");
13713       else
13714         {
13715           const char *name = ffesymbol_text (s);
13716
13717           fprintf (stderr, "In %s `%s':\n", kind, name);
13718         }
13719
13720       last_g = g;
13721       last_s = s;
13722     }
13723 }
13724
13725 /* Similar to `lookup_name' but look only at current binding level.  */
13726
13727 static tree
13728 lookup_name_current_level (tree name)
13729 {
13730   register tree t;
13731
13732   if (current_binding_level == global_binding_level)
13733     return IDENTIFIER_GLOBAL_VALUE (name);
13734
13735   if (IDENTIFIER_LOCAL_VALUE (name) == 0)
13736     return 0;
13737
13738   for (t = current_binding_level->names; t; t = TREE_CHAIN (t))
13739     if (DECL_NAME (t) == name)
13740       break;
13741
13742   return t;
13743 }
13744
13745 /* Create a new `struct binding_level'.  */
13746
13747 static struct binding_level *
13748 make_binding_level ()
13749 {
13750   /* NOSTRICT */
13751   return (struct binding_level *) xmalloc (sizeof (struct binding_level));
13752 }
13753
13754 /* Save and restore the variables in this file and elsewhere
13755    that keep track of the progress of compilation of the current function.
13756    Used for nested functions.  */
13757
13758 struct f_function
13759 {
13760   struct f_function *next;
13761   tree named_labels;
13762   tree shadowed_labels;
13763   struct binding_level *binding_level;
13764 };
13765
13766 struct f_function *f_function_chain;
13767
13768 /* Restore the variables used during compilation of a C function.  */
13769
13770 static void
13771 pop_f_function_context ()
13772 {
13773   struct f_function *p = f_function_chain;
13774   tree link;
13775
13776   /* Bring back all the labels that were shadowed.  */
13777   for (link = shadowed_labels; link; link = TREE_CHAIN (link))
13778     if (DECL_NAME (TREE_VALUE (link)) != 0)
13779       IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link)))
13780         = TREE_VALUE (link);
13781
13782   if (current_function_decl != error_mark_node
13783       && DECL_SAVED_INSNS (current_function_decl) == 0)
13784     {
13785       /* Stop pointing to the local nodes about to be freed.  */
13786       /* But DECL_INITIAL must remain nonzero so we know this was an actual
13787          function definition.  */
13788       DECL_INITIAL (current_function_decl) = error_mark_node;
13789       DECL_ARGUMENTS (current_function_decl) = 0;
13790     }
13791
13792   pop_function_context ();
13793
13794   f_function_chain = p->next;
13795
13796   named_labels = p->named_labels;
13797   shadowed_labels = p->shadowed_labels;
13798   current_binding_level = p->binding_level;
13799
13800   free (p);
13801 }
13802
13803 /* Save and reinitialize the variables
13804    used during compilation of a C function.  */
13805
13806 static void
13807 push_f_function_context ()
13808 {
13809   struct f_function *p
13810   = (struct f_function *) xmalloc (sizeof (struct f_function));
13811
13812   push_function_context ();
13813
13814   p->next = f_function_chain;
13815   f_function_chain = p;
13816
13817   p->named_labels = named_labels;
13818   p->shadowed_labels = shadowed_labels;
13819   p->binding_level = current_binding_level;
13820 }
13821
13822 static void
13823 push_parm_decl (tree parm)
13824 {
13825   int old_immediate_size_expand = immediate_size_expand;
13826
13827   /* Don't try computing parm sizes now -- wait till fn is called.  */
13828
13829   immediate_size_expand = 0;
13830
13831   /* Fill in arg stuff.  */
13832
13833   DECL_ARG_TYPE (parm) = TREE_TYPE (parm);
13834   DECL_ARG_TYPE_AS_WRITTEN (parm) = TREE_TYPE (parm);
13835   TREE_READONLY (parm) = 1;     /* All implementation args are read-only. */
13836
13837   parm = pushdecl (parm);
13838
13839   immediate_size_expand = old_immediate_size_expand;
13840
13841   finish_decl (parm, NULL_TREE, FALSE);
13842 }
13843
13844 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate.  */
13845
13846 static tree
13847 pushdecl_top_level (x)
13848      tree x;
13849 {
13850   register tree t;
13851   register struct binding_level *b = current_binding_level;
13852   register tree f = current_function_decl;
13853
13854   current_binding_level = global_binding_level;
13855   current_function_decl = NULL_TREE;
13856   t = pushdecl (x);
13857   current_binding_level = b;
13858   current_function_decl = f;
13859   return t;
13860 }
13861
13862 /* Store the list of declarations of the current level.
13863    This is done for the parameter declarations of a function being defined,
13864    after they are modified in the light of any missing parameters.  */
13865
13866 static tree
13867 storedecls (decls)
13868      tree decls;
13869 {
13870   return current_binding_level->names = decls;
13871 }
13872
13873 /* Store the parameter declarations into the current function declaration.
13874    This is called after parsing the parameter declarations, before
13875    digesting the body of the function.
13876
13877    For an old-style definition, modify the function's type
13878    to specify at least the number of arguments.  */
13879
13880 static void
13881 store_parm_decls (int is_main_program UNUSED)
13882 {
13883   register tree fndecl = current_function_decl;
13884
13885   if (fndecl == error_mark_node)
13886     return;
13887
13888   /* This is a chain of PARM_DECLs from old-style parm declarations.  */
13889   DECL_ARGUMENTS (fndecl) = storedecls (nreverse (getdecls ()));
13890
13891   /* Initialize the RTL code for the function.  */
13892
13893   init_function_start (fndecl, input_filename, lineno);
13894
13895   /* Set up parameters and prepare for return, for the function.  */
13896
13897   expand_function_start (fndecl, 0);
13898 }
13899
13900 static tree
13901 start_decl (tree decl, bool is_top_level)
13902 {
13903   register tree tem;
13904   bool at_top_level = (current_binding_level == global_binding_level);
13905   bool top_level = is_top_level || at_top_level;
13906
13907   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13908      level anyway.  */
13909   assert (!is_top_level || !at_top_level);
13910
13911   if (DECL_INITIAL (decl) != NULL_TREE)
13912     {
13913       assert (DECL_INITIAL (decl) == error_mark_node);
13914       assert (!DECL_EXTERNAL (decl));
13915     }
13916   else if (top_level)
13917     assert ((TREE_STATIC (decl) == 1) || DECL_EXTERNAL (decl) == 1);
13918
13919   /* For Fortran, we by default put things in .common when possible.  */
13920   DECL_COMMON (decl) = 1;
13921
13922   /* Add this decl to the current binding level. TEM may equal DECL or it may
13923      be a previous decl of the same name.  */
13924   if (is_top_level)
13925     tem = pushdecl_top_level (decl);
13926   else
13927     tem = pushdecl (decl);
13928
13929   /* For a local variable, define the RTL now.  */
13930   if (!top_level
13931   /* But not if this is a duplicate decl and we preserved the rtl from the
13932      previous one (which may or may not happen).  */
13933       && !DECL_RTL_SET_P (tem))
13934     {
13935       if (TYPE_SIZE (TREE_TYPE (tem)) != 0)
13936         expand_decl (tem);
13937       else if (TREE_CODE (TREE_TYPE (tem)) == ARRAY_TYPE
13938                && DECL_INITIAL (tem) != 0)
13939         expand_decl (tem);
13940     }
13941
13942   return tem;
13943 }
13944
13945 /* Create the FUNCTION_DECL for a function definition.
13946    DECLSPECS and DECLARATOR are the parts of the declaration;
13947    they describe the function's name and the type it returns,
13948    but twisted together in a fashion that parallels the syntax of C.
13949
13950    This function creates a binding context for the function body
13951    as well as setting up the FUNCTION_DECL in current_function_decl.
13952
13953    Returns 1 on success.  If the DECLARATOR is not suitable for a function
13954    (it defines a datum instead), we return 0, which tells
13955    yyparse to report a parse error.
13956
13957    NESTED is nonzero for a function nested within another function.  */
13958
13959 static void
13960 start_function (tree name, tree type, int nested, int public)
13961 {
13962   tree decl1;
13963   tree restype;
13964   int old_immediate_size_expand = immediate_size_expand;
13965
13966   named_labels = 0;
13967   shadowed_labels = 0;
13968
13969   /* Don't expand any sizes in the return type of the function.  */
13970   immediate_size_expand = 0;
13971
13972   if (nested)
13973     {
13974       assert (!public);
13975       assert (current_function_decl != NULL_TREE);
13976       assert (DECL_CONTEXT (current_function_decl) == NULL_TREE);
13977     }
13978   else
13979     {
13980       assert (current_function_decl == NULL_TREE);
13981     }
13982
13983   if (TREE_CODE (type) == ERROR_MARK)
13984     decl1 = current_function_decl = error_mark_node;
13985   else
13986     {
13987       decl1 = build_decl (FUNCTION_DECL,
13988                           name,
13989                           type);
13990       TREE_PUBLIC (decl1) = public ? 1 : 0;
13991       if (nested)
13992         DECL_INLINE (decl1) = 1;
13993       TREE_STATIC (decl1) = 1;
13994       DECL_EXTERNAL (decl1) = 0;
13995
13996       announce_function (decl1);
13997
13998       /* Make the init_value nonzero so pushdecl knows this is not tentative.
13999          error_mark_node is replaced below (in poplevel) with the BLOCK.  */
14000       DECL_INITIAL (decl1) = error_mark_node;
14001
14002       /* Record the decl so that the function name is defined. If we already have
14003          a decl for this name, and it is a FUNCTION_DECL, use the old decl.  */
14004
14005       current_function_decl = pushdecl (decl1);
14006     }
14007
14008   if (!nested)
14009     ffecom_outer_function_decl_ = current_function_decl;
14010
14011   pushlevel (0);
14012   current_binding_level->prep_state = 2;
14013
14014   if (TREE_CODE (current_function_decl) != ERROR_MARK)
14015     {
14016       make_decl_rtl (current_function_decl, NULL);
14017
14018       restype = TREE_TYPE (TREE_TYPE (current_function_decl));
14019       DECL_RESULT (current_function_decl)
14020         = build_decl (RESULT_DECL, NULL_TREE, restype);
14021     }
14022
14023   if (!nested && (TREE_CODE (current_function_decl) != ERROR_MARK))
14024     TREE_ADDRESSABLE (current_function_decl) = 1;
14025
14026   immediate_size_expand = old_immediate_size_expand;
14027 }
14028 \f
14029 /* Here are the public functions the GNU back end needs.  */
14030
14031 tree
14032 convert (type, expr)
14033      tree type, expr;
14034 {
14035   register tree e = expr;
14036   register enum tree_code code = TREE_CODE (type);
14037
14038   if (type == TREE_TYPE (e)
14039       || TREE_CODE (e) == ERROR_MARK)
14040     return e;
14041   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
14042     return fold (build1 (NOP_EXPR, type, e));
14043   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
14044       || code == ERROR_MARK)
14045     return error_mark_node;
14046   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
14047     {
14048       assert ("void value not ignored as it ought to be" == NULL);
14049       return error_mark_node;
14050     }
14051   if (code == VOID_TYPE)
14052     return build1 (CONVERT_EXPR, type, e);
14053   if ((code != RECORD_TYPE)
14054       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
14055     e = ffecom_1 (REALPART_EXPR, TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e))),
14056                   e);
14057   if (code == INTEGER_TYPE || code == ENUMERAL_TYPE)
14058     return fold (convert_to_integer (type, e));
14059   if (code == POINTER_TYPE)
14060     return fold (convert_to_pointer (type, e));
14061   if (code == REAL_TYPE)
14062     return fold (convert_to_real (type, e));
14063   if (code == COMPLEX_TYPE)
14064     return fold (convert_to_complex (type, e));
14065   if (code == RECORD_TYPE)
14066     return fold (ffecom_convert_to_complex_ (type, e));
14067
14068   assert ("conversion to non-scalar type requested" == NULL);
14069   return error_mark_node;
14070 }
14071
14072 /* integrate_decl_tree calls this function, but since we don't use the
14073    DECL_LANG_SPECIFIC field, this is a no-op.  */
14074
14075 void
14076 copy_lang_decl (node)
14077      tree node UNUSED;
14078 {
14079 }
14080
14081 /* Return the list of declarations of the current level.
14082    Note that this list is in reverse order unless/until
14083    you nreverse it; and when you do nreverse it, you must
14084    store the result back using `storedecls' or you will lose.  */
14085
14086 tree
14087 getdecls ()
14088 {
14089   return current_binding_level->names;
14090 }
14091
14092 /* Nonzero if we are currently in the global binding level.  */
14093
14094 int
14095 global_bindings_p ()
14096 {
14097   return current_binding_level == global_binding_level;
14098 }
14099
14100 /* Print an error message for invalid use of an incomplete type.
14101    VALUE is the expression that was used (or 0 if that isn't known)
14102    and TYPE is the type that was invalid.  */
14103
14104 void
14105 incomplete_type_error (value, type)
14106      tree value UNUSED;
14107      tree type;
14108 {
14109   if (TREE_CODE (type) == ERROR_MARK)
14110     return;
14111
14112   assert ("incomplete type?!?" == NULL);
14113 }
14114
14115 /* Mark ARG for GC.  */
14116 static void
14117 mark_binding_level (void *arg)
14118 {
14119   struct binding_level *level = *(struct binding_level **) arg;
14120
14121   while (level)
14122     {
14123       ggc_mark_tree (level->names);
14124       ggc_mark_tree (level->blocks);
14125       ggc_mark_tree (level->this_block);
14126       level = level->level_chain;
14127     }
14128 }
14129
14130 void
14131 init_decl_processing ()
14132 {
14133   static tree *const tree_roots[] = {
14134     &current_function_decl,
14135     &string_type_node,
14136     &ffecom_tree_fun_type_void,
14137     &ffecom_integer_zero_node,
14138     &ffecom_integer_one_node,
14139     &ffecom_tree_subr_type,
14140     &ffecom_tree_ptr_to_subr_type,
14141     &ffecom_tree_blockdata_type,
14142     &ffecom_tree_xargc_,
14143     &ffecom_f2c_integer_type_node,
14144     &ffecom_f2c_ptr_to_integer_type_node,
14145     &ffecom_f2c_address_type_node,
14146     &ffecom_f2c_real_type_node,
14147     &ffecom_f2c_ptr_to_real_type_node,
14148     &ffecom_f2c_doublereal_type_node,
14149     &ffecom_f2c_complex_type_node,
14150     &ffecom_f2c_doublecomplex_type_node,
14151     &ffecom_f2c_longint_type_node,
14152     &ffecom_f2c_logical_type_node,
14153     &ffecom_f2c_flag_type_node,
14154     &ffecom_f2c_ftnlen_type_node,
14155     &ffecom_f2c_ftnlen_zero_node,
14156     &ffecom_f2c_ftnlen_one_node,
14157     &ffecom_f2c_ftnlen_two_node,
14158     &ffecom_f2c_ptr_to_ftnlen_type_node,
14159     &ffecom_f2c_ftnint_type_node,
14160     &ffecom_f2c_ptr_to_ftnint_type_node,
14161     &ffecom_outer_function_decl_,
14162     &ffecom_previous_function_decl_,
14163     &ffecom_which_entrypoint_decl_,
14164     &ffecom_float_zero_,
14165     &ffecom_float_half_,
14166     &ffecom_double_zero_,
14167     &ffecom_double_half_,
14168     &ffecom_func_result_,
14169     &ffecom_func_length_,
14170     &ffecom_multi_type_node_,
14171     &ffecom_multi_retval_,
14172     &named_labels,
14173     &shadowed_labels
14174   };
14175   size_t i;
14176
14177   malloc_init ();
14178
14179   /* Record our roots.  */
14180   for (i = 0; i < ARRAY_SIZE (tree_roots); i++)
14181     ggc_add_tree_root (tree_roots[i], 1);
14182   ggc_add_tree_root (&ffecom_tree_type[0][0],
14183                      FFEINFO_basictype*FFEINFO_kindtype);
14184   ggc_add_tree_root (&ffecom_tree_fun_type[0][0],
14185                      FFEINFO_basictype*FFEINFO_kindtype);
14186   ggc_add_tree_root (&ffecom_tree_ptr_to_fun_type[0][0],
14187                      FFEINFO_basictype*FFEINFO_kindtype);
14188   ggc_add_tree_root (ffecom_gfrt_, FFECOM_gfrt);
14189   ggc_add_root (&current_binding_level, 1, sizeof current_binding_level,
14190                 mark_binding_level);
14191   ggc_add_root (&free_binding_level, 1, sizeof current_binding_level,
14192                 mark_binding_level);
14193   ggc_add_root (&tracker_head, 1, sizeof tracker_head, mark_tracker_head);
14194
14195   ffe_init_0 ();
14196 }
14197
14198 const char *
14199 init_parse (filename)
14200      const char *filename;
14201 {
14202   /* Open input file.  */
14203   if (filename == 0 || !strcmp (filename, "-"))
14204     {
14205       finput = stdin;
14206       filename = "stdin";
14207     }
14208   else
14209     finput = fopen (filename, "r");
14210   if (finput == 0)
14211     fatal_io_error ("can't open %s", filename);
14212
14213 #ifdef IO_BUFFER_SIZE
14214   setvbuf (finput, (char *) xmalloc (IO_BUFFER_SIZE), _IOFBF, IO_BUFFER_SIZE);
14215 #endif
14216
14217   /* Make identifier nodes long enough for the language-specific slots.  */
14218   set_identifier_size (sizeof (struct lang_identifier));
14219   decl_printable_name = lang_printable_name;
14220   print_error_function = lang_print_error_function;
14221
14222   return filename;
14223 }
14224
14225 void
14226 finish_parse ()
14227 {
14228   fclose (finput);
14229 }
14230
14231 /* Delete the node BLOCK from the current binding level.
14232    This is used for the block inside a stmt expr ({...})
14233    so that the block can be reinserted where appropriate.  */
14234
14235 static void
14236 delete_block (block)
14237      tree block;
14238 {
14239   tree t;
14240   if (current_binding_level->blocks == block)
14241     current_binding_level->blocks = TREE_CHAIN (block);
14242   for (t = current_binding_level->blocks; t;)
14243     {
14244       if (TREE_CHAIN (t) == block)
14245         TREE_CHAIN (t) = TREE_CHAIN (block);
14246       else
14247         t = TREE_CHAIN (t);
14248     }
14249   TREE_CHAIN (block) = NULL;
14250   /* Clear TREE_USED which is always set by poplevel.
14251      The flag is set again if insert_block is called.  */
14252   TREE_USED (block) = 0;
14253 }
14254
14255 void
14256 insert_block (block)
14257      tree block;
14258 {
14259   TREE_USED (block) = 1;
14260   current_binding_level->blocks
14261     = chainon (current_binding_level->blocks, block);
14262 }
14263
14264 /* Each front end provides its own.  */
14265 static void ffe_init PARAMS ((void));
14266 static void ffe_finish PARAMS ((void));
14267 static void ffe_init_options PARAMS ((void));
14268
14269 #undef  LANG_HOOKS_INIT
14270 #define LANG_HOOKS_INIT                 ffe_init
14271 #undef  LANG_HOOKS_FINISH
14272 #define LANG_HOOKS_FINISH               ffe_finish
14273 #undef  LANG_HOOKS_INIT_OPTIONS
14274 #define LANG_HOOKS_INIT_OPTIONS         ffe_init_options
14275 #undef  LANG_HOOKS_DECODE_OPTION
14276 #define LANG_HOOKS_DECODE_OPTION        ffe_decode_option
14277
14278 /* We do not wish to use alias-set based aliasing at all.  Used in the
14279    extreme (every object with its own set, with equivalences recorded) it
14280    might be helpful, but there are problems when it comes to inlining.  We
14281    get on ok with flag_argument_noalias, and alias-set aliasing does
14282    currently limit how stack slots can be reused, which is a lose.  */
14283 #undef LANG_HOOKS_GET_ALIAS_SET
14284 #define LANG_HOOKS_GET_ALIAS_SET hook_get_alias_set_0
14285
14286 struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER;
14287
14288 /* used by print-tree.c */
14289
14290 void
14291 lang_print_xnode (file, node, indent)
14292      FILE *file UNUSED;
14293      tree node UNUSED;
14294      int indent UNUSED;
14295 {
14296 }
14297
14298 static void
14299 ffe_finish ()
14300 {
14301   ffe_terminate_0 ();
14302
14303   if (ffe_is_ffedebug ())
14304     malloc_pool_display (malloc_pool_image ());
14305 }
14306
14307 const char *
14308 lang_identify ()
14309 {
14310   return "f77";
14311 }
14312
14313 static void
14314 ffe_init_options ()
14315 {
14316   /* Set default options for Fortran.  */
14317   flag_move_all_movables = 1;
14318   flag_reduce_all_givs = 1;
14319   flag_argument_noalias = 2;
14320   flag_merge_constants = 2;
14321   flag_errno_math = 0;
14322   flag_complex_divide_method = 1;
14323 }
14324
14325 static void
14326 ffe_init ()
14327 {
14328   /* If the file is output from cpp, it should contain a first line
14329      `# 1 "real-filename"', and the current design of gcc (toplev.c
14330      in particular and the way it sets up information relied on by
14331      INCLUDE) requires that we read this now, and store the
14332      "real-filename" info in master_input_filename.  Ask the lexer
14333      to try doing this.  */
14334   ffelex_hash_kludge (finput);
14335 }
14336
14337 int
14338 mark_addressable (exp)
14339      tree exp;
14340 {
14341   register tree x = exp;
14342   while (1)
14343     switch (TREE_CODE (x))
14344       {
14345       case ADDR_EXPR:
14346       case COMPONENT_REF:
14347       case ARRAY_REF:
14348         x = TREE_OPERAND (x, 0);
14349         break;
14350
14351       case CONSTRUCTOR:
14352         TREE_ADDRESSABLE (x) = 1;
14353         return 1;
14354
14355       case VAR_DECL:
14356       case CONST_DECL:
14357       case PARM_DECL:
14358       case RESULT_DECL:
14359         if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x)
14360             && DECL_NONLOCAL (x))
14361           {
14362             if (TREE_PUBLIC (x))
14363               {
14364                 assert ("address of global register var requested" == NULL);
14365                 return 0;
14366               }
14367             assert ("address of register variable requested" == NULL);
14368           }
14369         else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x))
14370           {
14371             if (TREE_PUBLIC (x))
14372               {
14373                 assert ("address of global register var requested" == NULL);
14374                 return 0;
14375               }
14376             assert ("address of register var requested" == NULL);
14377           }
14378         put_var_into_stack (x);
14379
14380         /* drops in */
14381       case FUNCTION_DECL:
14382         TREE_ADDRESSABLE (x) = 1;
14383 #if 0                           /* poplevel deals with this now.  */
14384         if (DECL_CONTEXT (x) == 0)
14385           TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x)) = 1;
14386 #endif
14387
14388       default:
14389         return 1;
14390       }
14391 }
14392
14393 /* If DECL has a cleanup, build and return that cleanup here.
14394    This is a callback called by expand_expr.  */
14395
14396 tree
14397 maybe_build_cleanup (decl)
14398      tree decl UNUSED;
14399 {
14400   /* There are no cleanups in Fortran.  */
14401   return NULL_TREE;
14402 }
14403
14404 /* Exit a binding level.
14405    Pop the level off, and restore the state of the identifier-decl mappings
14406    that were in effect when this level was entered.
14407
14408    If KEEP is nonzero, this level had explicit declarations, so
14409    and create a "block" (a BLOCK node) for the level
14410    to record its declarations and subblocks for symbol table output.
14411
14412    If FUNCTIONBODY is nonzero, this level is the body of a function,
14413    so create a block as if KEEP were set and also clear out all
14414    label names.
14415
14416    If REVERSE is nonzero, reverse the order of decls before putting
14417    them into the BLOCK.  */
14418
14419 tree
14420 poplevel (keep, reverse, functionbody)
14421      int keep;
14422      int reverse;
14423      int functionbody;
14424 {
14425   register tree link;
14426   /* The chain of decls was accumulated in reverse order.
14427      Put it into forward order, just for cleanliness.  */
14428   tree decls;
14429   tree subblocks = current_binding_level->blocks;
14430   tree block = 0;
14431   tree decl;
14432   int block_previously_created;
14433
14434   /* Get the decls in the order they were written.
14435      Usually current_binding_level->names is in reverse order.
14436      But parameter decls were previously put in forward order.  */
14437
14438   if (reverse)
14439     current_binding_level->names
14440       = decls = nreverse (current_binding_level->names);
14441   else
14442     decls = current_binding_level->names;
14443
14444   /* Output any nested inline functions within this block
14445      if they weren't already output.  */
14446
14447   for (decl = decls; decl; decl = TREE_CHAIN (decl))
14448     if (TREE_CODE (decl) == FUNCTION_DECL
14449         && ! TREE_ASM_WRITTEN (decl)
14450         && DECL_INITIAL (decl) != 0
14451         && TREE_ADDRESSABLE (decl))
14452       {
14453         /* If this decl was copied from a file-scope decl
14454            on account of a block-scope extern decl,
14455            propagate TREE_ADDRESSABLE to the file-scope decl.
14456
14457            DECL_ABSTRACT_ORIGIN can be set to itself if warn_return_type is
14458            true, since then the decl goes through save_for_inline_copying.  */
14459         if (DECL_ABSTRACT_ORIGIN (decl) != 0
14460             && DECL_ABSTRACT_ORIGIN (decl) != decl)
14461           TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl)) = 1;
14462         else if (DECL_SAVED_INSNS (decl) != 0)
14463           {
14464             push_function_context ();
14465             output_inline_function (decl);
14466             pop_function_context ();
14467           }
14468       }
14469
14470   /* If there were any declarations or structure tags in that level,
14471      or if this level is a function body,
14472      create a BLOCK to record them for the life of this function.  */
14473
14474   block = 0;
14475   block_previously_created = (current_binding_level->this_block != 0);
14476   if (block_previously_created)
14477     block = current_binding_level->this_block;
14478   else if (keep || functionbody)
14479     block = make_node (BLOCK);
14480   if (block != 0)
14481     {
14482       BLOCK_VARS (block) = decls;
14483       BLOCK_SUBBLOCKS (block) = subblocks;
14484     }
14485
14486   /* In each subblock, record that this is its superior.  */
14487
14488   for (link = subblocks; link; link = TREE_CHAIN (link))
14489     BLOCK_SUPERCONTEXT (link) = block;
14490
14491   /* Clear out the meanings of the local variables of this level.  */
14492
14493   for (link = decls; link; link = TREE_CHAIN (link))
14494     {
14495       if (DECL_NAME (link) != 0)
14496         {
14497           /* If the ident. was used or addressed via a local extern decl,
14498              don't forget that fact.  */
14499           if (DECL_EXTERNAL (link))
14500             {
14501               if (TREE_USED (link))
14502                 TREE_USED (DECL_NAME (link)) = 1;
14503               if (TREE_ADDRESSABLE (link))
14504                 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (link)) = 1;
14505             }
14506           IDENTIFIER_LOCAL_VALUE (DECL_NAME (link)) = 0;
14507         }
14508     }
14509
14510   /* If the level being exited is the top level of a function,
14511      check over all the labels, and clear out the current
14512      (function local) meanings of their names.  */
14513
14514   if (functionbody)
14515     {
14516       /* If this is the top level block of a function,
14517          the vars are the function's parameters.
14518          Don't leave them in the BLOCK because they are
14519          found in the FUNCTION_DECL instead.  */
14520
14521       BLOCK_VARS (block) = 0;
14522     }
14523
14524   /* Pop the current level, and free the structure for reuse.  */
14525
14526   {
14527     register struct binding_level *level = current_binding_level;
14528     current_binding_level = current_binding_level->level_chain;
14529
14530     level->level_chain = free_binding_level;
14531     free_binding_level = level;
14532   }
14533
14534   /* Dispose of the block that we just made inside some higher level.  */
14535   if (functionbody
14536       && current_function_decl != error_mark_node)
14537     DECL_INITIAL (current_function_decl) = block;
14538   else if (block)
14539     {
14540       if (!block_previously_created)
14541         current_binding_level->blocks
14542           = chainon (current_binding_level->blocks, block);
14543     }
14544   /* If we did not make a block for the level just exited,
14545      any blocks made for inner levels
14546      (since they cannot be recorded as subblocks in that level)
14547      must be carried forward so they will later become subblocks
14548      of something else.  */
14549   else if (subblocks)
14550     current_binding_level->blocks
14551       = chainon (current_binding_level->blocks, subblocks);
14552
14553   if (block)
14554     TREE_USED (block) = 1;
14555   return block;
14556 }
14557
14558 void
14559 print_lang_decl (file, node, indent)
14560      FILE *file UNUSED;
14561      tree node UNUSED;
14562      int indent UNUSED;
14563 {
14564 }
14565
14566 void
14567 print_lang_identifier (file, node, indent)
14568      FILE *file;
14569      tree node;
14570      int indent;
14571 {
14572   print_node (file, "global", IDENTIFIER_GLOBAL_VALUE (node), indent + 4);
14573   print_node (file, "local", IDENTIFIER_LOCAL_VALUE (node), indent + 4);
14574 }
14575
14576 void
14577 print_lang_statistics ()
14578 {
14579 }
14580
14581 void
14582 print_lang_type (file, node, indent)
14583      FILE *file UNUSED;
14584      tree node UNUSED;
14585      int indent UNUSED;
14586 {
14587 }
14588
14589 /* Record a decl-node X as belonging to the current lexical scope.
14590    Check for errors (such as an incompatible declaration for the same
14591    name already seen in the same scope).
14592
14593    Returns either X or an old decl for the same name.
14594    If an old decl is returned, it may have been smashed
14595    to agree with what X says.  */
14596
14597 tree
14598 pushdecl (x)
14599      tree x;
14600 {
14601   register tree t;
14602   register tree name = DECL_NAME (x);
14603   register struct binding_level *b = current_binding_level;
14604
14605   if ((TREE_CODE (x) == FUNCTION_DECL)
14606       && (DECL_INITIAL (x) == 0)
14607       && DECL_EXTERNAL (x))
14608     DECL_CONTEXT (x) = NULL_TREE;
14609   else
14610     DECL_CONTEXT (x) = current_function_decl;
14611
14612   if (name)
14613     {
14614       if (IDENTIFIER_INVENTED (name))
14615         {
14616           DECL_ARTIFICIAL (x) = 1;
14617           DECL_IN_SYSTEM_HEADER (x) = 1;
14618         }
14619
14620       t = lookup_name_current_level (name);
14621
14622       assert ((t == NULL_TREE) || (DECL_CONTEXT (x) == NULL_TREE));
14623
14624       /* Don't push non-parms onto list for parms until we understand
14625          why we're doing this and whether it works.  */
14626
14627       assert ((b == global_binding_level)
14628               || !ffecom_transform_only_dummies_
14629               || TREE_CODE (x) == PARM_DECL);
14630
14631       if ((t != NULL_TREE) && duplicate_decls (x, t))
14632         return t;
14633
14634       /* If we are processing a typedef statement, generate a whole new
14635          ..._TYPE node (which will be just an variant of the existing
14636          ..._TYPE node with identical properties) and then install the
14637          TYPE_DECL node generated to represent the typedef name as the
14638          TYPE_NAME of this brand new (duplicate) ..._TYPE node.
14639
14640          The whole point here is to end up with a situation where each and every
14641          ..._TYPE node the compiler creates will be uniquely associated with
14642          AT MOST one node representing a typedef name. This way, even though
14643          the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL
14644          (i.e. "typedef name") nodes very early on, later parts of the
14645          compiler can always do the reverse translation and get back the
14646          corresponding typedef name.  For example, given:
14647
14648          typedef struct S MY_TYPE; MY_TYPE object;
14649
14650          Later parts of the compiler might only know that `object' was of type
14651          `struct S' if it were not for code just below.  With this code
14652          however, later parts of the compiler see something like:
14653
14654          struct S' == struct S typedef struct S' MY_TYPE; struct S' object;
14655
14656          And they can then deduce (from the node for type struct S') that the
14657          original object declaration was:
14658
14659          MY_TYPE object;
14660
14661          Being able to do this is important for proper support of protoize, and
14662          also for generating precise symbolic debugging information which
14663          takes full account of the programmer's (typedef) vocabulary.
14664
14665          Obviously, we don't want to generate a duplicate ..._TYPE node if the
14666          TYPE_DECL node that we are now processing really represents a
14667          standard built-in type.
14668
14669          Since all standard types are effectively declared at line zero in the
14670          source file, we can easily check to see if we are working on a
14671          standard type by checking the current value of lineno.  */
14672
14673       if (TREE_CODE (x) == TYPE_DECL)
14674         {
14675           if (DECL_SOURCE_LINE (x) == 0)
14676             {
14677               if (TYPE_NAME (TREE_TYPE (x)) == 0)
14678                 TYPE_NAME (TREE_TYPE (x)) = x;
14679             }
14680           else if (TREE_TYPE (x) != error_mark_node)
14681             {
14682               tree tt = TREE_TYPE (x);
14683
14684               tt = build_type_copy (tt);
14685               TYPE_NAME (tt) = x;
14686               TREE_TYPE (x) = tt;
14687             }
14688         }
14689
14690       /* This name is new in its binding level. Install the new declaration
14691          and return it.  */
14692       if (b == global_binding_level)
14693         IDENTIFIER_GLOBAL_VALUE (name) = x;
14694       else
14695         IDENTIFIER_LOCAL_VALUE (name) = x;
14696     }
14697
14698   /* Put decls on list in reverse order. We will reverse them later if
14699      necessary.  */
14700   TREE_CHAIN (x) = b->names;
14701   b->names = x;
14702
14703   return x;
14704 }
14705
14706 /* Nonzero if the current level needs to have a BLOCK made.  */
14707
14708 static int
14709 kept_level_p ()
14710 {
14711   tree decl;
14712
14713   for (decl = current_binding_level->names;
14714        decl;
14715        decl = TREE_CHAIN (decl))
14716     {
14717       if (TREE_USED (decl) || TREE_CODE (decl) != VAR_DECL
14718           || (DECL_NAME (decl) && ! DECL_ARTIFICIAL (decl)))
14719         /* Currently, there aren't supposed to be non-artificial names
14720            at other than the top block for a function -- they're
14721            believed to always be temps.  But it's wise to check anyway.  */
14722         return 1;
14723     }
14724   return 0;
14725 }
14726
14727 /* Enter a new binding level.
14728    If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
14729    not for that of tags.  */
14730
14731 void
14732 pushlevel (tag_transparent)
14733      int tag_transparent;
14734 {
14735   register struct binding_level *newlevel = NULL_BINDING_LEVEL;
14736
14737   assert (! tag_transparent);
14738
14739   if (current_binding_level == global_binding_level)
14740     {
14741       named_labels = 0;
14742     }
14743
14744   /* Reuse or create a struct for this binding level.  */
14745
14746   if (free_binding_level)
14747     {
14748       newlevel = free_binding_level;
14749       free_binding_level = free_binding_level->level_chain;
14750     }
14751   else
14752     {
14753       newlevel = make_binding_level ();
14754     }
14755
14756   /* Add this level to the front of the chain (stack) of levels that
14757      are active.  */
14758
14759   *newlevel = clear_binding_level;
14760   newlevel->level_chain = current_binding_level;
14761   current_binding_level = newlevel;
14762 }
14763
14764 /* Set the BLOCK node for the innermost scope
14765    (the one we are currently in).  */
14766
14767 void
14768 set_block (block)
14769      register tree block;
14770 {
14771   current_binding_level->this_block = block;
14772   current_binding_level->names = chainon (current_binding_level->names,
14773                                           BLOCK_VARS (block));
14774   current_binding_level->blocks = chainon (current_binding_level->blocks,
14775                                            BLOCK_SUBBLOCKS (block));
14776 }
14777
14778 /* ~~gcc/tree.h *should* declare this, because toplev.c references it.  */
14779
14780 /* Can't 'yydebug' a front end not generated by yacc/bison!  */
14781
14782 void
14783 set_yydebug (value)
14784      int value;
14785 {
14786   if (value)
14787     fprintf (stderr, "warning: no yacc/bison-generated output to debug!\n");
14788 }
14789
14790 tree
14791 signed_or_unsigned_type (unsignedp, type)
14792      int unsignedp;
14793      tree type;
14794 {
14795   tree type2;
14796
14797   if (! INTEGRAL_TYPE_P (type))
14798     return type;
14799   if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node))
14800     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
14801   if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node))
14802     return unsignedp ? unsigned_type_node : integer_type_node;
14803   if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node))
14804     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
14805   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node))
14806     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
14807   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node))
14808     return (unsignedp ? long_long_unsigned_type_node
14809             : long_long_integer_type_node);
14810
14811   type2 = type_for_size (TYPE_PRECISION (type), unsignedp);
14812   if (type2 == NULL_TREE)
14813     return type;
14814
14815   return type2;
14816 }
14817
14818 tree
14819 signed_type (type)
14820      tree type;
14821 {
14822   tree type1 = TYPE_MAIN_VARIANT (type);
14823   ffeinfoKindtype kt;
14824   tree type2;
14825
14826   if (type1 == unsigned_char_type_node || type1 == char_type_node)
14827     return signed_char_type_node;
14828   if (type1 == unsigned_type_node)
14829     return integer_type_node;
14830   if (type1 == short_unsigned_type_node)
14831     return short_integer_type_node;
14832   if (type1 == long_unsigned_type_node)
14833     return long_integer_type_node;
14834   if (type1 == long_long_unsigned_type_node)
14835     return long_long_integer_type_node;
14836 #if 0   /* gcc/c-* files only */
14837   if (type1 == unsigned_intDI_type_node)
14838     return intDI_type_node;
14839   if (type1 == unsigned_intSI_type_node)
14840     return intSI_type_node;
14841   if (type1 == unsigned_intHI_type_node)
14842     return intHI_type_node;
14843   if (type1 == unsigned_intQI_type_node)
14844     return intQI_type_node;
14845 #endif
14846
14847   type2 = type_for_size (TYPE_PRECISION (type1), 0);
14848   if (type2 != NULL_TREE)
14849     return type2;
14850
14851   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
14852     {
14853       type2 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
14854
14855       if (type1 == type2)
14856         return ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
14857     }
14858
14859   return type;
14860 }
14861
14862 /* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
14863    or validate its data type for an `if' or `while' statement or ?..: exp.
14864
14865    This preparation consists of taking the ordinary
14866    representation of an expression expr and producing a valid tree
14867    boolean expression describing whether expr is nonzero.  We could
14868    simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
14869    but we optimize comparisons, &&, ||, and !.
14870
14871    The resulting type should always be `integer_type_node'.  */
14872
14873 tree
14874 truthvalue_conversion (expr)
14875      tree expr;
14876 {
14877   if (TREE_CODE (expr) == ERROR_MARK)
14878     return expr;
14879
14880 #if 0 /* This appears to be wrong for C++.  */
14881   /* These really should return error_mark_node after 2.4 is stable.
14882      But not all callers handle ERROR_MARK properly.  */
14883   switch (TREE_CODE (TREE_TYPE (expr)))
14884     {
14885     case RECORD_TYPE:
14886       error ("struct type value used where scalar is required");
14887       return integer_zero_node;
14888
14889     case UNION_TYPE:
14890       error ("union type value used where scalar is required");
14891       return integer_zero_node;
14892
14893     case ARRAY_TYPE:
14894       error ("array type value used where scalar is required");
14895       return integer_zero_node;
14896
14897     default:
14898       break;
14899     }
14900 #endif /* 0 */
14901
14902   switch (TREE_CODE (expr))
14903     {
14904       /* It is simpler and generates better code to have only TRUTH_*_EXPR
14905          or comparison expressions as truth values at this level.  */
14906 #if 0
14907     case COMPONENT_REF:
14908       /* A one-bit unsigned bit-field is already acceptable.  */
14909       if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr, 1)))
14910           && TREE_UNSIGNED (TREE_OPERAND (expr, 1)))
14911         return expr;
14912       break;
14913 #endif
14914
14915     case EQ_EXPR:
14916       /* It is simpler and generates better code to have only TRUTH_*_EXPR
14917          or comparison expressions as truth values at this level.  */
14918 #if 0
14919       if (integer_zerop (TREE_OPERAND (expr, 1)))
14920         return build_unary_op (TRUTH_NOT_EXPR, TREE_OPERAND (expr, 0), 0);
14921 #endif
14922     case NE_EXPR: case LE_EXPR: case GE_EXPR: case LT_EXPR: case GT_EXPR:
14923     case TRUTH_ANDIF_EXPR:
14924     case TRUTH_ORIF_EXPR:
14925     case TRUTH_AND_EXPR:
14926     case TRUTH_OR_EXPR:
14927     case TRUTH_XOR_EXPR:
14928       TREE_TYPE (expr) = integer_type_node;
14929       return expr;
14930
14931     case ERROR_MARK:
14932       return expr;
14933
14934     case INTEGER_CST:
14935       return integer_zerop (expr) ? integer_zero_node : integer_one_node;
14936
14937     case REAL_CST:
14938       return real_zerop (expr) ? integer_zero_node : integer_one_node;
14939
14940     case ADDR_EXPR:
14941       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 0)))
14942         return build (COMPOUND_EXPR, integer_type_node,
14943                       TREE_OPERAND (expr, 0), integer_one_node);
14944       else
14945         return integer_one_node;
14946
14947     case COMPLEX_EXPR:
14948       return ffecom_2 ((TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1))
14949                         ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
14950                        integer_type_node,
14951                        truthvalue_conversion (TREE_OPERAND (expr, 0)),
14952                        truthvalue_conversion (TREE_OPERAND (expr, 1)));
14953
14954     case NEGATE_EXPR:
14955     case ABS_EXPR:
14956     case FLOAT_EXPR:
14957     case FFS_EXPR:
14958       /* These don't change whether an object is non-zero or zero.  */
14959       return truthvalue_conversion (TREE_OPERAND (expr, 0));
14960
14961     case LROTATE_EXPR:
14962     case RROTATE_EXPR:
14963       /* These don't change whether an object is zero or non-zero, but
14964          we can't ignore them if their second arg has side-effects.  */
14965       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1)))
14966         return build (COMPOUND_EXPR, integer_type_node, TREE_OPERAND (expr, 1),
14967                       truthvalue_conversion (TREE_OPERAND (expr, 0)));
14968       else
14969         return truthvalue_conversion (TREE_OPERAND (expr, 0));
14970
14971     case COND_EXPR:
14972       /* Distribute the conversion into the arms of a COND_EXPR.  */
14973       return fold (build (COND_EXPR, integer_type_node, TREE_OPERAND (expr, 0),
14974                           truthvalue_conversion (TREE_OPERAND (expr, 1)),
14975                           truthvalue_conversion (TREE_OPERAND (expr, 2))));
14976
14977     case CONVERT_EXPR:
14978       /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
14979          since that affects how `default_conversion' will behave.  */
14980       if (TREE_CODE (TREE_TYPE (expr)) == REFERENCE_TYPE
14981           || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) == REFERENCE_TYPE)
14982         break;
14983       /* fall through... */
14984     case NOP_EXPR:
14985       /* If this is widening the argument, we can ignore it.  */
14986       if (TYPE_PRECISION (TREE_TYPE (expr))
14987           >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr, 0))))
14988         return truthvalue_conversion (TREE_OPERAND (expr, 0));
14989       break;
14990
14991     case MINUS_EXPR:
14992       /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize
14993          this case.  */
14994       if (TARGET_FLOAT_FORMAT == IEEE_FLOAT_FORMAT
14995           && TREE_CODE (TREE_TYPE (expr)) == REAL_TYPE)
14996         break;
14997       /* fall through... */
14998     case BIT_XOR_EXPR:
14999       /* This and MINUS_EXPR can be changed into a comparison of the
15000          two objects.  */
15001       if (TREE_TYPE (TREE_OPERAND (expr, 0))
15002           == TREE_TYPE (TREE_OPERAND (expr, 1)))
15003         return ffecom_2 (NE_EXPR, integer_type_node,
15004                          TREE_OPERAND (expr, 0),
15005                          TREE_OPERAND (expr, 1));
15006       return ffecom_2 (NE_EXPR, integer_type_node,
15007                        TREE_OPERAND (expr, 0),
15008                        fold (build1 (NOP_EXPR,
15009                                      TREE_TYPE (TREE_OPERAND (expr, 0)),
15010                                      TREE_OPERAND (expr, 1))));
15011
15012     case BIT_AND_EXPR:
15013       if (integer_onep (TREE_OPERAND (expr, 1)))
15014         return expr;
15015       break;
15016
15017     case MODIFY_EXPR:
15018 #if 0                           /* No such thing in Fortran. */
15019       if (warn_parentheses && C_EXP_ORIGINAL_CODE (expr) == MODIFY_EXPR)
15020         warning ("suggest parentheses around assignment used as truth value");
15021 #endif
15022       break;
15023
15024     default:
15025       break;
15026     }
15027
15028   if (TREE_CODE (TREE_TYPE (expr)) == COMPLEX_TYPE)
15029     return (ffecom_2
15030             ((TREE_SIDE_EFFECTS (expr)
15031               ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
15032              integer_type_node,
15033              truthvalue_conversion (ffecom_1 (REALPART_EXPR,
15034                                               TREE_TYPE (TREE_TYPE (expr)),
15035                                               expr)),
15036              truthvalue_conversion (ffecom_1 (IMAGPART_EXPR,
15037                                               TREE_TYPE (TREE_TYPE (expr)),
15038                                               expr))));
15039
15040   return ffecom_2 (NE_EXPR, integer_type_node,
15041                    expr,
15042                    convert (TREE_TYPE (expr), integer_zero_node));
15043 }
15044
15045 tree
15046 type_for_mode (mode, unsignedp)
15047      enum machine_mode mode;
15048      int unsignedp;
15049 {
15050   int i;
15051   int j;
15052   tree t;
15053
15054   if (mode == TYPE_MODE (integer_type_node))
15055     return unsignedp ? unsigned_type_node : integer_type_node;
15056
15057   if (mode == TYPE_MODE (signed_char_type_node))
15058     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15059
15060   if (mode == TYPE_MODE (short_integer_type_node))
15061     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15062
15063   if (mode == TYPE_MODE (long_integer_type_node))
15064     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15065
15066   if (mode == TYPE_MODE (long_long_integer_type_node))
15067     return unsignedp ? long_long_unsigned_type_node : long_long_integer_type_node;
15068
15069 #if HOST_BITS_PER_WIDE_INT >= 64
15070   if (mode == TYPE_MODE (intTI_type_node))
15071     return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
15072 #endif
15073
15074   if (mode == TYPE_MODE (float_type_node))
15075     return float_type_node;
15076
15077   if (mode == TYPE_MODE (double_type_node))
15078     return double_type_node;
15079
15080   if (mode == TYPE_MODE (build_pointer_type (char_type_node)))
15081     return build_pointer_type (char_type_node);
15082
15083   if (mode == TYPE_MODE (build_pointer_type (integer_type_node)))
15084     return build_pointer_type (integer_type_node);
15085
15086   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
15087     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
15088       {
15089         if (((t = ffecom_tree_type[i][j]) != NULL_TREE)
15090             && (mode == TYPE_MODE (t)))
15091           {
15092             if ((i == FFEINFO_basictypeINTEGER) && unsignedp)
15093               return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][j];
15094             else
15095               return t;
15096           }
15097       }
15098
15099   return 0;
15100 }
15101
15102 tree
15103 type_for_size (bits, unsignedp)
15104      unsigned bits;
15105      int unsignedp;
15106 {
15107   ffeinfoKindtype kt;
15108   tree type_node;
15109
15110   if (bits == TYPE_PRECISION (integer_type_node))
15111     return unsignedp ? unsigned_type_node : integer_type_node;
15112
15113   if (bits == TYPE_PRECISION (signed_char_type_node))
15114     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15115
15116   if (bits == TYPE_PRECISION (short_integer_type_node))
15117     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15118
15119   if (bits == TYPE_PRECISION (long_integer_type_node))
15120     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15121
15122   if (bits == TYPE_PRECISION (long_long_integer_type_node))
15123     return (unsignedp ? long_long_unsigned_type_node
15124             : long_long_integer_type_node);
15125
15126   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15127     {
15128       type_node = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15129
15130       if ((type_node != NULL_TREE) && (bits == TYPE_PRECISION (type_node)))
15131         return unsignedp ? ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]
15132           : type_node;
15133     }
15134
15135   return 0;
15136 }
15137
15138 tree
15139 unsigned_type (type)
15140      tree type;
15141 {
15142   tree type1 = TYPE_MAIN_VARIANT (type);
15143   ffeinfoKindtype kt;
15144   tree type2;
15145
15146   if (type1 == signed_char_type_node || type1 == char_type_node)
15147     return unsigned_char_type_node;
15148   if (type1 == integer_type_node)
15149     return unsigned_type_node;
15150   if (type1 == short_integer_type_node)
15151     return short_unsigned_type_node;
15152   if (type1 == long_integer_type_node)
15153     return long_unsigned_type_node;
15154   if (type1 == long_long_integer_type_node)
15155     return long_long_unsigned_type_node;
15156 #if 0   /* gcc/c-* files only */
15157   if (type1 == intDI_type_node)
15158     return unsigned_intDI_type_node;
15159   if (type1 == intSI_type_node)
15160     return unsigned_intSI_type_node;
15161   if (type1 == intHI_type_node)
15162     return unsigned_intHI_type_node;
15163   if (type1 == intQI_type_node)
15164     return unsigned_intQI_type_node;
15165 #endif
15166
15167   type2 = type_for_size (TYPE_PRECISION (type1), 1);
15168   if (type2 != NULL_TREE)
15169     return type2;
15170
15171   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15172     {
15173       type2 = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15174
15175       if (type1 == type2)
15176         return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
15177     }
15178
15179   return type;
15180 }
15181
15182 void
15183 lang_mark_tree (t)
15184      union tree_node *t ATTRIBUTE_UNUSED;
15185 {
15186   if (TREE_CODE (t) == IDENTIFIER_NODE)
15187     {
15188       struct lang_identifier *i = (struct lang_identifier *) t;
15189       ggc_mark_tree (IDENTIFIER_GLOBAL_VALUE (i));
15190       ggc_mark_tree (IDENTIFIER_LOCAL_VALUE (i));
15191       ggc_mark_tree (IDENTIFIER_LABEL_VALUE (i));
15192     }
15193   else if (TYPE_P (t) && TYPE_LANG_SPECIFIC (t))
15194     ggc_mark (TYPE_LANG_SPECIFIC (t));
15195 }
15196 \f
15197 /* From gcc/cccp.c, the code to handle -I.  */
15198
15199 /* Skip leading "./" from a directory name.
15200    This may yield the empty string, which represents the current directory.  */
15201
15202 static const char *
15203 skip_redundant_dir_prefix (const char *dir)
15204 {
15205   while (dir[0] == '.' && dir[1] == '/')
15206     for (dir += 2; *dir == '/'; dir++)
15207       continue;
15208   if (dir[0] == '.' && !dir[1])
15209     dir++;
15210   return dir;
15211 }
15212
15213 /* The file_name_map structure holds a mapping of file names for a
15214    particular directory.  This mapping is read from the file named
15215    FILE_NAME_MAP_FILE in that directory.  Such a file can be used to
15216    map filenames on a file system with severe filename restrictions,
15217    such as DOS.  The format of the file name map file is just a series
15218    of lines with two tokens on each line.  The first token is the name
15219    to map, and the second token is the actual name to use.  */
15220
15221 struct file_name_map
15222 {
15223   struct file_name_map *map_next;
15224   char *map_from;
15225   char *map_to;
15226 };
15227
15228 #define FILE_NAME_MAP_FILE "header.gcc"
15229
15230 /* Current maximum length of directory names in the search path
15231    for include files.  (Altered as we get more of them.)  */
15232
15233 static int max_include_len = 0;
15234
15235 struct file_name_list
15236   {
15237     struct file_name_list *next;
15238     char *fname;
15239     /* Mapping of file names for this directory.  */
15240     struct file_name_map *name_map;
15241     /* Non-zero if name_map is valid.  */
15242     int got_name_map;
15243   };
15244
15245 static struct file_name_list *include = NULL;   /* First dir to search */
15246 static struct file_name_list *last_include = NULL;      /* Last in chain */
15247
15248 /* I/O buffer structure.
15249    The `fname' field is nonzero for source files and #include files
15250    and for the dummy text used for -D and -U.
15251    It is zero for rescanning results of macro expansion
15252    and for expanding macro arguments.  */
15253 #define INPUT_STACK_MAX 400
15254 static struct file_buf {
15255   const char *fname;
15256   /* Filename specified with #line command.  */
15257   const char *nominal_fname;
15258   /* Record where in the search path this file was found.
15259      For #include_next.  */
15260   struct file_name_list *dir;
15261   ffewhereLine line;
15262   ffewhereColumn column;
15263 } instack[INPUT_STACK_MAX];
15264
15265 static int last_error_tick = 0;    /* Incremented each time we print it.  */
15266 static int input_file_stack_tick = 0;  /* Incremented when status changes.  */
15267
15268 /* Current nesting level of input sources.
15269    `instack[indepth]' is the level currently being read.  */
15270 static int indepth = -1;
15271
15272 typedef struct file_buf FILE_BUF;
15273
15274 typedef unsigned char U_CHAR;
15275
15276 /* table to tell if char can be part of a C identifier. */
15277 U_CHAR is_idchar[256];
15278 /* table to tell if char can be first char of a c identifier. */
15279 U_CHAR is_idstart[256];
15280 /* table to tell if c is horizontal space.  */
15281 U_CHAR is_hor_space[256];
15282 /* table to tell if c is horizontal or vertical space.  */
15283 static U_CHAR is_space[256];
15284
15285 #define SKIP_WHITE_SPACE(p) do { while (is_hor_space[*p]) p++; } while (0)
15286 #define SKIP_ALL_WHITE_SPACE(p) do { while (is_space[*p]) p++; } while (0)
15287
15288 /* Nonzero means -I- has been seen,
15289    so don't look for #include "foo" the source-file directory.  */
15290 static int ignore_srcdir;
15291
15292 #ifndef INCLUDE_LEN_FUDGE
15293 #define INCLUDE_LEN_FUDGE 0
15294 #endif
15295
15296 static void append_include_chain (struct file_name_list *first,
15297                                   struct file_name_list *last);
15298 static FILE *open_include_file (char *filename,
15299                                 struct file_name_list *searchptr);
15300 static void print_containing_files (ffebadSeverity sev);
15301 static char *read_filename_string (int ch, FILE *f);
15302 static struct file_name_map *read_name_map (const char *dirname);
15303
15304 /* Append a chain of `struct file_name_list's
15305    to the end of the main include chain.
15306    FIRST is the beginning of the chain to append, and LAST is the end.  */
15307
15308 static void
15309 append_include_chain (first, last)
15310      struct file_name_list *first, *last;
15311 {
15312   struct file_name_list *dir;
15313
15314   if (!first || !last)
15315     return;
15316
15317   if (include == 0)
15318     include = first;
15319   else
15320     last_include->next = first;
15321
15322   for (dir = first; ; dir = dir->next) {
15323     int len = strlen (dir->fname) + INCLUDE_LEN_FUDGE;
15324     if (len > max_include_len)
15325       max_include_len = len;
15326     if (dir == last)
15327       break;
15328   }
15329
15330   last->next = NULL;
15331   last_include = last;
15332 }
15333
15334 /* Try to open include file FILENAME.  SEARCHPTR is the directory
15335    being tried from the include file search path.  This function maps
15336    filenames on file systems based on information read by
15337    read_name_map.  */
15338
15339 static FILE *
15340 open_include_file (filename, searchptr)
15341      char *filename;
15342      struct file_name_list *searchptr;
15343 {
15344   register struct file_name_map *map;
15345   register char *from;
15346   char *p, *dir;
15347
15348   if (searchptr && ! searchptr->got_name_map)
15349     {
15350       searchptr->name_map = read_name_map (searchptr->fname
15351                                            ? searchptr->fname : ".");
15352       searchptr->got_name_map = 1;
15353     }
15354
15355   /* First check the mapping for the directory we are using.  */
15356   if (searchptr && searchptr->name_map)
15357     {
15358       from = filename;
15359       if (searchptr->fname)
15360         from += strlen (searchptr->fname) + 1;
15361       for (map = searchptr->name_map; map; map = map->map_next)
15362         {
15363           if (! strcmp (map->map_from, from))
15364             {
15365               /* Found a match.  */
15366               return fopen (map->map_to, "r");
15367             }
15368         }
15369     }
15370
15371   /* Try to find a mapping file for the particular directory we are
15372      looking in.  Thus #include <sys/types.h> will look up sys/types.h
15373      in /usr/include/header.gcc and look up types.h in
15374      /usr/include/sys/header.gcc.  */
15375   p = strrchr (filename, '/');
15376 #ifdef DIR_SEPARATOR
15377   if (! p) p = strrchr (filename, DIR_SEPARATOR);
15378   else {
15379     char *tmp = strrchr (filename, DIR_SEPARATOR);
15380     if (tmp != NULL && tmp > p) p = tmp;
15381   }
15382 #endif
15383   if (! p)
15384     p = filename;
15385   if (searchptr
15386       && searchptr->fname
15387       && strlen (searchptr->fname) == (size_t) (p - filename)
15388       && ! strncmp (searchptr->fname, filename, (int) (p - filename)))
15389     {
15390       /* FILENAME is in SEARCHPTR, which we've already checked.  */
15391       return fopen (filename, "r");
15392     }
15393
15394   if (p == filename)
15395     {
15396       from = filename;
15397       map = read_name_map (".");
15398     }
15399   else
15400     {
15401       dir = (char *) xmalloc (p - filename + 1);
15402       memcpy (dir, filename, p - filename);
15403       dir[p - filename] = '\0';
15404       from = p + 1;
15405       map = read_name_map (dir);
15406       free (dir);
15407     }
15408   for (; map; map = map->map_next)
15409     if (! strcmp (map->map_from, from))
15410       return fopen (map->map_to, "r");
15411
15412   return fopen (filename, "r");
15413 }
15414
15415 /* Print the file names and line numbers of the #include
15416    commands which led to the current file.  */
15417
15418 static void
15419 print_containing_files (ffebadSeverity sev)
15420 {
15421   FILE_BUF *ip = NULL;
15422   int i;
15423   int first = 1;
15424   const char *str1;
15425   const char *str2;
15426
15427   /* If stack of files hasn't changed since we last printed
15428      this info, don't repeat it.  */
15429   if (last_error_tick == input_file_stack_tick)
15430     return;
15431
15432   for (i = indepth; i >= 0; i--)
15433     if (instack[i].fname != NULL) {
15434       ip = &instack[i];
15435       break;
15436     }
15437
15438   /* Give up if we don't find a source file.  */
15439   if (ip == NULL)
15440     return;
15441
15442   /* Find the other, outer source files.  */
15443   for (i--; i >= 0; i--)
15444     if (instack[i].fname != NULL)
15445       {
15446         ip = &instack[i];
15447         if (first)
15448           {
15449             first = 0;
15450             str1 = "In file included";
15451           }
15452         else
15453           {
15454             str1 = "...          ...";
15455           }
15456
15457         if (i == 1)
15458           str2 = ":";
15459         else
15460           str2 = "";
15461
15462         ffebad_start_msg ("%A from %B at %0%C", sev);
15463         ffebad_here (0, ip->line, ip->column);
15464         ffebad_string (str1);
15465         ffebad_string (ip->nominal_fname);
15466         ffebad_string (str2);
15467         ffebad_finish ();
15468       }
15469
15470   /* Record we have printed the status as of this time.  */
15471   last_error_tick = input_file_stack_tick;
15472 }
15473
15474 /* Read a space delimited string of unlimited length from a stdio
15475    file.  */
15476
15477 static char *
15478 read_filename_string (ch, f)
15479      int ch;
15480      FILE *f;
15481 {
15482   char *alloc, *set;
15483   int len;
15484
15485   len = 20;
15486   set = alloc = xmalloc (len + 1);
15487   if (! is_space[ch])
15488     {
15489       *set++ = ch;
15490       while ((ch = getc (f)) != EOF && ! is_space[ch])
15491         {
15492           if (set - alloc == len)
15493             {
15494               len *= 2;
15495               alloc = xrealloc (alloc, len + 1);
15496               set = alloc + len / 2;
15497             }
15498           *set++ = ch;
15499         }
15500     }
15501   *set = '\0';
15502   ungetc (ch, f);
15503   return alloc;
15504 }
15505
15506 /* Read the file name map file for DIRNAME.  */
15507
15508 static struct file_name_map *
15509 read_name_map (dirname)
15510      const char *dirname;
15511 {
15512   /* This structure holds a linked list of file name maps, one per
15513      directory.  */
15514   struct file_name_map_list
15515     {
15516       struct file_name_map_list *map_list_next;
15517       char *map_list_name;
15518       struct file_name_map *map_list_map;
15519     };
15520   static struct file_name_map_list *map_list;
15521   register struct file_name_map_list *map_list_ptr;
15522   char *name;
15523   FILE *f;
15524   size_t dirlen;
15525   int separator_needed;
15526
15527   dirname = skip_redundant_dir_prefix (dirname);
15528
15529   for (map_list_ptr = map_list; map_list_ptr;
15530        map_list_ptr = map_list_ptr->map_list_next)
15531     if (! strcmp (map_list_ptr->map_list_name, dirname))
15532       return map_list_ptr->map_list_map;
15533
15534   map_list_ptr = ((struct file_name_map_list *)
15535                   xmalloc (sizeof (struct file_name_map_list)));
15536   map_list_ptr->map_list_name = xstrdup (dirname);
15537   map_list_ptr->map_list_map = NULL;
15538
15539   dirlen = strlen (dirname);
15540   separator_needed = dirlen != 0 && dirname[dirlen - 1] != '/';
15541   name = (char *) xmalloc (dirlen + strlen (FILE_NAME_MAP_FILE) + 2);
15542   strcpy (name, dirname);
15543   name[dirlen] = '/';
15544   strcpy (name + dirlen + separator_needed, FILE_NAME_MAP_FILE);
15545   f = fopen (name, "r");
15546   free (name);
15547   if (!f)
15548     map_list_ptr->map_list_map = NULL;
15549   else
15550     {
15551       int ch;
15552
15553       while ((ch = getc (f)) != EOF)
15554         {
15555           char *from, *to;
15556           struct file_name_map *ptr;
15557
15558           if (is_space[ch])
15559             continue;
15560           from = read_filename_string (ch, f);
15561           while ((ch = getc (f)) != EOF && is_hor_space[ch])
15562             ;
15563           to = read_filename_string (ch, f);
15564
15565           ptr = ((struct file_name_map *)
15566                  xmalloc (sizeof (struct file_name_map)));
15567           ptr->map_from = from;
15568
15569           /* Make the real filename absolute.  */
15570           if (*to == '/')
15571             ptr->map_to = to;
15572           else
15573             {
15574               ptr->map_to = xmalloc (dirlen + strlen (to) + 2);
15575               strcpy (ptr->map_to, dirname);
15576               ptr->map_to[dirlen] = '/';
15577               strcpy (ptr->map_to + dirlen + separator_needed, to);
15578               free (to);
15579             }
15580
15581           ptr->map_next = map_list_ptr->map_list_map;
15582           map_list_ptr->map_list_map = ptr;
15583
15584           while ((ch = getc (f)) != '\n')
15585             if (ch == EOF)
15586               break;
15587         }
15588       fclose (f);
15589     }
15590
15591   map_list_ptr->map_list_next = map_list;
15592   map_list = map_list_ptr;
15593
15594   return map_list_ptr->map_list_map;
15595 }
15596
15597 static void
15598 ffecom_file_ (const char *name)
15599 {
15600   FILE_BUF *fp;
15601
15602   /* Do partial setup of input buffer for the sake of generating
15603      early #line directives (when -g is in effect).  */
15604
15605   fp = &instack[++indepth];
15606   memset ((char *) fp, 0, sizeof (FILE_BUF));
15607   if (name == NULL)
15608     name = "";
15609   fp->nominal_fname = fp->fname = name;
15610 }
15611
15612 /* Initialize syntactic classifications of characters.  */
15613
15614 static void
15615 ffecom_initialize_char_syntax_ ()
15616 {
15617   register int i;
15618
15619   /*
15620    * Set up is_idchar and is_idstart tables.  These should be
15621    * faster than saying (is_alpha (c) || c == '_'), etc.
15622    * Set up these things before calling any routines tthat
15623    * refer to them.
15624    */
15625   for (i = 'a'; i <= 'z'; i++) {
15626     is_idchar[i - 'a' + 'A'] = 1;
15627     is_idchar[i] = 1;
15628     is_idstart[i - 'a' + 'A'] = 1;
15629     is_idstart[i] = 1;
15630   }
15631   for (i = '0'; i <= '9'; i++)
15632     is_idchar[i] = 1;
15633   is_idchar['_'] = 1;
15634   is_idstart['_'] = 1;
15635
15636   /* horizontal space table */
15637   is_hor_space[' '] = 1;
15638   is_hor_space['\t'] = 1;
15639   is_hor_space['\v'] = 1;
15640   is_hor_space['\f'] = 1;
15641   is_hor_space['\r'] = 1;
15642
15643   is_space[' '] = 1;
15644   is_space['\t'] = 1;
15645   is_space['\v'] = 1;
15646   is_space['\f'] = 1;
15647   is_space['\n'] = 1;
15648   is_space['\r'] = 1;
15649 }
15650
15651 static void
15652 ffecom_close_include_ (FILE *f)
15653 {
15654   fclose (f);
15655
15656   indepth--;
15657   input_file_stack_tick++;
15658
15659   ffewhere_line_kill (instack[indepth].line);
15660   ffewhere_column_kill (instack[indepth].column);
15661 }
15662
15663 static int
15664 ffecom_decode_include_option_ (char *spec)
15665 {
15666   struct file_name_list *dirtmp;
15667
15668   if (! ignore_srcdir && !strcmp (spec, "-"))
15669     ignore_srcdir = 1;
15670   else
15671     {
15672       dirtmp = (struct file_name_list *)
15673         xmalloc (sizeof (struct file_name_list));
15674       dirtmp->next = 0;         /* New one goes on the end */
15675       dirtmp->fname = spec;
15676       dirtmp->got_name_map = 0;
15677       if (spec[0] == 0)
15678         error ("Directory name must immediately follow -I");
15679       else
15680         append_include_chain (dirtmp, dirtmp);
15681     }
15682   return 1;
15683 }
15684
15685 /* Open INCLUDEd file.  */
15686
15687 static FILE *
15688 ffecom_open_include_ (char *name, ffewhereLine l, ffewhereColumn c)
15689 {
15690   char *fbeg = name;
15691   size_t flen = strlen (fbeg);
15692   struct file_name_list *search_start = include; /* Chain of dirs to search */
15693   struct file_name_list dsp[1]; /* First in chain, if #include "..." */
15694   struct file_name_list *searchptr = 0;
15695   char *fname;          /* Dynamically allocated fname buffer */
15696   FILE *f;
15697   FILE_BUF *fp;
15698
15699   if (flen == 0)
15700     return NULL;
15701
15702   dsp[0].fname = NULL;
15703
15704   /* If -I- was specified, don't search current dir, only spec'd ones. */
15705   if (!ignore_srcdir)
15706     {
15707       for (fp = &instack[indepth]; fp >= instack; fp--)
15708         {
15709           int n;
15710           char *ep;
15711           const char *nam;
15712
15713           if ((nam = fp->nominal_fname) != NULL)
15714             {
15715               /* Found a named file.  Figure out dir of the file,
15716                  and put it in front of the search list.  */
15717               dsp[0].next = search_start;
15718               search_start = dsp;
15719 #ifndef VMS
15720               ep = strrchr (nam, '/');
15721 #ifdef DIR_SEPARATOR
15722             if (ep == NULL) ep = strrchr (nam, DIR_SEPARATOR);
15723             else {
15724               char *tmp = strrchr (nam, DIR_SEPARATOR);
15725               if (tmp != NULL && tmp > ep) ep = tmp;
15726             }
15727 #endif
15728 #else                           /* VMS */
15729               ep = strrchr (nam, ']');
15730               if (ep == NULL) ep = strrchr (nam, '>');
15731               if (ep == NULL) ep = strrchr (nam, ':');
15732               if (ep != NULL) ep++;
15733 #endif                          /* VMS */
15734               if (ep != NULL)
15735                 {
15736                   n = ep - nam;
15737                   dsp[0].fname = (char *) xmalloc (n + 1);
15738                   strncpy (dsp[0].fname, nam, n);
15739                   dsp[0].fname[n] = '\0';
15740                   if (n + INCLUDE_LEN_FUDGE > max_include_len)
15741                     max_include_len = n + INCLUDE_LEN_FUDGE;
15742                 }
15743               else
15744                 dsp[0].fname = NULL; /* Current directory */
15745               dsp[0].got_name_map = 0;
15746               break;
15747             }
15748         }
15749     }
15750
15751   /* Allocate this permanently, because it gets stored in the definitions
15752      of macros.  */
15753   fname = xmalloc (max_include_len + flen + 4);
15754   /* + 2 above for slash and terminating null.  */
15755   /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED
15756      for g77 yet).  */
15757
15758   /* If specified file name is absolute, just open it.  */
15759
15760   if (*fbeg == '/'
15761 #ifdef DIR_SEPARATOR
15762       || *fbeg == DIR_SEPARATOR
15763 #endif
15764       )
15765     {
15766       strncpy (fname, (char *) fbeg, flen);
15767       fname[flen] = 0;
15768       f = open_include_file (fname, NULL);
15769     }
15770   else
15771     {
15772       f = NULL;
15773
15774       /* Search directory path, trying to open the file.
15775          Copy each filename tried into FNAME.  */
15776
15777       for (searchptr = search_start; searchptr; searchptr = searchptr->next)
15778         {
15779           if (searchptr->fname)
15780             {
15781               /* The empty string in a search path is ignored.
15782                  This makes it possible to turn off entirely
15783                  a standard piece of the list.  */
15784               if (searchptr->fname[0] == 0)
15785                 continue;
15786               strcpy (fname, skip_redundant_dir_prefix (searchptr->fname));
15787               if (fname[0] && fname[strlen (fname) - 1] != '/')
15788                 strcat (fname, "/");
15789               fname[strlen (fname) + flen] = 0;
15790             }
15791           else
15792             fname[0] = 0;
15793
15794           strncat (fname, fbeg, flen);
15795 #ifdef VMS
15796           /* Change this 1/2 Unix 1/2 VMS file specification into a
15797              full VMS file specification */
15798           if (searchptr->fname && (searchptr->fname[0] != 0))
15799             {
15800               /* Fix up the filename */
15801               hack_vms_include_specification (fname);
15802             }
15803           else
15804             {
15805               /* This is a normal VMS filespec, so use it unchanged.  */
15806               strncpy (fname, (char *) fbeg, flen);
15807               fname[flen] = 0;
15808 #if 0   /* Not for g77.  */
15809               /* if it's '#include filename', add the missing .h */
15810               if (strchr (fname, '.') == NULL)
15811                 strcat (fname, ".h");
15812 #endif
15813             }
15814 #endif /* VMS */
15815           f = open_include_file (fname, searchptr);
15816 #ifdef EACCES
15817           if (f == NULL && errno == EACCES)
15818             {
15819               print_containing_files (FFEBAD_severityWARNING);
15820               ffebad_start_msg ("At %0, INCLUDE file %A exists, but is not readable",
15821                                 FFEBAD_severityWARNING);
15822               ffebad_string (fname);
15823               ffebad_here (0, l, c);
15824               ffebad_finish ();
15825             }
15826 #endif
15827           if (f != NULL)
15828             break;
15829         }
15830     }
15831
15832   if (f == NULL)
15833     {
15834       /* A file that was not found.  */
15835
15836       strncpy (fname, (char *) fbeg, flen);
15837       fname[flen] = 0;
15838       print_containing_files (ffebad_severity (FFEBAD_OPEN_INCLUDE));
15839       ffebad_start (FFEBAD_OPEN_INCLUDE);
15840       ffebad_here (0, l, c);
15841       ffebad_string (fname);
15842       ffebad_finish ();
15843     }
15844
15845   if (dsp[0].fname != NULL)
15846     free (dsp[0].fname);
15847
15848   if (f == NULL)
15849     return NULL;
15850
15851   if (indepth >= (INPUT_STACK_MAX - 1))
15852     {
15853       print_containing_files (FFEBAD_severityFATAL);
15854       ffebad_start_msg ("At %0, INCLUDE nesting too deep",
15855                         FFEBAD_severityFATAL);
15856       ffebad_string (fname);
15857       ffebad_here (0, l, c);
15858       ffebad_finish ();
15859       return NULL;
15860     }
15861
15862   instack[indepth].line = ffewhere_line_use (l);
15863   instack[indepth].column = ffewhere_column_use (c);
15864
15865   fp = &instack[indepth + 1];
15866   memset ((char *) fp, 0, sizeof (FILE_BUF));
15867   fp->nominal_fname = fp->fname = fname;
15868   fp->dir = searchptr;
15869
15870   indepth++;
15871   input_file_stack_tick++;
15872
15873   return f;
15874 }
15875
15876 /**INDENT* (Do not reformat this comment even with -fca option.)
15877    Data-gathering files: Given the source file listed below, compiled with
15878    f2c I obtained the output file listed after that, and from the output
15879    file I derived the above code.
15880
15881 -------- (begin input file to f2c)
15882         implicit none
15883         character*10 A1,A2
15884         complex C1,C2
15885         integer I1,I2
15886         real R1,R2
15887         double precision D1,D2
15888 C
15889         call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2)
15890 c /
15891         call fooI(I1/I2)
15892         call fooR(R1/I1)
15893         call fooD(D1/I1)
15894         call fooC(C1/I1)
15895         call fooR(R1/R2)
15896         call fooD(R1/D1)
15897         call fooD(D1/D2)
15898         call fooD(D1/R1)
15899         call fooC(C1/C2)
15900         call fooC(C1/R1)
15901         call fooZ(C1/D1)
15902 c **
15903         call fooI(I1**I2)
15904         call fooR(R1**I1)
15905         call fooD(D1**I1)
15906         call fooC(C1**I1)
15907         call fooR(R1**R2)
15908         call fooD(R1**D1)
15909         call fooD(D1**D2)
15910         call fooD(D1**R1)
15911         call fooC(C1**C2)
15912         call fooC(C1**R1)
15913         call fooZ(C1**D1)
15914 c FFEINTRIN_impABS
15915         call fooR(ABS(R1))
15916 c FFEINTRIN_impACOS
15917         call fooR(ACOS(R1))
15918 c FFEINTRIN_impAIMAG
15919         call fooR(AIMAG(C1))
15920 c FFEINTRIN_impAINT
15921         call fooR(AINT(R1))
15922 c FFEINTRIN_impALOG
15923         call fooR(ALOG(R1))
15924 c FFEINTRIN_impALOG10
15925         call fooR(ALOG10(R1))
15926 c FFEINTRIN_impAMAX0
15927         call fooR(AMAX0(I1,I2))
15928 c FFEINTRIN_impAMAX1
15929         call fooR(AMAX1(R1,R2))
15930 c FFEINTRIN_impAMIN0
15931         call fooR(AMIN0(I1,I2))
15932 c FFEINTRIN_impAMIN1
15933         call fooR(AMIN1(R1,R2))
15934 c FFEINTRIN_impAMOD
15935         call fooR(AMOD(R1,R2))
15936 c FFEINTRIN_impANINT
15937         call fooR(ANINT(R1))
15938 c FFEINTRIN_impASIN
15939         call fooR(ASIN(R1))
15940 c FFEINTRIN_impATAN
15941         call fooR(ATAN(R1))
15942 c FFEINTRIN_impATAN2
15943         call fooR(ATAN2(R1,R2))
15944 c FFEINTRIN_impCABS
15945         call fooR(CABS(C1))
15946 c FFEINTRIN_impCCOS
15947         call fooC(CCOS(C1))
15948 c FFEINTRIN_impCEXP
15949         call fooC(CEXP(C1))
15950 c FFEINTRIN_impCHAR
15951         call fooA(CHAR(I1))
15952 c FFEINTRIN_impCLOG
15953         call fooC(CLOG(C1))
15954 c FFEINTRIN_impCONJG
15955         call fooC(CONJG(C1))
15956 c FFEINTRIN_impCOS
15957         call fooR(COS(R1))
15958 c FFEINTRIN_impCOSH
15959         call fooR(COSH(R1))
15960 c FFEINTRIN_impCSIN
15961         call fooC(CSIN(C1))
15962 c FFEINTRIN_impCSQRT
15963         call fooC(CSQRT(C1))
15964 c FFEINTRIN_impDABS
15965         call fooD(DABS(D1))
15966 c FFEINTRIN_impDACOS
15967         call fooD(DACOS(D1))
15968 c FFEINTRIN_impDASIN
15969         call fooD(DASIN(D1))
15970 c FFEINTRIN_impDATAN
15971         call fooD(DATAN(D1))
15972 c FFEINTRIN_impDATAN2
15973         call fooD(DATAN2(D1,D2))
15974 c FFEINTRIN_impDCOS
15975         call fooD(DCOS(D1))
15976 c FFEINTRIN_impDCOSH
15977         call fooD(DCOSH(D1))
15978 c FFEINTRIN_impDDIM
15979         call fooD(DDIM(D1,D2))
15980 c FFEINTRIN_impDEXP
15981         call fooD(DEXP(D1))
15982 c FFEINTRIN_impDIM
15983         call fooR(DIM(R1,R2))
15984 c FFEINTRIN_impDINT
15985         call fooD(DINT(D1))
15986 c FFEINTRIN_impDLOG
15987         call fooD(DLOG(D1))
15988 c FFEINTRIN_impDLOG10
15989         call fooD(DLOG10(D1))
15990 c FFEINTRIN_impDMAX1
15991         call fooD(DMAX1(D1,D2))
15992 c FFEINTRIN_impDMIN1
15993         call fooD(DMIN1(D1,D2))
15994 c FFEINTRIN_impDMOD
15995         call fooD(DMOD(D1,D2))
15996 c FFEINTRIN_impDNINT
15997         call fooD(DNINT(D1))
15998 c FFEINTRIN_impDPROD
15999         call fooD(DPROD(R1,R2))
16000 c FFEINTRIN_impDSIGN
16001         call fooD(DSIGN(D1,D2))
16002 c FFEINTRIN_impDSIN
16003         call fooD(DSIN(D1))
16004 c FFEINTRIN_impDSINH
16005         call fooD(DSINH(D1))
16006 c FFEINTRIN_impDSQRT
16007         call fooD(DSQRT(D1))
16008 c FFEINTRIN_impDTAN
16009         call fooD(DTAN(D1))
16010 c FFEINTRIN_impDTANH
16011         call fooD(DTANH(D1))
16012 c FFEINTRIN_impEXP
16013         call fooR(EXP(R1))
16014 c FFEINTRIN_impIABS
16015         call fooI(IABS(I1))
16016 c FFEINTRIN_impICHAR
16017         call fooI(ICHAR(A1))
16018 c FFEINTRIN_impIDIM
16019         call fooI(IDIM(I1,I2))
16020 c FFEINTRIN_impIDNINT
16021         call fooI(IDNINT(D1))
16022 c FFEINTRIN_impINDEX
16023         call fooI(INDEX(A1,A2))
16024 c FFEINTRIN_impISIGN
16025         call fooI(ISIGN(I1,I2))
16026 c FFEINTRIN_impLEN
16027         call fooI(LEN(A1))
16028 c FFEINTRIN_impLGE
16029         call fooL(LGE(A1,A2))
16030 c FFEINTRIN_impLGT
16031         call fooL(LGT(A1,A2))
16032 c FFEINTRIN_impLLE
16033         call fooL(LLE(A1,A2))
16034 c FFEINTRIN_impLLT
16035         call fooL(LLT(A1,A2))
16036 c FFEINTRIN_impMAX0
16037         call fooI(MAX0(I1,I2))
16038 c FFEINTRIN_impMAX1
16039         call fooI(MAX1(R1,R2))
16040 c FFEINTRIN_impMIN0
16041         call fooI(MIN0(I1,I2))
16042 c FFEINTRIN_impMIN1
16043         call fooI(MIN1(R1,R2))
16044 c FFEINTRIN_impMOD
16045         call fooI(MOD(I1,I2))
16046 c FFEINTRIN_impNINT
16047         call fooI(NINT(R1))
16048 c FFEINTRIN_impSIGN
16049         call fooR(SIGN(R1,R2))
16050 c FFEINTRIN_impSIN
16051         call fooR(SIN(R1))
16052 c FFEINTRIN_impSINH
16053         call fooR(SINH(R1))
16054 c FFEINTRIN_impSQRT
16055         call fooR(SQRT(R1))
16056 c FFEINTRIN_impTAN
16057         call fooR(TAN(R1))
16058 c FFEINTRIN_impTANH
16059         call fooR(TANH(R1))
16060 c FFEINTRIN_imp_CMPLX_C
16061         call fooC(cmplx(C1,C2))
16062 c FFEINTRIN_imp_CMPLX_D
16063         call fooZ(cmplx(D1,D2))
16064 c FFEINTRIN_imp_CMPLX_I
16065         call fooC(cmplx(I1,I2))
16066 c FFEINTRIN_imp_CMPLX_R
16067         call fooC(cmplx(R1,R2))
16068 c FFEINTRIN_imp_DBLE_C
16069         call fooD(dble(C1))
16070 c FFEINTRIN_imp_DBLE_D
16071         call fooD(dble(D1))
16072 c FFEINTRIN_imp_DBLE_I
16073         call fooD(dble(I1))
16074 c FFEINTRIN_imp_DBLE_R
16075         call fooD(dble(R1))
16076 c FFEINTRIN_imp_INT_C
16077         call fooI(int(C1))
16078 c FFEINTRIN_imp_INT_D
16079         call fooI(int(D1))
16080 c FFEINTRIN_imp_INT_I
16081         call fooI(int(I1))
16082 c FFEINTRIN_imp_INT_R
16083         call fooI(int(R1))
16084 c FFEINTRIN_imp_REAL_C
16085         call fooR(real(C1))
16086 c FFEINTRIN_imp_REAL_D
16087         call fooR(real(D1))
16088 c FFEINTRIN_imp_REAL_I
16089         call fooR(real(I1))
16090 c FFEINTRIN_imp_REAL_R
16091         call fooR(real(R1))
16092 c
16093 c FFEINTRIN_imp_INT_D:
16094 c
16095 c FFEINTRIN_specIDINT
16096         call fooI(IDINT(D1))
16097 c
16098 c FFEINTRIN_imp_INT_R:
16099 c
16100 c FFEINTRIN_specIFIX
16101         call fooI(IFIX(R1))
16102 c FFEINTRIN_specINT
16103         call fooI(INT(R1))
16104 c
16105 c FFEINTRIN_imp_REAL_D:
16106 c
16107 c FFEINTRIN_specSNGL
16108         call fooR(SNGL(D1))
16109 c
16110 c FFEINTRIN_imp_REAL_I:
16111 c
16112 c FFEINTRIN_specFLOAT
16113         call fooR(FLOAT(I1))
16114 c FFEINTRIN_specREAL
16115         call fooR(REAL(I1))
16116 c
16117         end
16118 -------- (end input file to f2c)
16119
16120 -------- (begin output from providing above input file as input to:
16121 --------  `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
16122 --------     -e "s:^#.*$::g"')
16123
16124 //  -- translated by f2c (version 19950223).
16125    You must link the resulting object file with the libraries:
16126         -lf2c -lm   (in that order)
16127 //
16128
16129
16130 // f2c.h  --  Standard Fortran to C header file //
16131
16132 ///  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
16133
16134         - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
16135
16136
16137
16138
16139 // F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems //
16140 // we assume short, float are OK //
16141 typedef long int // long int // integer;
16142 typedef char *address;
16143 typedef short int shortint;
16144 typedef float real;
16145 typedef double doublereal;
16146 typedef struct { real r, i; } complex;
16147 typedef struct { doublereal r, i; } doublecomplex;
16148 typedef long int // long int // logical;
16149 typedef short int shortlogical;
16150 typedef char logical1;
16151 typedef char integer1;
16152 // typedef long long longint; // // system-dependent //
16153
16154
16155
16156
16157 // Extern is for use with -E //
16158
16159
16160
16161
16162 // I/O stuff //
16163
16164
16165
16166
16167
16168
16169
16170
16171 typedef long int // int or long int // flag;
16172 typedef long int // int or long int // ftnlen;
16173 typedef long int // int or long int // ftnint;
16174
16175
16176 //external read, write//
16177 typedef struct
16178 {       flag cierr;
16179         ftnint ciunit;
16180         flag ciend;
16181         char *cifmt;
16182         ftnint cirec;
16183 } cilist;
16184
16185 //internal read, write//
16186 typedef struct
16187 {       flag icierr;
16188         char *iciunit;
16189         flag iciend;
16190         char *icifmt;
16191         ftnint icirlen;
16192         ftnint icirnum;
16193 } icilist;
16194
16195 //open//
16196 typedef struct
16197 {       flag oerr;
16198         ftnint ounit;
16199         char *ofnm;
16200         ftnlen ofnmlen;
16201         char *osta;
16202         char *oacc;
16203         char *ofm;
16204         ftnint orl;
16205         char *oblnk;
16206 } olist;
16207
16208 //close//
16209 typedef struct
16210 {       flag cerr;
16211         ftnint cunit;
16212         char *csta;
16213 } cllist;
16214
16215 //rewind, backspace, endfile//
16216 typedef struct
16217 {       flag aerr;
16218         ftnint aunit;
16219 } alist;
16220
16221 // inquire //
16222 typedef struct
16223 {       flag inerr;
16224         ftnint inunit;
16225         char *infile;
16226         ftnlen infilen;
16227         ftnint  *inex;  //parameters in standard's order//
16228         ftnint  *inopen;
16229         ftnint  *innum;
16230         ftnint  *innamed;
16231         char    *inname;
16232         ftnlen  innamlen;
16233         char    *inacc;
16234         ftnlen  inacclen;
16235         char    *inseq;
16236         ftnlen  inseqlen;
16237         char    *indir;
16238         ftnlen  indirlen;
16239         char    *infmt;
16240         ftnlen  infmtlen;
16241         char    *inform;
16242         ftnint  informlen;
16243         char    *inunf;
16244         ftnlen  inunflen;
16245         ftnint  *inrecl;
16246         ftnint  *innrec;
16247         char    *inblank;
16248         ftnlen  inblanklen;
16249 } inlist;
16250
16251
16252
16253 union Multitype {       // for multiple entry points //
16254         integer1 g;
16255         shortint h;
16256         integer i;
16257         // longint j; //
16258         real r;
16259         doublereal d;
16260         complex c;
16261         doublecomplex z;
16262         };
16263
16264 typedef union Multitype Multitype;
16265
16266 typedef long Long;      // No longer used; formerly in Namelist //
16267
16268 struct Vardesc {        // for Namelist //
16269         char *name;
16270         char *addr;
16271         ftnlen *dims;
16272         int  type;
16273         };
16274 typedef struct Vardesc Vardesc;
16275
16276 struct Namelist {
16277         char *name;
16278         Vardesc **vars;
16279         int nvars;
16280         };
16281 typedef struct Namelist Namelist;
16282
16283
16284
16285
16286
16287
16288
16289
16290 // procedure parameter types for -A and -C++ //
16291
16292
16293
16294
16295 typedef int // Unknown procedure type // (*U_fp)();
16296 typedef shortint (*J_fp)();
16297 typedef integer (*I_fp)();
16298 typedef real (*R_fp)();
16299 typedef doublereal (*D_fp)(), (*E_fp)();
16300 typedef // Complex // void  (*C_fp)();
16301 typedef // Double Complex // void  (*Z_fp)();
16302 typedef logical (*L_fp)();
16303 typedef shortlogical (*K_fp)();
16304 typedef // Character // void  (*H_fp)();
16305 typedef // Subroutine // int (*S_fp)();
16306
16307 // E_fp is for real functions when -R is not specified //
16308 typedef void  C_f;      // complex function //
16309 typedef void  H_f;      // character function //
16310 typedef void  Z_f;      // double complex function //
16311 typedef doublereal E_f; // real function with -R not specified //
16312
16313 // undef any lower-case symbols that your C compiler predefines, e.g.: //
16314
16315
16316 // (No such symbols should be defined in a strict ANSI C compiler.
16317    We can avoid trouble with f2c-translated code by using
16318    gcc -ansi [-traditional].) //
16319
16320
16321
16322
16323
16324
16325
16326
16327
16328
16329
16330
16331
16332
16333
16334
16335
16336
16337
16338
16339
16340
16341
16342 // Main program // MAIN__()
16343 {
16344     // System generated locals //
16345     integer i__1;
16346     real r__1, r__2;
16347     doublereal d__1, d__2;
16348     complex q__1;
16349     doublecomplex z__1, z__2, z__3;
16350     logical L__1;
16351     char ch__1[1];
16352
16353     // Builtin functions //
16354     void c_div();
16355     integer pow_ii();
16356     double pow_ri(), pow_di();
16357     void pow_ci();
16358     double pow_dd();
16359     void pow_zz();
16360     double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
16361             asin(), atan(), atan2(), c_abs();
16362     void c_cos(), c_exp(), c_log(), r_cnjg();
16363     double cos(), cosh();
16364     void c_sin(), c_sqrt();
16365     double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
16366             d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
16367     integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
16368     logical l_ge(), l_gt(), l_le(), l_lt();
16369     integer i_nint();
16370     double r_sign();
16371
16372     // Local variables //
16373     extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
16374             fool_(), fooz_(), getem_();
16375     static char a1[10], a2[10];
16376     static complex c1, c2;
16377     static doublereal d1, d2;
16378     static integer i1, i2;
16379     static real r1, r2;
16380
16381
16382     getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L);
16383 // / //
16384     i__1 = i1 / i2;
16385     fooi_(&i__1);
16386     r__1 = r1 / i1;
16387     foor_(&r__1);
16388     d__1 = d1 / i1;
16389     food_(&d__1);
16390     d__1 = (doublereal) i1;
16391     q__1.r = c1.r / d__1, q__1.i = c1.i / d__1;
16392     fooc_(&q__1);
16393     r__1 = r1 / r2;
16394     foor_(&r__1);
16395     d__1 = r1 / d1;
16396     food_(&d__1);
16397     d__1 = d1 / d2;
16398     food_(&d__1);
16399     d__1 = d1 / r1;
16400     food_(&d__1);
16401     c_div(&q__1, &c1, &c2);
16402     fooc_(&q__1);
16403     q__1.r = c1.r / r1, q__1.i = c1.i / r1;
16404     fooc_(&q__1);
16405     z__1.r = c1.r / d1, z__1.i = c1.i / d1;
16406     fooz_(&z__1);
16407 // ** //
16408     i__1 = pow_ii(&i1, &i2);
16409     fooi_(&i__1);
16410     r__1 = pow_ri(&r1, &i1);
16411     foor_(&r__1);
16412     d__1 = pow_di(&d1, &i1);
16413     food_(&d__1);
16414     pow_ci(&q__1, &c1, &i1);
16415     fooc_(&q__1);
16416     d__1 = (doublereal) r1;
16417     d__2 = (doublereal) r2;
16418     r__1 = pow_dd(&d__1, &d__2);
16419     foor_(&r__1);
16420     d__2 = (doublereal) r1;
16421     d__1 = pow_dd(&d__2, &d1);
16422     food_(&d__1);
16423     d__1 = pow_dd(&d1, &d2);
16424     food_(&d__1);
16425     d__2 = (doublereal) r1;
16426     d__1 = pow_dd(&d1, &d__2);
16427     food_(&d__1);
16428     z__2.r = c1.r, z__2.i = c1.i;
16429     z__3.r = c2.r, z__3.i = c2.i;
16430     pow_zz(&z__1, &z__2, &z__3);
16431     q__1.r = z__1.r, q__1.i = z__1.i;
16432     fooc_(&q__1);
16433     z__2.r = c1.r, z__2.i = c1.i;
16434     z__3.r = r1, z__3.i = 0.;
16435     pow_zz(&z__1, &z__2, &z__3);
16436     q__1.r = z__1.r, q__1.i = z__1.i;
16437     fooc_(&q__1);
16438     z__2.r = c1.r, z__2.i = c1.i;
16439     z__3.r = d1, z__3.i = 0.;
16440     pow_zz(&z__1, &z__2, &z__3);
16441     fooz_(&z__1);
16442 // FFEINTRIN_impABS //
16443     r__1 = (doublereal)((  r1  ) >= 0 ? (  r1  ) : -(  r1  ))  ;
16444     foor_(&r__1);
16445 // FFEINTRIN_impACOS //
16446     r__1 = acos(r1);
16447     foor_(&r__1);
16448 // FFEINTRIN_impAIMAG //
16449     r__1 = r_imag(&c1);
16450     foor_(&r__1);
16451 // FFEINTRIN_impAINT //
16452     r__1 = r_int(&r1);
16453     foor_(&r__1);
16454 // FFEINTRIN_impALOG //
16455     r__1 = log(r1);
16456     foor_(&r__1);
16457 // FFEINTRIN_impALOG10 //
16458     r__1 = r_lg10(&r1);
16459     foor_(&r__1);
16460 // FFEINTRIN_impAMAX0 //
16461     r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16462     foor_(&r__1);
16463 // FFEINTRIN_impAMAX1 //
16464     r__1 = (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16465     foor_(&r__1);
16466 // FFEINTRIN_impAMIN0 //
16467     r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16468     foor_(&r__1);
16469 // FFEINTRIN_impAMIN1 //
16470     r__1 = (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16471     foor_(&r__1);
16472 // FFEINTRIN_impAMOD //
16473     r__1 = r_mod(&r1, &r2);
16474     foor_(&r__1);
16475 // FFEINTRIN_impANINT //
16476     r__1 = r_nint(&r1);
16477     foor_(&r__1);
16478 // FFEINTRIN_impASIN //
16479     r__1 = asin(r1);
16480     foor_(&r__1);
16481 // FFEINTRIN_impATAN //
16482     r__1 = atan(r1);
16483     foor_(&r__1);
16484 // FFEINTRIN_impATAN2 //
16485     r__1 = atan2(r1, r2);
16486     foor_(&r__1);
16487 // FFEINTRIN_impCABS //
16488     r__1 = c_abs(&c1);
16489     foor_(&r__1);
16490 // FFEINTRIN_impCCOS //
16491     c_cos(&q__1, &c1);
16492     fooc_(&q__1);
16493 // FFEINTRIN_impCEXP //
16494     c_exp(&q__1, &c1);
16495     fooc_(&q__1);
16496 // FFEINTRIN_impCHAR //
16497     *(unsigned char *)&ch__1[0] = i1;
16498     fooa_(ch__1, 1L);
16499 // FFEINTRIN_impCLOG //
16500     c_log(&q__1, &c1);
16501     fooc_(&q__1);
16502 // FFEINTRIN_impCONJG //
16503     r_cnjg(&q__1, &c1);
16504     fooc_(&q__1);
16505 // FFEINTRIN_impCOS //
16506     r__1 = cos(r1);
16507     foor_(&r__1);
16508 // FFEINTRIN_impCOSH //
16509     r__1 = cosh(r1);
16510     foor_(&r__1);
16511 // FFEINTRIN_impCSIN //
16512     c_sin(&q__1, &c1);
16513     fooc_(&q__1);
16514 // FFEINTRIN_impCSQRT //
16515     c_sqrt(&q__1, &c1);
16516     fooc_(&q__1);
16517 // FFEINTRIN_impDABS //
16518     d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ;
16519     food_(&d__1);
16520 // FFEINTRIN_impDACOS //
16521     d__1 = acos(d1);
16522     food_(&d__1);
16523 // FFEINTRIN_impDASIN //
16524     d__1 = asin(d1);
16525     food_(&d__1);
16526 // FFEINTRIN_impDATAN //
16527     d__1 = atan(d1);
16528     food_(&d__1);
16529 // FFEINTRIN_impDATAN2 //
16530     d__1 = atan2(d1, d2);
16531     food_(&d__1);
16532 // FFEINTRIN_impDCOS //
16533     d__1 = cos(d1);
16534     food_(&d__1);
16535 // FFEINTRIN_impDCOSH //
16536     d__1 = cosh(d1);
16537     food_(&d__1);
16538 // FFEINTRIN_impDDIM //
16539     d__1 = d_dim(&d1, &d2);
16540     food_(&d__1);
16541 // FFEINTRIN_impDEXP //
16542     d__1 = exp(d1);
16543     food_(&d__1);
16544 // FFEINTRIN_impDIM //
16545     r__1 = r_dim(&r1, &r2);
16546     foor_(&r__1);
16547 // FFEINTRIN_impDINT //
16548     d__1 = d_int(&d1);
16549     food_(&d__1);
16550 // FFEINTRIN_impDLOG //
16551     d__1 = log(d1);
16552     food_(&d__1);
16553 // FFEINTRIN_impDLOG10 //
16554     d__1 = d_lg10(&d1);
16555     food_(&d__1);
16556 // FFEINTRIN_impDMAX1 //
16557     d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ;
16558     food_(&d__1);
16559 // FFEINTRIN_impDMIN1 //
16560     d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ;
16561     food_(&d__1);
16562 // FFEINTRIN_impDMOD //
16563     d__1 = d_mod(&d1, &d2);
16564     food_(&d__1);
16565 // FFEINTRIN_impDNINT //
16566     d__1 = d_nint(&d1);
16567     food_(&d__1);
16568 // FFEINTRIN_impDPROD //
16569     d__1 = (doublereal) r1 * r2;
16570     food_(&d__1);
16571 // FFEINTRIN_impDSIGN //
16572     d__1 = d_sign(&d1, &d2);
16573     food_(&d__1);
16574 // FFEINTRIN_impDSIN //
16575     d__1 = sin(d1);
16576     food_(&d__1);
16577 // FFEINTRIN_impDSINH //
16578     d__1 = sinh(d1);
16579     food_(&d__1);
16580 // FFEINTRIN_impDSQRT //
16581     d__1 = sqrt(d1);
16582     food_(&d__1);
16583 // FFEINTRIN_impDTAN //
16584     d__1 = tan(d1);
16585     food_(&d__1);
16586 // FFEINTRIN_impDTANH //
16587     d__1 = tanh(d1);
16588     food_(&d__1);
16589 // FFEINTRIN_impEXP //
16590     r__1 = exp(r1);
16591     foor_(&r__1);
16592 // FFEINTRIN_impIABS //
16593     i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ;
16594     fooi_(&i__1);
16595 // FFEINTRIN_impICHAR //
16596     i__1 = *(unsigned char *)a1;
16597     fooi_(&i__1);
16598 // FFEINTRIN_impIDIM //
16599     i__1 = i_dim(&i1, &i2);
16600     fooi_(&i__1);
16601 // FFEINTRIN_impIDNINT //
16602     i__1 = i_dnnt(&d1);
16603     fooi_(&i__1);
16604 // FFEINTRIN_impINDEX //
16605     i__1 = i_indx(a1, a2, 10L, 10L);
16606     fooi_(&i__1);
16607 // FFEINTRIN_impISIGN //
16608     i__1 = i_sign(&i1, &i2);
16609     fooi_(&i__1);
16610 // FFEINTRIN_impLEN //
16611     i__1 = i_len(a1, 10L);
16612     fooi_(&i__1);
16613 // FFEINTRIN_impLGE //
16614     L__1 = l_ge(a1, a2, 10L, 10L);
16615     fool_(&L__1);
16616 // FFEINTRIN_impLGT //
16617     L__1 = l_gt(a1, a2, 10L, 10L);
16618     fool_(&L__1);
16619 // FFEINTRIN_impLLE //
16620     L__1 = l_le(a1, a2, 10L, 10L);
16621     fool_(&L__1);
16622 // FFEINTRIN_impLLT //
16623     L__1 = l_lt(a1, a2, 10L, 10L);
16624     fool_(&L__1);
16625 // FFEINTRIN_impMAX0 //
16626     i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16627     fooi_(&i__1);
16628 // FFEINTRIN_impMAX1 //
16629     i__1 = (integer) (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16630     fooi_(&i__1);
16631 // FFEINTRIN_impMIN0 //
16632     i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16633     fooi_(&i__1);
16634 // FFEINTRIN_impMIN1 //
16635     i__1 = (integer) (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16636     fooi_(&i__1);
16637 // FFEINTRIN_impMOD //
16638     i__1 = i1 % i2;
16639     fooi_(&i__1);
16640 // FFEINTRIN_impNINT //
16641     i__1 = i_nint(&r1);
16642     fooi_(&i__1);
16643 // FFEINTRIN_impSIGN //
16644     r__1 = r_sign(&r1, &r2);
16645     foor_(&r__1);
16646 // FFEINTRIN_impSIN //
16647     r__1 = sin(r1);
16648     foor_(&r__1);
16649 // FFEINTRIN_impSINH //
16650     r__1 = sinh(r1);
16651     foor_(&r__1);
16652 // FFEINTRIN_impSQRT //
16653     r__1 = sqrt(r1);
16654     foor_(&r__1);
16655 // FFEINTRIN_impTAN //
16656     r__1 = tan(r1);
16657     foor_(&r__1);
16658 // FFEINTRIN_impTANH //
16659     r__1 = tanh(r1);
16660     foor_(&r__1);
16661 // FFEINTRIN_imp_CMPLX_C //
16662     r__1 = c1.r;
16663     r__2 = c2.r;
16664     q__1.r = r__1, q__1.i = r__2;
16665     fooc_(&q__1);
16666 // FFEINTRIN_imp_CMPLX_D //
16667     z__1.r = d1, z__1.i = d2;
16668     fooz_(&z__1);
16669 // FFEINTRIN_imp_CMPLX_I //
16670     r__1 = (real) i1;
16671     r__2 = (real) i2;
16672     q__1.r = r__1, q__1.i = r__2;
16673     fooc_(&q__1);
16674 // FFEINTRIN_imp_CMPLX_R //
16675     q__1.r = r1, q__1.i = r2;
16676     fooc_(&q__1);
16677 // FFEINTRIN_imp_DBLE_C //
16678     d__1 = (doublereal) c1.r;
16679     food_(&d__1);
16680 // FFEINTRIN_imp_DBLE_D //
16681     d__1 = d1;
16682     food_(&d__1);
16683 // FFEINTRIN_imp_DBLE_I //
16684     d__1 = (doublereal) i1;
16685     food_(&d__1);
16686 // FFEINTRIN_imp_DBLE_R //
16687     d__1 = (doublereal) r1;
16688     food_(&d__1);
16689 // FFEINTRIN_imp_INT_C //
16690     i__1 = (integer) c1.r;
16691     fooi_(&i__1);
16692 // FFEINTRIN_imp_INT_D //
16693     i__1 = (integer) d1;
16694     fooi_(&i__1);
16695 // FFEINTRIN_imp_INT_I //
16696     i__1 = i1;
16697     fooi_(&i__1);
16698 // FFEINTRIN_imp_INT_R //
16699     i__1 = (integer) r1;
16700     fooi_(&i__1);
16701 // FFEINTRIN_imp_REAL_C //
16702     r__1 = c1.r;
16703     foor_(&r__1);
16704 // FFEINTRIN_imp_REAL_D //
16705     r__1 = (real) d1;
16706     foor_(&r__1);
16707 // FFEINTRIN_imp_REAL_I //
16708     r__1 = (real) i1;
16709     foor_(&r__1);
16710 // FFEINTRIN_imp_REAL_R //
16711     r__1 = r1;
16712     foor_(&r__1);
16713
16714 // FFEINTRIN_imp_INT_D: //
16715
16716 // FFEINTRIN_specIDINT //
16717     i__1 = (integer) d1;
16718     fooi_(&i__1);
16719
16720 // FFEINTRIN_imp_INT_R: //
16721
16722 // FFEINTRIN_specIFIX //
16723     i__1 = (integer) r1;
16724     fooi_(&i__1);
16725 // FFEINTRIN_specINT //
16726     i__1 = (integer) r1;
16727     fooi_(&i__1);
16728
16729 // FFEINTRIN_imp_REAL_D: //
16730
16731 // FFEINTRIN_specSNGL //
16732     r__1 = (real) d1;
16733     foor_(&r__1);
16734
16735 // FFEINTRIN_imp_REAL_I: //
16736
16737 // FFEINTRIN_specFLOAT //
16738     r__1 = (real) i1;
16739     foor_(&r__1);
16740 // FFEINTRIN_specREAL //
16741     r__1 = (real) i1;
16742     foor_(&r__1);
16743
16744 } // MAIN__ //
16745
16746 -------- (end output file from f2c)
16747
16748 */