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 #include "langhooks-def.h"
  94
  95 /* VMS-specific definitions */
  96 #ifdef VMS
  97 #include <descrip.h>
  98 #define O_RDONLY        0       /* Open arg for Read/Only  */
  99 #define O_WRONLY        1       /* Open arg for Write/Only */
 100 #define read(fd,buf,size)       VMS_read (fd,buf,size)
 101 #define write(fd,buf,size)      VMS_write (fd,buf,size)
 102 #define open(fname,mode,prot)   VMS_open (fname,mode,prot)
 103 #define fopen(fname,mode)       VMS_fopen (fname,mode)
 104 #define freopen(fname,mode,ofile) VMS_freopen (fname,mode,ofile)
 105 #define strncat(dst,src,cnt) VMS_strncat (dst,src,cnt)
 106 #define fstat(fd,stbuf)         VMS_fstat (fd,stbuf)
 107 static int VMS_fstat (), VMS_stat ();
 108 static char * VMS_strncat ();
 109 static int VMS_read ();
 110 static int VMS_write ();
 111 static int VMS_open ();
 112 static FILE * VMS_fopen ();
 113 static FILE * VMS_freopen ();
 114 static void hack_vms_include_specification ();
 115 typedef struct { unsigned :16, :16, :16; } vms_ino_t;
 116 #define ino_t vms_ino_t
 117 #define INCLUDE_LEN_FUDGE 10    /* leave room for VMS syntax conversion */
 118 #endif /* VMS */
 119
 120 #define FFECOM_DETERMINE_TYPES 1 /* for com.h */
 121 #include "com.h"
 122 #include "bad.h"
 123 #include "bld.h"
 124 #include "equiv.h"
 125 #include "expr.h"
 126 #include "implic.h"
 127 #include "info.h"
 128 #include "malloc.h"
 129 #include "src.h"
 130 #include "st.h"
 131 #include "storag.h"
 132 #include "symbol.h"
 133 #include "target.h"
 134 #include "top.h"
 135 #include "type.h"
 136
 137 /* Externals defined here.  */
 138
 139 /* Stream for reading from the input file.  */
 140 FILE *finput;
 141
 142 /* These definitions parallel those in c-decl.c so that code from that
 143    module can be used pretty much as is.  Much of these defs aren't
 144    otherwise used, i.e. by g77 code per se, except some of them are used
 145    to build some of them that are.  The ones that are global (i.e. not
 146    "static") are those that ste.c and such might use (directly
 147    or by using com macros that reference them in their definitions).  */
 148
 149 tree string_type_node;
 150
 151 /* The rest of these are inventions for g77, though there might be
 152    similar things in the C front end.  As they are found, these
 153    inventions should be renamed to be canonical.  Note that only
 154    the ones currently required to be global are so.  */
 155
 156 static tree ffecom_tree_fun_type_void;
 157
 158 tree ffecom_integer_type_node;  /* Abbrev for _tree_type[blah][blah]. */
 159 tree ffecom_integer_zero_node;  /* Like *_*_* with g77's integer type. */
 160 tree ffecom_integer_one_node;   /* " */
 161 tree ffecom_tree_type[FFEINFO_basictype][FFEINFO_kindtype];
 162
 163 /* _fun_type things are the f2c-specific versions.  For -fno-f2c,
 164    just use build_function_type and build_pointer_type on the
 165    appropriate _tree_type array element.  */
 166
 167 static tree ffecom_tree_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
 168 static tree ffecom_tree_ptr_to_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
 169 static tree ffecom_tree_subr_type;
 170 static tree ffecom_tree_ptr_to_subr_type;
 171 static tree ffecom_tree_blockdata_type;
 172
 173 static tree ffecom_tree_xargc_;
 174
 175 ffecomSymbol ffecom_symbol_null_
 176 =
 177 {
 178   NULL_TREE,
 179   NULL_TREE,
 180   NULL_TREE,
 181   NULL_TREE,
 182   false
 183 };
 184 ffeinfoKindtype ffecom_pointer_kind_ = FFEINFO_basictypeNONE;
 185 ffeinfoKindtype ffecom_label_kind_ = FFEINFO_basictypeNONE;
 186
 187 int ffecom_f2c_typecode_[FFEINFO_basictype][FFEINFO_kindtype];
 188 tree ffecom_f2c_integer_type_node;
 189 tree ffecom_f2c_ptr_to_integer_type_node;
 190 tree ffecom_f2c_address_type_node;
 191 tree ffecom_f2c_real_type_node;
 192 tree ffecom_f2c_ptr_to_real_type_node;
 193 tree ffecom_f2c_doublereal_type_node;
 194 tree ffecom_f2c_complex_type_node;
 195 tree ffecom_f2c_doublecomplex_type_node;
 196 tree ffecom_f2c_longint_type_node;
 197 tree ffecom_f2c_logical_type_node;
 198 tree ffecom_f2c_flag_type_node;
 199 tree ffecom_f2c_ftnlen_type_node;
 200 tree ffecom_f2c_ftnlen_zero_node;
 201 tree ffecom_f2c_ftnlen_one_node;
 202 tree ffecom_f2c_ftnlen_two_node;
 203 tree ffecom_f2c_ptr_to_ftnlen_type_node;
 204 tree ffecom_f2c_ftnint_type_node;
 205 tree ffecom_f2c_ptr_to_ftnint_type_node;
 206
 207 /* Simple definitions and enumerations. */
 208
 209 #ifndef FFECOM_sizeMAXSTACKITEM
 210 #define FFECOM_sizeMAXSTACKITEM 32*1024 /* Keep user-declared things
 211                                            larger than this # bytes
 212                                            off stack if possible. */
 213 #endif
 214
 215 /* For systems that have large enough stacks, they should define
 216    this to 0, and here, for ease of use later on, we just undefine
 217    it if it is 0.  */
 218
 219 #if FFECOM_sizeMAXSTACKITEM == 0
 220 #undef FFECOM_sizeMAXSTACKITEM
 221 #endif
 222
 223 typedef enum
 224   {
 225     FFECOM_rttypeVOID_,
 226     FFECOM_rttypeVOIDSTAR_,     /* C's `void *' type. */
 227     FFECOM_rttypeFTNINT_,       /* f2c's `ftnint' type. */
 228     FFECOM_rttypeINTEGER_,      /* f2c's `integer' type. */
 229     FFECOM_rttypeLONGINT_,      /* f2c's `longint' type. */
 230     FFECOM_rttypeLOGICAL_,      /* f2c's `logical' type. */
 231     FFECOM_rttypeREAL_F2C_,     /* f2c's `real' returned as `double'. */
 232     FFECOM_rttypeREAL_GNU_,     /* `real' returned as such. */
 233     FFECOM_rttypeCOMPLEX_F2C_,  /* f2c's `complex' returned via 1st arg. */
 234     FFECOM_rttypeCOMPLEX_GNU_,  /* f2c's `complex' returned directly. */
 235     FFECOM_rttypeDOUBLE_,       /* C's `double' type. */
 236     FFECOM_rttypeDOUBLEREAL_,   /* f2c's `doublereal' type. */
 237     FFECOM_rttypeDBLCMPLX_F2C_, /* f2c's `doublecomplex' returned via 1st arg. */
 238     FFECOM_rttypeDBLCMPLX_GNU_, /* f2c's `doublecomplex' returned directly. */
 239     FFECOM_rttypeCHARACTER_,    /* f2c `char *'/`ftnlen' pair. */
 240     FFECOM_rttype_
 241   } ffecomRttype_;
 242
 243 /* Internal typedefs. */
 244
 245 typedef struct _ffecom_concat_list_ ffecomConcatList_;
 246
 247 /* Private include files. */
 248
 249
 250 /* Internal structure definitions. */
 251
 252 struct _ffecom_concat_list_
 253   {
 254     ffebld *exprs;
 255     int count;
 256     int max;
 257     ffetargetCharacterSize minlen;
 258     ffetargetCharacterSize maxlen;
 259   };
 260
 261 /* Static functions (internal). */
 262
 263 static void ffecom_init_decl_processing PARAMS ((void));
 264 static tree ffecom_arglist_expr_ (const char *argstring, ffebld args);
 265 static tree ffecom_widest_expr_type_ (ffebld list);
 266 static bool ffecom_overlap_ (tree dest_decl, tree dest_offset,
 267                              tree dest_size, tree source_tree,
 268                              ffebld source, bool scalar_arg);
 269 static bool ffecom_args_overlapping_ (tree dest_tree, ffebld dest,
 270                                       tree args, tree callee_commons,
 271                                       bool scalar_args);
 272 static tree ffecom_build_f2c_string_ (int i, const char *s);
 273 static tree ffecom_call_ (tree fn, ffeinfoKindtype kt,
 274                           bool is_f2c_complex, tree type,
 275                           tree args, tree dest_tree,
 276                           ffebld dest, bool *dest_used,
 277                           tree callee_commons, bool scalar_args, tree hook);
 278 static tree ffecom_call_binop_ (tree fn, ffeinfoKindtype kt,
 279                                 bool is_f2c_complex, tree type,
 280                                 ffebld left, ffebld right,
 281                                 tree dest_tree, ffebld dest,
 282                                 bool *dest_used, tree callee_commons,
 283                                 bool scalar_args, bool ref, tree hook);
 284 static void ffecom_char_args_x_ (tree *xitem, tree *length,
 285                                  ffebld expr, bool with_null);
 286 static tree ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy);
 287 static tree ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s);
 288 static ffecomConcatList_
 289   ffecom_concat_list_gather_ (ffecomConcatList_ catlist,
 290                               ffebld expr,
 291                               ffetargetCharacterSize max);
 292 static void ffecom_concat_list_kill_ (ffecomConcatList_ catlist);
 293 static ffecomConcatList_ ffecom_concat_list_new_ (ffebld expr,
 294                                                 ffetargetCharacterSize max);
 295 static void ffecom_debug_kludge_ (tree aggr, const char *aggr_type,
 296                                   ffesymbol member, tree member_type,
 297                                   ffetargetOffset offset);
 298 static void ffecom_do_entry_ (ffesymbol fn, int entrynum);
 299 static tree ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
 300                           bool *dest_used, bool assignp, bool widenp);
 301 static tree ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
 302                                     ffebld dest, bool *dest_used);
 303 static tree ffecom_expr_power_integer_ (ffebld expr);
 304 static void ffecom_expr_transform_ (ffebld expr);
 305 static void ffecom_f2c_make_type_ (tree *type, int tcode, const char *name);
 306 static void ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
 307                                       int code);
 308 static ffeglobal ffecom_finish_global_ (ffeglobal global);
 309 static ffesymbol ffecom_finish_symbol_transform_ (ffesymbol s);
 310 static tree ffecom_get_appended_identifier_ (char us, const char *text);
 311 static tree ffecom_get_external_identifier_ (ffesymbol s);
 312 static tree ffecom_get_identifier_ (const char *text);
 313 static tree ffecom_gen_sfuncdef_ (ffesymbol s,
 314                                   ffeinfoBasictype bt,
 315                                   ffeinfoKindtype kt);
 316 static const char *ffecom_gfrt_args_ (ffecomGfrt ix);
 317 static tree ffecom_gfrt_tree_ (ffecomGfrt ix);
 318 static tree ffecom_init_zero_ (tree decl);
 319 static tree ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
 320                                      tree *maybe_tree);
 321 static tree ffecom_intrinsic_len_ (ffebld expr);
 322 static void ffecom_let_char_ (tree dest_tree,
 323                               tree dest_length,
 324                               ffetargetCharacterSize dest_size,
 325                               ffebld source);
 326 static void ffecom_make_gfrt_ (ffecomGfrt ix);
 327 static void ffecom_member_phase1_ (ffestorag mst, ffestorag st);
 328 static void ffecom_member_phase2_ (ffestorag mst, ffestorag st);
 329 static void ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size,
 330                                       ffebld source);
 331 static void ffecom_push_dummy_decls_ (ffebld dumlist,
 332                                       bool stmtfunc);
 333 static void ffecom_start_progunit_ (void);
 334 static ffesymbol ffecom_sym_transform_ (ffesymbol s);
 335 static ffesymbol ffecom_sym_transform_assign_ (ffesymbol s);
 336 static void ffecom_transform_common_ (ffesymbol s);
 337 static void ffecom_transform_equiv_ (ffestorag st);
 338 static tree ffecom_transform_namelist_ (ffesymbol s);
 339 static void ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
 340                                        tree t);
 341 static void ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
 342                                        tree *size, tree tree);
 343 static tree ffecom_tree_divide_ (tree tree_type, tree left, tree right,
 344                                  tree dest_tree, ffebld dest,
 345                                  bool *dest_used, tree hook);
 346 static tree ffecom_type_localvar_ (ffesymbol s,
 347                                    ffeinfoBasictype bt,
 348                                    ffeinfoKindtype kt);
 349 static tree ffecom_type_namelist_ (void);
 350 static tree ffecom_type_vardesc_ (void);
 351 static tree ffecom_vardesc_ (ffebld expr);
 352 static tree ffecom_vardesc_array_ (ffesymbol s);
 353 static tree ffecom_vardesc_dims_ (ffesymbol s);
 354 static tree ffecom_convert_narrow_ (tree type, tree expr);
 355 static tree ffecom_convert_widen_ (tree type, tree expr);
 356
 357 /* These are static functions that parallel those found in the C front
 358    end and thus have the same names.  */
 359
 360 static tree bison_rule_compstmt_ (void);
 361 static void bison_rule_pushlevel_ (void);
 362 static void delete_block (tree block);
 363 static int duplicate_decls (tree newdecl, tree olddecl);
 364 static void finish_decl (tree decl, tree init, bool is_top_level);
 365 static void finish_function (int nested);
 366 static const char *lang_printable_name (tree decl, int v);
 367 static tree lookup_name_current_level (tree name);
 368 static struct binding_level *make_binding_level (void);
 369 static void pop_f_function_context (void);
 370 static void push_f_function_context (void);
 371 static void push_parm_decl (tree parm);
 372 static tree pushdecl_top_level (tree decl);
 373 static int kept_level_p (void);
 374 static tree storedecls (tree decls);
 375 static void store_parm_decls (int is_main_program);
 376 static tree start_decl (tree decl, bool is_top_level);
 377 static void start_function (tree name, tree type, int nested, int public);
 378 static void ffecom_file_ (const char *name);
 379 static void ffecom_close_include_ (FILE *f);
 380 static int ffecom_decode_include_option_ (char *spec);
 381 static FILE *ffecom_open_include_ (char *name, ffewhereLine l,
 382                                    ffewhereColumn c);
 383
 384 /* Static objects accessed by functions in this module. */
 385
 386 static ffesymbol ffecom_primary_entry_ = NULL;
 387 static ffesymbol ffecom_nested_entry_ = NULL;
 388 static ffeinfoKind ffecom_primary_entry_kind_;
 389 static bool ffecom_primary_entry_is_proc_;
 390 static tree ffecom_outer_function_decl_;
 391 static tree ffecom_previous_function_decl_;
 392 static tree ffecom_which_entrypoint_decl_;
 393 static tree ffecom_float_zero_ = NULL_TREE;
 394 static tree ffecom_float_half_ = NULL_TREE;
 395 static tree ffecom_double_zero_ = NULL_TREE;
 396 static tree ffecom_double_half_ = NULL_TREE;
 397 static tree ffecom_func_result_;/* For functions. */
 398 static tree ffecom_func_length_;/* For CHARACTER fns. */
 399 static ffebld ffecom_list_blockdata_;
 400 static ffebld ffecom_list_common_;
 401 static ffebld ffecom_master_arglist_;
 402 static ffeinfoBasictype ffecom_master_bt_;
 403 static ffeinfoKindtype ffecom_master_kt_;
 404 static ffetargetCharacterSize ffecom_master_size_;
 405 static int ffecom_num_fns_ = 0;
 406 static int ffecom_num_entrypoints_ = 0;
 407 static bool ffecom_is_altreturning_ = FALSE;
 408 static tree ffecom_multi_type_node_;
 409 static tree ffecom_multi_retval_;
 410 static tree
 411   ffecom_multi_fields_[FFEINFO_basictype][FFEINFO_kindtype];
 412 static bool ffecom_member_namelisted_;  /* _member_phase1_ namelisted? */
 413 static bool ffecom_doing_entry_ = FALSE;
 414 static bool ffecom_transform_only_dummies_ = FALSE;
 415 static int ffecom_typesize_pointer_;
 416 static int ffecom_typesize_integer1_;
 417
 418 /* Holds pointer-to-function expressions.  */
 419
 420 static tree ffecom_gfrt_[FFECOM_gfrt]
 421 =
 422 {
 423 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NULL_TREE,
 424 #include "com-rt.def"
 425 #undef DEFGFRT
 426 };
 427
 428 /* Holds the external names of the functions.  */
 429
 430 static const char *const ffecom_gfrt_name_[FFECOM_gfrt]
 431 =
 432 {
 433 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NAME,
 434 #include "com-rt.def"
 435 #undef DEFGFRT
 436 };
 437
 438 /* Whether the function returns.  */
 439
 440 static bool ffecom_gfrt_volatile_[FFECOM_gfrt]
 441 =
 442 {
 443 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) VOLATILE,
 444 #include "com-rt.def"
 445 #undef DEFGFRT
 446 };
 447
 448 /* Whether the function returns type complex.  */
 449
 450 static bool ffecom_gfrt_complex_[FFECOM_gfrt]
 451 =
 452 {
 453 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) COMPLEX,
 454 #include "com-rt.def"
 455 #undef DEFGFRT
 456 };
 457
 458 /* Whether the function is const
 459    (i.e., has no side effects and only depends on its arguments).  */
 460
 461 static bool ffecom_gfrt_const_[FFECOM_gfrt]
 462 =
 463 {
 464 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) CONST,
 465 #include "com-rt.def"
 466 #undef DEFGFRT
 467 };
 468
 469 /* Type code for the function return value.  */
 470
 471 static ffecomRttype_ ffecom_gfrt_type_[FFECOM_gfrt]
 472 =
 473 {
 474 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) TYPE,
 475 #include "com-rt.def"
 476 #undef DEFGFRT
 477 };
 478
 479 /* String of codes for the function's arguments.  */
 480
 481 static const char *const ffecom_gfrt_argstring_[FFECOM_gfrt]
 482 =
 483 {
 484 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) ARGS,
 485 #include "com-rt.def"
 486 #undef DEFGFRT
 487 };
 488
 489 /* Internal macros. */
 490
 491 /* We let tm.h override the types used here, to handle trivial differences
 492    such as the choice of unsigned int or long unsigned int for size_t.
 493    When machines start needing nontrivial differences in the size type,
 494    it would be best to do something here to figure out automatically
 495    from other information what type to use.  */
 496
 497 #ifndef SIZE_TYPE
 498 #define SIZE_TYPE "long unsigned int"
 499 #endif
 500
 501 #define ffecom_concat_list_count_(catlist) ((catlist).count)
 502 #define ffecom_concat_list_expr_(catlist,i) ((catlist).exprs[(i)])
 503 #define ffecom_concat_list_maxlen_(catlist) ((catlist).maxlen)
 504 #define ffecom_concat_list_minlen_(catlist) ((catlist).minlen)
 505
 506 #define ffecom_char_args_(i,l,e) ffecom_char_args_x_((i),(l),(e),FALSE)
 507 #define ffecom_char_args_with_null_(i,l,e) ffecom_char_args_x_((i),(l),(e),TRUE)
 508
 509 /* For each binding contour we allocate a binding_level structure
 510  * which records the names defined in that contour.
 511  * Contours include:
 512  *  0) the global one
 513  *  1) one for each function definition,
 514  *     where internal declarations of the parameters appear.
 515  *
 516  * The current meaning of a name can be found by searching the levels from
 517  * the current one out to the global one.
 518  */
 519
 520 /* Note that the information in the `names' component of the global contour
 521    is duplicated in the IDENTIFIER_GLOBAL_VALUEs of all identifiers.  */
 522
 523 struct binding_level
 524   {
 525     /* A chain of _DECL nodes for all variables, constants, functions,
 526        and typedef types.  These are in the reverse of the order supplied.
 527      */
 528     tree names;
 529
 530     /* For each level (except not the global one),
 531        a chain of BLOCK nodes for all the levels
 532        that were entered and exited one level down.  */
 533     tree blocks;
 534
 535     /* The BLOCK node for this level, if one has been preallocated.
 536        If 0, the BLOCK is allocated (if needed) when the level is popped.  */
 537     tree this_block;
 538
 539     /* The binding level which this one is contained in (inherits from).  */
 540     struct binding_level *level_chain;
 541
 542     /* 0: no ffecom_prepare_* functions called at this level yet;
 543        1: ffecom_prepare* functions called, except not ffecom_prepare_end;
 544        2: ffecom_prepare_end called.  */
 545     int prep_state;
 546   };
 547
 548 #define NULL_BINDING_LEVEL (struct binding_level *) NULL
 549
 550 /* The binding level currently in effect.  */
 551
 552 static struct binding_level *current_binding_level;
 553
 554 /* A chain of binding_level structures awaiting reuse.  */
 555
 556 static struct binding_level *free_binding_level;
 557
 558 /* The outermost binding level, for names of file scope.
 559    This is created when the compiler is started and exists
 560    through the entire run.  */
 561
 562 static struct binding_level *global_binding_level;
 563
 564 /* Binding level structures are initialized by copying this one.  */
 565
 566 static struct binding_level clear_binding_level
 567 =
 568 {NULL, NULL, NULL, NULL_BINDING_LEVEL, 0};
 569
 570 /* Language-dependent contents of an identifier.  */
 571
 572 struct lang_identifier
 573   {
 574     struct tree_identifier ignore;
 575     tree global_value, local_value, label_value;
 576     bool invented;
 577   };
 578
 579 /* Macros for access to language-specific slots in an identifier.  */
 580 /* Each of these slots contains a DECL node or null.  */
 581
 582 /* This represents the value which the identifier has in the
 583    file-scope namespace.  */
 584 #define IDENTIFIER_GLOBAL_VALUE(NODE)   \
 585   (((struct lang_identifier *)(NODE))->global_value)
 586 /* This represents the value which the identifier has in the current
 587    scope.  */
 588 #define IDENTIFIER_LOCAL_VALUE(NODE)    \
 589   (((struct lang_identifier *)(NODE))->local_value)
 590 /* This represents the value which the identifier has as a label in
 591    the current label scope.  */
 592 #define IDENTIFIER_LABEL_VALUE(NODE)    \
 593   (((struct lang_identifier *)(NODE))->label_value)
 594 /* This is nonzero if the identifier was "made up" by g77 code.  */
 595 #define IDENTIFIER_INVENTED(NODE)       \
 596   (((struct lang_identifier *)(NODE))->invented)
 597
 598 /* In identifiers, C uses the following fields in a special way:
 599    TREE_PUBLIC        to record that there was a previous local extern decl.
 600    TREE_USED          to record that such a decl was used.
 601    TREE_ADDRESSABLE   to record that the address of such a decl was used.  */
 602
 603 /* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function
 604    that have names.  Here so we can clear out their names' definitions
 605    at the end of the function.  */
 606
 607 static tree named_labels;
 608
 609 /* A list of LABEL_DECLs from outer contexts that are currently shadowed.  */
 610
 611 static tree shadowed_labels;
 612 \f
 613 /* Return the subscript expression, modified to do range-checking.
 614
 615    `array' is the array to be checked against.
 616    `element' is the subscript expression to check.
 617    `dim' is the dimension number (starting at 0).
 618    `total_dims' is the total number of dimensions (0 for CHARACTER substring).
 619 */
 620
 621 static tree
 622 ffecom_subscript_check_ (tree array, tree element, int dim, int total_dims,
 623                          const char *array_name)
 624 {
 625   tree low = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
 626   tree high = TYPE_MAX_VALUE (TYPE_DOMAIN (array));
 627   tree cond;
 628   tree die;
 629   tree args;
 630
 631   if (element == error_mark_node)
 632     return element;
 633
 634   if (TREE_TYPE (low) != TREE_TYPE (element))
 635     {
 636       if (TYPE_PRECISION (TREE_TYPE (low))
 637           > TYPE_PRECISION (TREE_TYPE (element)))
 638         element = convert (TREE_TYPE (low), element);
 639       else
 640         {
 641           low = convert (TREE_TYPE (element), low);
 642           if (high)
 643             high = convert (TREE_TYPE (element), high);
 644         }
 645     }
 646
 647   element = ffecom_save_tree (element);
 648   if (total_dims == 0)
 649     {
 650       /* Special handling for substring range checks.  Fortran allows the
 651          end subscript < begin subscript, which means that expressions like
 652        string(1:0) are valid (and yield a null string).  In view of this,
 653        enforce two simpler conditions:
 654           1) element<=high for end-substring;
 655           2) element>=low for start-substring.
 656        Run-time character movement will enforce remaining conditions.
 657
 658        More complicated checks would be better, but present structure only
 659        provides one index element at a time, so it is not possible to
 660        enforce a check of both i and j in string(i:j).  If it were, the
 661        complete set of rules would read,
 662          if ( ((j<i) && ((low<=i<=high) || (low<=j<=high))) ||
 663               ((low<=i<=high) && (low<=j<=high)) )
 664            ok ;
 665          else
 666            range error ;
 667       */
 668       if (dim)
 669         cond = ffecom_2 (LE_EXPR, integer_type_node, element, high);
 670       else
 671         cond = ffecom_2 (LE_EXPR, integer_type_node, low, element);
 672     }
 673   else
 674     {
 675       /* Array reference substring range checking.  */
 676
 677       cond = ffecom_2 (LE_EXPR, integer_type_node,
 678                      low,
 679                      element);
 680       if (high)
 681         {
 682           cond = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
 683                          cond,
 684                          ffecom_2 (LE_EXPR, integer_type_node,
 685                                    element,
 686                                    high));
 687         }
 688     }
 689
 690   {
 691     int len;
 692     char *proc;
 693     char *var;
 694     tree arg3;
 695     tree arg2;
 696     tree arg1;
 697     tree arg4;
 698
 699     switch (total_dims)
 700       {
 701       case 0:
 702         var = concat (array_name, "[", (dim ? "end" : "start"),
 703                       "-substring]", NULL);
 704         len = strlen (var) + 1;
 705         arg1 = build_string (len, var);
 706         free (var);
 707         break;
 708
 709       case 1:
 710         len = strlen (array_name) + 1;
 711         arg1 = build_string (len, array_name);
 712         break;
 713
 714       default:
 715         var = xmalloc (strlen (array_name) + 40);
 716         sprintf (var, "%s[subscript-%d-of-%d]",
 717                  array_name,
 718                  dim + 1, total_dims);
 719         len = strlen (var) + 1;
 720         arg1 = build_string (len, var);
 721         free (var);
 722         break;
 723       }
 724
 725     TREE_TYPE (arg1)
 726       = build_type_variant (build_array_type (char_type_node,
 727                                               build_range_type
 728                                               (integer_type_node,
 729                                                integer_one_node,
 730                                                build_int_2 (len, 0))),
 731                             1, 0);
 732     TREE_CONSTANT (arg1) = 1;
 733     TREE_STATIC (arg1) = 1;
 734     arg1 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg1)),
 735                      arg1);
 736
 737     /* s_rnge adds one to the element to print it, so bias against
 738        that -- want to print a faithful *subscript* value.  */
 739     arg2 = convert (ffecom_f2c_ftnint_type_node,
 740                     ffecom_2 (MINUS_EXPR,
 741                               TREE_TYPE (element),
 742                               element,
 743                               convert (TREE_TYPE (element),
 744                                        integer_one_node)));
 745
 746     proc = concat (input_filename, "/",
 747                    IDENTIFIER_POINTER (DECL_NAME (current_function_decl)),
 748                    NULL);
 749     len = strlen (proc) + 1;
 750     arg3 = build_string (len, proc);
 751
 752     free (proc);
 753
 754     TREE_TYPE (arg3)
 755       = build_type_variant (build_array_type (char_type_node,
 756                                               build_range_type
 757                                               (integer_type_node,
 758                                                integer_one_node,
 759                                                build_int_2 (len, 0))),
 760                             1, 0);
 761     TREE_CONSTANT (arg3) = 1;
 762     TREE_STATIC (arg3) = 1;
 763     arg3 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg3)),
 764                      arg3);
 765
 766     arg4 = convert (ffecom_f2c_ftnint_type_node,
 767                     build_int_2 (lineno, 0));
 768
 769     arg1 = build_tree_list (NULL_TREE, arg1);
 770     arg2 = build_tree_list (NULL_TREE, arg2);
 771     arg3 = build_tree_list (NULL_TREE, arg3);
 772     arg4 = build_tree_list (NULL_TREE, arg4);
 773     TREE_CHAIN (arg3) = arg4;
 774     TREE_CHAIN (arg2) = arg3;
 775     TREE_CHAIN (arg1) = arg2;
 776
 777     args = arg1;
 778   }
 779   die = ffecom_call_gfrt (FFECOM_gfrtRANGE,
 780                           args, NULL_TREE);
 781   TREE_SIDE_EFFECTS (die) = 1;
 782
 783   element = ffecom_3 (COND_EXPR,
 784                       TREE_TYPE (element),
 785                       cond,
 786                       element,
 787                       die);
 788
 789   return element;
 790 }
 791
 792 /* Return the computed element of an array reference.
 793
 794    `item' is NULL_TREE, or the transformed pointer to the array.
 795    `expr' is the original opARRAYREF expression, which is transformed
 796      if `item' is NULL_TREE.
 797    `want_ptr' is non-zero if a pointer to the element, instead of
 798      the element itself, is to be returned.  */
 799
 800 static tree
 801 ffecom_arrayref_ (tree item, ffebld expr, int want_ptr)
 802 {
 803   ffebld dims[FFECOM_dimensionsMAX];
 804   int i;
 805   int total_dims;
 806   int flatten = ffe_is_flatten_arrays ();
 807   int need_ptr;
 808   tree array;
 809   tree element;
 810   tree tree_type;
 811   tree tree_type_x;
 812   const char *array_name;
 813   ffetype type;
 814   ffebld list;
 815
 816   if (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER)
 817     array_name = ffesymbol_text (ffebld_symter (ffebld_left (expr)));
 818   else
 819     array_name = "[expr?]";
 820
 821   /* Build up ARRAY_REFs in reverse order (since we're column major
 822      here in Fortran land). */
 823
 824   for (i = 0, list = ffebld_right (expr);
 825        list != NULL;
 826        ++i, list = ffebld_trail (list))
 827     {
 828       dims[i] = ffebld_head (list);
 829       type = ffeinfo_type (ffebld_basictype (dims[i]),
 830                            ffebld_kindtype (dims[i]));
 831       if (! flatten
 832           && ffecom_typesize_pointer_ > ffecom_typesize_integer1_
 833           && ffetype_size (type) > ffecom_typesize_integer1_)
 834         /* E.g. ARRAY(INDEX), given INTEGER*8 INDEX, on a system with 64-bit
 835            pointers and 32-bit integers.  Do the full 64-bit pointer
 836            arithmetic, for codes using arrays for nonstandard heap-like
 837            work.  */
 838         flatten = 1;
 839     }
 840
 841   total_dims = i;
 842
 843   need_ptr = want_ptr || flatten;
 844
 845   if (! item)
 846     {
 847       if (need_ptr)
 848         item = ffecom_ptr_to_expr (ffebld_left (expr));
 849       else
 850         item = ffecom_expr (ffebld_left (expr));
 851
 852       if (item == error_mark_node)
 853         return item;
 854
 855       if (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereFLEETING
 856           && ! mark_addressable (item))
 857         return error_mark_node;
 858     }
 859
 860   if (item == error_mark_node)
 861     return item;
 862
 863   if (need_ptr)
 864     {
 865       tree min;
 866
 867       for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
 868            i >= 0;
 869            --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array)))
 870         {
 871           min = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
 872           element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
 873           if (flag_bounds_check)
 874             element = ffecom_subscript_check_ (array, element, i, total_dims,
 875                                                array_name);
 876           if (element == error_mark_node)
 877             return element;
 878
 879           /* Widen integral arithmetic as desired while preserving
 880              signedness.  */
 881           tree_type = TREE_TYPE (element);
 882           tree_type_x = tree_type;
 883           if (tree_type
 884               && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
 885               && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
 886             tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
 887
 888           if (TREE_TYPE (min) != tree_type_x)
 889             min = convert (tree_type_x, min);
 890           if (TREE_TYPE (element) != tree_type_x)
 891             element = convert (tree_type_x, element);
 892
 893           item = ffecom_2 (PLUS_EXPR,
 894                            build_pointer_type (TREE_TYPE (array)),
 895                            item,
 896                            size_binop (MULT_EXPR,
 897                                        size_in_bytes (TREE_TYPE (array)),
 898                                        convert (sizetype,
 899                                                 fold (build (MINUS_EXPR,
 900                                                              tree_type_x,
 901                                                              element, min)))));
 902         }
 903       if (! want_ptr)
 904         {
 905           item = ffecom_1 (INDIRECT_REF,
 906                            TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
 907                            item);
 908         }
 909     }
 910   else
 911     {
 912       for (--i;
 913            i >= 0;
 914            --i)
 915         {
 916           array = TYPE_MAIN_VARIANT (TREE_TYPE (item));
 917
 918           element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
 919           if (flag_bounds_check)
 920             element = ffecom_subscript_check_ (array, element, i, total_dims,
 921                                                array_name);
 922           if (element == error_mark_node)
 923             return element;
 924
 925           /* Widen integral arithmetic as desired while preserving
 926              signedness.  */
 927           tree_type = TREE_TYPE (element);
 928           tree_type_x = tree_type;
 929           if (tree_type
 930               && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
 931               && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
 932             tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
 933
 934           element = convert (tree_type_x, element);
 935
 936           item = ffecom_2 (ARRAY_REF,
 937                            TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
 938                            item,
 939                            element);
 940         }
 941     }
 942
 943   return item;
 944 }
 945
 946 /* This is like gcc's stabilize_reference -- in fact, most of the code
 947    comes from that -- but it handles the situation where the reference
 948    is going to have its subparts picked at, and it shouldn't change
 949    (or trigger extra invocations of functions in the subtrees) due to
 950    this.  save_expr is a bit overzealous, because we don't need the
 951    entire thing calculated and saved like a temp.  So, for DECLs, no
 952    change is needed, because these are stable aggregates, and ARRAY_REF
 953    and such might well be stable too, but for things like calculations,
 954    we do need to calculate a snapshot of a value before picking at it.  */
 955
 956 static tree
 957 ffecom_stabilize_aggregate_ (tree ref)
 958 {
 959   tree result;
 960   enum tree_code code = TREE_CODE (ref);
 961
 962   switch (code)
 963     {
 964     case VAR_DECL:
 965     case PARM_DECL:
 966     case RESULT_DECL:
 967       /* No action is needed in this case.  */
 968       return ref;
 969
 970     case NOP_EXPR:
 971     case CONVERT_EXPR:
 972     case FLOAT_EXPR:
 973     case FIX_TRUNC_EXPR:
 974     case FIX_FLOOR_EXPR:
 975     case FIX_ROUND_EXPR:
 976     case FIX_CEIL_EXPR:
 977       result = build_nt (code, stabilize_reference (TREE_OPERAND (ref, 0)));
 978       break;
 979
 980     case INDIRECT_REF:
 981       result = build_nt (INDIRECT_REF,
 982                          stabilize_reference_1 (TREE_OPERAND (ref, 0)));
 983       break;
 984
 985     case COMPONENT_REF:
 986       result = build_nt (COMPONENT_REF,
 987                          stabilize_reference (TREE_OPERAND (ref, 0)),
 988                          TREE_OPERAND (ref, 1));
 989       break;
 990
 991     case BIT_FIELD_REF:
 992       result = build_nt (BIT_FIELD_REF,
 993                          stabilize_reference (TREE_OPERAND (ref, 0)),
 994                          stabilize_reference_1 (TREE_OPERAND (ref, 1)),
 995                          stabilize_reference_1 (TREE_OPERAND (ref, 2)));
 996       break;
 997
 998     case ARRAY_REF:
 999       result = build_nt (ARRAY_REF,
1000                          stabilize_reference (TREE_OPERAND (ref, 0)),
1001                          stabilize_reference_1 (TREE_OPERAND (ref, 1)));
1002       break;
1003
1004     case COMPOUND_EXPR:
1005       result = build_nt (COMPOUND_EXPR,
1006                          stabilize_reference_1 (TREE_OPERAND (ref, 0)),
1007                          stabilize_reference (TREE_OPERAND (ref, 1)));
1008       break;
1009
1010     case RTL_EXPR:
1011       abort ();
1012
1013
1014     default:
1015       return save_expr (ref);
1016
1017     case ERROR_MARK:
1018       return error_mark_node;
1019     }
1020
1021   TREE_TYPE (result) = TREE_TYPE (ref);
1022   TREE_READONLY (result) = TREE_READONLY (ref);
1023   TREE_SIDE_EFFECTS (result) = TREE_SIDE_EFFECTS (ref);
1024   TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref);
1025
1026   return result;
1027 }
1028
1029 /* A rip-off of gcc's convert.c convert_to_complex function,
1030    reworked to handle complex implemented as C structures
1031    (RECORD_TYPE with two fields, real and imaginary `r' and `i').  */
1032
1033 static tree
1034 ffecom_convert_to_complex_ (tree type, tree expr)
1035 {
1036   register enum tree_code form = TREE_CODE (TREE_TYPE (expr));
1037   tree subtype;
1038
1039   assert (TREE_CODE (type) == RECORD_TYPE);
1040
1041   subtype = TREE_TYPE (TYPE_FIELDS (type));
1042
1043   if (form == REAL_TYPE || form == INTEGER_TYPE || form == ENUMERAL_TYPE)
1044     {
1045       expr = convert (subtype, expr);
1046       return ffecom_2 (COMPLEX_EXPR, type, expr,
1047                        convert (subtype, integer_zero_node));
1048     }
1049
1050   if (form == RECORD_TYPE)
1051     {
1052       tree elt_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr)));
1053       if (TYPE_MAIN_VARIANT (elt_type) == TYPE_MAIN_VARIANT (subtype))
1054         return expr;
1055       else
1056         {
1057           expr = save_expr (expr);
1058           return ffecom_2 (COMPLEX_EXPR,
1059                            type,
1060                            convert (subtype,
1061                                     ffecom_1 (REALPART_EXPR,
1062                                               TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1063                                               expr)),
1064                            convert (subtype,
1065                                     ffecom_1 (IMAGPART_EXPR,
1066                                               TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1067                                               expr)));
1068         }
1069     }
1070
1071   if (form == POINTER_TYPE || form == REFERENCE_TYPE)
1072     error ("pointer value used where a complex was expected");
1073   else
1074     error ("aggregate value used where a complex was expected");
1075
1076   return ffecom_2 (COMPLEX_EXPR, type,
1077                    convert (subtype, integer_zero_node),
1078                    convert (subtype, integer_zero_node));
1079 }
1080
1081 /* Like gcc's convert(), but crashes if widening might happen.  */
1082
1083 static tree
1084 ffecom_convert_narrow_ (type, expr)
1085      tree type, expr;
1086 {
1087   register tree e = expr;
1088   register enum tree_code code = TREE_CODE (type);
1089
1090   if (type == TREE_TYPE (e)
1091       || TREE_CODE (e) == ERROR_MARK)
1092     return e;
1093   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1094     return fold (build1 (NOP_EXPR, type, e));
1095   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1096       || code == ERROR_MARK)
1097     return error_mark_node;
1098   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1099     {
1100       assert ("void value not ignored as it ought to be" == NULL);
1101       return error_mark_node;
1102     }
1103   assert (code != VOID_TYPE);
1104   if ((code != RECORD_TYPE)
1105       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1106     assert ("converting COMPLEX to REAL" == NULL);
1107   assert (code != ENUMERAL_TYPE);
1108   if (code == INTEGER_TYPE)
1109     {
1110       assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1111                && TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)))
1112               || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1113                   && (TYPE_PRECISION (type)
1114                       == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1115       return fold (convert_to_integer (type, e));
1116     }
1117   if (code == POINTER_TYPE)
1118     {
1119       assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1120       return fold (convert_to_pointer (type, e));
1121     }
1122   if (code == REAL_TYPE)
1123     {
1124       assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1125       assert (TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)));
1126       return fold (convert_to_real (type, e));
1127     }
1128   if (code == COMPLEX_TYPE)
1129     {
1130       assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1131       assert (TYPE_PRECISION (TREE_TYPE (type)) <= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1132       return fold (convert_to_complex (type, e));
1133     }
1134   if (code == RECORD_TYPE)
1135     {
1136       assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1137       /* Check that at least the first field name agrees.  */
1138       assert (DECL_NAME (TYPE_FIELDS (type))
1139               == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1140       assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1141               <= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1142       if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1143           == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1144         return e;
1145       return fold (ffecom_convert_to_complex_ (type, e));
1146     }
1147
1148   assert ("conversion to non-scalar type requested" == NULL);
1149   return error_mark_node;
1150 }
1151
1152 /* Like gcc's convert(), but crashes if narrowing might happen.  */
1153
1154 static tree
1155 ffecom_convert_widen_ (type, expr)
1156      tree type, expr;
1157 {
1158   register tree e = expr;
1159   register enum tree_code code = TREE_CODE (type);
1160
1161   if (type == TREE_TYPE (e)
1162       || TREE_CODE (e) == ERROR_MARK)
1163     return e;
1164   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1165     return fold (build1 (NOP_EXPR, type, e));
1166   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1167       || code == ERROR_MARK)
1168     return error_mark_node;
1169   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1170     {
1171       assert ("void value not ignored as it ought to be" == NULL);
1172       return error_mark_node;
1173     }
1174   assert (code != VOID_TYPE);
1175   if ((code != RECORD_TYPE)
1176       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1177     assert ("narrowing COMPLEX to REAL" == NULL);
1178   assert (code != ENUMERAL_TYPE);
1179   if (code == INTEGER_TYPE)
1180     {
1181       assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1182                && TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)))
1183               || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1184                   && (TYPE_PRECISION (type)
1185                       == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1186       return fold (convert_to_integer (type, e));
1187     }
1188   if (code == POINTER_TYPE)
1189     {
1190       assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1191       return fold (convert_to_pointer (type, e));
1192     }
1193   if (code == REAL_TYPE)
1194     {
1195       assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1196       assert (TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)));
1197       return fold (convert_to_real (type, e));
1198     }
1199   if (code == COMPLEX_TYPE)
1200     {
1201       assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1202       assert (TYPE_PRECISION (TREE_TYPE (type)) >= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1203       return fold (convert_to_complex (type, e));
1204     }
1205   if (code == RECORD_TYPE)
1206     {
1207       assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1208       /* Check that at least the first field name agrees.  */
1209       assert (DECL_NAME (TYPE_FIELDS (type))
1210               == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1211       assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1212               >= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1213       if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1214           == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1215         return e;
1216       return fold (ffecom_convert_to_complex_ (type, e));
1217     }
1218
1219   assert ("conversion to non-scalar type requested" == NULL);
1220   return error_mark_node;
1221 }
1222
1223 /* Handles making a COMPLEX type, either the standard
1224    (but buggy?) gbe way, or the safer (but less elegant?)
1225    f2c way.  */
1226
1227 static tree
1228 ffecom_make_complex_type_ (tree subtype)
1229 {
1230   tree type;
1231   tree realfield;
1232   tree imagfield;
1233
1234   if (ffe_is_emulate_complex ())
1235     {
1236       type = make_node (RECORD_TYPE);
1237       realfield = ffecom_decl_field (type, NULL_TREE, "r", subtype);
1238       imagfield = ffecom_decl_field (type, realfield, "i", subtype);
1239       TYPE_FIELDS (type) = realfield;
1240       layout_type (type);
1241     }
1242   else
1243     {
1244       type = make_node (COMPLEX_TYPE);
1245       TREE_TYPE (type) = subtype;
1246       layout_type (type);
1247     }
1248
1249   return type;
1250 }
1251
1252 /* Chooses either the gbe or the f2c way to build a
1253    complex constant.  */
1254
1255 static tree
1256 ffecom_build_complex_constant_ (tree type, tree realpart, tree imagpart)
1257 {
1258   tree bothparts;
1259
1260   if (ffe_is_emulate_complex ())
1261     {
1262       bothparts = build_tree_list (TYPE_FIELDS (type), realpart);
1263       TREE_CHAIN (bothparts) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), imagpart);
1264       bothparts = build (CONSTRUCTOR, type, NULL_TREE, bothparts);
1265     }
1266   else
1267     {
1268       bothparts = build_complex (type, realpart, imagpart);
1269     }
1270
1271   return bothparts;
1272 }
1273
1274 static tree
1275 ffecom_arglist_expr_ (const char *c, ffebld expr)
1276 {
1277   tree list;
1278   tree *plist = &list;
1279   tree trail = NULL_TREE;       /* Append char length args here. */
1280   tree *ptrail = &trail;
1281   tree length;
1282   ffebld exprh;
1283   tree item;
1284   bool ptr = FALSE;
1285   tree wanted = NULL_TREE;
1286   static char zed[] = "0";
1287
1288   if (c == NULL)
1289     c = &zed[0];
1290
1291   while (expr != NULL)
1292     {
1293       if (*c != '\0')
1294         {
1295           ptr = FALSE;
1296           if (*c == '&')
1297             {
1298               ptr = TRUE;
1299               ++c;
1300             }
1301           switch (*(c++))
1302             {
1303             case '\0':
1304               ptr = TRUE;
1305               wanted = NULL_TREE;
1306               break;
1307
1308             case 'a':
1309               assert (ptr);
1310               wanted = NULL_TREE;
1311               break;
1312
1313             case 'c':
1314               wanted = ffecom_f2c_complex_type_node;
1315               break;
1316
1317             case 'd':
1318               wanted = ffecom_f2c_doublereal_type_node;
1319               break;
1320
1321             case 'e':
1322               wanted = ffecom_f2c_doublecomplex_type_node;
1323               break;
1324
1325             case 'f':
1326               wanted = ffecom_f2c_real_type_node;
1327               break;
1328
1329             case 'i':
1330               wanted = ffecom_f2c_integer_type_node;
1331               break;
1332
1333             case 'j':
1334               wanted = ffecom_f2c_longint_type_node;
1335               break;
1336
1337             default:
1338               assert ("bad argstring code" == NULL);
1339               wanted = NULL_TREE;
1340               break;
1341             }
1342         }
1343
1344       exprh = ffebld_head (expr);
1345       if (exprh == NULL)
1346         wanted = NULL_TREE;
1347
1348       if ((wanted == NULL_TREE)
1349           || (ptr
1350               && (TYPE_MODE
1351                   (ffecom_tree_type[ffeinfo_basictype (ffebld_info (exprh))]
1352                    [ffeinfo_kindtype (ffebld_info (exprh))])
1353                    == TYPE_MODE (wanted))))
1354         *plist
1355           = build_tree_list (NULL_TREE,
1356                              ffecom_arg_ptr_to_expr (exprh,
1357                                                      &length));
1358       else
1359         {
1360           item = ffecom_arg_expr (exprh, &length);
1361           item = ffecom_convert_widen_ (wanted, item);
1362           if (ptr)
1363             {
1364               item = ffecom_1 (ADDR_EXPR,
1365                                build_pointer_type (TREE_TYPE (item)),
1366                                item);
1367             }
1368           *plist
1369             = build_tree_list (NULL_TREE,
1370                                item);
1371         }
1372
1373       plist = &TREE_CHAIN (*plist);
1374       expr = ffebld_trail (expr);
1375       if (length != NULL_TREE)
1376         {
1377           *ptrail = build_tree_list (NULL_TREE, length);
1378           ptrail = &TREE_CHAIN (*ptrail);
1379         }
1380     }
1381
1382   /* We've run out of args in the call; if the implementation expects
1383      more, supply null pointers for them, which the implementation can
1384      check to see if an arg was omitted. */
1385
1386   while (*c != '\0' && *c != '0')
1387     {
1388       if (*c == '&')
1389         ++c;
1390       else
1391         assert ("missing arg to run-time routine!" == NULL);
1392
1393       switch (*(c++))
1394         {
1395         case '\0':
1396         case 'a':
1397         case 'c':
1398         case 'd':
1399         case 'e':
1400         case 'f':
1401         case 'i':
1402         case 'j':
1403           break;
1404
1405         default:
1406           assert ("bad arg string code" == NULL);
1407           break;
1408         }
1409       *plist
1410         = build_tree_list (NULL_TREE,
1411                            null_pointer_node);
1412       plist = &TREE_CHAIN (*plist);
1413     }
1414
1415   *plist = trail;
1416
1417   return list;
1418 }
1419
1420 static tree
1421 ffecom_widest_expr_type_ (ffebld list)
1422 {
1423   ffebld item;
1424   ffebld widest = NULL;
1425   ffetype type;
1426   ffetype widest_type = NULL;
1427   tree t;
1428
1429   for (; list != NULL; list = ffebld_trail (list))
1430     {
1431       item = ffebld_head (list);
1432       if (item == NULL)
1433         continue;
1434       if ((widest != NULL)
1435           && (ffeinfo_basictype (ffebld_info (item))
1436               != ffeinfo_basictype (ffebld_info (widest))))
1437         continue;
1438       type = ffeinfo_type (ffeinfo_basictype (ffebld_info (item)),
1439                            ffeinfo_kindtype (ffebld_info (item)));
1440       if ((widest == FFEINFO_kindtypeNONE)
1441           || (ffetype_size (type)
1442               > ffetype_size (widest_type)))
1443         {
1444           widest = item;
1445           widest_type = type;
1446         }
1447     }
1448
1449   assert (widest != NULL);
1450   t = ffecom_tree_type[ffeinfo_basictype (ffebld_info (widest))]
1451     [ffeinfo_kindtype (ffebld_info (widest))];
1452   assert (t != NULL_TREE);
1453   return t;
1454 }
1455
1456 /* Check whether a partial overlap between two expressions is possible.
1457
1458    Can *starting* to write a portion of expr1 change the value
1459    computed (perhaps already, *partially*) by expr2?
1460
1461    Currently, this is a concern only for a COMPLEX expr1.  But if it
1462    isn't in COMMON or local EQUIVALENCE, since we don't support
1463    aliasing of arguments, it isn't a concern.  */
1464
1465 static bool
1466 ffecom_possible_partial_overlap_ (ffebld expr1, ffebld expr2 ATTRIBUTE_UNUSED)
1467 {
1468   ffesymbol sym;
1469   ffestorag st;
1470
1471   switch (ffebld_op (expr1))
1472     {
1473     case FFEBLD_opSYMTER:
1474       sym = ffebld_symter (expr1);
1475       break;
1476
1477     case FFEBLD_opARRAYREF:
1478       if (ffebld_op (ffebld_left (expr1)) != FFEBLD_opSYMTER)
1479         return FALSE;
1480       sym = ffebld_symter (ffebld_left (expr1));
1481       break;
1482
1483     default:
1484       return FALSE;
1485     }
1486
1487   if (ffesymbol_where (sym) != FFEINFO_whereCOMMON
1488       && (ffesymbol_where (sym) != FFEINFO_whereLOCAL
1489           || ! (st = ffesymbol_storage (sym))
1490           || ! ffestorag_parent (st)))
1491     return FALSE;
1492
1493   /* It's in COMMON or local EQUIVALENCE.  */
1494
1495   return TRUE;
1496 }
1497
1498 /* Check whether dest and source might overlap.  ffebld versions of these
1499    might or might not be passed, will be NULL if not.
1500
1501    The test is really whether source_tree is modifiable and, if modified,
1502    might overlap destination such that the value(s) in the destination might
1503    change before it is finally modified.  dest_* are the canonized
1504    destination itself.  */
1505
1506 static bool
1507 ffecom_overlap_ (tree dest_decl, tree dest_offset, tree dest_size,
1508                  tree source_tree, ffebld source UNUSED,
1509                  bool scalar_arg)
1510 {
1511   tree source_decl;
1512   tree source_offset;
1513   tree source_size;
1514   tree t;
1515
1516   if (source_tree == NULL_TREE)
1517     return FALSE;
1518
1519   switch (TREE_CODE (source_tree))
1520     {
1521     case ERROR_MARK:
1522     case IDENTIFIER_NODE:
1523     case INTEGER_CST:
1524     case REAL_CST:
1525     case COMPLEX_CST:
1526     case STRING_CST:
1527     case CONST_DECL:
1528     case VAR_DECL:
1529     case RESULT_DECL:
1530     case FIELD_DECL:
1531     case MINUS_EXPR:
1532     case MULT_EXPR:
1533     case TRUNC_DIV_EXPR:
1534     case CEIL_DIV_EXPR:
1535     case FLOOR_DIV_EXPR:
1536     case ROUND_DIV_EXPR:
1537     case TRUNC_MOD_EXPR:
1538     case CEIL_MOD_EXPR:
1539     case FLOOR_MOD_EXPR:
1540     case ROUND_MOD_EXPR:
1541     case RDIV_EXPR:
1542     case EXACT_DIV_EXPR:
1543     case FIX_TRUNC_EXPR:
1544     case FIX_CEIL_EXPR:
1545     case FIX_FLOOR_EXPR:
1546     case FIX_ROUND_EXPR:
1547     case FLOAT_EXPR:
1548     case NEGATE_EXPR:
1549     case MIN_EXPR:
1550     case MAX_EXPR:
1551     case ABS_EXPR:
1552     case FFS_EXPR:
1553     case LSHIFT_EXPR:
1554     case RSHIFT_EXPR:
1555     case LROTATE_EXPR:
1556     case RROTATE_EXPR:
1557     case BIT_IOR_EXPR:
1558     case BIT_XOR_EXPR:
1559     case BIT_AND_EXPR:
1560     case BIT_ANDTC_EXPR:
1561     case BIT_NOT_EXPR:
1562     case TRUTH_ANDIF_EXPR:
1563     case TRUTH_ORIF_EXPR:
1564     case TRUTH_AND_EXPR:
1565     case TRUTH_OR_EXPR:
1566     case TRUTH_XOR_EXPR:
1567     case TRUTH_NOT_EXPR:
1568     case LT_EXPR:
1569     case LE_EXPR:
1570     case GT_EXPR:
1571     case GE_EXPR:
1572     case EQ_EXPR:
1573     case NE_EXPR:
1574     case COMPLEX_EXPR:
1575     case CONJ_EXPR:
1576     case REALPART_EXPR:
1577     case IMAGPART_EXPR:
1578     case LABEL_EXPR:
1579     case COMPONENT_REF:
1580       return FALSE;
1581
1582     case COMPOUND_EXPR:
1583       return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1584                               TREE_OPERAND (source_tree, 1), NULL,
1585                               scalar_arg);
1586
1587     case MODIFY_EXPR:
1588       return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1589                               TREE_OPERAND (source_tree, 0), NULL,
1590                               scalar_arg);
1591
1592     case CONVERT_EXPR:
1593     case NOP_EXPR:
1594     case NON_LVALUE_EXPR:
1595     case PLUS_EXPR:
1596       if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1597         return TRUE;
1598
1599       ffecom_tree_canonize_ptr_ (&source_decl, &source_offset,
1600                                  source_tree);
1601       source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1602       break;
1603
1604     case COND_EXPR:
1605       return
1606         ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1607                          TREE_OPERAND (source_tree, 1), NULL,
1608                          scalar_arg)
1609           || ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1610                               TREE_OPERAND (source_tree, 2), NULL,
1611                               scalar_arg);
1612
1613
1614     case ADDR_EXPR:
1615       ffecom_tree_canonize_ref_ (&source_decl, &source_offset,
1616                                  &source_size,
1617                                  TREE_OPERAND (source_tree, 0));
1618       break;
1619
1620     case PARM_DECL:
1621       if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1622         return TRUE;
1623
1624       source_decl = source_tree;
1625       source_offset = bitsize_zero_node;
1626       source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1627       break;
1628
1629     case SAVE_EXPR:
1630     case REFERENCE_EXPR:
1631     case PREDECREMENT_EXPR:
1632     case PREINCREMENT_EXPR:
1633     case POSTDECREMENT_EXPR:
1634     case POSTINCREMENT_EXPR:
1635     case INDIRECT_REF:
1636     case ARRAY_REF:
1637     case CALL_EXPR:
1638     default:
1639       return TRUE;
1640     }
1641
1642   /* Come here when source_decl, source_offset, and source_size filled
1643      in appropriately.  */
1644
1645   if (source_decl == NULL_TREE)
1646     return FALSE;               /* No decl involved, so no overlap. */
1647
1648   if (source_decl != dest_decl)
1649     return FALSE;               /* Different decl, no overlap. */
1650
1651   if (TREE_CODE (dest_size) == ERROR_MARK)
1652     return TRUE;                /* Assignment into entire assumed-size
1653                                    array?  Shouldn't happen.... */
1654
1655   t = ffecom_2 (LE_EXPR, integer_type_node,
1656                 ffecom_2 (PLUS_EXPR, TREE_TYPE (dest_offset),
1657                           dest_offset,
1658                           convert (TREE_TYPE (dest_offset),
1659                                    dest_size)),
1660                 convert (TREE_TYPE (dest_offset),
1661                          source_offset));
1662
1663   if (integer_onep (t))
1664     return FALSE;               /* Destination precedes source. */
1665
1666   if (!scalar_arg
1667       || (source_size == NULL_TREE)
1668       || (TREE_CODE (source_size) == ERROR_MARK)
1669       || integer_zerop (source_size))
1670     return TRUE;                /* No way to tell if dest follows source. */
1671
1672   t = ffecom_2 (LE_EXPR, integer_type_node,
1673                 ffecom_2 (PLUS_EXPR, TREE_TYPE (source_offset),
1674                           source_offset,
1675                           convert (TREE_TYPE (source_offset),
1676                                    source_size)),
1677                 convert (TREE_TYPE (source_offset),
1678                          dest_offset));
1679
1680   if (integer_onep (t))
1681     return FALSE;               /* Destination follows source. */
1682
1683   return TRUE;          /* Destination and source overlap. */
1684 }
1685
1686 /* Check whether dest might overlap any of a list of arguments or is
1687    in a COMMON area the callee might know about (and thus modify).  */
1688
1689 static bool
1690 ffecom_args_overlapping_ (tree dest_tree, ffebld dest UNUSED,
1691                           tree args, tree callee_commons,
1692                           bool scalar_args)
1693 {
1694   tree arg;
1695   tree dest_decl;
1696   tree dest_offset;
1697   tree dest_size;
1698
1699   ffecom_tree_canonize_ref_ (&dest_decl, &dest_offset, &dest_size,
1700                              dest_tree);
1701
1702   if (dest_decl == NULL_TREE)
1703     return FALSE;               /* Seems unlikely! */
1704
1705   /* If the decl cannot be determined reliably, or if its in COMMON
1706      and the callee isn't known to not futz with COMMON via other
1707      means, overlap might happen.  */
1708
1709   if ((TREE_CODE (dest_decl) == ERROR_MARK)
1710       || ((callee_commons != NULL_TREE)
1711           && TREE_PUBLIC (dest_decl)))
1712     return TRUE;
1713
1714   for (; args != NULL_TREE; args = TREE_CHAIN (args))
1715     {
1716       if (((arg = TREE_VALUE (args)) != NULL_TREE)
1717           && ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1718                               arg, NULL, scalar_args))
1719         return TRUE;
1720     }
1721
1722   return FALSE;
1723 }
1724
1725 /* Build a string for a variable name as used by NAMELIST.  This means that
1726    if we're using the f2c library, we build an uppercase string, since
1727    f2c does this.  */
1728
1729 static tree
1730 ffecom_build_f2c_string_ (int i, const char *s)
1731 {
1732   if (!ffe_is_f2c_library ())
1733     return build_string (i, s);
1734
1735   {
1736     char *tmp;
1737     const char *p;
1738     char *q;
1739     char space[34];
1740     tree t;
1741
1742     if (((size_t) i) > ARRAY_SIZE (space))
1743       tmp = malloc_new_ks (malloc_pool_image (), "f2c_string", i);
1744     else
1745       tmp = &space[0];
1746
1747     for (p = s, q = tmp; *p != '\0'; ++p, ++q)
1748       *q = TOUPPER (*p);
1749     *q = '\0';
1750
1751     t = build_string (i, tmp);
1752
1753     if (((size_t) i) > ARRAY_SIZE (space))
1754       malloc_kill_ks (malloc_pool_image (), tmp, i);
1755
1756     return t;
1757   }
1758 }
1759
1760 /* Returns CALL_EXPR or equivalent with given type (pass NULL_TREE for
1761    type to just get whatever the function returns), handling the
1762    f2c value-returning convention, if required, by prepending
1763    to the arglist a pointer to a temporary to receive the return value.  */
1764
1765 static tree
1766 ffecom_call_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1767               tree type, tree args, tree dest_tree,
1768               ffebld dest, bool *dest_used, tree callee_commons,
1769               bool scalar_args, tree hook)
1770 {
1771   tree item;
1772   tree tempvar;
1773
1774   if (dest_used != NULL)
1775     *dest_used = FALSE;
1776
1777   if (is_f2c_complex)
1778     {
1779       if ((dest_used == NULL)
1780           || (dest == NULL)
1781           || (ffeinfo_basictype (ffebld_info (dest))
1782               != FFEINFO_basictypeCOMPLEX)
1783           || (ffeinfo_kindtype (ffebld_info (dest)) != kt)
1784           || ((type != NULL_TREE) && (TREE_TYPE (dest_tree) != type))
1785           || ffecom_args_overlapping_ (dest_tree, dest, args,
1786                                        callee_commons,
1787                                        scalar_args))
1788         {
1789 #ifdef HOHO
1790           tempvar = ffecom_make_tempvar (ffecom_tree_type
1791                                          [FFEINFO_basictypeCOMPLEX][kt],
1792                                          FFETARGET_charactersizeNONE,
1793                                          -1);
1794 #else
1795           tempvar = hook;
1796           assert (tempvar);
1797 #endif
1798         }
1799       else
1800         {
1801           *dest_used = TRUE;
1802           tempvar = dest_tree;
1803           type = NULL_TREE;
1804         }
1805
1806       item
1807         = build_tree_list (NULL_TREE,
1808                            ffecom_1 (ADDR_EXPR,
1809                                      build_pointer_type (TREE_TYPE (tempvar)),
1810                                      tempvar));
1811       TREE_CHAIN (item) = args;
1812
1813       item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1814                         item, NULL_TREE);
1815
1816       if (tempvar != dest_tree)
1817         item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item, tempvar);
1818     }
1819   else
1820     item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1821                       args, NULL_TREE);
1822
1823   if ((type != NULL_TREE) && (TREE_TYPE (item) != type))
1824     item = ffecom_convert_narrow_ (type, item);
1825
1826   return item;
1827 }
1828
1829 /* Given two arguments, transform them and make a call to the given
1830    function via ffecom_call_.  */
1831
1832 static tree
1833 ffecom_call_binop_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1834                     tree type, ffebld left, ffebld right,
1835                     tree dest_tree, ffebld dest, bool *dest_used,
1836                     tree callee_commons, bool scalar_args, bool ref, tree hook)
1837 {
1838   tree left_tree;
1839   tree right_tree;
1840   tree left_length;
1841   tree right_length;
1842
1843   if (ref)
1844     {
1845       /* Pass arguments by reference.  */
1846       left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
1847       right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
1848     }
1849   else
1850     {
1851       /* Pass arguments by value.  */
1852       left_tree = ffecom_arg_expr (left, &left_length);
1853       right_tree = ffecom_arg_expr (right, &right_length);
1854     }
1855
1856
1857   left_tree = build_tree_list (NULL_TREE, left_tree);
1858   right_tree = build_tree_list (NULL_TREE, right_tree);
1859   TREE_CHAIN (left_tree) = right_tree;
1860
1861   if (left_length != NULL_TREE)
1862     {
1863       left_length = build_tree_list (NULL_TREE, left_length);
1864       TREE_CHAIN (right_tree) = left_length;
1865     }
1866
1867   if (right_length != NULL_TREE)
1868     {
1869       right_length = build_tree_list (NULL_TREE, right_length);
1870       if (left_length != NULL_TREE)
1871         TREE_CHAIN (left_length) = right_length;
1872       else
1873         TREE_CHAIN (right_tree) = right_length;
1874     }
1875
1876   return ffecom_call_ (fn, kt, is_f2c_complex, type, left_tree,
1877                        dest_tree, dest, dest_used, callee_commons,
1878                        scalar_args, hook);
1879 }
1880
1881 /* Return ptr/length args for char subexpression
1882
1883    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
1884    subexpressions by constructing the appropriate trees for the ptr-to-
1885    character-text and length-of-character-text arguments in a calling
1886    sequence.
1887
1888    Note that if with_null is TRUE, and the expression is an opCONTER,
1889    a null byte is appended to the string.  */
1890
1891 static void
1892 ffecom_char_args_x_ (tree *xitem, tree *length, ffebld expr, bool with_null)
1893 {
1894   tree item;
1895   tree high;
1896   ffetargetCharacter1 val;
1897   ffetargetCharacterSize newlen;
1898
1899   switch (ffebld_op (expr))
1900     {
1901     case FFEBLD_opCONTER:
1902       val = ffebld_constant_character1 (ffebld_conter (expr));
1903       newlen = ffetarget_length_character1 (val);
1904       if (with_null)
1905         {
1906           /* Begin FFETARGET-NULL-KLUDGE.  */
1907           if (newlen != 0)
1908             ++newlen;
1909         }
1910       *length = build_int_2 (newlen, 0);
1911       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
1912       high = build_int_2 (newlen, 0);
1913       TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
1914       item = build_string (newlen,
1915                            ffetarget_text_character1 (val));
1916       /* End FFETARGET-NULL-KLUDGE.  */
1917       TREE_TYPE (item)
1918         = build_type_variant
1919           (build_array_type
1920            (char_type_node,
1921             build_range_type
1922             (ffecom_f2c_ftnlen_type_node,
1923              ffecom_f2c_ftnlen_one_node,
1924              high)),
1925            1, 0);
1926       TREE_CONSTANT (item) = 1;
1927       TREE_STATIC (item) = 1;
1928       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
1929                        item);
1930       break;
1931
1932     case FFEBLD_opSYMTER:
1933       {
1934         ffesymbol s = ffebld_symter (expr);
1935
1936         item = ffesymbol_hook (s).decl_tree;
1937         if (item == NULL_TREE)
1938           {
1939             s = ffecom_sym_transform_ (s);
1940             item = ffesymbol_hook (s).decl_tree;
1941           }
1942         if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
1943           {
1944             if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
1945               *length = ffesymbol_hook (s).length_tree;
1946             else
1947               {
1948                 *length = build_int_2 (ffesymbol_size (s), 0);
1949                 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
1950               }
1951           }
1952         else if (item == error_mark_node)
1953           *length = error_mark_node;
1954         else
1955           /* FFEINFO_kindFUNCTION.  */
1956           *length = NULL_TREE;
1957         if (!ffesymbol_hook (s).addr
1958             && (item != error_mark_node))
1959           item = ffecom_1 (ADDR_EXPR,
1960                            build_pointer_type (TREE_TYPE (item)),
1961                            item);
1962       }
1963       break;
1964
1965     case FFEBLD_opARRAYREF:
1966       {
1967         ffecom_char_args_ (&item, length, ffebld_left (expr));
1968
1969         if (item == error_mark_node || *length == error_mark_node)
1970           {
1971             item = *length = error_mark_node;
1972             break;
1973           }
1974
1975         item = ffecom_arrayref_ (item, expr, 1);
1976       }
1977       break;
1978
1979     case FFEBLD_opSUBSTR:
1980       {
1981         ffebld start;
1982         ffebld end;
1983         ffebld thing = ffebld_right (expr);
1984         tree start_tree;
1985         tree end_tree;
1986         const char *char_name;
1987         ffebld left_symter;
1988         tree array;
1989
1990         assert (ffebld_op (thing) == FFEBLD_opITEM);
1991         start = ffebld_head (thing);
1992         thing = ffebld_trail (thing);
1993         assert (ffebld_trail (thing) == NULL);
1994         end = ffebld_head (thing);
1995
1996         /* Determine name for pretty-printing range-check errors.  */
1997         for (left_symter = ffebld_left (expr);
1998              left_symter && ffebld_op (left_symter) == FFEBLD_opARRAYREF;
1999              left_symter = ffebld_left (left_symter))
2000           ;
2001         if (ffebld_op (left_symter) == FFEBLD_opSYMTER)
2002           char_name = ffesymbol_text (ffebld_symter (left_symter));
2003         else
2004           char_name = "[expr?]";
2005
2006         ffecom_char_args_ (&item, length, ffebld_left (expr));
2007
2008         if (item == error_mark_node || *length == error_mark_node)
2009           {
2010             item = *length = error_mark_node;
2011             break;
2012           }
2013
2014         array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
2015
2016         /* ~~~~Handle INTEGER*8 start/end, a la FFEBLD_opARRAYREF.  */
2017
2018         if (start == NULL)
2019           {
2020             if (end == NULL)
2021               ;
2022             else
2023               {
2024                 end_tree = ffecom_expr (end);
2025                 if (flag_bounds_check)
2026                   end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2027                                                       char_name);
2028                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2029                                     end_tree);
2030
2031                 if (end_tree == error_mark_node)
2032                   {
2033                     item = *length = error_mark_node;
2034                     break;
2035                   }
2036
2037                 *length = end_tree;
2038               }
2039           }
2040         else
2041           {
2042             start_tree = ffecom_expr (start);
2043             if (flag_bounds_check)
2044               start_tree = ffecom_subscript_check_ (array, start_tree, 0, 0,
2045                                                     char_name);
2046             start_tree = convert (ffecom_f2c_ftnlen_type_node,
2047                                   start_tree);
2048
2049             if (start_tree == error_mark_node)
2050               {
2051                 item = *length = error_mark_node;
2052                 break;
2053               }
2054
2055             start_tree = ffecom_save_tree (start_tree);
2056
2057             item = ffecom_2 (PLUS_EXPR, TREE_TYPE (item),
2058                              item,
2059                              ffecom_2 (MINUS_EXPR,
2060                                        TREE_TYPE (start_tree),
2061                                        start_tree,
2062                                        ffecom_f2c_ftnlen_one_node));
2063
2064             if (end == NULL)
2065               {
2066                 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2067                                     ffecom_f2c_ftnlen_one_node,
2068                                     ffecom_2 (MINUS_EXPR,
2069                                               ffecom_f2c_ftnlen_type_node,
2070                                               *length,
2071                                               start_tree));
2072               }
2073             else
2074               {
2075                 end_tree = ffecom_expr (end);
2076                 if (flag_bounds_check)
2077                   end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2078                                                       char_name);
2079                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2080                                     end_tree);
2081
2082                 if (end_tree == error_mark_node)
2083                   {
2084                     item = *length = error_mark_node;
2085                     break;
2086                   }
2087
2088                 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2089                                     ffecom_f2c_ftnlen_one_node,
2090                                     ffecom_2 (MINUS_EXPR,
2091                                               ffecom_f2c_ftnlen_type_node,
2092                                               end_tree, start_tree));
2093               }
2094           }
2095       }
2096       break;
2097
2098     case FFEBLD_opFUNCREF:
2099       {
2100         ffesymbol s = ffebld_symter (ffebld_left (expr));
2101         tree tempvar;
2102         tree args;
2103         ffetargetCharacterSize size = ffeinfo_size (ffebld_info (expr));
2104         ffecomGfrt ix;
2105
2106         if (size == FFETARGET_charactersizeNONE)
2107           /* ~~Kludge alert!  This should someday be fixed. */
2108           size = 24;
2109
2110         *length = build_int_2 (size, 0);
2111         TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2112
2113         if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
2114             == FFEINFO_whereINTRINSIC)
2115           {
2116             if (size == 1)
2117               {
2118                 /* Invocation of an intrinsic returning CHARACTER*1.  */
2119                 item = ffecom_expr_intrinsic_ (expr, NULL_TREE,
2120                                                NULL, NULL);
2121                 break;
2122               }
2123             ix = ffeintrin_gfrt_direct (ffebld_symter_implementation (ffebld_left (expr)));
2124             assert (ix != FFECOM_gfrt);
2125             item = ffecom_gfrt_tree_ (ix);
2126           }
2127         else
2128           {
2129             ix = FFECOM_gfrt;
2130             item = ffesymbol_hook (s).decl_tree;
2131             if (item == NULL_TREE)
2132               {
2133                 s = ffecom_sym_transform_ (s);
2134                 item = ffesymbol_hook (s).decl_tree;
2135               }
2136             if (item == error_mark_node)
2137               {
2138                 item = *length = error_mark_node;
2139                 break;
2140               }
2141
2142             if (!ffesymbol_hook (s).addr)
2143               item = ffecom_1_fn (item);
2144           }
2145
2146 #ifdef HOHO
2147         tempvar = ffecom_push_tempvar (char_type_node, size, -1, TRUE);
2148 #else
2149         tempvar = ffebld_nonter_hook (expr);
2150         assert (tempvar);
2151 #endif
2152         tempvar = ffecom_1 (ADDR_EXPR,
2153                             build_pointer_type (TREE_TYPE (tempvar)),
2154                             tempvar);
2155
2156         args = build_tree_list (NULL_TREE, tempvar);
2157
2158         if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)       /* Sfunc args by value. */
2159           TREE_CHAIN (args) = ffecom_list_expr (ffebld_right (expr));
2160         else
2161           {
2162             TREE_CHAIN (args) = build_tree_list (NULL_TREE, *length);
2163             if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
2164               {
2165                 TREE_CHAIN (TREE_CHAIN (args))
2166                   = ffecom_arglist_expr_ (ffecom_gfrt_args_ (ix),
2167                                           ffebld_right (expr));
2168               }
2169             else
2170               {
2171                 TREE_CHAIN (TREE_CHAIN (args))
2172                   = ffecom_list_ptr_to_expr (ffebld_right (expr));
2173               }
2174           }
2175
2176         item = ffecom_3s (CALL_EXPR,
2177                           TREE_TYPE (TREE_TYPE (TREE_TYPE (item))),
2178                           item, args, NULL_TREE);
2179         item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item,
2180                          tempvar);
2181       }
2182       break;
2183
2184     case FFEBLD_opCONVERT:
2185
2186       ffecom_char_args_ (&item, length, ffebld_left (expr));
2187
2188       if (item == error_mark_node || *length == error_mark_node)
2189         {
2190           item = *length = error_mark_node;
2191           break;
2192         }
2193
2194       if ((ffebld_size_known (ffebld_left (expr))
2195            == FFETARGET_charactersizeNONE)
2196           || (ffebld_size_known (ffebld_left (expr)) < (ffebld_size (expr))))
2197         {                       /* Possible blank-padding needed, copy into
2198                                    temporary. */
2199           tree tempvar;
2200           tree args;
2201           tree newlen;
2202
2203 #ifdef HOHO
2204           tempvar = ffecom_make_tempvar (char_type_node,
2205                                          ffebld_size (expr), -1);
2206 #else
2207           tempvar = ffebld_nonter_hook (expr);
2208           assert (tempvar);
2209 #endif
2210           tempvar = ffecom_1 (ADDR_EXPR,
2211                               build_pointer_type (TREE_TYPE (tempvar)),
2212                               tempvar);
2213
2214           newlen = build_int_2 (ffebld_size (expr), 0);
2215           TREE_TYPE (newlen) = ffecom_f2c_ftnlen_type_node;
2216
2217           args = build_tree_list (NULL_TREE, tempvar);
2218           TREE_CHAIN (args) = build_tree_list (NULL_TREE, item);
2219           TREE_CHAIN (TREE_CHAIN (args)) = build_tree_list (NULL_TREE, newlen);
2220           TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (args)))
2221             = build_tree_list (NULL_TREE, *length);
2222
2223           item = ffecom_call_gfrt (FFECOM_gfrtCOPY, args, NULL_TREE);
2224           TREE_SIDE_EFFECTS (item) = 1;
2225           item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), fold (item),
2226                            tempvar);
2227           *length = newlen;
2228         }
2229       else
2230         {                       /* Just truncate the length. */
2231           *length = build_int_2 (ffebld_size (expr), 0);
2232           TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2233         }
2234       break;
2235
2236     default:
2237       assert ("bad op for single char arg expr" == NULL);
2238       item = NULL_TREE;
2239       break;
2240     }
2241
2242   *xitem = item;
2243 }
2244
2245 /* Check the size of the type to be sure it doesn't overflow the
2246    "portable" capacities of the compiler back end.  `dummy' types
2247    can generally overflow the normal sizes as long as the computations
2248    themselves don't overflow.  A particular target of the back end
2249    must still enforce its size requirements, though, and the back
2250    end takes care of this in stor-layout.c.  */
2251
2252 static tree
2253 ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy)
2254 {
2255   if (TREE_CODE (type) == ERROR_MARK)
2256     return type;
2257
2258   if (TYPE_SIZE (type) == NULL_TREE)
2259     return type;
2260
2261   if (TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST)
2262     return type;
2263
2264   if ((tree_int_cst_sgn (TYPE_SIZE (type)) < 0)
2265       || (!dummy && TREE_OVERFLOW (TYPE_SIZE (type))))
2266     {
2267       ffebad_start (FFEBAD_ARRAY_LARGE);
2268       ffebad_string (ffesymbol_text (s));
2269       ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s));
2270       ffebad_finish ();
2271
2272       return error_mark_node;
2273     }
2274
2275   return type;
2276 }
2277
2278 /* Builds a length argument (PARM_DECL).  Also wraps type in an array type
2279    where the dimension info is (1:size) where <size> is ffesymbol_size(s) if
2280    known, length_arg if not known (FFETARGET_charactersizeNONE).  */
2281
2282 static tree
2283 ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s)
2284 {
2285   ffetargetCharacterSize sz = ffesymbol_size (s);
2286   tree highval;
2287   tree tlen;
2288   tree type = *xtype;
2289
2290   if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
2291     tlen = NULL_TREE;           /* A statement function, no length passed. */
2292   else
2293     {
2294       if (ffesymbol_where (s) == FFEINFO_whereDUMMY)
2295         tlen = ffecom_get_invented_identifier ("__g77_length_%s",
2296                                                ffesymbol_text (s));
2297       else
2298         tlen = ffecom_get_invented_identifier ("__g77_%s", "length");
2299       tlen = build_decl (PARM_DECL, tlen, ffecom_f2c_ftnlen_type_node);
2300       DECL_ARTIFICIAL (tlen) = 1;
2301     }
2302
2303   if (sz == FFETARGET_charactersizeNONE)
2304     {
2305       assert (tlen != NULL_TREE);
2306       highval = variable_size (tlen);
2307     }
2308   else
2309     {
2310       highval = build_int_2 (sz, 0);
2311       TREE_TYPE (highval) = ffecom_f2c_ftnlen_type_node;
2312     }
2313
2314   type = build_array_type (type,
2315                            build_range_type (ffecom_f2c_ftnlen_type_node,
2316                                              ffecom_f2c_ftnlen_one_node,
2317                                              highval));
2318
2319   *xtype = type;
2320   return tlen;
2321 }
2322
2323 /* ffecom_concat_list_gather_ -- Gather list of concatenated string exprs
2324
2325    ffecomConcatList_ catlist;
2326    ffebld expr;  // expr of CHARACTER basictype.
2327    ffetargetCharacterSize max;  // max chars to gather or _...NONE if no max
2328    catlist = ffecom_concat_list_gather_(catlist,expr,max);
2329
2330    Scans expr for character subexpressions, updates and returns catlist
2331    accordingly.  */
2332
2333 static ffecomConcatList_
2334 ffecom_concat_list_gather_ (ffecomConcatList_ catlist, ffebld expr,
2335                             ffetargetCharacterSize max)
2336 {
2337   ffetargetCharacterSize sz;
2338
2339  recurse:
2340
2341   if (expr == NULL)
2342     return catlist;
2343
2344   if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen >= max))
2345     return catlist;             /* Don't append any more items. */
2346
2347   switch (ffebld_op (expr))
2348     {
2349     case FFEBLD_opCONTER:
2350     case FFEBLD_opSYMTER:
2351     case FFEBLD_opARRAYREF:
2352     case FFEBLD_opFUNCREF:
2353     case FFEBLD_opSUBSTR:
2354     case FFEBLD_opCONVERT:      /* Callers should strip this off beforehand
2355                                    if they don't need to preserve it. */
2356       if (catlist.count == catlist.max)
2357         {                       /* Make a (larger) list. */
2358           ffebld *newx;
2359           int newmax;
2360
2361           newmax = (catlist.max == 0) ? 8 : catlist.max * 2;
2362           newx = malloc_new_ks (malloc_pool_image (), "catlist",
2363                                 newmax * sizeof (newx[0]));
2364           if (catlist.max != 0)
2365             {
2366               memcpy (newx, catlist.exprs, catlist.max * sizeof (newx[0]));
2367               malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2368                               catlist.max * sizeof (newx[0]));
2369             }
2370           catlist.max = newmax;
2371           catlist.exprs = newx;
2372         }
2373       if ((sz = ffebld_size_known (expr)) != FFETARGET_charactersizeNONE)
2374         catlist.minlen += sz;
2375       else
2376         ++catlist.minlen;       /* Not true for F90; can be 0 length. */
2377       if ((sz = ffebld_size_max (expr)) == FFETARGET_charactersizeNONE)
2378         catlist.maxlen = sz;
2379       else
2380         catlist.maxlen += sz;
2381       if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen > max))
2382         {                       /* This item overlaps (or is beyond) the end
2383                                    of the destination. */
2384           switch (ffebld_op (expr))
2385             {
2386             case FFEBLD_opCONTER:
2387             case FFEBLD_opSYMTER:
2388             case FFEBLD_opARRAYREF:
2389             case FFEBLD_opFUNCREF:
2390             case FFEBLD_opSUBSTR:
2391               /* ~~Do useful truncations here. */
2392               break;
2393
2394             default:
2395               assert ("op changed or inconsistent switches!" == NULL);
2396               break;
2397             }
2398         }
2399       catlist.exprs[catlist.count++] = expr;
2400       return catlist;
2401
2402     case FFEBLD_opPAREN:
2403       expr = ffebld_left (expr);
2404       goto recurse;             /* :::::::::::::::::::: */
2405
2406     case FFEBLD_opCONCATENATE:
2407       catlist = ffecom_concat_list_gather_ (catlist, ffebld_left (expr), max);
2408       expr = ffebld_right (expr);
2409       goto recurse;             /* :::::::::::::::::::: */
2410
2411 #if 0                           /* Breaks passing small actual arg to larger
2412                                    dummy arg of sfunc */
2413     case FFEBLD_opCONVERT:
2414       expr = ffebld_left (expr);
2415       {
2416         ffetargetCharacterSize cmax;
2417
2418         cmax = catlist.len + ffebld_size_known (expr);
2419
2420         if ((max == FFETARGET_charactersizeNONE) || (max > cmax))
2421           max = cmax;
2422       }
2423       goto recurse;             /* :::::::::::::::::::: */
2424 #endif
2425
2426     case FFEBLD_opANY:
2427       return catlist;
2428
2429     default:
2430       assert ("bad op in _gather_" == NULL);
2431       return catlist;
2432     }
2433 }
2434
2435 /* ffecom_concat_list_kill_ -- Kill list of concatenated string exprs
2436
2437    ffecomConcatList_ catlist;
2438    ffecom_concat_list_kill_(catlist);
2439
2440    Anything allocated within the list info is deallocated.  */
2441
2442 static void
2443 ffecom_concat_list_kill_ (ffecomConcatList_ catlist)
2444 {
2445   if (catlist.max != 0)
2446     malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2447                     catlist.max * sizeof (catlist.exprs[0]));
2448 }
2449
2450 /* Make list of concatenated string exprs.
2451
2452    Returns a flattened list of concatenated subexpressions given a
2453    tree of such expressions.  */
2454
2455 static ffecomConcatList_
2456 ffecom_concat_list_new_ (ffebld expr, ffetargetCharacterSize max)
2457 {
2458   ffecomConcatList_ catlist;
2459
2460   catlist.maxlen = catlist.minlen = catlist.max = catlist.count = 0;
2461   return ffecom_concat_list_gather_ (catlist, expr, max);
2462 }
2463
2464 /* Provide some kind of useful info on member of aggregate area,
2465    since current g77/gcc technology does not provide debug info
2466    on these members.  */
2467
2468 static void
2469 ffecom_debug_kludge_ (tree aggr, const char *aggr_type, ffesymbol member,
2470                       tree member_type UNUSED, ffetargetOffset offset)
2471 {
2472   tree value;
2473   tree decl;
2474   int len;
2475   char *buff;
2476   char space[120];
2477 #if 0
2478   tree type_id;
2479
2480   for (type_id = member_type;
2481        TREE_CODE (type_id) != IDENTIFIER_NODE;
2482        )
2483     {
2484       switch (TREE_CODE (type_id))
2485         {
2486         case INTEGER_TYPE:
2487         case REAL_TYPE:
2488           type_id = TYPE_NAME (type_id);
2489           break;
2490
2491         case ARRAY_TYPE:
2492         case COMPLEX_TYPE:
2493           type_id = TREE_TYPE (type_id);
2494           break;
2495
2496         default:
2497           assert ("no IDENTIFIER_NODE for type!" == NULL);
2498           type_id = error_mark_node;
2499           break;
2500         }
2501     }
2502 #endif
2503
2504   if (ffecom_transform_only_dummies_
2505       || !ffe_is_debug_kludge ())
2506     return;     /* Can't do this yet, maybe later. */
2507
2508   len = 60
2509     + strlen (aggr_type)
2510     + IDENTIFIER_LENGTH (DECL_NAME (aggr));
2511 #if 0
2512     + IDENTIFIER_LENGTH (type_id);
2513 #endif
2514
2515   if (((size_t) len) >= ARRAY_SIZE (space))
2516     buff = malloc_new_ks (malloc_pool_image (), "debug_kludge", len + 1);
2517   else
2518     buff = &space[0];
2519
2520   sprintf (&buff[0], "At (%s) `%s' plus %ld bytes",
2521            aggr_type,
2522            IDENTIFIER_POINTER (DECL_NAME (aggr)),
2523            (long int) offset);
2524
2525   value = build_string (len, buff);
2526   TREE_TYPE (value)
2527     = build_type_variant (build_array_type (char_type_node,
2528                                             build_range_type
2529                                             (integer_type_node,
2530                                              integer_one_node,
2531                                              build_int_2 (strlen (buff), 0))),
2532                           1, 0);
2533   decl = build_decl (VAR_DECL,
2534                      ffecom_get_identifier_ (ffesymbol_text (member)),
2535                      TREE_TYPE (value));
2536   TREE_CONSTANT (decl) = 1;
2537   TREE_STATIC (decl) = 1;
2538   DECL_INITIAL (decl) = error_mark_node;
2539   DECL_IN_SYSTEM_HEADER (decl) = 1;     /* Don't let -Wunused complain. */
2540   decl = start_decl (decl, FALSE);
2541   finish_decl (decl, value, FALSE);
2542
2543   if (buff != &space[0])
2544     malloc_kill_ks (malloc_pool_image (), buff, len + 1);
2545 }
2546
2547 /* ffecom_do_entry_ -- Do compilation of a particular entrypoint
2548
2549    ffesymbol fn;  // the SUBROUTINE, FUNCTION, or ENTRY symbol itself
2550    int i;  // entry# for this entrypoint (used by master fn)
2551    ffecom_do_entrypoint_(s,i);
2552
2553    Makes a public entry point that calls our private master fn (already
2554    compiled).  */
2555
2556 static void
2557 ffecom_do_entry_ (ffesymbol fn, int entrynum)
2558 {
2559   ffebld item;
2560   tree type;                    /* Type of function. */
2561   tree multi_retval;            /* Var holding return value (union). */
2562   tree result;                  /* Var holding result. */
2563   ffeinfoBasictype bt;
2564   ffeinfoKindtype kt;
2565   ffeglobal g;
2566   ffeglobalType gt;
2567   bool charfunc;                /* All entry points return same type
2568                                    CHARACTER. */
2569   bool cmplxfunc;               /* Use f2c way of returning COMPLEX. */
2570   bool multi;                   /* Master fn has multiple return types. */
2571   bool altreturning = FALSE;    /* This entry point has alternate returns. */
2572   int old_lineno = lineno;
2573   const char *old_input_filename = input_filename;
2574
2575   input_filename = ffesymbol_where_filename (fn);
2576   lineno = ffesymbol_where_filelinenum (fn);
2577
2578   ffecom_doing_entry_ = TRUE;   /* Don't bother with array dimensions. */
2579
2580   switch (ffecom_primary_entry_kind_)
2581     {
2582     case FFEINFO_kindFUNCTION:
2583
2584       /* Determine actual return type for function. */
2585
2586       gt = FFEGLOBAL_typeFUNC;
2587       bt = ffesymbol_basictype (fn);
2588       kt = ffesymbol_kindtype (fn);
2589       if (bt == FFEINFO_basictypeNONE)
2590         {
2591           ffeimplic_establish_symbol (fn);
2592           if (ffesymbol_funcresult (fn) != NULL)
2593             ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
2594           bt = ffesymbol_basictype (fn);
2595           kt = ffesymbol_kindtype (fn);
2596         }
2597
2598       if (bt == FFEINFO_basictypeCHARACTER)
2599         charfunc = TRUE, cmplxfunc = FALSE;
2600       else if ((bt == FFEINFO_basictypeCOMPLEX)
2601                && ffesymbol_is_f2c (fn))
2602         charfunc = FALSE, cmplxfunc = TRUE;
2603       else
2604         charfunc = cmplxfunc = FALSE;
2605
2606       if (charfunc)
2607         type = ffecom_tree_fun_type_void;
2608       else if (ffesymbol_is_f2c (fn))
2609         type = ffecom_tree_fun_type[bt][kt];
2610       else
2611         type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
2612
2613       if ((type == NULL_TREE)
2614           || (TREE_TYPE (type) == NULL_TREE))
2615         type = ffecom_tree_fun_type_void;       /* _sym_exec_transition. */
2616
2617       multi = (ffecom_master_bt_ == FFEINFO_basictypeNONE);
2618       break;
2619
2620     case FFEINFO_kindSUBROUTINE:
2621       gt = FFEGLOBAL_typeSUBR;
2622       bt = FFEINFO_basictypeNONE;
2623       kt = FFEINFO_kindtypeNONE;
2624       if (ffecom_is_altreturning_)
2625         {                       /* Am _I_ altreturning? */
2626           for (item = ffesymbol_dummyargs (fn);
2627                item != NULL;
2628                item = ffebld_trail (item))
2629             {
2630               if (ffebld_op (ffebld_head (item)) == FFEBLD_opSTAR)
2631                 {
2632                   altreturning = TRUE;
2633                   break;
2634                 }
2635             }
2636           if (altreturning)
2637             type = ffecom_tree_subr_type;
2638           else
2639             type = ffecom_tree_fun_type_void;
2640         }
2641       else
2642         type = ffecom_tree_fun_type_void;
2643       charfunc = FALSE;
2644       cmplxfunc = FALSE;
2645       multi = FALSE;
2646       break;
2647
2648     default:
2649       assert ("say what??" == NULL);
2650       /* Fall through. */
2651     case FFEINFO_kindANY:
2652       gt = FFEGLOBAL_typeANY;
2653       bt = FFEINFO_basictypeNONE;
2654       kt = FFEINFO_kindtypeNONE;
2655       type = error_mark_node;
2656       charfunc = FALSE;
2657       cmplxfunc = FALSE;
2658       multi = FALSE;
2659       break;
2660     }
2661
2662   /* build_decl uses the current lineno and input_filename to set the decl
2663      source info.  So, I've putzed with ffestd and ffeste code to update that
2664      source info to point to the appropriate statement just before calling
2665      ffecom_do_entrypoint (which calls this fn).  */
2666
2667   start_function (ffecom_get_external_identifier_ (fn),
2668                   type,
2669                   0,            /* nested/inline */
2670                   1);           /* TREE_PUBLIC */
2671
2672   if (((g = ffesymbol_global (fn)) != NULL)
2673       && ((ffeglobal_type (g) == gt)
2674           || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
2675     {
2676       ffeglobal_set_hook (g, current_function_decl);
2677     }
2678
2679   /* Reset args in master arg list so they get retransitioned. */
2680
2681   for (item = ffecom_master_arglist_;
2682        item != NULL;
2683        item = ffebld_trail (item))
2684     {
2685       ffebld arg;
2686       ffesymbol s;
2687
2688       arg = ffebld_head (item);
2689       if (ffebld_op (arg) != FFEBLD_opSYMTER)
2690         continue;               /* Alternate return or some such thing. */
2691       s = ffebld_symter (arg);
2692       ffesymbol_hook (s).decl_tree = NULL_TREE;
2693       ffesymbol_hook (s).length_tree = NULL_TREE;
2694     }
2695
2696   /* Build dummy arg list for this entry point. */
2697
2698   if (charfunc || cmplxfunc)
2699     {                           /* Prepend arg for where result goes. */
2700       tree type;
2701       tree length;
2702
2703       if (charfunc)
2704         type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
2705       else
2706         type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
2707
2708       result = ffecom_get_invented_identifier ("__g77_%s", "result");
2709
2710       /* Make length arg _and_ enhance type info for CHAR arg itself.  */
2711
2712       if (charfunc)
2713         length = ffecom_char_enhance_arg_ (&type, fn);
2714       else
2715         length = NULL_TREE;     /* Not ref'd if !charfunc. */
2716
2717       type = build_pointer_type (type);
2718       result = build_decl (PARM_DECL, result, type);
2719
2720       push_parm_decl (result);
2721       ffecom_func_result_ = result;
2722
2723       if (charfunc)
2724         {
2725           push_parm_decl (length);
2726           ffecom_func_length_ = length;
2727         }
2728     }
2729   else
2730     result = DECL_RESULT (current_function_decl);
2731
2732   ffecom_push_dummy_decls_ (ffesymbol_dummyargs (fn), FALSE);
2733
2734   store_parm_decls (0);
2735
2736   ffecom_start_compstmt ();
2737   /* Disallow temp vars at this level.  */
2738   current_binding_level->prep_state = 2;
2739
2740   /* Make local var to hold return type for multi-type master fn. */
2741
2742   if (multi)
2743     {
2744       multi_retval = ffecom_get_invented_identifier ("__g77_%s",
2745                                                      "multi_retval");
2746       multi_retval = build_decl (VAR_DECL, multi_retval,
2747                                  ffecom_multi_type_node_);
2748       multi_retval = start_decl (multi_retval, FALSE);
2749       finish_decl (multi_retval, NULL_TREE, FALSE);
2750     }
2751   else
2752     multi_retval = NULL_TREE;   /* Not actually ref'd if !multi. */
2753
2754   /* Here we emit the actual code for the entry point. */
2755
2756   {
2757     ffebld list;
2758     ffebld arg;
2759     ffesymbol s;
2760     tree arglist = NULL_TREE;
2761     tree *plist = &arglist;
2762     tree prepend;
2763     tree call;
2764     tree actarg;
2765     tree master_fn;
2766
2767     /* Prepare actual arg list based on master arg list. */
2768
2769     for (list = ffecom_master_arglist_;
2770          list != NULL;
2771          list = ffebld_trail (list))
2772       {
2773         arg = ffebld_head (list);
2774         if (ffebld_op (arg) != FFEBLD_opSYMTER)
2775           continue;
2776         s = ffebld_symter (arg);
2777         if (ffesymbol_hook (s).decl_tree == NULL_TREE
2778             || ffesymbol_hook (s).decl_tree == error_mark_node)
2779           actarg = null_pointer_node;   /* We don't have this arg. */
2780         else
2781           actarg = ffesymbol_hook (s).decl_tree;
2782         *plist = build_tree_list (NULL_TREE, actarg);
2783         plist = &TREE_CHAIN (*plist);
2784       }
2785
2786     /* This code appends the length arguments for character
2787        variables/arrays.  */
2788
2789     for (list = ffecom_master_arglist_;
2790          list != NULL;
2791          list = ffebld_trail (list))
2792       {
2793         arg = ffebld_head (list);
2794         if (ffebld_op (arg) != FFEBLD_opSYMTER)
2795           continue;
2796         s = ffebld_symter (arg);
2797         if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
2798           continue;             /* Only looking for CHARACTER arguments. */
2799         if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
2800           continue;             /* Only looking for variables and arrays. */
2801         if (ffesymbol_hook (s).length_tree == NULL_TREE
2802             || ffesymbol_hook (s).length_tree == error_mark_node)
2803           actarg = ffecom_f2c_ftnlen_zero_node; /* We don't have this arg. */
2804         else
2805           actarg = ffesymbol_hook (s).length_tree;
2806         *plist = build_tree_list (NULL_TREE, actarg);
2807         plist = &TREE_CHAIN (*plist);
2808       }
2809
2810     /* Prepend character-value return info to actual arg list. */
2811
2812     if (charfunc)
2813       {
2814         prepend = build_tree_list (NULL_TREE, ffecom_func_result_);
2815         TREE_CHAIN (prepend)
2816           = build_tree_list (NULL_TREE, ffecom_func_length_);
2817         TREE_CHAIN (TREE_CHAIN (prepend)) = arglist;
2818         arglist = prepend;
2819       }
2820
2821     /* Prepend multi-type return value to actual arg list. */
2822
2823     if (multi)
2824       {
2825         prepend
2826           = build_tree_list (NULL_TREE,
2827                              ffecom_1 (ADDR_EXPR,
2828                               build_pointer_type (TREE_TYPE (multi_retval)),
2829                                        multi_retval));
2830         TREE_CHAIN (prepend) = arglist;
2831         arglist = prepend;
2832       }
2833
2834     /* Prepend my entry-point number to the actual arg list. */
2835
2836     prepend = build_tree_list (NULL_TREE, build_int_2 (entrynum, 0));
2837     TREE_CHAIN (prepend) = arglist;
2838     arglist = prepend;
2839
2840     /* Build the call to the master function. */
2841
2842     master_fn = ffecom_1_fn (ffecom_previous_function_decl_);
2843     call = ffecom_3s (CALL_EXPR,
2844                       TREE_TYPE (TREE_TYPE (TREE_TYPE (master_fn))),
2845                       master_fn, arglist, NULL_TREE);
2846
2847     /* Decide whether the master function is a function or subroutine, and
2848        handle the return value for my entry point. */
2849
2850     if (charfunc || ((ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
2851                      && !altreturning))
2852       {
2853         expand_expr_stmt (call);
2854         expand_null_return ();
2855       }
2856     else if (multi && cmplxfunc)
2857       {
2858         expand_expr_stmt (call);
2859         result
2860           = ffecom_1 (INDIRECT_REF,
2861                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
2862                       result);
2863         result = ffecom_modify (NULL_TREE, result,
2864                                 ffecom_2 (COMPONENT_REF, TREE_TYPE (result),
2865                                           multi_retval,
2866                                           ffecom_multi_fields_[bt][kt]));
2867         expand_expr_stmt (result);
2868         expand_null_return ();
2869       }
2870     else if (multi)
2871       {
2872         expand_expr_stmt (call);
2873         result
2874           = ffecom_modify (NULL_TREE, result,
2875                            convert (TREE_TYPE (result),
2876                                     ffecom_2 (COMPONENT_REF,
2877                                               ffecom_tree_type[bt][kt],
2878                                               multi_retval,
2879                                               ffecom_multi_fields_[bt][kt])));
2880         expand_return (result);
2881       }
2882     else if (cmplxfunc)
2883       {
2884         result
2885           = ffecom_1 (INDIRECT_REF,
2886                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
2887                       result);
2888         result = ffecom_modify (NULL_TREE, result, call);
2889         expand_expr_stmt (result);
2890         expand_null_return ();
2891       }
2892     else
2893       {
2894         result = ffecom_modify (NULL_TREE,
2895                                 result,
2896                                 convert (TREE_TYPE (result),
2897                                          call));
2898         expand_return (result);
2899       }
2900   }
2901
2902   ffecom_end_compstmt ();
2903
2904   finish_function (0);
2905
2906   lineno = old_lineno;
2907   input_filename = old_input_filename;
2908
2909   ffecom_doing_entry_ = FALSE;
2910 }
2911
2912 /* Transform expr into gcc tree with possible destination
2913
2914    Recursive descent on expr while making corresponding tree nodes and
2915    attaching type info and such.  If destination supplied and compatible
2916    with temporary that would be made in certain cases, temporary isn't
2917    made, destination used instead, and dest_used flag set TRUE.  */
2918
2919 static tree
2920 ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
2921               bool *dest_used, bool assignp, bool widenp)
2922 {
2923   tree item;
2924   tree list;
2925   tree args;
2926   ffeinfoBasictype bt;
2927   ffeinfoKindtype kt;
2928   tree t;
2929   tree dt;                      /* decl_tree for an ffesymbol. */
2930   tree tree_type, tree_type_x;
2931   tree left, right;
2932   ffesymbol s;
2933   enum tree_code code;
2934
2935   assert (expr != NULL);
2936
2937   if (dest_used != NULL)
2938     *dest_used = FALSE;
2939
2940   bt = ffeinfo_basictype (ffebld_info (expr));
2941   kt = ffeinfo_kindtype (ffebld_info (expr));
2942   tree_type = ffecom_tree_type[bt][kt];
2943
2944   /* Widen integral arithmetic as desired while preserving signedness.  */
2945   tree_type_x = NULL_TREE;
2946   if (widenp && tree_type
2947       && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
2948       && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
2949     tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
2950
2951   switch (ffebld_op (expr))
2952     {
2953     case FFEBLD_opACCTER:
2954       {
2955         ffebitCount i;
2956         ffebit bits = ffebld_accter_bits (expr);
2957         ffetargetOffset source_offset = 0;
2958         ffetargetOffset dest_offset = ffebld_accter_pad (expr);
2959         tree purpose;
2960
2961         assert (dest_offset == 0
2962                 || (bt == FFEINFO_basictypeCHARACTER
2963                     && kt == FFEINFO_kindtypeCHARACTER1));
2964
2965         list = item = NULL;
2966         for (;;)
2967           {
2968             ffebldConstantUnion cu;
2969             ffebitCount length;
2970             bool value;
2971             ffebldConstantArray ca = ffebld_accter (expr);
2972
2973             ffebit_test (bits, source_offset, &value, &length);
2974             if (length == 0)
2975               break;
2976
2977             if (value)
2978               {
2979                 for (i = 0; i < length; ++i)
2980                   {
2981                     cu = ffebld_constantarray_get (ca, bt, kt,
2982                                                    source_offset + i);
2983
2984                     t = ffecom_constantunion (&cu, bt, kt, tree_type);
2985
2986                     if (i == 0
2987                         && dest_offset != 0)
2988                       purpose = build_int_2 (dest_offset, 0);
2989                     else
2990                       purpose = NULL_TREE;
2991
2992                     if (list == NULL_TREE)
2993                       list = item = build_tree_list (purpose, t);
2994                     else
2995                       {
2996                         TREE_CHAIN (item) = build_tree_list (purpose, t);
2997                         item = TREE_CHAIN (item);
2998                       }
2999                   }
3000               }
3001             source_offset += length;
3002             dest_offset += length;
3003           }
3004       }
3005
3006       item = build_int_2 ((ffebld_accter_size (expr)
3007                            + ffebld_accter_pad (expr)) - 1, 0);
3008       ffebit_kill (ffebld_accter_bits (expr));
3009       TREE_TYPE (item) = ffecom_integer_type_node;
3010       item
3011         = build_array_type
3012           (tree_type,
3013            build_range_type (ffecom_integer_type_node,
3014                              ffecom_integer_zero_node,
3015                              item));
3016       list = build (CONSTRUCTOR, item, NULL_TREE, list);
3017       TREE_CONSTANT (list) = 1;
3018       TREE_STATIC (list) = 1;
3019       return list;
3020
3021     case FFEBLD_opARRTER:
3022       {
3023         ffetargetOffset i;
3024
3025         list = NULL_TREE;
3026         if (ffebld_arrter_pad (expr) == 0)
3027           item = NULL_TREE;
3028         else
3029           {
3030             assert (bt == FFEINFO_basictypeCHARACTER
3031                     && kt == FFEINFO_kindtypeCHARACTER1);
3032
3033             /* Becomes PURPOSE first time through loop.  */
3034             item = build_int_2 (ffebld_arrter_pad (expr), 0);
3035           }
3036
3037         for (i = 0; i < ffebld_arrter_size (expr); ++i)
3038           {
3039             ffebldConstantUnion cu
3040             = ffebld_constantarray_get (ffebld_arrter (expr), bt, kt, i);
3041
3042             t = ffecom_constantunion (&cu, bt, kt, tree_type);
3043
3044             if (list == NULL_TREE)
3045               /* Assume item is PURPOSE first time through loop.  */
3046               list = item = build_tree_list (item, t);
3047             else
3048               {
3049                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
3050                 item = TREE_CHAIN (item);
3051               }
3052           }
3053       }
3054
3055       item = build_int_2 ((ffebld_arrter_size (expr)
3056                           + ffebld_arrter_pad (expr)) - 1, 0);
3057       TREE_TYPE (item) = ffecom_integer_type_node;
3058       item
3059         = build_array_type
3060           (tree_type,
3061            build_range_type (ffecom_integer_type_node,
3062                              ffecom_integer_zero_node,
3063                              item));
3064       list = build (CONSTRUCTOR, item, NULL_TREE, list);
3065       TREE_CONSTANT (list) = 1;
3066       TREE_STATIC (list) = 1;
3067       return list;
3068
3069     case FFEBLD_opCONTER:
3070       assert (ffebld_conter_pad (expr) == 0);
3071       item
3072         = ffecom_constantunion (&ffebld_constant_union (ffebld_conter (expr)),
3073                                 bt, kt, tree_type);
3074       return item;
3075
3076     case FFEBLD_opSYMTER:
3077       if ((ffebld_symter_generic (expr) != FFEINTRIN_genNONE)
3078           || (ffebld_symter_specific (expr) != FFEINTRIN_specNONE))
3079         return ffecom_ptr_to_expr (expr);       /* Same as %REF(intrinsic). */
3080       s = ffebld_symter (expr);
3081       t = ffesymbol_hook (s).decl_tree;
3082
3083       if (assignp)
3084         {                       /* ASSIGN'ed-label expr. */
3085           if (ffe_is_ugly_assign ())
3086             {
3087               /* User explicitly wants ASSIGN'ed variables to be at the same
3088                  memory address as the variables when used in non-ASSIGN
3089                  contexts.  That can make old, arcane, non-standard code
3090                  work, but don't try to do it when a pointer wouldn't fit
3091                  in the normal variable (take other approach, and warn,
3092                  instead).  */
3093
3094               if (t == NULL_TREE)
3095                 {
3096                   s = ffecom_sym_transform_ (s);
3097                   t = ffesymbol_hook (s).decl_tree;
3098                   assert (t != NULL_TREE);
3099                 }
3100
3101               if (t == error_mark_node)
3102                 return t;
3103
3104               if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t)))
3105                   >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
3106                 {
3107                   if (ffesymbol_hook (s).addr)
3108                     t = ffecom_1 (INDIRECT_REF,
3109                                   TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3110                   return t;
3111                 }
3112
3113               if (ffesymbol_hook (s).assign_tree == NULL_TREE)
3114                 {
3115                   ffebad_start_msg ("ASSIGN'ed label cannot fit into `%A' at %0 -- using wider sibling",
3116                                     FFEBAD_severityWARNING);
3117                   ffebad_string (ffesymbol_text (s));
3118                   ffebad_here (0, ffesymbol_where_line (s),
3119                                ffesymbol_where_column (s));
3120                   ffebad_finish ();
3121                 }
3122             }
3123
3124           /* Don't use the normal variable's tree for ASSIGN, though mark
3125              it as in the system header (housekeeping).  Use an explicit,
3126              specially created sibling that is known to be wide enough
3127              to hold pointers to labels.  */
3128
3129           if (t != NULL_TREE
3130               && TREE_CODE (t) == VAR_DECL)
3131             DECL_IN_SYSTEM_HEADER (t) = 1;      /* Don't let -Wunused complain. */
3132
3133           t = ffesymbol_hook (s).assign_tree;
3134           if (t == NULL_TREE)
3135             {
3136               s = ffecom_sym_transform_assign_ (s);
3137               t = ffesymbol_hook (s).assign_tree;
3138               assert (t != NULL_TREE);
3139             }
3140         }
3141       else
3142         {
3143           if (t == NULL_TREE)
3144             {
3145               s = ffecom_sym_transform_ (s);
3146               t = ffesymbol_hook (s).decl_tree;
3147               assert (t != NULL_TREE);
3148             }
3149           if (ffesymbol_hook (s).addr)
3150             t = ffecom_1 (INDIRECT_REF,
3151                           TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3152         }
3153       return t;
3154
3155     case FFEBLD_opARRAYREF:
3156       return ffecom_arrayref_ (NULL_TREE, expr, 0);
3157
3158     case FFEBLD_opUPLUS:
3159       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3160       return ffecom_1 (NOP_EXPR, tree_type, left);
3161
3162     case FFEBLD_opPAREN:
3163       /* ~~~Make sure Fortran rules respected here */
3164       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3165       return ffecom_1 (NOP_EXPR, tree_type, left);
3166
3167     case FFEBLD_opUMINUS:
3168       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3169       if (tree_type_x)
3170         {
3171           tree_type = tree_type_x;
3172           left = convert (tree_type, left);
3173         }
3174       return ffecom_1 (NEGATE_EXPR, tree_type, left);
3175
3176     case FFEBLD_opADD:
3177       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3178       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3179       if (tree_type_x)
3180         {
3181           tree_type = tree_type_x;
3182           left = convert (tree_type, left);
3183           right = convert (tree_type, right);
3184         }
3185       return ffecom_2 (PLUS_EXPR, tree_type, left, right);
3186
3187     case FFEBLD_opSUBTRACT:
3188       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3189       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3190       if (tree_type_x)
3191         {
3192           tree_type = tree_type_x;
3193           left = convert (tree_type, left);
3194           right = convert (tree_type, right);
3195         }
3196       return ffecom_2 (MINUS_EXPR, tree_type, left, right);
3197
3198     case FFEBLD_opMULTIPLY:
3199       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3200       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3201       if (tree_type_x)
3202         {
3203           tree_type = tree_type_x;
3204           left = convert (tree_type, left);
3205           right = convert (tree_type, right);
3206         }
3207       return ffecom_2 (MULT_EXPR, tree_type, left, right);
3208
3209     case FFEBLD_opDIVIDE:
3210       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3211       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3212       if (tree_type_x)
3213         {
3214           tree_type = tree_type_x;
3215           left = convert (tree_type, left);
3216           right = convert (tree_type, right);
3217         }
3218       return ffecom_tree_divide_ (tree_type, left, right,
3219                                   dest_tree, dest, dest_used,
3220                                   ffebld_nonter_hook (expr));
3221
3222     case FFEBLD_opPOWER:
3223       {
3224         ffebld left = ffebld_left (expr);
3225         ffebld right = ffebld_right (expr);
3226         ffecomGfrt code;
3227         ffeinfoKindtype rtkt;
3228         ffeinfoKindtype ltkt;
3229         bool ref = TRUE;
3230
3231         switch (ffeinfo_basictype (ffebld_info (right)))
3232           {
3233
3234           case FFEINFO_basictypeINTEGER:
3235             if (1 || optimize)
3236               {
3237                 item = ffecom_expr_power_integer_ (expr);
3238                 if (item != NULL_TREE)
3239                   return item;
3240               }
3241
3242             rtkt = FFEINFO_kindtypeINTEGER1;
3243             switch (ffeinfo_basictype (ffebld_info (left)))
3244               {
3245               case FFEINFO_basictypeINTEGER:
3246                 if ((ffeinfo_kindtype (ffebld_info (left))
3247                     == FFEINFO_kindtypeINTEGER4)
3248                     || (ffeinfo_kindtype (ffebld_info (right))
3249                         == FFEINFO_kindtypeINTEGER4))
3250                   {
3251                     code = FFECOM_gfrtPOW_QQ;
3252                     ltkt = FFEINFO_kindtypeINTEGER4;
3253                     rtkt = FFEINFO_kindtypeINTEGER4;
3254                   }
3255                 else
3256                   {
3257                     code = FFECOM_gfrtPOW_II;
3258                     ltkt = FFEINFO_kindtypeINTEGER1;
3259                   }
3260                 break;
3261
3262               case FFEINFO_basictypeREAL:
3263                 if (ffeinfo_kindtype (ffebld_info (left))
3264                     == FFEINFO_kindtypeREAL1)
3265                   {
3266                     code = FFECOM_gfrtPOW_RI;
3267                     ltkt = FFEINFO_kindtypeREAL1;
3268                   }
3269                 else
3270                   {
3271                     code = FFECOM_gfrtPOW_DI;
3272                     ltkt = FFEINFO_kindtypeREAL2;
3273                   }
3274                 break;
3275
3276               case FFEINFO_basictypeCOMPLEX:
3277                 if (ffeinfo_kindtype (ffebld_info (left))
3278                     == FFEINFO_kindtypeREAL1)
3279                   {
3280                     code = FFECOM_gfrtPOW_CI;   /* Overlapping result okay. */
3281                     ltkt = FFEINFO_kindtypeREAL1;
3282                   }
3283                 else
3284                   {
3285                     code = FFECOM_gfrtPOW_ZI;   /* Overlapping result okay. */
3286                     ltkt = FFEINFO_kindtypeREAL2;
3287                   }
3288                 break;
3289
3290               default:
3291                 assert ("bad pow_*i" == NULL);
3292                 code = FFECOM_gfrtPOW_CI;       /* Overlapping result okay. */
3293                 ltkt = FFEINFO_kindtypeREAL1;
3294                 break;
3295               }
3296             if (ffeinfo_kindtype (ffebld_info (left)) != ltkt)
3297               left = ffeexpr_convert (left, NULL, NULL,
3298                                       ffeinfo_basictype (ffebld_info (left)),
3299                                       ltkt, 0,
3300                                       FFETARGET_charactersizeNONE,
3301                                       FFEEXPR_contextLET);
3302             if (ffeinfo_kindtype (ffebld_info (right)) != rtkt)
3303               right = ffeexpr_convert (right, NULL, NULL,
3304                                        FFEINFO_basictypeINTEGER,
3305                                        rtkt, 0,
3306                                        FFETARGET_charactersizeNONE,
3307                                        FFEEXPR_contextLET);
3308             break;
3309
3310           case FFEINFO_basictypeREAL:
3311             if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3312               left = ffeexpr_convert (left, NULL, NULL, FFEINFO_basictypeREAL,
3313                                       FFEINFO_kindtypeREALDOUBLE, 0,
3314                                       FFETARGET_charactersizeNONE,
3315                                       FFEEXPR_contextLET);
3316             if (ffeinfo_kindtype (ffebld_info (right))
3317                 == FFEINFO_kindtypeREAL1)
3318               right = ffeexpr_convert (right, NULL, NULL,
3319                                        FFEINFO_basictypeREAL,
3320                                        FFEINFO_kindtypeREALDOUBLE, 0,
3321                                        FFETARGET_charactersizeNONE,
3322                                        FFEEXPR_contextLET);
3323             /* We used to call FFECOM_gfrtPOW_DD here,
3324                which passes arguments by reference.  */
3325             code = FFECOM_gfrtL_POW;
3326             /* Pass arguments by value. */
3327             ref  = FALSE;
3328             break;
3329
3330           case FFEINFO_basictypeCOMPLEX:
3331             if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3332               left = ffeexpr_convert (left, NULL, NULL,
3333                                       FFEINFO_basictypeCOMPLEX,
3334                                       FFEINFO_kindtypeREALDOUBLE, 0,
3335                                       FFETARGET_charactersizeNONE,
3336                                       FFEEXPR_contextLET);
3337             if (ffeinfo_kindtype (ffebld_info (right))
3338                 == FFEINFO_kindtypeREAL1)
3339               right = ffeexpr_convert (right, NULL, NULL,
3340                                        FFEINFO_basictypeCOMPLEX,
3341                                        FFEINFO_kindtypeREALDOUBLE, 0,
3342                                        FFETARGET_charactersizeNONE,
3343                                        FFEEXPR_contextLET);
3344             code = FFECOM_gfrtPOW_ZZ;   /* Overlapping result okay. */
3345             ref = TRUE;                 /* Pass arguments by reference. */
3346             break;
3347
3348           default:
3349             assert ("bad pow_x*" == NULL);
3350             code = FFECOM_gfrtPOW_II;
3351             break;
3352           }
3353         return ffecom_call_binop_ (ffecom_gfrt_tree_ (code),
3354                                    ffecom_gfrt_kindtype (code),
3355                                    (ffe_is_f2c_library ()
3356                                     && ffecom_gfrt_complex_[code]),
3357                                    tree_type, left, right,
3358                                    dest_tree, dest, dest_used,
3359                                    NULL_TREE, FALSE, ref,
3360                                    ffebld_nonter_hook (expr));
3361       }
3362
3363     case FFEBLD_opNOT:
3364       switch (bt)
3365         {
3366         case FFEINFO_basictypeLOGICAL:
3367           item = ffecom_truth_value_invert (ffecom_expr (ffebld_left (expr)));
3368           return convert (tree_type, item);
3369
3370         case FFEINFO_basictypeINTEGER:
3371           return ffecom_1 (BIT_NOT_EXPR, tree_type,
3372                            ffecom_expr (ffebld_left (expr)));
3373
3374         default:
3375           assert ("NOT bad basictype" == NULL);
3376           /* Fall through. */
3377         case FFEINFO_basictypeANY:
3378           return error_mark_node;
3379         }
3380       break;
3381
3382     case FFEBLD_opFUNCREF:
3383       assert (ffeinfo_basictype (ffebld_info (expr))
3384               != FFEINFO_basictypeCHARACTER);
3385       /* Fall through.   */
3386     case FFEBLD_opSUBRREF:
3387       if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
3388           == FFEINFO_whereINTRINSIC)
3389         {                       /* Invocation of an intrinsic. */
3390           item = ffecom_expr_intrinsic_ (expr, dest_tree, dest,
3391                                          dest_used);
3392           return item;
3393         }
3394       s = ffebld_symter (ffebld_left (expr));
3395       dt = ffesymbol_hook (s).decl_tree;
3396       if (dt == NULL_TREE)
3397         {
3398           s = ffecom_sym_transform_ (s);
3399           dt = ffesymbol_hook (s).decl_tree;
3400         }
3401       if (dt == error_mark_node)
3402         return dt;
3403
3404       if (ffesymbol_hook (s).addr)
3405         item = dt;
3406       else
3407         item = ffecom_1_fn (dt);
3408
3409       if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
3410         args = ffecom_list_expr (ffebld_right (expr));
3411       else
3412         args = ffecom_list_ptr_to_expr (ffebld_right (expr));
3413
3414       if (args == error_mark_node)
3415         return error_mark_node;
3416
3417       item = ffecom_call_ (item, kt,
3418                            ffesymbol_is_f2c (s)
3419                            && (bt == FFEINFO_basictypeCOMPLEX)
3420                            && (ffesymbol_where (s)
3421                                != FFEINFO_whereCONSTANT),
3422                            tree_type,
3423                            args,
3424                            dest_tree, dest, dest_used,
3425                            error_mark_node, FALSE,
3426                            ffebld_nonter_hook (expr));
3427       TREE_SIDE_EFFECTS (item) = 1;
3428       return item;
3429
3430     case FFEBLD_opAND:
3431       switch (bt)
3432         {
3433         case FFEINFO_basictypeLOGICAL:
3434           item
3435             = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3436                        ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3437                      ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3438           return convert (tree_type, item);
3439
3440         case FFEINFO_basictypeINTEGER:
3441           return ffecom_2 (BIT_AND_EXPR, tree_type,
3442                            ffecom_expr (ffebld_left (expr)),
3443                            ffecom_expr (ffebld_right (expr)));
3444
3445         default:
3446           assert ("AND bad basictype" == NULL);
3447           /* Fall through. */
3448         case FFEINFO_basictypeANY:
3449           return error_mark_node;
3450         }
3451       break;
3452
3453     case FFEBLD_opOR:
3454       switch (bt)
3455         {
3456         case FFEINFO_basictypeLOGICAL:
3457           item
3458             = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
3459                        ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3460                      ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3461           return convert (tree_type, item);
3462
3463         case FFEINFO_basictypeINTEGER:
3464           return ffecom_2 (BIT_IOR_EXPR, tree_type,
3465                            ffecom_expr (ffebld_left (expr)),
3466                            ffecom_expr (ffebld_right (expr)));
3467
3468         default:
3469           assert ("OR bad basictype" == NULL);
3470           /* Fall through. */
3471         case FFEINFO_basictypeANY:
3472           return error_mark_node;
3473         }
3474       break;
3475
3476     case FFEBLD_opXOR:
3477     case FFEBLD_opNEQV:
3478       switch (bt)
3479         {
3480         case FFEINFO_basictypeLOGICAL:
3481           item
3482             = ffecom_2 (NE_EXPR, integer_type_node,
3483                         ffecom_expr (ffebld_left (expr)),
3484                         ffecom_expr (ffebld_right (expr)));
3485           return convert (tree_type, ffecom_truth_value (item));
3486
3487         case FFEINFO_basictypeINTEGER:
3488           return ffecom_2 (BIT_XOR_EXPR, tree_type,
3489                            ffecom_expr (ffebld_left (expr)),
3490                            ffecom_expr (ffebld_right (expr)));
3491
3492         default:
3493           assert ("XOR/NEQV bad basictype" == NULL);
3494           /* Fall through. */
3495         case FFEINFO_basictypeANY:
3496           return error_mark_node;
3497         }
3498       break;
3499
3500     case FFEBLD_opEQV:
3501       switch (bt)
3502         {
3503         case FFEINFO_basictypeLOGICAL:
3504           item
3505             = ffecom_2 (EQ_EXPR, integer_type_node,
3506                         ffecom_expr (ffebld_left (expr)),
3507                         ffecom_expr (ffebld_right (expr)));
3508           return convert (tree_type, ffecom_truth_value (item));
3509
3510         case FFEINFO_basictypeINTEGER:
3511           return
3512             ffecom_1 (BIT_NOT_EXPR, tree_type,
3513                       ffecom_2 (BIT_XOR_EXPR, tree_type,
3514                                 ffecom_expr (ffebld_left (expr)),
3515                                 ffecom_expr (ffebld_right (expr))));
3516
3517         default:
3518           assert ("EQV bad basictype" == NULL);
3519           /* Fall through. */
3520         case FFEINFO_basictypeANY:
3521           return error_mark_node;
3522         }
3523       break;
3524
3525     case FFEBLD_opCONVERT:
3526       if (ffebld_op (ffebld_left (expr)) == FFEBLD_opANY)
3527         return error_mark_node;
3528
3529       switch (bt)
3530         {
3531         case FFEINFO_basictypeLOGICAL:
3532         case FFEINFO_basictypeINTEGER:
3533         case FFEINFO_basictypeREAL:
3534           return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3535
3536         case FFEINFO_basictypeCOMPLEX:
3537           switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3538             {
3539             case FFEINFO_basictypeINTEGER:
3540             case FFEINFO_basictypeLOGICAL:
3541             case FFEINFO_basictypeREAL:
3542               item = ffecom_expr (ffebld_left (expr));
3543               if (item == error_mark_node)
3544                 return error_mark_node;
3545               /* convert() takes care of converting to the subtype first,
3546                  at least in gcc-2.7.2. */
3547               item = convert (tree_type, item);
3548               return item;
3549
3550             case FFEINFO_basictypeCOMPLEX:
3551               return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3552
3553             default:
3554               assert ("CONVERT COMPLEX bad basictype" == NULL);
3555               /* Fall through. */
3556             case FFEINFO_basictypeANY:
3557               return error_mark_node;
3558             }
3559           break;
3560
3561         default:
3562           assert ("CONVERT bad basictype" == NULL);
3563           /* Fall through. */
3564         case FFEINFO_basictypeANY:
3565           return error_mark_node;
3566         }
3567       break;
3568
3569     case FFEBLD_opLT:
3570       code = LT_EXPR;
3571       goto relational;          /* :::::::::::::::::::: */
3572
3573     case FFEBLD_opLE:
3574       code = LE_EXPR;
3575       goto relational;          /* :::::::::::::::::::: */
3576
3577     case FFEBLD_opEQ:
3578       code = EQ_EXPR;
3579       goto relational;          /* :::::::::::::::::::: */
3580
3581     case FFEBLD_opNE:
3582       code = NE_EXPR;
3583       goto relational;          /* :::::::::::::::::::: */
3584
3585     case FFEBLD_opGT:
3586       code = GT_EXPR;
3587       goto relational;          /* :::::::::::::::::::: */
3588
3589     case FFEBLD_opGE:
3590       code = GE_EXPR;
3591
3592     relational:         /* :::::::::::::::::::: */
3593       switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3594         {
3595         case FFEINFO_basictypeLOGICAL:
3596         case FFEINFO_basictypeINTEGER:
3597         case FFEINFO_basictypeREAL:
3598           item = ffecom_2 (code, integer_type_node,
3599                            ffecom_expr (ffebld_left (expr)),
3600                            ffecom_expr (ffebld_right (expr)));
3601           return convert (tree_type, item);
3602
3603         case FFEINFO_basictypeCOMPLEX:
3604           assert (code == EQ_EXPR || code == NE_EXPR);
3605           {
3606             tree real_type;
3607             tree arg1 = ffecom_expr (ffebld_left (expr));
3608             tree arg2 = ffecom_expr (ffebld_right (expr));
3609
3610             if (arg1 == error_mark_node || arg2 == error_mark_node)
3611               return error_mark_node;
3612
3613             arg1 = ffecom_save_tree (arg1);
3614             arg2 = ffecom_save_tree (arg2);
3615
3616             if (TREE_CODE (TREE_TYPE (arg1)) == COMPLEX_TYPE)
3617               {
3618                 real_type = TREE_TYPE (TREE_TYPE (arg1));
3619                 assert (real_type == TREE_TYPE (TREE_TYPE (arg2)));
3620               }
3621             else
3622               {
3623                 real_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg1)));
3624                 assert (real_type == TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg2))));
3625               }
3626
3627             item
3628               = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3629                           ffecom_2 (EQ_EXPR, integer_type_node,
3630                                   ffecom_1 (REALPART_EXPR, real_type, arg1),
3631                                  ffecom_1 (REALPART_EXPR, real_type, arg2)),
3632                           ffecom_2 (EQ_EXPR, integer_type_node,
3633                                   ffecom_1 (IMAGPART_EXPR, real_type, arg1),
3634                                     ffecom_1 (IMAGPART_EXPR, real_type,
3635                                               arg2)));
3636             if (code == EQ_EXPR)
3637               item = ffecom_truth_value (item);
3638             else
3639               item = ffecom_truth_value_invert (item);
3640             return convert (tree_type, item);
3641           }
3642
3643         case FFEINFO_basictypeCHARACTER:
3644           {
3645             ffebld left = ffebld_left (expr);
3646             ffebld right = ffebld_right (expr);
3647             tree left_tree;
3648             tree right_tree;
3649             tree left_length;
3650             tree right_length;
3651
3652             /* f2c run-time functions do the implicit blank-padding for us,
3653                so we don't usually have to implement blank-padding ourselves.
3654                (The exception is when we pass an argument to a separately
3655                compiled statement function -- if we know the arg is not the
3656                same length as the dummy, we must truncate or extend it.  If
3657                we "inline" statement functions, that necessity goes away as
3658                well.)
3659
3660                Strip off the CONVERT operators that blank-pad.  (Truncation by
3661                CONVERT shouldn't happen here, but it can happen in
3662                assignments.) */
3663
3664             while (ffebld_op (left) == FFEBLD_opCONVERT)
3665               left = ffebld_left (left);
3666             while (ffebld_op (right) == FFEBLD_opCONVERT)
3667               right = ffebld_left (right);
3668
3669             left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
3670             right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
3671
3672             if (left_tree == error_mark_node || left_length == error_mark_node
3673                 || right_tree == error_mark_node
3674                 || right_length == error_mark_node)
3675               return error_mark_node;
3676
3677             if ((ffebld_size_known (left) == 1)
3678                 && (ffebld_size_known (right) == 1))
3679               {
3680                 left_tree
3681                   = ffecom_1 (INDIRECT_REF,
3682                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3683                               left_tree);
3684                 right_tree
3685                   = ffecom_1 (INDIRECT_REF,
3686                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3687                               right_tree);
3688
3689                 item
3690                   = ffecom_2 (code, integer_type_node,
3691                               ffecom_2 (ARRAY_REF,
3692                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3693                                         left_tree,
3694                                         integer_one_node),
3695                               ffecom_2 (ARRAY_REF,
3696                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3697                                         right_tree,
3698                                         integer_one_node));
3699               }
3700             else
3701               {
3702                 item = build_tree_list (NULL_TREE, left_tree);
3703                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, right_tree);
3704                 TREE_CHAIN (TREE_CHAIN (item)) = build_tree_list (NULL_TREE,
3705                                                                left_length);
3706                 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
3707                   = build_tree_list (NULL_TREE, right_length);
3708                 item = ffecom_call_gfrt (FFECOM_gfrtCMP, item, NULL_TREE);
3709                 item = ffecom_2 (code, integer_type_node,
3710                                  item,
3711                                  convert (TREE_TYPE (item),
3712                                           integer_zero_node));
3713               }
3714             item = convert (tree_type, item);
3715           }
3716
3717           return item;
3718
3719         default:
3720           assert ("relational bad basictype" == NULL);
3721           /* Fall through. */
3722         case FFEINFO_basictypeANY:
3723           return error_mark_node;
3724         }
3725       break;
3726
3727     case FFEBLD_opPERCENT_LOC:
3728       item = ffecom_arg_ptr_to_expr (ffebld_left (expr), &list);
3729       return convert (tree_type, item);
3730
3731     case FFEBLD_opITEM:
3732     case FFEBLD_opSTAR:
3733     case FFEBLD_opBOUNDS:
3734     case FFEBLD_opREPEAT:
3735     case FFEBLD_opLABTER:
3736     case FFEBLD_opLABTOK:
3737     case FFEBLD_opIMPDO:
3738     case FFEBLD_opCONCATENATE:
3739     case FFEBLD_opSUBSTR:
3740     default:
3741       assert ("bad op" == NULL);
3742       /* Fall through. */
3743     case FFEBLD_opANY:
3744       return error_mark_node;
3745     }
3746
3747 #if 1
3748   assert ("didn't think anything got here anymore!!" == NULL);
3749 #else
3750   switch (ffebld_arity (expr))
3751     {
3752     case 2:
3753       TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3754       TREE_OPERAND (item, 1) = ffecom_expr (ffebld_right (expr));
3755       if (TREE_OPERAND (item, 0) == error_mark_node
3756           || TREE_OPERAND (item, 1) == error_mark_node)
3757         return error_mark_node;
3758       break;
3759
3760     case 1:
3761       TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3762       if (TREE_OPERAND (item, 0) == error_mark_node)
3763         return error_mark_node;
3764       break;
3765
3766     default:
3767       break;
3768     }
3769
3770   return fold (item);
3771 #endif
3772 }
3773
3774 /* Returns the tree that does the intrinsic invocation.
3775
3776    Note: this function applies only to intrinsics returning
3777    CHARACTER*1 or non-CHARACTER results, and to intrinsic
3778    subroutines.  */
3779
3780 static tree
3781 ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
3782                         ffebld dest, bool *dest_used)
3783 {
3784   tree expr_tree;
3785   tree saved_expr1;             /* For those who need it. */
3786   tree saved_expr2;             /* For those who need it. */
3787   ffeinfoBasictype bt;
3788   ffeinfoKindtype kt;
3789   tree tree_type;
3790   tree arg1_type;
3791   tree real_type;               /* REAL type corresponding to COMPLEX. */
3792   tree tempvar;
3793   ffebld list = ffebld_right (expr);    /* List of (some) args. */
3794   ffebld arg1;                  /* For handy reference. */
3795   ffebld arg2;
3796   ffebld arg3;
3797   ffeintrinImp codegen_imp;
3798   ffecomGfrt gfrt;
3799
3800   assert (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER);
3801
3802   if (dest_used != NULL)
3803     *dest_used = FALSE;
3804
3805   bt = ffeinfo_basictype (ffebld_info (expr));
3806   kt = ffeinfo_kindtype (ffebld_info (expr));
3807   tree_type = ffecom_tree_type[bt][kt];
3808
3809   if (list != NULL)
3810     {
3811       arg1 = ffebld_head (list);
3812       if (arg1 != NULL && ffebld_op (arg1) == FFEBLD_opANY)
3813         return error_mark_node;
3814       if ((list = ffebld_trail (list)) != NULL)
3815         {
3816           arg2 = ffebld_head (list);
3817           if (arg2 != NULL && ffebld_op (arg2) == FFEBLD_opANY)
3818             return error_mark_node;
3819           if ((list = ffebld_trail (list)) != NULL)
3820             {
3821               arg3 = ffebld_head (list);
3822               if (arg3 != NULL && ffebld_op (arg3) == FFEBLD_opANY)
3823                 return error_mark_node;
3824             }
3825           else
3826             arg3 = NULL;
3827         }
3828       else
3829         arg2 = arg3 = NULL;
3830     }
3831   else
3832     arg1 = arg2 = arg3 = NULL;
3833
3834   /* <list> ends up at the opITEM of the 3rd arg, or NULL if there are < 3
3835      args.  This is used by the MAX/MIN expansions. */
3836
3837   if (arg1 != NULL)
3838     arg1_type = ffecom_tree_type
3839       [ffeinfo_basictype (ffebld_info (arg1))]
3840       [ffeinfo_kindtype (ffebld_info (arg1))];
3841   else
3842     arg1_type = NULL_TREE;      /* Really not needed, but might catch bugs
3843                                    here. */
3844
3845   /* There are several ways for each of the cases in the following switch
3846      statements to exit (from simplest to use to most complicated):
3847
3848      break;  (when expr_tree == NULL)
3849
3850      A standard call is made to the specific intrinsic just as if it had been
3851      passed in as a dummy procedure and called as any old procedure.  This
3852      method can produce slower code but in some cases it's the easiest way for
3853      now.  However, if a (presumably faster) direct call is available,
3854      that is used, so this is the easiest way in many more cases now.
3855
3856      gfrt = FFECOM_gfrtWHATEVER;
3857      break;
3858
3859      gfrt contains the gfrt index of a library function to call, passing the
3860      argument(s) by value rather than by reference.  Used when a more
3861      careful choice of library function is needed than that provided
3862      by the vanilla `break;'.
3863
3864      return expr_tree;
3865
3866      The expr_tree has been completely set up and is ready to be returned
3867      as is.  No further actions are taken.  Use this when the tree is not
3868      in the simple form for one of the arity_n labels.   */
3869
3870   /* For info on how the switch statement cases were written, see the files
3871      enclosed in comments below the switch statement. */
3872
3873   codegen_imp = ffebld_symter_implementation (ffebld_left (expr));
3874   gfrt = ffeintrin_gfrt_direct (codegen_imp);
3875   if (gfrt == FFECOM_gfrt)
3876     gfrt = ffeintrin_gfrt_indirect (codegen_imp);
3877
3878   switch (codegen_imp)
3879     {
3880     case FFEINTRIN_impABS:
3881     case FFEINTRIN_impCABS:
3882     case FFEINTRIN_impCDABS:
3883     case FFEINTRIN_impDABS:
3884     case FFEINTRIN_impIABS:
3885       if (ffeinfo_basictype (ffebld_info (arg1))
3886           == FFEINFO_basictypeCOMPLEX)
3887         {
3888           if (kt == FFEINFO_kindtypeREAL1)
3889             gfrt = FFECOM_gfrtCABS;
3890           else if (kt == FFEINFO_kindtypeREAL2)
3891             gfrt = FFECOM_gfrtCDABS;
3892           break;
3893         }
3894       return ffecom_1 (ABS_EXPR, tree_type,
3895                        convert (tree_type, ffecom_expr (arg1)));
3896
3897     case FFEINTRIN_impACOS:
3898     case FFEINTRIN_impDACOS:
3899       break;
3900
3901     case FFEINTRIN_impAIMAG:
3902     case FFEINTRIN_impDIMAG:
3903     case FFEINTRIN_impIMAGPART:
3904       if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
3905         arg1_type = TREE_TYPE (arg1_type);
3906       else
3907         arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
3908
3909       return
3910         convert (tree_type,
3911                  ffecom_1 (IMAGPART_EXPR, arg1_type,
3912                            ffecom_expr (arg1)));
3913
3914     case FFEINTRIN_impAINT:
3915     case FFEINTRIN_impDINT:
3916 #if 0
3917       /* ~~Someday implement FIX_TRUNC_EXPR yielding same type as arg.  */
3918       return ffecom_1 (FIX_TRUNC_EXPR, tree_type, ffecom_expr (arg1));
3919 #else /* in the meantime, must use floor to avoid range problems with ints */
3920       /* r__1 = r1 >= 0 ? floor(r1) : -floor(-r1); */
3921       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
3922       return
3923         convert (tree_type,
3924                  ffecom_3 (COND_EXPR, double_type_node,
3925                            ffecom_truth_value
3926                            (ffecom_2 (GE_EXPR, integer_type_node,
3927                                       saved_expr1,
3928                                       convert (arg1_type,
3929                                                ffecom_float_zero_))),
3930                            ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
3931                                              build_tree_list (NULL_TREE,
3932                                                   convert (double_type_node,
3933                                                            saved_expr1)),
3934                                              NULL_TREE),
3935                            ffecom_1 (NEGATE_EXPR, double_type_node,
3936                                      ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
3937                                                  build_tree_list (NULL_TREE,
3938                                                   convert (double_type_node,
3939                                                       ffecom_1 (NEGATE_EXPR,
3940                                                                 arg1_type,
3941                                                                saved_expr1))),
3942                                                        NULL_TREE)
3943                                      ))
3944                  );
3945 #endif
3946
3947     case FFEINTRIN_impANINT:
3948     case FFEINTRIN_impDNINT:
3949 #if 0                           /* This way of doing it won't handle real
3950                                    numbers of large magnitudes. */
3951       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
3952       expr_tree = convert (tree_type,
3953                            convert (integer_type_node,
3954                                     ffecom_3 (COND_EXPR, tree_type,
3955                                               ffecom_truth_value
3956                                               (ffecom_2 (GE_EXPR,
3957                                                          integer_type_node,
3958                                                          saved_expr1,
3959                                                        ffecom_float_zero_)),
3960                                               ffecom_2 (PLUS_EXPR,
3961                                                         tree_type,
3962                                                         saved_expr1,
3963                                                         ffecom_float_half_),
3964                                               ffecom_2 (MINUS_EXPR,
3965                                                         tree_type,
3966                                                         saved_expr1,
3967                                                      ffecom_float_half_))));
3968       return expr_tree;
3969 #else /* So we instead call floor. */
3970       /* r__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1) */
3971       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
3972       return
3973         convert (tree_type,
3974                  ffecom_3 (COND_EXPR, double_type_node,
3975                            ffecom_truth_value
3976                            (ffecom_2 (GE_EXPR, integer_type_node,
3977                                       saved_expr1,
3978                                       convert (arg1_type,
3979                                                ffecom_float_zero_))),
3980                            ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
3981                                              build_tree_list (NULL_TREE,
3982                                                   convert (double_type_node,
3983                                                            ffecom_2 (PLUS_EXPR,
3984                                                                      arg1_type,
3985                                                                      saved_expr1,
3986                                                                      convert (arg1_type,
3987                                                                               ffecom_float_half_)))),
3988                                              NULL_TREE),
3989                            ffecom_1 (NEGATE_EXPR, double_type_node,
3990                                      ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
3991                                                        build_tree_list (NULL_TREE,
3992                                                                         convert (double_type_node,
3993                                                                                  ffecom_2 (MINUS_EXPR,
3994                                                                                            arg1_type,
3995                                                                                            convert (arg1_type,
3996                                                                                                     ffecom_float_half_),
3997                                                                                            saved_expr1))),
3998                                                        NULL_TREE))
3999                            )
4000                  );
4001 #endif
4002
4003     case FFEINTRIN_impASIN:
4004     case FFEINTRIN_impDASIN:
4005     case FFEINTRIN_impATAN:
4006     case FFEINTRIN_impDATAN:
4007     case FFEINTRIN_impATAN2:
4008     case FFEINTRIN_impDATAN2:
4009       break;
4010
4011     case FFEINTRIN_impCHAR:
4012     case FFEINTRIN_impACHAR:
4013 #ifdef HOHO
4014       tempvar = ffecom_make_tempvar (char_type_node, 1, -1);
4015 #else
4016       tempvar = ffebld_nonter_hook (expr);
4017       assert (tempvar);
4018 #endif
4019       {
4020         tree tmv = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (tempvar)));
4021
4022         expr_tree = ffecom_modify (tmv,
4023                                    ffecom_2 (ARRAY_REF, tmv, tempvar,
4024                                              integer_one_node),
4025                                    convert (tmv, ffecom_expr (arg1)));
4026       }
4027       expr_tree = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar),
4028                             expr_tree,
4029                             tempvar);
4030       expr_tree = ffecom_1 (ADDR_EXPR,
4031                             build_pointer_type (TREE_TYPE (expr_tree)),
4032                             expr_tree);
4033       return expr_tree;
4034
4035     case FFEINTRIN_impCMPLX:
4036     case FFEINTRIN_impDCMPLX:
4037       if (arg2 == NULL)
4038         return
4039           convert (tree_type, ffecom_expr (arg1));
4040
4041       real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4042       return
4043         ffecom_2 (COMPLEX_EXPR, tree_type,
4044                   convert (real_type, ffecom_expr (arg1)),
4045                   convert (real_type,
4046                            ffecom_expr (arg2)));
4047
4048     case FFEINTRIN_impCOMPLEX:
4049       return
4050         ffecom_2 (COMPLEX_EXPR, tree_type,
4051                   ffecom_expr (arg1),
4052                   ffecom_expr (arg2));
4053
4054     case FFEINTRIN_impCONJG:
4055     case FFEINTRIN_impDCONJG:
4056       {
4057         tree arg1_tree;
4058
4059         real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4060         arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4061         return
4062           ffecom_2 (COMPLEX_EXPR, tree_type,
4063                     ffecom_1 (REALPART_EXPR, real_type, arg1_tree),
4064                     ffecom_1 (NEGATE_EXPR, real_type,
4065                               ffecom_1 (IMAGPART_EXPR, real_type, arg1_tree)));
4066       }
4067
4068     case FFEINTRIN_impCOS:
4069     case FFEINTRIN_impCCOS:
4070     case FFEINTRIN_impCDCOS:
4071     case FFEINTRIN_impDCOS:
4072       if (bt == FFEINFO_basictypeCOMPLEX)
4073         {
4074           if (kt == FFEINFO_kindtypeREAL1)
4075             gfrt = FFECOM_gfrtCCOS;     /* Overlapping result okay. */
4076           else if (kt == FFEINFO_kindtypeREAL2)
4077             gfrt = FFECOM_gfrtCDCOS;    /* Overlapping result okay. */
4078         }
4079       break;
4080
4081     case FFEINTRIN_impCOSH:
4082     case FFEINTRIN_impDCOSH:
4083       break;
4084
4085     case FFEINTRIN_impDBLE:
4086     case FFEINTRIN_impDFLOAT:
4087     case FFEINTRIN_impDREAL:
4088     case FFEINTRIN_impFLOAT:
4089     case FFEINTRIN_impIDINT:
4090     case FFEINTRIN_impIFIX:
4091     case FFEINTRIN_impINT2:
4092     case FFEINTRIN_impINT8:
4093     case FFEINTRIN_impINT:
4094     case FFEINTRIN_impLONG:
4095     case FFEINTRIN_impREAL:
4096     case FFEINTRIN_impSHORT:
4097     case FFEINTRIN_impSNGL:
4098       return convert (tree_type, ffecom_expr (arg1));
4099
4100     case FFEINTRIN_impDIM:
4101     case FFEINTRIN_impDDIM:
4102     case FFEINTRIN_impIDIM:
4103       saved_expr1 = ffecom_save_tree (convert (tree_type,
4104                                                ffecom_expr (arg1)));
4105       saved_expr2 = ffecom_save_tree (convert (tree_type,
4106                                                ffecom_expr (arg2)));
4107       return
4108         ffecom_3 (COND_EXPR, tree_type,
4109                   ffecom_truth_value
4110                   (ffecom_2 (GT_EXPR, integer_type_node,
4111                              saved_expr1,
4112                              saved_expr2)),
4113                   ffecom_2 (MINUS_EXPR, tree_type,
4114                             saved_expr1,
4115                             saved_expr2),
4116                   convert (tree_type, ffecom_float_zero_));
4117
4118     case FFEINTRIN_impDPROD:
4119       return
4120         ffecom_2 (MULT_EXPR, tree_type,
4121                   convert (tree_type, ffecom_expr (arg1)),
4122                   convert (tree_type, ffecom_expr (arg2)));
4123
4124     case FFEINTRIN_impEXP:
4125     case FFEINTRIN_impCDEXP:
4126     case FFEINTRIN_impCEXP:
4127     case FFEINTRIN_impDEXP:
4128       if (bt == FFEINFO_basictypeCOMPLEX)
4129         {
4130           if (kt == FFEINFO_kindtypeREAL1)
4131             gfrt = FFECOM_gfrtCEXP;     /* Overlapping result okay. */
4132           else if (kt == FFEINFO_kindtypeREAL2)
4133             gfrt = FFECOM_gfrtCDEXP;    /* Overlapping result okay. */
4134         }
4135       break;
4136
4137     case FFEINTRIN_impICHAR:
4138     case FFEINTRIN_impIACHAR:
4139 #if 0                           /* The simple approach. */
4140       ffecom_char_args_ (&expr_tree, &saved_expr1 /* Ignored */ , arg1);
4141       expr_tree
4142         = ffecom_1 (INDIRECT_REF,
4143                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4144                     expr_tree);
4145       expr_tree
4146         = ffecom_2 (ARRAY_REF,
4147                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4148                     expr_tree,
4149                     integer_one_node);
4150       return convert (tree_type, expr_tree);
4151 #else /* The more interesting (and more optimal) approach. */
4152       expr_tree = ffecom_intrinsic_ichar_ (tree_type, arg1, &saved_expr1);
4153       expr_tree = ffecom_3 (COND_EXPR, tree_type,
4154                             saved_expr1,
4155                             expr_tree,
4156                             convert (tree_type, integer_zero_node));
4157       return expr_tree;
4158 #endif
4159
4160     case FFEINTRIN_impINDEX:
4161       break;
4162
4163     case FFEINTRIN_impLEN:
4164 #if 0
4165       break;                                    /* The simple approach. */
4166 #else
4167       return ffecom_intrinsic_len_ (arg1);      /* The more optimal approach. */
4168 #endif
4169
4170     case FFEINTRIN_impLGE:
4171     case FFEINTRIN_impLGT:
4172     case FFEINTRIN_impLLE:
4173     case FFEINTRIN_impLLT:
4174       break;
4175
4176     case FFEINTRIN_impLOG:
4177     case FFEINTRIN_impALOG:
4178     case FFEINTRIN_impCDLOG:
4179     case FFEINTRIN_impCLOG:
4180     case FFEINTRIN_impDLOG:
4181       if (bt == FFEINFO_basictypeCOMPLEX)
4182         {
4183           if (kt == FFEINFO_kindtypeREAL1)
4184             gfrt = FFECOM_gfrtCLOG;     /* Overlapping result okay. */
4185           else if (kt == FFEINFO_kindtypeREAL2)
4186             gfrt = FFECOM_gfrtCDLOG;    /* Overlapping result okay. */
4187         }
4188       break;
4189
4190     case FFEINTRIN_impLOG10:
4191     case FFEINTRIN_impALOG10:
4192     case FFEINTRIN_impDLOG10:
4193       if (gfrt != FFECOM_gfrt)
4194         break;  /* Already picked one, stick with it. */
4195
4196       if (kt == FFEINFO_kindtypeREAL1)
4197         /* We used to call FFECOM_gfrtALOG10 here.  */
4198         gfrt = FFECOM_gfrtL_LOG10;
4199       else if (kt == FFEINFO_kindtypeREAL2)
4200         /* We used to call FFECOM_gfrtDLOG10 here.  */
4201         gfrt = FFECOM_gfrtL_LOG10;
4202       break;
4203
4204     case FFEINTRIN_impMAX:
4205     case FFEINTRIN_impAMAX0:
4206     case FFEINTRIN_impAMAX1:
4207     case FFEINTRIN_impDMAX1:
4208     case FFEINTRIN_impMAX0:
4209     case FFEINTRIN_impMAX1:
4210       if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4211         arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4212       else
4213         arg1_type = tree_type;
4214       expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4215                             convert (arg1_type, ffecom_expr (arg1)),
4216                             convert (arg1_type, ffecom_expr (arg2)));
4217       for (; list != NULL; list = ffebld_trail (list))
4218         {
4219           if ((ffebld_head (list) == NULL)
4220               || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4221             continue;
4222           expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4223                                 expr_tree,
4224                                 convert (arg1_type,
4225                                          ffecom_expr (ffebld_head (list))));
4226         }
4227       return convert (tree_type, expr_tree);
4228
4229     case FFEINTRIN_impMIN:
4230     case FFEINTRIN_impAMIN0:
4231     case FFEINTRIN_impAMIN1:
4232     case FFEINTRIN_impDMIN1:
4233     case FFEINTRIN_impMIN0:
4234     case FFEINTRIN_impMIN1:
4235       if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4236         arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4237       else
4238         arg1_type = tree_type;
4239       expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4240                             convert (arg1_type, ffecom_expr (arg1)),
4241                             convert (arg1_type, ffecom_expr (arg2)));
4242       for (; list != NULL; list = ffebld_trail (list))
4243         {
4244           if ((ffebld_head (list) == NULL)
4245               || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4246             continue;
4247           expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4248                                 expr_tree,
4249                                 convert (arg1_type,
4250                                          ffecom_expr (ffebld_head (list))));
4251         }
4252       return convert (tree_type, expr_tree);
4253
4254     case FFEINTRIN_impMOD:
4255     case FFEINTRIN_impAMOD:
4256     case FFEINTRIN_impDMOD:
4257       if (bt != FFEINFO_basictypeREAL)
4258         return ffecom_2 (TRUNC_MOD_EXPR, tree_type,
4259                          convert (tree_type, ffecom_expr (arg1)),
4260                          convert (tree_type, ffecom_expr (arg2)));
4261
4262       if (kt == FFEINFO_kindtypeREAL1)
4263         /* We used to call FFECOM_gfrtAMOD here.  */
4264         gfrt = FFECOM_gfrtL_FMOD;
4265       else if (kt == FFEINFO_kindtypeREAL2)
4266         /* We used to call FFECOM_gfrtDMOD here.  */
4267         gfrt = FFECOM_gfrtL_FMOD;
4268       break;
4269
4270     case FFEINTRIN_impNINT:
4271     case FFEINTRIN_impIDNINT:
4272 #if 0
4273       /* ~~Ideally FIX_ROUND_EXPR would be implemented, but it ain't yet.  */
4274       return ffecom_1 (FIX_ROUND_EXPR, tree_type, ffecom_expr (arg1));
4275 #else
4276       /* i__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1); */
4277       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4278       return
4279         convert (ffecom_integer_type_node,
4280                  ffecom_3 (COND_EXPR, arg1_type,
4281                            ffecom_truth_value
4282                            (ffecom_2 (GE_EXPR, integer_type_node,
4283                                       saved_expr1,
4284                                       convert (arg1_type,
4285                                                ffecom_float_zero_))),
4286                            ffecom_2 (PLUS_EXPR, arg1_type,
4287                                      saved_expr1,
4288                                      convert (arg1_type,
4289                                               ffecom_float_half_)),
4290                            ffecom_2 (MINUS_EXPR, arg1_type,
4291                                      saved_expr1,
4292                                      convert (arg1_type,
4293                                               ffecom_float_half_))));
4294 #endif
4295
4296     case FFEINTRIN_impSIGN:
4297     case FFEINTRIN_impDSIGN:
4298     case FFEINTRIN_impISIGN:
4299       {
4300         tree arg2_tree = ffecom_expr (arg2);
4301
4302         saved_expr1
4303           = ffecom_save_tree
4304           (ffecom_1 (ABS_EXPR, tree_type,
4305                      convert (tree_type,
4306                               ffecom_expr (arg1))));
4307         expr_tree
4308           = ffecom_3 (COND_EXPR, tree_type,
4309                       ffecom_truth_value
4310                       (ffecom_2 (GE_EXPR, integer_type_node,
4311                                  arg2_tree,
4312                                  convert (TREE_TYPE (arg2_tree),
4313                                           integer_zero_node))),
4314                       saved_expr1,
4315                       ffecom_1 (NEGATE_EXPR, tree_type, saved_expr1));
4316         /* Make sure SAVE_EXPRs get referenced early enough. */
4317         expr_tree
4318           = ffecom_2 (COMPOUND_EXPR, tree_type,
4319                       convert (void_type_node, saved_expr1),
4320                       expr_tree);
4321       }
4322       return expr_tree;
4323
4324     case FFEINTRIN_impSIN:
4325     case FFEINTRIN_impCDSIN:
4326     case FFEINTRIN_impCSIN:
4327     case FFEINTRIN_impDSIN:
4328       if (bt == FFEINFO_basictypeCOMPLEX)
4329         {
4330           if (kt == FFEINFO_kindtypeREAL1)
4331             gfrt = FFECOM_gfrtCSIN;     /* Overlapping result okay. */
4332           else if (kt == FFEINFO_kindtypeREAL2)
4333             gfrt = FFECOM_gfrtCDSIN;    /* Overlapping result okay. */
4334         }
4335       break;
4336
4337     case FFEINTRIN_impSINH:
4338     case FFEINTRIN_impDSINH:
4339       break;
4340
4341     case FFEINTRIN_impSQRT:
4342     case FFEINTRIN_impCDSQRT:
4343     case FFEINTRIN_impCSQRT:
4344     case FFEINTRIN_impDSQRT:
4345       if (bt == FFEINFO_basictypeCOMPLEX)
4346         {
4347           if (kt == FFEINFO_kindtypeREAL1)
4348             gfrt = FFECOM_gfrtCSQRT;    /* Overlapping result okay. */
4349           else if (kt == FFEINFO_kindtypeREAL2)
4350             gfrt = FFECOM_gfrtCDSQRT;   /* Overlapping result okay. */
4351         }
4352       break;
4353
4354     case FFEINTRIN_impTAN:
4355     case FFEINTRIN_impDTAN:
4356     case FFEINTRIN_impTANH:
4357     case FFEINTRIN_impDTANH:
4358       break;
4359
4360     case FFEINTRIN_impREALPART:
4361       if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
4362         arg1_type = TREE_TYPE (arg1_type);
4363       else
4364         arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
4365
4366       return
4367         convert (tree_type,
4368                  ffecom_1 (REALPART_EXPR, arg1_type,
4369                            ffecom_expr (arg1)));
4370
4371     case FFEINTRIN_impIAND:
4372     case FFEINTRIN_impAND:
4373       return ffecom_2 (BIT_AND_EXPR, tree_type,
4374                        convert (tree_type,
4375                                 ffecom_expr (arg1)),
4376                        convert (tree_type,
4377                                 ffecom_expr (arg2)));
4378
4379     case FFEINTRIN_impIOR:
4380     case FFEINTRIN_impOR:
4381       return ffecom_2 (BIT_IOR_EXPR, tree_type,
4382                        convert (tree_type,
4383                                 ffecom_expr (arg1)),
4384                        convert (tree_type,
4385                                 ffecom_expr (arg2)));
4386
4387     case FFEINTRIN_impIEOR:
4388     case FFEINTRIN_impXOR:
4389       return ffecom_2 (BIT_XOR_EXPR, tree_type,
4390                        convert (tree_type,
4391                                 ffecom_expr (arg1)),
4392                        convert (tree_type,
4393                                 ffecom_expr (arg2)));
4394
4395     case FFEINTRIN_impLSHIFT:
4396       return ffecom_2 (LSHIFT_EXPR, tree_type,
4397                        ffecom_expr (arg1),
4398                        convert (integer_type_node,
4399                                 ffecom_expr (arg2)));
4400
4401     case FFEINTRIN_impRSHIFT:
4402       return ffecom_2 (RSHIFT_EXPR, tree_type,
4403                        ffecom_expr (arg1),
4404                        convert (integer_type_node,
4405                                 ffecom_expr (arg2)));
4406
4407     case FFEINTRIN_impNOT:
4408       return ffecom_1 (BIT_NOT_EXPR, tree_type, ffecom_expr (arg1));
4409
4410     case FFEINTRIN_impBIT_SIZE:
4411       return convert (tree_type, TYPE_SIZE (arg1_type));
4412
4413     case FFEINTRIN_impBTEST:
4414       {
4415         ffetargetLogical1 target_true;
4416         ffetargetLogical1 target_false;
4417         tree true_tree;
4418         tree false_tree;
4419
4420         ffetarget_logical1 (&target_true, TRUE);
4421         ffetarget_logical1 (&target_false, FALSE);
4422         if (target_true == 1)
4423           true_tree = convert (tree_type, integer_one_node);
4424         else
4425           true_tree = convert (tree_type, build_int_2 (target_true, 0));
4426         if (target_false == 0)
4427           false_tree = convert (tree_type, integer_zero_node);
4428         else
4429           false_tree = convert (tree_type, build_int_2 (target_false, 0));
4430
4431         return
4432           ffecom_3 (COND_EXPR, tree_type,
4433                     ffecom_truth_value
4434                     (ffecom_2 (EQ_EXPR, integer_type_node,
4435                                ffecom_2 (BIT_AND_EXPR, arg1_type,
4436                                          ffecom_expr (arg1),
4437                                          ffecom_2 (LSHIFT_EXPR, arg1_type,
4438                                                    convert (arg1_type,
4439                                                           integer_one_node),
4440                                                    convert (integer_type_node,
4441                                                             ffecom_expr (arg2)))),
4442                                convert (arg1_type,
4443                                         integer_zero_node))),
4444                     false_tree,
4445                     true_tree);
4446       }
4447
4448     case FFEINTRIN_impIBCLR:
4449       return
4450         ffecom_2 (BIT_AND_EXPR, tree_type,
4451                   ffecom_expr (arg1),
4452                   ffecom_1 (BIT_NOT_EXPR, tree_type,
4453                             ffecom_2 (LSHIFT_EXPR, tree_type,
4454                                       convert (tree_type,
4455                                                integer_one_node),
4456                                       convert (integer_type_node,
4457                                                ffecom_expr (arg2)))));
4458
4459     case FFEINTRIN_impIBITS:
4460       {
4461         tree arg3_tree = ffecom_save_tree (convert (integer_type_node,
4462                                                     ffecom_expr (arg3)));
4463         tree uns_type
4464         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4465
4466         expr_tree
4467           = ffecom_2 (BIT_AND_EXPR, tree_type,
4468                       ffecom_2 (RSHIFT_EXPR, tree_type,
4469                                 ffecom_expr (arg1),
4470                                 convert (integer_type_node,
4471                                          ffecom_expr (arg2))),
4472                       convert (tree_type,
4473                                ffecom_2 (RSHIFT_EXPR, uns_type,
4474                                          ffecom_1 (BIT_NOT_EXPR,
4475                                                    uns_type,
4476                                                    convert (uns_type,
4477                                                         integer_zero_node)),
4478                                          ffecom_2 (MINUS_EXPR,
4479                                                    integer_type_node,
4480                                                    TYPE_SIZE (uns_type),
4481                                                    arg3_tree))));
4482         /* Fix up, because the RSHIFT_EXPR above can't shift over TYPE_SIZE.  */
4483         expr_tree
4484           = ffecom_3 (COND_EXPR, tree_type,
4485                       ffecom_truth_value
4486                       (ffecom_2 (NE_EXPR, integer_type_node,
4487                                  arg3_tree,
4488                                  integer_zero_node)),
4489                       expr_tree,
4490                       convert (tree_type, integer_zero_node));
4491       }
4492       return expr_tree;
4493
4494     case FFEINTRIN_impIBSET:
4495       return
4496         ffecom_2 (BIT_IOR_EXPR, tree_type,
4497                   ffecom_expr (arg1),
4498                   ffecom_2 (LSHIFT_EXPR, tree_type,
4499                             convert (tree_type, integer_one_node),
4500                             convert (integer_type_node,
4501                                      ffecom_expr (arg2))));
4502
4503     case FFEINTRIN_impISHFT:
4504       {
4505         tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4506         tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4507                                                     ffecom_expr (arg2)));
4508         tree uns_type
4509         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4510
4511         expr_tree
4512           = ffecom_3 (COND_EXPR, tree_type,
4513                       ffecom_truth_value
4514                       (ffecom_2 (GE_EXPR, integer_type_node,
4515                                  arg2_tree,
4516                                  integer_zero_node)),
4517                       ffecom_2 (LSHIFT_EXPR, tree_type,
4518                                 arg1_tree,
4519                                 arg2_tree),
4520                       convert (tree_type,
4521                                ffecom_2 (RSHIFT_EXPR, uns_type,
4522                                          convert (uns_type, arg1_tree),
4523                                          ffecom_1 (NEGATE_EXPR,
4524                                                    integer_type_node,
4525                                                    arg2_tree))));
4526         /* Fix up, because {L|R}SHIFT_EXPR don't go over TYPE_SIZE bounds.  */
4527         expr_tree
4528           = ffecom_3 (COND_EXPR, tree_type,
4529                       ffecom_truth_value
4530                       (ffecom_2 (NE_EXPR, integer_type_node,
4531                                  ffecom_1 (ABS_EXPR,
4532                                            integer_type_node,
4533                                            arg2_tree),
4534                                  TYPE_SIZE (uns_type))),
4535                       expr_tree,
4536                       convert (tree_type, integer_zero_node));
4537         /* Make sure SAVE_EXPRs get referenced early enough. */
4538         expr_tree
4539           = ffecom_2 (COMPOUND_EXPR, tree_type,
4540                       convert (void_type_node, arg1_tree),
4541                       ffecom_2 (COMPOUND_EXPR, tree_type,
4542                                 convert (void_type_node, arg2_tree),
4543                                 expr_tree));
4544       }
4545       return expr_tree;
4546
4547     case FFEINTRIN_impISHFTC:
4548       {
4549         tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4550         tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4551                                                     ffecom_expr (arg2)));
4552         tree arg3_tree = (arg3 == NULL) ? TYPE_SIZE (tree_type)
4553         : ffecom_save_tree (convert (integer_type_node, ffecom_expr (arg3)));
4554         tree shift_neg;
4555         tree shift_pos;
4556         tree mask_arg1;
4557         tree masked_arg1;
4558         tree uns_type
4559         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4560
4561         mask_arg1
4562           = ffecom_2 (LSHIFT_EXPR, tree_type,
4563                       ffecom_1 (BIT_NOT_EXPR, tree_type,
4564                                 convert (tree_type, integer_zero_node)),
4565                       arg3_tree);
4566         /* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE.  */
4567         mask_arg1
4568           = ffecom_3 (COND_EXPR, tree_type,
4569                       ffecom_truth_value
4570                       (ffecom_2 (NE_EXPR, integer_type_node,
4571                                  arg3_tree,
4572                                  TYPE_SIZE (uns_type))),
4573                       mask_arg1,
4574                       convert (tree_type, integer_zero_node));
4575         mask_arg1 = ffecom_save_tree (mask_arg1);
4576         masked_arg1
4577           = ffecom_2 (BIT_AND_EXPR, tree_type,
4578                       arg1_tree,
4579                       ffecom_1 (BIT_NOT_EXPR, tree_type,
4580                                 mask_arg1));
4581         masked_arg1 = ffecom_save_tree (masked_arg1);
4582         shift_neg
4583           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4584                       convert (tree_type,
4585                                ffecom_2 (RSHIFT_EXPR, uns_type,
4586                                          convert (uns_type, masked_arg1),
4587                                          ffecom_1 (NEGATE_EXPR,
4588                                                    integer_type_node,
4589                                                    arg2_tree))),
4590                       ffecom_2 (LSHIFT_EXPR, tree_type,
4591                                 arg1_tree,
4592                                 ffecom_2 (PLUS_EXPR, integer_type_node,
4593                                           arg2_tree,
4594                                           arg3_tree)));
4595         shift_pos
4596           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4597                       ffecom_2 (LSHIFT_EXPR, tree_type,
4598                                 arg1_tree,
4599                                 arg2_tree),
4600                       convert (tree_type,
4601                                ffecom_2 (RSHIFT_EXPR, uns_type,
4602                                          convert (uns_type, masked_arg1),
4603                                          ffecom_2 (MINUS_EXPR,
4604                                                    integer_type_node,
4605                                                    arg3_tree,
4606                                                    arg2_tree))));
4607         expr_tree
4608           = ffecom_3 (COND_EXPR, tree_type,
4609                       ffecom_truth_value
4610                       (ffecom_2 (LT_EXPR, integer_type_node,
4611                                  arg2_tree,
4612                                  integer_zero_node)),
4613                       shift_neg,
4614                       shift_pos);
4615         expr_tree
4616           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4617                       ffecom_2 (BIT_AND_EXPR, tree_type,
4618                                 mask_arg1,
4619                                 arg1_tree),
4620                       ffecom_2 (BIT_AND_EXPR, tree_type,
4621                                 ffecom_1 (BIT_NOT_EXPR, tree_type,
4622                                           mask_arg1),
4623                                 expr_tree));
4624         expr_tree
4625           = ffecom_3 (COND_EXPR, tree_type,
4626                       ffecom_truth_value
4627                       (ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
4628                                  ffecom_2 (EQ_EXPR, integer_type_node,
4629                                            ffecom_1 (ABS_EXPR,
4630                                                      integer_type_node,
4631                                                      arg2_tree),
4632                                            arg3_tree),
4633                                  ffecom_2 (EQ_EXPR, integer_type_node,
4634                                            arg2_tree,
4635                                            integer_zero_node))),
4636                       arg1_tree,
4637                       expr_tree);
4638         /* Make sure SAVE_EXPRs get referenced early enough. */
4639         expr_tree
4640           = ffecom_2 (COMPOUND_EXPR, tree_type,
4641                       convert (void_type_node, arg1_tree),
4642                       ffecom_2 (COMPOUND_EXPR, tree_type,
4643                                 convert (void_type_node, arg2_tree),
4644                                 ffecom_2 (COMPOUND_EXPR, tree_type,
4645                                           convert (void_type_node,
4646                                                    mask_arg1),
4647                                           ffecom_2 (COMPOUND_EXPR, tree_type,
4648                                                     convert (void_type_node,
4649                                                              masked_arg1),
4650                                                     expr_tree))));
4651         expr_tree
4652           = ffecom_2 (COMPOUND_EXPR, tree_type,
4653                       convert (void_type_node,
4654                                arg3_tree),
4655                       expr_tree);
4656       }
4657       return expr_tree;
4658
4659     case FFEINTRIN_impLOC:
4660       {
4661         tree arg1_tree = ffecom_expr (arg1);
4662
4663         expr_tree
4664           = convert (tree_type,
4665                      ffecom_1 (ADDR_EXPR,
4666                                build_pointer_type (TREE_TYPE (arg1_tree)),
4667                                arg1_tree));
4668       }
4669       return expr_tree;
4670
4671     case FFEINTRIN_impMVBITS:
4672       {
4673         tree arg1_tree;
4674         tree arg2_tree;
4675         tree arg3_tree;
4676         ffebld arg4 = ffebld_head (ffebld_trail (list));
4677         tree arg4_tree;
4678         tree arg4_type;
4679         ffebld arg5 = ffebld_head (ffebld_trail (ffebld_trail (list)));
4680         tree arg5_tree;
4681         tree prep_arg1;
4682         tree prep_arg4;
4683         tree arg5_plus_arg3;
4684
4685         arg2_tree = convert (integer_type_node,
4686                              ffecom_expr (arg2));
4687         arg3_tree = ffecom_save_tree (convert (integer_type_node,
4688                                                ffecom_expr (arg3)));
4689         arg4_tree = ffecom_expr_rw (NULL_TREE, arg4);
4690         arg4_type = TREE_TYPE (arg4_tree);
4691
4692         arg1_tree = ffecom_save_tree (convert (arg4_type,
4693                                                ffecom_expr (arg1)));
4694
4695         arg5_tree = ffecom_save_tree (convert (integer_type_node,
4696                                                ffecom_expr (arg5)));
4697
4698         prep_arg1
4699           = ffecom_2 (LSHIFT_EXPR, arg4_type,
4700                       ffecom_2 (BIT_AND_EXPR, arg4_type,
4701                                 ffecom_2 (RSHIFT_EXPR, arg4_type,
4702                                           arg1_tree,
4703                                           arg2_tree),
4704                                 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4705                                           ffecom_2 (LSHIFT_EXPR, arg4_type,
4706                                                     ffecom_1 (BIT_NOT_EXPR,
4707                                                               arg4_type,
4708                                                               convert
4709                                                               (arg4_type,
4710                                                         integer_zero_node)),
4711                                                     arg3_tree))),
4712                       arg5_tree);
4713         arg5_plus_arg3
4714           = ffecom_save_tree (ffecom_2 (PLUS_EXPR, arg4_type,
4715                                         arg5_tree,
4716                                         arg3_tree));
4717         prep_arg4
4718           = ffecom_2 (LSHIFT_EXPR, arg4_type,
4719                       ffecom_1 (BIT_NOT_EXPR, arg4_type,
4720                                 convert (arg4_type,
4721                                          integer_zero_node)),
4722                       arg5_plus_arg3);
4723         /* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE.  */
4724         prep_arg4
4725           = ffecom_3 (COND_EXPR, arg4_type,
4726                       ffecom_truth_value
4727                       (ffecom_2 (NE_EXPR, integer_type_node,
4728                                  arg5_plus_arg3,
4729                                  convert (TREE_TYPE (arg5_plus_arg3),
4730                                           TYPE_SIZE (arg4_type)))),
4731                       prep_arg4,
4732                       convert (arg4_type, integer_zero_node));
4733         prep_arg4
4734           = ffecom_2 (BIT_AND_EXPR, arg4_type,
4735                       arg4_tree,
4736                       ffecom_2 (BIT_IOR_EXPR, arg4_type,
4737                                 prep_arg4,
4738                                 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4739                                           ffecom_2 (LSHIFT_EXPR, arg4_type,
4740                                                     ffecom_1 (BIT_NOT_EXPR,
4741                                                               arg4_type,
4742                                                               convert
4743                                                               (arg4_type,
4744                                                         integer_zero_node)),
4745                                                     arg5_tree))));
4746         prep_arg1
4747           = ffecom_2 (BIT_IOR_EXPR, arg4_type,
4748                       prep_arg1,
4749                       prep_arg4);
4750         /* Fix up (twice), because LSHIFT_EXPR above
4751            can't shift over TYPE_SIZE.  */
4752         prep_arg1
4753           = ffecom_3 (COND_EXPR, arg4_type,
4754                       ffecom_truth_value
4755                       (ffecom_2 (NE_EXPR, integer_type_node,
4756                                  arg3_tree,
4757                                  convert (TREE_TYPE (arg3_tree),
4758                                           integer_zero_node))),
4759                       prep_arg1,
4760                       arg4_tree);
4761         prep_arg1
4762           = ffecom_3 (COND_EXPR, arg4_type,
4763                       ffecom_truth_value
4764                       (ffecom_2 (NE_EXPR, integer_type_node,
4765                                  arg3_tree,
4766                                  convert (TREE_TYPE (arg3_tree),
4767                                           TYPE_SIZE (arg4_type)))),
4768                       prep_arg1,
4769                       arg1_tree);
4770         expr_tree
4771           = ffecom_2s (MODIFY_EXPR, void_type_node,
4772                        arg4_tree,
4773                        prep_arg1);
4774         /* Make sure SAVE_EXPRs get referenced early enough. */
4775         expr_tree
4776           = ffecom_2 (COMPOUND_EXPR, void_type_node,
4777                       arg1_tree,
4778                       ffecom_2 (COMPOUND_EXPR, void_type_node,
4779                                 arg3_tree,
4780                                 ffecom_2 (COMPOUND_EXPR, void_type_node,
4781                                           arg5_tree,
4782                                           ffecom_2 (COMPOUND_EXPR, void_type_node,
4783                                                     arg5_plus_arg3,
4784                                                     expr_tree))));
4785         expr_tree
4786           = ffecom_2 (COMPOUND_EXPR, void_type_node,
4787                       arg4_tree,
4788                       expr_tree);
4789
4790       }
4791       return expr_tree;
4792
4793     case FFEINTRIN_impDERF:
4794     case FFEINTRIN_impERF:
4795     case FFEINTRIN_impDERFC:
4796     case FFEINTRIN_impERFC:
4797       break;
4798
4799     case FFEINTRIN_impIARGC:
4800       /* extern int xargc; i__1 = xargc - 1; */
4801       expr_tree = ffecom_2 (MINUS_EXPR, TREE_TYPE (ffecom_tree_xargc_),
4802                             ffecom_tree_xargc_,
4803                             convert (TREE_TYPE (ffecom_tree_xargc_),
4804                                      integer_one_node));
4805       return expr_tree;
4806
4807     case FFEINTRIN_impSIGNAL_func:
4808     case FFEINTRIN_impSIGNAL_subr:
4809       {
4810         tree arg1_tree;
4811         tree arg2_tree;
4812         tree arg3_tree;
4813
4814         arg1_tree = convert (ffecom_f2c_integer_type_node,
4815                              ffecom_expr (arg1));
4816         arg1_tree = ffecom_1 (ADDR_EXPR,
4817                               build_pointer_type (TREE_TYPE (arg1_tree)),
4818                               arg1_tree);
4819
4820         /* Pass procedure as a pointer to it, anything else by value.  */
4821         if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
4822           arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
4823         else
4824           arg2_tree = ffecom_ptr_to_expr (arg2);
4825         arg2_tree = convert (TREE_TYPE (null_pointer_node),
4826                              arg2_tree);
4827
4828         if (arg3 != NULL)
4829           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
4830         else
4831           arg3_tree = NULL_TREE;
4832
4833         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4834         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4835         TREE_CHAIN (arg1_tree) = arg2_tree;
4836
4837         expr_tree
4838           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4839                           ffecom_gfrt_kindtype (gfrt),
4840                           FALSE,
4841                           ((codegen_imp == FFEINTRIN_impSIGNAL_subr) ?
4842                            NULL_TREE :
4843                            tree_type),
4844                           arg1_tree,
4845                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4846                           ffebld_nonter_hook (expr));
4847
4848         if (arg3_tree != NULL_TREE)
4849           expr_tree
4850             = ffecom_modify (NULL_TREE, arg3_tree,
4851                              convert (TREE_TYPE (arg3_tree),
4852                                       expr_tree));
4853       }
4854       return expr_tree;
4855
4856     case FFEINTRIN_impALARM:
4857       {
4858         tree arg1_tree;
4859         tree arg2_tree;
4860         tree arg3_tree;
4861
4862         arg1_tree = convert (ffecom_f2c_integer_type_node,
4863                              ffecom_expr (arg1));
4864         arg1_tree = ffecom_1 (ADDR_EXPR,
4865                               build_pointer_type (TREE_TYPE (arg1_tree)),
4866                               arg1_tree);
4867
4868         /* Pass procedure as a pointer to it, anything else by value.  */
4869         if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
4870           arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
4871         else
4872           arg2_tree = ffecom_ptr_to_expr (arg2);
4873         arg2_tree = convert (TREE_TYPE (null_pointer_node),
4874                              arg2_tree);
4875
4876         if (arg3 != NULL)
4877           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
4878         else
4879           arg3_tree = NULL_TREE;
4880
4881         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4882         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4883         TREE_CHAIN (arg1_tree) = arg2_tree;
4884
4885         expr_tree
4886           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4887                           ffecom_gfrt_kindtype (gfrt),
4888                           FALSE,
4889                           NULL_TREE,
4890                           arg1_tree,
4891                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4892                           ffebld_nonter_hook (expr));
4893
4894         if (arg3_tree != NULL_TREE)
4895           expr_tree
4896             = ffecom_modify (NULL_TREE, arg3_tree,
4897                              convert (TREE_TYPE (arg3_tree),
4898                                       expr_tree));
4899       }
4900       return expr_tree;
4901
4902     case FFEINTRIN_impCHDIR_subr:
4903     case FFEINTRIN_impFDATE_subr:
4904     case FFEINTRIN_impFGET_subr:
4905     case FFEINTRIN_impFPUT_subr:
4906     case FFEINTRIN_impGETCWD_subr:
4907     case FFEINTRIN_impHOSTNM_subr:
4908     case FFEINTRIN_impSYSTEM_subr:
4909     case FFEINTRIN_impUNLINK_subr:
4910       {
4911         tree arg1_len = integer_zero_node;
4912         tree arg1_tree;
4913         tree arg2_tree;
4914
4915         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
4916
4917         if (arg2 != NULL)
4918           arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
4919         else
4920           arg2_tree = NULL_TREE;
4921
4922         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4923         arg1_len = build_tree_list (NULL_TREE, arg1_len);
4924         TREE_CHAIN (arg1_tree) = arg1_len;
4925
4926         expr_tree
4927           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4928                           ffecom_gfrt_kindtype (gfrt),
4929                           FALSE,
4930                           NULL_TREE,
4931                           arg1_tree,
4932                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4933                           ffebld_nonter_hook (expr));
4934
4935         if (arg2_tree != NULL_TREE)
4936           expr_tree
4937             = ffecom_modify (NULL_TREE, arg2_tree,
4938                              convert (TREE_TYPE (arg2_tree),
4939                                       expr_tree));
4940       }
4941       return expr_tree;
4942
4943     case FFEINTRIN_impEXIT:
4944       if (arg1 != NULL)
4945         break;
4946
4947       expr_tree = build_tree_list (NULL_TREE,
4948                                    ffecom_1 (ADDR_EXPR,
4949                                              build_pointer_type
4950                                              (ffecom_integer_type_node),
4951                                              integer_zero_node));
4952
4953       return
4954         ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4955                       ffecom_gfrt_kindtype (gfrt),
4956                       FALSE,
4957                       void_type_node,
4958                       expr_tree,
4959                       NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4960                       ffebld_nonter_hook (expr));
4961
4962     case FFEINTRIN_impFLUSH:
4963       if (arg1 == NULL)
4964         gfrt = FFECOM_gfrtFLUSH;
4965       else
4966         gfrt = FFECOM_gfrtFLUSH1;
4967       break;
4968
4969     case FFEINTRIN_impCHMOD_subr:
4970     case FFEINTRIN_impLINK_subr:
4971     case FFEINTRIN_impRENAME_subr:
4972     case FFEINTRIN_impSYMLNK_subr:
4973       {
4974         tree arg1_len = integer_zero_node;
4975         tree arg1_tree;
4976         tree arg2_len = integer_zero_node;
4977         tree arg2_tree;
4978         tree arg3_tree;
4979
4980         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
4981         arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
4982         if (arg3 != NULL)
4983           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
4984         else
4985           arg3_tree = NULL_TREE;
4986
4987         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4988         arg1_len = build_tree_list (NULL_TREE, arg1_len);
4989         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4990         arg2_len = build_tree_list (NULL_TREE, arg2_len);
4991         TREE_CHAIN (arg1_tree) = arg2_tree;
4992         TREE_CHAIN (arg2_tree) = arg1_len;
4993         TREE_CHAIN (arg1_len) = arg2_len;
4994         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4995                                   ffecom_gfrt_kindtype (gfrt),
4996                                   FALSE,
4997                                   NULL_TREE,
4998                                   arg1_tree,
4999                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5000                                   ffebld_nonter_hook (expr));
5001         if (arg3_tree != NULL_TREE)
5002           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5003                                      convert (TREE_TYPE (arg3_tree),
5004                                               expr_tree));
5005       }
5006       return expr_tree;
5007
5008     case FFEINTRIN_impLSTAT_subr:
5009     case FFEINTRIN_impSTAT_subr:
5010       {
5011         tree arg1_len = integer_zero_node;
5012         tree arg1_tree;
5013         tree arg2_tree;
5014         tree arg3_tree;
5015
5016         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5017
5018         arg2_tree = ffecom_ptr_to_expr (arg2);
5019
5020         if (arg3 != NULL)
5021           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5022         else
5023           arg3_tree = NULL_TREE;
5024
5025         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5026         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5027         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5028         TREE_CHAIN (arg1_tree) = arg2_tree;
5029         TREE_CHAIN (arg2_tree) = arg1_len;
5030         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5031                                   ffecom_gfrt_kindtype (gfrt),
5032                                   FALSE,
5033                                   NULL_TREE,
5034                                   arg1_tree,
5035                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5036                                   ffebld_nonter_hook (expr));
5037         if (arg3_tree != NULL_TREE)
5038           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5039                                      convert (TREE_TYPE (arg3_tree),
5040                                               expr_tree));
5041       }
5042       return expr_tree;
5043
5044     case FFEINTRIN_impFGETC_subr:
5045     case FFEINTRIN_impFPUTC_subr:
5046       {
5047         tree arg1_tree;
5048         tree arg2_tree;
5049         tree arg2_len = integer_zero_node;
5050         tree arg3_tree;
5051
5052         arg1_tree = convert (ffecom_f2c_integer_type_node,
5053                              ffecom_expr (arg1));
5054         arg1_tree = ffecom_1 (ADDR_EXPR,
5055                               build_pointer_type (TREE_TYPE (arg1_tree)),
5056                               arg1_tree);
5057
5058         arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
5059         if (arg3 != NULL)
5060           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5061         else
5062           arg3_tree = NULL_TREE;
5063
5064         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5065         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5066         arg2_len = build_tree_list (NULL_TREE, arg2_len);
5067         TREE_CHAIN (arg1_tree) = arg2_tree;
5068         TREE_CHAIN (arg2_tree) = arg2_len;
5069
5070         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5071                                   ffecom_gfrt_kindtype (gfrt),
5072                                   FALSE,
5073                                   NULL_TREE,
5074                                   arg1_tree,
5075                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5076                                   ffebld_nonter_hook (expr));
5077         if (arg3_tree != NULL_TREE)
5078           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5079                                      convert (TREE_TYPE (arg3_tree),
5080                                               expr_tree));
5081       }
5082       return expr_tree;
5083
5084     case FFEINTRIN_impFSTAT_subr:
5085       {
5086         tree arg1_tree;
5087         tree arg2_tree;
5088         tree arg3_tree;
5089
5090         arg1_tree = convert (ffecom_f2c_integer_type_node,
5091                              ffecom_expr (arg1));
5092         arg1_tree = ffecom_1 (ADDR_EXPR,
5093                               build_pointer_type (TREE_TYPE (arg1_tree)),
5094                               arg1_tree);
5095
5096         arg2_tree = convert (ffecom_f2c_ptr_to_integer_type_node,
5097                              ffecom_ptr_to_expr (arg2));
5098
5099         if (arg3 == NULL)
5100           arg3_tree = NULL_TREE;
5101         else
5102           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5103
5104         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5105         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5106         TREE_CHAIN (arg1_tree) = arg2_tree;
5107         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5108                                   ffecom_gfrt_kindtype (gfrt),
5109                                   FALSE,
5110                                   NULL_TREE,
5111                                   arg1_tree,
5112                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5113                                   ffebld_nonter_hook (expr));
5114         if (arg3_tree != NULL_TREE) {
5115           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5116                                      convert (TREE_TYPE (arg3_tree),
5117                                               expr_tree));
5118         }
5119       }
5120       return expr_tree;
5121
5122     case FFEINTRIN_impKILL_subr:
5123       {
5124         tree arg1_tree;
5125         tree arg2_tree;
5126         tree arg3_tree;
5127
5128         arg1_tree = convert (ffecom_f2c_integer_type_node,
5129                              ffecom_expr (arg1));
5130         arg1_tree = ffecom_1 (ADDR_EXPR,
5131                               build_pointer_type (TREE_TYPE (arg1_tree)),
5132                               arg1_tree);
5133
5134         arg2_tree = convert (ffecom_f2c_integer_type_node,
5135                              ffecom_expr (arg2));
5136         arg2_tree = ffecom_1 (ADDR_EXPR,
5137                               build_pointer_type (TREE_TYPE (arg2_tree)),
5138                               arg2_tree);
5139
5140         if (arg3 == NULL)
5141           arg3_tree = NULL_TREE;
5142         else
5143           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5144
5145         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5146         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5147         TREE_CHAIN (arg1_tree) = arg2_tree;
5148         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5149                                   ffecom_gfrt_kindtype (gfrt),
5150                                   FALSE,
5151                                   NULL_TREE,
5152                                   arg1_tree,
5153                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5154                                   ffebld_nonter_hook (expr));
5155         if (arg3_tree != NULL_TREE) {
5156           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5157                                      convert (TREE_TYPE (arg3_tree),
5158                                               expr_tree));
5159         }
5160       }
5161       return expr_tree;
5162
5163     case FFEINTRIN_impCTIME_subr:
5164     case FFEINTRIN_impTTYNAM_subr:
5165       {
5166         tree arg1_len = integer_zero_node;
5167         tree arg1_tree;
5168         tree arg2_tree;
5169
5170         arg1_tree = ffecom_arg_ptr_to_expr (arg2, &arg1_len);
5171
5172         arg2_tree = convert (((codegen_imp == FFEINTRIN_impCTIME_subr) ?
5173                               ffecom_f2c_longint_type_node :
5174                               ffecom_f2c_integer_type_node),
5175                              ffecom_expr (arg1));
5176         arg2_tree = ffecom_1 (ADDR_EXPR,
5177                               build_pointer_type (TREE_TYPE (arg2_tree)),
5178                               arg2_tree);
5179
5180         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5181         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5182         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5183         TREE_CHAIN (arg1_len) = arg2_tree;
5184         TREE_CHAIN (arg1_tree) = arg1_len;
5185
5186         expr_tree
5187           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5188                           ffecom_gfrt_kindtype (gfrt),
5189                           FALSE,
5190                           NULL_TREE,
5191                           arg1_tree,
5192                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5193                           ffebld_nonter_hook (expr));
5194         TREE_SIDE_EFFECTS (expr_tree) = 1;
5195       }
5196       return expr_tree;
5197
5198     case FFEINTRIN_impIRAND:
5199     case FFEINTRIN_impRAND:
5200       /* Arg defaults to 0 (normal random case) */
5201       {
5202         tree arg1_tree;
5203
5204         if (arg1 == NULL)
5205           arg1_tree = ffecom_integer_zero_node;
5206         else
5207           arg1_tree = ffecom_expr (arg1);
5208         arg1_tree = convert (ffecom_f2c_integer_type_node,
5209                              arg1_tree);
5210         arg1_tree = ffecom_1 (ADDR_EXPR,
5211                               build_pointer_type (TREE_TYPE (arg1_tree)),
5212                               arg1_tree);
5213         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5214
5215         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5216                                   ffecom_gfrt_kindtype (gfrt),
5217                                   FALSE,
5218                                   ((codegen_imp == FFEINTRIN_impIRAND) ?
5219                                    ffecom_f2c_integer_type_node :
5220                                    ffecom_f2c_real_type_node),
5221                                   arg1_tree,
5222                                   dest_tree, dest, dest_used,
5223                                   NULL_TREE, TRUE,
5224                                   ffebld_nonter_hook (expr));
5225       }
5226       return expr_tree;
5227
5228     case FFEINTRIN_impFTELL_subr:
5229     case FFEINTRIN_impUMASK_subr:
5230       {
5231         tree arg1_tree;
5232         tree arg2_tree;
5233
5234         arg1_tree = convert (ffecom_f2c_integer_type_node,
5235                              ffecom_expr (arg1));
5236         arg1_tree = ffecom_1 (ADDR_EXPR,
5237                               build_pointer_type (TREE_TYPE (arg1_tree)),
5238                               arg1_tree);
5239
5240         if (arg2 == NULL)
5241           arg2_tree = NULL_TREE;
5242         else
5243           arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
5244
5245         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5246                                   ffecom_gfrt_kindtype (gfrt),
5247                                   FALSE,
5248                                   NULL_TREE,
5249                                   build_tree_list (NULL_TREE, arg1_tree),
5250                                   NULL_TREE, NULL, NULL, NULL_TREE,
5251                                   TRUE,
5252                                   ffebld_nonter_hook (expr));
5253         if (arg2_tree != NULL_TREE) {
5254           expr_tree = ffecom_modify (NULL_TREE, arg2_tree,
5255                                      convert (TREE_TYPE (arg2_tree),
5256                                               expr_tree));
5257         }
5258       }
5259       return expr_tree;
5260
5261     case FFEINTRIN_impCPU_TIME:
5262     case FFEINTRIN_impSECOND_subr:
5263       {
5264         tree arg1_tree;
5265
5266         arg1_tree = ffecom_expr_w (NULL_TREE, arg1);
5267
5268         expr_tree
5269           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5270                           ffecom_gfrt_kindtype (gfrt),
5271                           FALSE,
5272                           NULL_TREE,
5273                           NULL_TREE,
5274                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5275                           ffebld_nonter_hook (expr));
5276
5277         expr_tree
5278           = ffecom_modify (NULL_TREE, arg1_tree,
5279                            convert (TREE_TYPE (arg1_tree),
5280                                     expr_tree));
5281       }
5282       return expr_tree;
5283
5284     case FFEINTRIN_impDTIME_subr:
5285     case FFEINTRIN_impETIME_subr:
5286       {
5287         tree arg1_tree;
5288         tree result_tree;
5289
5290         result_tree = ffecom_expr_w (NULL_TREE, arg2);
5291
5292         arg1_tree = ffecom_ptr_to_expr (arg1);
5293
5294         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5295                                   ffecom_gfrt_kindtype (gfrt),
5296                                   FALSE,
5297                                   NULL_TREE,
5298                                   build_tree_list (NULL_TREE, arg1_tree),
5299                                   NULL_TREE, NULL, NULL, NULL_TREE,
5300                                   TRUE,
5301                                   ffebld_nonter_hook (expr));
5302         expr_tree = ffecom_modify (NULL_TREE, result_tree,
5303                                    convert (TREE_TYPE (result_tree),
5304                                             expr_tree));
5305       }
5306       return expr_tree;
5307
5308       /* Straightforward calls of libf2c routines: */
5309     case FFEINTRIN_impABORT:
5310     case FFEINTRIN_impACCESS:
5311     case FFEINTRIN_impBESJ0:
5312     case FFEINTRIN_impBESJ1:
5313     case FFEINTRIN_impBESJN:
5314     case FFEINTRIN_impBESY0:
5315     case FFEINTRIN_impBESY1:
5316     case FFEINTRIN_impBESYN:
5317     case FFEINTRIN_impCHDIR_func:
5318     case FFEINTRIN_impCHMOD_func:
5319     case FFEINTRIN_impDATE:
5320     case FFEINTRIN_impDATE_AND_TIME:
5321     case FFEINTRIN_impDBESJ0:
5322     case FFEINTRIN_impDBESJ1:
5323     case FFEINTRIN_impDBESJN:
5324     case FFEINTRIN_impDBESY0:
5325     case FFEINTRIN_impDBESY1:
5326     case FFEINTRIN_impDBESYN:
5327     case FFEINTRIN_impDTIME_func:
5328     case FFEINTRIN_impETIME_func:
5329     case FFEINTRIN_impFGETC_func:
5330     case FFEINTRIN_impFGET_func:
5331     case FFEINTRIN_impFNUM:
5332     case FFEINTRIN_impFPUTC_func:
5333     case FFEINTRIN_impFPUT_func:
5334     case FFEINTRIN_impFSEEK:
5335     case FFEINTRIN_impFSTAT_func:
5336     case FFEINTRIN_impFTELL_func:
5337     case FFEINTRIN_impGERROR:
5338     case FFEINTRIN_impGETARG:
5339     case FFEINTRIN_impGETCWD_func:
5340     case FFEINTRIN_impGETENV:
5341     case FFEINTRIN_impGETGID:
5342     case FFEINTRIN_impGETLOG:
5343     case FFEINTRIN_impGETPID:
5344     case FFEINTRIN_impGETUID:
5345     case FFEINTRIN_impGMTIME:
5346     case FFEINTRIN_impHOSTNM_func:
5347     case FFEINTRIN_impIDATE_unix:
5348     case FFEINTRIN_impIDATE_vxt:
5349     case FFEINTRIN_impIERRNO:
5350     case FFEINTRIN_impISATTY:
5351     case FFEINTRIN_impITIME:
5352     case FFEINTRIN_impKILL_func:
5353     case FFEINTRIN_impLINK_func:
5354     case FFEINTRIN_impLNBLNK:
5355     case FFEINTRIN_impLSTAT_func:
5356     case FFEINTRIN_impLTIME:
5357     case FFEINTRIN_impMCLOCK8:
5358     case FFEINTRIN_impMCLOCK:
5359     case FFEINTRIN_impPERROR:
5360     case FFEINTRIN_impRENAME_func:
5361     case FFEINTRIN_impSECNDS:
5362     case FFEINTRIN_impSECOND_func:
5363     case FFEINTRIN_impSLEEP:
5364     case FFEINTRIN_impSRAND:
5365     case FFEINTRIN_impSTAT_func:
5366     case FFEINTRIN_impSYMLNK_func:
5367     case FFEINTRIN_impSYSTEM_CLOCK:
5368     case FFEINTRIN_impSYSTEM_func:
5369     case FFEINTRIN_impTIME8:
5370     case FFEINTRIN_impTIME_unix:
5371     case FFEINTRIN_impTIME_vxt:
5372     case FFEINTRIN_impUMASK_func:
5373     case FFEINTRIN_impUNLINK_func:
5374       break;
5375
5376     case FFEINTRIN_impCTIME_func:       /* CHARACTER functions not handled here. */
5377     case FFEINTRIN_impFDATE_func:       /* CHARACTER functions not handled here. */
5378     case FFEINTRIN_impTTYNAM_func:      /* CHARACTER functions not handled here. */
5379     case FFEINTRIN_impNONE:
5380     case FFEINTRIN_imp:         /* Hush up gcc warning. */
5381       fprintf (stderr, "No %s implementation.\n",
5382                ffeintrin_name_implementation (ffebld_symter_implementation (ffebld_left (expr))));
5383       assert ("unimplemented intrinsic" == NULL);
5384       return error_mark_node;
5385     }
5386
5387   assert (gfrt != FFECOM_gfrt); /* Must have an implementation! */
5388
5389   expr_tree = ffecom_arglist_expr_ (ffecom_gfrt_args_ (gfrt),
5390                                     ffebld_right (expr));
5391
5392   return ffecom_call_ (ffecom_gfrt_tree_ (gfrt), ffecom_gfrt_kindtype (gfrt),
5393                        (ffe_is_f2c_library () && ffecom_gfrt_complex_[gfrt]),
5394                        tree_type,
5395                        expr_tree, dest_tree, dest, dest_used,
5396                        NULL_TREE, TRUE,
5397                        ffebld_nonter_hook (expr));
5398
5399   /* See bottom of this file for f2c transforms used to determine
5400      many of the above implementations.  The info seems to confuse
5401      Emacs's C mode indentation, which is why it's been moved to
5402      the bottom of this source file.  */
5403 }
5404
5405 /* For power (exponentiation) where right-hand operand is type INTEGER,
5406    generate in-line code to do it the fast way (which, if the operand
5407    is a constant, might just mean a series of multiplies).  */
5408
5409 static tree
5410 ffecom_expr_power_integer_ (ffebld expr)
5411 {
5412   tree l = ffecom_expr (ffebld_left (expr));
5413   tree r = ffecom_expr (ffebld_right (expr));
5414   tree ltype = TREE_TYPE (l);
5415   tree rtype = TREE_TYPE (r);
5416   tree result = NULL_TREE;
5417
5418   if (l == error_mark_node
5419       || r == error_mark_node)
5420     return error_mark_node;
5421
5422   if (TREE_CODE (r) == INTEGER_CST)
5423     {
5424       int sgn = tree_int_cst_sgn (r);
5425
5426       if (sgn == 0)
5427         return convert (ltype, integer_one_node);
5428
5429       if ((TREE_CODE (ltype) == INTEGER_TYPE)
5430           && (sgn < 0))
5431         {
5432           /* Reciprocal of integer is either 0, -1, or 1, so after
5433              calculating that (which we leave to the back end to do
5434              or not do optimally), don't bother with any multiplying.  */
5435
5436           result = ffecom_tree_divide_ (ltype,
5437                                         convert (ltype, integer_one_node),
5438                                         l,
5439                                         NULL_TREE, NULL, NULL, NULL_TREE);
5440           r = ffecom_1 (NEGATE_EXPR,
5441                         rtype,
5442                         r);
5443           if ((TREE_INT_CST_LOW (r) & 1) == 0)
5444             result = ffecom_1 (ABS_EXPR, rtype,
5445                                result);
5446         }
5447
5448       /* Generate appropriate series of multiplies, preceded
5449          by divide if the exponent is negative.  */
5450
5451       l = save_expr (l);
5452
5453       if (sgn < 0)
5454         {
5455           l = ffecom_tree_divide_ (ltype,
5456                                    convert (ltype, integer_one_node),
5457                                    l,
5458                                    NULL_TREE, NULL, NULL,
5459                                    ffebld_nonter_hook (expr));
5460           r = ffecom_1 (NEGATE_EXPR, rtype, r);
5461           assert (TREE_CODE (r) == INTEGER_CST);
5462
5463           if (tree_int_cst_sgn (r) < 0)
5464             {                   /* The "most negative" number.  */
5465               r = ffecom_1 (NEGATE_EXPR, rtype,
5466                             ffecom_2 (RSHIFT_EXPR, rtype,
5467                                       r,
5468                                       integer_one_node));
5469               l = save_expr (l);
5470               l = ffecom_2 (MULT_EXPR, ltype,
5471                             l,
5472                             l);
5473             }
5474         }
5475
5476       for (;;)
5477         {
5478           if (TREE_INT_CST_LOW (r) & 1)
5479             {
5480               if (result == NULL_TREE)
5481                 result = l;
5482               else
5483                 result = ffecom_2 (MULT_EXPR, ltype,
5484                                    result,
5485                                    l);
5486             }
5487
5488           r = ffecom_2 (RSHIFT_EXPR, rtype,
5489                         r,
5490                         integer_one_node);
5491           if (integer_zerop (r))
5492             break;
5493           assert (TREE_CODE (r) == INTEGER_CST);
5494
5495           l = save_expr (l);
5496           l = ffecom_2 (MULT_EXPR, ltype,
5497                         l,
5498                         l);
5499         }
5500       return result;
5501     }
5502
5503   /* Though rhs isn't a constant, in-line code cannot be expanded
5504      while transforming dummies
5505      because the back end cannot be easily convinced to generate
5506      stores (MODIFY_EXPR), handle temporaries, and so on before
5507      all the appropriate rtx's have been generated for things like
5508      dummy args referenced in rhs -- which doesn't happen until
5509      store_parm_decls() is called (expand_function_start, I believe,
5510      does the actual rtx-stuffing of PARM_DECLs).
5511
5512      So, in this case, let the caller generate the call to the
5513      run-time-library function to evaluate the power for us.  */
5514
5515   if (ffecom_transform_only_dummies_)
5516     return NULL_TREE;
5517
5518   /* Right-hand operand not a constant, expand in-line code to figure
5519      out how to do the multiplies, &c.
5520
5521      The returned expression is expressed this way in GNU C, where l and
5522      r are the "inputs":
5523
5524      ({ typeof (r) rtmp = r;
5525         typeof (l) ltmp = l;
5526         typeof (l) result;
5527
5528         if (rtmp == 0)
5529           result = 1;
5530         else
5531           {
5532             if ((basetypeof (l) == basetypeof (int))
5533                 && (rtmp < 0))
5534               {
5535                 result = ((typeof (l)) 1) / ltmp;
5536                 if ((ltmp < 0) && (((-rtmp) & 1) == 0))
5537                   result = -result;
5538               }
5539             else
5540               {
5541                 result = 1;
5542                 if ((basetypeof (l) != basetypeof (int))
5543                     && (rtmp < 0))
5544                   {
5545                     ltmp = ((typeof (l)) 1) / ltmp;
5546                     rtmp = -rtmp;
5547                     if (rtmp < 0)
5548                       {
5549                         rtmp = -(rtmp >> 1);
5550                         ltmp *= ltmp;
5551                       }
5552                   }
5553                 for (;;)
5554                   {
5555                     if (rtmp & 1)
5556                       result *= ltmp;
5557                     if ((rtmp >>= 1) == 0)
5558                       break;
5559                     ltmp *= ltmp;
5560                   }
5561               }
5562           }
5563         result;
5564      })
5565
5566      Note that some of the above is compile-time collapsable, such as
5567      the first part of the if statements that checks the base type of
5568      l against int.  The if statements are phrased that way to suggest
5569      an easy way to generate the if/else constructs here, knowing that
5570      the back end should (and probably does) eliminate the resulting
5571      dead code (either the int case or the non-int case), something
5572      it couldn't do without the redundant phrasing, requiring explicit
5573      dead-code elimination here, which would be kind of difficult to
5574      read.  */
5575
5576   {
5577     tree rtmp;
5578     tree ltmp;
5579     tree divide;
5580     tree basetypeof_l_is_int;
5581     tree se;
5582     tree t;
5583
5584     basetypeof_l_is_int
5585       = build_int_2 ((TREE_CODE (ltype) == INTEGER_TYPE), 0);
5586
5587     se = expand_start_stmt_expr (1);
5588
5589     ffecom_start_compstmt ();
5590
5591 #ifndef HAHA
5592     rtmp = ffecom_make_tempvar ("power_r", rtype,
5593                                 FFETARGET_charactersizeNONE, -1);
5594     ltmp = ffecom_make_tempvar ("power_l", ltype,
5595                                 FFETARGET_charactersizeNONE, -1);
5596     result = ffecom_make_tempvar ("power_res", ltype,
5597                                   FFETARGET_charactersizeNONE, -1);
5598     if (TREE_CODE (ltype) == COMPLEX_TYPE
5599         || TREE_CODE (ltype) == RECORD_TYPE)
5600       divide = ffecom_make_tempvar ("power_div", ltype,
5601                                     FFETARGET_charactersizeNONE, -1);
5602     else
5603       divide = NULL_TREE;
5604 #else  /* HAHA */
5605     {
5606       tree hook;
5607
5608       hook = ffebld_nonter_hook (expr);
5609       assert (hook);
5610       assert (TREE_CODE (hook) == TREE_VEC);
5611       assert (TREE_VEC_LENGTH (hook) == 4);
5612       rtmp = TREE_VEC_ELT (hook, 0);
5613       ltmp = TREE_VEC_ELT (hook, 1);
5614       result = TREE_VEC_ELT (hook, 2);
5615       divide = TREE_VEC_ELT (hook, 3);
5616       if (TREE_CODE (ltype) == COMPLEX_TYPE
5617           || TREE_CODE (ltype) == RECORD_TYPE)
5618         assert (divide);
5619       else
5620         assert (! divide);
5621     }
5622 #endif  /* HAHA */
5623
5624     expand_expr_stmt (ffecom_modify (void_type_node,
5625                                      rtmp,
5626                                      r));
5627     expand_expr_stmt (ffecom_modify (void_type_node,
5628                                      ltmp,
5629                                      l));
5630     expand_start_cond (ffecom_truth_value
5631                        (ffecom_2 (EQ_EXPR, integer_type_node,
5632                                   rtmp,
5633                                   convert (rtype, integer_zero_node))),
5634                        0);
5635     expand_expr_stmt (ffecom_modify (void_type_node,
5636                                      result,
5637                                      convert (ltype, integer_one_node)));
5638     expand_start_else ();
5639     if (! integer_zerop (basetypeof_l_is_int))
5640       {
5641         expand_start_cond (ffecom_2 (LT_EXPR, integer_type_node,
5642                                      rtmp,
5643                                      convert (rtype,
5644                                               integer_zero_node)),
5645                            0);
5646         expand_expr_stmt (ffecom_modify (void_type_node,
5647                                          result,
5648                                          ffecom_tree_divide_
5649                                          (ltype,
5650                                           convert (ltype, integer_one_node),
5651                                           ltmp,
5652                                           NULL_TREE, NULL, NULL,
5653                                           divide)));
5654         expand_start_cond (ffecom_truth_value
5655                            (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5656                                       ffecom_2 (LT_EXPR, integer_type_node,
5657                                                 ltmp,
5658                                                 convert (ltype,
5659                                                          integer_zero_node)),
5660                                       ffecom_2 (EQ_EXPR, integer_type_node,
5661                                                 ffecom_2 (BIT_AND_EXPR,
5662                                                           rtype,
5663                                                           ffecom_1 (NEGATE_EXPR,
5664                                                                     rtype,
5665                                                                     rtmp),
5666                                                           convert (rtype,
5667                                                                    integer_one_node)),
5668                                                 convert (rtype,
5669                                                          integer_zero_node)))),
5670                            0);
5671         expand_expr_stmt (ffecom_modify (void_type_node,
5672                                          result,
5673                                          ffecom_1 (NEGATE_EXPR,
5674                                                    ltype,
5675                                                    result)));
5676         expand_end_cond ();
5677         expand_start_else ();
5678       }
5679     expand_expr_stmt (ffecom_modify (void_type_node,
5680                                      result,
5681                                      convert (ltype, integer_one_node)));
5682     expand_start_cond (ffecom_truth_value
5683                        (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5684                                   ffecom_truth_value_invert
5685                                   (basetypeof_l_is_int),
5686                                   ffecom_2 (LT_EXPR, integer_type_node,
5687                                             rtmp,
5688                                             convert (rtype,
5689                                                      integer_zero_node)))),
5690                        0);
5691     expand_expr_stmt (ffecom_modify (void_type_node,
5692                                      ltmp,
5693                                      ffecom_tree_divide_
5694                                      (ltype,
5695                                       convert (ltype, integer_one_node),
5696                                       ltmp,
5697                                       NULL_TREE, NULL, NULL,
5698                                       divide)));
5699     expand_expr_stmt (ffecom_modify (void_type_node,
5700                                      rtmp,
5701                                      ffecom_1 (NEGATE_EXPR, rtype,
5702                                                rtmp)));
5703     expand_start_cond (ffecom_truth_value
5704                        (ffecom_2 (LT_EXPR, integer_type_node,
5705                                   rtmp,
5706                                   convert (rtype, integer_zero_node))),
5707                        0);
5708     expand_expr_stmt (ffecom_modify (void_type_node,
5709                                      rtmp,
5710                                      ffecom_1 (NEGATE_EXPR, rtype,
5711                                                ffecom_2 (RSHIFT_EXPR,
5712                                                          rtype,
5713                                                          rtmp,
5714                                                          integer_one_node))));
5715     expand_expr_stmt (ffecom_modify (void_type_node,
5716                                      ltmp,
5717                                      ffecom_2 (MULT_EXPR, ltype,
5718                                                ltmp,
5719                                                ltmp)));
5720     expand_end_cond ();
5721     expand_end_cond ();
5722     expand_start_loop (1);
5723     expand_start_cond (ffecom_truth_value
5724                        (ffecom_2 (BIT_AND_EXPR, rtype,
5725                                   rtmp,
5726                                   convert (rtype, integer_one_node))),
5727                        0);
5728     expand_expr_stmt (ffecom_modify (void_type_node,
5729                                      result,
5730                                      ffecom_2 (MULT_EXPR, ltype,
5731                                                result,
5732                                                ltmp)));
5733     expand_end_cond ();
5734     expand_exit_loop_if_false (NULL,
5735                                ffecom_truth_value
5736                                (ffecom_modify (rtype,
5737                                                rtmp,
5738                                                ffecom_2 (RSHIFT_EXPR,
5739                                                          rtype,
5740                                                          rtmp,
5741                                                          integer_one_node))));
5742     expand_expr_stmt (ffecom_modify (void_type_node,
5743                                      ltmp,
5744                                      ffecom_2 (MULT_EXPR, ltype,
5745                                                ltmp,
5746                                                ltmp)));
5747     expand_end_loop ();
5748     expand_end_cond ();
5749     if (!integer_zerop (basetypeof_l_is_int))
5750       expand_end_cond ();
5751     expand_expr_stmt (result);
5752
5753     t = ffecom_end_compstmt ();
5754
5755     result = expand_end_stmt_expr (se);
5756
5757     /* This code comes from c-parse.in, after its expand_end_stmt_expr.  */
5758
5759     if (TREE_CODE (t) == BLOCK)
5760       {
5761         /* Make a BIND_EXPR for the BLOCK already made.  */
5762         result = build (BIND_EXPR, TREE_TYPE (result),
5763                         NULL_TREE, result, t);
5764         /* Remove the block from the tree at this point.
5765            It gets put back at the proper place
5766            when the BIND_EXPR is expanded.  */
5767         delete_block (t);
5768       }
5769     else
5770       result = t;
5771   }
5772
5773   return result;
5774 }
5775
5776 /* ffecom_expr_transform_ -- Transform symbols in expr
5777
5778    ffebld expr;  // FFE expression.
5779    ffecom_expr_transform_ (expr);
5780
5781    Recursive descent on expr while transforming any untransformed SYMTERs.  */
5782
5783 static void
5784 ffecom_expr_transform_ (ffebld expr)
5785 {
5786   tree t;
5787   ffesymbol s;
5788
5789  tail_recurse:
5790
5791   if (expr == NULL)
5792     return;
5793
5794   switch (ffebld_op (expr))
5795     {
5796     case FFEBLD_opSYMTER:
5797       s = ffebld_symter (expr);
5798       t = ffesymbol_hook (s).decl_tree;
5799       if ((t == NULL_TREE)
5800           && ((ffesymbol_kind (s) != FFEINFO_kindNONE)
5801               || ((ffesymbol_where (s) != FFEINFO_whereNONE)
5802                   && (ffesymbol_where (s) != FFEINFO_whereINTRINSIC))))
5803         {
5804           s = ffecom_sym_transform_ (s);
5805           t = ffesymbol_hook (s).decl_tree;     /* Sfunc expr non-dummy,
5806                                                    DIMENSION expr? */
5807         }
5808       break;                    /* Ok if (t == NULL) here. */
5809
5810     case FFEBLD_opITEM:
5811       ffecom_expr_transform_ (ffebld_head (expr));
5812       expr = ffebld_trail (expr);
5813       goto tail_recurse;        /* :::::::::::::::::::: */
5814
5815     default:
5816       break;
5817     }
5818
5819   switch (ffebld_arity (expr))
5820     {
5821     case 2:
5822       ffecom_expr_transform_ (ffebld_left (expr));
5823       expr = ffebld_right (expr);
5824       goto tail_recurse;        /* :::::::::::::::::::: */
5825
5826     case 1:
5827       expr = ffebld_left (expr);
5828       goto tail_recurse;        /* :::::::::::::::::::: */
5829
5830     default:
5831       break;
5832     }
5833
5834   return;
5835 }
5836
5837 /* Make a type based on info in live f2c.h file.  */
5838
5839 static void
5840 ffecom_f2c_make_type_ (tree *type, int tcode, const char *name)
5841 {
5842   switch (tcode)
5843     {
5844     case FFECOM_f2ccodeCHAR:
5845       *type = make_signed_type (CHAR_TYPE_SIZE);
5846       break;
5847
5848     case FFECOM_f2ccodeSHORT:
5849       *type = make_signed_type (SHORT_TYPE_SIZE);
5850       break;
5851
5852     case FFECOM_f2ccodeINT:
5853       *type = make_signed_type (INT_TYPE_SIZE);
5854       break;
5855
5856     case FFECOM_f2ccodeLONG:
5857       *type = make_signed_type (LONG_TYPE_SIZE);
5858       break;
5859
5860     case FFECOM_f2ccodeLONGLONG:
5861       *type = make_signed_type (LONG_LONG_TYPE_SIZE);
5862       break;
5863
5864     case FFECOM_f2ccodeCHARPTR:
5865       *type = build_pointer_type (DEFAULT_SIGNED_CHAR
5866                                   ? signed_char_type_node
5867                                   : unsigned_char_type_node);
5868       break;
5869
5870     case FFECOM_f2ccodeFLOAT:
5871       *type = make_node (REAL_TYPE);
5872       TYPE_PRECISION (*type) = FLOAT_TYPE_SIZE;
5873       layout_type (*type);
5874       break;
5875
5876     case FFECOM_f2ccodeDOUBLE:
5877       *type = make_node (REAL_TYPE);
5878       TYPE_PRECISION (*type) = DOUBLE_TYPE_SIZE;
5879       layout_type (*type);
5880       break;
5881
5882     case FFECOM_f2ccodeLONGDOUBLE:
5883       *type = make_node (REAL_TYPE);
5884       TYPE_PRECISION (*type) = LONG_DOUBLE_TYPE_SIZE;
5885       layout_type (*type);
5886       break;
5887
5888     case FFECOM_f2ccodeTWOREALS:
5889       *type = ffecom_make_complex_type_ (ffecom_f2c_real_type_node);
5890       break;
5891
5892     case FFECOM_f2ccodeTWODOUBLEREALS:
5893       *type = ffecom_make_complex_type_ (ffecom_f2c_doublereal_type_node);
5894       break;
5895
5896     default:
5897       assert ("unexpected FFECOM_f2ccodeXYZZY!" == NULL);
5898       *type = error_mark_node;
5899       return;
5900     }
5901
5902   pushdecl (build_decl (TYPE_DECL,
5903                         ffecom_get_invented_identifier ("__g77_f2c_%s", name),
5904                         *type));
5905 }
5906
5907 /* Set the f2c list-directed-I/O code for whatever (integral) type has the
5908    given size.  */
5909
5910 static void
5911 ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
5912                           int code)
5913 {
5914   int j;
5915   tree t;
5916
5917   for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
5918     if ((t = ffecom_tree_type[bt][j]) != NULL_TREE
5919         && compare_tree_int (TYPE_SIZE (t), size) == 0)
5920       {
5921         assert (code != -1);
5922         ffecom_f2c_typecode_[bt][j] = code;
5923         code = -1;
5924       }
5925 }
5926
5927 /* Finish up globals after doing all program units in file
5928
5929    Need to handle only uninitialized COMMON areas.  */
5930
5931 static ffeglobal
5932 ffecom_finish_global_ (ffeglobal global)
5933 {
5934   tree cbtype;
5935   tree cbt;
5936   tree size;
5937
5938   if (ffeglobal_type (global) != FFEGLOBAL_typeCOMMON)
5939       return global;
5940
5941   if (ffeglobal_common_init (global))
5942       return global;
5943
5944   cbt = ffeglobal_hook (global);
5945   if ((cbt == NULL_TREE)
5946       || !ffeglobal_common_have_size (global))
5947     return global;              /* No need to make common, never ref'd. */
5948
5949   DECL_EXTERNAL (cbt) = 0;
5950
5951   /* Give the array a size now.  */
5952
5953   size = build_int_2 ((ffeglobal_common_size (global)
5954                       + ffeglobal_common_pad (global)) - 1,
5955                       0);
5956
5957   cbtype = TREE_TYPE (cbt);
5958   TYPE_DOMAIN (cbtype) = build_range_type (integer_type_node,
5959                                            integer_zero_node,
5960                                            size);
5961   if (!TREE_TYPE (size))
5962     TREE_TYPE (size) = TYPE_DOMAIN (cbtype);
5963   layout_type (cbtype);
5964
5965   cbt = start_decl (cbt, FALSE);
5966   assert (cbt == ffeglobal_hook (global));
5967
5968   finish_decl (cbt, NULL_TREE, FALSE);
5969
5970   return global;
5971 }
5972
5973 /* Finish up any untransformed symbols.  */
5974
5975 static ffesymbol
5976 ffecom_finish_symbol_transform_ (ffesymbol s)
5977 {
5978   if ((s == NULL) || (TREE_CODE (current_function_decl) == ERROR_MARK))
5979     return s;
5980
5981   /* It's easy to know to transform an untransformed symbol, to make sure
5982      we put out debugging info for it.  But COMMON variables, unlike
5983      EQUIVALENCE ones, aren't given declarations in addition to the
5984      tree expressions that specify offsets, because COMMON variables
5985      can be referenced in the outer scope where only dummy arguments
5986      (PARM_DECLs) should really be seen.  To be safe, just don't do any
5987      VAR_DECLs for COMMON variables when we transform them for real
5988      use, and therefore we do all the VAR_DECL creating here.  */
5989
5990   if (ffesymbol_hook (s).decl_tree == NULL_TREE)
5991     {
5992       if (ffesymbol_kind (s) != FFEINFO_kindNONE
5993           || (ffesymbol_where (s) != FFEINFO_whereNONE
5994               && ffesymbol_where (s) != FFEINFO_whereINTRINSIC
5995               && ffesymbol_where (s) != FFEINFO_whereDUMMY))
5996         /* Not transformed, and not CHARACTER*(*), and not a dummy
5997            argument, which can happen only if the entry point names
5998            it "rides in on" are all invalidated for other reasons.  */
5999         s = ffecom_sym_transform_ (s);
6000     }
6001
6002   if ((ffesymbol_where (s) == FFEINFO_whereCOMMON)
6003       && (ffesymbol_hook (s).decl_tree != error_mark_node))
6004     {
6005       /* This isn't working, at least for dbxout.  The .s file looks
6006          okay to me (burley), but in gdb 4.9 at least, the variables
6007          appear to reside somewhere outside of the common area, so
6008          it doesn't make sense to mislead anyone by generating the info
6009          on those variables until this is fixed.  NOTE: Same problem
6010          with EQUIVALENCE, sadly...see similar #if later.  */
6011       ffecom_member_phase2_ (ffesymbol_storage (ffesymbol_common (s)),
6012                              ffesymbol_storage (s));
6013     }
6014
6015   return s;
6016 }
6017
6018 /* Append underscore(s) to name before calling get_identifier.  "us"
6019    is nonzero if the name already contains an underscore and thus
6020    needs two underscores appended.  */
6021
6022 static tree
6023 ffecom_get_appended_identifier_ (char us, const char *name)
6024 {
6025   int i;
6026   char *newname;
6027   tree id;
6028
6029   newname = xmalloc ((i = strlen (name)) + 1
6030                      + ffe_is_underscoring ()
6031                      + us);
6032   memcpy (newname, name, i);
6033   newname[i] = '_';
6034   newname[i + us] = '_';
6035   newname[i + 1 + us] = '\0';
6036   id = get_identifier (newname);
6037
6038   free (newname);
6039
6040   return id;
6041 }
6042
6043 /* Decide whether to append underscore to name before calling
6044    get_identifier.  */
6045
6046 static tree
6047 ffecom_get_external_identifier_ (ffesymbol s)
6048 {
6049   char us;
6050   const char *name = ffesymbol_text (s);
6051
6052   /* If name is a built-in name, just return it as is.  */
6053
6054   if (!ffe_is_underscoring ()
6055       || (strcmp (name, FFETARGET_nameBLANK_COMMON) == 0)
6056 #if FFETARGET_isENFORCED_MAIN_NAME
6057       || (strcmp (name, FFETARGET_nameENFORCED_NAME) == 0)
6058 #else
6059       || (strcmp (name, FFETARGET_nameUNNAMED_MAIN) == 0)
6060 #endif
6061       || (strcmp (name, FFETARGET_nameUNNAMED_BLOCK_DATA) == 0))
6062     return get_identifier (name);
6063
6064   us = ffe_is_second_underscore ()
6065     ? (strchr (name, '_') != NULL)
6066       : 0;
6067
6068   return ffecom_get_appended_identifier_ (us, name);
6069 }
6070
6071 /* Decide whether to append underscore to internal name before calling
6072    get_identifier.
6073
6074    This is for non-external, top-function-context names only.  Transform
6075    identifier so it doesn't conflict with the transformed result
6076    of using a _different_ external name.  E.g. if "CALL FOO" is
6077    transformed into "FOO_();", then the variable in "FOO_ = 3"
6078    must be transformed into something that does not conflict, since
6079    these two things should be independent.
6080
6081    The transformation is as follows.  If the name does not contain
6082    an underscore, there is no possible conflict, so just return.
6083    If the name does contain an underscore, then transform it just
6084    like we transform an external identifier.  */
6085
6086 static tree
6087 ffecom_get_identifier_ (const char *name)
6088 {
6089   /* If name does not contain an underscore, just return it as is.  */
6090
6091   if (!ffe_is_underscoring ()
6092       || (strchr (name, '_') == NULL))
6093     return get_identifier (name);
6094
6095   return ffecom_get_appended_identifier_ (ffe_is_second_underscore (),
6096                                           name);
6097 }
6098
6099 /* ffecom_gen_sfuncdef_ -- Generate definition of statement function
6100
6101    tree t;
6102    ffesymbol s;  // kindFUNCTION, whereIMMEDIATE.
6103    t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s),
6104          ffesymbol_kindtype(s));
6105
6106    Call after setting up containing function and getting trees for all
6107    other symbols.  */
6108
6109 static tree
6110 ffecom_gen_sfuncdef_ (ffesymbol s, ffeinfoBasictype bt, ffeinfoKindtype kt)
6111 {
6112   ffebld expr = ffesymbol_sfexpr (s);
6113   tree type;
6114   tree func;
6115   tree result;
6116   bool charfunc = (bt == FFEINFO_basictypeCHARACTER);
6117   static bool recurse = FALSE;
6118   int old_lineno = lineno;
6119   const char *old_input_filename = input_filename;
6120
6121   ffecom_nested_entry_ = s;
6122
6123   /* For now, we don't have a handy pointer to where the sfunc is actually
6124      defined, though that should be easy to add to an ffesymbol. (The
6125      token/where info available might well point to the place where the type
6126      of the sfunc is declared, especially if that precedes the place where
6127      the sfunc itself is defined, which is typically the case.)  We should
6128      put out a null pointer rather than point somewhere wrong, but I want to
6129      see how it works at this point.  */
6130
6131   input_filename = ffesymbol_where_filename (s);
6132   lineno = ffesymbol_where_filelinenum (s);
6133
6134   /* Pretransform the expression so any newly discovered things belong to the
6135      outer program unit, not to the statement function. */
6136
6137   ffecom_expr_transform_ (expr);
6138
6139   /* Make sure no recursive invocation of this fn (a specific case of failing
6140      to pretransform an sfunc's expression, i.e. where its expression
6141      references another untransformed sfunc) happens. */
6142
6143   assert (!recurse);
6144   recurse = TRUE;
6145
6146   push_f_function_context ();
6147
6148   if (charfunc)
6149     type = void_type_node;
6150   else
6151     {
6152       type = ffecom_tree_type[bt][kt];
6153       if (type == NULL_TREE)
6154         type = integer_type_node;       /* _sym_exec_transition reports
6155                                            error. */
6156     }
6157
6158   start_function (ffecom_get_identifier_ (ffesymbol_text (s)),
6159                   build_function_type (type, NULL_TREE),
6160                   1,            /* nested/inline */
6161                   0);           /* TREE_PUBLIC */
6162
6163   /* We don't worry about COMPLEX return values here, because this is
6164      entirely internal to our code, and gcc has the ability to return COMPLEX
6165      directly as a value.  */
6166
6167   if (charfunc)
6168     {                           /* Prepend arg for where result goes. */
6169       tree type;
6170
6171       type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
6172
6173       result = ffecom_get_invented_identifier ("__g77_%s", "result");
6174
6175       ffecom_char_enhance_arg_ (&type, s);      /* Ignore returned length. */
6176
6177       type = build_pointer_type (type);
6178       result = build_decl (PARM_DECL, result, type);
6179
6180       push_parm_decl (result);
6181     }
6182   else
6183     result = NULL_TREE;         /* Not ref'd if !charfunc. */
6184
6185   ffecom_push_dummy_decls_ (ffesymbol_dummyargs (s), TRUE);
6186
6187   store_parm_decls (0);
6188
6189   ffecom_start_compstmt ();
6190
6191   if (expr != NULL)
6192     {
6193       if (charfunc)
6194         {
6195           ffetargetCharacterSize sz = ffesymbol_size (s);
6196           tree result_length;
6197
6198           result_length = build_int_2 (sz, 0);
6199           TREE_TYPE (result_length) = ffecom_f2c_ftnlen_type_node;
6200
6201           ffecom_prepare_let_char_ (sz, expr);
6202
6203           ffecom_prepare_end ();
6204
6205           ffecom_let_char_ (result, result_length, sz, expr);
6206           expand_null_return ();
6207         }
6208       else
6209         {
6210           ffecom_prepare_expr (expr);
6211
6212           ffecom_prepare_end ();
6213
6214           expand_return (ffecom_modify (NULL_TREE,
6215                                         DECL_RESULT (current_function_decl),
6216                                         ffecom_expr (expr)));
6217         }
6218     }
6219
6220   ffecom_end_compstmt ();
6221
6222   func = current_function_decl;
6223   finish_function (1);
6224
6225   pop_f_function_context ();
6226
6227   recurse = FALSE;
6228
6229   lineno = old_lineno;
6230   input_filename = old_input_filename;
6231
6232   ffecom_nested_entry_ = NULL;
6233
6234   return func;
6235 }
6236
6237 static const char *
6238 ffecom_gfrt_args_ (ffecomGfrt ix)
6239 {
6240   return ffecom_gfrt_argstring_[ix];
6241 }
6242
6243 static tree
6244 ffecom_gfrt_tree_ (ffecomGfrt ix)
6245 {
6246   if (ffecom_gfrt_[ix] == NULL_TREE)
6247     ffecom_make_gfrt_ (ix);
6248
6249   return ffecom_1 (ADDR_EXPR,
6250                    build_pointer_type (TREE_TYPE (ffecom_gfrt_[ix])),
6251                    ffecom_gfrt_[ix]);
6252 }
6253
6254 /* Return initialize-to-zero expression for this VAR_DECL.  */
6255
6256 /* A somewhat evil way to prevent the garbage collector
6257    from collecting 'tree' structures.  */
6258 #define NUM_TRACKED_CHUNK 63
6259 static struct tree_ggc_tracker
6260 {
6261   struct tree_ggc_tracker *next;
6262   tree trees[NUM_TRACKED_CHUNK];
6263 } *tracker_head = NULL;
6264
6265 static void
6266 mark_tracker_head (void *arg)
6267 {
6268   struct tree_ggc_tracker *head;
6269   int i;
6270
6271   for (head = * (struct tree_ggc_tracker **) arg;
6272        head != NULL;
6273        head = head->next)
6274   {
6275     ggc_mark (head);
6276     for (i = 0; i < NUM_TRACKED_CHUNK; i++)
6277       ggc_mark_tree (head->trees[i]);
6278   }
6279 }
6280
6281 void
6282 ffecom_save_tree_forever (tree t)
6283 {
6284   int i;
6285   if (tracker_head != NULL)
6286     for (i = 0; i < NUM_TRACKED_CHUNK; i++)
6287       if (tracker_head->trees[i] == NULL)
6288         {
6289           tracker_head->trees[i] = t;
6290           return;
6291         }
6292
6293   {
6294     /* Need to allocate a new block.  */
6295     struct tree_ggc_tracker *old_head = tracker_head;
6296
6297     tracker_head = ggc_alloc (sizeof (*tracker_head));
6298     tracker_head->next = old_head;
6299     tracker_head->trees[0] = t;
6300     for (i = 1; i < NUM_TRACKED_CHUNK; i++)
6301       tracker_head->trees[i] = NULL;
6302   }
6303 }
6304
6305 static tree
6306 ffecom_init_zero_ (tree decl)
6307 {
6308   tree init;
6309   int incremental = TREE_STATIC (decl);
6310   tree type = TREE_TYPE (decl);
6311
6312   if (incremental)
6313     {
6314       make_decl_rtl (decl, NULL);
6315       assemble_variable (decl, TREE_PUBLIC (decl) ? 1 : 0, 0, 1);
6316     }
6317
6318   if ((TREE_CODE (type) != ARRAY_TYPE)
6319       && (TREE_CODE (type) != RECORD_TYPE)
6320       && (TREE_CODE (type) != UNION_TYPE)
6321       && !incremental)
6322     init = convert (type, integer_zero_node);
6323   else if (!incremental)
6324     {
6325       init = build (CONSTRUCTOR, type, NULL_TREE, NULL_TREE);
6326       TREE_CONSTANT (init) = 1;
6327       TREE_STATIC (init) = 1;
6328     }
6329   else
6330     {
6331       assemble_zeros (int_size_in_bytes (type));
6332       init = error_mark_node;
6333     }
6334
6335   return init;
6336 }
6337
6338 static tree
6339 ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
6340                          tree *maybe_tree)
6341 {
6342   tree expr_tree;
6343   tree length_tree;
6344
6345   switch (ffebld_op (arg))
6346     {
6347     case FFEBLD_opCONTER:       /* For F90, check 0-length. */
6348       if (ffetarget_length_character1
6349           (ffebld_constant_character1
6350            (ffebld_conter (arg))) == 0)
6351         {
6352           *maybe_tree = integer_zero_node;
6353           return convert (tree_type, integer_zero_node);
6354         }
6355
6356       *maybe_tree = integer_one_node;
6357       expr_tree = build_int_2 (*ffetarget_text_character1
6358                                (ffebld_constant_character1
6359                                 (ffebld_conter (arg))),
6360                                0);
6361       TREE_TYPE (expr_tree) = tree_type;
6362       return expr_tree;
6363
6364     case FFEBLD_opSYMTER:
6365     case FFEBLD_opARRAYREF:
6366     case FFEBLD_opFUNCREF:
6367     case FFEBLD_opSUBSTR:
6368       ffecom_char_args_ (&expr_tree, &length_tree, arg);
6369
6370       if ((expr_tree == error_mark_node)
6371           || (length_tree == error_mark_node))
6372         {
6373           *maybe_tree = error_mark_node;
6374           return error_mark_node;
6375         }
6376
6377       if (integer_zerop (length_tree))
6378         {
6379           *maybe_tree = integer_zero_node;
6380           return convert (tree_type, integer_zero_node);
6381         }
6382
6383       expr_tree
6384         = ffecom_1 (INDIRECT_REF,
6385                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6386                     expr_tree);
6387       expr_tree
6388         = ffecom_2 (ARRAY_REF,
6389                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6390                     expr_tree,
6391                     integer_one_node);
6392       expr_tree = convert (tree_type, expr_tree);
6393
6394       if (TREE_CODE (length_tree) == INTEGER_CST)
6395         *maybe_tree = integer_one_node;
6396       else                      /* Must check length at run time.  */
6397         *maybe_tree
6398           = ffecom_truth_value
6399             (ffecom_2 (GT_EXPR, integer_type_node,
6400                        length_tree,
6401                        ffecom_f2c_ftnlen_zero_node));
6402       return expr_tree;
6403
6404     case FFEBLD_opPAREN:
6405     case FFEBLD_opCONVERT:
6406       if (ffeinfo_size (ffebld_info (arg)) == 0)
6407         {
6408           *maybe_tree = integer_zero_node;
6409           return convert (tree_type, integer_zero_node);
6410         }
6411       return ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6412                                       maybe_tree);
6413
6414     case FFEBLD_opCONCATENATE:
6415       {
6416         tree maybe_left;
6417         tree maybe_right;
6418         tree expr_left;
6419         tree expr_right;
6420
6421         expr_left = ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6422                                              &maybe_left);
6423         expr_right = ffecom_intrinsic_ichar_ (tree_type, ffebld_right (arg),
6424                                               &maybe_right);
6425         *maybe_tree = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
6426                                 maybe_left,
6427                                 maybe_right);
6428         expr_tree = ffecom_3 (COND_EXPR, tree_type,
6429                               maybe_left,
6430                               expr_left,
6431                               expr_right);
6432         return expr_tree;
6433       }
6434
6435     default:
6436       assert ("bad op in ICHAR" == NULL);
6437       return error_mark_node;
6438     }
6439 }
6440
6441 /* ffecom_intrinsic_len_ -- Return length info for char arg (LEN())
6442
6443    tree length_arg;
6444    ffebld expr;
6445    length_arg = ffecom_intrinsic_len_ (expr);
6446
6447    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
6448    subexpressions by constructing the appropriate tree for the
6449    length-of-character-text argument in a calling sequence.  */
6450
6451 static tree
6452 ffecom_intrinsic_len_ (ffebld expr)
6453 {
6454   ffetargetCharacter1 val;
6455   tree length;
6456
6457   switch (ffebld_op (expr))
6458     {
6459     case FFEBLD_opCONTER:
6460       val = ffebld_constant_character1 (ffebld_conter (expr));
6461       length = build_int_2 (ffetarget_length_character1 (val), 0);
6462       TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6463       break;
6464
6465     case FFEBLD_opSYMTER:
6466       {
6467         ffesymbol s = ffebld_symter (expr);
6468         tree item;
6469
6470         item = ffesymbol_hook (s).decl_tree;
6471         if (item == NULL_TREE)
6472           {
6473             s = ffecom_sym_transform_ (s);
6474             item = ffesymbol_hook (s).decl_tree;
6475           }
6476         if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
6477           {
6478             if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
6479               length = ffesymbol_hook (s).length_tree;
6480             else
6481               {
6482                 length = build_int_2 (ffesymbol_size (s), 0);
6483                 TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6484               }
6485           }
6486         else if (item == error_mark_node)
6487           length = error_mark_node;
6488         else                    /* FFEINFO_kindFUNCTION: */
6489           length = NULL_TREE;
6490       }
6491       break;
6492
6493     case FFEBLD_opARRAYREF:
6494       length = ffecom_intrinsic_len_ (ffebld_left (expr));
6495       break;
6496
6497     case FFEBLD_opSUBSTR:
6498       {
6499         ffebld start;
6500         ffebld end;
6501         ffebld thing = ffebld_right (expr);
6502         tree start_tree;
6503         tree end_tree;
6504
6505         assert (ffebld_op (thing) == FFEBLD_opITEM);
6506         start = ffebld_head (thing);
6507         thing = ffebld_trail (thing);
6508         assert (ffebld_trail (thing) == NULL);
6509         end = ffebld_head (thing);
6510
6511         length = ffecom_intrinsic_len_ (ffebld_left (expr));
6512
6513         if (length == error_mark_node)
6514           break;
6515
6516         if (start == NULL)
6517           {
6518             if (end == NULL)
6519               ;
6520             else
6521               {
6522                 length = convert (ffecom_f2c_ftnlen_type_node,
6523                                   ffecom_expr (end));
6524               }
6525           }
6526         else
6527           {
6528             start_tree = convert (ffecom_f2c_ftnlen_type_node,
6529                                   ffecom_expr (start));
6530
6531             if (start_tree == error_mark_node)
6532               {
6533                 length = error_mark_node;
6534                 break;
6535               }
6536
6537             if (end == NULL)
6538               {
6539                 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6540                                    ffecom_f2c_ftnlen_one_node,
6541                                    ffecom_2 (MINUS_EXPR,
6542                                              ffecom_f2c_ftnlen_type_node,
6543                                              length,
6544                                              start_tree));
6545               }
6546             else
6547               {
6548                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
6549                                     ffecom_expr (end));
6550
6551                 if (end_tree == error_mark_node)
6552                   {
6553                     length = error_mark_node;
6554                     break;
6555                   }
6556
6557                 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6558                                    ffecom_f2c_ftnlen_one_node,
6559                                    ffecom_2 (MINUS_EXPR,
6560                                              ffecom_f2c_ftnlen_type_node,
6561                                              end_tree, start_tree));
6562               }
6563           }
6564       }
6565       break;
6566
6567     case FFEBLD_opCONCATENATE:
6568       length
6569         = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6570                     ffecom_intrinsic_len_ (ffebld_left (expr)),
6571                     ffecom_intrinsic_len_ (ffebld_right (expr)));
6572       break;
6573
6574     case FFEBLD_opFUNCREF:
6575     case FFEBLD_opCONVERT:
6576       length = build_int_2 (ffebld_size (expr), 0);
6577       TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6578       break;
6579
6580     default:
6581       assert ("bad op for single char arg expr" == NULL);
6582       length = ffecom_f2c_ftnlen_zero_node;
6583       break;
6584     }
6585
6586   assert (length != NULL_TREE);
6587
6588   return length;
6589 }
6590
6591 /* Handle CHARACTER assignments.
6592
6593    Generates code to do the assignment.  Used by ordinary assignment
6594    statement handler ffecom_let_stmt and by statement-function
6595    handler to generate code for a statement function.  */
6596
6597 static void
6598 ffecom_let_char_ (tree dest_tree, tree dest_length,
6599                   ffetargetCharacterSize dest_size, ffebld source)
6600 {
6601   ffecomConcatList_ catlist;
6602   tree source_length;
6603   tree source_tree;
6604   tree expr_tree;
6605
6606   if ((dest_tree == error_mark_node)
6607       || (dest_length == error_mark_node))
6608     return;
6609
6610   assert (dest_tree != NULL_TREE);
6611   assert (dest_length != NULL_TREE);
6612
6613   /* Source might be an opCONVERT, which just means it is a different size
6614      than the destination.  Since the underlying implementation here handles
6615      that (directly or via the s_copy or s_cat run-time-library functions),
6616      we don't need the "convenience" of an opCONVERT that tells us to
6617      truncate or blank-pad, particularly since the resulting implementation
6618      would probably be slower than otherwise. */
6619
6620   while (ffebld_op (source) == FFEBLD_opCONVERT)
6621     source = ffebld_left (source);
6622
6623   catlist = ffecom_concat_list_new_ (source, dest_size);
6624   switch (ffecom_concat_list_count_ (catlist))
6625     {
6626     case 0:                     /* Shouldn't happen, but in case it does... */
6627       ffecom_concat_list_kill_ (catlist);
6628       source_tree = null_pointer_node;
6629       source_length = ffecom_f2c_ftnlen_zero_node;
6630       expr_tree = build_tree_list (NULL_TREE, dest_tree);
6631       TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6632       TREE_CHAIN (TREE_CHAIN (expr_tree))
6633         = build_tree_list (NULL_TREE, dest_length);
6634       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6635         = build_tree_list (NULL_TREE, source_length);
6636
6637       expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6638       TREE_SIDE_EFFECTS (expr_tree) = 1;
6639
6640       expand_expr_stmt (expr_tree);
6641
6642       return;
6643
6644     case 1:                     /* The (fairly) easy case. */
6645       ffecom_char_args_ (&source_tree, &source_length,
6646                          ffecom_concat_list_expr_ (catlist, 0));
6647       ffecom_concat_list_kill_ (catlist);
6648       assert (source_tree != NULL_TREE);
6649       assert (source_length != NULL_TREE);
6650
6651       if ((source_tree == error_mark_node)
6652           || (source_length == error_mark_node))
6653         return;
6654
6655       if (dest_size == 1)
6656         {
6657           dest_tree
6658             = ffecom_1 (INDIRECT_REF,
6659                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6660                                                       (dest_tree))),
6661                         dest_tree);
6662           dest_tree
6663             = ffecom_2 (ARRAY_REF,
6664                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6665                                                       (dest_tree))),
6666                         dest_tree,
6667                         integer_one_node);
6668           source_tree
6669             = ffecom_1 (INDIRECT_REF,
6670                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6671                                                       (source_tree))),
6672                         source_tree);
6673           source_tree
6674             = ffecom_2 (ARRAY_REF,
6675                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6676                                                       (source_tree))),
6677                         source_tree,
6678                         integer_one_node);
6679
6680           expr_tree = ffecom_modify (void_type_node, dest_tree, source_tree);
6681
6682           expand_expr_stmt (expr_tree);
6683
6684           return;
6685         }
6686
6687       expr_tree = build_tree_list (NULL_TREE, dest_tree);
6688       TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6689       TREE_CHAIN (TREE_CHAIN (expr_tree))
6690         = build_tree_list (NULL_TREE, dest_length);
6691       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6692         = build_tree_list (NULL_TREE, source_length);
6693
6694       expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6695       TREE_SIDE_EFFECTS (expr_tree) = 1;
6696
6697       expand_expr_stmt (expr_tree);
6698
6699       return;
6700
6701     default:                    /* Must actually concatenate things. */
6702       break;
6703     }
6704
6705   /* Heavy-duty concatenation. */
6706
6707   {
6708     int count = ffecom_concat_list_count_ (catlist);
6709     int i;
6710     tree lengths;
6711     tree items;
6712     tree length_array;
6713     tree item_array;
6714     tree citem;
6715     tree clength;
6716
6717 #ifdef HOHO
6718     length_array
6719       = lengths
6720       = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
6721                              FFETARGET_charactersizeNONE, count, TRUE);
6722     item_array = items = ffecom_push_tempvar (ffecom_f2c_address_type_node,
6723                                               FFETARGET_charactersizeNONE,
6724                                               count, TRUE);
6725 #else
6726     {
6727       tree hook;
6728
6729       hook = ffebld_nonter_hook (source);
6730       assert (hook);
6731       assert (TREE_CODE (hook) == TREE_VEC);
6732       assert (TREE_VEC_LENGTH (hook) == 2);
6733       length_array = lengths = TREE_VEC_ELT (hook, 0);
6734       item_array = items = TREE_VEC_ELT (hook, 1);
6735     }
6736 #endif
6737
6738     for (i = 0; i < count; ++i)
6739       {
6740         ffecom_char_args_ (&citem, &clength,
6741                            ffecom_concat_list_expr_ (catlist, i));
6742         if ((citem == error_mark_node)
6743             || (clength == error_mark_node))
6744           {
6745             ffecom_concat_list_kill_ (catlist);
6746             return;
6747           }
6748
6749         items
6750           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
6751                       ffecom_modify (void_type_node,
6752                                      ffecom_2 (ARRAY_REF,
6753                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
6754                                                item_array,
6755                                                build_int_2 (i, 0)),
6756                                      citem),
6757                       items);
6758         lengths
6759           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
6760                       ffecom_modify (void_type_node,
6761                                      ffecom_2 (ARRAY_REF,
6762                    TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
6763                                                length_array,
6764                                                build_int_2 (i, 0)),
6765                                      clength),
6766                       lengths);
6767       }
6768
6769     expr_tree = build_tree_list (NULL_TREE, dest_tree);
6770     TREE_CHAIN (expr_tree)
6771       = build_tree_list (NULL_TREE,
6772                          ffecom_1 (ADDR_EXPR,
6773                                    build_pointer_type (TREE_TYPE (items)),
6774                                    items));
6775     TREE_CHAIN (TREE_CHAIN (expr_tree))
6776       = build_tree_list (NULL_TREE,
6777                          ffecom_1 (ADDR_EXPR,
6778                                    build_pointer_type (TREE_TYPE (lengths)),
6779                                    lengths));
6780     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6781       = build_tree_list
6782         (NULL_TREE,
6783          ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
6784                    convert (ffecom_f2c_ftnlen_type_node,
6785                             build_int_2 (count, 0))));
6786     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree))))
6787       = build_tree_list (NULL_TREE, dest_length);
6788
6789     expr_tree = ffecom_call_gfrt (FFECOM_gfrtCAT, expr_tree, NULL_TREE);
6790     TREE_SIDE_EFFECTS (expr_tree) = 1;
6791
6792     expand_expr_stmt (expr_tree);
6793   }
6794
6795   ffecom_concat_list_kill_ (catlist);
6796 }
6797
6798 /* ffecom_make_gfrt_ -- Make initial info for run-time routine
6799
6800    ffecomGfrt ix;
6801    ffecom_make_gfrt_(ix);
6802
6803    Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL
6804    for the indicated run-time routine (ix).  */
6805
6806 static void
6807 ffecom_make_gfrt_ (ffecomGfrt ix)
6808 {
6809   tree t;
6810   tree ttype;
6811
6812   switch (ffecom_gfrt_type_[ix])
6813     {
6814     case FFECOM_rttypeVOID_:
6815       ttype = void_type_node;
6816       break;
6817
6818     case FFECOM_rttypeVOIDSTAR_:
6819       ttype = TREE_TYPE (null_pointer_node);    /* `void *'. */
6820       break;
6821
6822     case FFECOM_rttypeFTNINT_:
6823       ttype = ffecom_f2c_ftnint_type_node;
6824       break;
6825
6826     case FFECOM_rttypeINTEGER_:
6827       ttype = ffecom_f2c_integer_type_node;
6828       break;
6829
6830     case FFECOM_rttypeLONGINT_:
6831       ttype = ffecom_f2c_longint_type_node;
6832       break;
6833
6834     case FFECOM_rttypeLOGICAL_:
6835       ttype = ffecom_f2c_logical_type_node;
6836       break;
6837
6838     case FFECOM_rttypeREAL_F2C_:
6839       ttype = double_type_node;
6840       break;
6841
6842     case FFECOM_rttypeREAL_GNU_:
6843       ttype = float_type_node;
6844       break;
6845
6846     case FFECOM_rttypeCOMPLEX_F2C_:
6847       ttype = void_type_node;
6848       break;
6849
6850     case FFECOM_rttypeCOMPLEX_GNU_:
6851       ttype = ffecom_f2c_complex_type_node;
6852       break;
6853
6854     case FFECOM_rttypeDOUBLE_:
6855       ttype = double_type_node;
6856       break;
6857
6858     case FFECOM_rttypeDOUBLEREAL_:
6859       ttype = ffecom_f2c_doublereal_type_node;
6860       break;
6861
6862     case FFECOM_rttypeDBLCMPLX_F2C_:
6863       ttype = void_type_node;
6864       break;
6865
6866     case FFECOM_rttypeDBLCMPLX_GNU_:
6867       ttype = ffecom_f2c_doublecomplex_type_node;
6868       break;
6869
6870     case FFECOM_rttypeCHARACTER_:
6871       ttype = void_type_node;
6872       break;
6873
6874     default:
6875       ttype = NULL;
6876       assert ("bad rttype" == NULL);
6877       break;
6878     }
6879
6880   ttype = build_function_type (ttype, NULL_TREE);
6881   t = build_decl (FUNCTION_DECL,
6882                   get_identifier (ffecom_gfrt_name_[ix]),
6883                   ttype);
6884   DECL_EXTERNAL (t) = 1;
6885   TREE_READONLY (t) = ffecom_gfrt_const_[ix] ? 1 : 0;
6886   TREE_PUBLIC (t) = 1;
6887   TREE_THIS_VOLATILE (t) = ffecom_gfrt_volatile_[ix] ? 1 : 0;
6888
6889   /* Sanity check:  A function that's const cannot be volatile.  */
6890
6891   assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_volatile_[ix] : 1);
6892
6893   /* Sanity check: A function that's const cannot return complex.  */
6894
6895   assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_complex_[ix] : 1);
6896
6897   t = start_decl (t, TRUE);
6898
6899   finish_decl (t, NULL_TREE, TRUE);
6900
6901   ffecom_gfrt_[ix] = t;
6902 }
6903
6904 /* Phase 1 pass over each member of a COMMON/EQUIVALENCE group.  */
6905
6906 static void
6907 ffecom_member_phase1_ (ffestorag mst UNUSED, ffestorag st)
6908 {
6909   ffesymbol s = ffestorag_symbol (st);
6910
6911   if (ffesymbol_namelisted (s))
6912     ffecom_member_namelisted_ = TRUE;
6913 }
6914
6915 /* Phase 2 pass over each member of a COMMON/EQUIVALENCE group.  Declare
6916    the member so debugger will see it.  Otherwise nobody should be
6917    referencing the member.  */
6918
6919 static void
6920 ffecom_member_phase2_ (ffestorag mst, ffestorag st)
6921 {
6922   ffesymbol s;
6923   tree t;
6924   tree mt;
6925   tree type;
6926
6927   if ((mst == NULL)
6928       || ((mt = ffestorag_hook (mst)) == NULL)
6929       || (mt == error_mark_node))
6930     return;
6931
6932   if ((st == NULL)
6933       || ((s = ffestorag_symbol (st)) == NULL))
6934     return;
6935
6936   type = ffecom_type_localvar_ (s,
6937                                 ffesymbol_basictype (s),
6938                                 ffesymbol_kindtype (s));
6939   if (type == error_mark_node)
6940     return;
6941
6942   t = build_decl (VAR_DECL,
6943                   ffecom_get_identifier_ (ffesymbol_text (s)),
6944                   type);
6945
6946   TREE_STATIC (t) = TREE_STATIC (mt);
6947   DECL_INITIAL (t) = NULL_TREE;
6948   TREE_ASM_WRITTEN (t) = 1;
6949   TREE_USED (t) = 1;
6950
6951   SET_DECL_RTL (t,
6952                 gen_rtx (MEM, TYPE_MODE (type),
6953                          plus_constant (XEXP (DECL_RTL (mt), 0),
6954                                         ffestorag_modulo (mst)
6955                                         + ffestorag_offset (st)
6956                                         - ffestorag_offset (mst))));
6957
6958   t = start_decl (t, FALSE);
6959
6960   finish_decl (t, NULL_TREE, FALSE);
6961 }
6962
6963 /* Prepare source expression for assignment into a destination perhaps known
6964    to be of a specific size.  */
6965
6966 static void
6967 ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size, ffebld source)
6968 {
6969   ffecomConcatList_ catlist;
6970   int count;
6971   int i;
6972   tree ltmp;
6973   tree itmp;
6974   tree tempvar = NULL_TREE;
6975
6976   while (ffebld_op (source) == FFEBLD_opCONVERT)
6977     source = ffebld_left (source);
6978
6979   catlist = ffecom_concat_list_new_ (source, dest_size);
6980   count = ffecom_concat_list_count_ (catlist);
6981
6982   if (count >= 2)
6983     {
6984       ltmp
6985         = ffecom_make_tempvar ("let_char_len", ffecom_f2c_ftnlen_type_node,
6986                                FFETARGET_charactersizeNONE, count);
6987       itmp
6988         = ffecom_make_tempvar ("let_char_item", ffecom_f2c_address_type_node,
6989                                FFETARGET_charactersizeNONE, count);
6990
6991       tempvar = make_tree_vec (2);
6992       TREE_VEC_ELT (tempvar, 0) = ltmp;
6993       TREE_VEC_ELT (tempvar, 1) = itmp;
6994     }
6995
6996   for (i = 0; i < count; ++i)
6997     ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist, i));
6998
6999   ffecom_concat_list_kill_ (catlist);
7000
7001   if (tempvar)
7002     {
7003       ffebld_nonter_set_hook (source, tempvar);
7004       current_binding_level->prep_state = 1;
7005     }
7006 }
7007
7008 /* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order
7009
7010    Ignores STAR (alternate-return) dummies.  All other get exec-transitioned
7011    (which generates their trees) and then their trees get push_parm_decl'd.
7012
7013    The second arg is TRUE if the dummies are for a statement function, in
7014    which case lengths are not pushed for character arguments (since they are
7015    always known by both the caller and the callee, though the code allows
7016    for someday permitting CHAR*(*) stmtfunc dummies).  */
7017
7018 static void
7019 ffecom_push_dummy_decls_ (ffebld dummy_list, bool stmtfunc)
7020 {
7021   ffebld dummy;
7022   ffebld dumlist;
7023   ffesymbol s;
7024   tree parm;
7025
7026   ffecom_transform_only_dummies_ = TRUE;
7027
7028   /* First push the parms corresponding to actual dummy "contents".  */
7029
7030   for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7031     {
7032       dummy = ffebld_head (dumlist);
7033       switch (ffebld_op (dummy))
7034         {
7035         case FFEBLD_opSTAR:
7036         case FFEBLD_opANY:
7037           continue;             /* Forget alternate returns. */
7038
7039         default:
7040           break;
7041         }
7042       assert (ffebld_op (dummy) == FFEBLD_opSYMTER);
7043       s = ffebld_symter (dummy);
7044       parm = ffesymbol_hook (s).decl_tree;
7045       if (parm == NULL_TREE)
7046         {
7047           s = ffecom_sym_transform_ (s);
7048           parm = ffesymbol_hook (s).decl_tree;
7049           assert (parm != NULL_TREE);
7050         }
7051       if (parm != error_mark_node)
7052         push_parm_decl (parm);
7053     }
7054
7055   /* Then, for CHARACTER dummies, push the parms giving their lengths.  */
7056
7057   for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7058     {
7059       dummy = ffebld_head (dumlist);
7060       switch (ffebld_op (dummy))
7061         {
7062         case FFEBLD_opSTAR:
7063         case FFEBLD_opANY:
7064           continue;             /* Forget alternate returns, they mean
7065                                    NOTHING! */
7066
7067         default:
7068           break;
7069         }
7070       s = ffebld_symter (dummy);
7071       if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
7072         continue;               /* Only looking for CHARACTER arguments. */
7073       if (stmtfunc && (ffesymbol_size (s) != FFETARGET_charactersizeNONE))
7074         continue;               /* Stmtfunc arg with known size needs no
7075                                    length param. */
7076       if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
7077         continue;               /* Only looking for variables and arrays. */
7078       parm = ffesymbol_hook (s).length_tree;
7079       assert (parm != NULL_TREE);
7080       if (parm != error_mark_node)
7081         push_parm_decl (parm);
7082     }
7083
7084   ffecom_transform_only_dummies_ = FALSE;
7085 }
7086
7087 /* ffecom_start_progunit_ -- Beginning of program unit
7088
7089    Does GNU back end stuff necessary to teach it about the start of its
7090    equivalent of a Fortran program unit.  */
7091
7092 static void
7093 ffecom_start_progunit_ ()
7094 {
7095   ffesymbol fn = ffecom_primary_entry_;
7096   ffebld arglist;
7097   tree id;                      /* Identifier (name) of function. */
7098   tree type;                    /* Type of function. */
7099   tree result;                  /* Result of function. */
7100   ffeinfoBasictype bt;
7101   ffeinfoKindtype kt;
7102   ffeglobal g;
7103   ffeglobalType gt;
7104   ffeglobalType egt = FFEGLOBAL_type;
7105   bool charfunc;
7106   bool cmplxfunc;
7107   bool altentries = (ffecom_num_entrypoints_ != 0);
7108   bool multi
7109   = altentries
7110   && (ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
7111   && (ffecom_master_bt_ == FFEINFO_basictypeNONE);
7112   bool main_program = FALSE;
7113   int old_lineno = lineno;
7114   const char *old_input_filename = input_filename;
7115
7116   assert (fn != NULL);
7117   assert (ffesymbol_hook (fn).decl_tree == NULL_TREE);
7118
7119   input_filename = ffesymbol_where_filename (fn);
7120   lineno = ffesymbol_where_filelinenum (fn);
7121
7122   switch (ffecom_primary_entry_kind_)
7123     {
7124     case FFEINFO_kindPROGRAM:
7125       main_program = TRUE;
7126       gt = FFEGLOBAL_typeMAIN;
7127       bt = FFEINFO_basictypeNONE;
7128       kt = FFEINFO_kindtypeNONE;
7129       type = ffecom_tree_fun_type_void;
7130       charfunc = FALSE;
7131       cmplxfunc = FALSE;
7132       break;
7133
7134     case FFEINFO_kindBLOCKDATA:
7135       gt = FFEGLOBAL_typeBDATA;
7136       bt = FFEINFO_basictypeNONE;
7137       kt = FFEINFO_kindtypeNONE;
7138       type = ffecom_tree_fun_type_void;
7139       charfunc = FALSE;
7140       cmplxfunc = FALSE;
7141       break;
7142
7143     case FFEINFO_kindFUNCTION:
7144       gt = FFEGLOBAL_typeFUNC;
7145       egt = FFEGLOBAL_typeEXT;
7146       bt = ffesymbol_basictype (fn);
7147       kt = ffesymbol_kindtype (fn);
7148       if (bt == FFEINFO_basictypeNONE)
7149         {
7150           ffeimplic_establish_symbol (fn);
7151           if (ffesymbol_funcresult (fn) != NULL)
7152             ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
7153           bt = ffesymbol_basictype (fn);
7154           kt = ffesymbol_kindtype (fn);
7155         }
7156
7157       if (multi)
7158         charfunc = cmplxfunc = FALSE;
7159       else if (bt == FFEINFO_basictypeCHARACTER)
7160         charfunc = TRUE, cmplxfunc = FALSE;
7161       else if ((bt == FFEINFO_basictypeCOMPLEX)
7162                && ffesymbol_is_f2c (fn)
7163                && !altentries)
7164         charfunc = FALSE, cmplxfunc = TRUE;
7165       else
7166         charfunc = cmplxfunc = FALSE;
7167
7168       if (multi || charfunc)
7169         type = ffecom_tree_fun_type_void;
7170       else if (ffesymbol_is_f2c (fn) && !altentries)
7171         type = ffecom_tree_fun_type[bt][kt];
7172       else
7173         type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
7174
7175       if ((type == NULL_TREE)
7176           || (TREE_TYPE (type) == NULL_TREE))
7177         type = ffecom_tree_fun_type_void;       /* _sym_exec_transition. */
7178       break;
7179
7180     case FFEINFO_kindSUBROUTINE:
7181       gt = FFEGLOBAL_typeSUBR;
7182       egt = FFEGLOBAL_typeEXT;
7183       bt = FFEINFO_basictypeNONE;
7184       kt = FFEINFO_kindtypeNONE;
7185       if (ffecom_is_altreturning_)
7186         type = ffecom_tree_subr_type;
7187       else
7188         type = ffecom_tree_fun_type_void;
7189       charfunc = FALSE;
7190       cmplxfunc = FALSE;
7191       break;
7192
7193     default:
7194       assert ("say what??" == NULL);
7195       /* Fall through. */
7196     case FFEINFO_kindANY:
7197       gt = FFEGLOBAL_typeANY;
7198       bt = FFEINFO_basictypeNONE;
7199       kt = FFEINFO_kindtypeNONE;
7200       type = error_mark_node;
7201       charfunc = FALSE;
7202       cmplxfunc = FALSE;
7203       break;
7204     }
7205
7206   if (altentries)
7207     {
7208       id = ffecom_get_invented_identifier ("__g77_masterfun_%s",
7209                                            ffesymbol_text (fn));
7210     }
7211 #if FFETARGET_isENFORCED_MAIN
7212   else if (main_program)
7213     id = get_identifier (FFETARGET_nameENFORCED_MAIN_NAME);
7214 #endif
7215   else
7216     id = ffecom_get_external_identifier_ (fn);
7217
7218   start_function (id,
7219                   type,
7220                   0,            /* nested/inline */
7221                   !altentries); /* TREE_PUBLIC */
7222
7223   TREE_USED (current_function_decl) = 1;        /* Avoid spurious warning if altentries. */
7224
7225   if (!altentries
7226       && ((g = ffesymbol_global (fn)) != NULL)
7227       && ((ffeglobal_type (g) == gt)
7228           || (ffeglobal_type (g) == egt)))
7229     {
7230       ffeglobal_set_hook (g, current_function_decl);
7231     }
7232
7233   /* Arg handling needs exec-transitioned ffesymbols to work with.  But
7234      exec-transitioning needs current_function_decl to be filled in.  So we
7235      do these things in two phases. */
7236
7237   if (altentries)
7238     {                           /* 1st arg identifies which entrypoint. */
7239       ffecom_which_entrypoint_decl_
7240         = build_decl (PARM_DECL,
7241                       ffecom_get_invented_identifier ("__g77_%s",
7242                                                       "which_entrypoint"),
7243                       integer_type_node);
7244       push_parm_decl (ffecom_which_entrypoint_decl_);
7245     }
7246
7247   if (charfunc
7248       || cmplxfunc
7249       || multi)
7250     {                           /* Arg for result (return value). */
7251       tree type;
7252       tree length;
7253
7254       if (charfunc)
7255         type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
7256       else if (cmplxfunc)
7257         type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
7258       else
7259         type = ffecom_multi_type_node_;
7260
7261       result = ffecom_get_invented_identifier ("__g77_%s", "result");
7262
7263       /* Make length arg _and_ enhance type info for CHAR arg itself.  */
7264
7265       if (charfunc)
7266         length = ffecom_char_enhance_arg_ (&type, fn);
7267       else
7268         length = NULL_TREE;     /* Not ref'd if !charfunc. */
7269
7270       type = build_pointer_type (type);
7271       result = build_decl (PARM_DECL, result, type);
7272
7273       push_parm_decl (result);
7274       if (multi)
7275         ffecom_multi_retval_ = result;
7276       else
7277         ffecom_func_result_ = result;
7278
7279       if (charfunc)
7280         {
7281           push_parm_decl (length);
7282           ffecom_func_length_ = length;
7283         }
7284     }
7285
7286   if (ffecom_primary_entry_is_proc_)
7287     {
7288       if (altentries)
7289         arglist = ffecom_master_arglist_;
7290       else
7291         arglist = ffesymbol_dummyargs (fn);
7292       ffecom_push_dummy_decls_ (arglist, FALSE);
7293     }
7294
7295   if (TREE_CODE (current_function_decl) != ERROR_MARK)
7296     store_parm_decls (main_program ? 1 : 0);
7297
7298   ffecom_start_compstmt ();
7299   /* Disallow temp vars at this level.  */
7300   current_binding_level->prep_state = 2;
7301
7302   lineno = old_lineno;
7303   input_filename = old_input_filename;
7304
7305   /* This handles any symbols still untransformed, in case -g specified.
7306      This used to be done in ffecom_finish_progunit, but it turns out to
7307      be necessary to do it here so that statement functions are
7308      expanded before code.  But don't bother for BLOCK DATA.  */
7309
7310   if (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
7311     ffesymbol_drive (ffecom_finish_symbol_transform_);
7312 }
7313
7314 /* ffecom_sym_transform_ -- Transform FFE sym into backend sym
7315
7316    ffesymbol s;
7317    ffecom_sym_transform_(s);
7318
7319    The ffesymbol_hook info for s is updated with appropriate backend info
7320    on the symbol.  */
7321
7322 static ffesymbol
7323 ffecom_sym_transform_ (ffesymbol s)
7324 {
7325   tree t;                       /* Transformed thingy. */
7326   tree tlen;                    /* Length if CHAR*(*). */
7327   bool addr;                    /* Is t the address of the thingy? */
7328   ffeinfoBasictype bt;
7329   ffeinfoKindtype kt;
7330   ffeglobal g;
7331   int old_lineno = lineno;
7332   const char *old_input_filename = input_filename;
7333
7334   /* Must ensure special ASSIGN variables are declared at top of outermost
7335      block, else they'll end up in the innermost block when their first
7336      ASSIGN is seen, which leaves them out of scope when they're the
7337      subject of a GOTO or I/O statement.
7338
7339      We make this variable even if -fugly-assign.  Just let it go unused,
7340      in case it turns out there are cases where we really want to use this
7341      variable anyway (e.g. ASSIGN to INTEGER*2 variable).  */
7342
7343   if (! ffecom_transform_only_dummies_
7344       && ffesymbol_assigned (s)
7345       && ! ffesymbol_hook (s).assign_tree)
7346     s = ffecom_sym_transform_assign_ (s);
7347
7348   if (ffesymbol_sfdummyparent (s) == NULL)
7349     {
7350       input_filename = ffesymbol_where_filename (s);
7351       lineno = ffesymbol_where_filelinenum (s);
7352     }
7353   else
7354     {
7355       ffesymbol sf = ffesymbol_sfdummyparent (s);
7356
7357       input_filename = ffesymbol_where_filename (sf);
7358       lineno = ffesymbol_where_filelinenum (sf);
7359     }
7360
7361   bt = ffeinfo_basictype (ffebld_info (s));
7362   kt = ffeinfo_kindtype (ffebld_info (s));
7363
7364   t = NULL_TREE;
7365   tlen = NULL_TREE;
7366   addr = FALSE;
7367
7368   switch (ffesymbol_kind (s))
7369     {
7370     case FFEINFO_kindNONE:
7371       switch (ffesymbol_where (s))
7372         {
7373         case FFEINFO_whereDUMMY:        /* Subroutine or function. */
7374           assert (ffecom_transform_only_dummies_);
7375
7376           /* Before 0.4, this could be ENTITY/DUMMY, but see
7377              ffestu_sym_end_transition -- no longer true (in particular, if
7378              it could be an ENTITY, it _will_ be made one, so that
7379              possibility won't come through here).  So we never make length
7380              arg for CHARACTER type.  */
7381
7382           t = build_decl (PARM_DECL,
7383                           ffecom_get_identifier_ (ffesymbol_text (s)),
7384                           ffecom_tree_ptr_to_subr_type);
7385           DECL_ARTIFICIAL (t) = 1;
7386           addr = TRUE;
7387           break;
7388
7389         case FFEINFO_whereGLOBAL:       /* Subroutine or function. */
7390           assert (!ffecom_transform_only_dummies_);
7391
7392           if (((g = ffesymbol_global (s)) != NULL)
7393               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7394                   || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7395                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
7396               && (ffeglobal_hook (g) != NULL_TREE)
7397               && ffe_is_globals ())
7398             {
7399               t = ffeglobal_hook (g);
7400               break;
7401             }
7402
7403           t = build_decl (FUNCTION_DECL,
7404                           ffecom_get_external_identifier_ (s),
7405                           ffecom_tree_subr_type);       /* Assume subr. */
7406           DECL_EXTERNAL (t) = 1;
7407           TREE_PUBLIC (t) = 1;
7408
7409           t = start_decl (t, FALSE);
7410           finish_decl (t, NULL_TREE, FALSE);
7411
7412           if ((g != NULL)
7413               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7414                   || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7415                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
7416             ffeglobal_set_hook (g, t);
7417
7418           ffecom_save_tree_forever (t);
7419
7420           break;
7421
7422         default:
7423           assert ("NONE where unexpected" == NULL);
7424           /* Fall through. */
7425         case FFEINFO_whereANY:
7426           break;
7427         }
7428       break;
7429
7430     case FFEINFO_kindENTITY:
7431       switch (ffeinfo_where (ffesymbol_info (s)))
7432         {
7433
7434         case FFEINFO_whereCONSTANT:
7435           /* ~~Debugging info needed? */
7436           assert (!ffecom_transform_only_dummies_);
7437           t = error_mark_node;  /* Shouldn't ever see this in expr. */
7438           break;
7439
7440         case FFEINFO_whereLOCAL:
7441           assert (!ffecom_transform_only_dummies_);
7442
7443           {
7444             ffestorag st = ffesymbol_storage (s);
7445             tree type;
7446
7447             if ((st != NULL)
7448                 && (ffestorag_size (st) == 0))
7449               {
7450                 t = error_mark_node;
7451                 break;
7452               }
7453
7454             type = ffecom_type_localvar_ (s, bt, kt);
7455
7456             if (type == error_mark_node)
7457               {
7458                 t = error_mark_node;
7459                 break;
7460               }
7461
7462             if ((st != NULL)
7463                 && (ffestorag_parent (st) != NULL))
7464               {                 /* Child of EQUIVALENCE parent. */
7465                 ffestorag est;
7466                 tree et;
7467                 ffetargetOffset offset;
7468
7469                 est = ffestorag_parent (st);
7470                 ffecom_transform_equiv_ (est);
7471
7472                 et = ffestorag_hook (est);
7473                 assert (et != NULL_TREE);
7474
7475                 if (! TREE_STATIC (et))
7476                   put_var_into_stack (et);
7477
7478                 offset = ffestorag_modulo (est)
7479                   + ffestorag_offset (ffesymbol_storage (s))
7480                   - ffestorag_offset (est);
7481
7482                 ffecom_debug_kludge_ (et, "EQUIVALENCE", s, type, offset);
7483
7484                 /* (t_type *) (((char *) &et) + offset) */
7485
7486                 t = convert (string_type_node,  /* (char *) */
7487                              ffecom_1 (ADDR_EXPR,
7488                                        build_pointer_type (TREE_TYPE (et)),
7489                                        et));
7490                 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
7491                               t,
7492                               build_int_2 (offset, 0));
7493                 t = convert (build_pointer_type (type),
7494                              t);
7495                 TREE_CONSTANT (t) = staticp (et);
7496
7497                 addr = TRUE;
7498               }
7499             else
7500               {
7501                 tree initexpr;
7502                 bool init = ffesymbol_is_init (s);
7503
7504                 t = build_decl (VAR_DECL,
7505                                 ffecom_get_identifier_ (ffesymbol_text (s)),
7506                                 type);
7507
7508                 if (init
7509                     || ffesymbol_namelisted (s)
7510 #ifdef FFECOM_sizeMAXSTACKITEM
7511                     || ((st != NULL)
7512                         && (ffestorag_size (st) > FFECOM_sizeMAXSTACKITEM))
7513 #endif
7514                     || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
7515                         && (ffecom_primary_entry_kind_
7516                             != FFEINFO_kindBLOCKDATA)
7517                         && (ffesymbol_is_save (s) || ffe_is_saveall ())))
7518                   TREE_STATIC (t) = !ffesymbol_attr (s, FFESYMBOL_attrADJUSTABLE);
7519                 else
7520                   TREE_STATIC (t) = 0;  /* No need to make static. */
7521
7522                 if (init || ffe_is_init_local_zero ())
7523                   DECL_INITIAL (t) = error_mark_node;
7524
7525                 /* Keep -Wunused from complaining about var if it
7526                    is used as sfunc arg or DATA implied-DO.  */
7527                 if (ffesymbol_attrs (s) & FFESYMBOL_attrsSFARG)
7528                   DECL_IN_SYSTEM_HEADER (t) = 1;
7529
7530                 t = start_decl (t, FALSE);
7531
7532                 if (init)
7533                   {
7534                     if (ffesymbol_init (s) != NULL)
7535                       initexpr = ffecom_expr (ffesymbol_init (s));
7536                     else
7537                       initexpr = ffecom_init_zero_ (t);
7538                   }
7539                 else if (ffe_is_init_local_zero ())
7540                   initexpr = ffecom_init_zero_ (t);
7541                 else
7542                   initexpr = NULL_TREE; /* Not ref'd if !init. */
7543
7544                 finish_decl (t, initexpr, FALSE);
7545
7546                 if (st != NULL && DECL_SIZE (t) != error_mark_node)
7547                   {
7548                     assert (TREE_CODE (DECL_SIZE_UNIT (t)) == INTEGER_CST);
7549                     assert (0 == compare_tree_int (DECL_SIZE_UNIT (t),
7550                                                    ffestorag_size (st)));
7551                   }
7552               }
7553           }
7554           break;
7555
7556         case FFEINFO_whereRESULT:
7557           assert (!ffecom_transform_only_dummies_);
7558
7559           if (bt == FFEINFO_basictypeCHARACTER)
7560             {                   /* Result is already in list of dummies, use
7561                                    it (& length). */
7562               t = ffecom_func_result_;
7563               tlen = ffecom_func_length_;
7564               addr = TRUE;
7565               break;
7566             }
7567           if ((ffecom_num_entrypoints_ == 0)
7568               && (bt == FFEINFO_basictypeCOMPLEX)
7569               && (ffesymbol_is_f2c (ffecom_primary_entry_)))
7570             {                   /* Result is already in list of dummies, use
7571                                    it. */
7572               t = ffecom_func_result_;
7573               addr = TRUE;
7574               break;
7575             }
7576           if (ffecom_func_result_ != NULL_TREE)
7577             {
7578               t = ffecom_func_result_;
7579               break;
7580             }
7581           if ((ffecom_num_entrypoints_ != 0)
7582               && (ffecom_master_bt_ == FFEINFO_basictypeNONE))
7583             {
7584               assert (ffecom_multi_retval_ != NULL_TREE);
7585               t = ffecom_1 (INDIRECT_REF, ffecom_multi_type_node_,
7586                             ffecom_multi_retval_);
7587               t = ffecom_2 (COMPONENT_REF, ffecom_tree_type[bt][kt],
7588                             t, ffecom_multi_fields_[bt][kt]);
7589
7590               break;
7591             }
7592
7593           t = build_decl (VAR_DECL,
7594                           ffecom_get_identifier_ (ffesymbol_text (s)),
7595                           ffecom_tree_type[bt][kt]);
7596           TREE_STATIC (t) = 0;  /* Put result on stack. */
7597           t = start_decl (t, FALSE);
7598           finish_decl (t, NULL_TREE, FALSE);
7599
7600           ffecom_func_result_ = t;
7601
7602           break;
7603
7604         case FFEINFO_whereDUMMY:
7605           {
7606             tree type;
7607             ffebld dl;
7608             ffebld dim;
7609             tree low;
7610             tree high;
7611             tree old_sizes;
7612             bool adjustable = FALSE;    /* Conditionally adjustable? */
7613
7614             type = ffecom_tree_type[bt][kt];
7615             if (ffesymbol_sfdummyparent (s) != NULL)
7616               {
7617                 if (current_function_decl == ffecom_outer_function_decl_)
7618                   {                     /* Exec transition before sfunc
7619                                            context; get it later. */
7620                     break;
7621                   }
7622                 t = ffecom_get_identifier_ (ffesymbol_text
7623                                             (ffesymbol_sfdummyparent (s)));
7624               }
7625             else
7626               t = ffecom_get_identifier_ (ffesymbol_text (s));
7627
7628             assert (ffecom_transform_only_dummies_);
7629
7630             old_sizes = get_pending_sizes ();
7631             put_pending_sizes (old_sizes);
7632
7633             if (bt == FFEINFO_basictypeCHARACTER)
7634               tlen = ffecom_char_enhance_arg_ (&type, s);
7635             type = ffecom_check_size_overflow_ (s, type, TRUE);
7636
7637             for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
7638               {
7639                 if (type == error_mark_node)
7640                   break;
7641
7642                 dim = ffebld_head (dl);
7643                 assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
7644                 if ((ffebld_left (dim) == NULL) || ffecom_doing_entry_)
7645                   low = ffecom_integer_one_node;
7646                 else
7647                   low = ffecom_expr (ffebld_left (dim));
7648                 assert (ffebld_right (dim) != NULL);
7649                 if ((ffebld_op (ffebld_right (dim)) == FFEBLD_opSTAR)
7650                     || ffecom_doing_entry_)
7651                   {
7652                     /* Used to just do high=low.  But for ffecom_tree_
7653                        canonize_ref_, it probably is important to correctly
7654                        assess the size.  E.g. given COMPLEX C(*),CFUNC and
7655                        C(2)=CFUNC(C), overlap can happen, while it can't
7656                        for, say, C(1)=CFUNC(C(2)).  */
7657                     /* Even more recently used to set to INT_MAX, but that
7658                        broke when some overflow checking went into the back
7659                        end.  Now we just leave the upper bound unspecified.  */
7660                     high = NULL;
7661                   }
7662                 else
7663                   high = ffecom_expr (ffebld_right (dim));
7664
7665                 /* Determine whether array is conditionally adjustable,
7666                    to decide whether back-end magic is needed.
7667
7668                    Normally the front end uses the back-end function
7669                    variable_size to wrap SAVE_EXPR's around expressions
7670                    affecting the size/shape of an array so that the
7671                    size/shape info doesn't change during execution
7672                    of the compiled code even though variables and
7673                    functions referenced in those expressions might.
7674
7675                    variable_size also makes sure those saved expressions
7676                    get evaluated immediately upon entry to the
7677                    compiled procedure -- the front end normally doesn't
7678                    have to worry about that.
7679
7680                    However, there is a problem with this that affects
7681                    g77's implementation of entry points, and that is
7682                    that it is _not_ true that each invocation of the
7683                    compiled procedure is permitted to evaluate
7684                    array size/shape info -- because it is possible
7685                    that, for some invocations, that info is invalid (in
7686                    which case it is "promised" -- i.e. a violation of
7687                    the Fortran standard -- that the compiled code
7688                    won't reference the array or its size/shape
7689                    during that particular invocation).
7690
7691                    To phrase this in C terms, consider this gcc function:
7692
7693                      void foo (int *n, float (*a)[*n])
7694                      {
7695                        // a is "pointer to array ...", fyi.
7696                      }
7697
7698                    Suppose that, for some invocations, it is permitted
7699                    for a caller of foo to do this:
7700
7701                        foo (NULL, NULL);
7702
7703                    Now the _written_ code for foo can take such a call
7704                    into account by either testing explicitly for whether
7705                    (a == NULL) || (n == NULL) -- presumably it is
7706                    not permitted to reference *a in various fashions
7707                    if (n == NULL) I suppose -- or it can avoid it by
7708                    looking at other info (other arguments, static/global
7709                    data, etc.).
7710
7711                    However, this won't work in gcc 2.5.8 because it'll
7712                    automatically emit the code to save the "*n"
7713                    expression, which'll yield a NULL dereference for
7714                    the "foo (NULL, NULL)" call, something the code
7715                    for foo cannot prevent.
7716
7717                    g77 definitely needs to avoid executing such
7718                    code anytime the pointer to the adjustable array
7719                    is NULL, because even if its bounds expressions
7720                    don't have any references to possible "absent"
7721                    variables like "*n" -- say all variable references
7722                    are to COMMON variables, i.e. global (though in C,
7723                    local static could actually make sense) -- the
7724                    expressions could yield other run-time problems
7725                    for allowably "dead" values in those variables.
7726
7727                    For example, let's consider a more complicated
7728                    version of foo:
7729
7730                      extern int i;
7731                      extern int j;
7732
7733                      void foo (float (*a)[i/j])
7734                      {
7735                        ...
7736                      }
7737
7738                    The above is (essentially) quite valid for Fortran
7739                    but, again, for a call like "foo (NULL);", it is
7740                    permitted for i and j to be undefined when the
7741                    call is made.  If j happened to be zero, for
7742                    example, emitting the code to evaluate "i/j"
7743                    could result in a run-time error.
7744
7745                    Offhand, though I don't have my F77 or F90
7746                    standards handy, it might even be valid for a
7747                    bounds expression to contain a function reference,
7748                    in which case I doubt it is permitted for an
7749                    implementation to invoke that function in the
7750                    Fortran case involved here (invocation of an
7751                    alternate ENTRY point that doesn't have the adjustable
7752                    array as one of its arguments).
7753
7754                    So, the code that the compiler would normally emit
7755                    to preevaluate the size/shape info for an
7756                    adjustable array _must not_ be executed at run time
7757                    in certain cases.  Specifically, for Fortran,
7758                    the case is when the pointer to the adjustable
7759                    array == NULL.  (For gnu-ish C, it might be nice
7760                    for the source code itself to specify an expression
7761                    that, if TRUE, inhibits execution of the code.  Or
7762                    reverse the sense for elegance.)
7763
7764                    (Note that g77 could use a different test than NULL,
7765                    actually, since it happens to always pass an
7766                    integer to the called function that specifies which
7767                    entry point is being invoked.  Hmm, this might
7768                    solve the next problem.)
7769
7770                    One way a user could, I suppose, write "foo" so
7771                    it works is to insert COND_EXPR's for the
7772                    size/shape info so the dangerous stuff isn't
7773                    actually done, as in:
7774
7775                      void foo (int *n, float (*a)[(a == NULL) ? 0 : *n])
7776                      {
7777                        ...
7778                      }
7779
7780                    The next problem is that the front end needs to
7781                    be able to tell the back end about the array's
7782                    decl _before_ it tells it about the conditional
7783                    expression to inhibit evaluation of size/shape info,
7784                    as shown above.
7785
7786                    To solve this, the front end needs to be able
7787                    to give the back end the expression to inhibit
7788                    generation of the preevaluation code _after_
7789                    it makes the decl for the adjustable array.
7790
7791                    Until then, the above example using the COND_EXPR
7792                    doesn't pass muster with gcc because the "(a == NULL)"
7793                    part has a reference to "a", which is still
7794                    undefined at that point.
7795
7796                    g77 will therefore use a different mechanism in the
7797                    meantime.  */
7798
7799                 if (!adjustable
7800                     && ((TREE_CODE (low) != INTEGER_CST)
7801                         || (high && TREE_CODE (high) != INTEGER_CST)))
7802                   adjustable = TRUE;
7803
7804 #if 0                           /* Old approach -- see below. */
7805                 if (TREE_CODE (low) != INTEGER_CST)
7806                   low = ffecom_3 (COND_EXPR, integer_type_node,
7807                                   ffecom_adjarray_passed_ (s),
7808                                   low,
7809                                   ffecom_integer_zero_node);
7810
7811                 if (high && TREE_CODE (high) != INTEGER_CST)
7812                   high = ffecom_3 (COND_EXPR, integer_type_node,
7813                                    ffecom_adjarray_passed_ (s),
7814                                    high,
7815                                    ffecom_integer_zero_node);
7816 #endif
7817
7818                 /* ~~~gcc/stor-layout.c (layout_type) should do this,
7819                    probably.  Fixes 950302-1.f.  */
7820
7821                 if (TREE_CODE (low) != INTEGER_CST)
7822                   low = variable_size (low);
7823
7824                 /* ~~~Similarly, this fixes dumb0.f.  The C front end
7825                    does this, which is why dumb0.c would work.  */
7826
7827                 if (high && TREE_CODE (high) != INTEGER_CST)
7828                   high = variable_size (high);
7829
7830                 type
7831                   = build_array_type
7832                     (type,
7833                      build_range_type (ffecom_integer_type_node,
7834                                        low, high));
7835                 type = ffecom_check_size_overflow_ (s, type, TRUE);
7836               }
7837
7838             if (type == error_mark_node)
7839               {
7840                 t = error_mark_node;
7841                 break;
7842               }
7843
7844             if ((ffesymbol_sfdummyparent (s) == NULL)
7845                  || (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER))
7846               {
7847                 type = build_pointer_type (type);
7848                 addr = TRUE;
7849               }
7850
7851             t = build_decl (PARM_DECL, t, type);
7852             DECL_ARTIFICIAL (t) = 1;
7853
7854             /* If this arg is present in every entry point's list of
7855                dummy args, then we're done.  */
7856
7857             if (ffesymbol_numentries (s)
7858                 == (ffecom_num_entrypoints_ + 1))
7859               break;
7860
7861 #if 1
7862
7863             /* If variable_size in stor-layout has been called during
7864                the above, then get_pending_sizes should have the
7865                yet-to-be-evaluated saved expressions pending.
7866                Make the whole lot of them get emitted, conditionally
7867                on whether the array decl ("t" above) is not NULL.  */
7868
7869             {
7870               tree sizes = get_pending_sizes ();
7871               tree tem;
7872
7873               for (tem = sizes;
7874                    tem != old_sizes;
7875                    tem = TREE_CHAIN (tem))
7876                 {
7877                   tree temv = TREE_VALUE (tem);
7878
7879                   if (sizes == tem)
7880                     sizes = temv;
7881                   else
7882                     sizes
7883                       = ffecom_2 (COMPOUND_EXPR,
7884                                   TREE_TYPE (sizes),
7885                                   temv,
7886                                   sizes);
7887                 }
7888
7889               if (sizes != tem)
7890                 {
7891                   sizes
7892                     = ffecom_3 (COND_EXPR,
7893                                 TREE_TYPE (sizes),
7894                                 ffecom_2 (NE_EXPR,
7895                                           integer_type_node,
7896                                           t,
7897                                           null_pointer_node),
7898                                 sizes,
7899                                 convert (TREE_TYPE (sizes),
7900                                          integer_zero_node));
7901                   sizes = ffecom_save_tree (sizes);
7902
7903                   sizes
7904                     = tree_cons (NULL_TREE, sizes, tem);
7905                 }
7906
7907               if (sizes)
7908                 put_pending_sizes (sizes);
7909             }
7910
7911 #else
7912 #if 0
7913             if (adjustable
7914                 && (ffesymbol_numentries (s)
7915                     != ffecom_num_entrypoints_ + 1))
7916               DECL_SOMETHING (t)
7917                 = ffecom_2 (NE_EXPR, integer_type_node,
7918                             t,
7919                             null_pointer_node);
7920 #else
7921 #if 0
7922             if (adjustable
7923                 && (ffesymbol_numentries (s)
7924                     != ffecom_num_entrypoints_ + 1))
7925               {
7926                 ffebad_start (FFEBAD_MISSING_ADJARRAY_UNSUPPORTED);
7927                 ffebad_here (0, ffesymbol_where_line (s),
7928                              ffesymbol_where_column (s));
7929                 ffebad_string (ffesymbol_text (s));
7930                 ffebad_finish ();
7931               }
7932 #endif
7933 #endif
7934 #endif
7935           }
7936           break;
7937
7938         case FFEINFO_whereCOMMON:
7939           {
7940             ffesymbol cs;
7941             ffeglobal cg;
7942             tree ct;
7943             ffestorag st = ffesymbol_storage (s);
7944             tree type;
7945
7946             cs = ffesymbol_common (s);  /* The COMMON area itself.  */
7947             if (st != NULL)     /* Else not laid out. */
7948               {
7949                 ffecom_transform_common_ (cs);
7950                 st = ffesymbol_storage (s);
7951               }
7952
7953             type = ffecom_type_localvar_ (s, bt, kt);
7954
7955             cg = ffesymbol_global (cs); /* The global COMMON info.  */
7956             if ((cg == NULL)
7957                 || (ffeglobal_type (cg) != FFEGLOBAL_typeCOMMON))
7958               ct = NULL_TREE;
7959             else
7960               ct = ffeglobal_hook (cg); /* The common area's tree.  */
7961
7962             if ((ct == NULL_TREE)
7963                 || (st == NULL)
7964                 || (type == error_mark_node))
7965               t = error_mark_node;
7966             else
7967               {
7968                 ffetargetOffset offset;
7969                 ffestorag cst;
7970
7971                 cst = ffestorag_parent (st);
7972                 assert (cst == ffesymbol_storage (cs));
7973
7974                 offset = ffestorag_modulo (cst)
7975                   + ffestorag_offset (st)
7976                   - ffestorag_offset (cst);
7977
7978                 ffecom_debug_kludge_ (ct, "COMMON", s, type, offset);
7979
7980                 /* (t_type *) (((char *) &ct) + offset) */
7981
7982                 t = convert (string_type_node,  /* (char *) */
7983                              ffecom_1 (ADDR_EXPR,
7984                                        build_pointer_type (TREE_TYPE (ct)),
7985                                        ct));
7986                 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
7987                               t,
7988                               build_int_2 (offset, 0));
7989                 t = convert (build_pointer_type (type),
7990                              t);
7991                 TREE_CONSTANT (t) = 1;
7992
7993                 addr = TRUE;
7994               }
7995           }
7996           break;
7997
7998         case FFEINFO_whereIMMEDIATE:
7999         case FFEINFO_whereGLOBAL:
8000         case FFEINFO_whereFLEETING:
8001         case FFEINFO_whereFLEETING_CADDR:
8002         case FFEINFO_whereFLEETING_IADDR:
8003         case FFEINFO_whereINTRINSIC:
8004         case FFEINFO_whereCONSTANT_SUBOBJECT:
8005         default:
8006           assert ("ENTITY where unheard of" == NULL);
8007           /* Fall through. */
8008         case FFEINFO_whereANY:
8009           t = error_mark_node;
8010           break;
8011         }
8012       break;
8013
8014     case FFEINFO_kindFUNCTION:
8015       switch (ffeinfo_where (ffesymbol_info (s)))
8016         {
8017         case FFEINFO_whereLOCAL:        /* Me. */
8018           assert (!ffecom_transform_only_dummies_);
8019           t = current_function_decl;
8020           break;
8021
8022         case FFEINFO_whereGLOBAL:
8023           assert (!ffecom_transform_only_dummies_);
8024
8025           if (((g = ffesymbol_global (s)) != NULL)
8026               && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8027                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8028               && (ffeglobal_hook (g) != NULL_TREE)
8029               && ffe_is_globals ())
8030             {
8031               t = ffeglobal_hook (g);
8032               break;
8033             }
8034
8035           if (ffesymbol_is_f2c (s)
8036               && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8037             t = ffecom_tree_fun_type[bt][kt];
8038           else
8039             t = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
8040
8041           t = build_decl (FUNCTION_DECL,
8042                           ffecom_get_external_identifier_ (s),
8043                           t);
8044           DECL_EXTERNAL (t) = 1;
8045           TREE_PUBLIC (t) = 1;
8046
8047           t = start_decl (t, FALSE);
8048           finish_decl (t, NULL_TREE, FALSE);
8049
8050           if ((g != NULL)
8051               && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8052                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8053             ffeglobal_set_hook (g, t);
8054
8055           ffecom_save_tree_forever (t);
8056
8057           break;
8058
8059         case FFEINFO_whereDUMMY:
8060           assert (ffecom_transform_only_dummies_);
8061
8062           if (ffesymbol_is_f2c (s)
8063               && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8064             t = ffecom_tree_ptr_to_fun_type[bt][kt];
8065           else
8066             t = build_pointer_type
8067               (build_function_type (ffecom_tree_type[bt][kt], NULL_TREE));
8068
8069           t = build_decl (PARM_DECL,
8070                           ffecom_get_identifier_ (ffesymbol_text (s)),
8071                           t);
8072           DECL_ARTIFICIAL (t) = 1;
8073           addr = TRUE;
8074           break;
8075
8076         case FFEINFO_whereCONSTANT:     /* Statement function. */
8077           assert (!ffecom_transform_only_dummies_);
8078           t = ffecom_gen_sfuncdef_ (s, bt, kt);
8079           break;
8080
8081         case FFEINFO_whereINTRINSIC:
8082           assert (!ffecom_transform_only_dummies_);
8083           break;                /* Let actual references generate their
8084                                    decls. */
8085
8086         default:
8087           assert ("FUNCTION where unheard of" == NULL);
8088           /* Fall through. */
8089         case FFEINFO_whereANY:
8090           t = error_mark_node;
8091           break;
8092         }
8093       break;
8094
8095     case FFEINFO_kindSUBROUTINE:
8096       switch (ffeinfo_where (ffesymbol_info (s)))
8097         {
8098         case FFEINFO_whereLOCAL:        /* Me. */
8099           assert (!ffecom_transform_only_dummies_);
8100           t = current_function_decl;
8101           break;
8102
8103         case FFEINFO_whereGLOBAL:
8104           assert (!ffecom_transform_only_dummies_);
8105
8106           if (((g = ffesymbol_global (s)) != NULL)
8107               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8108                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8109               && (ffeglobal_hook (g) != NULL_TREE)
8110               && ffe_is_globals ())
8111             {
8112               t = ffeglobal_hook (g);
8113               break;
8114             }
8115
8116           t = build_decl (FUNCTION_DECL,
8117                           ffecom_get_external_identifier_ (s),
8118                           ffecom_tree_subr_type);
8119           DECL_EXTERNAL (t) = 1;
8120           TREE_PUBLIC (t) = 1;
8121
8122           t = start_decl (t, FALSE);
8123           finish_decl (t, NULL_TREE, FALSE);
8124
8125           if ((g != NULL)
8126               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8127                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8128             ffeglobal_set_hook (g, t);
8129
8130           ffecom_save_tree_forever (t);
8131
8132           break;
8133
8134         case FFEINFO_whereDUMMY:
8135           assert (ffecom_transform_only_dummies_);
8136
8137           t = build_decl (PARM_DECL,
8138                           ffecom_get_identifier_ (ffesymbol_text (s)),
8139                           ffecom_tree_ptr_to_subr_type);
8140           DECL_ARTIFICIAL (t) = 1;
8141           addr = TRUE;
8142           break;
8143
8144         case FFEINFO_whereINTRINSIC:
8145           assert (!ffecom_transform_only_dummies_);
8146           break;                /* Let actual references generate their
8147                                    decls. */
8148
8149         default:
8150           assert ("SUBROUTINE where unheard of" == NULL);
8151           /* Fall through. */
8152         case FFEINFO_whereANY:
8153           t = error_mark_node;
8154           break;
8155         }
8156       break;
8157
8158     case FFEINFO_kindPROGRAM:
8159       switch (ffeinfo_where (ffesymbol_info (s)))
8160         {
8161         case FFEINFO_whereLOCAL:        /* Me. */
8162           assert (!ffecom_transform_only_dummies_);
8163           t = current_function_decl;
8164           break;
8165
8166         case FFEINFO_whereCOMMON:
8167         case FFEINFO_whereDUMMY:
8168         case FFEINFO_whereGLOBAL:
8169         case FFEINFO_whereRESULT:
8170         case FFEINFO_whereFLEETING:
8171         case FFEINFO_whereFLEETING_CADDR:
8172         case FFEINFO_whereFLEETING_IADDR:
8173         case FFEINFO_whereIMMEDIATE:
8174         case FFEINFO_whereINTRINSIC:
8175         case FFEINFO_whereCONSTANT:
8176         case FFEINFO_whereCONSTANT_SUBOBJECT:
8177         default:
8178           assert ("PROGRAM where unheard of" == NULL);
8179           /* Fall through. */
8180         case FFEINFO_whereANY:
8181           t = error_mark_node;
8182           break;
8183         }
8184       break;
8185
8186     case FFEINFO_kindBLOCKDATA:
8187       switch (ffeinfo_where (ffesymbol_info (s)))
8188         {
8189         case FFEINFO_whereLOCAL:        /* Me. */
8190           assert (!ffecom_transform_only_dummies_);
8191           t = current_function_decl;
8192           break;
8193
8194         case FFEINFO_whereGLOBAL:
8195           assert (!ffecom_transform_only_dummies_);
8196
8197           t = build_decl (FUNCTION_DECL,
8198                           ffecom_get_external_identifier_ (s),
8199                           ffecom_tree_blockdata_type);
8200           DECL_EXTERNAL (t) = 1;
8201           TREE_PUBLIC (t) = 1;
8202
8203           t = start_decl (t, FALSE);
8204           finish_decl (t, NULL_TREE, FALSE);
8205
8206           ffecom_save_tree_forever (t);
8207
8208           break;
8209
8210         case FFEINFO_whereCOMMON:
8211         case FFEINFO_whereDUMMY:
8212         case FFEINFO_whereRESULT:
8213         case FFEINFO_whereFLEETING:
8214         case FFEINFO_whereFLEETING_CADDR:
8215         case FFEINFO_whereFLEETING_IADDR:
8216         case FFEINFO_whereIMMEDIATE:
8217         case FFEINFO_whereINTRINSIC:
8218         case FFEINFO_whereCONSTANT:
8219         case FFEINFO_whereCONSTANT_SUBOBJECT:
8220         default:
8221           assert ("BLOCKDATA where unheard of" == NULL);
8222           /* Fall through. */
8223         case FFEINFO_whereANY:
8224           t = error_mark_node;
8225           break;
8226         }
8227       break;
8228
8229     case FFEINFO_kindCOMMON:
8230       switch (ffeinfo_where (ffesymbol_info (s)))
8231         {
8232         case FFEINFO_whereLOCAL:
8233           assert (!ffecom_transform_only_dummies_);
8234           ffecom_transform_common_ (s);
8235           break;
8236
8237         case FFEINFO_whereNONE:
8238         case FFEINFO_whereCOMMON:
8239         case FFEINFO_whereDUMMY:
8240         case FFEINFO_whereGLOBAL:
8241         case FFEINFO_whereRESULT:
8242         case FFEINFO_whereFLEETING:
8243         case FFEINFO_whereFLEETING_CADDR:
8244         case FFEINFO_whereFLEETING_IADDR:
8245         case FFEINFO_whereIMMEDIATE:
8246         case FFEINFO_whereINTRINSIC:
8247         case FFEINFO_whereCONSTANT:
8248         case FFEINFO_whereCONSTANT_SUBOBJECT:
8249         default:
8250           assert ("COMMON where unheard of" == NULL);
8251           /* Fall through. */
8252         case FFEINFO_whereANY:
8253           t = error_mark_node;
8254           break;
8255         }
8256       break;
8257
8258     case FFEINFO_kindCONSTRUCT:
8259       switch (ffeinfo_where (ffesymbol_info (s)))
8260         {
8261         case FFEINFO_whereLOCAL:
8262           assert (!ffecom_transform_only_dummies_);
8263           break;
8264
8265         case FFEINFO_whereNONE:
8266         case FFEINFO_whereCOMMON:
8267         case FFEINFO_whereDUMMY:
8268         case FFEINFO_whereGLOBAL:
8269         case FFEINFO_whereRESULT:
8270         case FFEINFO_whereFLEETING:
8271         case FFEINFO_whereFLEETING_CADDR:
8272         case FFEINFO_whereFLEETING_IADDR:
8273         case FFEINFO_whereIMMEDIATE:
8274         case FFEINFO_whereINTRINSIC:
8275         case FFEINFO_whereCONSTANT:
8276         case FFEINFO_whereCONSTANT_SUBOBJECT:
8277         default:
8278           assert ("CONSTRUCT where unheard of" == NULL);
8279           /* Fall through. */
8280         case FFEINFO_whereANY:
8281           t = error_mark_node;
8282           break;
8283         }
8284       break;
8285
8286     case FFEINFO_kindNAMELIST:
8287       switch (ffeinfo_where (ffesymbol_info (s)))
8288         {
8289         case FFEINFO_whereLOCAL:
8290           assert (!ffecom_transform_only_dummies_);
8291           t = ffecom_transform_namelist_ (s);
8292           break;
8293
8294         case FFEINFO_whereNONE:
8295         case FFEINFO_whereCOMMON:
8296         case FFEINFO_whereDUMMY:
8297         case FFEINFO_whereGLOBAL:
8298         case FFEINFO_whereRESULT:
8299         case FFEINFO_whereFLEETING:
8300         case FFEINFO_whereFLEETING_CADDR:
8301         case FFEINFO_whereFLEETING_IADDR:
8302         case FFEINFO_whereIMMEDIATE:
8303         case FFEINFO_whereINTRINSIC:
8304         case FFEINFO_whereCONSTANT:
8305         case FFEINFO_whereCONSTANT_SUBOBJECT:
8306         default:
8307           assert ("NAMELIST where unheard of" == NULL);
8308           /* Fall through. */
8309         case FFEINFO_whereANY:
8310           t = error_mark_node;
8311           break;
8312         }
8313       break;
8314
8315     default:
8316       assert ("kind unheard of" == NULL);
8317       /* Fall through. */
8318     case FFEINFO_kindANY:
8319       t = error_mark_node;
8320       break;
8321     }
8322
8323   ffesymbol_hook (s).decl_tree = t;
8324   ffesymbol_hook (s).length_tree = tlen;
8325   ffesymbol_hook (s).addr = addr;
8326
8327   lineno = old_lineno;
8328   input_filename = old_input_filename;
8329
8330   return s;
8331 }
8332
8333 /* Transform into ASSIGNable symbol.
8334
8335    Symbol has already been transformed, but for whatever reason, the
8336    resulting decl_tree has been deemed not usable for an ASSIGN target.
8337    (E.g. it isn't wide enough to hold a pointer.)  So, here we invent
8338    another local symbol of type void * and stuff that in the assign_tree
8339    argument.  The F77/F90 standards allow this implementation.  */
8340
8341 static ffesymbol
8342 ffecom_sym_transform_assign_ (ffesymbol s)
8343 {
8344   tree t;                       /* Transformed thingy. */
8345   int old_lineno = lineno;
8346   const char *old_input_filename = input_filename;
8347
8348   if (ffesymbol_sfdummyparent (s) == NULL)
8349     {
8350       input_filename = ffesymbol_where_filename (s);
8351       lineno = ffesymbol_where_filelinenum (s);
8352     }
8353   else
8354     {
8355       ffesymbol sf = ffesymbol_sfdummyparent (s);
8356
8357       input_filename = ffesymbol_where_filename (sf);
8358       lineno = ffesymbol_where_filelinenum (sf);
8359     }
8360
8361   assert (!ffecom_transform_only_dummies_);
8362
8363   t = build_decl (VAR_DECL,
8364                   ffecom_get_invented_identifier ("__g77_ASSIGN_%s",
8365                                                    ffesymbol_text (s)),
8366                   TREE_TYPE (null_pointer_node));
8367
8368   switch (ffesymbol_where (s))
8369     {
8370     case FFEINFO_whereLOCAL:
8371       /* Unlike for regular vars, SAVE status is easy to determine for
8372          ASSIGNed vars, since there's no initialization, there's no
8373          effective storage association (so "SAVE J" does not apply to
8374          K even given "EQUIVALENCE (J,K)"), there's no size issue
8375          to worry about, etc.  */
8376       if ((ffesymbol_is_save (s) || ffe_is_saveall ())
8377           && (ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8378           && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA))
8379         TREE_STATIC (t) = 1;    /* SAVEd in proc, make static. */
8380       else
8381         TREE_STATIC (t) = 0;    /* No need to make static. */
8382       break;
8383
8384     case FFEINFO_whereCOMMON:
8385       TREE_STATIC (t) = 1;      /* Assume COMMONs always SAVEd. */
8386       break;
8387
8388     case FFEINFO_whereDUMMY:
8389       /* Note that twinning a DUMMY means the caller won't see
8390          the ASSIGNed value.  But both F77 and F90 allow implementations
8391          to do this, i.e. disallow Fortran code that would try and
8392          take advantage of actually putting a label into a variable
8393          via a dummy argument (or any other storage association, for
8394          that matter).  */
8395       TREE_STATIC (t) = 0;
8396       break;
8397
8398     default:
8399       TREE_STATIC (t) = 0;
8400       break;
8401     }
8402
8403   t = start_decl (t, FALSE);
8404   finish_decl (t, NULL_TREE, FALSE);
8405
8406   ffesymbol_hook (s).assign_tree = t;
8407
8408   lineno = old_lineno;
8409   input_filename = old_input_filename;
8410
8411   return s;
8412 }
8413
8414 /* Implement COMMON area in back end.
8415
8416    Because COMMON-based variables can be referenced in the dimension
8417    expressions of dummy (adjustable) arrays, and because dummies
8418    (in the gcc back end) need to be put in the outer binding level
8419    of a function (which has two binding levels, the outer holding
8420    the dummies and the inner holding the other vars), special care
8421    must be taken to handle COMMON areas.
8422
8423    The current strategy is basically to always tell the back end about
8424    the COMMON area as a top-level external reference to just a block
8425    of storage of the master type of that area (e.g. integer, real,
8426    character, whatever -- not a structure).  As a distinct action,
8427    if initial values are provided, tell the back end about the area
8428    as a top-level non-external (initialized) area and remember not to
8429    allow further initialization or expansion of the area.  Meanwhile,
8430    if no initialization happens at all, tell the back end about
8431    the largest size we've seen declared so the space does get reserved.
8432    (This function doesn't handle all that stuff, but it does some
8433    of the important things.)
8434
8435    Meanwhile, for COMMON variables themselves, just keep creating
8436    references like *((float *) (&common_area + offset)) each time
8437    we reference the variable.  In other words, don't make a VAR_DECL
8438    or any kind of component reference (like we used to do before 0.4),
8439    though we might do that as well just for debugging purposes (and
8440    stuff the rtl with the appropriate offset expression).  */
8441
8442 static void
8443 ffecom_transform_common_ (ffesymbol s)
8444 {
8445   ffestorag st = ffesymbol_storage (s);
8446   ffeglobal g = ffesymbol_global (s);
8447   tree cbt;
8448   tree cbtype;
8449   tree init;
8450   tree high;
8451   bool is_init = ffestorag_is_init (st);
8452
8453   assert (st != NULL);
8454
8455   if ((g == NULL)
8456       || (ffeglobal_type (g) != FFEGLOBAL_typeCOMMON))
8457     return;
8458
8459   /* First update the size of the area in global terms.  */
8460
8461   ffeglobal_size_common (s, ffestorag_size (st));
8462
8463   if (!ffeglobal_common_init (g))
8464     is_init = FALSE;    /* No explicit init, don't let erroneous joins init. */
8465
8466   cbt = ffeglobal_hook (g);
8467
8468   /* If we already have declared this common block for a previous program
8469      unit, and either we already initialized it or we don't have new
8470      initialization for it, just return what we have without changing it.  */
8471
8472   if ((cbt != NULL_TREE)
8473       && (!is_init
8474           || !DECL_EXTERNAL (cbt)))
8475     {
8476       if (st->hook == NULL) ffestorag_set_hook (st, cbt);
8477       return;
8478     }
8479
8480   /* Process inits.  */
8481
8482   if (is_init)
8483     {
8484       if (ffestorag_init (st) != NULL)
8485         {
8486           ffebld sexp;
8487
8488           /* Set the padding for the expression, so ffecom_expr
8489              knows to insert that many zeros.  */
8490           switch (ffebld_op (sexp = ffestorag_init (st)))
8491             {
8492             case FFEBLD_opCONTER:
8493               ffebld_conter_set_pad (sexp, ffestorag_modulo (st));
8494               break;
8495
8496             case FFEBLD_opARRTER:
8497               ffebld_arrter_set_pad (sexp, ffestorag_modulo (st));
8498               break;
8499
8500             case FFEBLD_opACCTER:
8501               ffebld_accter_set_pad (sexp, ffestorag_modulo (st));
8502               break;
8503
8504             default:
8505               assert ("bad op for cmn init (pad)" == NULL);
8506               break;
8507             }
8508
8509           init = ffecom_expr (sexp);
8510           if (init == error_mark_node)
8511             {                   /* Hopefully the back end complained! */
8512               init = NULL_TREE;
8513               if (cbt != NULL_TREE)
8514                 return;
8515             }
8516         }
8517       else
8518         init = error_mark_node;
8519     }
8520   else
8521     init = NULL_TREE;
8522
8523   /* cbtype must be permanently allocated!  */
8524
8525   /* Allocate the MAX of the areas so far, seen filewide.  */
8526   high = build_int_2 ((ffeglobal_common_size (g)
8527                        + ffeglobal_common_pad (g)) - 1, 0);
8528   TREE_TYPE (high) = ffecom_integer_type_node;
8529
8530   if (init)
8531     cbtype = build_array_type (char_type_node,
8532                                build_range_type (integer_type_node,
8533                                                  integer_zero_node,
8534                                                  high));
8535   else
8536     cbtype = build_array_type (char_type_node, NULL_TREE);
8537
8538   if (cbt == NULL_TREE)
8539     {
8540       cbt
8541         = build_decl (VAR_DECL,
8542                       ffecom_get_external_identifier_ (s),
8543                       cbtype);
8544       TREE_STATIC (cbt) = 1;
8545       TREE_PUBLIC (cbt) = 1;
8546     }
8547   else
8548     {
8549       assert (is_init);
8550       TREE_TYPE (cbt) = cbtype;
8551     }
8552   DECL_EXTERNAL (cbt) = init ? 0 : 1;
8553   DECL_INITIAL (cbt) = init ? error_mark_node : NULL_TREE;
8554
8555   cbt = start_decl (cbt, TRUE);
8556   if (ffeglobal_hook (g) != NULL)
8557     assert (cbt == ffeglobal_hook (g));
8558
8559   assert (!init || !DECL_EXTERNAL (cbt));
8560
8561   /* Make sure that any type can live in COMMON and be referenced
8562      without getting a bus error.  We could pick the most restrictive
8563      alignment of all entities actually placed in the COMMON, but
8564      this seems easy enough.  */
8565
8566   DECL_ALIGN (cbt) = BIGGEST_ALIGNMENT;
8567   DECL_USER_ALIGN (cbt) = 0;
8568
8569   if (is_init && (ffestorag_init (st) == NULL))
8570     init = ffecom_init_zero_ (cbt);
8571
8572   finish_decl (cbt, init, TRUE);
8573
8574   if (is_init)
8575     ffestorag_set_init (st, ffebld_new_any ());
8576
8577   if (init)
8578     {
8579       assert (DECL_SIZE_UNIT (cbt) != NULL_TREE);
8580       assert (TREE_CODE (DECL_SIZE_UNIT (cbt)) == INTEGER_CST);
8581       assert (0 == compare_tree_int (DECL_SIZE_UNIT (cbt),
8582                                      (ffeglobal_common_size (g)
8583                                       + ffeglobal_common_pad (g))));
8584     }
8585
8586   ffeglobal_set_hook (g, cbt);
8587
8588   ffestorag_set_hook (st, cbt);
8589
8590   ffecom_save_tree_forever (cbt);
8591 }
8592
8593 /* Make master area for local EQUIVALENCE.  */
8594
8595 static void
8596 ffecom_transform_equiv_ (ffestorag eqst)
8597 {
8598   tree eqt;
8599   tree eqtype;
8600   tree init;
8601   tree high;
8602   bool is_init = ffestorag_is_init (eqst);
8603
8604   assert (eqst != NULL);
8605
8606   eqt = ffestorag_hook (eqst);
8607
8608   if (eqt != NULL_TREE)
8609     return;
8610
8611   /* Process inits.  */
8612
8613   if (is_init)
8614     {
8615       if (ffestorag_init (eqst) != NULL)
8616         {
8617           ffebld sexp;
8618
8619           /* Set the padding for the expression, so ffecom_expr
8620              knows to insert that many zeros.  */
8621           switch (ffebld_op (sexp = ffestorag_init (eqst)))
8622             {
8623             case FFEBLD_opCONTER:
8624               ffebld_conter_set_pad (sexp, ffestorag_modulo (eqst));
8625               break;
8626
8627             case FFEBLD_opARRTER:
8628               ffebld_arrter_set_pad (sexp, ffestorag_modulo (eqst));
8629               break;
8630
8631             case FFEBLD_opACCTER:
8632               ffebld_accter_set_pad (sexp, ffestorag_modulo (eqst));
8633               break;
8634
8635             default:
8636               assert ("bad op for eqv init (pad)" == NULL);
8637               break;
8638             }
8639
8640           init = ffecom_expr (sexp);
8641           if (init == error_mark_node)
8642             init = NULL_TREE;   /* Hopefully the back end complained! */
8643         }
8644       else
8645         init = error_mark_node;
8646     }
8647   else if (ffe_is_init_local_zero ())
8648     init = error_mark_node;
8649   else
8650     init = NULL_TREE;
8651
8652   ffecom_member_namelisted_ = FALSE;
8653   ffestorag_drive (ffestorag_list_equivs (eqst),
8654                    &ffecom_member_phase1_,
8655                    eqst);
8656
8657   high = build_int_2 ((ffestorag_size (eqst)
8658                        + ffestorag_modulo (eqst)) - 1, 0);
8659   TREE_TYPE (high) = ffecom_integer_type_node;
8660
8661   eqtype = build_array_type (char_type_node,
8662                              build_range_type (ffecom_integer_type_node,
8663                                                ffecom_integer_zero_node,
8664                                                high));
8665
8666   eqt = build_decl (VAR_DECL,
8667                     ffecom_get_invented_identifier ("__g77_equiv_%s",
8668                                                     ffesymbol_text
8669                                                     (ffestorag_symbol (eqst))),
8670                     eqtype);
8671   DECL_EXTERNAL (eqt) = 0;
8672   if (is_init
8673       || ffecom_member_namelisted_
8674 #ifdef FFECOM_sizeMAXSTACKITEM
8675       || (ffestorag_size (eqst) > FFECOM_sizeMAXSTACKITEM)
8676 #endif
8677       || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8678           && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
8679           && (ffestorag_is_save (eqst) || ffe_is_saveall ())))
8680     TREE_STATIC (eqt) = 1;
8681   else
8682     TREE_STATIC (eqt) = 0;
8683   TREE_PUBLIC (eqt) = 0;
8684   TREE_ADDRESSABLE (eqt) = 1;  /* Ensure non-register allocation */
8685   DECL_CONTEXT (eqt) = current_function_decl;
8686   if (init)
8687     DECL_INITIAL (eqt) = error_mark_node;
8688   else
8689     DECL_INITIAL (eqt) = NULL_TREE;
8690
8691   eqt = start_decl (eqt, FALSE);
8692
8693   /* Make sure that any type can live in EQUIVALENCE and be referenced
8694      without getting a bus error.  We could pick the most restrictive
8695      alignment of all entities actually placed in the EQUIVALENCE, but
8696      this seems easy enough.  */
8697
8698   DECL_ALIGN (eqt) = BIGGEST_ALIGNMENT;
8699   DECL_USER_ALIGN (eqt) = 0;
8700
8701   if ((!is_init && ffe_is_init_local_zero ())
8702       || (is_init && (ffestorag_init (eqst) == NULL)))
8703     init = ffecom_init_zero_ (eqt);
8704
8705   finish_decl (eqt, init, FALSE);
8706
8707   if (is_init)
8708     ffestorag_set_init (eqst, ffebld_new_any ());
8709
8710   {
8711     assert (TREE_CODE (DECL_SIZE_UNIT (eqt)) == INTEGER_CST);
8712     assert (0 == compare_tree_int (DECL_SIZE_UNIT (eqt),
8713                                    (ffestorag_size (eqst)
8714                                     + ffestorag_modulo (eqst))));
8715   }
8716
8717   ffestorag_set_hook (eqst, eqt);
8718
8719   ffestorag_drive (ffestorag_list_equivs (eqst),
8720                    &ffecom_member_phase2_,
8721                    eqst);
8722 }
8723
8724 /* Implement NAMELIST in back end.  See f2c/format.c for more info.  */
8725
8726 static tree
8727 ffecom_transform_namelist_ (ffesymbol s)
8728 {
8729   tree nmlt;
8730   tree nmltype = ffecom_type_namelist_ ();
8731   tree nmlinits;
8732   tree nameinit;
8733   tree varsinit;
8734   tree nvarsinit;
8735   tree field;
8736   tree high;
8737   int i;
8738   static int mynumber = 0;
8739
8740   nmlt = build_decl (VAR_DECL,
8741                      ffecom_get_invented_identifier ("__g77_namelist_%d",
8742                                                      mynumber++),
8743                      nmltype);
8744   TREE_STATIC (nmlt) = 1;
8745   DECL_INITIAL (nmlt) = error_mark_node;
8746
8747   nmlt = start_decl (nmlt, FALSE);
8748
8749   /* Process inits.  */
8750
8751   i = strlen (ffesymbol_text (s));
8752
8753   high = build_int_2 (i, 0);
8754   TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
8755
8756   nameinit = ffecom_build_f2c_string_ (i + 1,
8757                                        ffesymbol_text (s));
8758   TREE_TYPE (nameinit)
8759     = build_type_variant
8760     (build_array_type
8761      (char_type_node,
8762       build_range_type (ffecom_f2c_ftnlen_type_node,
8763                         ffecom_f2c_ftnlen_one_node,
8764                         high)),
8765      1, 0);
8766   TREE_CONSTANT (nameinit) = 1;
8767   TREE_STATIC (nameinit) = 1;
8768   nameinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (nameinit)),
8769                        nameinit);
8770
8771   varsinit = ffecom_vardesc_array_ (s);
8772   varsinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (varsinit)),
8773                        varsinit);
8774   TREE_CONSTANT (varsinit) = 1;
8775   TREE_STATIC (varsinit) = 1;
8776
8777   {
8778     ffebld b;
8779
8780     for (i = 0, b = ffesymbol_namelist (s); b != NULL; b = ffebld_trail (b))
8781       ++i;
8782   }
8783   nvarsinit = build_int_2 (i, 0);
8784   TREE_TYPE (nvarsinit) = integer_type_node;
8785   TREE_CONSTANT (nvarsinit) = 1;
8786   TREE_STATIC (nvarsinit) = 1;
8787
8788   nmlinits = build_tree_list ((field = TYPE_FIELDS (nmltype)), nameinit);
8789   TREE_CHAIN (nmlinits) = build_tree_list ((field = TREE_CHAIN (field)),
8790                                            varsinit);
8791   TREE_CHAIN (TREE_CHAIN (nmlinits))
8792     = build_tree_list ((field = TREE_CHAIN (field)), nvarsinit);
8793
8794   nmlinits = build (CONSTRUCTOR, nmltype, NULL_TREE, nmlinits);
8795   TREE_CONSTANT (nmlinits) = 1;
8796   TREE_STATIC (nmlinits) = 1;
8797
8798   finish_decl (nmlt, nmlinits, FALSE);
8799
8800   nmlt = ffecom_1 (ADDR_EXPR, build_pointer_type (nmltype), nmlt);
8801
8802   return nmlt;
8803 }
8804
8805 /* A subroutine of ffecom_tree_canonize_ref_.  The incoming tree is
8806    analyzed on the assumption it is calculating a pointer to be
8807    indirected through.  It must return the proper decl and offset,
8808    taking into account different units of measurements for offsets.  */
8809
8810 static void
8811 ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
8812                            tree t)
8813 {
8814   switch (TREE_CODE (t))
8815     {
8816     case NOP_EXPR:
8817     case CONVERT_EXPR:
8818     case NON_LVALUE_EXPR:
8819       ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
8820       break;
8821
8822     case PLUS_EXPR:
8823       ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
8824       if ((*decl == NULL_TREE)
8825           || (*decl == error_mark_node))
8826         break;
8827
8828       if (TREE_CODE (TREE_OPERAND (t, 1)) == INTEGER_CST)
8829         {
8830           /* An offset into COMMON.  */
8831           *offset = fold (build (PLUS_EXPR, TREE_TYPE (*offset),
8832                                  *offset, TREE_OPERAND (t, 1)));
8833           /* Convert offset (presumably in bytes) into canonical units
8834              (presumably bits).  */
8835           *offset = size_binop (MULT_EXPR,
8836                                 convert (bitsizetype, *offset),
8837                                 TYPE_SIZE (TREE_TYPE (TREE_TYPE (t))));
8838           break;
8839         }
8840       /* Not a COMMON reference, so an unrecognized pattern.  */
8841       *decl = error_mark_node;
8842       break;
8843
8844     case PARM_DECL:
8845       *decl = t;
8846       *offset = bitsize_zero_node;
8847       break;
8848
8849     case ADDR_EXPR:
8850       if (TREE_CODE (TREE_OPERAND (t, 0)) == VAR_DECL)
8851         {
8852           /* A reference to COMMON.  */
8853           *decl = TREE_OPERAND (t, 0);
8854           *offset = bitsize_zero_node;
8855           break;
8856         }
8857       /* Fall through.  */
8858     default:
8859       /* Not a COMMON reference, so an unrecognized pattern.  */
8860       *decl = error_mark_node;
8861       break;
8862     }
8863 }
8864
8865 /* Given a tree that is possibly intended for use as an lvalue, return
8866    information representing a canonical view of that tree as a decl, an
8867    offset into that decl, and a size for the lvalue.
8868
8869    If there's no applicable decl, NULL_TREE is returned for the decl,
8870    and the other fields are left undefined.
8871
8872    If the tree doesn't fit the recognizable forms, an ERROR_MARK node
8873    is returned for the decl, and the other fields are left undefined.
8874
8875    Otherwise, the decl returned currently is either a VAR_DECL or a
8876    PARM_DECL.
8877
8878    The offset returned is always valid, but of course not necessarily
8879    a constant, and not necessarily converted into the appropriate
8880    type, leaving that up to the caller (so as to avoid that overhead
8881    if the decls being looked at are different anyway).
8882
8883    If the size cannot be determined (e.g. an adjustable array),
8884    an ERROR_MARK node is returned for the size.  Otherwise, the
8885    size returned is valid, not necessarily a constant, and not
8886    necessarily converted into the appropriate type as with the
8887    offset.
8888
8889    Note that the offset and size expressions are expressed in the
8890    base storage units (usually bits) rather than in the units of
8891    the type of the decl, because two decls with different types
8892    might overlap but with apparently non-overlapping array offsets,
8893    whereas converting the array offsets to consistant offsets will
8894    reveal the overlap.  */
8895
8896 static void
8897 ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
8898                            tree *size, tree t)
8899 {
8900   /* The default path is to report a nonexistant decl.  */
8901   *decl = NULL_TREE;
8902
8903   if (t == NULL_TREE)
8904     return;
8905
8906   switch (TREE_CODE (t))
8907     {
8908     case ERROR_MARK:
8909     case IDENTIFIER_NODE:
8910     case INTEGER_CST:
8911     case REAL_CST:
8912     case COMPLEX_CST:
8913     case STRING_CST:
8914     case CONST_DECL:
8915     case PLUS_EXPR:
8916     case MINUS_EXPR:
8917     case MULT_EXPR:
8918     case TRUNC_DIV_EXPR:
8919     case CEIL_DIV_EXPR:
8920     case FLOOR_DIV_EXPR:
8921     case ROUND_DIV_EXPR:
8922     case TRUNC_MOD_EXPR:
8923     case CEIL_MOD_EXPR:
8924     case FLOOR_MOD_EXPR:
8925     case ROUND_MOD_EXPR:
8926     case RDIV_EXPR:
8927     case EXACT_DIV_EXPR:
8928     case FIX_TRUNC_EXPR:
8929     case FIX_CEIL_EXPR:
8930     case FIX_FLOOR_EXPR:
8931     case FIX_ROUND_EXPR:
8932     case FLOAT_EXPR:
8933     case NEGATE_EXPR:
8934     case MIN_EXPR:
8935     case MAX_EXPR:
8936     case ABS_EXPR:
8937     case FFS_EXPR:
8938     case LSHIFT_EXPR:
8939     case RSHIFT_EXPR:
8940     case LROTATE_EXPR:
8941     case RROTATE_EXPR:
8942     case BIT_IOR_EXPR:
8943     case BIT_XOR_EXPR:
8944     case BIT_AND_EXPR:
8945     case BIT_ANDTC_EXPR:
8946     case BIT_NOT_EXPR:
8947     case TRUTH_ANDIF_EXPR:
8948     case TRUTH_ORIF_EXPR:
8949     case TRUTH_AND_EXPR:
8950     case TRUTH_OR_EXPR:
8951     case TRUTH_XOR_EXPR:
8952     case TRUTH_NOT_EXPR:
8953     case LT_EXPR:
8954     case LE_EXPR:
8955     case GT_EXPR:
8956     case GE_EXPR:
8957     case EQ_EXPR:
8958     case NE_EXPR:
8959     case COMPLEX_EXPR:
8960     case CONJ_EXPR:
8961     case REALPART_EXPR:
8962     case IMAGPART_EXPR:
8963     case LABEL_EXPR:
8964     case COMPONENT_REF:
8965     case COMPOUND_EXPR:
8966     case ADDR_EXPR:
8967       return;
8968
8969     case VAR_DECL:
8970     case PARM_DECL:
8971       *decl = t;
8972       *offset = bitsize_zero_node;
8973       *size = TYPE_SIZE (TREE_TYPE (t));
8974       return;
8975
8976     case ARRAY_REF:
8977       {
8978         tree array = TREE_OPERAND (t, 0);
8979         tree element = TREE_OPERAND (t, 1);
8980         tree init_offset;
8981
8982         if ((array == NULL_TREE)
8983             || (element == NULL_TREE))
8984           {
8985             *decl = error_mark_node;
8986             return;
8987           }
8988
8989         ffecom_tree_canonize_ref_ (decl, &init_offset, size,
8990                                    array);
8991         if ((*decl == NULL_TREE)
8992             || (*decl == error_mark_node))
8993           return;
8994
8995         /* Calculate ((element - base) * NBBY) + init_offset.  */
8996         *offset = fold (build (MINUS_EXPR, TREE_TYPE (element),
8997                                element,
8998                                TYPE_MIN_VALUE (TYPE_DOMAIN
8999                                                (TREE_TYPE (array)))));
9000
9001         *offset = size_binop (MULT_EXPR,
9002                               convert (bitsizetype, *offset),
9003                               TYPE_SIZE (TREE_TYPE (TREE_TYPE (array))));
9004
9005         *offset = size_binop (PLUS_EXPR, init_offset, *offset);
9006
9007         *size = TYPE_SIZE (TREE_TYPE (t));
9008         return;
9009       }
9010
9011     case INDIRECT_REF:
9012
9013       /* Most of this code is to handle references to COMMON.  And so
9014          far that is useful only for calling library functions, since
9015          external (user) functions might reference common areas.  But
9016          even calling an external function, it's worthwhile to decode
9017          COMMON references because if not storing into COMMON, we don't
9018          want COMMON-based arguments to gratuitously force use of a
9019          temporary.  */
9020
9021       *size = TYPE_SIZE (TREE_TYPE (t));
9022
9023       ffecom_tree_canonize_ptr_ (decl, offset,
9024                                  TREE_OPERAND (t, 0));
9025
9026       return;
9027
9028     case CONVERT_EXPR:
9029     case NOP_EXPR:
9030     case MODIFY_EXPR:
9031     case NON_LVALUE_EXPR:
9032     case RESULT_DECL:
9033     case FIELD_DECL:
9034     case COND_EXPR:             /* More cases than we can handle. */
9035     case SAVE_EXPR:
9036     case REFERENCE_EXPR:
9037     case PREDECREMENT_EXPR:
9038     case PREINCREMENT_EXPR:
9039     case POSTDECREMENT_EXPR:
9040     case POSTINCREMENT_EXPR:
9041     case CALL_EXPR:
9042     default:
9043       *decl = error_mark_node;
9044       return;
9045     }
9046 }
9047
9048 /* Do divide operation appropriate to type of operands.  */
9049
9050 static tree
9051 ffecom_tree_divide_ (tree tree_type, tree left, tree right,
9052                      tree dest_tree, ffebld dest, bool *dest_used,
9053                      tree hook)
9054 {
9055   if ((left == error_mark_node)
9056       || (right == error_mark_node))
9057     return error_mark_node;
9058
9059   switch (TREE_CODE (tree_type))
9060     {
9061     case INTEGER_TYPE:
9062       return ffecom_2 (TRUNC_DIV_EXPR, tree_type,
9063                        left,
9064                        right);
9065
9066     case COMPLEX_TYPE:
9067       if (! optimize_size)
9068         return ffecom_2 (RDIV_EXPR, tree_type,
9069                          left,
9070                          right);
9071       {
9072         ffecomGfrt ix;
9073
9074         if (TREE_TYPE (tree_type)
9075             == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9076           ix = FFECOM_gfrtDIV_CC;       /* Overlapping result okay. */
9077         else
9078           ix = FFECOM_gfrtDIV_ZZ;       /* Overlapping result okay. */
9079
9080         left = ffecom_1 (ADDR_EXPR,
9081                          build_pointer_type (TREE_TYPE (left)),
9082                          left);
9083         left = build_tree_list (NULL_TREE, left);
9084         right = ffecom_1 (ADDR_EXPR,
9085                           build_pointer_type (TREE_TYPE (right)),
9086                           right);
9087         right = build_tree_list (NULL_TREE, right);
9088         TREE_CHAIN (left) = right;
9089
9090         return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9091                              ffecom_gfrt_kindtype (ix),
9092                              ffe_is_f2c_library (),
9093                              tree_type,
9094                              left,
9095                              dest_tree, dest, dest_used,
9096                              NULL_TREE, TRUE, hook);
9097       }
9098       break;
9099
9100     case RECORD_TYPE:
9101       {
9102         ffecomGfrt ix;
9103
9104         if (TREE_TYPE (TYPE_FIELDS (tree_type))
9105             == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9106           ix = FFECOM_gfrtDIV_CC;       /* Overlapping result okay. */
9107         else
9108           ix = FFECOM_gfrtDIV_ZZ;       /* Overlapping result okay. */
9109
9110         left = ffecom_1 (ADDR_EXPR,
9111                          build_pointer_type (TREE_TYPE (left)),
9112                          left);
9113         left = build_tree_list (NULL_TREE, left);
9114         right = ffecom_1 (ADDR_EXPR,
9115                           build_pointer_type (TREE_TYPE (right)),
9116                           right);
9117         right = build_tree_list (NULL_TREE, right);
9118         TREE_CHAIN (left) = right;
9119
9120         return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9121                              ffecom_gfrt_kindtype (ix),
9122                              ffe_is_f2c_library (),
9123                              tree_type,
9124                              left,
9125                              dest_tree, dest, dest_used,
9126                              NULL_TREE, TRUE, hook);
9127       }
9128       break;
9129
9130     default:
9131       return ffecom_2 (RDIV_EXPR, tree_type,
9132                        left,
9133                        right);
9134     }
9135 }
9136
9137 /* Build type info for non-dummy variable.  */
9138
9139 static tree
9140 ffecom_type_localvar_ (ffesymbol s, ffeinfoBasictype bt,
9141                        ffeinfoKindtype kt)
9142 {
9143   tree type;
9144   ffebld dl;
9145   ffebld dim;
9146   tree lowt;
9147   tree hight;
9148
9149   type = ffecom_tree_type[bt][kt];
9150   if (bt == FFEINFO_basictypeCHARACTER)
9151     {
9152       hight = build_int_2 (ffesymbol_size (s), 0);
9153       TREE_TYPE (hight) = ffecom_f2c_ftnlen_type_node;
9154
9155       type
9156         = build_array_type
9157           (type,
9158            build_range_type (ffecom_f2c_ftnlen_type_node,
9159                              ffecom_f2c_ftnlen_one_node,
9160                              hight));
9161       type = ffecom_check_size_overflow_ (s, type, FALSE);
9162     }
9163
9164   for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
9165     {
9166       if (type == error_mark_node)
9167         break;
9168
9169       dim = ffebld_head (dl);
9170       assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
9171
9172       if (ffebld_left (dim) == NULL)
9173         lowt = integer_one_node;
9174       else
9175         lowt = ffecom_expr (ffebld_left (dim));
9176
9177       if (TREE_CODE (lowt) != INTEGER_CST)
9178         lowt = variable_size (lowt);
9179
9180       assert (ffebld_right (dim) != NULL);
9181       hight = ffecom_expr (ffebld_right (dim));
9182
9183       if (TREE_CODE (hight) != INTEGER_CST)
9184         hight = variable_size (hight);
9185
9186       type = build_array_type (type,
9187                                build_range_type (ffecom_integer_type_node,
9188                                                  lowt, hight));
9189       type = ffecom_check_size_overflow_ (s, type, FALSE);
9190     }
9191
9192   return type;
9193 }
9194
9195 /* Build Namelist type.  */
9196
9197 static tree
9198 ffecom_type_namelist_ ()
9199 {
9200   static tree type = NULL_TREE;
9201
9202   if (type == NULL_TREE)
9203     {
9204       static tree namefield, varsfield, nvarsfield;
9205       tree vardesctype;
9206
9207       vardesctype = ffecom_type_vardesc_ ();
9208
9209       type = make_node (RECORD_TYPE);
9210
9211       vardesctype = build_pointer_type (build_pointer_type (vardesctype));
9212
9213       namefield = ffecom_decl_field (type, NULL_TREE, "name",
9214                                      string_type_node);
9215       varsfield = ffecom_decl_field (type, namefield, "vars", vardesctype);
9216       nvarsfield = ffecom_decl_field (type, varsfield, "nvars",
9217                                       integer_type_node);
9218
9219       TYPE_FIELDS (type) = namefield;
9220       layout_type (type);
9221
9222       ggc_add_tree_root (&type, 1);
9223     }
9224
9225   return type;
9226 }
9227
9228 /* Build Vardesc type.  */
9229
9230 static tree
9231 ffecom_type_vardesc_ ()
9232 {
9233   static tree type = NULL_TREE;
9234   static tree namefield, addrfield, dimsfield, typefield;
9235
9236   if (type == NULL_TREE)
9237     {
9238       type = make_node (RECORD_TYPE);
9239
9240       namefield = ffecom_decl_field (type, NULL_TREE, "name",
9241                                      string_type_node);
9242       addrfield = ffecom_decl_field (type, namefield, "addr",
9243                                      string_type_node);
9244       dimsfield = ffecom_decl_field (type, addrfield, "dims",
9245                                      ffecom_f2c_ptr_to_ftnlen_type_node);
9246       typefield = ffecom_decl_field (type, dimsfield, "type",
9247                                      integer_type_node);
9248
9249       TYPE_FIELDS (type) = namefield;
9250       layout_type (type);
9251
9252       ggc_add_tree_root (&type, 1);
9253     }
9254
9255   return type;
9256 }
9257
9258 static tree
9259 ffecom_vardesc_ (ffebld expr)
9260 {
9261   ffesymbol s;
9262
9263   assert (ffebld_op (expr) == FFEBLD_opSYMTER);
9264   s = ffebld_symter (expr);
9265
9266   if (ffesymbol_hook (s).vardesc_tree == NULL_TREE)
9267     {
9268       int i;
9269       tree vardesctype = ffecom_type_vardesc_ ();
9270       tree var;
9271       tree nameinit;
9272       tree dimsinit;
9273       tree addrinit;
9274       tree typeinit;
9275       tree field;
9276       tree varinits;
9277       static int mynumber = 0;
9278
9279       var = build_decl (VAR_DECL,
9280                         ffecom_get_invented_identifier ("__g77_vardesc_%d",
9281                                                         mynumber++),
9282                         vardesctype);
9283       TREE_STATIC (var) = 1;
9284       DECL_INITIAL (var) = error_mark_node;
9285
9286       var = start_decl (var, FALSE);
9287
9288       /* Process inits.  */
9289
9290       nameinit = ffecom_build_f2c_string_ ((i = strlen (ffesymbol_text (s)))
9291                                            + 1,
9292                                            ffesymbol_text (s));
9293       TREE_TYPE (nameinit)
9294         = build_type_variant
9295         (build_array_type
9296          (char_type_node,
9297           build_range_type (integer_type_node,
9298                             integer_one_node,
9299                             build_int_2 (i, 0))),
9300          1, 0);
9301       TREE_CONSTANT (nameinit) = 1;
9302       TREE_STATIC (nameinit) = 1;
9303       nameinit = ffecom_1 (ADDR_EXPR,
9304                            build_pointer_type (TREE_TYPE (nameinit)),
9305                            nameinit);
9306
9307       addrinit = ffecom_arg_ptr_to_expr (expr, &typeinit);
9308
9309       dimsinit = ffecom_vardesc_dims_ (s);
9310
9311       if (typeinit == NULL_TREE)
9312         {
9313           ffeinfoBasictype bt = ffesymbol_basictype (s);
9314           ffeinfoKindtype kt = ffesymbol_kindtype (s);
9315           int tc = ffecom_f2c_typecode (bt, kt);
9316
9317           assert (tc != -1);
9318           typeinit = build_int_2 (tc, (tc < 0) ? -1 : 0);
9319         }
9320       else
9321         typeinit = ffecom_1 (NEGATE_EXPR, TREE_TYPE (typeinit), typeinit);
9322
9323       varinits = build_tree_list ((field = TYPE_FIELDS (vardesctype)),
9324                                   nameinit);
9325       TREE_CHAIN (varinits) = build_tree_list ((field = TREE_CHAIN (field)),
9326                                                addrinit);
9327       TREE_CHAIN (TREE_CHAIN (varinits))
9328         = build_tree_list ((field = TREE_CHAIN (field)), dimsinit);
9329       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (varinits)))
9330         = build_tree_list ((field = TREE_CHAIN (field)), typeinit);
9331
9332       varinits = build (CONSTRUCTOR, vardesctype, NULL_TREE, varinits);
9333       TREE_CONSTANT (varinits) = 1;
9334       TREE_STATIC (varinits) = 1;
9335
9336       finish_decl (var, varinits, FALSE);
9337
9338       var = ffecom_1 (ADDR_EXPR, build_pointer_type (vardesctype), var);
9339
9340       ffesymbol_hook (s).vardesc_tree = var;
9341     }
9342
9343   return ffesymbol_hook (s).vardesc_tree;
9344 }
9345
9346 static tree
9347 ffecom_vardesc_array_ (ffesymbol s)
9348 {
9349   ffebld b;
9350   tree list;
9351   tree item = NULL_TREE;
9352   tree var;
9353   int i;
9354   static int mynumber = 0;
9355
9356   for (i = 0, list = NULL_TREE, b = ffesymbol_namelist (s);
9357        b != NULL;
9358        b = ffebld_trail (b), ++i)
9359     {
9360       tree t;
9361
9362       t = ffecom_vardesc_ (ffebld_head (b));
9363
9364       if (list == NULL_TREE)
9365         list = item = build_tree_list (NULL_TREE, t);
9366       else
9367         {
9368           TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9369           item = TREE_CHAIN (item);
9370         }
9371     }
9372
9373   item = build_array_type (build_pointer_type (ffecom_type_vardesc_ ()),
9374                            build_range_type (integer_type_node,
9375                                              integer_one_node,
9376                                              build_int_2 (i, 0)));
9377   list = build (CONSTRUCTOR, item, NULL_TREE, list);
9378   TREE_CONSTANT (list) = 1;
9379   TREE_STATIC (list) = 1;
9380
9381   var = ffecom_get_invented_identifier ("__g77_vardesc_array_%d", mynumber++);
9382   var = build_decl (VAR_DECL, var, item);
9383   TREE_STATIC (var) = 1;
9384   DECL_INITIAL (var) = error_mark_node;
9385   var = start_decl (var, FALSE);
9386   finish_decl (var, list, FALSE);
9387
9388   return var;
9389 }
9390
9391 static tree
9392 ffecom_vardesc_dims_ (ffesymbol s)
9393 {
9394   if (ffesymbol_dims (s) == NULL)
9395     return convert (ffecom_f2c_ptr_to_ftnlen_type_node,
9396                     integer_zero_node);
9397
9398   {
9399     ffebld b;
9400     ffebld e;
9401     tree list;
9402     tree backlist;
9403     tree item = NULL_TREE;
9404     tree var;
9405     tree numdim;
9406     tree numelem;
9407     tree baseoff = NULL_TREE;
9408     static int mynumber = 0;
9409
9410     numdim = build_int_2 ((int) ffesymbol_rank (s), 0);
9411     TREE_TYPE (numdim) = ffecom_f2c_ftnlen_type_node;
9412
9413     numelem = ffecom_expr (ffesymbol_arraysize (s));
9414     TREE_TYPE (numelem) = ffecom_f2c_ftnlen_type_node;
9415
9416     list = NULL_TREE;
9417     backlist = NULL_TREE;
9418     for (b = ffesymbol_dims (s), e = ffesymbol_extents (s);
9419          b != NULL;
9420          b = ffebld_trail (b), e = ffebld_trail (e))
9421       {
9422         tree t;
9423         tree low;
9424         tree back;
9425
9426         if (ffebld_trail (b) == NULL)
9427           t = NULL_TREE;
9428         else
9429           {
9430             t = convert (ffecom_f2c_ftnlen_type_node,
9431                          ffecom_expr (ffebld_head (e)));
9432
9433             if (list == NULL_TREE)
9434               list = item = build_tree_list (NULL_TREE, t);
9435             else
9436               {
9437                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9438                 item = TREE_CHAIN (item);
9439               }
9440           }
9441
9442         if (ffebld_left (ffebld_head (b)) == NULL)
9443           low = ffecom_integer_one_node;
9444         else
9445           low = ffecom_expr (ffebld_left (ffebld_head (b)));
9446         low = convert (ffecom_f2c_ftnlen_type_node, low);
9447
9448         back = build_tree_list (low, t);
9449         TREE_CHAIN (back) = backlist;
9450         backlist = back;
9451       }
9452
9453     for (item = backlist; item != NULL_TREE; item = TREE_CHAIN (item))
9454       {
9455         if (TREE_VALUE (item) == NULL_TREE)
9456           baseoff = TREE_PURPOSE (item);
9457         else
9458           baseoff = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
9459                               TREE_PURPOSE (item),
9460                               ffecom_2 (MULT_EXPR,
9461                                         ffecom_f2c_ftnlen_type_node,
9462                                         TREE_VALUE (item),
9463                                         baseoff));
9464       }
9465
9466     /* backlist now dead, along with all TREE_PURPOSEs on it.  */
9467
9468     baseoff = build_tree_list (NULL_TREE, baseoff);
9469     TREE_CHAIN (baseoff) = list;
9470
9471     numelem = build_tree_list (NULL_TREE, numelem);
9472     TREE_CHAIN (numelem) = baseoff;
9473
9474     numdim = build_tree_list (NULL_TREE, numdim);
9475     TREE_CHAIN (numdim) = numelem;
9476
9477     item = build_array_type (ffecom_f2c_ftnlen_type_node,
9478                              build_range_type (integer_type_node,
9479                                                integer_zero_node,
9480                                                build_int_2
9481                                                ((int) ffesymbol_rank (s)
9482                                                 + 2, 0)));
9483     list = build (CONSTRUCTOR, item, NULL_TREE, numdim);
9484     TREE_CONSTANT (list) = 1;
9485     TREE_STATIC (list) = 1;
9486
9487     var = ffecom_get_invented_identifier ("__g77_dims_%d", mynumber++);
9488     var = build_decl (VAR_DECL, var, item);
9489     TREE_STATIC (var) = 1;
9490     DECL_INITIAL (var) = error_mark_node;
9491     var = start_decl (var, FALSE);
9492     finish_decl (var, list, FALSE);
9493
9494     var = ffecom_1 (ADDR_EXPR, build_pointer_type (item), var);
9495
9496     return var;
9497   }
9498 }
9499
9500 /* Essentially does a "fold (build1 (code, type, node))" while checking
9501    for certain housekeeping things.
9502
9503    NOTE: for building an ADDR_EXPR around a FUNCTION_DECL, use
9504    ffecom_1_fn instead.  */
9505
9506 tree
9507 ffecom_1 (enum tree_code code, tree type, tree node)
9508 {
9509   tree item;
9510
9511   if ((node == error_mark_node)
9512       || (type == error_mark_node))
9513     return error_mark_node;
9514
9515   if (code == ADDR_EXPR)
9516     {
9517       if (!mark_addressable (node))
9518         assert ("can't mark_addressable this node!" == NULL);
9519     }
9520
9521   switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9522     {
9523       tree realtype;
9524
9525     case REALPART_EXPR:
9526       item = build (COMPONENT_REF, type, node, TYPE_FIELDS (TREE_TYPE (node)));
9527       break;
9528
9529     case IMAGPART_EXPR:
9530       item = build (COMPONENT_REF, type, node, TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (node))));
9531       break;
9532
9533
9534     case NEGATE_EXPR:
9535       if (TREE_CODE (type) != RECORD_TYPE)
9536         {
9537           item = build1 (code, type, node);
9538           break;
9539         }
9540       node = ffecom_stabilize_aggregate_ (node);
9541       realtype = TREE_TYPE (TYPE_FIELDS (type));
9542       item =
9543         ffecom_2 (COMPLEX_EXPR, type,
9544                   ffecom_1 (NEGATE_EXPR, realtype,
9545                             ffecom_1 (REALPART_EXPR, realtype,
9546                                       node)),
9547                   ffecom_1 (NEGATE_EXPR, realtype,
9548                             ffecom_1 (IMAGPART_EXPR, realtype,
9549                                       node)));
9550       break;
9551
9552     default:
9553       item = build1 (code, type, node);
9554       break;
9555     }
9556
9557   if (TREE_SIDE_EFFECTS (node))
9558     TREE_SIDE_EFFECTS (item) = 1;
9559   if ((code == ADDR_EXPR) && staticp (node))
9560     TREE_CONSTANT (item) = 1;
9561   return fold (item);
9562 }
9563
9564 /* Like ffecom_1 (ADDR_EXPR, TREE_TYPE (node), node), except
9565    handles TREE_CODE (node) == FUNCTION_DECL.  In particular,
9566    does not set TREE_ADDRESSABLE (because calling an inline
9567    function does not mean the function needs to be separately
9568    compiled).  */
9569
9570 tree
9571 ffecom_1_fn (tree node)
9572 {
9573   tree item;
9574   tree type;
9575
9576   if (node == error_mark_node)
9577     return error_mark_node;
9578
9579   type = build_type_variant (TREE_TYPE (node),
9580                              TREE_READONLY (node),
9581                              TREE_THIS_VOLATILE (node));
9582   item = build1 (ADDR_EXPR,
9583                  build_pointer_type (type), node);
9584   if (TREE_SIDE_EFFECTS (node))
9585     TREE_SIDE_EFFECTS (item) = 1;
9586   if (staticp (node))
9587     TREE_CONSTANT (item) = 1;
9588   return fold (item);
9589 }
9590
9591 /* Essentially does a "fold (build (code, type, node1, node2))" while
9592    checking for certain housekeeping things.  */
9593
9594 tree
9595 ffecom_2 (enum tree_code code, tree type, tree node1,
9596           tree node2)
9597 {
9598   tree item;
9599
9600   if ((node1 == error_mark_node)
9601       || (node2 == error_mark_node)
9602       || (type == error_mark_node))
9603     return error_mark_node;
9604
9605   switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9606     {
9607       tree a, b, c, d, realtype;
9608
9609     case CONJ_EXPR:
9610       assert ("no CONJ_EXPR support yet" == NULL);
9611       return error_mark_node;
9612
9613     case COMPLEX_EXPR:
9614       item = build_tree_list (TYPE_FIELDS (type), node1);
9615       TREE_CHAIN (item) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), node2);
9616       item = build (CONSTRUCTOR, type, NULL_TREE, item);
9617       break;
9618
9619     case PLUS_EXPR:
9620       if (TREE_CODE (type) != RECORD_TYPE)
9621         {
9622           item = build (code, type, node1, node2);
9623           break;
9624         }
9625       node1 = ffecom_stabilize_aggregate_ (node1);
9626       node2 = ffecom_stabilize_aggregate_ (node2);
9627       realtype = TREE_TYPE (TYPE_FIELDS (type));
9628       item =
9629         ffecom_2 (COMPLEX_EXPR, type,
9630                   ffecom_2 (PLUS_EXPR, realtype,
9631                             ffecom_1 (REALPART_EXPR, realtype,
9632                                       node1),
9633                             ffecom_1 (REALPART_EXPR, realtype,
9634                                       node2)),
9635                   ffecom_2 (PLUS_EXPR, realtype,
9636                             ffecom_1 (IMAGPART_EXPR, realtype,
9637                                       node1),
9638                             ffecom_1 (IMAGPART_EXPR, realtype,
9639                                       node2)));
9640       break;
9641
9642     case MINUS_EXPR:
9643       if (TREE_CODE (type) != RECORD_TYPE)
9644         {
9645           item = build (code, type, node1, node2);
9646           break;
9647         }
9648       node1 = ffecom_stabilize_aggregate_ (node1);
9649       node2 = ffecom_stabilize_aggregate_ (node2);
9650       realtype = TREE_TYPE (TYPE_FIELDS (type));
9651       item =
9652         ffecom_2 (COMPLEX_EXPR, type,
9653                   ffecom_2 (MINUS_EXPR, realtype,
9654                             ffecom_1 (REALPART_EXPR, realtype,
9655                                       node1),
9656                             ffecom_1 (REALPART_EXPR, realtype,
9657                                       node2)),
9658                   ffecom_2 (MINUS_EXPR, realtype,
9659                             ffecom_1 (IMAGPART_EXPR, realtype,
9660                                       node1),
9661                             ffecom_1 (IMAGPART_EXPR, realtype,
9662                                       node2)));
9663       break;
9664
9665     case MULT_EXPR:
9666       if (TREE_CODE (type) != RECORD_TYPE)
9667         {
9668           item = build (code, type, node1, node2);
9669           break;
9670         }
9671       node1 = ffecom_stabilize_aggregate_ (node1);
9672       node2 = ffecom_stabilize_aggregate_ (node2);
9673       realtype = TREE_TYPE (TYPE_FIELDS (type));
9674       a = save_expr (ffecom_1 (REALPART_EXPR, realtype,
9675                                node1));
9676       b = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
9677                                node1));
9678       c = save_expr (ffecom_1 (REALPART_EXPR, realtype,
9679                                node2));
9680       d = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
9681                                node2));
9682       item =
9683         ffecom_2 (COMPLEX_EXPR, type,
9684                   ffecom_2 (MINUS_EXPR, realtype,
9685                             ffecom_2 (MULT_EXPR, realtype,
9686                                       a,
9687                                       c),
9688                             ffecom_2 (MULT_EXPR, realtype,
9689                                       b,
9690                                       d)),
9691                   ffecom_2 (PLUS_EXPR, realtype,
9692                             ffecom_2 (MULT_EXPR, realtype,
9693                                       a,
9694                                       d),
9695                             ffecom_2 (MULT_EXPR, realtype,
9696                                       c,
9697                                       b)));
9698       break;
9699
9700     case EQ_EXPR:
9701       if ((TREE_CODE (node1) != RECORD_TYPE)
9702           && (TREE_CODE (node2) != RECORD_TYPE))
9703         {
9704           item = build (code, type, node1, node2);
9705           break;
9706         }
9707       assert (TREE_CODE (node1) == RECORD_TYPE);
9708       assert (TREE_CODE (node2) == RECORD_TYPE);
9709       node1 = ffecom_stabilize_aggregate_ (node1);
9710       node2 = ffecom_stabilize_aggregate_ (node2);
9711       realtype = TREE_TYPE (TYPE_FIELDS (type));
9712       item =
9713         ffecom_2 (TRUTH_ANDIF_EXPR, type,
9714                   ffecom_2 (code, type,
9715                             ffecom_1 (REALPART_EXPR, realtype,
9716                                       node1),
9717                             ffecom_1 (REALPART_EXPR, realtype,
9718                                       node2)),
9719                   ffecom_2 (code, type,
9720                             ffecom_1 (IMAGPART_EXPR, realtype,
9721                                       node1),
9722                             ffecom_1 (IMAGPART_EXPR, realtype,
9723                                       node2)));
9724       break;
9725
9726     case NE_EXPR:
9727       if ((TREE_CODE (node1) != RECORD_TYPE)
9728           && (TREE_CODE (node2) != RECORD_TYPE))
9729         {
9730           item = build (code, type, node1, node2);
9731           break;
9732         }
9733       assert (TREE_CODE (node1) == RECORD_TYPE);
9734       assert (TREE_CODE (node2) == RECORD_TYPE);
9735       node1 = ffecom_stabilize_aggregate_ (node1);
9736       node2 = ffecom_stabilize_aggregate_ (node2);
9737       realtype = TREE_TYPE (TYPE_FIELDS (type));
9738       item =
9739         ffecom_2 (TRUTH_ORIF_EXPR, type,
9740                   ffecom_2 (code, type,
9741                             ffecom_1 (REALPART_EXPR, realtype,
9742                                       node1),
9743                             ffecom_1 (REALPART_EXPR, realtype,
9744                                       node2)),
9745                   ffecom_2 (code, type,
9746                             ffecom_1 (IMAGPART_EXPR, realtype,
9747                                       node1),
9748                             ffecom_1 (IMAGPART_EXPR, realtype,
9749                                       node2)));
9750       break;
9751
9752     default:
9753       item = build (code, type, node1, node2);
9754       break;
9755     }
9756
9757   if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2))
9758     TREE_SIDE_EFFECTS (item) = 1;
9759   return fold (item);
9760 }
9761
9762 /* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint
9763
9764    ffesymbol s;  // the ENTRY point itself
9765    if (ffecom_2pass_advise_entrypoint(s))
9766        // the ENTRY point has been accepted
9767
9768    Does whatever compiler needs to do when it learns about the entrypoint,
9769    like determine the return type of the master function, count the
9770    number of entrypoints, etc.  Returns FALSE if the return type is
9771    not compatible with the return type(s) of other entrypoint(s).
9772
9773    NOTE: for every call to this fn that returns TRUE, _do_entrypoint must
9774    later (after _finish_progunit) be called with the same entrypoint(s)
9775    as passed to this fn for which TRUE was returned.
9776
9777    03-Jan-92  JCB  2.0
9778       Return FALSE if the return type conflicts with previous entrypoints.  */
9779
9780 bool
9781 ffecom_2pass_advise_entrypoint (ffesymbol entry)
9782 {
9783   ffebld list;                  /* opITEM. */
9784   ffebld mlist;                 /* opITEM. */
9785   ffebld plist;                 /* opITEM. */
9786   ffebld arg;                   /* ffebld_head(opITEM). */
9787   ffebld item;                  /* opITEM. */
9788   ffesymbol s;                  /* ffebld_symter(arg). */
9789   ffeinfoBasictype bt = ffesymbol_basictype (entry);
9790   ffeinfoKindtype kt = ffesymbol_kindtype (entry);
9791   ffetargetCharacterSize size = ffesymbol_size (entry);
9792   bool ok;
9793
9794   if (ffecom_num_entrypoints_ == 0)
9795     {                           /* First entrypoint, make list of main
9796                                    arglist's dummies. */
9797       assert (ffecom_primary_entry_ != NULL);
9798
9799       ffecom_master_bt_ = ffesymbol_basictype (ffecom_primary_entry_);
9800       ffecom_master_kt_ = ffesymbol_kindtype (ffecom_primary_entry_);
9801       ffecom_master_size_ = ffesymbol_size (ffecom_primary_entry_);
9802
9803       for (plist = NULL, list = ffesymbol_dummyargs (ffecom_primary_entry_);
9804            list != NULL;
9805            list = ffebld_trail (list))
9806         {
9807           arg = ffebld_head (list);
9808           if (ffebld_op (arg) != FFEBLD_opSYMTER)
9809             continue;           /* Alternate return or some such thing. */
9810           item = ffebld_new_item (arg, NULL);
9811           if (plist == NULL)
9812             ffecom_master_arglist_ = item;
9813           else
9814             ffebld_set_trail (plist, item);
9815           plist = item;
9816         }
9817     }
9818
9819   /* If necessary, scan entry arglist for alternate returns.  Do this scan
9820      apparently redundantly (it's done below to UNIONize the arglists) so
9821      that we don't complain about RETURN 1 if an offending ENTRY is the only
9822      one with an alternate return.  */
9823
9824   if (!ffecom_is_altreturning_)
9825     {
9826       for (list = ffesymbol_dummyargs (entry);
9827            list != NULL;
9828            list = ffebld_trail (list))
9829         {
9830           arg = ffebld_head (list);
9831           if (ffebld_op (arg) == FFEBLD_opSTAR)
9832             {
9833               ffecom_is_altreturning_ = TRUE;
9834               break;
9835             }
9836         }
9837     }
9838
9839   /* Now check type compatibility. */
9840
9841   switch (ffecom_master_bt_)
9842     {
9843     case FFEINFO_basictypeNONE:
9844       ok = (bt != FFEINFO_basictypeCHARACTER);
9845       break;
9846
9847     case FFEINFO_basictypeCHARACTER:
9848       ok
9849         = (bt == FFEINFO_basictypeCHARACTER)
9850         && (kt == ffecom_master_kt_)
9851         && (size == ffecom_master_size_);
9852       break;
9853
9854     case FFEINFO_basictypeANY:
9855       return FALSE;             /* Just don't bother. */
9856
9857     default:
9858       if (bt == FFEINFO_basictypeCHARACTER)
9859         {
9860           ok = FALSE;
9861           break;
9862         }
9863       ok = TRUE;
9864       if ((bt != ffecom_master_bt_) || (kt != ffecom_master_kt_))
9865         {
9866           ffecom_master_bt_ = FFEINFO_basictypeNONE;
9867           ffecom_master_kt_ = FFEINFO_kindtypeNONE;
9868         }
9869       break;
9870     }
9871
9872   if (!ok)
9873     {
9874       ffebad_start (FFEBAD_ENTRY_CONFLICTS);
9875       ffest_ffebad_here_current_stmt (0);
9876       ffebad_finish ();
9877       return FALSE;             /* Can't handle entrypoint. */
9878     }
9879
9880   /* Entrypoint type compatible with previous types. */
9881
9882   ++ffecom_num_entrypoints_;
9883
9884   /* Master-arg-list = UNION(Master-arg-list,entry-arg-list). */
9885
9886   for (list = ffesymbol_dummyargs (entry);
9887        list != NULL;
9888        list = ffebld_trail (list))
9889     {
9890       arg = ffebld_head (list);
9891       if (ffebld_op (arg) != FFEBLD_opSYMTER)
9892         continue;               /* Alternate return or some such thing. */
9893       s = ffebld_symter (arg);
9894       for (plist = NULL, mlist = ffecom_master_arglist_;
9895            mlist != NULL;
9896            plist = mlist, mlist = ffebld_trail (mlist))
9897         {                       /* plist points to previous item for easy
9898                                    appending of arg. */
9899           if (ffebld_symter (ffebld_head (mlist)) == s)
9900             break;              /* Already have this arg in the master list. */
9901         }
9902       if (mlist != NULL)
9903         continue;               /* Already have this arg in the master list. */
9904
9905       /* Append this arg to the master list. */
9906
9907       item = ffebld_new_item (arg, NULL);
9908       if (plist == NULL)
9909         ffecom_master_arglist_ = item;
9910       else
9911         ffebld_set_trail (plist, item);
9912     }
9913
9914   return TRUE;
9915 }
9916
9917 /* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint
9918
9919    ffesymbol s;  // the ENTRY point itself
9920    ffecom_2pass_do_entrypoint(s);
9921
9922    Does whatever compiler needs to do to make the entrypoint actually
9923    happen.  Must be called for each entrypoint after
9924    ffecom_finish_progunit is called.  */
9925
9926 void
9927 ffecom_2pass_do_entrypoint (ffesymbol entry)
9928 {
9929   static int mfn_num = 0;
9930   static int ent_num;
9931
9932   if (mfn_num != ffecom_num_fns_)
9933     {                           /* First entrypoint for this program unit. */
9934       ent_num = 1;
9935       mfn_num = ffecom_num_fns_;
9936       ffecom_do_entry_ (ffecom_primary_entry_, 0);
9937     }
9938   else
9939     ++ent_num;
9940
9941   --ffecom_num_entrypoints_;
9942
9943   ffecom_do_entry_ (entry, ent_num);
9944 }
9945
9946 /* Essentially does a "fold (build (code, type, node1, node2))" while
9947    checking for certain housekeeping things.  Always sets
9948    TREE_SIDE_EFFECTS.  */
9949
9950 tree
9951 ffecom_2s (enum tree_code code, tree type, tree node1,
9952            tree node2)
9953 {
9954   tree item;
9955
9956   if ((node1 == error_mark_node)
9957       || (node2 == error_mark_node)
9958       || (type == error_mark_node))
9959     return error_mark_node;
9960
9961   item = build (code, type, node1, node2);
9962   TREE_SIDE_EFFECTS (item) = 1;
9963   return fold (item);
9964 }
9965
9966 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
9967    checking for certain housekeeping things.  */
9968
9969 tree
9970 ffecom_3 (enum tree_code code, tree type, tree node1,
9971           tree node2, tree node3)
9972 {
9973   tree item;
9974
9975   if ((node1 == error_mark_node)
9976       || (node2 == error_mark_node)
9977       || (node3 == error_mark_node)
9978       || (type == error_mark_node))
9979     return error_mark_node;
9980
9981   item = build (code, type, node1, node2, node3);
9982   if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2)
9983       || (node3 != NULL_TREE && TREE_SIDE_EFFECTS (node3)))
9984     TREE_SIDE_EFFECTS (item) = 1;
9985   return fold (item);
9986 }
9987
9988 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
9989    checking for certain housekeeping things.  Always sets
9990    TREE_SIDE_EFFECTS.  */
9991
9992 tree
9993 ffecom_3s (enum tree_code code, tree type, tree node1,
9994            tree node2, tree node3)
9995 {
9996   tree item;
9997
9998   if ((node1 == error_mark_node)
9999       || (node2 == error_mark_node)
10000       || (node3 == error_mark_node)
10001       || (type == error_mark_node))
10002     return error_mark_node;
10003
10004   item = build (code, type, node1, node2, node3);
10005   TREE_SIDE_EFFECTS (item) = 1;
10006   return fold (item);
10007 }
10008
10009 /* ffecom_arg_expr -- Transform argument expr into gcc tree
10010
10011    See use by ffecom_list_expr.
10012
10013    If expression is NULL, returns an integer zero tree.  If it is not
10014    a CHARACTER expression, returns whatever ffecom_expr
10015    returns and sets the length return value to NULL_TREE.  Otherwise
10016    generates code to evaluate the character expression, returns the proper
10017    pointer to the result, but does NOT set the length return value to a tree
10018    that specifies the length of the result.  (In other words, the length
10019    variable is always set to NULL_TREE, because a length is never passed.)
10020
10021    21-Dec-91  JCB  1.1
10022       Don't set returned length, since nobody needs it (yet; someday if
10023       we allow CHARACTER*(*) dummies to statement functions, we'll need
10024       it).  */
10025
10026 tree
10027 ffecom_arg_expr (ffebld expr, tree *length)
10028 {
10029   tree ign;
10030
10031   *length = NULL_TREE;
10032
10033   if (expr == NULL)
10034     return integer_zero_node;
10035
10036   if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10037     return ffecom_expr (expr);
10038
10039   return ffecom_arg_ptr_to_expr (expr, &ign);
10040 }
10041
10042 /* Transform expression into constant argument-pointer-to-expression tree.
10043
10044    If the expression can be transformed into a argument-pointer-to-expression
10045    tree that is constant, that is done, and the tree returned.  Else
10046    NULL_TREE is returned.
10047
10048    That way, a caller can attempt to provide compile-time initialization
10049    of a variable and, if that fails, *then* choose to start a new block
10050    and resort to using temporaries, as appropriate.  */
10051
10052 tree
10053 ffecom_arg_ptr_to_const_expr (ffebld expr, tree *length)
10054 {
10055   if (! expr)
10056     return integer_zero_node;
10057
10058   if (ffebld_op (expr) == FFEBLD_opANY)
10059     {
10060       if (length)
10061         *length = error_mark_node;
10062       return error_mark_node;
10063     }
10064
10065   if (ffebld_arity (expr) == 0
10066       && (ffebld_op (expr) != FFEBLD_opSYMTER
10067           || ffebld_where (expr) == FFEINFO_whereCOMMON
10068           || ffebld_where (expr) == FFEINFO_whereGLOBAL
10069           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10070     {
10071       tree t;
10072
10073       t = ffecom_arg_ptr_to_expr (expr, length);
10074       assert (TREE_CONSTANT (t));
10075       assert (! length || TREE_CONSTANT (*length));
10076       return t;
10077     }
10078
10079   if (length
10080       && ffebld_size (expr) != FFETARGET_charactersizeNONE)
10081     *length = build_int_2 (ffebld_size (expr), 0);
10082   else if (length)
10083     *length = NULL_TREE;
10084   return NULL_TREE;
10085 }
10086
10087 /* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree
10088
10089    See use by ffecom_list_ptr_to_expr.
10090
10091    If expression is NULL, returns an integer zero tree.  If it is not
10092    a CHARACTER expression, returns whatever ffecom_ptr_to_expr
10093    returns and sets the length return value to NULL_TREE.  Otherwise
10094    generates code to evaluate the character expression, returns the proper
10095    pointer to the result, AND sets the length return value to a tree that
10096    specifies the length of the result.
10097
10098    If the length argument is NULL, this is a slightly special
10099    case of building a FORMAT expression, that is, an expression that
10100    will be used at run time without regard to length.  For the current
10101    implementation, which uses the libf2c library, this means it is nice
10102    to append a null byte to the end of the expression, where feasible,
10103    to make sure any diagnostic about the FORMAT string terminates at
10104    some useful point.
10105
10106    For now, treat %REF(char-expr) as the same as char-expr with a NULL
10107    length argument.  This might even be seen as a feature, if a null
10108    byte can always be appended.  */
10109
10110 tree
10111 ffecom_arg_ptr_to_expr (ffebld expr, tree *length)
10112 {
10113   tree item;
10114   tree ign_length;
10115   ffecomConcatList_ catlist;
10116
10117   if (length != NULL)
10118     *length = NULL_TREE;
10119
10120   if (expr == NULL)
10121     return integer_zero_node;
10122
10123   switch (ffebld_op (expr))
10124     {
10125     case FFEBLD_opPERCENT_VAL:
10126       if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10127         return ffecom_expr (ffebld_left (expr));
10128       {
10129         tree temp_exp;
10130         tree temp_length;
10131
10132         temp_exp = ffecom_arg_ptr_to_expr (ffebld_left (expr), &temp_length);
10133         if (temp_exp == error_mark_node)
10134           return error_mark_node;
10135
10136         return ffecom_1 (INDIRECT_REF, TREE_TYPE (TREE_TYPE (temp_exp)),
10137                          temp_exp);
10138       }
10139
10140     case FFEBLD_opPERCENT_REF:
10141       if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10142         return ffecom_ptr_to_expr (ffebld_left (expr));
10143       if (length != NULL)
10144         {
10145           ign_length = NULL_TREE;
10146           length = &ign_length;
10147         }
10148       expr = ffebld_left (expr);
10149       break;
10150
10151     case FFEBLD_opPERCENT_DESCR:
10152       switch (ffeinfo_basictype (ffebld_info (expr)))
10153         {
10154 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10155         case FFEINFO_basictypeHOLLERITH:
10156 #endif
10157         case FFEINFO_basictypeCHARACTER:
10158           break;                /* Passed by descriptor anyway. */
10159
10160         default:
10161           item = ffecom_ptr_to_expr (expr);
10162           if (item != error_mark_node)
10163             *length = TYPE_SIZE (TREE_TYPE (TREE_TYPE (item)));
10164           break;
10165         }
10166       break;
10167
10168     default:
10169       break;
10170     }
10171
10172 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10173   if ((ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeHOLLERITH)
10174       && (length != NULL))
10175     {                           /* Pass Hollerith by descriptor. */
10176       ffetargetHollerith h;
10177
10178       assert (ffebld_op (expr) == FFEBLD_opCONTER);
10179       h = ffebld_cu_val_hollerith (ffebld_constant_union
10180                                    (ffebld_conter (expr)));
10181       *length
10182         = build_int_2 (h.length, 0);
10183       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10184     }
10185 #endif
10186
10187   if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10188     return ffecom_ptr_to_expr (expr);
10189
10190   assert (ffeinfo_kindtype (ffebld_info (expr))
10191           == FFEINFO_kindtypeCHARACTER1);
10192
10193   while (ffebld_op (expr) == FFEBLD_opPAREN)
10194     expr = ffebld_left (expr);
10195
10196   catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
10197   switch (ffecom_concat_list_count_ (catlist))
10198     {
10199     case 0:                     /* Shouldn't happen, but in case it does... */
10200       if (length != NULL)
10201         {
10202           *length = ffecom_f2c_ftnlen_zero_node;
10203           TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10204         }
10205       ffecom_concat_list_kill_ (catlist);
10206       return null_pointer_node;
10207
10208     case 1:                     /* The (fairly) easy case. */
10209       if (length == NULL)
10210         ffecom_char_args_with_null_ (&item, &ign_length,
10211                                      ffecom_concat_list_expr_ (catlist, 0));
10212       else
10213         ffecom_char_args_ (&item, length,
10214                            ffecom_concat_list_expr_ (catlist, 0));
10215       ffecom_concat_list_kill_ (catlist);
10216       assert (item != NULL_TREE);
10217       return item;
10218
10219     default:                    /* Must actually concatenate things. */
10220       break;
10221     }
10222
10223   {
10224     int count = ffecom_concat_list_count_ (catlist);
10225     int i;
10226     tree lengths;
10227     tree items;
10228     tree length_array;
10229     tree item_array;
10230     tree citem;
10231     tree clength;
10232     tree temporary;
10233     tree num;
10234     tree known_length;
10235     ffetargetCharacterSize sz;
10236
10237     sz = ffecom_concat_list_maxlen_ (catlist);
10238     /* ~~Kludge! */
10239     assert (sz != FFETARGET_charactersizeNONE);
10240
10241 #ifdef HOHO
10242     length_array
10243       = lengths
10244       = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
10245                              FFETARGET_charactersizeNONE, count, TRUE);
10246     item_array
10247       = items
10248       = ffecom_push_tempvar (ffecom_f2c_address_type_node,
10249                              FFETARGET_charactersizeNONE, count, TRUE);
10250     temporary = ffecom_push_tempvar (char_type_node,
10251                                      sz, -1, TRUE);
10252 #else
10253     {
10254       tree hook;
10255
10256       hook = ffebld_nonter_hook (expr);
10257       assert (hook);
10258       assert (TREE_CODE (hook) == TREE_VEC);
10259       assert (TREE_VEC_LENGTH (hook) == 3);
10260       length_array = lengths = TREE_VEC_ELT (hook, 0);
10261       item_array = items = TREE_VEC_ELT (hook, 1);
10262       temporary = TREE_VEC_ELT (hook, 2);
10263     }
10264 #endif
10265
10266     known_length = ffecom_f2c_ftnlen_zero_node;
10267
10268     for (i = 0; i < count; ++i)
10269       {
10270         if ((i == count)
10271             && (length == NULL))
10272           ffecom_char_args_with_null_ (&citem, &clength,
10273                                        ffecom_concat_list_expr_ (catlist, i));
10274         else
10275           ffecom_char_args_ (&citem, &clength,
10276                              ffecom_concat_list_expr_ (catlist, i));
10277         if ((citem == error_mark_node)
10278             || (clength == error_mark_node))
10279           {
10280             ffecom_concat_list_kill_ (catlist);
10281             *length = error_mark_node;
10282             return error_mark_node;
10283           }
10284
10285         items
10286           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
10287                       ffecom_modify (void_type_node,
10288                                      ffecom_2 (ARRAY_REF,
10289                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
10290                                                item_array,
10291                                                build_int_2 (i, 0)),
10292                                      citem),
10293                       items);
10294         clength = ffecom_save_tree (clength);
10295         if (length != NULL)
10296           known_length
10297             = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
10298                         known_length,
10299                         clength);
10300         lengths
10301           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
10302                       ffecom_modify (void_type_node,
10303                                      ffecom_2 (ARRAY_REF,
10304                    TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
10305                                                length_array,
10306                                                build_int_2 (i, 0)),
10307                                      clength),
10308                       lengths);
10309       }
10310
10311     temporary = ffecom_1 (ADDR_EXPR,
10312                           build_pointer_type (TREE_TYPE (temporary)),
10313                           temporary);
10314
10315     item = build_tree_list (NULL_TREE, temporary);
10316     TREE_CHAIN (item)
10317       = build_tree_list (NULL_TREE,
10318                          ffecom_1 (ADDR_EXPR,
10319                                    build_pointer_type (TREE_TYPE (items)),
10320                                    items));
10321     TREE_CHAIN (TREE_CHAIN (item))
10322       = build_tree_list (NULL_TREE,
10323                          ffecom_1 (ADDR_EXPR,
10324                                    build_pointer_type (TREE_TYPE (lengths)),
10325                                    lengths));
10326     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
10327       = build_tree_list
10328         (NULL_TREE,
10329          ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
10330                    convert (ffecom_f2c_ftnlen_type_node,
10331                             build_int_2 (count, 0))));
10332     num = build_int_2 (sz, 0);
10333     TREE_TYPE (num) = ffecom_f2c_ftnlen_type_node;
10334     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item))))
10335       = build_tree_list (NULL_TREE, num);
10336
10337     item = ffecom_call_gfrt (FFECOM_gfrtCAT, item, NULL_TREE);
10338     TREE_SIDE_EFFECTS (item) = 1;
10339     item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (temporary),
10340                      item,
10341                      temporary);
10342
10343     if (length != NULL)
10344       *length = known_length;
10345   }
10346
10347   ffecom_concat_list_kill_ (catlist);
10348   assert (item != NULL_TREE);
10349   return item;
10350 }
10351
10352 /* Generate call to run-time function.
10353
10354    The first arg is the GNU Fortran Run-Time function index, the second
10355    arg is the list of arguments to pass to it.  Returned is the expression
10356    (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the
10357    result (which may be void).  */
10358
10359 tree
10360 ffecom_call_gfrt (ffecomGfrt ix, tree args, tree hook)
10361 {
10362   return ffecom_call_ (ffecom_gfrt_tree_ (ix),
10363                        ffecom_gfrt_kindtype (ix),
10364                        ffe_is_f2c_library () && ffecom_gfrt_complex_[ix],
10365                        NULL_TREE, args, NULL_TREE, NULL,
10366                        NULL, NULL_TREE, TRUE, hook);
10367 }
10368
10369 /* Transform constant-union to tree.  */
10370
10371 tree
10372 ffecom_constantunion (ffebldConstantUnion *cu, ffeinfoBasictype bt,
10373                       ffeinfoKindtype kt, tree tree_type)
10374 {
10375   tree item;
10376
10377   switch (bt)
10378     {
10379     case FFEINFO_basictypeINTEGER:
10380       {
10381         int val;
10382
10383         switch (kt)
10384           {
10385 #if FFETARGET_okINTEGER1
10386           case FFEINFO_kindtypeINTEGER1:
10387             val = ffebld_cu_val_integer1 (*cu);
10388             break;
10389 #endif
10390
10391 #if FFETARGET_okINTEGER2
10392           case FFEINFO_kindtypeINTEGER2:
10393             val = ffebld_cu_val_integer2 (*cu);
10394             break;
10395 #endif
10396
10397 #if FFETARGET_okINTEGER3
10398           case FFEINFO_kindtypeINTEGER3:
10399             val = ffebld_cu_val_integer3 (*cu);
10400             break;
10401 #endif
10402
10403 #if FFETARGET_okINTEGER4
10404           case FFEINFO_kindtypeINTEGER4:
10405             val = ffebld_cu_val_integer4 (*cu);
10406             break;
10407 #endif
10408
10409           default:
10410             assert ("bad INTEGER constant kind type" == NULL);
10411             /* Fall through. */
10412           case FFEINFO_kindtypeANY:
10413             return error_mark_node;
10414           }
10415         item = build_int_2 (val, (val < 0) ? -1 : 0);
10416         TREE_TYPE (item) = tree_type;
10417       }
10418       break;
10419
10420     case FFEINFO_basictypeLOGICAL:
10421       {
10422         int val;
10423
10424         switch (kt)
10425           {
10426 #if FFETARGET_okLOGICAL1
10427           case FFEINFO_kindtypeLOGICAL1:
10428             val = ffebld_cu_val_logical1 (*cu);
10429             break;
10430 #endif
10431
10432 #if FFETARGET_okLOGICAL2
10433           case FFEINFO_kindtypeLOGICAL2:
10434             val = ffebld_cu_val_logical2 (*cu);
10435             break;
10436 #endif
10437
10438 #if FFETARGET_okLOGICAL3
10439           case FFEINFO_kindtypeLOGICAL3:
10440             val = ffebld_cu_val_logical3 (*cu);
10441             break;
10442 #endif
10443
10444 #if FFETARGET_okLOGICAL4
10445           case FFEINFO_kindtypeLOGICAL4:
10446             val = ffebld_cu_val_logical4 (*cu);
10447             break;
10448 #endif
10449
10450           default:
10451             assert ("bad LOGICAL constant kind type" == NULL);
10452             /* Fall through. */
10453           case FFEINFO_kindtypeANY:
10454             return error_mark_node;
10455           }
10456         item = build_int_2 (val, (val < 0) ? -1 : 0);
10457         TREE_TYPE (item) = tree_type;
10458       }
10459       break;
10460
10461     case FFEINFO_basictypeREAL:
10462       {
10463         REAL_VALUE_TYPE val;
10464
10465         switch (kt)
10466           {
10467 #if FFETARGET_okREAL1
10468           case FFEINFO_kindtypeREAL1:
10469             val = ffetarget_value_real1 (ffebld_cu_val_real1 (*cu));
10470             break;
10471 #endif
10472
10473 #if FFETARGET_okREAL2
10474           case FFEINFO_kindtypeREAL2:
10475             val = ffetarget_value_real2 (ffebld_cu_val_real2 (*cu));
10476             break;
10477 #endif
10478
10479 #if FFETARGET_okREAL3
10480           case FFEINFO_kindtypeREAL3:
10481             val = ffetarget_value_real3 (ffebld_cu_val_real3 (*cu));
10482             break;
10483 #endif
10484
10485 #if FFETARGET_okREAL4
10486           case FFEINFO_kindtypeREAL4:
10487             val = ffetarget_value_real4 (ffebld_cu_val_real4 (*cu));
10488             break;
10489 #endif
10490
10491           default:
10492             assert ("bad REAL constant kind type" == NULL);
10493             /* Fall through. */
10494           case FFEINFO_kindtypeANY:
10495             return error_mark_node;
10496           }
10497         item = build_real (tree_type, val);
10498       }
10499       break;
10500
10501     case FFEINFO_basictypeCOMPLEX:
10502       {
10503         REAL_VALUE_TYPE real;
10504         REAL_VALUE_TYPE imag;
10505         tree el_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
10506
10507         switch (kt)
10508           {
10509 #if FFETARGET_okCOMPLEX1
10510           case FFEINFO_kindtypeREAL1:
10511             real = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).real);
10512             imag = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).imaginary);
10513             break;
10514 #endif
10515
10516 #if FFETARGET_okCOMPLEX2
10517           case FFEINFO_kindtypeREAL2:
10518             real = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).real);
10519             imag = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).imaginary);
10520             break;
10521 #endif
10522
10523 #if FFETARGET_okCOMPLEX3
10524           case FFEINFO_kindtypeREAL3:
10525             real = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).real);
10526             imag = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).imaginary);
10527             break;
10528 #endif
10529
10530 #if FFETARGET_okCOMPLEX4
10531           case FFEINFO_kindtypeREAL4:
10532             real = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).real);
10533             imag = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).imaginary);
10534             break;
10535 #endif
10536
10537           default:
10538             assert ("bad REAL constant kind type" == NULL);
10539             /* Fall through. */
10540           case FFEINFO_kindtypeANY:
10541             return error_mark_node;
10542           }
10543         item = ffecom_build_complex_constant_ (tree_type,
10544                                                build_real (el_type, real),
10545                                                build_real (el_type, imag));
10546       }
10547       break;
10548
10549     case FFEINFO_basictypeCHARACTER:
10550       {                         /* Happens only in DATA and similar contexts. */
10551         ffetargetCharacter1 val;
10552
10553         switch (kt)
10554           {
10555 #if FFETARGET_okCHARACTER1
10556           case FFEINFO_kindtypeLOGICAL1:
10557             val = ffebld_cu_val_character1 (*cu);
10558             break;
10559 #endif
10560
10561           default:
10562             assert ("bad CHARACTER constant kind type" == NULL);
10563             /* Fall through. */
10564           case FFEINFO_kindtypeANY:
10565             return error_mark_node;
10566           }
10567         item = build_string (ffetarget_length_character1 (val),
10568                              ffetarget_text_character1 (val));
10569         TREE_TYPE (item)
10570           = build_type_variant (build_array_type (char_type_node,
10571                                                   build_range_type
10572                                                   (integer_type_node,
10573                                                    integer_one_node,
10574                                                    build_int_2
10575                                                 (ffetarget_length_character1
10576                                                  (val), 0))),
10577                                 1, 0);
10578       }
10579       break;
10580
10581     case FFEINFO_basictypeHOLLERITH:
10582       {
10583         ffetargetHollerith h;
10584
10585         h = ffebld_cu_val_hollerith (*cu);
10586
10587         /* If not at least as wide as default INTEGER, widen it.  */
10588         if (h.length >= FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE)
10589           item = build_string (h.length, h.text);
10590         else
10591           {
10592             char str[FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE];
10593
10594             memcpy (str, h.text, h.length);
10595             memset (&str[h.length], ' ',
10596                     FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE
10597                     - h.length);
10598             item = build_string (FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE,
10599                                  str);
10600           }
10601         TREE_TYPE (item)
10602           = build_type_variant (build_array_type (char_type_node,
10603                                                   build_range_type
10604                                                   (integer_type_node,
10605                                                    integer_one_node,
10606                                                    build_int_2
10607                                                    (h.length, 0))),
10608                                 1, 0);
10609       }
10610       break;
10611
10612     case FFEINFO_basictypeTYPELESS:
10613       {
10614         ffetargetInteger1 ival;
10615         ffetargetTypeless tless;
10616         ffebad error;
10617
10618         tless = ffebld_cu_val_typeless (*cu);
10619         error = ffetarget_convert_integer1_typeless (&ival, tless);
10620         assert (error == FFEBAD);
10621
10622         item = build_int_2 ((int) ival, 0);
10623       }
10624       break;
10625
10626     default:
10627       assert ("not yet on constant type" == NULL);
10628       /* Fall through. */
10629     case FFEINFO_basictypeANY:
10630       return error_mark_node;
10631     }
10632
10633   TREE_CONSTANT (item) = 1;
10634
10635   return item;
10636 }
10637
10638 /* Transform expression into constant tree.
10639
10640    If the expression can be transformed into a tree that is constant,
10641    that is done, and the tree returned.  Else NULL_TREE is returned.
10642
10643    That way, a caller can attempt to provide compile-time initialization
10644    of a variable and, if that fails, *then* choose to start a new block
10645    and resort to using temporaries, as appropriate.  */
10646
10647 tree
10648 ffecom_const_expr (ffebld expr)
10649 {
10650   if (! expr)
10651     return integer_zero_node;
10652
10653   if (ffebld_op (expr) == FFEBLD_opANY)
10654     return error_mark_node;
10655
10656   if (ffebld_arity (expr) == 0
10657       && (ffebld_op (expr) != FFEBLD_opSYMTER
10658 #if NEWCOMMON
10659           /* ~~Enable once common/equivalence is handled properly?  */
10660           || ffebld_where (expr) == FFEINFO_whereCOMMON
10661 #endif
10662           || ffebld_where (expr) == FFEINFO_whereGLOBAL
10663           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10664     {
10665       tree t;
10666
10667       t = ffecom_expr (expr);
10668       assert (TREE_CONSTANT (t));
10669       return t;
10670     }
10671
10672   return NULL_TREE;
10673 }
10674
10675 /* Handy way to make a field in a struct/union.  */
10676
10677 tree
10678 ffecom_decl_field (tree context, tree prevfield,
10679                    const char *name, tree type)
10680 {
10681   tree field;
10682
10683   field = build_decl (FIELD_DECL, get_identifier (name), type);
10684   DECL_CONTEXT (field) = context;
10685   DECL_ALIGN (field) = 0;
10686   DECL_USER_ALIGN (field) = 0;
10687   if (prevfield != NULL_TREE)
10688     TREE_CHAIN (prevfield) = field;
10689
10690   return field;
10691 }
10692
10693 void
10694 ffecom_close_include (FILE *f)
10695 {
10696   ffecom_close_include_ (f);
10697 }
10698
10699 int
10700 ffecom_decode_include_option (char *spec)
10701 {
10702   return ffecom_decode_include_option_ (spec);
10703 }
10704
10705 /* End a compound statement (block).  */
10706
10707 tree
10708 ffecom_end_compstmt (void)
10709 {
10710   return bison_rule_compstmt_ ();
10711 }
10712
10713 /* ffecom_end_transition -- Perform end transition on all symbols
10714
10715    ffecom_end_transition();
10716
10717    Calls ffecom_sym_end_transition for each global and local symbol.  */
10718
10719 void
10720 ffecom_end_transition ()
10721 {
10722   ffebld item;
10723
10724   if (ffe_is_ffedebug ())
10725     fprintf (dmpout, "; end_stmt_transition\n");
10726
10727   ffecom_list_blockdata_ = NULL;
10728   ffecom_list_common_ = NULL;
10729
10730   ffesymbol_drive (ffecom_sym_end_transition);
10731   if (ffe_is_ffedebug ())
10732     {
10733       ffestorag_report ();
10734     }
10735
10736   ffecom_start_progunit_ ();
10737
10738   for (item = ffecom_list_blockdata_;
10739        item != NULL;
10740        item = ffebld_trail (item))
10741     {
10742       ffebld callee;
10743       ffesymbol s;
10744       tree dt;
10745       tree t;
10746       tree var;
10747       static int number = 0;
10748
10749       callee = ffebld_head (item);
10750       s = ffebld_symter (callee);
10751       t = ffesymbol_hook (s).decl_tree;
10752       if (t == NULL_TREE)
10753         {
10754           s = ffecom_sym_transform_ (s);
10755           t = ffesymbol_hook (s).decl_tree;
10756         }
10757
10758       dt = build_pointer_type (TREE_TYPE (t));
10759
10760       var = build_decl (VAR_DECL,
10761                         ffecom_get_invented_identifier ("__g77_forceload_%d",
10762                                                         number++),
10763                         dt);
10764       DECL_EXTERNAL (var) = 0;
10765       TREE_STATIC (var) = 1;
10766       TREE_PUBLIC (var) = 0;
10767       DECL_INITIAL (var) = error_mark_node;
10768       TREE_USED (var) = 1;
10769
10770       var = start_decl (var, FALSE);
10771
10772       t = ffecom_1 (ADDR_EXPR, dt, t);
10773
10774       finish_decl (var, t, FALSE);
10775     }
10776
10777   /* This handles any COMMON areas that weren't referenced but have, for
10778      example, important initial data.  */
10779
10780   for (item = ffecom_list_common_;
10781        item != NULL;
10782        item = ffebld_trail (item))
10783     ffecom_transform_common_ (ffebld_symter (ffebld_head (item)));
10784
10785   ffecom_list_common_ = NULL;
10786 }
10787
10788 /* ffecom_exec_transition -- Perform exec transition on all symbols
10789
10790    ffecom_exec_transition();
10791
10792    Calls ffecom_sym_exec_transition for each global and local symbol.
10793    Make sure error updating not inhibited.  */
10794
10795 void
10796 ffecom_exec_transition ()
10797 {
10798   bool inhibited;
10799
10800   if (ffe_is_ffedebug ())
10801     fprintf (dmpout, "; exec_stmt_transition\n");
10802
10803   inhibited = ffebad_inhibit ();
10804   ffebad_set_inhibit (FALSE);
10805
10806   ffesymbol_drive (ffecom_sym_exec_transition); /* Don't retract! */
10807   ffeequiv_exec_transition ();  /* Handle all pending EQUIVALENCEs. */
10808   if (ffe_is_ffedebug ())
10809     {
10810       ffestorag_report ();
10811     }
10812
10813   if (inhibited)
10814     ffebad_set_inhibit (TRUE);
10815 }
10816
10817 /* Handle assignment statement.
10818
10819    Convert dest and source using ffecom_expr, then join them
10820    with an ASSIGN op and pass the whole thing to expand_expr_stmt.  */
10821
10822 void
10823 ffecom_expand_let_stmt (ffebld dest, ffebld source)
10824 {
10825   tree dest_tree;
10826   tree dest_length;
10827   tree source_tree;
10828   tree expr_tree;
10829
10830   if (ffeinfo_basictype (ffebld_info (dest)) != FFEINFO_basictypeCHARACTER)
10831     {
10832       bool dest_used;
10833       tree assign_temp;
10834
10835       /* This attempts to replicate the test below, but must not be
10836          true when the test below is false.  (Always err on the side
10837          of creating unused temporaries, to avoid ICEs.)  */
10838       if (ffebld_op (dest) != FFEBLD_opSYMTER
10839           || ((dest_tree = ffesymbol_hook (ffebld_symter (dest)).decl_tree)
10840               && (TREE_CODE (dest_tree) != VAR_DECL
10841                   || TREE_ADDRESSABLE (dest_tree))))
10842         {
10843           ffecom_prepare_expr_ (source, dest);
10844           dest_used = TRUE;
10845         }
10846       else
10847         {
10848           ffecom_prepare_expr_ (source, NULL);
10849           dest_used = FALSE;
10850         }
10851
10852       ffecom_prepare_expr_w (NULL_TREE, dest);
10853
10854       /* For COMPLEX assignment like C1=C2, if partial overlap is possible,
10855          create a temporary through which the assignment is to take place,
10856          since MODIFY_EXPR doesn't handle partial overlap properly.  */
10857       if (ffebld_basictype (dest) == FFEINFO_basictypeCOMPLEX
10858           && ffecom_possible_partial_overlap_ (dest, source))
10859         {
10860           assign_temp = ffecom_make_tempvar ("complex_let",
10861                                              ffecom_tree_type
10862                                              [ffebld_basictype (dest)]
10863                                              [ffebld_kindtype (dest)],
10864                                              FFETARGET_charactersizeNONE,
10865                                              -1);
10866         }
10867       else
10868         assign_temp = NULL_TREE;
10869
10870       ffecom_prepare_end ();
10871
10872       dest_tree = ffecom_expr_w (NULL_TREE, dest);
10873       if (dest_tree == error_mark_node)
10874         return;
10875
10876       if ((TREE_CODE (dest_tree) != VAR_DECL)
10877           || TREE_ADDRESSABLE (dest_tree))
10878         source_tree = ffecom_expr_ (source, dest_tree, dest, &dest_used,
10879                                     FALSE, FALSE);
10880       else
10881         {
10882           assert (! dest_used);
10883           dest_used = FALSE;
10884           source_tree = ffecom_expr (source);
10885         }
10886       if (source_tree == error_mark_node)
10887         return;
10888
10889       if (dest_used)
10890         expr_tree = source_tree;
10891       else if (assign_temp)
10892         {
10893 #ifdef MOVE_EXPR
10894           /* The back end understands a conceptual move (evaluate source;
10895              store into dest), so use that, in case it can determine
10896              that it is going to use, say, two registers as temporaries
10897              anyway.  So don't use the temp (and someday avoid generating
10898              it, once this code starts triggering regularly).  */
10899           expr_tree = ffecom_2s (MOVE_EXPR, void_type_node,
10900                                  dest_tree,
10901                                  source_tree);
10902 #else
10903           expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
10904                                  assign_temp,
10905                                  source_tree);
10906           expand_expr_stmt (expr_tree);
10907           expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
10908                                  dest_tree,
10909                                  assign_temp);
10910 #endif
10911         }
10912       else
10913         expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
10914                                dest_tree,
10915                                source_tree);
10916
10917       expand_expr_stmt (expr_tree);
10918       return;
10919     }
10920
10921   ffecom_prepare_let_char_ (ffebld_size_known (dest), source);
10922   ffecom_prepare_expr_w (NULL_TREE, dest);
10923
10924   ffecom_prepare_end ();
10925
10926   ffecom_char_args_ (&dest_tree, &dest_length, dest);
10927   ffecom_let_char_ (dest_tree, dest_length, ffebld_size_known (dest),
10928                     source);
10929 }
10930
10931 /* ffecom_expr -- Transform expr into gcc tree
10932
10933    tree t;
10934    ffebld expr;  // FFE expression.
10935    tree = ffecom_expr(expr);
10936
10937    Recursive descent on expr while making corresponding tree nodes and
10938    attaching type info and such.  */
10939
10940 tree
10941 ffecom_expr (ffebld expr)
10942 {
10943   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, FALSE, FALSE);
10944 }
10945
10946 /* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT.  */
10947
10948 tree
10949 ffecom_expr_assign (ffebld expr)
10950 {
10951   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
10952 }
10953
10954 /* Like ffecom_expr_rw, but return tree usable for ASSIGN.  */
10955
10956 tree
10957 ffecom_expr_assign_w (ffebld expr)
10958 {
10959   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
10960 }
10961
10962 /* Transform expr for use as into read/write tree and stabilize the
10963    reference.  Not for use on CHARACTER expressions.
10964
10965    Recursive descent on expr while making corresponding tree nodes and
10966    attaching type info and such.  */
10967
10968 tree
10969 ffecom_expr_rw (tree type, ffebld expr)
10970 {
10971   assert (expr != NULL);
10972   /* Different target types not yet supported.  */
10973   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
10974
10975   return stabilize_reference (ffecom_expr (expr));
10976 }
10977
10978 /* Transform expr for use as into write tree and stabilize the
10979    reference.  Not for use on CHARACTER expressions.
10980
10981    Recursive descent on expr while making corresponding tree nodes and
10982    attaching type info and such.  */
10983
10984 tree
10985 ffecom_expr_w (tree type, ffebld expr)
10986 {
10987   assert (expr != NULL);
10988   /* Different target types not yet supported.  */
10989   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
10990
10991   return stabilize_reference (ffecom_expr (expr));
10992 }
10993
10994 /* Do global stuff.  */
10995
10996 void
10997 ffecom_finish_compile ()
10998 {
10999   assert (ffecom_outer_function_decl_ == NULL_TREE);
11000   assert (current_function_decl == NULL_TREE);
11001
11002   ffeglobal_drive (ffecom_finish_global_);
11003 }
11004
11005 /* Public entry point for front end to access finish_decl.  */
11006
11007 void
11008 ffecom_finish_decl (tree decl, tree init, bool is_top_level)
11009 {
11010   assert (!is_top_level);
11011   finish_decl (decl, init, FALSE);
11012 }
11013
11014 /* Finish a program unit.  */
11015
11016 void
11017 ffecom_finish_progunit ()
11018 {
11019   ffecom_end_compstmt ();
11020
11021   ffecom_previous_function_decl_ = current_function_decl;
11022   ffecom_which_entrypoint_decl_ = NULL_TREE;
11023
11024   finish_function (0);
11025 }
11026
11027 /* Wrapper for get_identifier.  pattern is sprintf-like.  */
11028
11029 tree
11030 ffecom_get_invented_identifier (const char *pattern, ...)
11031 {
11032   tree decl;
11033   char *nam;
11034   va_list ap;
11035
11036   va_start (ap, pattern);
11037   if (vasprintf (&nam, pattern, ap) == 0)
11038     abort ();
11039   va_end (ap);
11040   decl = get_identifier (nam);
11041   free (nam);
11042   IDENTIFIER_INVENTED (decl) = 1;
11043   return decl;
11044 }
11045
11046 ffeinfoBasictype
11047 ffecom_gfrt_basictype (ffecomGfrt gfrt)
11048 {
11049   assert (gfrt < FFECOM_gfrt);
11050
11051   switch (ffecom_gfrt_type_[gfrt])
11052     {
11053     case FFECOM_rttypeVOID_:
11054     case FFECOM_rttypeVOIDSTAR_:
11055       return FFEINFO_basictypeNONE;
11056
11057     case FFECOM_rttypeFTNINT_:
11058       return FFEINFO_basictypeINTEGER;
11059
11060     case FFECOM_rttypeINTEGER_:
11061       return FFEINFO_basictypeINTEGER;
11062
11063     case FFECOM_rttypeLONGINT_:
11064       return FFEINFO_basictypeINTEGER;
11065
11066     case FFECOM_rttypeLOGICAL_:
11067       return FFEINFO_basictypeLOGICAL;
11068
11069     case FFECOM_rttypeREAL_F2C_:
11070     case FFECOM_rttypeREAL_GNU_:
11071       return FFEINFO_basictypeREAL;
11072
11073     case FFECOM_rttypeCOMPLEX_F2C_:
11074     case FFECOM_rttypeCOMPLEX_GNU_:
11075       return FFEINFO_basictypeCOMPLEX;
11076
11077     case FFECOM_rttypeDOUBLE_:
11078     case FFECOM_rttypeDOUBLEREAL_:
11079       return FFEINFO_basictypeREAL;
11080
11081     case FFECOM_rttypeDBLCMPLX_F2C_:
11082     case FFECOM_rttypeDBLCMPLX_GNU_:
11083       return FFEINFO_basictypeCOMPLEX;
11084
11085     case FFECOM_rttypeCHARACTER_:
11086       return FFEINFO_basictypeCHARACTER;
11087
11088     default:
11089       return FFEINFO_basictypeANY;
11090     }
11091 }
11092
11093 ffeinfoKindtype
11094 ffecom_gfrt_kindtype (ffecomGfrt gfrt)
11095 {
11096   assert (gfrt < FFECOM_gfrt);
11097
11098   switch (ffecom_gfrt_type_[gfrt])
11099     {
11100     case FFECOM_rttypeVOID_:
11101     case FFECOM_rttypeVOIDSTAR_:
11102       return FFEINFO_kindtypeNONE;
11103
11104     case FFECOM_rttypeFTNINT_:
11105       return FFEINFO_kindtypeINTEGER1;
11106
11107     case FFECOM_rttypeINTEGER_:
11108       return FFEINFO_kindtypeINTEGER1;
11109
11110     case FFECOM_rttypeLONGINT_:
11111       return FFEINFO_kindtypeINTEGER4;
11112
11113     case FFECOM_rttypeLOGICAL_:
11114       return FFEINFO_kindtypeLOGICAL1;
11115
11116     case FFECOM_rttypeREAL_F2C_:
11117     case FFECOM_rttypeREAL_GNU_:
11118       return FFEINFO_kindtypeREAL1;
11119
11120     case FFECOM_rttypeCOMPLEX_F2C_:
11121     case FFECOM_rttypeCOMPLEX_GNU_:
11122       return FFEINFO_kindtypeREAL1;
11123
11124     case FFECOM_rttypeDOUBLE_:
11125     case FFECOM_rttypeDOUBLEREAL_:
11126       return FFEINFO_kindtypeREAL2;
11127
11128     case FFECOM_rttypeDBLCMPLX_F2C_:
11129     case FFECOM_rttypeDBLCMPLX_GNU_:
11130       return FFEINFO_kindtypeREAL2;
11131
11132     case FFECOM_rttypeCHARACTER_:
11133       return FFEINFO_kindtypeCHARACTER1;
11134
11135     default:
11136       return FFEINFO_kindtypeANY;
11137     }
11138 }
11139
11140 void
11141 ffecom_init_0 ()
11142 {
11143   tree endlink;
11144   int i;
11145   int j;
11146   tree t;
11147   tree field;
11148   ffetype type;
11149   ffetype base_type;
11150   tree double_ftype_double;
11151   tree float_ftype_float;
11152   tree ldouble_ftype_ldouble;
11153   tree ffecom_tree_ptr_to_fun_type_void;
11154
11155   /* This block of code comes from the now-obsolete cktyps.c.  It checks
11156      whether the compiler environment is buggy in known ways, some of which
11157      would, if not explicitly checked here, result in subtle bugs in g77.  */
11158
11159   if (ffe_is_do_internal_checks ())
11160     {
11161       static const char names[][12]
11162         =
11163       {"bar", "bletch", "foo", "foobar"};
11164       const char *name;
11165       unsigned long ul;
11166       double fl;
11167
11168       name = bsearch ("foo", &names[0], ARRAY_SIZE (names), sizeof (names[0]),
11169                       (int (*)(const void *, const void *)) strcmp);
11170       if (name != &names[0][2])
11171         {
11172           assert ("bsearch doesn't work, #define FFEPROJ_BSEARCH 0 in proj.h"
11173                   == NULL);
11174           abort ();
11175         }
11176
11177       ul = strtoul ("123456789", NULL, 10);
11178       if (ul != 123456789L)
11179         {
11180           assert ("strtoul doesn't have enough range, #define FFEPROJ_STRTOUL 0\
11181  in proj.h" == NULL);
11182           abort ();
11183         }
11184
11185       fl = atof ("56.789");
11186       if ((fl < 56.788) || (fl > 56.79))
11187         {
11188           assert ("atof not type double, fix your #include <stdio.h>"
11189                   == NULL);
11190           abort ();
11191         }
11192     }
11193
11194   ffecom_outer_function_decl_ = NULL_TREE;
11195   current_function_decl = NULL_TREE;
11196   named_labels = NULL_TREE;
11197   current_binding_level = NULL_BINDING_LEVEL;
11198   free_binding_level = NULL_BINDING_LEVEL;
11199   /* Make the binding_level structure for global names.  */
11200   pushlevel (0);
11201   global_binding_level = current_binding_level;
11202   current_binding_level->prep_state = 2;
11203
11204   build_common_tree_nodes (1);
11205
11206   /* Define `int' and `char' first so that dbx will output them first.  */
11207   pushdecl (build_decl (TYPE_DECL, get_identifier ("int"),
11208                         integer_type_node));
11209   /* CHARACTER*1 is unsigned in ICHAR contexts.  */
11210   char_type_node = make_unsigned_type (CHAR_TYPE_SIZE);
11211   pushdecl (build_decl (TYPE_DECL, get_identifier ("char"),
11212                         char_type_node));
11213   pushdecl (build_decl (TYPE_DECL, get_identifier ("long int"),
11214                         long_integer_type_node));
11215   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned int"),
11216                         unsigned_type_node));
11217   pushdecl (build_decl (TYPE_DECL, get_identifier ("long unsigned int"),
11218                         long_unsigned_type_node));
11219   pushdecl (build_decl (TYPE_DECL, get_identifier ("long long int"),
11220                         long_long_integer_type_node));
11221   pushdecl (build_decl (TYPE_DECL, get_identifier ("long long unsigned int"),
11222                         long_long_unsigned_type_node));
11223   pushdecl (build_decl (TYPE_DECL, get_identifier ("short int"),
11224                         short_integer_type_node));
11225   pushdecl (build_decl (TYPE_DECL, get_identifier ("short unsigned int"),
11226                         short_unsigned_type_node));
11227
11228   /* Set the sizetype before we make other types.  This *should* be the
11229      first type we create.  */
11230
11231   set_sizetype
11232     (TREE_TYPE (IDENTIFIER_GLOBAL_VALUE (get_identifier (SIZE_TYPE))));
11233   ffecom_typesize_pointer_
11234     = TREE_INT_CST_LOW (TYPE_SIZE (sizetype)) / BITS_PER_UNIT;
11235
11236   build_common_tree_nodes_2 (0);
11237
11238   /* Define both `signed char' and `unsigned char'.  */
11239   pushdecl (build_decl (TYPE_DECL, get_identifier ("signed char"),
11240                         signed_char_type_node));
11241
11242   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned char"),
11243                         unsigned_char_type_node));
11244
11245   pushdecl (build_decl (TYPE_DECL, get_identifier ("float"),
11246                         float_type_node));
11247   pushdecl (build_decl (TYPE_DECL, get_identifier ("double"),
11248                         double_type_node));
11249   pushdecl (build_decl (TYPE_DECL, get_identifier ("long double"),
11250                         long_double_type_node));
11251
11252   /* For now, override what build_common_tree_nodes has done.  */
11253   complex_integer_type_node = ffecom_make_complex_type_ (integer_type_node);
11254   complex_float_type_node = ffecom_make_complex_type_ (float_type_node);
11255   complex_double_type_node = ffecom_make_complex_type_ (double_type_node);
11256   complex_long_double_type_node
11257     = ffecom_make_complex_type_ (long_double_type_node);
11258
11259   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex int"),
11260                         complex_integer_type_node));
11261   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex float"),
11262                         complex_float_type_node));
11263   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex double"),
11264                         complex_double_type_node));
11265   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex long double"),
11266                         complex_long_double_type_node));
11267
11268   pushdecl (build_decl (TYPE_DECL, get_identifier ("void"),
11269                         void_type_node));
11270   /* We are not going to have real types in C with less than byte alignment,
11271      so we might as well not have any types that claim to have it.  */
11272   TYPE_ALIGN (void_type_node) = BITS_PER_UNIT;
11273   TYPE_USER_ALIGN (void_type_node) = 0;
11274
11275   string_type_node = build_pointer_type (char_type_node);
11276
11277   ffecom_tree_fun_type_void
11278     = build_function_type (void_type_node, NULL_TREE);
11279
11280   ffecom_tree_ptr_to_fun_type_void
11281     = build_pointer_type (ffecom_tree_fun_type_void);
11282
11283   endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE);
11284
11285   float_ftype_float
11286     = build_function_type (float_type_node,
11287                            tree_cons (NULL_TREE, float_type_node, endlink));
11288
11289   double_ftype_double
11290     = build_function_type (double_type_node,
11291                            tree_cons (NULL_TREE, double_type_node, endlink));
11292
11293   ldouble_ftype_ldouble
11294     = build_function_type (long_double_type_node,
11295                            tree_cons (NULL_TREE, long_double_type_node,
11296                                       endlink));
11297
11298   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11299     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11300       {
11301         ffecom_tree_type[i][j] = NULL_TREE;
11302         ffecom_tree_fun_type[i][j] = NULL_TREE;
11303         ffecom_tree_ptr_to_fun_type[i][j] = NULL_TREE;
11304         ffecom_f2c_typecode_[i][j] = -1;
11305       }
11306
11307   /* Set up standard g77 types.  Note that INTEGER and LOGICAL are set
11308      to size FLOAT_TYPE_SIZE because they have to be the same size as
11309      REAL, which also is FLOAT_TYPE_SIZE, according to the standard.
11310      Compiler options and other such stuff that change the ways these
11311      types are set should not affect this particular setup.  */
11312
11313   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1]
11314     = t = make_signed_type (FLOAT_TYPE_SIZE);
11315   pushdecl (build_decl (TYPE_DECL, get_identifier ("integer"),
11316                         t));
11317   type = ffetype_new ();
11318   base_type = type;
11319   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER1,
11320                     type);
11321   ffetype_set_ams (type,
11322                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11323                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11324   ffetype_set_star (base_type,
11325                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11326                     type);
11327   ffetype_set_kind (base_type, 1, type);
11328   ffecom_typesize_integer1_ = ffetype_size (type);
11329   assert (ffetype_size (type) == sizeof (ffetargetInteger1));
11330
11331   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER1]
11332     = t = make_unsigned_type (FLOAT_TYPE_SIZE); /* HOLLERITH means unsigned. */
11333   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned"),
11334                         t));
11335
11336   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER2]
11337     = t = make_signed_type (CHAR_TYPE_SIZE);
11338   pushdecl (build_decl (TYPE_DECL, get_identifier ("byte"),
11339                         t));
11340   type = ffetype_new ();
11341   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER2,
11342                     type);
11343   ffetype_set_ams (type,
11344                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11345                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11346   ffetype_set_star (base_type,
11347                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11348                     type);
11349   ffetype_set_kind (base_type, 3, type);
11350   assert (ffetype_size (type) == sizeof (ffetargetInteger2));
11351
11352   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER2]
11353     = t = make_unsigned_type (CHAR_TYPE_SIZE);
11354   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned byte"),
11355                         t));
11356
11357   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER3]
11358     = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11359   pushdecl (build_decl (TYPE_DECL, get_identifier ("word"),
11360                         t));
11361   type = ffetype_new ();
11362   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER3,
11363                     type);
11364   ffetype_set_ams (type,
11365                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11366                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11367   ffetype_set_star (base_type,
11368                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11369                     type);
11370   ffetype_set_kind (base_type, 6, type);
11371   assert (ffetype_size (type) == sizeof (ffetargetInteger3));
11372
11373   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER3]
11374     = t = make_unsigned_type (CHAR_TYPE_SIZE * 2);
11375   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned word"),
11376                         t));
11377
11378   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER4]
11379     = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11380   pushdecl (build_decl (TYPE_DECL, get_identifier ("integer4"),
11381                         t));
11382   type = ffetype_new ();
11383   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER4,
11384                     type);
11385   ffetype_set_ams (type,
11386                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11387                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11388   ffetype_set_star (base_type,
11389                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11390                     type);
11391   ffetype_set_kind (base_type, 2, type);
11392   assert (ffetype_size (type) == sizeof (ffetargetInteger4));
11393
11394   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER4]
11395     = t = make_unsigned_type (FLOAT_TYPE_SIZE * 2);
11396   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned4"),
11397                         t));
11398
11399 #if 0
11400   if (ffe_is_do_internal_checks ()
11401       && LONG_TYPE_SIZE != FLOAT_TYPE_SIZE
11402       && LONG_TYPE_SIZE != CHAR_TYPE_SIZE
11403       && LONG_TYPE_SIZE != SHORT_TYPE_SIZE
11404       && LONG_TYPE_SIZE != LONG_LONG_TYPE_SIZE)
11405     {
11406       fprintf (stderr, "Sorry, no g77 support for LONG_TYPE_SIZE (%d bits) yet.\n",
11407                LONG_TYPE_SIZE);
11408     }
11409 #endif
11410
11411   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL1]
11412     = t = make_signed_type (FLOAT_TYPE_SIZE);
11413   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical"),
11414                         t));
11415   type = ffetype_new ();
11416   base_type = type;
11417   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL1,
11418                     type);
11419   ffetype_set_ams (type,
11420                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11421                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11422   ffetype_set_star (base_type,
11423                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11424                     type);
11425   ffetype_set_kind (base_type, 1, type);
11426   assert (ffetype_size (type) == sizeof (ffetargetLogical1));
11427
11428   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL2]
11429     = t = make_signed_type (CHAR_TYPE_SIZE);
11430   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical2"),
11431                         t));
11432   type = ffetype_new ();
11433   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL2,
11434                     type);
11435   ffetype_set_ams (type,
11436                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11437                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11438   ffetype_set_star (base_type,
11439                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11440                     type);
11441   ffetype_set_kind (base_type, 3, type);
11442   assert (ffetype_size (type) == sizeof (ffetargetLogical2));
11443
11444   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL3]
11445     = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11446   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical3"),
11447                         t));
11448   type = ffetype_new ();
11449   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL3,
11450                     type);
11451   ffetype_set_ams (type,
11452                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11453                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11454   ffetype_set_star (base_type,
11455                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11456                     type);
11457   ffetype_set_kind (base_type, 6, type);
11458   assert (ffetype_size (type) == sizeof (ffetargetLogical3));
11459
11460   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL4]
11461     = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11462   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical4"),
11463                         t));
11464   type = ffetype_new ();
11465   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL4,
11466                     type);
11467   ffetype_set_ams (type,
11468                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11469                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11470   ffetype_set_star (base_type,
11471                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11472                     type);
11473   ffetype_set_kind (base_type, 2, type);
11474   assert (ffetype_size (type) == sizeof (ffetargetLogical4));
11475
11476   ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11477     = t = make_node (REAL_TYPE);
11478   TYPE_PRECISION (t) = FLOAT_TYPE_SIZE;
11479   pushdecl (build_decl (TYPE_DECL, get_identifier ("real"),
11480                         t));
11481   layout_type (t);
11482   type = ffetype_new ();
11483   base_type = type;
11484   ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL1,
11485                     type);
11486   ffetype_set_ams (type,
11487                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11488                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11489   ffetype_set_star (base_type,
11490                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11491                     type);
11492   ffetype_set_kind (base_type, 1, type);
11493   ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11494     = FFETARGET_f2cTYREAL;
11495   assert (ffetype_size (type) == sizeof (ffetargetReal1));
11496
11497   ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREALDOUBLE]
11498     = t = make_node (REAL_TYPE);
11499   TYPE_PRECISION (t) = FLOAT_TYPE_SIZE * 2;     /* Always twice REAL. */
11500   pushdecl (build_decl (TYPE_DECL, get_identifier ("double precision"),
11501                         t));
11502   layout_type (t);
11503   type = ffetype_new ();
11504   ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE,
11505                     type);
11506   ffetype_set_ams (type,
11507                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11508                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11509   ffetype_set_star (base_type,
11510                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11511                     type);
11512   ffetype_set_kind (base_type, 2, type);
11513   ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]
11514     = FFETARGET_f2cTYDREAL;
11515   assert (ffetype_size (type) == sizeof (ffetargetReal2));
11516
11517   ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11518     = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]);
11519   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex"),
11520                         t));
11521   type = ffetype_new ();
11522   base_type = type;
11523   ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL1,
11524                     type);
11525   ffetype_set_ams (type,
11526                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11527                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11528   ffetype_set_star (base_type,
11529                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11530                     type);
11531   ffetype_set_kind (base_type, 1, type);
11532   ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11533     = FFETARGET_f2cTYCOMPLEX;
11534   assert (ffetype_size (type) == sizeof (ffetargetComplex1));
11535
11536   ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREALDOUBLE]
11537     = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]);
11538   pushdecl (build_decl (TYPE_DECL, get_identifier ("double complex"),
11539                         t));
11540   type = ffetype_new ();
11541   ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREALDOUBLE,
11542                     type);
11543   ffetype_set_ams (type,
11544                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11545                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11546   ffetype_set_star (base_type,
11547                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11548                     type);
11549   ffetype_set_kind (base_type, 2,
11550                     type);
11551   ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL2]
11552     = FFETARGET_f2cTYDCOMPLEX;
11553   assert (ffetype_size (type) == sizeof (ffetargetComplex2));
11554
11555   /* Make function and ptr-to-function types for non-CHARACTER types. */
11556
11557   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11558     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11559       {
11560         if ((t = ffecom_tree_type[i][j]) != NULL_TREE)
11561           {
11562             if (i == FFEINFO_basictypeINTEGER)
11563               {
11564                 /* Figure out the smallest INTEGER type that can hold
11565                    a pointer on this machine. */
11566                 if (GET_MODE_SIZE (TYPE_MODE (t))
11567                     >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
11568                   {
11569                     if ((ffecom_pointer_kind_ == FFEINFO_kindtypeNONE)
11570                         || (GET_MODE_SIZE (TYPE_MODE (ffecom_tree_type[i][ffecom_pointer_kind_]))
11571                             > GET_MODE_SIZE (TYPE_MODE (t))))
11572                       ffecom_pointer_kind_ = j;
11573                   }
11574               }
11575             else if (i == FFEINFO_basictypeCOMPLEX)
11576               t = void_type_node;
11577             /* For f2c compatibility, REAL functions are really
11578                implemented as DOUBLE PRECISION.  */
11579             else if ((i == FFEINFO_basictypeREAL)
11580                      && (j == FFEINFO_kindtypeREAL1))
11581               t = ffecom_tree_type
11582                 [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2];
11583
11584             t = ffecom_tree_fun_type[i][j] = build_function_type (t,
11585                                                                   NULL_TREE);
11586             ffecom_tree_ptr_to_fun_type[i][j] = build_pointer_type (t);
11587           }
11588       }
11589
11590   /* Set up pointer types.  */
11591
11592   if (ffecom_pointer_kind_ == FFEINFO_basictypeNONE)
11593     fatal_error ("no INTEGER type can hold a pointer on this configuration");
11594   else if (0 && ffe_is_do_internal_checks ())
11595     fprintf (stderr, "Pointer type kt=%d\n", ffecom_pointer_kind_);
11596   ffetype_set_kind (ffeinfo_type (FFEINFO_basictypeINTEGER,
11597                                   FFEINFO_kindtypeINTEGERDEFAULT),
11598                     7,
11599                     ffeinfo_type (FFEINFO_basictypeINTEGER,
11600                                   ffecom_pointer_kind_));
11601
11602   if (ffe_is_ugly_assign ())
11603     ffecom_label_kind_ = ffecom_pointer_kind_;  /* Require ASSIGN etc to this. */
11604   else
11605     ffecom_label_kind_ = FFEINFO_kindtypeINTEGERDEFAULT;
11606   if (0 && ffe_is_do_internal_checks ())
11607     fprintf (stderr, "Label type kt=%d\n", ffecom_label_kind_);
11608
11609   ffecom_integer_type_node
11610     = ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1];
11611   ffecom_integer_zero_node = convert (ffecom_integer_type_node,
11612                                       integer_zero_node);
11613   ffecom_integer_one_node = convert (ffecom_integer_type_node,
11614                                      integer_one_node);
11615
11616   /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional.
11617      Turns out that by TYLONG, runtime/libI77/lio.h really means
11618      "whatever size an ftnint is".  For consistency and sanity,
11619      com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen
11620      all are INTEGER, which we also make out of whatever back-end
11621      integer type is FLOAT_TYPE_SIZE bits wide.  This change, from
11622      LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to
11623      accommodate machines like the Alpha.  Note that this suggests
11624      f2c and libf2c are missing a distinction perhaps needed on
11625      some machines between "int" and "long int".  -- burley 0.5.5 950215 */
11626
11627   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, FLOAT_TYPE_SIZE,
11628                             FFETARGET_f2cTYLONG);
11629   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, SHORT_TYPE_SIZE,
11630                             FFETARGET_f2cTYSHORT);
11631   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, CHAR_TYPE_SIZE,
11632                             FFETARGET_f2cTYINT1);
11633   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, LONG_LONG_TYPE_SIZE,
11634                             FFETARGET_f2cTYQUAD);
11635   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, FLOAT_TYPE_SIZE,
11636                             FFETARGET_f2cTYLOGICAL);
11637   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, SHORT_TYPE_SIZE,
11638                             FFETARGET_f2cTYLOGICAL2);
11639   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, CHAR_TYPE_SIZE,
11640                             FFETARGET_f2cTYLOGICAL1);
11641   /* ~~~Not really such a type in libf2c, e.g. I/O support?  */
11642   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, LONG_LONG_TYPE_SIZE,
11643                             FFETARGET_f2cTYQUAD);
11644
11645   /* CHARACTER stuff is all special-cased, so it is not handled in the above
11646      loop.  CHARACTER items are built as arrays of unsigned char.  */
11647
11648   ffecom_tree_type[FFEINFO_basictypeCHARACTER]
11649     [FFEINFO_kindtypeCHARACTER1] = t = char_type_node;
11650   type = ffetype_new ();
11651   base_type = type;
11652   ffeinfo_set_type (FFEINFO_basictypeCHARACTER,
11653                     FFEINFO_kindtypeCHARACTER1,
11654                     type);
11655   ffetype_set_ams (type,
11656                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11657                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11658   ffetype_set_kind (base_type, 1, type);
11659   assert (ffetype_size (type)
11660           == sizeof (((ffetargetCharacter1) { 0, NULL }).text[0]));
11661
11662   ffecom_tree_fun_type[FFEINFO_basictypeCHARACTER]
11663     [FFEINFO_kindtypeCHARACTER1] = ffecom_tree_fun_type_void;
11664   ffecom_tree_ptr_to_fun_type[FFEINFO_basictypeCHARACTER]
11665     [FFEINFO_kindtypeCHARACTER1]
11666     = ffecom_tree_ptr_to_fun_type_void;
11667   ffecom_f2c_typecode_[FFEINFO_basictypeCHARACTER][FFEINFO_kindtypeCHARACTER1]
11668     = FFETARGET_f2cTYCHAR;
11669
11670   ffecom_f2c_typecode_[FFEINFO_basictypeANY][FFEINFO_kindtypeANY]
11671     = 0;
11672
11673   /* Make multi-return-value type and fields. */
11674
11675   ffecom_multi_type_node_ = make_node (UNION_TYPE);
11676
11677   field = NULL_TREE;
11678
11679   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11680     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11681       {
11682         char name[30];
11683
11684         if (ffecom_tree_type[i][j] == NULL_TREE)
11685           continue;             /* Not supported. */
11686         sprintf (&name[0], "bt_%s_kt_%s",
11687                  ffeinfo_basictype_string ((ffeinfoBasictype) i),
11688                  ffeinfo_kindtype_string ((ffeinfoKindtype) j));
11689         ffecom_multi_fields_[i][j] = build_decl (FIELD_DECL,
11690                                                  get_identifier (name),
11691                                                  ffecom_tree_type[i][j]);
11692         DECL_CONTEXT (ffecom_multi_fields_[i][j])
11693           = ffecom_multi_type_node_;
11694         DECL_ALIGN (ffecom_multi_fields_[i][j]) = 0;
11695         DECL_USER_ALIGN (ffecom_multi_fields_[i][j]) = 0;
11696         TREE_CHAIN (ffecom_multi_fields_[i][j]) = field;
11697         field = ffecom_multi_fields_[i][j];
11698       }
11699
11700   TYPE_FIELDS (ffecom_multi_type_node_) = field;
11701   layout_type (ffecom_multi_type_node_);
11702
11703   /* Subroutines usually return integer because they might have alternate
11704      returns. */
11705
11706   ffecom_tree_subr_type
11707     = build_function_type (integer_type_node, NULL_TREE);
11708   ffecom_tree_ptr_to_subr_type
11709     = build_pointer_type (ffecom_tree_subr_type);
11710   ffecom_tree_blockdata_type
11711     = build_function_type (void_type_node, NULL_TREE);
11712
11713   builtin_function ("__builtin_sqrtf", float_ftype_float,
11714                     BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrtf");
11715   builtin_function ("__builtin_fsqrt", double_ftype_double,
11716                     BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrt");
11717   builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble,
11718                     BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrtl");
11719   builtin_function ("__builtin_sinf", float_ftype_float,
11720                     BUILT_IN_SIN, BUILT_IN_NORMAL, "sinf");
11721   builtin_function ("__builtin_sin", double_ftype_double,
11722                     BUILT_IN_SIN, BUILT_IN_NORMAL, "sin");
11723   builtin_function ("__builtin_sinl", ldouble_ftype_ldouble,
11724                     BUILT_IN_SIN, BUILT_IN_NORMAL, "sinl");
11725   builtin_function ("__builtin_cosf", float_ftype_float,
11726                     BUILT_IN_COS, BUILT_IN_NORMAL, "cosf");
11727   builtin_function ("__builtin_cos", double_ftype_double,
11728                     BUILT_IN_COS, BUILT_IN_NORMAL, "cos");
11729   builtin_function ("__builtin_cosl", ldouble_ftype_ldouble,
11730                     BUILT_IN_COS, BUILT_IN_NORMAL, "cosl");
11731
11732   pedantic_lvalues = FALSE;
11733
11734   ffecom_f2c_make_type_ (&ffecom_f2c_integer_type_node,
11735                          FFECOM_f2cINTEGER,
11736                          "integer");
11737   ffecom_f2c_make_type_ (&ffecom_f2c_address_type_node,
11738                          FFECOM_f2cADDRESS,
11739                          "address");
11740   ffecom_f2c_make_type_ (&ffecom_f2c_real_type_node,
11741                          FFECOM_f2cREAL,
11742                          "real");
11743   ffecom_f2c_make_type_ (&ffecom_f2c_doublereal_type_node,
11744                          FFECOM_f2cDOUBLEREAL,
11745                          "doublereal");
11746   ffecom_f2c_make_type_ (&ffecom_f2c_complex_type_node,
11747                          FFECOM_f2cCOMPLEX,
11748                          "complex");
11749   ffecom_f2c_make_type_ (&ffecom_f2c_doublecomplex_type_node,
11750                          FFECOM_f2cDOUBLECOMPLEX,
11751                          "doublecomplex");
11752   ffecom_f2c_make_type_ (&ffecom_f2c_longint_type_node,
11753                          FFECOM_f2cLONGINT,
11754                          "longint");
11755   ffecom_f2c_make_type_ (&ffecom_f2c_logical_type_node,
11756                          FFECOM_f2cLOGICAL,
11757                          "logical");
11758   ffecom_f2c_make_type_ (&ffecom_f2c_flag_type_node,
11759                          FFECOM_f2cFLAG,
11760                          "flag");
11761   ffecom_f2c_make_type_ (&ffecom_f2c_ftnlen_type_node,
11762                          FFECOM_f2cFTNLEN,
11763                          "ftnlen");
11764   ffecom_f2c_make_type_ (&ffecom_f2c_ftnint_type_node,
11765                          FFECOM_f2cFTNINT,
11766                          "ftnint");
11767
11768   ffecom_f2c_ftnlen_zero_node
11769     = convert (ffecom_f2c_ftnlen_type_node, integer_zero_node);
11770
11771   ffecom_f2c_ftnlen_one_node
11772     = convert (ffecom_f2c_ftnlen_type_node, integer_one_node);
11773
11774   ffecom_f2c_ftnlen_two_node = build_int_2 (2, 0);
11775   TREE_TYPE (ffecom_f2c_ftnlen_two_node) = ffecom_integer_type_node;
11776
11777   ffecom_f2c_ptr_to_ftnlen_type_node
11778     = build_pointer_type (ffecom_f2c_ftnlen_type_node);
11779
11780   ffecom_f2c_ptr_to_ftnint_type_node
11781     = build_pointer_type (ffecom_f2c_ftnint_type_node);
11782
11783   ffecom_f2c_ptr_to_integer_type_node
11784     = build_pointer_type (ffecom_f2c_integer_type_node);
11785
11786   ffecom_f2c_ptr_to_real_type_node
11787     = build_pointer_type (ffecom_f2c_real_type_node);
11788
11789   ffecom_float_zero_ = build_real (float_type_node, dconst0);
11790   ffecom_double_zero_ = build_real (double_type_node, dconst0);
11791   {
11792     REAL_VALUE_TYPE point_5;
11793
11794 #ifdef REAL_ARITHMETIC
11795     REAL_ARITHMETIC (point_5, RDIV_EXPR, dconst1, dconst2);
11796 #else
11797     point_5 = .5;
11798 #endif
11799     ffecom_float_half_ = build_real (float_type_node, point_5);
11800     ffecom_double_half_ = build_real (double_type_node, point_5);
11801   }
11802
11803   /* Do "extern int xargc;".  */
11804
11805   ffecom_tree_xargc_ = build_decl (VAR_DECL,
11806                                    get_identifier ("f__xargc"),
11807                                    integer_type_node);
11808   DECL_EXTERNAL (ffecom_tree_xargc_) = 1;
11809   TREE_STATIC (ffecom_tree_xargc_) = 1;
11810   TREE_PUBLIC (ffecom_tree_xargc_) = 1;
11811   ffecom_tree_xargc_ = start_decl (ffecom_tree_xargc_, FALSE);
11812   finish_decl (ffecom_tree_xargc_, NULL_TREE, FALSE);
11813
11814 #if 0   /* This is being fixed, and seems to be working now. */
11815   if ((FLOAT_TYPE_SIZE != 32)
11816       || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))) != 32))
11817     {
11818       warning ("configuration: REAL, INTEGER, and LOGICAL are %d bits wide,",
11819                (int) FLOAT_TYPE_SIZE);
11820       warning ("and pointers are %d bits wide, but g77 doesn't yet work",
11821           (int) TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))));
11822       warning ("properly unless they all are 32 bits wide");
11823       warning ("Please keep this in mind before you report bugs.  g77 should");
11824       warning ("support non-32-bit machines better as of version 0.6");
11825     }
11826 #endif
11827
11828 #if 0   /* Code in ste.c that would crash has been commented out. */
11829   if (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)
11830       < TYPE_PRECISION (string_type_node))
11831     /* I/O will probably crash.  */
11832     warning ("configuration: char * holds %d bits, but ftnlen only %d",
11833              TYPE_PRECISION (string_type_node),
11834              TYPE_PRECISION (ffecom_f2c_ftnlen_type_node));
11835 #endif
11836
11837 #if 0   /* ASSIGN-related stuff has been changed to accommodate this. */
11838   if (TYPE_PRECISION (ffecom_integer_type_node)
11839       < TYPE_PRECISION (string_type_node))
11840     /* ASSIGN 10 TO I will crash.  */
11841     warning ("configuration: char * holds %d bits, but INTEGER only %d --\n\
11842  ASSIGN statement might fail",
11843              TYPE_PRECISION (string_type_node),
11844              TYPE_PRECISION (ffecom_integer_type_node));
11845 #endif
11846 }
11847
11848 /* ffecom_init_2 -- Initialize
11849
11850    ffecom_init_2();  */
11851
11852 void
11853 ffecom_init_2 ()
11854 {
11855   assert (ffecom_outer_function_decl_ == NULL_TREE);
11856   assert (current_function_decl == NULL_TREE);
11857   assert (ffecom_which_entrypoint_decl_ == NULL_TREE);
11858
11859   ffecom_master_arglist_ = NULL;
11860   ++ffecom_num_fns_;
11861   ffecom_primary_entry_ = NULL;
11862   ffecom_is_altreturning_ = FALSE;
11863   ffecom_func_result_ = NULL_TREE;
11864   ffecom_multi_retval_ = NULL_TREE;
11865 }
11866
11867 /* ffecom_list_expr -- Transform list of exprs into gcc tree
11868
11869    tree t;
11870    ffebld expr;  // FFE opITEM list.
11871    tree = ffecom_list_expr(expr);
11872
11873    List of actual args is transformed into corresponding gcc backend list.  */
11874
11875 tree
11876 ffecom_list_expr (ffebld expr)
11877 {
11878   tree list;
11879   tree *plist = &list;
11880   tree trail = NULL_TREE;       /* Append char length args here. */
11881   tree *ptrail = &trail;
11882   tree length;
11883
11884   while (expr != NULL)
11885     {
11886       tree texpr = ffecom_arg_expr (ffebld_head (expr), &length);
11887
11888       if (texpr == error_mark_node)
11889         return error_mark_node;
11890
11891       *plist = build_tree_list (NULL_TREE, texpr);
11892       plist = &TREE_CHAIN (*plist);
11893       expr = ffebld_trail (expr);
11894       if (length != NULL_TREE)
11895         {
11896           *ptrail = build_tree_list (NULL_TREE, length);
11897           ptrail = &TREE_CHAIN (*ptrail);
11898         }
11899     }
11900
11901   *plist = trail;
11902
11903   return list;
11904 }
11905
11906 /* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree
11907
11908    tree t;
11909    ffebld expr;  // FFE opITEM list.
11910    tree = ffecom_list_ptr_to_expr(expr);
11911
11912    List of actual args is transformed into corresponding gcc backend list for
11913    use in calling an external procedure (vs. a statement function).  */
11914
11915 tree
11916 ffecom_list_ptr_to_expr (ffebld expr)
11917 {
11918   tree list;
11919   tree *plist = &list;
11920   tree trail = NULL_TREE;       /* Append char length args here. */
11921   tree *ptrail = &trail;
11922   tree length;
11923
11924   while (expr != NULL)
11925     {
11926       tree texpr = ffecom_arg_ptr_to_expr (ffebld_head (expr), &length);
11927
11928       if (texpr == error_mark_node)
11929         return error_mark_node;
11930
11931       *plist = build_tree_list (NULL_TREE, texpr);
11932       plist = &TREE_CHAIN (*plist);
11933       expr = ffebld_trail (expr);
11934       if (length != NULL_TREE)
11935         {
11936           *ptrail = build_tree_list (NULL_TREE, length);
11937           ptrail = &TREE_CHAIN (*ptrail);
11938         }
11939     }
11940
11941   *plist = trail;
11942
11943   return list;
11944 }
11945
11946 /* Obtain gcc's LABEL_DECL tree for label.  */
11947
11948 tree
11949 ffecom_lookup_label (ffelab label)
11950 {
11951   tree glabel;
11952
11953   if (ffelab_hook (label) == NULL_TREE)
11954     {
11955       char labelname[16];
11956
11957       switch (ffelab_type (label))
11958         {
11959         case FFELAB_typeLOOPEND:
11960         case FFELAB_typeNOTLOOP:
11961         case FFELAB_typeENDIF:
11962           sprintf (labelname, "%" ffelabValue_f "u", ffelab_value (label));
11963           glabel = build_decl (LABEL_DECL, get_identifier (labelname),
11964                                void_type_node);
11965           DECL_CONTEXT (glabel) = current_function_decl;
11966           DECL_MODE (glabel) = VOIDmode;
11967           break;
11968
11969         case FFELAB_typeFORMAT:
11970           glabel = build_decl (VAR_DECL,
11971                                ffecom_get_invented_identifier
11972                                ("__g77_format_%d", (int) ffelab_value (label)),
11973                                build_type_variant (build_array_type
11974                                                    (char_type_node,
11975                                                     NULL_TREE),
11976                                                    1, 0));
11977           TREE_CONSTANT (glabel) = 1;
11978           TREE_STATIC (glabel) = 1;
11979           DECL_CONTEXT (glabel) = current_function_decl;
11980           DECL_INITIAL (glabel) = NULL;
11981           make_decl_rtl (glabel, NULL);
11982           expand_decl (glabel);
11983
11984           ffecom_save_tree_forever (glabel);
11985
11986           break;
11987
11988         case FFELAB_typeANY:
11989           glabel = error_mark_node;
11990           break;
11991
11992         default:
11993           assert ("bad label type" == NULL);
11994           glabel = NULL;
11995           break;
11996         }
11997       ffelab_set_hook (label, glabel);
11998     }
11999   else
12000     {
12001       glabel = ffelab_hook (label);
12002     }
12003
12004   return glabel;
12005 }
12006
12007 /* Stabilizes the arguments.  Don't use this if the lhs and rhs come from
12008    a single source specification (as in the fourth argument of MVBITS).
12009    If the type is NULL_TREE, the type of lhs is used to make the type of
12010    the MODIFY_EXPR.  */
12011
12012 tree
12013 ffecom_modify (tree newtype, tree lhs,
12014                tree rhs)
12015 {
12016   if (lhs == error_mark_node || rhs == error_mark_node)
12017     return error_mark_node;
12018
12019   if (newtype == NULL_TREE)
12020     newtype = TREE_TYPE (lhs);
12021
12022   if (TREE_SIDE_EFFECTS (lhs))
12023     lhs = stabilize_reference (lhs);
12024
12025   return ffecom_2s (MODIFY_EXPR, newtype, lhs, rhs);
12026 }
12027
12028 /* Register source file name.  */
12029
12030 void
12031 ffecom_file (const char *name)
12032 {
12033   ffecom_file_ (name);
12034 }
12035
12036 /* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed
12037
12038    ffestorag st;
12039    ffecom_notify_init_storage(st);
12040
12041    Gets called when all possible units in an aggregate storage area (a LOCAL
12042    with equivalences or a COMMON) have been initialized.  The initialization
12043    info either is in ffestorag_init or, if that is NULL,
12044    ffestorag_accretion:
12045
12046    ffestorag_init may contain an opCONTER or opARRTER.  opCONTER may occur
12047    even for an array if the array is one element in length!
12048
12049    ffestorag_accretion will contain an opACCTER.  It is much like an
12050    opARRTER except it has an ffebit object in it instead of just a size.
12051    The back end can use the info in the ffebit object, if it wants, to
12052    reduce the amount of actual initialization, but in any case it should
12053    kill the ffebit object when done.  Also, set accretion to NULL but
12054    init to a non-NULL value.
12055
12056    After performing initialization, DO NOT set init to NULL, because that'll
12057    tell the front end it is ok for more initialization to happen.  Instead,
12058    set init to an opANY expression or some such thing that you can use to
12059    tell that you've already initialized the object.
12060
12061    27-Oct-91  JCB  1.1
12062       Support two-pass FFE.  */
12063
12064 void
12065 ffecom_notify_init_storage (ffestorag st)
12066 {
12067   ffebld init;                  /* The initialization expression. */
12068
12069   if (ffestorag_init (st) == NULL)
12070     {
12071       init = ffestorag_accretion (st);
12072       assert (init != NULL);
12073       ffestorag_set_accretion (st, NULL);
12074       ffestorag_set_accretes (st, 0);
12075       ffestorag_set_init (st, init);
12076     }
12077 }
12078
12079 /* ffecom_notify_init_symbol -- A symbol is now fully init'ed
12080
12081    ffesymbol s;
12082    ffecom_notify_init_symbol(s);
12083
12084    Gets called when all possible units in a symbol (not placed in COMMON
12085    or involved in EQUIVALENCE, unless it as yet has no ffestorag object)
12086    have been initialized.  The initialization info either is in
12087    ffesymbol_init or, if that is NULL, ffesymbol_accretion:
12088
12089    ffesymbol_init may contain an opCONTER or opARRTER.  opCONTER may occur
12090    even for an array if the array is one element in length!
12091
12092    ffesymbol_accretion will contain an opACCTER.  It is much like an
12093    opARRTER except it has an ffebit object in it instead of just a size.
12094    The back end can use the info in the ffebit object, if it wants, to
12095    reduce the amount of actual initialization, but in any case it should
12096    kill the ffebit object when done.  Also, set accretion to NULL but
12097    init to a non-NULL value.
12098
12099    After performing initialization, DO NOT set init to NULL, because that'll
12100    tell the front end it is ok for more initialization to happen.  Instead,
12101    set init to an opANY expression or some such thing that you can use to
12102    tell that you've already initialized the object.
12103
12104    27-Oct-91  JCB  1.1
12105       Support two-pass FFE.  */
12106
12107 void
12108 ffecom_notify_init_symbol (ffesymbol s)
12109 {
12110   ffebld init;                  /* The initialization expression. */
12111
12112   if (ffesymbol_storage (s) == NULL)
12113     return;                     /* Do nothing until COMMON/EQUIVALENCE
12114                                    possibilities checked. */
12115
12116   if ((ffesymbol_init (s) == NULL)
12117       && ((init = ffesymbol_accretion (s)) != NULL))
12118     {
12119       ffesymbol_set_accretion (s, NULL);
12120       ffesymbol_set_accretes (s, 0);
12121       ffesymbol_set_init (s, init);
12122     }
12123 }
12124
12125 /* ffecom_notify_primary_entry -- Learn which is the primary entry point
12126
12127    ffesymbol s;
12128    ffecom_notify_primary_entry(s);
12129
12130    Gets called when implicit or explicit PROGRAM statement seen or when
12131    FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary
12132    global symbol that serves as the entry point.  */
12133
12134 void
12135 ffecom_notify_primary_entry (ffesymbol s)
12136 {
12137   ffecom_primary_entry_ = s;
12138   ffecom_primary_entry_kind_ = ffesymbol_kind (s);
12139
12140   if ((ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
12141       || (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE))
12142     ffecom_primary_entry_is_proc_ = TRUE;
12143   else
12144     ffecom_primary_entry_is_proc_ = FALSE;
12145
12146   if (!ffe_is_silent ())
12147     {
12148       if (ffecom_primary_entry_kind_ == FFEINFO_kindPROGRAM)
12149         fprintf (stderr, "%s:\n", ffesymbol_text (s));
12150       else
12151         fprintf (stderr, "  %s:\n", ffesymbol_text (s));
12152     }
12153
12154   if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
12155     {
12156       ffebld list;
12157       ffebld arg;
12158
12159       for (list = ffesymbol_dummyargs (s);
12160            list != NULL;
12161            list = ffebld_trail (list))
12162         {
12163           arg = ffebld_head (list);
12164           if (ffebld_op (arg) == FFEBLD_opSTAR)
12165             {
12166               ffecom_is_altreturning_ = TRUE;
12167               break;
12168             }
12169         }
12170     }
12171 }
12172
12173 FILE *
12174 ffecom_open_include (char *name, ffewhereLine l, ffewhereColumn c)
12175 {
12176   return ffecom_open_include_ (name, l, c);
12177 }
12178
12179 /* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front
12180
12181    tree t;
12182    ffebld expr;  // FFE expression.
12183    tree = ffecom_ptr_to_expr(expr);
12184
12185    Like ffecom_expr, but sticks address-of in front of most things.  */
12186
12187 tree
12188 ffecom_ptr_to_expr (ffebld expr)
12189 {
12190   tree item;
12191   ffeinfoBasictype bt;
12192   ffeinfoKindtype kt;
12193   ffesymbol s;
12194
12195   assert (expr != NULL);
12196
12197   switch (ffebld_op (expr))
12198     {
12199     case FFEBLD_opSYMTER:
12200       s = ffebld_symter (expr);
12201       if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
12202         {
12203           ffecomGfrt ix;
12204
12205           ix = ffeintrin_gfrt_indirect (ffebld_symter_implementation (expr));
12206           assert (ix != FFECOM_gfrt);
12207           if ((item = ffecom_gfrt_[ix]) == NULL_TREE)
12208             {
12209               ffecom_make_gfrt_ (ix);
12210               item = ffecom_gfrt_[ix];
12211             }
12212         }
12213       else
12214         {
12215           item = ffesymbol_hook (s).decl_tree;
12216           if (item == NULL_TREE)
12217             {
12218               s = ffecom_sym_transform_ (s);
12219               item = ffesymbol_hook (s).decl_tree;
12220             }
12221         }
12222       assert (item != NULL);
12223       if (item == error_mark_node)
12224         return item;
12225       if (!ffesymbol_hook (s).addr)
12226         item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12227                          item);
12228       return item;
12229
12230     case FFEBLD_opARRAYREF:
12231       return ffecom_arrayref_ (NULL_TREE, expr, 1);
12232
12233     case FFEBLD_opCONTER:
12234
12235       bt = ffeinfo_basictype (ffebld_info (expr));
12236       kt = ffeinfo_kindtype (ffebld_info (expr));
12237
12238       item = ffecom_constantunion (&ffebld_constant_union
12239                                    (ffebld_conter (expr)), bt, kt,
12240                                    ffecom_tree_type[bt][kt]);
12241       if (item == error_mark_node)
12242         return error_mark_node;
12243       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12244                        item);
12245       return item;
12246
12247     case FFEBLD_opANY:
12248       return error_mark_node;
12249
12250     default:
12251       bt = ffeinfo_basictype (ffebld_info (expr));
12252       kt = ffeinfo_kindtype (ffebld_info (expr));
12253
12254       item = ffecom_expr (expr);
12255       if (item == error_mark_node)
12256         return error_mark_node;
12257
12258       /* The back end currently optimizes a bit too zealously for us, in that
12259          we fail JCB001 if the following block of code is omitted.  It checks
12260          to see if the transformed expression is a symbol or array reference,
12261          and encloses it in a SAVE_EXPR if that is the case.  */
12262
12263       STRIP_NOPS (item);
12264       if ((TREE_CODE (item) == VAR_DECL)
12265           || (TREE_CODE (item) == PARM_DECL)
12266           || (TREE_CODE (item) == RESULT_DECL)
12267           || (TREE_CODE (item) == INDIRECT_REF)
12268           || (TREE_CODE (item) == ARRAY_REF)
12269           || (TREE_CODE (item) == COMPONENT_REF)
12270 #ifdef OFFSET_REF
12271           || (TREE_CODE (item) == OFFSET_REF)
12272 #endif
12273           || (TREE_CODE (item) == BUFFER_REF)
12274           || (TREE_CODE (item) == REALPART_EXPR)
12275           || (TREE_CODE (item) == IMAGPART_EXPR))
12276         {
12277           item = ffecom_save_tree (item);
12278         }
12279
12280       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12281                        item);
12282       return item;
12283     }
12284
12285   assert ("fall-through error" == NULL);
12286   return error_mark_node;
12287 }
12288
12289 /* Obtain a temp var with given data type.
12290
12291    size is FFETARGET_charactersizeNONE for a non-CHARACTER type
12292    or >= 0 for a CHARACTER type.
12293
12294    elements is -1 for a scalar or > 0 for an array of type.  */
12295
12296 tree
12297 ffecom_make_tempvar (const char *commentary, tree type,
12298                      ffetargetCharacterSize size, int elements)
12299 {
12300   tree t;
12301   static int mynumber;
12302
12303   assert (current_binding_level->prep_state < 2);
12304
12305   if (type == error_mark_node)
12306     return error_mark_node;
12307
12308   if (size != FFETARGET_charactersizeNONE)
12309     type = build_array_type (type,
12310                              build_range_type (ffecom_f2c_ftnlen_type_node,
12311                                                ffecom_f2c_ftnlen_one_node,
12312                                                build_int_2 (size, 0)));
12313   if (elements != -1)
12314     type = build_array_type (type,
12315                              build_range_type (integer_type_node,
12316                                                integer_zero_node,
12317                                                build_int_2 (elements - 1,
12318                                                             0)));
12319   t = build_decl (VAR_DECL,
12320                   ffecom_get_invented_identifier ("__g77_%s_%d",
12321                                                   commentary,
12322                                                   mynumber++),
12323                   type);
12324
12325   t = start_decl (t, FALSE);
12326   finish_decl (t, NULL_TREE, FALSE);
12327
12328   return t;
12329 }
12330
12331 /* Prepare argument pointer to expression.
12332
12333    Like ffecom_prepare_expr, except for expressions to be evaluated
12334    via ffecom_arg_ptr_to_expr.  */
12335
12336 void
12337 ffecom_prepare_arg_ptr_to_expr (ffebld expr)
12338 {
12339   /* ~~For now, it seems to be the same thing.  */
12340   ffecom_prepare_expr (expr);
12341   return;
12342 }
12343
12344 /* End of preparations.  */
12345
12346 bool
12347 ffecom_prepare_end (void)
12348 {
12349   int prep_state = current_binding_level->prep_state;
12350
12351   assert (prep_state < 2);
12352   current_binding_level->prep_state = 2;
12353
12354   return (prep_state == 1) ? TRUE : FALSE;
12355 }
12356
12357 /* Prepare expression.
12358
12359    This is called before any code is generated for the current block.
12360    It scans the expression, declares any temporaries that might be needed
12361    during evaluation of the expression, and stores those temporaries in
12362    the appropriate "hook" fields of the expression.  `dest', if not NULL,
12363    specifies the destination that ffecom_expr_ will see, in case that
12364    helps avoid generating unused temporaries.
12365
12366    ~~Improve to avoid allocating unused temporaries by taking `dest'
12367    into account vis-a-vis aliasing requirements of complex/character
12368    functions.  */
12369
12370 void
12371 ffecom_prepare_expr_ (ffebld expr, ffebld dest UNUSED)
12372 {
12373   ffeinfoBasictype bt;
12374   ffeinfoKindtype kt;
12375   ffetargetCharacterSize sz;
12376   tree tempvar = NULL_TREE;
12377
12378   assert (current_binding_level->prep_state < 2);
12379
12380   if (! expr)
12381     return;
12382
12383   bt = ffeinfo_basictype (ffebld_info (expr));
12384   kt = ffeinfo_kindtype (ffebld_info (expr));
12385   sz = ffeinfo_size (ffebld_info (expr));
12386
12387   /* Generate whatever temporaries are needed to represent the result
12388      of the expression.  */
12389
12390   if (bt == FFEINFO_basictypeCHARACTER)
12391     {
12392       while (ffebld_op (expr) == FFEBLD_opPAREN)
12393         expr = ffebld_left (expr);
12394     }
12395
12396   switch (ffebld_op (expr))
12397     {
12398     default:
12399       /* Don't make temps for SYMTER, CONTER, etc.  */
12400       if (ffebld_arity (expr) == 0)
12401         break;
12402
12403       switch (bt)
12404         {
12405         case FFEINFO_basictypeCOMPLEX:
12406           if (ffebld_op (expr) == FFEBLD_opFUNCREF)
12407             {
12408               ffesymbol s;
12409
12410               if (ffebld_op (ffebld_left (expr)) != FFEBLD_opSYMTER)
12411                 break;
12412
12413               s = ffebld_symter (ffebld_left (expr));
12414               if (ffesymbol_where (s) == FFEINFO_whereCONSTANT
12415                   || (ffesymbol_where (s) != FFEINFO_whereINTRINSIC
12416                       && ! ffesymbol_is_f2c (s))
12417                   || (ffesymbol_where (s) == FFEINFO_whereINTRINSIC
12418                       && ! ffe_is_f2c_library ()))
12419                 break;
12420             }
12421           else if (ffebld_op (expr) == FFEBLD_opPOWER)
12422             {
12423               /* Requires special treatment.  There's no POW_CC function
12424                  in libg2c, so POW_ZZ is used, which means we always
12425                  need a double-complex temp, not a single-complex.  */
12426               kt = FFEINFO_kindtypeREAL2;
12427             }
12428           else if (ffebld_op (expr) != FFEBLD_opDIVIDE)
12429             /* The other ops don't need temps for complex operands.  */
12430             break;
12431
12432           /* ~~~Avoid making temps for some intrinsics, such as AIMAG(C),
12433              REAL(C).  See 19990325-0.f, routine `check', for cases.  */
12434           tempvar = ffecom_make_tempvar ("complex",
12435                                          ffecom_tree_type
12436                                          [FFEINFO_basictypeCOMPLEX][kt],
12437                                          FFETARGET_charactersizeNONE,
12438                                          -1);
12439           break;
12440
12441         case FFEINFO_basictypeCHARACTER:
12442           if (ffebld_op (expr) != FFEBLD_opFUNCREF)
12443             break;
12444
12445           if (sz == FFETARGET_charactersizeNONE)
12446             /* ~~Kludge alert!  This should someday be fixed. */
12447             sz = 24;
12448
12449           tempvar = ffecom_make_tempvar ("char", char_type_node, sz, -1);
12450           break;
12451
12452         default:
12453           break;
12454         }
12455       break;
12456
12457 #ifdef HAHA
12458     case FFEBLD_opPOWER:
12459       {
12460         tree rtype, ltype;
12461         tree rtmp, ltmp, result;
12462
12463         ltype = ffecom_type_expr (ffebld_left (expr));
12464         rtype = ffecom_type_expr (ffebld_right (expr));
12465
12466         rtmp = ffecom_make_tempvar (rtype, FFETARGET_charactersizeNONE, -1);
12467         ltmp = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
12468         result = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
12469
12470         tempvar = make_tree_vec (3);
12471         TREE_VEC_ELT (tempvar, 0) = rtmp;
12472         TREE_VEC_ELT (tempvar, 1) = ltmp;
12473         TREE_VEC_ELT (tempvar, 2) = result;
12474       }
12475       break;
12476 #endif  /* HAHA */
12477
12478     case FFEBLD_opCONCATENATE:
12479       {
12480         /* This gets special handling, because only one set of temps
12481            is needed for a tree of these -- the tree is treated as
12482            a flattened list of concatenations when generating code.  */
12483
12484         ffecomConcatList_ catlist;
12485         tree ltmp, itmp, result;
12486         int count;
12487         int i;
12488
12489         catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
12490         count = ffecom_concat_list_count_ (catlist);
12491
12492         if (count >= 2)
12493           {
12494             ltmp
12495               = ffecom_make_tempvar ("concat_len",
12496                                      ffecom_f2c_ftnlen_type_node,
12497                                      FFETARGET_charactersizeNONE, count);
12498             itmp
12499               = ffecom_make_tempvar ("concat_item",
12500                                      ffecom_f2c_address_type_node,
12501                                      FFETARGET_charactersizeNONE, count);
12502             result
12503               = ffecom_make_tempvar ("concat_res",
12504                                      char_type_node,
12505                                      ffecom_concat_list_maxlen_ (catlist),
12506                                      -1);
12507
12508             tempvar = make_tree_vec (3);
12509             TREE_VEC_ELT (tempvar, 0) = ltmp;
12510             TREE_VEC_ELT (tempvar, 1) = itmp;
12511             TREE_VEC_ELT (tempvar, 2) = result;
12512           }
12513
12514         for (i = 0; i < count; ++i)
12515           ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist,
12516                                                                     i));
12517
12518         ffecom_concat_list_kill_ (catlist);
12519
12520         if (tempvar)
12521           {
12522             ffebld_nonter_set_hook (expr, tempvar);
12523             current_binding_level->prep_state = 1;
12524           }
12525       }
12526       return;
12527
12528     case FFEBLD_opCONVERT:
12529       if (bt == FFEINFO_basictypeCHARACTER
12530           && ((ffebld_size_known (ffebld_left (expr))
12531                == FFETARGET_charactersizeNONE)
12532               || (ffebld_size_known (ffebld_left (expr)) >= sz)))
12533         tempvar = ffecom_make_tempvar ("convert", char_type_node, sz, -1);
12534       break;
12535     }
12536
12537   if (tempvar)
12538     {
12539       ffebld_nonter_set_hook (expr, tempvar);
12540       current_binding_level->prep_state = 1;
12541     }
12542
12543   /* Prepare subexpressions for this expr.  */
12544
12545   switch (ffebld_op (expr))
12546     {
12547     case FFEBLD_opPERCENT_LOC:
12548       ffecom_prepare_ptr_to_expr (ffebld_left (expr));
12549       break;
12550
12551     case FFEBLD_opPERCENT_VAL:
12552     case FFEBLD_opPERCENT_REF:
12553       ffecom_prepare_expr (ffebld_left (expr));
12554       break;
12555
12556     case FFEBLD_opPERCENT_DESCR:
12557       ffecom_prepare_arg_ptr_to_expr (ffebld_left (expr));
12558       break;
12559
12560     case FFEBLD_opITEM:
12561       {
12562         ffebld item;
12563
12564         for (item = expr;
12565              item != NULL;
12566              item = ffebld_trail (item))
12567           if (ffebld_head (item) != NULL)
12568             ffecom_prepare_expr (ffebld_head (item));
12569       }
12570       break;
12571
12572     default:
12573       /* Need to handle character conversion specially.  */
12574       switch (ffebld_arity (expr))
12575         {
12576         case 2:
12577           ffecom_prepare_expr (ffebld_left (expr));
12578           ffecom_prepare_expr (ffebld_right (expr));
12579           break;
12580
12581         case 1:
12582           ffecom_prepare_expr (ffebld_left (expr));
12583           break;
12584
12585         default:
12586           break;
12587         }
12588     }
12589
12590   return;
12591 }
12592
12593 /* Prepare expression for reading and writing.
12594
12595    Like ffecom_prepare_expr, except for expressions to be evaluated
12596    via ffecom_expr_rw.  */
12597
12598 void
12599 ffecom_prepare_expr_rw (tree type, ffebld expr)
12600 {
12601   /* This is all we support for now.  */
12602   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
12603
12604   /* ~~For now, it seems to be the same thing.  */
12605   ffecom_prepare_expr (expr);
12606   return;
12607 }
12608
12609 /* Prepare expression for writing.
12610
12611    Like ffecom_prepare_expr, except for expressions to be evaluated
12612    via ffecom_expr_w.  */
12613
12614 void
12615 ffecom_prepare_expr_w (tree type, ffebld expr)
12616 {
12617   /* This is all we support for now.  */
12618   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
12619
12620   /* ~~For now, it seems to be the same thing.  */
12621   ffecom_prepare_expr (expr);
12622   return;
12623 }
12624
12625 /* Prepare expression for returning.
12626
12627    Like ffecom_prepare_expr, except for expressions to be evaluated
12628    via ffecom_return_expr.  */
12629
12630 void
12631 ffecom_prepare_return_expr (ffebld expr)
12632 {
12633   assert (current_binding_level->prep_state < 2);
12634
12635   if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE
12636       && ffecom_is_altreturning_
12637       && expr != NULL)
12638     ffecom_prepare_expr (expr);
12639 }
12640
12641 /* Prepare pointer to expression.
12642
12643    Like ffecom_prepare_expr, except for expressions to be evaluated
12644    via ffecom_ptr_to_expr.  */
12645
12646 void
12647 ffecom_prepare_ptr_to_expr (ffebld expr)
12648 {
12649   /* ~~For now, it seems to be the same thing.  */
12650   ffecom_prepare_expr (expr);
12651   return;
12652 }
12653
12654 /* Transform expression into constant pointer-to-expression tree.
12655
12656    If the expression can be transformed into a pointer-to-expression tree
12657    that is constant, that is done, and the tree returned.  Else NULL_TREE
12658    is returned.
12659
12660    That way, a caller can attempt to provide compile-time initialization
12661    of a variable and, if that fails, *then* choose to start a new block
12662    and resort to using temporaries, as appropriate.  */
12663
12664 tree
12665 ffecom_ptr_to_const_expr (ffebld expr)
12666 {
12667   if (! expr)
12668     return integer_zero_node;
12669
12670   if (ffebld_op (expr) == FFEBLD_opANY)
12671     return error_mark_node;
12672
12673   if (ffebld_arity (expr) == 0
12674       && (ffebld_op (expr) != FFEBLD_opSYMTER
12675           || ffebld_where (expr) == FFEINFO_whereCOMMON
12676           || ffebld_where (expr) == FFEINFO_whereGLOBAL
12677           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
12678     {
12679       tree t;
12680
12681       t = ffecom_ptr_to_expr (expr);
12682       assert (TREE_CONSTANT (t));
12683       return t;
12684     }
12685
12686   return NULL_TREE;
12687 }
12688
12689 /* ffecom_return_expr -- Returns return-value expr given alt return expr
12690
12691    tree rtn;  // NULL_TREE means use expand_null_return()
12692    ffebld expr;  // NULL if no alt return expr to RETURN stmt
12693    rtn = ffecom_return_expr(expr);
12694
12695    Based on the program unit type and other info (like return function
12696    type, return master function type when alternate ENTRY points,
12697    whether subroutine has any alternate RETURN points, etc), returns the
12698    appropriate expression to be returned to the caller, or NULL_TREE
12699    meaning no return value or the caller expects it to be returned somewhere
12700    else (which is handled by other parts of this module).  */
12701
12702 tree
12703 ffecom_return_expr (ffebld expr)
12704 {
12705   tree rtn;
12706
12707   switch (ffecom_primary_entry_kind_)
12708     {
12709     case FFEINFO_kindPROGRAM:
12710     case FFEINFO_kindBLOCKDATA:
12711       rtn = NULL_TREE;
12712       break;
12713
12714     case FFEINFO_kindSUBROUTINE:
12715       if (!ffecom_is_altreturning_)
12716         rtn = NULL_TREE;        /* No alt returns, never an expr. */
12717       else if (expr == NULL)
12718         rtn = integer_zero_node;
12719       else
12720         rtn = ffecom_expr (expr);
12721       break;
12722
12723     case FFEINFO_kindFUNCTION:
12724       if ((ffecom_multi_retval_ != NULL_TREE)
12725           || (ffesymbol_basictype (ffecom_primary_entry_)
12726               == FFEINFO_basictypeCHARACTER)
12727           || ((ffesymbol_basictype (ffecom_primary_entry_)
12728                == FFEINFO_basictypeCOMPLEX)
12729               && (ffecom_num_entrypoints_ == 0)
12730               && ffesymbol_is_f2c (ffecom_primary_entry_)))
12731         {                       /* Value is returned by direct assignment
12732                                    into (implicit) dummy. */
12733           rtn = NULL_TREE;
12734           break;
12735         }
12736       rtn = ffecom_func_result_;
12737 #if 0
12738       /* Spurious error if RETURN happens before first reference!  So elide
12739          this code.  In particular, for debugging registry, rtn should always
12740          be non-null after all, but TREE_USED won't be set until we encounter
12741          a reference in the code.  Perfectly okay (but weird) code that,
12742          e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in
12743          this diagnostic for no reason.  Have people use -O -Wuninitialized
12744          and leave it to the back end to find obviously weird cases.  */
12745
12746       /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid
12747          situation; if the return value has never been referenced, it won't
12748          have a tree under 2pass mode. */
12749       if ((rtn == NULL_TREE)
12750           || !TREE_USED (rtn))
12751         {
12752           ffebad_start (FFEBAD_RETURN_VALUE_UNSET);
12753           ffebad_here (0, ffesymbol_where_line (ffecom_primary_entry_),
12754                        ffesymbol_where_column (ffecom_primary_entry_));
12755           ffebad_string (ffesymbol_text (ffesymbol_funcresult
12756                                          (ffecom_primary_entry_)));
12757           ffebad_finish ();
12758         }
12759 #endif
12760       break;
12761
12762     default:
12763       assert ("bad unit kind" == NULL);
12764     case FFEINFO_kindANY:
12765       rtn = error_mark_node;
12766       break;
12767     }
12768
12769   return rtn;
12770 }
12771
12772 /* Do save_expr only if tree is not error_mark_node.  */
12773
12774 tree
12775 ffecom_save_tree (tree t)
12776 {
12777   return save_expr (t);
12778 }
12779
12780 /* Start a compound statement (block).  */
12781
12782 void
12783 ffecom_start_compstmt (void)
12784 {
12785   bison_rule_pushlevel_ ();
12786 }
12787
12788 /* Public entry point for front end to access start_decl.  */
12789
12790 tree
12791 ffecom_start_decl (tree decl, bool is_initialized)
12792 {
12793   DECL_INITIAL (decl) = is_initialized ? error_mark_node : NULL_TREE;
12794   return start_decl (decl, FALSE);
12795 }
12796
12797 /* ffecom_sym_commit -- Symbol's state being committed to reality
12798
12799    ffesymbol s;
12800    ffecom_sym_commit(s);
12801
12802    Does whatever the backend needs when a symbol is committed after having
12803    been backtrackable for a period of time.  */
12804
12805 void
12806 ffecom_sym_commit (ffesymbol s UNUSED)
12807 {
12808   assert (!ffesymbol_retractable ());
12809 }
12810
12811 /* ffecom_sym_end_transition -- Perform end transition on all symbols
12812
12813    ffecom_sym_end_transition();
12814
12815    Does backend-specific stuff and also calls ffest_sym_end_transition
12816    to do the necessary FFE stuff.
12817
12818    Backtracking is never enabled when this fn is called, so don't worry
12819    about it.  */
12820
12821 ffesymbol
12822 ffecom_sym_end_transition (ffesymbol s)
12823 {
12824   ffestorag st;
12825
12826   assert (!ffesymbol_retractable ());
12827
12828   s = ffest_sym_end_transition (s);
12829
12830   if ((ffesymbol_kind (s) == FFEINFO_kindBLOCKDATA)
12831       && (ffesymbol_where (s) == FFEINFO_whereGLOBAL))
12832     {
12833       ffecom_list_blockdata_
12834         = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
12835                                               FFEINTRIN_specNONE,
12836                                               FFEINTRIN_impNONE),
12837                            ffecom_list_blockdata_);
12838     }
12839
12840   /* This is where we finally notice that a symbol has partial initialization
12841      and finalize it. */
12842
12843   if (ffesymbol_accretion (s) != NULL)
12844     {
12845       assert (ffesymbol_init (s) == NULL);
12846       ffecom_notify_init_symbol (s);
12847     }
12848   else if (((st = ffesymbol_storage (s)) != NULL)
12849            && ((st = ffestorag_parent (st)) != NULL)
12850            && (ffestorag_accretion (st) != NULL))
12851     {
12852       assert (ffestorag_init (st) == NULL);
12853       ffecom_notify_init_storage (st);
12854     }
12855
12856   if ((ffesymbol_kind (s) == FFEINFO_kindCOMMON)
12857       && (ffesymbol_where (s) == FFEINFO_whereLOCAL)
12858       && (ffesymbol_storage (s) != NULL))
12859     {
12860       ffecom_list_common_
12861         = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
12862                                               FFEINTRIN_specNONE,
12863                                               FFEINTRIN_impNONE),
12864                            ffecom_list_common_);
12865     }
12866
12867   return s;
12868 }
12869
12870 /* ffecom_sym_exec_transition -- Perform exec transition on all symbols
12871
12872    ffecom_sym_exec_transition();
12873
12874    Does backend-specific stuff and also calls ffest_sym_exec_transition
12875    to do the necessary FFE stuff.
12876
12877    See the long-winded description in ffecom_sym_learned for info
12878    on handling the situation where backtracking is inhibited.  */
12879
12880 ffesymbol
12881 ffecom_sym_exec_transition (ffesymbol s)
12882 {
12883   s = ffest_sym_exec_transition (s);
12884
12885   return s;
12886 }
12887
12888 /* ffecom_sym_learned -- Initial or more info gained on symbol after exec
12889
12890    ffesymbol s;
12891    s = ffecom_sym_learned(s);
12892
12893    Called when a new symbol is seen after the exec transition or when more
12894    info (perhaps) is gained for an UNCERTAIN symbol.  The symbol state when
12895    it arrives here is that all its latest info is updated already, so its
12896    state may be UNCERTAIN or UNDERSTOOD, it might already have the hook
12897    field filled in if its gone through here or exec_transition first, and
12898    so on.
12899
12900    The backend probably wants to check ffesymbol_retractable() to see if
12901    backtracking is in effect.  If so, the FFE's changes to the symbol may
12902    be retracted (undone) or committed (ratified), at which time the
12903    appropriate ffecom_sym_retract or _commit function will be called
12904    for that function.
12905
12906    If the backend has its own backtracking mechanism, great, use it so that
12907    committal is a simple operation.  Though it doesn't make much difference,
12908    I suppose: the reason for tentative symbol evolution in the FFE is to
12909    enable error detection in weird incorrect statements early and to disable
12910    incorrect error detection on a correct statement.  The backend is not
12911    likely to introduce any information that'll get involved in these
12912    considerations, so it is probably just fine that the implementation
12913    model for this fn and for _exec_transition is to not do anything
12914    (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE
12915    and instead wait until ffecom_sym_commit is called (which it never
12916    will be as long as we're using ambiguity-detecting statement analysis in
12917    the FFE, which we are initially to shake out the code, but don't depend
12918    on this), otherwise go ahead and do whatever is needed.
12919
12920    In essence, then, when this fn and _exec_transition get called while
12921    backtracking is enabled, a general mechanism would be to flag which (or
12922    both) of these were called (and in what order? neat question as to what
12923    might happen that I'm too lame to think through right now) and then when
12924    _commit is called reproduce the original calling sequence, if any, for
12925    the two fns (at which point backtracking will, of course, be disabled).  */
12926
12927 ffesymbol
12928 ffecom_sym_learned (ffesymbol s)
12929 {
12930   ffestorag_exec_layout (s);
12931
12932   return s;
12933 }
12934
12935 /* ffecom_sym_retract -- Symbol's state being retracted from reality
12936
12937    ffesymbol s;
12938    ffecom_sym_retract(s);
12939
12940    Does whatever the backend needs when a symbol is retracted after having
12941    been backtrackable for a period of time.  */
12942
12943 void
12944 ffecom_sym_retract (ffesymbol s UNUSED)
12945 {
12946   assert (!ffesymbol_retractable ());
12947
12948 #if 0                           /* GCC doesn't commit any backtrackable sins,
12949                                    so nothing needed here. */
12950   switch (ffesymbol_hook (s).state)
12951     {
12952     case 0:                     /* nothing happened yet. */
12953       break;
12954
12955     case 1:                     /* exec transition happened. */
12956       break;
12957
12958     case 2:                     /* learned happened. */
12959       break;
12960
12961     case 3:                     /* learned then exec. */
12962       break;
12963
12964     case 4:                     /* exec then learned. */
12965       break;
12966
12967     default:
12968       assert ("bad hook state" == NULL);
12969       break;
12970     }
12971 #endif
12972 }
12973
12974 /* Create temporary gcc label.  */
12975
12976 tree
12977 ffecom_temp_label ()
12978 {
12979   tree glabel;
12980   static int mynumber = 0;
12981
12982   glabel = build_decl (LABEL_DECL,
12983                        ffecom_get_invented_identifier ("__g77_label_%d",
12984                                                        mynumber++),
12985                        void_type_node);
12986   DECL_CONTEXT (glabel) = current_function_decl;
12987   DECL_MODE (glabel) = VOIDmode;
12988
12989   return glabel;
12990 }
12991
12992 /* Return an expression that is usable as an arg in a conditional context
12993    (IF, DO WHILE, .NOT., and so on).
12994
12995    Use the one provided for the back end as of >2.6.0.  */
12996
12997 tree
12998 ffecom_truth_value (tree expr)
12999 {
13000   return truthvalue_conversion (expr);
13001 }
13002
13003 /* Return the inversion of a truth value (the inversion of what
13004    ffecom_truth_value builds).
13005
13006    Apparently invert_truthvalue, which is properly in the back end, is
13007    enough for now, so just use it.  */
13008
13009 tree
13010 ffecom_truth_value_invert (tree expr)
13011 {
13012   return invert_truthvalue (ffecom_truth_value (expr));
13013 }
13014
13015 /* Return the tree that is the type of the expression, as would be
13016    returned in TREE_TYPE(ffecom_expr(expr)), without otherwise
13017    transforming the expression, generating temporaries, etc.  */
13018
13019 tree
13020 ffecom_type_expr (ffebld expr)
13021 {
13022   ffeinfoBasictype bt;
13023   ffeinfoKindtype kt;
13024   tree tree_type;
13025
13026   assert (expr != NULL);
13027
13028   bt = ffeinfo_basictype (ffebld_info (expr));
13029   kt = ffeinfo_kindtype (ffebld_info (expr));
13030   tree_type = ffecom_tree_type[bt][kt];
13031
13032   switch (ffebld_op (expr))
13033     {
13034     case FFEBLD_opCONTER:
13035     case FFEBLD_opSYMTER:
13036     case FFEBLD_opARRAYREF:
13037     case FFEBLD_opUPLUS:
13038     case FFEBLD_opPAREN:
13039     case FFEBLD_opUMINUS:
13040     case FFEBLD_opADD:
13041     case FFEBLD_opSUBTRACT:
13042     case FFEBLD_opMULTIPLY:
13043     case FFEBLD_opDIVIDE:
13044     case FFEBLD_opPOWER:
13045     case FFEBLD_opNOT:
13046     case FFEBLD_opFUNCREF:
13047     case FFEBLD_opSUBRREF:
13048     case FFEBLD_opAND:
13049     case FFEBLD_opOR:
13050     case FFEBLD_opXOR:
13051     case FFEBLD_opNEQV:
13052     case FFEBLD_opEQV:
13053     case FFEBLD_opCONVERT:
13054     case FFEBLD_opLT:
13055     case FFEBLD_opLE:
13056     case FFEBLD_opEQ:
13057     case FFEBLD_opNE:
13058     case FFEBLD_opGT:
13059     case FFEBLD_opGE:
13060     case FFEBLD_opPERCENT_LOC:
13061       return tree_type;
13062
13063     case FFEBLD_opACCTER:
13064     case FFEBLD_opARRTER:
13065     case FFEBLD_opITEM:
13066     case FFEBLD_opSTAR:
13067     case FFEBLD_opBOUNDS:
13068     case FFEBLD_opREPEAT:
13069     case FFEBLD_opLABTER:
13070     case FFEBLD_opLABTOK:
13071     case FFEBLD_opIMPDO:
13072     case FFEBLD_opCONCATENATE:
13073     case FFEBLD_opSUBSTR:
13074     default:
13075       assert ("bad op for ffecom_type_expr" == NULL);
13076       /* Fall through. */
13077     case FFEBLD_opANY:
13078       return error_mark_node;
13079     }
13080 }
13081
13082 /* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points
13083
13084    If the PARM_DECL already exists, return it, else create it.  It's an
13085    integer_type_node argument for the master function that implements a
13086    subroutine or function with more than one entrypoint and is bound at
13087    run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for
13088    first ENTRY statement, and so on).  */
13089
13090 tree
13091 ffecom_which_entrypoint_decl ()
13092 {
13093   assert (ffecom_which_entrypoint_decl_ != NULL_TREE);
13094
13095   return ffecom_which_entrypoint_decl_;
13096 }
13097 \f
13098 /* The following sections consists of private and public functions
13099    that have the same names and perform roughly the same functions
13100    as counterparts in the C front end.  Changes in the C front end
13101    might affect how things should be done here.  Only functions
13102    needed by the back end should be public here; the rest should
13103    be private (static in the C sense).  Functions needed by other
13104    g77 front-end modules should be accessed by them via public
13105    ffecom_* names, which should themselves call private versions
13106    in this section so the private versions are easy to recognize
13107    when upgrading to a new gcc and finding interesting changes
13108    in the front end.
13109
13110    Functions named after rule "foo:" in c-parse.y are named
13111    "bison_rule_foo_" so they are easy to find.  */
13112
13113 static void
13114 bison_rule_pushlevel_ ()
13115 {
13116   emit_line_note (input_filename, lineno);
13117   pushlevel (0);
13118   clear_last_expr ();
13119   expand_start_bindings (0);
13120 }
13121
13122 static tree
13123 bison_rule_compstmt_ ()
13124 {
13125   tree t;
13126   int keep = kept_level_p ();
13127
13128   /* Make the temps go away.  */
13129   if (! keep)
13130     current_binding_level->names = NULL_TREE;
13131
13132   emit_line_note (input_filename, lineno);
13133   expand_end_bindings (getdecls (), keep, 0);
13134   t = poplevel (keep, 1, 0);
13135
13136   return t;
13137 }
13138
13139 /* Return a definition for a builtin function named NAME and whose data type
13140    is TYPE.  TYPE should be a function type with argument types.
13141    FUNCTION_CODE tells later passes how to compile calls to this function.
13142    See tree.h for its possible values.
13143
13144    If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
13145    the name to be called if we can't opencode the function.  */
13146
13147 tree
13148 builtin_function (const char *name, tree type, int function_code,
13149                   enum built_in_class class,
13150                   const char *library_name)
13151 {
13152   tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type);
13153   DECL_EXTERNAL (decl) = 1;
13154   TREE_PUBLIC (decl) = 1;
13155   if (library_name)
13156     SET_DECL_ASSEMBLER_NAME (decl, get_identifier (library_name));
13157   make_decl_rtl (decl, NULL);
13158   pushdecl (decl);
13159   DECL_BUILT_IN_CLASS (decl) = class;
13160   DECL_FUNCTION_CODE (decl) = function_code;
13161
13162   return decl;
13163 }
13164
13165 /* Handle when a new declaration NEWDECL
13166    has the same name as an old one OLDDECL
13167    in the same binding contour.
13168    Prints an error message if appropriate.
13169
13170    If safely possible, alter OLDDECL to look like NEWDECL, and return 1.
13171    Otherwise, return 0.  */
13172
13173 static int
13174 duplicate_decls (tree newdecl, tree olddecl)
13175 {
13176   int types_match = 1;
13177   int new_is_definition = (TREE_CODE (newdecl) == FUNCTION_DECL
13178                            && DECL_INITIAL (newdecl) != 0);
13179   tree oldtype = TREE_TYPE (olddecl);
13180   tree newtype = TREE_TYPE (newdecl);
13181
13182   if (olddecl == newdecl)
13183     return 1;
13184
13185   if (TREE_CODE (newtype) == ERROR_MARK
13186       || TREE_CODE (oldtype) == ERROR_MARK)
13187     types_match = 0;
13188
13189   /* New decl is completely inconsistent with the old one =>
13190      tell caller to replace the old one.
13191      This is always an error except in the case of shadowing a builtin.  */
13192   if (TREE_CODE (olddecl) != TREE_CODE (newdecl))
13193     return 0;
13194
13195   /* For real parm decl following a forward decl,
13196      return 1 so old decl will be reused.  */
13197   if (types_match && TREE_CODE (newdecl) == PARM_DECL
13198       && TREE_ASM_WRITTEN (olddecl) && ! TREE_ASM_WRITTEN (newdecl))
13199     return 1;
13200
13201   /* The new declaration is the same kind of object as the old one.
13202      The declarations may partially match.  Print warnings if they don't
13203      match enough.  Ultimately, copy most of the information from the new
13204      decl to the old one, and keep using the old one.  */
13205
13206   if (TREE_CODE (olddecl) == FUNCTION_DECL
13207       && DECL_BUILT_IN (olddecl))
13208     {
13209       /* A function declaration for a built-in function.  */
13210       if (!TREE_PUBLIC (newdecl))
13211         return 0;
13212       else if (!types_match)
13213         {
13214           /* Accept the return type of the new declaration if same modes.  */
13215           tree oldreturntype = TREE_TYPE (TREE_TYPE (olddecl));
13216           tree newreturntype = TREE_TYPE (TREE_TYPE (newdecl));
13217
13218           if (TYPE_MODE (oldreturntype) == TYPE_MODE (newreturntype))
13219             {
13220               /* Function types may be shared, so we can't just modify
13221                  the return type of olddecl's function type.  */
13222               tree newtype
13223                 = build_function_type (newreturntype,
13224                                        TYPE_ARG_TYPES (TREE_TYPE (olddecl)));
13225
13226               types_match = 1;
13227               if (types_match)
13228                 TREE_TYPE (olddecl) = newtype;
13229             }
13230         }
13231       if (!types_match)
13232         return 0;
13233     }
13234   else if (TREE_CODE (olddecl) == FUNCTION_DECL
13235            && DECL_SOURCE_LINE (olddecl) == 0)
13236     {
13237       /* A function declaration for a predeclared function
13238          that isn't actually built in.  */
13239       if (!TREE_PUBLIC (newdecl))
13240         return 0;
13241       else if (!types_match)
13242         {
13243           /* If the types don't match, preserve volatility indication.
13244              Later on, we will discard everything else about the
13245              default declaration.  */
13246           TREE_THIS_VOLATILE (newdecl) |= TREE_THIS_VOLATILE (olddecl);
13247         }
13248     }
13249
13250   /* Copy all the DECL_... slots specified in the new decl
13251      except for any that we copy here from the old type.
13252
13253      Past this point, we don't change OLDTYPE and NEWTYPE
13254      even if we change the types of NEWDECL and OLDDECL.  */
13255
13256   if (types_match)
13257     {
13258       /* Merge the data types specified in the two decls.  */
13259       if (TREE_CODE (newdecl) != FUNCTION_DECL || !DECL_BUILT_IN (olddecl))
13260         TREE_TYPE (newdecl)
13261           = TREE_TYPE (olddecl)
13262             = TREE_TYPE (newdecl);
13263
13264       /* Lay the type out, unless already done.  */
13265       if (oldtype != TREE_TYPE (newdecl))
13266         {
13267           if (TREE_TYPE (newdecl) != error_mark_node)
13268             layout_type (TREE_TYPE (newdecl));
13269           if (TREE_CODE (newdecl) != FUNCTION_DECL
13270               && TREE_CODE (newdecl) != TYPE_DECL
13271               && TREE_CODE (newdecl) != CONST_DECL)
13272             layout_decl (newdecl, 0);
13273         }
13274       else
13275         {
13276           /* Since the type is OLDDECL's, make OLDDECL's size go with.  */
13277           DECL_SIZE (newdecl) = DECL_SIZE (olddecl);
13278           DECL_SIZE_UNIT (newdecl) = DECL_SIZE_UNIT (olddecl);
13279           if (TREE_CODE (olddecl) != FUNCTION_DECL)
13280             if (DECL_ALIGN (olddecl) > DECL_ALIGN (newdecl))
13281               {
13282                 DECL_ALIGN (newdecl) = DECL_ALIGN (olddecl);
13283                 DECL_USER_ALIGN (newdecl) |= DECL_USER_ALIGN (olddecl);
13284               }
13285         }
13286
13287       /* Keep the old rtl since we can safely use it.  */
13288       COPY_DECL_RTL (olddecl, newdecl);
13289
13290       /* Merge the type qualifiers.  */
13291       if (DECL_BUILT_IN_NONANSI (olddecl) && TREE_THIS_VOLATILE (olddecl)
13292           && !TREE_THIS_VOLATILE (newdecl))
13293         TREE_THIS_VOLATILE (olddecl) = 0;
13294       if (TREE_READONLY (newdecl))
13295         TREE_READONLY (olddecl) = 1;
13296       if (TREE_THIS_VOLATILE (newdecl))
13297         {
13298           TREE_THIS_VOLATILE (olddecl) = 1;
13299           if (TREE_CODE (newdecl) == VAR_DECL)
13300             make_var_volatile (newdecl);
13301         }
13302
13303       /* Keep source location of definition rather than declaration.
13304          Likewise, keep decl at outer scope.  */
13305       if ((DECL_INITIAL (newdecl) == 0 && DECL_INITIAL (olddecl) != 0)
13306           || (DECL_CONTEXT (newdecl) != 0 && DECL_CONTEXT (olddecl) == 0))
13307         {
13308           DECL_SOURCE_LINE (newdecl) = DECL_SOURCE_LINE (olddecl);
13309           DECL_SOURCE_FILE (newdecl) = DECL_SOURCE_FILE (olddecl);
13310
13311           if (DECL_CONTEXT (olddecl) == 0
13312               && TREE_CODE (newdecl) != FUNCTION_DECL)
13313             DECL_CONTEXT (newdecl) = 0;
13314         }
13315
13316       /* Merge the unused-warning information.  */
13317       if (DECL_IN_SYSTEM_HEADER (olddecl))
13318         DECL_IN_SYSTEM_HEADER (newdecl) = 1;
13319       else if (DECL_IN_SYSTEM_HEADER (newdecl))
13320         DECL_IN_SYSTEM_HEADER (olddecl) = 1;
13321
13322       /* Merge the initialization information.  */
13323       if (DECL_INITIAL (newdecl) == 0)
13324         DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13325
13326       /* Merge the section attribute.
13327          We want to issue an error if the sections conflict but that must be
13328          done later in decl_attributes since we are called before attributes
13329          are assigned.  */
13330       if (DECL_SECTION_NAME (newdecl) == NULL_TREE)
13331         DECL_SECTION_NAME (newdecl) = DECL_SECTION_NAME (olddecl);
13332
13333       if (TREE_CODE (newdecl) == FUNCTION_DECL)
13334         {
13335           DECL_STATIC_CONSTRUCTOR(newdecl) |= DECL_STATIC_CONSTRUCTOR(olddecl);
13336           DECL_STATIC_DESTRUCTOR (newdecl) |= DECL_STATIC_DESTRUCTOR (olddecl);
13337         }
13338     }
13339   /* If cannot merge, then use the new type and qualifiers,
13340      and don't preserve the old rtl.  */
13341   else
13342     {
13343       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13344       TREE_READONLY (olddecl) = TREE_READONLY (newdecl);
13345       TREE_THIS_VOLATILE (olddecl) = TREE_THIS_VOLATILE (newdecl);
13346       TREE_SIDE_EFFECTS (olddecl) = TREE_SIDE_EFFECTS (newdecl);
13347     }
13348
13349   /* Merge the storage class information.  */
13350   /* For functions, static overrides non-static.  */
13351   if (TREE_CODE (newdecl) == FUNCTION_DECL)
13352     {
13353       TREE_PUBLIC (newdecl) &= TREE_PUBLIC (olddecl);
13354       /* This is since we don't automatically
13355          copy the attributes of NEWDECL into OLDDECL.  */
13356       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13357       /* If this clears `static', clear it in the identifier too.  */
13358       if (! TREE_PUBLIC (olddecl))
13359         TREE_PUBLIC (DECL_NAME (olddecl)) = 0;
13360     }
13361   if (DECL_EXTERNAL (newdecl))
13362     {
13363       TREE_STATIC (newdecl) = TREE_STATIC (olddecl);
13364       DECL_EXTERNAL (newdecl) = DECL_EXTERNAL (olddecl);
13365       /* An extern decl does not override previous storage class.  */
13366       TREE_PUBLIC (newdecl) = TREE_PUBLIC (olddecl);
13367     }
13368   else
13369     {
13370       TREE_STATIC (olddecl) = TREE_STATIC (newdecl);
13371       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13372     }
13373
13374   /* If either decl says `inline', this fn is inline,
13375      unless its definition was passed already.  */
13376   if (DECL_INLINE (newdecl) && DECL_INITIAL (olddecl) == 0)
13377     DECL_INLINE (olddecl) = 1;
13378   DECL_INLINE (newdecl) = DECL_INLINE (olddecl);
13379
13380   /* Get rid of any built-in function if new arg types don't match it
13381      or if we have a function definition.  */
13382   if (TREE_CODE (newdecl) == FUNCTION_DECL
13383       && DECL_BUILT_IN (olddecl)
13384       && (!types_match || new_is_definition))
13385     {
13386       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13387       DECL_BUILT_IN_CLASS (olddecl) = NOT_BUILT_IN;
13388     }
13389
13390   /* If redeclaring a builtin function, and not a definition,
13391      it stays built in.
13392      Also preserve various other info from the definition.  */
13393   if (TREE_CODE (newdecl) == FUNCTION_DECL && !new_is_definition)
13394     {
13395       if (DECL_BUILT_IN (olddecl))
13396         {
13397           DECL_BUILT_IN_CLASS (newdecl) = DECL_BUILT_IN_CLASS (olddecl);
13398           DECL_FUNCTION_CODE (newdecl) = DECL_FUNCTION_CODE (olddecl);
13399         }
13400
13401       DECL_RESULT (newdecl) = DECL_RESULT (olddecl);
13402       DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13403       DECL_SAVED_INSNS (newdecl) = DECL_SAVED_INSNS (olddecl);
13404       DECL_ARGUMENTS (newdecl) = DECL_ARGUMENTS (olddecl);
13405     }
13406
13407   /* Copy most of the decl-specific fields of NEWDECL into OLDDECL.
13408      But preserve olddecl's DECL_UID.  */
13409   {
13410     register unsigned olddecl_uid = DECL_UID (olddecl);
13411
13412     memcpy ((char *) olddecl + sizeof (struct tree_common),
13413             (char *) newdecl + sizeof (struct tree_common),
13414             sizeof (struct tree_decl) - sizeof (struct tree_common));
13415     DECL_UID (olddecl) = olddecl_uid;
13416   }
13417
13418   return 1;
13419 }
13420
13421 /* Finish processing of a declaration;
13422    install its initial value.
13423    If the length of an array type is not known before,
13424    it must be determined now, from the initial value, or it is an error.  */
13425
13426 static void
13427 finish_decl (tree decl, tree init, bool is_top_level)
13428 {
13429   register tree type = TREE_TYPE (decl);
13430   int was_incomplete = (DECL_SIZE (decl) == 0);
13431   bool at_top_level = (current_binding_level == global_binding_level);
13432   bool top_level = is_top_level || at_top_level;
13433
13434   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13435      level anyway.  */
13436   assert (!is_top_level || !at_top_level);
13437
13438   if (TREE_CODE (decl) == PARM_DECL)
13439     assert (init == NULL_TREE);
13440   /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it
13441      overlaps DECL_ARG_TYPE.  */
13442   else if (init == NULL_TREE)
13443     assert (DECL_INITIAL (decl) == NULL_TREE);
13444   else
13445     assert (DECL_INITIAL (decl) == error_mark_node);
13446
13447   if (init != NULL_TREE)
13448     {
13449       if (TREE_CODE (decl) != TYPE_DECL)
13450         DECL_INITIAL (decl) = init;
13451       else
13452         {
13453           /* typedef foo = bar; store the type of bar as the type of foo.  */
13454           TREE_TYPE (decl) = TREE_TYPE (init);
13455           DECL_INITIAL (decl) = init = 0;
13456         }
13457     }
13458
13459   /* Deduce size of array from initialization, if not already known */
13460
13461   if (TREE_CODE (type) == ARRAY_TYPE
13462       && TYPE_DOMAIN (type) == 0
13463       && TREE_CODE (decl) != TYPE_DECL)
13464     {
13465       assert (top_level);
13466       assert (was_incomplete);
13467
13468       layout_decl (decl, 0);
13469     }
13470
13471   if (TREE_CODE (decl) == VAR_DECL)
13472     {
13473       if (DECL_SIZE (decl) == NULL_TREE
13474           && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
13475         layout_decl (decl, 0);
13476
13477       if (DECL_SIZE (decl) == NULL_TREE
13478           && (TREE_STATIC (decl)
13479               ?
13480       /* A static variable with an incomplete type is an error if it is
13481          initialized. Also if it is not file scope. Otherwise, let it
13482          through, but if it is not `extern' then it may cause an error
13483          message later.  */
13484               (DECL_INITIAL (decl) != 0 || DECL_CONTEXT (decl) != 0)
13485               :
13486       /* An automatic variable with an incomplete type is an error.  */
13487               !DECL_EXTERNAL (decl)))
13488         {
13489           assert ("storage size not known" == NULL);
13490           abort ();
13491         }
13492
13493       if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl))
13494           && (DECL_SIZE (decl) != 0)
13495           && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST))
13496         {
13497           assert ("storage size not constant" == NULL);
13498           abort ();
13499         }
13500     }
13501
13502   /* Output the assembler code and/or RTL code for variables and functions,
13503      unless the type is an undefined structure or union. If not, it will get
13504      done when the type is completed.  */
13505
13506   if (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == FUNCTION_DECL)
13507     {
13508       rest_of_decl_compilation (decl, NULL,
13509                                 DECL_CONTEXT (decl) == 0,
13510                                 0);
13511
13512       if (DECL_CONTEXT (decl) != 0)
13513         {
13514           /* Recompute the RTL of a local array now if it used to be an
13515              incomplete type.  */
13516           if (was_incomplete
13517               && !TREE_STATIC (decl) && !DECL_EXTERNAL (decl))
13518             {
13519               /* If we used it already as memory, it must stay in memory.  */
13520               TREE_ADDRESSABLE (decl) = TREE_USED (decl);
13521               /* If it's still incomplete now, no init will save it.  */
13522               if (DECL_SIZE (decl) == 0)
13523                 DECL_INITIAL (decl) = 0;
13524               expand_decl (decl);
13525             }
13526           /* Compute and store the initial value.  */
13527           if (TREE_CODE (decl) != FUNCTION_DECL)
13528             expand_decl_init (decl);
13529         }
13530     }
13531   else if (TREE_CODE (decl) == TYPE_DECL)
13532     {
13533       rest_of_decl_compilation (decl, NULL,
13534                                 DECL_CONTEXT (decl) == 0,
13535                                 0);
13536     }
13537
13538   /* At the end of a declaration, throw away any variable type sizes of types
13539      defined inside that declaration.  There is no use computing them in the
13540      following function definition.  */
13541   if (current_binding_level == global_binding_level)
13542     get_pending_sizes ();
13543 }
13544
13545 /* Finish up a function declaration and compile that function
13546    all the way to assembler language output.  The free the storage
13547    for the function definition.
13548
13549    This is called after parsing the body of the function definition.
13550
13551    NESTED is nonzero if the function being finished is nested in another.  */
13552
13553 static void
13554 finish_function (int nested)
13555 {
13556   register tree fndecl = current_function_decl;
13557
13558   assert (fndecl != NULL_TREE);
13559   if (TREE_CODE (fndecl) != ERROR_MARK)
13560     {
13561       if (nested)
13562         assert (DECL_CONTEXT (fndecl) != NULL_TREE);
13563       else
13564         assert (DECL_CONTEXT (fndecl) == NULL_TREE);
13565     }
13566
13567 /*  TREE_READONLY (fndecl) = 1;
13568     This caused &foo to be of type ptr-to-const-function
13569     which then got a warning when stored in a ptr-to-function variable.  */
13570
13571   poplevel (1, 0, 1);
13572
13573   if (TREE_CODE (fndecl) != ERROR_MARK)
13574     {
13575       BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
13576
13577       /* Must mark the RESULT_DECL as being in this function.  */
13578
13579       DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl;
13580
13581       /* Obey `register' declarations if `setjmp' is called in this fn.  */
13582       /* Generate rtl for function exit.  */
13583       expand_function_end (input_filename, lineno, 0);
13584
13585       /* If this is a nested function, protect the local variables in the stack
13586          above us from being collected while we're compiling this function.  */
13587       if (nested)
13588         ggc_push_context ();
13589
13590       /* Run the optimizers and output the assembler code for this function.  */
13591       rest_of_compilation (fndecl);
13592
13593       /* Undo the GC context switch.  */
13594       if (nested)
13595         ggc_pop_context ();
13596     }
13597
13598   if (TREE_CODE (fndecl) != ERROR_MARK
13599       && !nested
13600       && DECL_SAVED_INSNS (fndecl) == 0)
13601     {
13602       /* Stop pointing to the local nodes about to be freed.  */
13603       /* But DECL_INITIAL must remain nonzero so we know this was an actual
13604          function definition.  */
13605       /* For a nested function, this is done in pop_f_function_context.  */
13606       /* If rest_of_compilation set this to 0, leave it 0.  */
13607       if (DECL_INITIAL (fndecl) != 0)
13608         DECL_INITIAL (fndecl) = error_mark_node;
13609       DECL_ARGUMENTS (fndecl) = 0;
13610     }
13611
13612   if (!nested)
13613     {
13614       /* Let the error reporting routines know that we're outside a function.
13615          For a nested function, this value is used in pop_c_function_context
13616          and then reset via pop_function_context.  */
13617       ffecom_outer_function_decl_ = current_function_decl = NULL;
13618     }
13619 }
13620
13621 /* Plug-in replacement for identifying the name of a decl and, for a
13622    function, what we call it in diagnostics.  For now, "program unit"
13623    should suffice, since it's a bit of a hassle to figure out which
13624    of several kinds of things it is.  Note that it could conceivably
13625    be a statement function, which probably isn't really a program unit
13626    per se, but if that comes up, it should be easy to check (being a
13627    nested function and all).  */
13628
13629 static const char *
13630 lang_printable_name (tree decl, int v)
13631 {
13632   /* Just to keep GCC quiet about the unused variable.
13633      In theory, differing values of V should produce different
13634      output.  */
13635   switch (v)
13636     {
13637     default:
13638       if (TREE_CODE (decl) == ERROR_MARK)
13639         return "erroneous code";
13640       return IDENTIFIER_POINTER (DECL_NAME (decl));
13641     }
13642 }
13643
13644 /* g77's function to print out name of current function that caused
13645    an error.  */
13646
13647 static void
13648 lang_print_error_function (diagnostic_context *context __attribute__((unused)),
13649                            const char *file)
13650 {
13651   static ffeglobal last_g = NULL;
13652   static ffesymbol last_s = NULL;
13653   ffeglobal g;
13654   ffesymbol s;
13655   const char *kind;
13656
13657   if ((ffecom_primary_entry_ == NULL)
13658       || (ffesymbol_global (ffecom_primary_entry_) == NULL))
13659     {
13660       g = NULL;
13661       s = NULL;
13662       kind = NULL;
13663     }
13664   else
13665     {
13666       g = ffesymbol_global (ffecom_primary_entry_);
13667       if (ffecom_nested_entry_ == NULL)
13668         {
13669           s = ffecom_primary_entry_;
13670           switch (ffesymbol_kind (s))
13671             {
13672             case FFEINFO_kindFUNCTION:
13673               kind = "function";
13674               break;
13675
13676             case FFEINFO_kindSUBROUTINE:
13677               kind = "subroutine";
13678               break;
13679
13680             case FFEINFO_kindPROGRAM:
13681               kind = "program";
13682               break;
13683
13684             case FFEINFO_kindBLOCKDATA:
13685               kind = "block-data";
13686               break;
13687
13688             default:
13689               kind = ffeinfo_kind_message (ffesymbol_kind (s));
13690               break;
13691             }
13692         }
13693       else
13694         {
13695           s = ffecom_nested_entry_;
13696           kind = "statement function";
13697         }
13698     }
13699
13700   if ((last_g != g) || (last_s != s))
13701     {
13702       if (file)
13703         fprintf (stderr, "%s: ", file);
13704
13705       if (s == NULL)
13706         fprintf (stderr, "Outside of any program unit:\n");
13707       else
13708         {
13709           const char *name = ffesymbol_text (s);
13710
13711           fprintf (stderr, "In %s `%s':\n", kind, name);
13712         }
13713
13714       last_g = g;
13715       last_s = s;
13716     }
13717 }
13718
13719 /* Similar to `lookup_name' but look only at current binding level.  */
13720
13721 static tree
13722 lookup_name_current_level (tree name)
13723 {
13724   register tree t;
13725
13726   if (current_binding_level == global_binding_level)
13727     return IDENTIFIER_GLOBAL_VALUE (name);
13728
13729   if (IDENTIFIER_LOCAL_VALUE (name) == 0)
13730     return 0;
13731
13732   for (t = current_binding_level->names; t; t = TREE_CHAIN (t))
13733     if (DECL_NAME (t) == name)
13734       break;
13735
13736   return t;
13737 }
13738
13739 /* Create a new `struct binding_level'.  */
13740
13741 static struct binding_level *
13742 make_binding_level ()
13743 {
13744   /* NOSTRICT */
13745   return (struct binding_level *) xmalloc (sizeof (struct binding_level));
13746 }
13747
13748 /* Save and restore the variables in this file and elsewhere
13749    that keep track of the progress of compilation of the current function.
13750    Used for nested functions.  */
13751
13752 struct f_function
13753 {
13754   struct f_function *next;
13755   tree named_labels;
13756   tree shadowed_labels;
13757   struct binding_level *binding_level;
13758 };
13759
13760 struct f_function *f_function_chain;
13761
13762 /* Restore the variables used during compilation of a C function.  */
13763
13764 static void
13765 pop_f_function_context ()
13766 {
13767   struct f_function *p = f_function_chain;
13768   tree link;
13769
13770   /* Bring back all the labels that were shadowed.  */
13771   for (link = shadowed_labels; link; link = TREE_CHAIN (link))
13772     if (DECL_NAME (TREE_VALUE (link)) != 0)
13773       IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link)))
13774         = TREE_VALUE (link);
13775
13776   if (current_function_decl != error_mark_node
13777       && DECL_SAVED_INSNS (current_function_decl) == 0)
13778     {
13779       /* Stop pointing to the local nodes about to be freed.  */
13780       /* But DECL_INITIAL must remain nonzero so we know this was an actual
13781          function definition.  */
13782       DECL_INITIAL (current_function_decl) = error_mark_node;
13783       DECL_ARGUMENTS (current_function_decl) = 0;
13784     }
13785
13786   pop_function_context ();
13787
13788   f_function_chain = p->next;
13789
13790   named_labels = p->named_labels;
13791   shadowed_labels = p->shadowed_labels;
13792   current_binding_level = p->binding_level;
13793
13794   free (p);
13795 }
13796
13797 /* Save and reinitialize the variables
13798    used during compilation of a C function.  */
13799
13800 static void
13801 push_f_function_context ()
13802 {
13803   struct f_function *p
13804   = (struct f_function *) xmalloc (sizeof (struct f_function));
13805
13806   push_function_context ();
13807
13808   p->next = f_function_chain;
13809   f_function_chain = p;
13810
13811   p->named_labels = named_labels;
13812   p->shadowed_labels = shadowed_labels;
13813   p->binding_level = current_binding_level;
13814 }
13815
13816 static void
13817 push_parm_decl (tree parm)
13818 {
13819   int old_immediate_size_expand = immediate_size_expand;
13820
13821   /* Don't try computing parm sizes now -- wait till fn is called.  */
13822
13823   immediate_size_expand = 0;
13824
13825   /* Fill in arg stuff.  */
13826
13827   DECL_ARG_TYPE (parm) = TREE_TYPE (parm);
13828   DECL_ARG_TYPE_AS_WRITTEN (parm) = TREE_TYPE (parm);
13829   TREE_READONLY (parm) = 1;     /* All implementation args are read-only. */
13830
13831   parm = pushdecl (parm);
13832
13833   immediate_size_expand = old_immediate_size_expand;
13834
13835   finish_decl (parm, NULL_TREE, FALSE);
13836 }
13837
13838 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate.  */
13839
13840 static tree
13841 pushdecl_top_level (x)
13842      tree x;
13843 {
13844   register tree t;
13845   register struct binding_level *b = current_binding_level;
13846   register tree f = current_function_decl;
13847
13848   current_binding_level = global_binding_level;
13849   current_function_decl = NULL_TREE;
13850   t = pushdecl (x);
13851   current_binding_level = b;
13852   current_function_decl = f;
13853   return t;
13854 }
13855
13856 /* Store the list of declarations of the current level.
13857    This is done for the parameter declarations of a function being defined,
13858    after they are modified in the light of any missing parameters.  */
13859
13860 static tree
13861 storedecls (decls)
13862      tree decls;
13863 {
13864   return current_binding_level->names = decls;
13865 }
13866
13867 /* Store the parameter declarations into the current function declaration.
13868    This is called after parsing the parameter declarations, before
13869    digesting the body of the function.
13870
13871    For an old-style definition, modify the function's type
13872    to specify at least the number of arguments.  */
13873
13874 static void
13875 store_parm_decls (int is_main_program UNUSED)
13876 {
13877   register tree fndecl = current_function_decl;
13878
13879   if (fndecl == error_mark_node)
13880     return;
13881
13882   /* This is a chain of PARM_DECLs from old-style parm declarations.  */
13883   DECL_ARGUMENTS (fndecl) = storedecls (nreverse (getdecls ()));
13884
13885   /* Initialize the RTL code for the function.  */
13886
13887   init_function_start (fndecl, input_filename, lineno);
13888
13889   /* Set up parameters and prepare for return, for the function.  */
13890
13891   expand_function_start (fndecl, 0);
13892 }
13893
13894 static tree
13895 start_decl (tree decl, bool is_top_level)
13896 {
13897   register tree tem;
13898   bool at_top_level = (current_binding_level == global_binding_level);
13899   bool top_level = is_top_level || at_top_level;
13900
13901   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13902      level anyway.  */
13903   assert (!is_top_level || !at_top_level);
13904
13905   if (DECL_INITIAL (decl) != NULL_TREE)
13906     {
13907       assert (DECL_INITIAL (decl) == error_mark_node);
13908       assert (!DECL_EXTERNAL (decl));
13909     }
13910   else if (top_level)
13911     assert ((TREE_STATIC (decl) == 1) || DECL_EXTERNAL (decl) == 1);
13912
13913   /* For Fortran, we by default put things in .common when possible.  */
13914   DECL_COMMON (decl) = 1;
13915
13916   /* Add this decl to the current binding level. TEM may equal DECL or it may
13917      be a previous decl of the same name.  */
13918   if (is_top_level)
13919     tem = pushdecl_top_level (decl);
13920   else
13921     tem = pushdecl (decl);
13922
13923   /* For a local variable, define the RTL now.  */
13924   if (!top_level
13925   /* But not if this is a duplicate decl and we preserved the rtl from the
13926      previous one (which may or may not happen).  */
13927       && !DECL_RTL_SET_P (tem))
13928     {
13929       if (TYPE_SIZE (TREE_TYPE (tem)) != 0)
13930         expand_decl (tem);
13931       else if (TREE_CODE (TREE_TYPE (tem)) == ARRAY_TYPE
13932                && DECL_INITIAL (tem) != 0)
13933         expand_decl (tem);
13934     }
13935
13936   return tem;
13937 }
13938
13939 /* Create the FUNCTION_DECL for a function definition.
13940    DECLSPECS and DECLARATOR are the parts of the declaration;
13941    they describe the function's name and the type it returns,
13942    but twisted together in a fashion that parallels the syntax of C.
13943
13944    This function creates a binding context for the function body
13945    as well as setting up the FUNCTION_DECL in current_function_decl.
13946
13947    Returns 1 on success.  If the DECLARATOR is not suitable for a function
13948    (it defines a datum instead), we return 0, which tells
13949    yyparse to report a parse error.
13950
13951    NESTED is nonzero for a function nested within another function.  */
13952
13953 static void
13954 start_function (tree name, tree type, int nested, int public)
13955 {
13956   tree decl1;
13957   tree restype;
13958   int old_immediate_size_expand = immediate_size_expand;
13959
13960   named_labels = 0;
13961   shadowed_labels = 0;
13962
13963   /* Don't expand any sizes in the return type of the function.  */
13964   immediate_size_expand = 0;
13965
13966   if (nested)
13967     {
13968       assert (!public);
13969       assert (current_function_decl != NULL_TREE);
13970       assert (DECL_CONTEXT (current_function_decl) == NULL_TREE);
13971     }
13972   else
13973     {
13974       assert (current_function_decl == NULL_TREE);
13975     }
13976
13977   if (TREE_CODE (type) == ERROR_MARK)
13978     decl1 = current_function_decl = error_mark_node;
13979   else
13980     {
13981       decl1 = build_decl (FUNCTION_DECL,
13982                           name,
13983                           type);
13984       TREE_PUBLIC (decl1) = public ? 1 : 0;
13985       if (nested)
13986         DECL_INLINE (decl1) = 1;
13987       TREE_STATIC (decl1) = 1;
13988       DECL_EXTERNAL (decl1) = 0;
13989
13990       announce_function (decl1);
13991
13992       /* Make the init_value nonzero so pushdecl knows this is not tentative.
13993          error_mark_node is replaced below (in poplevel) with the BLOCK.  */
13994       DECL_INITIAL (decl1) = error_mark_node;
13995
13996       /* Record the decl so that the function name is defined. If we already have
13997          a decl for this name, and it is a FUNCTION_DECL, use the old decl.  */
13998
13999       current_function_decl = pushdecl (decl1);
14000     }
14001
14002   if (!nested)
14003     ffecom_outer_function_decl_ = current_function_decl;
14004
14005   pushlevel (0);
14006   current_binding_level->prep_state = 2;
14007
14008   if (TREE_CODE (current_function_decl) != ERROR_MARK)
14009     {
14010       make_decl_rtl (current_function_decl, NULL);
14011
14012       restype = TREE_TYPE (TREE_TYPE (current_function_decl));
14013       DECL_RESULT (current_function_decl)
14014         = build_decl (RESULT_DECL, NULL_TREE, restype);
14015     }
14016
14017   if (!nested && (TREE_CODE (current_function_decl) != ERROR_MARK))
14018     TREE_ADDRESSABLE (current_function_decl) = 1;
14019
14020   immediate_size_expand = old_immediate_size_expand;
14021 }
14022 \f
14023 /* Here are the public functions the GNU back end needs.  */
14024
14025 tree
14026 convert (type, expr)
14027      tree type, expr;
14028 {
14029   register tree e = expr;
14030   register enum tree_code code = TREE_CODE (type);
14031
14032   if (type == TREE_TYPE (e)
14033       || TREE_CODE (e) == ERROR_MARK)
14034     return e;
14035   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
14036     return fold (build1 (NOP_EXPR, type, e));
14037   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
14038       || code == ERROR_MARK)
14039     return error_mark_node;
14040   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
14041     {
14042       assert ("void value not ignored as it ought to be" == NULL);
14043       return error_mark_node;
14044     }
14045   if (code == VOID_TYPE)
14046     return build1 (CONVERT_EXPR, type, e);
14047   if ((code != RECORD_TYPE)
14048       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
14049     e = ffecom_1 (REALPART_EXPR, TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e))),
14050                   e);
14051   if (code == INTEGER_TYPE || code == ENUMERAL_TYPE)
14052     return fold (convert_to_integer (type, e));
14053   if (code == POINTER_TYPE)
14054     return fold (convert_to_pointer (type, e));
14055   if (code == REAL_TYPE)
14056     return fold (convert_to_real (type, e));
14057   if (code == COMPLEX_TYPE)
14058     return fold (convert_to_complex (type, e));
14059   if (code == RECORD_TYPE)
14060     return fold (ffecom_convert_to_complex_ (type, e));
14061
14062   assert ("conversion to non-scalar type requested" == NULL);
14063   return error_mark_node;
14064 }
14065
14066 /* integrate_decl_tree calls this function, but since we don't use the
14067    DECL_LANG_SPECIFIC field, this is a no-op.  */
14068
14069 void
14070 copy_lang_decl (node)
14071      tree node UNUSED;
14072 {
14073 }
14074
14075 /* Return the list of declarations of the current level.
14076    Note that this list is in reverse order unless/until
14077    you nreverse it; and when you do nreverse it, you must
14078    store the result back using `storedecls' or you will lose.  */
14079
14080 tree
14081 getdecls ()
14082 {
14083   return current_binding_level->names;
14084 }
14085
14086 /* Nonzero if we are currently in the global binding level.  */
14087
14088 int
14089 global_bindings_p ()
14090 {
14091   return current_binding_level == global_binding_level;
14092 }
14093
14094 /* Print an error message for invalid use of an incomplete type.
14095    VALUE is the expression that was used (or 0 if that isn't known)
14096    and TYPE is the type that was invalid.  */
14097
14098 void
14099 incomplete_type_error (value, type)
14100      tree value UNUSED;
14101      tree type;
14102 {
14103   if (TREE_CODE (type) == ERROR_MARK)
14104     return;
14105
14106   assert ("incomplete type?!?" == NULL);
14107 }
14108
14109 /* Mark ARG for GC.  */
14110 static void
14111 mark_binding_level (void *arg)
14112 {
14113   struct binding_level *level = *(struct binding_level **) arg;
14114
14115   while (level)
14116     {
14117       ggc_mark_tree (level->names);
14118       ggc_mark_tree (level->blocks);
14119       ggc_mark_tree (level->this_block);
14120       level = level->level_chain;
14121     }
14122 }
14123
14124 static void
14125 ffecom_init_decl_processing ()
14126 {
14127   static tree *const tree_roots[] = {
14128     &current_function_decl,
14129     &string_type_node,
14130     &ffecom_tree_fun_type_void,
14131     &ffecom_integer_zero_node,
14132     &ffecom_integer_one_node,
14133     &ffecom_tree_subr_type,
14134     &ffecom_tree_ptr_to_subr_type,
14135     &ffecom_tree_blockdata_type,
14136     &ffecom_tree_xargc_,
14137     &ffecom_f2c_integer_type_node,
14138     &ffecom_f2c_ptr_to_integer_type_node,
14139     &ffecom_f2c_address_type_node,
14140     &ffecom_f2c_real_type_node,
14141     &ffecom_f2c_ptr_to_real_type_node,
14142     &ffecom_f2c_doublereal_type_node,
14143     &ffecom_f2c_complex_type_node,
14144     &ffecom_f2c_doublecomplex_type_node,
14145     &ffecom_f2c_longint_type_node,
14146     &ffecom_f2c_logical_type_node,
14147     &ffecom_f2c_flag_type_node,
14148     &ffecom_f2c_ftnlen_type_node,
14149     &ffecom_f2c_ftnlen_zero_node,
14150     &ffecom_f2c_ftnlen_one_node,
14151     &ffecom_f2c_ftnlen_two_node,
14152     &ffecom_f2c_ptr_to_ftnlen_type_node,
14153     &ffecom_f2c_ftnint_type_node,
14154     &ffecom_f2c_ptr_to_ftnint_type_node,
14155     &ffecom_outer_function_decl_,
14156     &ffecom_previous_function_decl_,
14157     &ffecom_which_entrypoint_decl_,
14158     &ffecom_float_zero_,
14159     &ffecom_float_half_,
14160     &ffecom_double_zero_,
14161     &ffecom_double_half_,
14162     &ffecom_func_result_,
14163     &ffecom_func_length_,
14164     &ffecom_multi_type_node_,
14165     &ffecom_multi_retval_,
14166     &named_labels,
14167     &shadowed_labels
14168   };
14169   size_t i;
14170
14171   malloc_init ();
14172
14173   /* Record our roots.  */
14174   for (i = 0; i < ARRAY_SIZE (tree_roots); i++)
14175     ggc_add_tree_root (tree_roots[i], 1);
14176   ggc_add_tree_root (&ffecom_tree_type[0][0],
14177                      FFEINFO_basictype*FFEINFO_kindtype);
14178   ggc_add_tree_root (&ffecom_tree_fun_type[0][0],
14179                      FFEINFO_basictype*FFEINFO_kindtype);
14180   ggc_add_tree_root (&ffecom_tree_ptr_to_fun_type[0][0],
14181                      FFEINFO_basictype*FFEINFO_kindtype);
14182   ggc_add_tree_root (ffecom_gfrt_, FFECOM_gfrt);
14183   ggc_add_root (&current_binding_level, 1, sizeof current_binding_level,
14184                 mark_binding_level);
14185   ggc_add_root (&free_binding_level, 1, sizeof current_binding_level,
14186                 mark_binding_level);
14187   ggc_add_root (&tracker_head, 1, sizeof tracker_head, mark_tracker_head);
14188
14189   ffe_init_0 ();
14190 }
14191
14192 /* Delete the node BLOCK from the current binding level.
14193    This is used for the block inside a stmt expr ({...})
14194    so that the block can be reinserted where appropriate.  */
14195
14196 static void
14197 delete_block (block)
14198      tree block;
14199 {
14200   tree t;
14201   if (current_binding_level->blocks == block)
14202     current_binding_level->blocks = TREE_CHAIN (block);
14203   for (t = current_binding_level->blocks; t;)
14204     {
14205       if (TREE_CHAIN (t) == block)
14206         TREE_CHAIN (t) = TREE_CHAIN (block);
14207       else
14208         t = TREE_CHAIN (t);
14209     }
14210   TREE_CHAIN (block) = NULL;
14211   /* Clear TREE_USED which is always set by poplevel.
14212      The flag is set again if insert_block is called.  */
14213   TREE_USED (block) = 0;
14214 }
14215
14216 void
14217 insert_block (block)
14218      tree block;
14219 {
14220   TREE_USED (block) = 1;
14221   current_binding_level->blocks
14222     = chainon (current_binding_level->blocks, block);
14223 }
14224
14225 /* Each front end provides its own.  */
14226 static const char *ffe_init PARAMS ((const char *));
14227 static void ffe_finish PARAMS ((void));
14228 static void ffe_init_options PARAMS ((void));
14229 static void ffe_print_identifier PARAMS ((FILE *, tree, int));
14230
14231 #undef  LANG_HOOKS_NAME
14232 #define LANG_HOOKS_NAME                 "GNU F77"
14233 #undef  LANG_HOOKS_INIT
14234 #define LANG_HOOKS_INIT                 ffe_init
14235 #undef  LANG_HOOKS_FINISH
14236 #define LANG_HOOKS_FINISH               ffe_finish
14237 #undef  LANG_HOOKS_INIT_OPTIONS
14238 #define LANG_HOOKS_INIT_OPTIONS         ffe_init_options
14239 #undef  LANG_HOOKS_DECODE_OPTION
14240 #define LANG_HOOKS_DECODE_OPTION        ffe_decode_option
14241 #undef  LANG_HOOKS_PRINT_IDENTIFIER
14242 #define LANG_HOOKS_PRINT_IDENTIFIER     ffe_print_identifier
14243
14244 /* We do not wish to use alias-set based aliasing at all.  Used in the
14245    extreme (every object with its own set, with equivalences recorded) it
14246    might be helpful, but there are problems when it comes to inlining.  We
14247    get on ok with flag_argument_noalias, and alias-set aliasing does
14248    currently limit how stack slots can be reused, which is a lose.  */
14249 #undef LANG_HOOKS_GET_ALIAS_SET
14250 #define LANG_HOOKS_GET_ALIAS_SET hook_get_alias_set_0
14251
14252 const struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER;
14253
14254 static const char *
14255 ffe_init (filename)
14256      const char *filename;
14257 {
14258   /* Open input file.  */
14259   if (filename == 0 || !strcmp (filename, "-"))
14260     {
14261       finput = stdin;
14262       filename = "stdin";
14263     }
14264   else
14265     finput = fopen (filename, "r");
14266   if (finput == 0)
14267     fatal_io_error ("can't open %s", filename);
14268
14269 #ifdef IO_BUFFER_SIZE
14270   setvbuf (finput, (char *) xmalloc (IO_BUFFER_SIZE), _IOFBF, IO_BUFFER_SIZE);
14271 #endif
14272
14273   ffecom_init_decl_processing ();
14274   decl_printable_name = lang_printable_name;
14275   print_error_function = lang_print_error_function;
14276
14277   /* If the file is output from cpp, it should contain a first line
14278      `# 1 "real-filename"', and the current design of gcc (toplev.c
14279      in particular and the way it sets up information relied on by
14280      INCLUDE) requires that we read this now, and store the
14281      "real-filename" info in master_input_filename.  Ask the lexer
14282      to try doing this.  */
14283   ffelex_hash_kludge (finput);
14284
14285   /* FIXME: The ffelex_hash_kludge code needs to be cleaned up to
14286      return the new file name.  */
14287   if (main_input_filename)
14288     filename = main_input_filename;
14289
14290   return filename;
14291 }
14292
14293 static void
14294 ffe_finish ()
14295 {
14296   ffe_terminate_0 ();
14297
14298   if (ffe_is_ffedebug ())
14299     malloc_pool_display (malloc_pool_image ());
14300
14301   fclose (finput);
14302 }
14303
14304 static void
14305 ffe_init_options ()
14306 {
14307   /* Set default options for Fortran.  */
14308   flag_move_all_movables = 1;
14309   flag_reduce_all_givs = 1;
14310   flag_argument_noalias = 2;
14311   flag_merge_constants = 2;
14312   flag_errno_math = 0;
14313   flag_complex_divide_method = 1;
14314 }
14315
14316 int
14317 mark_addressable (exp)
14318      tree exp;
14319 {
14320   register tree x = exp;
14321   while (1)
14322     switch (TREE_CODE (x))
14323       {
14324       case ADDR_EXPR:
14325       case COMPONENT_REF:
14326       case ARRAY_REF:
14327         x = TREE_OPERAND (x, 0);
14328         break;
14329
14330       case CONSTRUCTOR:
14331         TREE_ADDRESSABLE (x) = 1;
14332         return 1;
14333
14334       case VAR_DECL:
14335       case CONST_DECL:
14336       case PARM_DECL:
14337       case RESULT_DECL:
14338         if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x)
14339             && DECL_NONLOCAL (x))
14340           {
14341             if (TREE_PUBLIC (x))
14342               {
14343                 assert ("address of global register var requested" == NULL);
14344                 return 0;
14345               }
14346             assert ("address of register variable requested" == NULL);
14347           }
14348         else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x))
14349           {
14350             if (TREE_PUBLIC (x))
14351               {
14352                 assert ("address of global register var requested" == NULL);
14353                 return 0;
14354               }
14355             assert ("address of register var requested" == NULL);
14356           }
14357         put_var_into_stack (x);
14358
14359         /* drops in */
14360       case FUNCTION_DECL:
14361         TREE_ADDRESSABLE (x) = 1;
14362 #if 0                           /* poplevel deals with this now.  */
14363         if (DECL_CONTEXT (x) == 0)
14364           TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x)) = 1;
14365 #endif
14366
14367       default:
14368         return 1;
14369       }
14370 }
14371
14372 /* If DECL has a cleanup, build and return that cleanup here.
14373    This is a callback called by expand_expr.  */
14374
14375 tree
14376 maybe_build_cleanup (decl)
14377      tree decl UNUSED;
14378 {
14379   /* There are no cleanups in Fortran.  */
14380   return NULL_TREE;
14381 }
14382
14383 /* Exit a binding level.
14384    Pop the level off, and restore the state of the identifier-decl mappings
14385    that were in effect when this level was entered.
14386
14387    If KEEP is nonzero, this level had explicit declarations, so
14388    and create a "block" (a BLOCK node) for the level
14389    to record its declarations and subblocks for symbol table output.
14390
14391    If FUNCTIONBODY is nonzero, this level is the body of a function,
14392    so create a block as if KEEP were set and also clear out all
14393    label names.
14394
14395    If REVERSE is nonzero, reverse the order of decls before putting
14396    them into the BLOCK.  */
14397
14398 tree
14399 poplevel (keep, reverse, functionbody)
14400      int keep;
14401      int reverse;
14402      int functionbody;
14403 {
14404   register tree link;
14405   /* The chain of decls was accumulated in reverse order.
14406      Put it into forward order, just for cleanliness.  */
14407   tree decls;
14408   tree subblocks = current_binding_level->blocks;
14409   tree block = 0;
14410   tree decl;
14411   int block_previously_created;
14412
14413   /* Get the decls in the order they were written.
14414      Usually current_binding_level->names is in reverse order.
14415      But parameter decls were previously put in forward order.  */
14416
14417   if (reverse)
14418     current_binding_level->names
14419       = decls = nreverse (current_binding_level->names);
14420   else
14421     decls = current_binding_level->names;
14422
14423   /* Output any nested inline functions within this block
14424      if they weren't already output.  */
14425
14426   for (decl = decls; decl; decl = TREE_CHAIN (decl))
14427     if (TREE_CODE (decl) == FUNCTION_DECL
14428         && ! TREE_ASM_WRITTEN (decl)
14429         && DECL_INITIAL (decl) != 0
14430         && TREE_ADDRESSABLE (decl))
14431       {
14432         /* If this decl was copied from a file-scope decl
14433            on account of a block-scope extern decl,
14434            propagate TREE_ADDRESSABLE to the file-scope decl.
14435
14436            DECL_ABSTRACT_ORIGIN can be set to itself if warn_return_type is
14437            true, since then the decl goes through save_for_inline_copying.  */
14438         if (DECL_ABSTRACT_ORIGIN (decl) != 0
14439             && DECL_ABSTRACT_ORIGIN (decl) != decl)
14440           TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl)) = 1;
14441         else if (DECL_SAVED_INSNS (decl) != 0)
14442           {
14443             push_function_context ();
14444             output_inline_function (decl);
14445             pop_function_context ();
14446           }
14447       }
14448
14449   /* If there were any declarations or structure tags in that level,
14450      or if this level is a function body,
14451      create a BLOCK to record them for the life of this function.  */
14452
14453   block = 0;
14454   block_previously_created = (current_binding_level->this_block != 0);
14455   if (block_previously_created)
14456     block = current_binding_level->this_block;
14457   else if (keep || functionbody)
14458     block = make_node (BLOCK);
14459   if (block != 0)
14460     {
14461       BLOCK_VARS (block) = decls;
14462       BLOCK_SUBBLOCKS (block) = subblocks;
14463     }
14464
14465   /* In each subblock, record that this is its superior.  */
14466
14467   for (link = subblocks; link; link = TREE_CHAIN (link))
14468     BLOCK_SUPERCONTEXT (link) = block;
14469
14470   /* Clear out the meanings of the local variables of this level.  */
14471
14472   for (link = decls; link; link = TREE_CHAIN (link))
14473     {
14474       if (DECL_NAME (link) != 0)
14475         {
14476           /* If the ident. was used or addressed via a local extern decl,
14477              don't forget that fact.  */
14478           if (DECL_EXTERNAL (link))
14479             {
14480               if (TREE_USED (link))
14481                 TREE_USED (DECL_NAME (link)) = 1;
14482               if (TREE_ADDRESSABLE (link))
14483                 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (link)) = 1;
14484             }
14485           IDENTIFIER_LOCAL_VALUE (DECL_NAME (link)) = 0;
14486         }
14487     }
14488
14489   /* If the level being exited is the top level of a function,
14490      check over all the labels, and clear out the current
14491      (function local) meanings of their names.  */
14492
14493   if (functionbody)
14494     {
14495       /* If this is the top level block of a function,
14496          the vars are the function's parameters.
14497          Don't leave them in the BLOCK because they are
14498          found in the FUNCTION_DECL instead.  */
14499
14500       BLOCK_VARS (block) = 0;
14501     }
14502
14503   /* Pop the current level, and free the structure for reuse.  */
14504
14505   {
14506     register struct binding_level *level = current_binding_level;
14507     current_binding_level = current_binding_level->level_chain;
14508
14509     level->level_chain = free_binding_level;
14510     free_binding_level = level;
14511   }
14512
14513   /* Dispose of the block that we just made inside some higher level.  */
14514   if (functionbody
14515       && current_function_decl != error_mark_node)
14516     DECL_INITIAL (current_function_decl) = block;
14517   else if (block)
14518     {
14519       if (!block_previously_created)
14520         current_binding_level->blocks
14521           = chainon (current_binding_level->blocks, block);
14522     }
14523   /* If we did not make a block for the level just exited,
14524      any blocks made for inner levels
14525      (since they cannot be recorded as subblocks in that level)
14526      must be carried forward so they will later become subblocks
14527      of something else.  */
14528   else if (subblocks)
14529     current_binding_level->blocks
14530       = chainon (current_binding_level->blocks, subblocks);
14531
14532   if (block)
14533     TREE_USED (block) = 1;
14534   return block;
14535 }
14536
14537 static void
14538 ffe_print_identifier (file, node, indent)
14539      FILE *file;
14540      tree node;
14541      int indent;
14542 {
14543   print_node (file, "global", IDENTIFIER_GLOBAL_VALUE (node), indent + 4);
14544   print_node (file, "local", IDENTIFIER_LOCAL_VALUE (node), indent + 4);
14545 }
14546
14547 /* Record a decl-node X as belonging to the current lexical scope.
14548    Check for errors (such as an incompatible declaration for the same
14549    name already seen in the same scope).
14550
14551    Returns either X or an old decl for the same name.
14552    If an old decl is returned, it may have been smashed
14553    to agree with what X says.  */
14554
14555 tree
14556 pushdecl (x)
14557      tree x;
14558 {
14559   register tree t;
14560   register tree name = DECL_NAME (x);
14561   register struct binding_level *b = current_binding_level;
14562
14563   if ((TREE_CODE (x) == FUNCTION_DECL)
14564       && (DECL_INITIAL (x) == 0)
14565       && DECL_EXTERNAL (x))
14566     DECL_CONTEXT (x) = NULL_TREE;
14567   else
14568     DECL_CONTEXT (x) = current_function_decl;
14569
14570   if (name)
14571     {
14572       if (IDENTIFIER_INVENTED (name))
14573         {
14574           DECL_ARTIFICIAL (x) = 1;
14575           DECL_IN_SYSTEM_HEADER (x) = 1;
14576         }
14577
14578       t = lookup_name_current_level (name);
14579
14580       assert ((t == NULL_TREE) || (DECL_CONTEXT (x) == NULL_TREE));
14581
14582       /* Don't push non-parms onto list for parms until we understand
14583          why we're doing this and whether it works.  */
14584
14585       assert ((b == global_binding_level)
14586               || !ffecom_transform_only_dummies_
14587               || TREE_CODE (x) == PARM_DECL);
14588
14589       if ((t != NULL_TREE) && duplicate_decls (x, t))
14590         return t;
14591
14592       /* If we are processing a typedef statement, generate a whole new
14593          ..._TYPE node (which will be just an variant of the existing
14594          ..._TYPE node with identical properties) and then install the
14595          TYPE_DECL node generated to represent the typedef name as the
14596          TYPE_NAME of this brand new (duplicate) ..._TYPE node.
14597
14598          The whole point here is to end up with a situation where each and every
14599          ..._TYPE node the compiler creates will be uniquely associated with
14600          AT MOST one node representing a typedef name. This way, even though
14601          the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL
14602          (i.e. "typedef name") nodes very early on, later parts of the
14603          compiler can always do the reverse translation and get back the
14604          corresponding typedef name.  For example, given:
14605
14606          typedef struct S MY_TYPE; MY_TYPE object;
14607
14608          Later parts of the compiler might only know that `object' was of type
14609          `struct S' if it were not for code just below.  With this code
14610          however, later parts of the compiler see something like:
14611
14612          struct S' == struct S typedef struct S' MY_TYPE; struct S' object;
14613
14614          And they can then deduce (from the node for type struct S') that the
14615          original object declaration was:
14616
14617          MY_TYPE object;
14618
14619          Being able to do this is important for proper support of protoize, and
14620          also for generating precise symbolic debugging information which
14621          takes full account of the programmer's (typedef) vocabulary.
14622
14623          Obviously, we don't want to generate a duplicate ..._TYPE node if the
14624          TYPE_DECL node that we are now processing really represents a
14625          standard built-in type.
14626
14627          Since all standard types are effectively declared at line zero in the
14628          source file, we can easily check to see if we are working on a
14629          standard type by checking the current value of lineno.  */
14630
14631       if (TREE_CODE (x) == TYPE_DECL)
14632         {
14633           if (DECL_SOURCE_LINE (x) == 0)
14634             {
14635               if (TYPE_NAME (TREE_TYPE (x)) == 0)
14636                 TYPE_NAME (TREE_TYPE (x)) = x;
14637             }
14638           else if (TREE_TYPE (x) != error_mark_node)
14639             {
14640               tree tt = TREE_TYPE (x);
14641
14642               tt = build_type_copy (tt);
14643               TYPE_NAME (tt) = x;
14644               TREE_TYPE (x) = tt;
14645             }
14646         }
14647
14648       /* This name is new in its binding level. Install the new declaration
14649          and return it.  */
14650       if (b == global_binding_level)
14651         IDENTIFIER_GLOBAL_VALUE (name) = x;
14652       else
14653         IDENTIFIER_LOCAL_VALUE (name) = x;
14654     }
14655
14656   /* Put decls on list in reverse order. We will reverse them later if
14657      necessary.  */
14658   TREE_CHAIN (x) = b->names;
14659   b->names = x;
14660
14661   return x;
14662 }
14663
14664 /* Nonzero if the current level needs to have a BLOCK made.  */
14665
14666 static int
14667 kept_level_p ()
14668 {
14669   tree decl;
14670
14671   for (decl = current_binding_level->names;
14672        decl;
14673        decl = TREE_CHAIN (decl))
14674     {
14675       if (TREE_USED (decl) || TREE_CODE (decl) != VAR_DECL
14676           || (DECL_NAME (decl) && ! DECL_ARTIFICIAL (decl)))
14677         /* Currently, there aren't supposed to be non-artificial names
14678            at other than the top block for a function -- they're
14679            believed to always be temps.  But it's wise to check anyway.  */
14680         return 1;
14681     }
14682   return 0;
14683 }
14684
14685 /* Enter a new binding level.
14686    If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
14687    not for that of tags.  */
14688
14689 void
14690 pushlevel (tag_transparent)
14691      int tag_transparent;
14692 {
14693   register struct binding_level *newlevel = NULL_BINDING_LEVEL;
14694
14695   assert (! tag_transparent);
14696
14697   if (current_binding_level == global_binding_level)
14698     {
14699       named_labels = 0;
14700     }
14701
14702   /* Reuse or create a struct for this binding level.  */
14703
14704   if (free_binding_level)
14705     {
14706       newlevel = free_binding_level;
14707       free_binding_level = free_binding_level->level_chain;
14708     }
14709   else
14710     {
14711       newlevel = make_binding_level ();
14712     }
14713
14714   /* Add this level to the front of the chain (stack) of levels that
14715      are active.  */
14716
14717   *newlevel = clear_binding_level;
14718   newlevel->level_chain = current_binding_level;
14719   current_binding_level = newlevel;
14720 }
14721
14722 /* Set the BLOCK node for the innermost scope
14723    (the one we are currently in).  */
14724
14725 void
14726 set_block (block)
14727      register tree block;
14728 {
14729   current_binding_level->this_block = block;
14730   current_binding_level->names = chainon (current_binding_level->names,
14731                                           BLOCK_VARS (block));
14732   current_binding_level->blocks = chainon (current_binding_level->blocks,
14733                                            BLOCK_SUBBLOCKS (block));
14734 }
14735
14736 tree
14737 signed_or_unsigned_type (unsignedp, type)
14738      int unsignedp;
14739      tree type;
14740 {
14741   tree type2;
14742
14743   if (! INTEGRAL_TYPE_P (type))
14744     return type;
14745   if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node))
14746     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
14747   if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node))
14748     return unsignedp ? unsigned_type_node : integer_type_node;
14749   if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node))
14750     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
14751   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node))
14752     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
14753   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node))
14754     return (unsignedp ? long_long_unsigned_type_node
14755             : long_long_integer_type_node);
14756
14757   type2 = type_for_size (TYPE_PRECISION (type), unsignedp);
14758   if (type2 == NULL_TREE)
14759     return type;
14760
14761   return type2;
14762 }
14763
14764 tree
14765 signed_type (type)
14766      tree type;
14767 {
14768   tree type1 = TYPE_MAIN_VARIANT (type);
14769   ffeinfoKindtype kt;
14770   tree type2;
14771
14772   if (type1 == unsigned_char_type_node || type1 == char_type_node)
14773     return signed_char_type_node;
14774   if (type1 == unsigned_type_node)
14775     return integer_type_node;
14776   if (type1 == short_unsigned_type_node)
14777     return short_integer_type_node;
14778   if (type1 == long_unsigned_type_node)
14779     return long_integer_type_node;
14780   if (type1 == long_long_unsigned_type_node)
14781     return long_long_integer_type_node;
14782 #if 0   /* gcc/c-* files only */
14783   if (type1 == unsigned_intDI_type_node)
14784     return intDI_type_node;
14785   if (type1 == unsigned_intSI_type_node)
14786     return intSI_type_node;
14787   if (type1 == unsigned_intHI_type_node)
14788     return intHI_type_node;
14789   if (type1 == unsigned_intQI_type_node)
14790     return intQI_type_node;
14791 #endif
14792
14793   type2 = type_for_size (TYPE_PRECISION (type1), 0);
14794   if (type2 != NULL_TREE)
14795     return type2;
14796
14797   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
14798     {
14799       type2 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
14800
14801       if (type1 == type2)
14802         return ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
14803     }
14804
14805   return type;
14806 }
14807
14808 /* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
14809    or validate its data type for an `if' or `while' statement or ?..: exp.
14810
14811    This preparation consists of taking the ordinary
14812    representation of an expression expr and producing a valid tree
14813    boolean expression describing whether expr is nonzero.  We could
14814    simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
14815    but we optimize comparisons, &&, ||, and !.
14816
14817    The resulting type should always be `integer_type_node'.  */
14818
14819 tree
14820 truthvalue_conversion (expr)
14821      tree expr;
14822 {
14823   if (TREE_CODE (expr) == ERROR_MARK)
14824     return expr;
14825
14826 #if 0 /* This appears to be wrong for C++.  */
14827   /* These really should return error_mark_node after 2.4 is stable.
14828      But not all callers handle ERROR_MARK properly.  */
14829   switch (TREE_CODE (TREE_TYPE (expr)))
14830     {
14831     case RECORD_TYPE:
14832       error ("struct type value used where scalar is required");
14833       return integer_zero_node;
14834
14835     case UNION_TYPE:
14836       error ("union type value used where scalar is required");
14837       return integer_zero_node;
14838
14839     case ARRAY_TYPE:
14840       error ("array type value used where scalar is required");
14841       return integer_zero_node;
14842
14843     default:
14844       break;
14845     }
14846 #endif /* 0 */
14847
14848   switch (TREE_CODE (expr))
14849     {
14850       /* It is simpler and generates better code to have only TRUTH_*_EXPR
14851          or comparison expressions as truth values at this level.  */
14852 #if 0
14853     case COMPONENT_REF:
14854       /* A one-bit unsigned bit-field is already acceptable.  */
14855       if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr, 1)))
14856           && TREE_UNSIGNED (TREE_OPERAND (expr, 1)))
14857         return expr;
14858       break;
14859 #endif
14860
14861     case EQ_EXPR:
14862       /* It is simpler and generates better code to have only TRUTH_*_EXPR
14863          or comparison expressions as truth values at this level.  */
14864 #if 0
14865       if (integer_zerop (TREE_OPERAND (expr, 1)))
14866         return build_unary_op (TRUTH_NOT_EXPR, TREE_OPERAND (expr, 0), 0);
14867 #endif
14868     case NE_EXPR: case LE_EXPR: case GE_EXPR: case LT_EXPR: case GT_EXPR:
14869     case TRUTH_ANDIF_EXPR:
14870     case TRUTH_ORIF_EXPR:
14871     case TRUTH_AND_EXPR:
14872     case TRUTH_OR_EXPR:
14873     case TRUTH_XOR_EXPR:
14874       TREE_TYPE (expr) = integer_type_node;
14875       return expr;
14876
14877     case ERROR_MARK:
14878       return expr;
14879
14880     case INTEGER_CST:
14881       return integer_zerop (expr) ? integer_zero_node : integer_one_node;
14882
14883     case REAL_CST:
14884       return real_zerop (expr) ? integer_zero_node : integer_one_node;
14885
14886     case ADDR_EXPR:
14887       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 0)))
14888         return build (COMPOUND_EXPR, integer_type_node,
14889                       TREE_OPERAND (expr, 0), integer_one_node);
14890       else
14891         return integer_one_node;
14892
14893     case COMPLEX_EXPR:
14894       return ffecom_2 ((TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1))
14895                         ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
14896                        integer_type_node,
14897                        truthvalue_conversion (TREE_OPERAND (expr, 0)),
14898                        truthvalue_conversion (TREE_OPERAND (expr, 1)));
14899
14900     case NEGATE_EXPR:
14901     case ABS_EXPR:
14902     case FLOAT_EXPR:
14903     case FFS_EXPR:
14904       /* These don't change whether an object is non-zero or zero.  */
14905       return truthvalue_conversion (TREE_OPERAND (expr, 0));
14906
14907     case LROTATE_EXPR:
14908     case RROTATE_EXPR:
14909       /* These don't change whether an object is zero or non-zero, but
14910          we can't ignore them if their second arg has side-effects.  */
14911       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1)))
14912         return build (COMPOUND_EXPR, integer_type_node, TREE_OPERAND (expr, 1),
14913                       truthvalue_conversion (TREE_OPERAND (expr, 0)));
14914       else
14915         return truthvalue_conversion (TREE_OPERAND (expr, 0));
14916
14917     case COND_EXPR:
14918       /* Distribute the conversion into the arms of a COND_EXPR.  */
14919       return fold (build (COND_EXPR, integer_type_node, TREE_OPERAND (expr, 0),
14920                           truthvalue_conversion (TREE_OPERAND (expr, 1)),
14921                           truthvalue_conversion (TREE_OPERAND (expr, 2))));
14922
14923     case CONVERT_EXPR:
14924       /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
14925          since that affects how `default_conversion' will behave.  */
14926       if (TREE_CODE (TREE_TYPE (expr)) == REFERENCE_TYPE
14927           || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) == REFERENCE_TYPE)
14928         break;
14929       /* fall through... */
14930     case NOP_EXPR:
14931       /* If this is widening the argument, we can ignore it.  */
14932       if (TYPE_PRECISION (TREE_TYPE (expr))
14933           >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr, 0))))
14934         return truthvalue_conversion (TREE_OPERAND (expr, 0));
14935       break;
14936
14937     case MINUS_EXPR:
14938       /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize
14939          this case.  */
14940       if (TARGET_FLOAT_FORMAT == IEEE_FLOAT_FORMAT
14941           && TREE_CODE (TREE_TYPE (expr)) == REAL_TYPE)
14942         break;
14943       /* fall through... */
14944     case BIT_XOR_EXPR:
14945       /* This and MINUS_EXPR can be changed into a comparison of the
14946          two objects.  */
14947       if (TREE_TYPE (TREE_OPERAND (expr, 0))
14948           == TREE_TYPE (TREE_OPERAND (expr, 1)))
14949         return ffecom_2 (NE_EXPR, integer_type_node,
14950                          TREE_OPERAND (expr, 0),
14951                          TREE_OPERAND (expr, 1));
14952       return ffecom_2 (NE_EXPR, integer_type_node,
14953                        TREE_OPERAND (expr, 0),
14954                        fold (build1 (NOP_EXPR,
14955                                      TREE_TYPE (TREE_OPERAND (expr, 0)),
14956                                      TREE_OPERAND (expr, 1))));
14957
14958     case BIT_AND_EXPR:
14959       if (integer_onep (TREE_OPERAND (expr, 1)))
14960         return expr;
14961       break;
14962
14963     case MODIFY_EXPR:
14964 #if 0                           /* No such thing in Fortran. */
14965       if (warn_parentheses && C_EXP_ORIGINAL_CODE (expr) == MODIFY_EXPR)
14966         warning ("suggest parentheses around assignment used as truth value");
14967 #endif
14968       break;
14969
14970     default:
14971       break;
14972     }
14973
14974   if (TREE_CODE (TREE_TYPE (expr)) == COMPLEX_TYPE)
14975     return (ffecom_2
14976             ((TREE_SIDE_EFFECTS (expr)
14977               ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
14978              integer_type_node,
14979              truthvalue_conversion (ffecom_1 (REALPART_EXPR,
14980                                               TREE_TYPE (TREE_TYPE (expr)),
14981                                               expr)),
14982              truthvalue_conversion (ffecom_1 (IMAGPART_EXPR,
14983                                               TREE_TYPE (TREE_TYPE (expr)),
14984                                               expr))));
14985
14986   return ffecom_2 (NE_EXPR, integer_type_node,
14987                    expr,
14988                    convert (TREE_TYPE (expr), integer_zero_node));
14989 }
14990
14991 tree
14992 type_for_mode (mode, unsignedp)
14993      enum machine_mode mode;
14994      int unsignedp;
14995 {
14996   int i;
14997   int j;
14998   tree t;
14999
15000   if (mode == TYPE_MODE (integer_type_node))
15001     return unsignedp ? unsigned_type_node : integer_type_node;
15002
15003   if (mode == TYPE_MODE (signed_char_type_node))
15004     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15005
15006   if (mode == TYPE_MODE (short_integer_type_node))
15007     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15008
15009   if (mode == TYPE_MODE (long_integer_type_node))
15010     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15011
15012   if (mode == TYPE_MODE (long_long_integer_type_node))
15013     return unsignedp ? long_long_unsigned_type_node : long_long_integer_type_node;
15014
15015 #if HOST_BITS_PER_WIDE_INT >= 64
15016   if (mode == TYPE_MODE (intTI_type_node))
15017     return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
15018 #endif
15019
15020   if (mode == TYPE_MODE (float_type_node))
15021     return float_type_node;
15022
15023   if (mode == TYPE_MODE (double_type_node))
15024     return double_type_node;
15025
15026   if (mode == TYPE_MODE (build_pointer_type (char_type_node)))
15027     return build_pointer_type (char_type_node);
15028
15029   if (mode == TYPE_MODE (build_pointer_type (integer_type_node)))
15030     return build_pointer_type (integer_type_node);
15031
15032   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
15033     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
15034       {
15035         if (((t = ffecom_tree_type[i][j]) != NULL_TREE)
15036             && (mode == TYPE_MODE (t)))
15037           {
15038             if ((i == FFEINFO_basictypeINTEGER) && unsignedp)
15039               return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][j];
15040             else
15041               return t;
15042           }
15043       }
15044
15045   return 0;
15046 }
15047
15048 tree
15049 type_for_size (bits, unsignedp)
15050      unsigned bits;
15051      int unsignedp;
15052 {
15053   ffeinfoKindtype kt;
15054   tree type_node;
15055
15056   if (bits == TYPE_PRECISION (integer_type_node))
15057     return unsignedp ? unsigned_type_node : integer_type_node;
15058
15059   if (bits == TYPE_PRECISION (signed_char_type_node))
15060     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15061
15062   if (bits == TYPE_PRECISION (short_integer_type_node))
15063     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15064
15065   if (bits == TYPE_PRECISION (long_integer_type_node))
15066     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15067
15068   if (bits == TYPE_PRECISION (long_long_integer_type_node))
15069     return (unsignedp ? long_long_unsigned_type_node
15070             : long_long_integer_type_node);
15071
15072   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15073     {
15074       type_node = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15075
15076       if ((type_node != NULL_TREE) && (bits == TYPE_PRECISION (type_node)))
15077         return unsignedp ? ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]
15078           : type_node;
15079     }
15080
15081   return 0;
15082 }
15083
15084 tree
15085 unsigned_type (type)
15086      tree type;
15087 {
15088   tree type1 = TYPE_MAIN_VARIANT (type);
15089   ffeinfoKindtype kt;
15090   tree type2;
15091
15092   if (type1 == signed_char_type_node || type1 == char_type_node)
15093     return unsigned_char_type_node;
15094   if (type1 == integer_type_node)
15095     return unsigned_type_node;
15096   if (type1 == short_integer_type_node)
15097     return short_unsigned_type_node;
15098   if (type1 == long_integer_type_node)
15099     return long_unsigned_type_node;
15100   if (type1 == long_long_integer_type_node)
15101     return long_long_unsigned_type_node;
15102 #if 0   /* gcc/c-* files only */
15103   if (type1 == intDI_type_node)
15104     return unsigned_intDI_type_node;
15105   if (type1 == intSI_type_node)
15106     return unsigned_intSI_type_node;
15107   if (type1 == intHI_type_node)
15108     return unsigned_intHI_type_node;
15109   if (type1 == intQI_type_node)
15110     return unsigned_intQI_type_node;
15111 #endif
15112
15113   type2 = type_for_size (TYPE_PRECISION (type1), 1);
15114   if (type2 != NULL_TREE)
15115     return type2;
15116
15117   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15118     {
15119       type2 = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15120
15121       if (type1 == type2)
15122         return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
15123     }
15124
15125   return type;
15126 }
15127
15128 void
15129 lang_mark_tree (t)
15130      union tree_node *t ATTRIBUTE_UNUSED;
15131 {
15132   if (TREE_CODE (t) == IDENTIFIER_NODE)
15133     {
15134       struct lang_identifier *i = (struct lang_identifier *) t;
15135       ggc_mark_tree (IDENTIFIER_GLOBAL_VALUE (i));
15136       ggc_mark_tree (IDENTIFIER_LOCAL_VALUE (i));
15137       ggc_mark_tree (IDENTIFIER_LABEL_VALUE (i));
15138     }
15139   else if (TYPE_P (t) && TYPE_LANG_SPECIFIC (t))
15140     ggc_mark (TYPE_LANG_SPECIFIC (t));
15141 }
15142 \f
15143 /* From gcc/cccp.c, the code to handle -I.  */
15144
15145 /* Skip leading "./" from a directory name.
15146    This may yield the empty string, which represents the current directory.  */
15147
15148 static const char *
15149 skip_redundant_dir_prefix (const char *dir)
15150 {
15151   while (dir[0] == '.' && dir[1] == '/')
15152     for (dir += 2; *dir == '/'; dir++)
15153       continue;
15154   if (dir[0] == '.' && !dir[1])
15155     dir++;
15156   return dir;
15157 }
15158
15159 /* The file_name_map structure holds a mapping of file names for a
15160    particular directory.  This mapping is read from the file named
15161    FILE_NAME_MAP_FILE in that directory.  Such a file can be used to
15162    map filenames on a file system with severe filename restrictions,
15163    such as DOS.  The format of the file name map file is just a series
15164    of lines with two tokens on each line.  The first token is the name
15165    to map, and the second token is the actual name to use.  */
15166
15167 struct file_name_map
15168 {
15169   struct file_name_map *map_next;
15170   char *map_from;
15171   char *map_to;
15172 };
15173
15174 #define FILE_NAME_MAP_FILE "header.gcc"
15175
15176 /* Current maximum length of directory names in the search path
15177    for include files.  (Altered as we get more of them.)  */
15178
15179 static int max_include_len = 0;
15180
15181 struct file_name_list
15182   {
15183     struct file_name_list *next;
15184     char *fname;
15185     /* Mapping of file names for this directory.  */
15186     struct file_name_map *name_map;
15187     /* Non-zero if name_map is valid.  */
15188     int got_name_map;
15189   };
15190
15191 static struct file_name_list *include = NULL;   /* First dir to search */
15192 static struct file_name_list *last_include = NULL;      /* Last in chain */
15193
15194 /* I/O buffer structure.
15195    The `fname' field is nonzero for source files and #include files
15196    and for the dummy text used for -D and -U.
15197    It is zero for rescanning results of macro expansion
15198    and for expanding macro arguments.  */
15199 #define INPUT_STACK_MAX 400
15200 static struct file_buf {
15201   const char *fname;
15202   /* Filename specified with #line command.  */
15203   const char *nominal_fname;
15204   /* Record where in the search path this file was found.
15205      For #include_next.  */
15206   struct file_name_list *dir;
15207   ffewhereLine line;
15208   ffewhereColumn column;
15209 } instack[INPUT_STACK_MAX];
15210
15211 static int last_error_tick = 0;    /* Incremented each time we print it.  */
15212 static int input_file_stack_tick = 0;  /* Incremented when status changes.  */
15213
15214 /* Current nesting level of input sources.
15215    `instack[indepth]' is the level currently being read.  */
15216 static int indepth = -1;
15217
15218 typedef struct file_buf FILE_BUF;
15219
15220 /* Nonzero means -I- has been seen,
15221    so don't look for #include "foo" the source-file directory.  */
15222 static int ignore_srcdir;
15223
15224 #ifndef INCLUDE_LEN_FUDGE
15225 #define INCLUDE_LEN_FUDGE 0
15226 #endif
15227
15228 static void append_include_chain (struct file_name_list *first,
15229                                   struct file_name_list *last);
15230 static FILE *open_include_file (char *filename,
15231                                 struct file_name_list *searchptr);
15232 static void print_containing_files (ffebadSeverity sev);
15233 static char *read_filename_string (int ch, FILE *f);
15234 static struct file_name_map *read_name_map (const char *dirname);
15235
15236 /* Append a chain of `struct file_name_list's
15237    to the end of the main include chain.
15238    FIRST is the beginning of the chain to append, and LAST is the end.  */
15239
15240 static void
15241 append_include_chain (first, last)
15242      struct file_name_list *first, *last;
15243 {
15244   struct file_name_list *dir;
15245
15246   if (!first || !last)
15247     return;
15248
15249   if (include == 0)
15250     include = first;
15251   else
15252     last_include->next = first;
15253
15254   for (dir = first; ; dir = dir->next) {
15255     int len = strlen (dir->fname) + INCLUDE_LEN_FUDGE;
15256     if (len > max_include_len)
15257       max_include_len = len;
15258     if (dir == last)
15259       break;
15260   }
15261
15262   last->next = NULL;
15263   last_include = last;
15264 }
15265
15266 /* Try to open include file FILENAME.  SEARCHPTR is the directory
15267    being tried from the include file search path.  This function maps
15268    filenames on file systems based on information read by
15269    read_name_map.  */
15270
15271 static FILE *
15272 open_include_file (filename, searchptr)
15273      char *filename;
15274      struct file_name_list *searchptr;
15275 {
15276   register struct file_name_map *map;
15277   register char *from;
15278   char *p, *dir;
15279
15280   if (searchptr && ! searchptr->got_name_map)
15281     {
15282       searchptr->name_map = read_name_map (searchptr->fname
15283                                            ? searchptr->fname : ".");
15284       searchptr->got_name_map = 1;
15285     }
15286
15287   /* First check the mapping for the directory we are using.  */
15288   if (searchptr && searchptr->name_map)
15289     {
15290       from = filename;
15291       if (searchptr->fname)
15292         from += strlen (searchptr->fname) + 1;
15293       for (map = searchptr->name_map; map; map = map->map_next)
15294         {
15295           if (! strcmp (map->map_from, from))
15296             {
15297               /* Found a match.  */
15298               return fopen (map->map_to, "r");
15299             }
15300         }
15301     }
15302
15303   /* Try to find a mapping file for the particular directory we are
15304      looking in.  Thus #include <sys/types.h> will look up sys/types.h
15305      in /usr/include/header.gcc and look up types.h in
15306      /usr/include/sys/header.gcc.  */
15307   p = strrchr (filename, '/');
15308 #ifdef DIR_SEPARATOR
15309   if (! p) p = strrchr (filename, DIR_SEPARATOR);
15310   else {
15311     char *tmp = strrchr (filename, DIR_SEPARATOR);
15312     if (tmp != NULL && tmp > p) p = tmp;
15313   }
15314 #endif
15315   if (! p)
15316     p = filename;
15317   if (searchptr
15318       && searchptr->fname
15319       && strlen (searchptr->fname) == (size_t) (p - filename)
15320       && ! strncmp (searchptr->fname, filename, (int) (p - filename)))
15321     {
15322       /* FILENAME is in SEARCHPTR, which we've already checked.  */
15323       return fopen (filename, "r");
15324     }
15325
15326   if (p == filename)
15327     {
15328       from = filename;
15329       map = read_name_map (".");
15330     }
15331   else
15332     {
15333       dir = (char *) xmalloc (p - filename + 1);
15334       memcpy (dir, filename, p - filename);
15335       dir[p - filename] = '\0';
15336       from = p + 1;
15337       map = read_name_map (dir);
15338       free (dir);
15339     }
15340   for (; map; map = map->map_next)
15341     if (! strcmp (map->map_from, from))
15342       return fopen (map->map_to, "r");
15343
15344   return fopen (filename, "r");
15345 }
15346
15347 /* Print the file names and line numbers of the #include
15348    commands which led to the current file.  */
15349
15350 static void
15351 print_containing_files (ffebadSeverity sev)
15352 {
15353   FILE_BUF *ip = NULL;
15354   int i;
15355   int first = 1;
15356   const char *str1;
15357   const char *str2;
15358
15359   /* If stack of files hasn't changed since we last printed
15360      this info, don't repeat it.  */
15361   if (last_error_tick == input_file_stack_tick)
15362     return;
15363
15364   for (i = indepth; i >= 0; i--)
15365     if (instack[i].fname != NULL) {
15366       ip = &instack[i];
15367       break;
15368     }
15369
15370   /* Give up if we don't find a source file.  */
15371   if (ip == NULL)
15372     return;
15373
15374   /* Find the other, outer source files.  */
15375   for (i--; i >= 0; i--)
15376     if (instack[i].fname != NULL)
15377       {
15378         ip = &instack[i];
15379         if (first)
15380           {
15381             first = 0;
15382             str1 = "In file included";
15383           }
15384         else
15385           {
15386             str1 = "...          ...";
15387           }
15388
15389         if (i == 1)
15390           str2 = ":";
15391         else
15392           str2 = "";
15393
15394         ffebad_start_msg ("%A from %B at %0%C", sev);
15395         ffebad_here (0, ip->line, ip->column);
15396         ffebad_string (str1);
15397         ffebad_string (ip->nominal_fname);
15398         ffebad_string (str2);
15399         ffebad_finish ();
15400       }
15401
15402   /* Record we have printed the status as of this time.  */
15403   last_error_tick = input_file_stack_tick;
15404 }
15405
15406 /* Read a space delimited string of unlimited length from a stdio
15407    file.  */
15408
15409 static char *
15410 read_filename_string (ch, f)
15411      int ch;
15412      FILE *f;
15413 {
15414   char *alloc, *set;
15415   int len;
15416
15417   len = 20;
15418   set = alloc = xmalloc (len + 1);
15419   if (! ISSPACE (ch))
15420     {
15421       *set++ = ch;
15422       while ((ch = getc (f)) != EOF && ! ISSPACE (ch))
15423         {
15424           if (set - alloc == len)
15425             {
15426               len *= 2;
15427               alloc = xrealloc (alloc, len + 1);
15428               set = alloc + len / 2;
15429             }
15430           *set++ = ch;
15431         }
15432     }
15433   *set = '\0';
15434   ungetc (ch, f);
15435   return alloc;
15436 }
15437
15438 /* Read the file name map file for DIRNAME.  */
15439
15440 static struct file_name_map *
15441 read_name_map (dirname)
15442      const char *dirname;
15443 {
15444   /* This structure holds a linked list of file name maps, one per
15445      directory.  */
15446   struct file_name_map_list
15447     {
15448       struct file_name_map_list *map_list_next;
15449       char *map_list_name;
15450       struct file_name_map *map_list_map;
15451     };
15452   static struct file_name_map_list *map_list;
15453   register struct file_name_map_list *map_list_ptr;
15454   char *name;
15455   FILE *f;
15456   size_t dirlen;
15457   int separator_needed;
15458
15459   dirname = skip_redundant_dir_prefix (dirname);
15460
15461   for (map_list_ptr = map_list; map_list_ptr;
15462        map_list_ptr = map_list_ptr->map_list_next)
15463     if (! strcmp (map_list_ptr->map_list_name, dirname))
15464       return map_list_ptr->map_list_map;
15465
15466   map_list_ptr = ((struct file_name_map_list *)
15467                   xmalloc (sizeof (struct file_name_map_list)));
15468   map_list_ptr->map_list_name = xstrdup (dirname);
15469   map_list_ptr->map_list_map = NULL;
15470
15471   dirlen = strlen (dirname);
15472   separator_needed = dirlen != 0 && dirname[dirlen - 1] != '/';
15473   name = (char *) xmalloc (dirlen + strlen (FILE_NAME_MAP_FILE) + 2);
15474   strcpy (name, dirname);
15475   name[dirlen] = '/';
15476   strcpy (name + dirlen + separator_needed, FILE_NAME_MAP_FILE);
15477   f = fopen (name, "r");
15478   free (name);
15479   if (!f)
15480     map_list_ptr->map_list_map = NULL;
15481   else
15482     {
15483       int ch;
15484
15485       while ((ch = getc (f)) != EOF)
15486         {
15487           char *from, *to;
15488           struct file_name_map *ptr;
15489
15490           if (ISSPACE (ch))
15491             continue;
15492           from = read_filename_string (ch, f);
15493           while ((ch = getc (f)) != EOF && ISSPACE (ch) && ch != '\n')
15494             ;
15495           to = read_filename_string (ch, f);
15496
15497           ptr = ((struct file_name_map *)
15498                  xmalloc (sizeof (struct file_name_map)));
15499           ptr->map_from = from;
15500
15501           /* Make the real filename absolute.  */
15502           if (*to == '/')
15503             ptr->map_to = to;
15504           else
15505             {
15506               ptr->map_to = xmalloc (dirlen + strlen (to) + 2);
15507               strcpy (ptr->map_to, dirname);
15508               ptr->map_to[dirlen] = '/';
15509               strcpy (ptr->map_to + dirlen + separator_needed, to);
15510               free (to);
15511             }
15512
15513           ptr->map_next = map_list_ptr->map_list_map;
15514           map_list_ptr->map_list_map = ptr;
15515
15516           while ((ch = getc (f)) != '\n')
15517             if (ch == EOF)
15518               break;
15519         }
15520       fclose (f);
15521     }
15522
15523   map_list_ptr->map_list_next = map_list;
15524   map_list = map_list_ptr;
15525
15526   return map_list_ptr->map_list_map;
15527 }
15528
15529 static void
15530 ffecom_file_ (const char *name)
15531 {
15532   FILE_BUF *fp;
15533
15534   /* Do partial setup of input buffer for the sake of generating
15535      early #line directives (when -g is in effect).  */
15536
15537   fp = &instack[++indepth];
15538   memset ((char *) fp, 0, sizeof (FILE_BUF));
15539   if (name == NULL)
15540     name = "";
15541   fp->nominal_fname = fp->fname = name;
15542 }
15543
15544 static void
15545 ffecom_close_include_ (FILE *f)
15546 {
15547   fclose (f);
15548
15549   indepth--;
15550   input_file_stack_tick++;
15551
15552   ffewhere_line_kill (instack[indepth].line);
15553   ffewhere_column_kill (instack[indepth].column);
15554 }
15555
15556 static int
15557 ffecom_decode_include_option_ (char *spec)
15558 {
15559   struct file_name_list *dirtmp;
15560
15561   if (! ignore_srcdir && !strcmp (spec, "-"))
15562     ignore_srcdir = 1;
15563   else
15564     {
15565       dirtmp = (struct file_name_list *)
15566         xmalloc (sizeof (struct file_name_list));
15567       dirtmp->next = 0;         /* New one goes on the end */
15568       dirtmp->fname = spec;
15569       dirtmp->got_name_map = 0;
15570       if (spec[0] == 0)
15571         error ("directory name must immediately follow -I");
15572       else
15573         append_include_chain (dirtmp, dirtmp);
15574     }
15575   return 1;
15576 }
15577
15578 /* Open INCLUDEd file.  */
15579
15580 static FILE *
15581 ffecom_open_include_ (char *name, ffewhereLine l, ffewhereColumn c)
15582 {
15583   char *fbeg = name;
15584   size_t flen = strlen (fbeg);
15585   struct file_name_list *search_start = include; /* Chain of dirs to search */
15586   struct file_name_list dsp[1]; /* First in chain, if #include "..." */
15587   struct file_name_list *searchptr = 0;
15588   char *fname;          /* Dynamically allocated fname buffer */
15589   FILE *f;
15590   FILE_BUF *fp;
15591
15592   if (flen == 0)
15593     return NULL;
15594
15595   dsp[0].fname = NULL;
15596
15597   /* If -I- was specified, don't search current dir, only spec'd ones. */
15598   if (!ignore_srcdir)
15599     {
15600       for (fp = &instack[indepth]; fp >= instack; fp--)
15601         {
15602           int n;
15603           char *ep;
15604           const char *nam;
15605
15606           if ((nam = fp->nominal_fname) != NULL)
15607             {
15608               /* Found a named file.  Figure out dir of the file,
15609                  and put it in front of the search list.  */
15610               dsp[0].next = search_start;
15611               search_start = dsp;
15612 #ifndef VMS
15613               ep = strrchr (nam, '/');
15614 #ifdef DIR_SEPARATOR
15615             if (ep == NULL) ep = strrchr (nam, DIR_SEPARATOR);
15616             else {
15617               char *tmp = strrchr (nam, DIR_SEPARATOR);
15618               if (tmp != NULL && tmp > ep) ep = tmp;
15619             }
15620 #endif
15621 #else                           /* VMS */
15622               ep = strrchr (nam, ']');
15623               if (ep == NULL) ep = strrchr (nam, '>');
15624               if (ep == NULL) ep = strrchr (nam, ':');
15625               if (ep != NULL) ep++;
15626 #endif                          /* VMS */
15627               if (ep != NULL)
15628                 {
15629                   n = ep - nam;
15630                   dsp[0].fname = (char *) xmalloc (n + 1);
15631                   strncpy (dsp[0].fname, nam, n);
15632                   dsp[0].fname[n] = '\0';
15633                   if (n + INCLUDE_LEN_FUDGE > max_include_len)
15634                     max_include_len = n + INCLUDE_LEN_FUDGE;
15635                 }
15636               else
15637                 dsp[0].fname = NULL; /* Current directory */
15638               dsp[0].got_name_map = 0;
15639               break;
15640             }
15641         }
15642     }
15643
15644   /* Allocate this permanently, because it gets stored in the definitions
15645      of macros.  */
15646   fname = xmalloc (max_include_len + flen + 4);
15647   /* + 2 above for slash and terminating null.  */
15648   /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED
15649      for g77 yet).  */
15650
15651   /* If specified file name is absolute, just open it.  */
15652
15653   if (*fbeg == '/'
15654 #ifdef DIR_SEPARATOR
15655       || *fbeg == DIR_SEPARATOR
15656 #endif
15657       )
15658     {
15659       strncpy (fname, (char *) fbeg, flen);
15660       fname[flen] = 0;
15661       f = open_include_file (fname, NULL);
15662     }
15663   else
15664     {
15665       f = NULL;
15666
15667       /* Search directory path, trying to open the file.
15668          Copy each filename tried into FNAME.  */
15669
15670       for (searchptr = search_start; searchptr; searchptr = searchptr->next)
15671         {
15672           if (searchptr->fname)
15673             {
15674               /* The empty string in a search path is ignored.
15675                  This makes it possible to turn off entirely
15676                  a standard piece of the list.  */
15677               if (searchptr->fname[0] == 0)
15678                 continue;
15679               strcpy (fname, skip_redundant_dir_prefix (searchptr->fname));
15680               if (fname[0] && fname[strlen (fname) - 1] != '/')
15681                 strcat (fname, "/");
15682               fname[strlen (fname) + flen] = 0;
15683             }
15684           else
15685             fname[0] = 0;
15686
15687           strncat (fname, fbeg, flen);
15688 #ifdef VMS
15689           /* Change this 1/2 Unix 1/2 VMS file specification into a
15690              full VMS file specification */
15691           if (searchptr->fname && (searchptr->fname[0] != 0))
15692             {
15693               /* Fix up the filename */
15694               hack_vms_include_specification (fname);
15695             }
15696           else
15697             {
15698               /* This is a normal VMS filespec, so use it unchanged.  */
15699               strncpy (fname, (char *) fbeg, flen);
15700               fname[flen] = 0;
15701 #if 0   /* Not for g77.  */
15702               /* if it's '#include filename', add the missing .h */
15703               if (strchr (fname, '.') == NULL)
15704                 strcat (fname, ".h");
15705 #endif
15706             }
15707 #endif /* VMS */
15708           f = open_include_file (fname, searchptr);
15709 #ifdef EACCES
15710           if (f == NULL && errno == EACCES)
15711             {
15712               print_containing_files (FFEBAD_severityWARNING);
15713               ffebad_start_msg ("At %0, INCLUDE file %A exists, but is not readable",
15714                                 FFEBAD_severityWARNING);
15715               ffebad_string (fname);
15716               ffebad_here (0, l, c);
15717               ffebad_finish ();
15718             }
15719 #endif
15720           if (f != NULL)
15721             break;
15722         }
15723     }
15724
15725   if (f == NULL)
15726     {
15727       /* A file that was not found.  */
15728
15729       strncpy (fname, (char *) fbeg, flen);
15730       fname[flen] = 0;
15731       print_containing_files (ffebad_severity (FFEBAD_OPEN_INCLUDE));
15732       ffebad_start (FFEBAD_OPEN_INCLUDE);
15733       ffebad_here (0, l, c);
15734       ffebad_string (fname);
15735       ffebad_finish ();
15736     }
15737
15738   if (dsp[0].fname != NULL)
15739     free (dsp[0].fname);
15740
15741   if (f == NULL)
15742     return NULL;
15743
15744   if (indepth >= (INPUT_STACK_MAX - 1))
15745     {
15746       print_containing_files (FFEBAD_severityFATAL);
15747       ffebad_start_msg ("At %0, INCLUDE nesting too deep",
15748                         FFEBAD_severityFATAL);
15749       ffebad_string (fname);
15750       ffebad_here (0, l, c);
15751       ffebad_finish ();
15752       return NULL;
15753     }
15754
15755   instack[indepth].line = ffewhere_line_use (l);
15756   instack[indepth].column = ffewhere_column_use (c);
15757
15758   fp = &instack[indepth + 1];
15759   memset ((char *) fp, 0, sizeof (FILE_BUF));
15760   fp->nominal_fname = fp->fname = fname;
15761   fp->dir = searchptr;
15762
15763   indepth++;
15764   input_file_stack_tick++;
15765
15766   return f;
15767 }
15768
15769 /**INDENT* (Do not reformat this comment even with -fca option.)
15770    Data-gathering files: Given the source file listed below, compiled with
15771    f2c I obtained the output file listed after that, and from the output
15772    file I derived the above code.
15773
15774 -------- (begin input file to f2c)
15775         implicit none
15776         character*10 A1,A2
15777         complex C1,C2
15778         integer I1,I2
15779         real R1,R2
15780         double precision D1,D2
15781 C
15782         call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2)
15783 c /
15784         call fooI(I1/I2)
15785         call fooR(R1/I1)
15786         call fooD(D1/I1)
15787         call fooC(C1/I1)
15788         call fooR(R1/R2)
15789         call fooD(R1/D1)
15790         call fooD(D1/D2)
15791         call fooD(D1/R1)
15792         call fooC(C1/C2)
15793         call fooC(C1/R1)
15794         call fooZ(C1/D1)
15795 c **
15796         call fooI(I1**I2)
15797         call fooR(R1**I1)
15798         call fooD(D1**I1)
15799         call fooC(C1**I1)
15800         call fooR(R1**R2)
15801         call fooD(R1**D1)
15802         call fooD(D1**D2)
15803         call fooD(D1**R1)
15804         call fooC(C1**C2)
15805         call fooC(C1**R1)
15806         call fooZ(C1**D1)
15807 c FFEINTRIN_impABS
15808         call fooR(ABS(R1))
15809 c FFEINTRIN_impACOS
15810         call fooR(ACOS(R1))
15811 c FFEINTRIN_impAIMAG
15812         call fooR(AIMAG(C1))
15813 c FFEINTRIN_impAINT
15814         call fooR(AINT(R1))
15815 c FFEINTRIN_impALOG
15816         call fooR(ALOG(R1))
15817 c FFEINTRIN_impALOG10
15818         call fooR(ALOG10(R1))
15819 c FFEINTRIN_impAMAX0
15820         call fooR(AMAX0(I1,I2))
15821 c FFEINTRIN_impAMAX1
15822         call fooR(AMAX1(R1,R2))
15823 c FFEINTRIN_impAMIN0
15824         call fooR(AMIN0(I1,I2))
15825 c FFEINTRIN_impAMIN1
15826         call fooR(AMIN1(R1,R2))
15827 c FFEINTRIN_impAMOD
15828         call fooR(AMOD(R1,R2))
15829 c FFEINTRIN_impANINT
15830         call fooR(ANINT(R1))
15831 c FFEINTRIN_impASIN
15832         call fooR(ASIN(R1))
15833 c FFEINTRIN_impATAN
15834         call fooR(ATAN(R1))
15835 c FFEINTRIN_impATAN2
15836         call fooR(ATAN2(R1,R2))
15837 c FFEINTRIN_impCABS
15838         call fooR(CABS(C1))
15839 c FFEINTRIN_impCCOS
15840         call fooC(CCOS(C1))
15841 c FFEINTRIN_impCEXP
15842         call fooC(CEXP(C1))
15843 c FFEINTRIN_impCHAR
15844         call fooA(CHAR(I1))
15845 c FFEINTRIN_impCLOG
15846         call fooC(CLOG(C1))
15847 c FFEINTRIN_impCONJG
15848         call fooC(CONJG(C1))
15849 c FFEINTRIN_impCOS
15850         call fooR(COS(R1))
15851 c FFEINTRIN_impCOSH
15852         call fooR(COSH(R1))
15853 c FFEINTRIN_impCSIN
15854         call fooC(CSIN(C1))
15855 c FFEINTRIN_impCSQRT
15856         call fooC(CSQRT(C1))
15857 c FFEINTRIN_impDABS
15858         call fooD(DABS(D1))
15859 c FFEINTRIN_impDACOS
15860         call fooD(DACOS(D1))
15861 c FFEINTRIN_impDASIN
15862         call fooD(DASIN(D1))
15863 c FFEINTRIN_impDATAN
15864         call fooD(DATAN(D1))
15865 c FFEINTRIN_impDATAN2
15866         call fooD(DATAN2(D1,D2))
15867 c FFEINTRIN_impDCOS
15868         call fooD(DCOS(D1))
15869 c FFEINTRIN_impDCOSH
15870         call fooD(DCOSH(D1))
15871 c FFEINTRIN_impDDIM
15872         call fooD(DDIM(D1,D2))
15873 c FFEINTRIN_impDEXP
15874         call fooD(DEXP(D1))
15875 c FFEINTRIN_impDIM
15876         call fooR(DIM(R1,R2))
15877 c FFEINTRIN_impDINT
15878         call fooD(DINT(D1))
15879 c FFEINTRIN_impDLOG
15880         call fooD(DLOG(D1))
15881 c FFEINTRIN_impDLOG10
15882         call fooD(DLOG10(D1))
15883 c FFEINTRIN_impDMAX1
15884         call fooD(DMAX1(D1,D2))
15885 c FFEINTRIN_impDMIN1
15886         call fooD(DMIN1(D1,D2))
15887 c FFEINTRIN_impDMOD
15888         call fooD(DMOD(D1,D2))
15889 c FFEINTRIN_impDNINT
15890         call fooD(DNINT(D1))
15891 c FFEINTRIN_impDPROD
15892         call fooD(DPROD(R1,R2))
15893 c FFEINTRIN_impDSIGN
15894         call fooD(DSIGN(D1,D2))
15895 c FFEINTRIN_impDSIN
15896         call fooD(DSIN(D1))
15897 c FFEINTRIN_impDSINH
15898         call fooD(DSINH(D1))
15899 c FFEINTRIN_impDSQRT
15900         call fooD(DSQRT(D1))
15901 c FFEINTRIN_impDTAN
15902         call fooD(DTAN(D1))
15903 c FFEINTRIN_impDTANH
15904         call fooD(DTANH(D1))
15905 c FFEINTRIN_impEXP
15906         call fooR(EXP(R1))
15907 c FFEINTRIN_impIABS
15908         call fooI(IABS(I1))
15909 c FFEINTRIN_impICHAR
15910         call fooI(ICHAR(A1))
15911 c FFEINTRIN_impIDIM
15912         call fooI(IDIM(I1,I2))
15913 c FFEINTRIN_impIDNINT
15914         call fooI(IDNINT(D1))
15915 c FFEINTRIN_impINDEX
15916         call fooI(INDEX(A1,A2))
15917 c FFEINTRIN_impISIGN
15918         call fooI(ISIGN(I1,I2))
15919 c FFEINTRIN_impLEN
15920         call fooI(LEN(A1))
15921 c FFEINTRIN_impLGE
15922         call fooL(LGE(A1,A2))
15923 c FFEINTRIN_impLGT
15924         call fooL(LGT(A1,A2))
15925 c FFEINTRIN_impLLE
15926         call fooL(LLE(A1,A2))
15927 c FFEINTRIN_impLLT
15928         call fooL(LLT(A1,A2))
15929 c FFEINTRIN_impMAX0
15930         call fooI(MAX0(I1,I2))
15931 c FFEINTRIN_impMAX1
15932         call fooI(MAX1(R1,R2))
15933 c FFEINTRIN_impMIN0
15934         call fooI(MIN0(I1,I2))
15935 c FFEINTRIN_impMIN1
15936         call fooI(MIN1(R1,R2))
15937 c FFEINTRIN_impMOD
15938         call fooI(MOD(I1,I2))
15939 c FFEINTRIN_impNINT
15940         call fooI(NINT(R1))
15941 c FFEINTRIN_impSIGN
15942         call fooR(SIGN(R1,R2))
15943 c FFEINTRIN_impSIN
15944         call fooR(SIN(R1))
15945 c FFEINTRIN_impSINH
15946         call fooR(SINH(R1))
15947 c FFEINTRIN_impSQRT
15948         call fooR(SQRT(R1))
15949 c FFEINTRIN_impTAN
15950         call fooR(TAN(R1))
15951 c FFEINTRIN_impTANH
15952         call fooR(TANH(R1))
15953 c FFEINTRIN_imp_CMPLX_C
15954         call fooC(cmplx(C1,C2))
15955 c FFEINTRIN_imp_CMPLX_D
15956         call fooZ(cmplx(D1,D2))
15957 c FFEINTRIN_imp_CMPLX_I
15958         call fooC(cmplx(I1,I2))
15959 c FFEINTRIN_imp_CMPLX_R
15960         call fooC(cmplx(R1,R2))
15961 c FFEINTRIN_imp_DBLE_C
15962         call fooD(dble(C1))
15963 c FFEINTRIN_imp_DBLE_D
15964         call fooD(dble(D1))
15965 c FFEINTRIN_imp_DBLE_I
15966         call fooD(dble(I1))
15967 c FFEINTRIN_imp_DBLE_R
15968         call fooD(dble(R1))
15969 c FFEINTRIN_imp_INT_C
15970         call fooI(int(C1))
15971 c FFEINTRIN_imp_INT_D
15972         call fooI(int(D1))
15973 c FFEINTRIN_imp_INT_I
15974         call fooI(int(I1))
15975 c FFEINTRIN_imp_INT_R
15976         call fooI(int(R1))
15977 c FFEINTRIN_imp_REAL_C
15978         call fooR(real(C1))
15979 c FFEINTRIN_imp_REAL_D
15980         call fooR(real(D1))
15981 c FFEINTRIN_imp_REAL_I
15982         call fooR(real(I1))
15983 c FFEINTRIN_imp_REAL_R
15984         call fooR(real(R1))
15985 c
15986 c FFEINTRIN_imp_INT_D:
15987 c
15988 c FFEINTRIN_specIDINT
15989         call fooI(IDINT(D1))
15990 c
15991 c FFEINTRIN_imp_INT_R:
15992 c
15993 c FFEINTRIN_specIFIX
15994         call fooI(IFIX(R1))
15995 c FFEINTRIN_specINT
15996         call fooI(INT(R1))
15997 c
15998 c FFEINTRIN_imp_REAL_D:
15999 c
16000 c FFEINTRIN_specSNGL
16001         call fooR(SNGL(D1))
16002 c
16003 c FFEINTRIN_imp_REAL_I:
16004 c
16005 c FFEINTRIN_specFLOAT
16006         call fooR(FLOAT(I1))
16007 c FFEINTRIN_specREAL
16008         call fooR(REAL(I1))
16009 c
16010         end
16011 -------- (end input file to f2c)
16012
16013 -------- (begin output from providing above input file as input to:
16014 --------  `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
16015 --------     -e "s:^#.*$::g"')
16016
16017 //  -- translated by f2c (version 19950223).
16018    You must link the resulting object file with the libraries:
16019         -lf2c -lm   (in that order)
16020 //
16021
16022
16023 // f2c.h  --  Standard Fortran to C header file //
16024
16025 ///  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
16026
16027         - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
16028
16029
16030
16031
16032 // F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems //
16033 // we assume short, float are OK //
16034 typedef long int // long int // integer;
16035 typedef char *address;
16036 typedef short int shortint;
16037 typedef float real;
16038 typedef double doublereal;
16039 typedef struct { real r, i; } complex;
16040 typedef struct { doublereal r, i; } doublecomplex;
16041 typedef long int // long int // logical;
16042 typedef short int shortlogical;
16043 typedef char logical1;
16044 typedef char integer1;
16045 // typedef long long longint; // // system-dependent //
16046
16047
16048
16049
16050 // Extern is for use with -E //
16051
16052
16053
16054
16055 // I/O stuff //
16056
16057
16058
16059
16060
16061
16062
16063
16064 typedef long int // int or long int // flag;
16065 typedef long int // int or long int // ftnlen;
16066 typedef long int // int or long int // ftnint;
16067
16068
16069 //external read, write//
16070 typedef struct
16071 {       flag cierr;
16072         ftnint ciunit;
16073         flag ciend;
16074         char *cifmt;
16075         ftnint cirec;
16076 } cilist;
16077
16078 //internal read, write//
16079 typedef struct
16080 {       flag icierr;
16081         char *iciunit;
16082         flag iciend;
16083         char *icifmt;
16084         ftnint icirlen;
16085         ftnint icirnum;
16086 } icilist;
16087
16088 //open//
16089 typedef struct
16090 {       flag oerr;
16091         ftnint ounit;
16092         char *ofnm;
16093         ftnlen ofnmlen;
16094         char *osta;
16095         char *oacc;
16096         char *ofm;
16097         ftnint orl;
16098         char *oblnk;
16099 } olist;
16100
16101 //close//
16102 typedef struct
16103 {       flag cerr;
16104         ftnint cunit;
16105         char *csta;
16106 } cllist;
16107
16108 //rewind, backspace, endfile//
16109 typedef struct
16110 {       flag aerr;
16111         ftnint aunit;
16112 } alist;
16113
16114 // inquire //
16115 typedef struct
16116 {       flag inerr;
16117         ftnint inunit;
16118         char *infile;
16119         ftnlen infilen;
16120         ftnint  *inex;  //parameters in standard's order//
16121         ftnint  *inopen;
16122         ftnint  *innum;
16123         ftnint  *innamed;
16124         char    *inname;
16125         ftnlen  innamlen;
16126         char    *inacc;
16127         ftnlen  inacclen;
16128         char    *inseq;
16129         ftnlen  inseqlen;
16130         char    *indir;
16131         ftnlen  indirlen;
16132         char    *infmt;
16133         ftnlen  infmtlen;
16134         char    *inform;
16135         ftnint  informlen;
16136         char    *inunf;
16137         ftnlen  inunflen;
16138         ftnint  *inrecl;
16139         ftnint  *innrec;
16140         char    *inblank;
16141         ftnlen  inblanklen;
16142 } inlist;
16143
16144
16145
16146 union Multitype {       // for multiple entry points //
16147         integer1 g;
16148         shortint h;
16149         integer i;
16150         // longint j; //
16151         real r;
16152         doublereal d;
16153         complex c;
16154         doublecomplex z;
16155         };
16156
16157 typedef union Multitype Multitype;
16158
16159 typedef long Long;      // No longer used; formerly in Namelist //
16160
16161 struct Vardesc {        // for Namelist //
16162         char *name;
16163         char *addr;
16164         ftnlen *dims;
16165         int  type;
16166         };
16167 typedef struct Vardesc Vardesc;
16168
16169 struct Namelist {
16170         char *name;
16171         Vardesc **vars;
16172         int nvars;
16173         };
16174 typedef struct Namelist Namelist;
16175
16176
16177
16178
16179
16180
16181
16182
16183 // procedure parameter types for -A and -C++ //
16184
16185
16186
16187
16188 typedef int // Unknown procedure type // (*U_fp)();
16189 typedef shortint (*J_fp)();
16190 typedef integer (*I_fp)();
16191 typedef real (*R_fp)();
16192 typedef doublereal (*D_fp)(), (*E_fp)();
16193 typedef // Complex // void  (*C_fp)();
16194 typedef // Double Complex // void  (*Z_fp)();
16195 typedef logical (*L_fp)();
16196 typedef shortlogical (*K_fp)();
16197 typedef // Character // void  (*H_fp)();
16198 typedef // Subroutine // int (*S_fp)();
16199
16200 // E_fp is for real functions when -R is not specified //
16201 typedef void  C_f;      // complex function //
16202 typedef void  H_f;      // character function //
16203 typedef void  Z_f;      // double complex function //
16204 typedef doublereal E_f; // real function with -R not specified //
16205
16206 // undef any lower-case symbols that your C compiler predefines, e.g.: //
16207
16208
16209 // (No such symbols should be defined in a strict ANSI C compiler.
16210    We can avoid trouble with f2c-translated code by using
16211    gcc -ansi [-traditional].) //
16212
16213
16214
16215
16216
16217
16218
16219
16220
16221
16222
16223
16224
16225
16226
16227
16228
16229
16230
16231
16232
16233
16234
16235 // Main program // MAIN__()
16236 {
16237     // System generated locals //
16238     integer i__1;
16239     real r__1, r__2;
16240     doublereal d__1, d__2;
16241     complex q__1;
16242     doublecomplex z__1, z__2, z__3;
16243     logical L__1;
16244     char ch__1[1];
16245
16246     // Builtin functions //
16247     void c_div();
16248     integer pow_ii();
16249     double pow_ri(), pow_di();
16250     void pow_ci();
16251     double pow_dd();
16252     void pow_zz();
16253     double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
16254             asin(), atan(), atan2(), c_abs();
16255     void c_cos(), c_exp(), c_log(), r_cnjg();
16256     double cos(), cosh();
16257     void c_sin(), c_sqrt();
16258     double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
16259             d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
16260     integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
16261     logical l_ge(), l_gt(), l_le(), l_lt();
16262     integer i_nint();
16263     double r_sign();
16264
16265     // Local variables //
16266     extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
16267             fool_(), fooz_(), getem_();
16268     static char a1[10], a2[10];
16269     static complex c1, c2;
16270     static doublereal d1, d2;
16271     static integer i1, i2;
16272     static real r1, r2;
16273
16274
16275     getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L);
16276 // / //
16277     i__1 = i1 / i2;
16278     fooi_(&i__1);
16279     r__1 = r1 / i1;
16280     foor_(&r__1);
16281     d__1 = d1 / i1;
16282     food_(&d__1);
16283     d__1 = (doublereal) i1;
16284     q__1.r = c1.r / d__1, q__1.i = c1.i / d__1;
16285     fooc_(&q__1);
16286     r__1 = r1 / r2;
16287     foor_(&r__1);
16288     d__1 = r1 / d1;
16289     food_(&d__1);
16290     d__1 = d1 / d2;
16291     food_(&d__1);
16292     d__1 = d1 / r1;
16293     food_(&d__1);
16294     c_div(&q__1, &c1, &c2);
16295     fooc_(&q__1);
16296     q__1.r = c1.r / r1, q__1.i = c1.i / r1;
16297     fooc_(&q__1);
16298     z__1.r = c1.r / d1, z__1.i = c1.i / d1;
16299     fooz_(&z__1);
16300 // ** //
16301     i__1 = pow_ii(&i1, &i2);
16302     fooi_(&i__1);
16303     r__1 = pow_ri(&r1, &i1);
16304     foor_(&r__1);
16305     d__1 = pow_di(&d1, &i1);
16306     food_(&d__1);
16307     pow_ci(&q__1, &c1, &i1);
16308     fooc_(&q__1);
16309     d__1 = (doublereal) r1;
16310     d__2 = (doublereal) r2;
16311     r__1 = pow_dd(&d__1, &d__2);
16312     foor_(&r__1);
16313     d__2 = (doublereal) r1;
16314     d__1 = pow_dd(&d__2, &d1);
16315     food_(&d__1);
16316     d__1 = pow_dd(&d1, &d2);
16317     food_(&d__1);
16318     d__2 = (doublereal) r1;
16319     d__1 = pow_dd(&d1, &d__2);
16320     food_(&d__1);
16321     z__2.r = c1.r, z__2.i = c1.i;
16322     z__3.r = c2.r, z__3.i = c2.i;
16323     pow_zz(&z__1, &z__2, &z__3);
16324     q__1.r = z__1.r, q__1.i = z__1.i;
16325     fooc_(&q__1);
16326     z__2.r = c1.r, z__2.i = c1.i;
16327     z__3.r = r1, z__3.i = 0.;
16328     pow_zz(&z__1, &z__2, &z__3);
16329     q__1.r = z__1.r, q__1.i = z__1.i;
16330     fooc_(&q__1);
16331     z__2.r = c1.r, z__2.i = c1.i;
16332     z__3.r = d1, z__3.i = 0.;
16333     pow_zz(&z__1, &z__2, &z__3);
16334     fooz_(&z__1);
16335 // FFEINTRIN_impABS //
16336     r__1 = (doublereal)((  r1  ) >= 0 ? (  r1  ) : -(  r1  ))  ;
16337     foor_(&r__1);
16338 // FFEINTRIN_impACOS //
16339     r__1 = acos(r1);
16340     foor_(&r__1);
16341 // FFEINTRIN_impAIMAG //
16342     r__1 = r_imag(&c1);
16343     foor_(&r__1);
16344 // FFEINTRIN_impAINT //
16345     r__1 = r_int(&r1);
16346     foor_(&r__1);
16347 // FFEINTRIN_impALOG //
16348     r__1 = log(r1);
16349     foor_(&r__1);
16350 // FFEINTRIN_impALOG10 //
16351     r__1 = r_lg10(&r1);
16352     foor_(&r__1);
16353 // FFEINTRIN_impAMAX0 //
16354     r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16355     foor_(&r__1);
16356 // FFEINTRIN_impAMAX1 //
16357     r__1 = (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16358     foor_(&r__1);
16359 // FFEINTRIN_impAMIN0 //
16360     r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16361     foor_(&r__1);
16362 // FFEINTRIN_impAMIN1 //
16363     r__1 = (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16364     foor_(&r__1);
16365 // FFEINTRIN_impAMOD //
16366     r__1 = r_mod(&r1, &r2);
16367     foor_(&r__1);
16368 // FFEINTRIN_impANINT //
16369     r__1 = r_nint(&r1);
16370     foor_(&r__1);
16371 // FFEINTRIN_impASIN //
16372     r__1 = asin(r1);
16373     foor_(&r__1);
16374 // FFEINTRIN_impATAN //
16375     r__1 = atan(r1);
16376     foor_(&r__1);
16377 // FFEINTRIN_impATAN2 //
16378     r__1 = atan2(r1, r2);
16379     foor_(&r__1);
16380 // FFEINTRIN_impCABS //
16381     r__1 = c_abs(&c1);
16382     foor_(&r__1);
16383 // FFEINTRIN_impCCOS //
16384     c_cos(&q__1, &c1);
16385     fooc_(&q__1);
16386 // FFEINTRIN_impCEXP //
16387     c_exp(&q__1, &c1);
16388     fooc_(&q__1);
16389 // FFEINTRIN_impCHAR //
16390     *(unsigned char *)&ch__1[0] = i1;
16391     fooa_(ch__1, 1L);
16392 // FFEINTRIN_impCLOG //
16393     c_log(&q__1, &c1);
16394     fooc_(&q__1);
16395 // FFEINTRIN_impCONJG //
16396     r_cnjg(&q__1, &c1);
16397     fooc_(&q__1);
16398 // FFEINTRIN_impCOS //
16399     r__1 = cos(r1);
16400     foor_(&r__1);
16401 // FFEINTRIN_impCOSH //
16402     r__1 = cosh(r1);
16403     foor_(&r__1);
16404 // FFEINTRIN_impCSIN //
16405     c_sin(&q__1, &c1);
16406     fooc_(&q__1);
16407 // FFEINTRIN_impCSQRT //
16408     c_sqrt(&q__1, &c1);
16409     fooc_(&q__1);
16410 // FFEINTRIN_impDABS //
16411     d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ;
16412     food_(&d__1);
16413 // FFEINTRIN_impDACOS //
16414     d__1 = acos(d1);
16415     food_(&d__1);
16416 // FFEINTRIN_impDASIN //
16417     d__1 = asin(d1);
16418     food_(&d__1);
16419 // FFEINTRIN_impDATAN //
16420     d__1 = atan(d1);
16421     food_(&d__1);
16422 // FFEINTRIN_impDATAN2 //
16423     d__1 = atan2(d1, d2);
16424     food_(&d__1);
16425 // FFEINTRIN_impDCOS //
16426     d__1 = cos(d1);
16427     food_(&d__1);
16428 // FFEINTRIN_impDCOSH //
16429     d__1 = cosh(d1);
16430     food_(&d__1);
16431 // FFEINTRIN_impDDIM //
16432     d__1 = d_dim(&d1, &d2);
16433     food_(&d__1);
16434 // FFEINTRIN_impDEXP //
16435     d__1 = exp(d1);
16436     food_(&d__1);
16437 // FFEINTRIN_impDIM //
16438     r__1 = r_dim(&r1, &r2);
16439     foor_(&r__1);
16440 // FFEINTRIN_impDINT //
16441     d__1 = d_int(&d1);
16442     food_(&d__1);
16443 // FFEINTRIN_impDLOG //
16444     d__1 = log(d1);
16445     food_(&d__1);
16446 // FFEINTRIN_impDLOG10 //
16447     d__1 = d_lg10(&d1);
16448     food_(&d__1);
16449 // FFEINTRIN_impDMAX1 //
16450     d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ;
16451     food_(&d__1);
16452 // FFEINTRIN_impDMIN1 //
16453     d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ;
16454     food_(&d__1);
16455 // FFEINTRIN_impDMOD //
16456     d__1 = d_mod(&d1, &d2);
16457     food_(&d__1);
16458 // FFEINTRIN_impDNINT //
16459     d__1 = d_nint(&d1);
16460     food_(&d__1);
16461 // FFEINTRIN_impDPROD //
16462     d__1 = (doublereal) r1 * r2;
16463     food_(&d__1);
16464 // FFEINTRIN_impDSIGN //
16465     d__1 = d_sign(&d1, &d2);
16466     food_(&d__1);
16467 // FFEINTRIN_impDSIN //
16468     d__1 = sin(d1);
16469     food_(&d__1);
16470 // FFEINTRIN_impDSINH //
16471     d__1 = sinh(d1);
16472     food_(&d__1);
16473 // FFEINTRIN_impDSQRT //
16474     d__1 = sqrt(d1);
16475     food_(&d__1);
16476 // FFEINTRIN_impDTAN //
16477     d__1 = tan(d1);
16478     food_(&d__1);
16479 // FFEINTRIN_impDTANH //
16480     d__1 = tanh(d1);
16481     food_(&d__1);
16482 // FFEINTRIN_impEXP //
16483     r__1 = exp(r1);
16484     foor_(&r__1);
16485 // FFEINTRIN_impIABS //
16486     i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ;
16487     fooi_(&i__1);
16488 // FFEINTRIN_impICHAR //
16489     i__1 = *(unsigned char *)a1;
16490     fooi_(&i__1);
16491 // FFEINTRIN_impIDIM //
16492     i__1 = i_dim(&i1, &i2);
16493     fooi_(&i__1);
16494 // FFEINTRIN_impIDNINT //
16495     i__1 = i_dnnt(&d1);
16496     fooi_(&i__1);
16497 // FFEINTRIN_impINDEX //
16498     i__1 = i_indx(a1, a2, 10L, 10L);
16499     fooi_(&i__1);
16500 // FFEINTRIN_impISIGN //
16501     i__1 = i_sign(&i1, &i2);
16502     fooi_(&i__1);
16503 // FFEINTRIN_impLEN //
16504     i__1 = i_len(a1, 10L);
16505     fooi_(&i__1);
16506 // FFEINTRIN_impLGE //
16507     L__1 = l_ge(a1, a2, 10L, 10L);
16508     fool_(&L__1);
16509 // FFEINTRIN_impLGT //
16510     L__1 = l_gt(a1, a2, 10L, 10L);
16511     fool_(&L__1);
16512 // FFEINTRIN_impLLE //
16513     L__1 = l_le(a1, a2, 10L, 10L);
16514     fool_(&L__1);
16515 // FFEINTRIN_impLLT //
16516     L__1 = l_lt(a1, a2, 10L, 10L);
16517     fool_(&L__1);
16518 // FFEINTRIN_impMAX0 //
16519     i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16520     fooi_(&i__1);
16521 // FFEINTRIN_impMAX1 //
16522     i__1 = (integer) (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16523     fooi_(&i__1);
16524 // FFEINTRIN_impMIN0 //
16525     i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16526     fooi_(&i__1);
16527 // FFEINTRIN_impMIN1 //
16528     i__1 = (integer) (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16529     fooi_(&i__1);
16530 // FFEINTRIN_impMOD //
16531     i__1 = i1 % i2;
16532     fooi_(&i__1);
16533 // FFEINTRIN_impNINT //
16534     i__1 = i_nint(&r1);
16535     fooi_(&i__1);
16536 // FFEINTRIN_impSIGN //
16537     r__1 = r_sign(&r1, &r2);
16538     foor_(&r__1);
16539 // FFEINTRIN_impSIN //
16540     r__1 = sin(r1);
16541     foor_(&r__1);
16542 // FFEINTRIN_impSINH //
16543     r__1 = sinh(r1);
16544     foor_(&r__1);
16545 // FFEINTRIN_impSQRT //
16546     r__1 = sqrt(r1);
16547     foor_(&r__1);
16548 // FFEINTRIN_impTAN //
16549     r__1 = tan(r1);
16550     foor_(&r__1);
16551 // FFEINTRIN_impTANH //
16552     r__1 = tanh(r1);
16553     foor_(&r__1);
16554 // FFEINTRIN_imp_CMPLX_C //
16555     r__1 = c1.r;
16556     r__2 = c2.r;
16557     q__1.r = r__1, q__1.i = r__2;
16558     fooc_(&q__1);
16559 // FFEINTRIN_imp_CMPLX_D //
16560     z__1.r = d1, z__1.i = d2;
16561     fooz_(&z__1);
16562 // FFEINTRIN_imp_CMPLX_I //
16563     r__1 = (real) i1;
16564     r__2 = (real) i2;
16565     q__1.r = r__1, q__1.i = r__2;
16566     fooc_(&q__1);
16567 // FFEINTRIN_imp_CMPLX_R //
16568     q__1.r = r1, q__1.i = r2;
16569     fooc_(&q__1);
16570 // FFEINTRIN_imp_DBLE_C //
16571     d__1 = (doublereal) c1.r;
16572     food_(&d__1);
16573 // FFEINTRIN_imp_DBLE_D //
16574     d__1 = d1;
16575     food_(&d__1);
16576 // FFEINTRIN_imp_DBLE_I //
16577     d__1 = (doublereal) i1;
16578     food_(&d__1);
16579 // FFEINTRIN_imp_DBLE_R //
16580     d__1 = (doublereal) r1;
16581     food_(&d__1);
16582 // FFEINTRIN_imp_INT_C //
16583     i__1 = (integer) c1.r;
16584     fooi_(&i__1);
16585 // FFEINTRIN_imp_INT_D //
16586     i__1 = (integer) d1;
16587     fooi_(&i__1);
16588 // FFEINTRIN_imp_INT_I //
16589     i__1 = i1;
16590     fooi_(&i__1);
16591 // FFEINTRIN_imp_INT_R //
16592     i__1 = (integer) r1;
16593     fooi_(&i__1);
16594 // FFEINTRIN_imp_REAL_C //
16595     r__1 = c1.r;
16596     foor_(&r__1);
16597 // FFEINTRIN_imp_REAL_D //
16598     r__1 = (real) d1;
16599     foor_(&r__1);
16600 // FFEINTRIN_imp_REAL_I //
16601     r__1 = (real) i1;
16602     foor_(&r__1);
16603 // FFEINTRIN_imp_REAL_R //
16604     r__1 = r1;
16605     foor_(&r__1);
16606
16607 // FFEINTRIN_imp_INT_D: //
16608
16609 // FFEINTRIN_specIDINT //
16610     i__1 = (integer) d1;
16611     fooi_(&i__1);
16612
16613 // FFEINTRIN_imp_INT_R: //
16614
16615 // FFEINTRIN_specIFIX //
16616     i__1 = (integer) r1;
16617     fooi_(&i__1);
16618 // FFEINTRIN_specINT //
16619     i__1 = (integer) r1;
16620     fooi_(&i__1);
16621
16622 // FFEINTRIN_imp_REAL_D: //
16623
16624 // FFEINTRIN_specSNGL //
16625     r__1 = (real) d1;
16626     foor_(&r__1);
16627
16628 // FFEINTRIN_imp_REAL_I: //
16629
16630 // FFEINTRIN_specFLOAT //
16631     r__1 = (real) i1;
16632     foor_(&r__1);
16633 // FFEINTRIN_specREAL //
16634     r__1 = (real) i1;
16635     foor_(&r__1);
16636
16637 } // MAIN__ //
16638
16639 -------- (end output file from f2c)
16640
16641 */