gcc/f/com.c

   1 /* com.c -- Implementation File (module.c template V1.0)
   2    Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002
   3    Free Software Foundation, Inc.
   4    Contributed by James Craig Burley.
   5
   6 This file is part of GNU Fortran.
   7
   8 GNU Fortran is free software; you can redistribute it and/or modify
   9 it under the terms of the GNU General Public License as published by
  10 the Free Software Foundation; either version 2, or (at your option)
  11 any later version.
  12
  13 GNU Fortran is distributed in the hope that it will be useful,
  14 but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 GNU General Public License for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with GNU Fortran; see the file COPYING.  If not, write to
  20 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
  21 02111-1307, USA.
  22
  23    Related Modules:
  24       None
  25
  26    Description:
  27       Contains compiler-specific functions.
  28
  29    Modifications:
  30 */
  31
  32 /* Understanding this module means understanding the interface between
  33    the g77 front end and the gcc back end (or, perhaps, some other
  34    back end).  In here are the functions called by the front end proper
  35    to notify whatever back end is in place about certain things, and
  36    also the back-end-specific functions.  It's a bear to deal with, so
  37    lately I've been trying to simplify things, especially with regard
  38    to the gcc-back-end-specific stuff.
  39
  40    Building expressions generally seems quite easy, but building decls
  41    has been challenging and is undergoing revision.  gcc has several
  42    kinds of decls:
  43
  44    TYPE_DECL -- a type (int, float, struct, function, etc.)
  45    CONST_DECL -- a constant of some type other than function
  46    LABEL_DECL -- a variable or a constant?
  47    PARM_DECL -- an argument to a function (a variable that is a dummy)
  48    RESULT_DECL -- the return value of a function (a variable)
  49    VAR_DECL -- other variable (can hold a ptr-to-function, struct, int, etc.)
  50    FUNCTION_DECL -- a function (either the actual function or an extern ref)
  51    FIELD_DECL -- a field in a struct or union (goes into types)
  52
  53    g77 has a set of functions that somewhat parallels the gcc front end
  54    when it comes to building decls:
  55
  56    Internal Function (one we define, not just declare as extern):
  57    if (is_nested) push_f_function_context ();
  58    start_function (get_identifier ("function_name"), function_type,
  59                    is_nested, is_public);
  60    // for each arg, build PARM_DECL and call push_parm_decl (decl) with it;
  61    store_parm_decls (is_main_program);
  62    ffecom_start_compstmt ();
  63    // for stmts and decls inside function, do appropriate things;
  64    ffecom_end_compstmt ();
  65    finish_function (is_nested);
  66    if (is_nested) pop_f_function_context ();
  67
  68    Everything Else:
  69    tree d;
  70    tree init;
  71    // fill in external, public, static, &c for decl, and
  72    // set DECL_INITIAL to error_mark_node if going to initialize
  73    // set is_top_level TRUE only if not at top level and decl
  74    // must go in top level (i.e. not within current function decl context)
  75    d = start_decl (decl, is_top_level);
  76    init = ...;  // if have initializer
  77    finish_decl (d, init, is_top_level);
  78
  79 */
  80
  81 /* Include files. */
  82
  83 #include "proj.h"
  84 #include "flags.h"
  85 #include "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 "intl.h"
  93 #include "langhooks.h"
  94 #include "langhooks-def.h"
  95
  96 /* VMS-specific definitions */
  97 #ifdef VMS
  98 #include <descrip.h>
  99 #define O_RDONLY        0       /* Open arg for Read/Only  */
 100 #define O_WRONLY        1       /* Open arg for Write/Only */
 101 #define read(fd,buf,size)       VMS_read (fd,buf,size)
 102 #define write(fd,buf,size)      VMS_write (fd,buf,size)
 103 #define open(fname,mode,prot)   VMS_open (fname,mode,prot)
 104 #define fopen(fname,mode)       VMS_fopen (fname,mode)
 105 #define freopen(fname,mode,ofile) VMS_freopen (fname,mode,ofile)
 106 #define strncat(dst,src,cnt) VMS_strncat (dst,src,cnt)
 107 #define fstat(fd,stbuf)         VMS_fstat (fd,stbuf)
 108 static int VMS_fstat (), VMS_stat ();
 109 static char * VMS_strncat ();
 110 static int VMS_read ();
 111 static int VMS_write ();
 112 static int VMS_open ();
 113 static FILE * VMS_fopen ();
 114 static FILE * VMS_freopen ();
 115 static void hack_vms_include_specification ();
 116 typedef struct { unsigned :16, :16, :16; } vms_ino_t;
 117 #define ino_t vms_ino_t
 118 #define INCLUDE_LEN_FUDGE 10    /* leave room for VMS syntax conversion */
 119 #endif /* VMS */
 120
 121 #define FFECOM_DETERMINE_TYPES 1 /* for com.h */
 122 #include "com.h"
 123 #include "bad.h"
 124 #include "bld.h"
 125 #include "equiv.h"
 126 #include "expr.h"
 127 #include "implic.h"
 128 #include "info.h"
 129 #include "malloc.h"
 130 #include "src.h"
 131 #include "st.h"
 132 #include "storag.h"
 133 #include "symbol.h"
 134 #include "target.h"
 135 #include "top.h"
 136 #include "type.h"
 137
 138 /* Externals defined here.  */
 139
 140 /* Stream for reading from the input file.  */
 141 FILE *finput;
 142
 143 /* These definitions parallel those in c-decl.c so that code from that
 144    module can be used pretty much as is.  Much of these defs aren't
 145    otherwise used, i.e. by g77 code per se, except some of them are used
 146    to build some of them that are.  The ones that are global (i.e. not
 147    "static") are those that ste.c and such might use (directly
 148    or by using com macros that reference them in their definitions).  */
 149
 150 tree string_type_node;
 151
 152 /* The rest of these are inventions for g77, though there might be
 153    similar things in the C front end.  As they are found, these
 154    inventions should be renamed to be canonical.  Note that only
 155    the ones currently required to be global are so.  */
 156
 157 static tree ffecom_tree_fun_type_void;
 158
 159 tree ffecom_integer_type_node;  /* Abbrev for _tree_type[blah][blah]. */
 160 tree ffecom_integer_zero_node;  /* Like *_*_* with g77's integer type. */
 161 tree ffecom_integer_one_node;   /* " */
 162 tree ffecom_tree_type[FFEINFO_basictype][FFEINFO_kindtype];
 163
 164 /* _fun_type things are the f2c-specific versions.  For -fno-f2c,
 165    just use build_function_type and build_pointer_type on the
 166    appropriate _tree_type array element.  */
 167
 168 static tree ffecom_tree_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
 169 static tree ffecom_tree_ptr_to_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
 170 static tree ffecom_tree_subr_type;
 171 static tree ffecom_tree_ptr_to_subr_type;
 172 static tree ffecom_tree_blockdata_type;
 173
 174 static tree ffecom_tree_xargc_;
 175
 176 ffecomSymbol ffecom_symbol_null_
 177 =
 178 {
 179   NULL_TREE,
 180   NULL_TREE,
 181   NULL_TREE,
 182   NULL_TREE,
 183   false
 184 };
 185 ffeinfoKindtype ffecom_pointer_kind_ = FFEINFO_basictypeNONE;
 186 ffeinfoKindtype ffecom_label_kind_ = FFEINFO_basictypeNONE;
 187
 188 int ffecom_f2c_typecode_[FFEINFO_basictype][FFEINFO_kindtype];
 189 tree ffecom_f2c_integer_type_node;
 190 tree ffecom_f2c_ptr_to_integer_type_node;
 191 tree ffecom_f2c_address_type_node;
 192 tree ffecom_f2c_real_type_node;
 193 tree ffecom_f2c_ptr_to_real_type_node;
 194 tree ffecom_f2c_doublereal_type_node;
 195 tree ffecom_f2c_complex_type_node;
 196 tree ffecom_f2c_doublecomplex_type_node;
 197 tree ffecom_f2c_longint_type_node;
 198 tree ffecom_f2c_logical_type_node;
 199 tree ffecom_f2c_flag_type_node;
 200 tree ffecom_f2c_ftnlen_type_node;
 201 tree ffecom_f2c_ftnlen_zero_node;
 202 tree ffecom_f2c_ftnlen_one_node;
 203 tree ffecom_f2c_ftnlen_two_node;
 204 tree ffecom_f2c_ptr_to_ftnlen_type_node;
 205 tree ffecom_f2c_ftnint_type_node;
 206 tree ffecom_f2c_ptr_to_ftnint_type_node;
 207
 208 /* Simple definitions and enumerations. */
 209
 210 #ifndef FFECOM_sizeMAXSTACKITEM
 211 #define FFECOM_sizeMAXSTACKITEM 32*1024 /* Keep user-declared things
 212                                            larger than this # bytes
 213                                            off stack if possible. */
 214 #endif
 215
 216 /* For systems that have large enough stacks, they should define
 217    this to 0, and here, for ease of use later on, we just undefine
 218    it if it is 0.  */
 219
 220 #if FFECOM_sizeMAXSTACKITEM == 0
 221 #undef FFECOM_sizeMAXSTACKITEM
 222 #endif
 223
 224 typedef enum
 225   {
 226     FFECOM_rttypeVOID_,
 227     FFECOM_rttypeVOIDSTAR_,     /* C's `void *' type. */
 228     FFECOM_rttypeFTNINT_,       /* f2c's `ftnint' type. */
 229     FFECOM_rttypeINTEGER_,      /* f2c's `integer' type. */
 230     FFECOM_rttypeLONGINT_,      /* f2c's `longint' type. */
 231     FFECOM_rttypeLOGICAL_,      /* f2c's `logical' type. */
 232     FFECOM_rttypeREAL_F2C_,     /* f2c's `real' returned as `double'. */
 233     FFECOM_rttypeREAL_GNU_,     /* `real' returned as such. */
 234     FFECOM_rttypeCOMPLEX_F2C_,  /* f2c's `complex' returned via 1st arg. */
 235     FFECOM_rttypeCOMPLEX_GNU_,  /* f2c's `complex' returned directly. */
 236     FFECOM_rttypeDOUBLE_,       /* C's `double' type. */
 237     FFECOM_rttypeDOUBLEREAL_,   /* f2c's `doublereal' type. */
 238     FFECOM_rttypeDBLCMPLX_F2C_, /* f2c's `doublecomplex' returned via 1st arg. */
 239     FFECOM_rttypeDBLCMPLX_GNU_, /* f2c's `doublecomplex' returned directly. */
 240     FFECOM_rttypeCHARACTER_,    /* f2c `char *'/`ftnlen' pair. */
 241     FFECOM_rttype_
 242   } ffecomRttype_;
 243
 244 /* Internal typedefs. */
 245
 246 typedef struct _ffecom_concat_list_ ffecomConcatList_;
 247
 248 /* Private include files. */
 249
 250
 251 /* Internal structure definitions. */
 252
 253 struct _ffecom_concat_list_
 254   {
 255     ffebld *exprs;
 256     int count;
 257     int max;
 258     ffetargetCharacterSize minlen;
 259     ffetargetCharacterSize maxlen;
 260   };
 261
 262 /* Static functions (internal). */
 263
 264 static tree ffe_type_for_mode PARAMS ((enum machine_mode, int));
 265 static tree ffe_type_for_size PARAMS ((unsigned int, int));
 266 static tree ffe_unsigned_type PARAMS ((tree));
 267 static tree ffe_signed_type PARAMS ((tree));
 268 static tree ffe_signed_or_unsigned_type PARAMS ((int, tree));
 269 static bool ffe_mark_addressable PARAMS ((tree));
 270 static tree ffe_truthvalue_conversion PARAMS ((tree));
 271 static void ffecom_init_decl_processing PARAMS ((void));
 272 static tree ffecom_arglist_expr_ (const char *argstring, ffebld args);
 273 static tree ffecom_widest_expr_type_ (ffebld list);
 274 static bool ffecom_overlap_ (tree dest_decl, tree dest_offset,
 275                              tree dest_size, tree source_tree,
 276                              ffebld source, bool scalar_arg);
 277 static bool ffecom_args_overlapping_ (tree dest_tree, ffebld dest,
 278                                       tree args, tree callee_commons,
 279                                       bool scalar_args);
 280 static tree ffecom_build_f2c_string_ (int i, const char *s);
 281 static tree ffecom_call_ (tree fn, ffeinfoKindtype kt,
 282                           bool is_f2c_complex, tree type,
 283                           tree args, tree dest_tree,
 284                           ffebld dest, bool *dest_used,
 285                           tree callee_commons, bool scalar_args, tree hook);
 286 static tree ffecom_call_binop_ (tree fn, ffeinfoKindtype kt,
 287                                 bool is_f2c_complex, tree type,
 288                                 ffebld left, ffebld right,
 289                                 tree dest_tree, ffebld dest,
 290                                 bool *dest_used, tree callee_commons,
 291                                 bool scalar_args, bool ref, tree hook);
 292 static void ffecom_char_args_x_ (tree *xitem, tree *length,
 293                                  ffebld expr, bool with_null);
 294 static tree ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy);
 295 static tree ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s);
 296 static ffecomConcatList_
 297   ffecom_concat_list_gather_ (ffecomConcatList_ catlist,
 298                               ffebld expr,
 299                               ffetargetCharacterSize max);
 300 static void ffecom_concat_list_kill_ (ffecomConcatList_ catlist);
 301 static ffecomConcatList_ ffecom_concat_list_new_ (ffebld expr,
 302                                                 ffetargetCharacterSize max);
 303 static void ffecom_debug_kludge_ (tree aggr, const char *aggr_type,
 304                                   ffesymbol member, tree member_type,
 305                                   ffetargetOffset offset);
 306 static void ffecom_do_entry_ (ffesymbol fn, int entrynum);
 307 static tree ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
 308                           bool *dest_used, bool assignp, bool widenp);
 309 static tree ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
 310                                     ffebld dest, bool *dest_used);
 311 static tree ffecom_expr_power_integer_ (ffebld expr);
 312 static void ffecom_expr_transform_ (ffebld expr);
 313 static void ffecom_f2c_make_type_ (tree *type, int tcode, const char *name);
 314 static void ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
 315                                       int code);
 316 static ffeglobal ffecom_finish_global_ (ffeglobal global);
 317 static ffesymbol ffecom_finish_symbol_transform_ (ffesymbol s);
 318 static tree ffecom_get_appended_identifier_ (char us, const char *text);
 319 static tree ffecom_get_external_identifier_ (ffesymbol s);
 320 static tree ffecom_get_identifier_ (const char *text);
 321 static tree ffecom_gen_sfuncdef_ (ffesymbol s,
 322                                   ffeinfoBasictype bt,
 323                                   ffeinfoKindtype kt);
 324 static const char *ffecom_gfrt_args_ (ffecomGfrt ix);
 325 static tree ffecom_gfrt_tree_ (ffecomGfrt ix);
 326 static tree ffecom_init_zero_ (tree decl);
 327 static tree ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
 328                                      tree *maybe_tree);
 329 static tree ffecom_intrinsic_len_ (ffebld expr);
 330 static void ffecom_let_char_ (tree dest_tree,
 331                               tree dest_length,
 332                               ffetargetCharacterSize dest_size,
 333                               ffebld source);
 334 static void ffecom_make_gfrt_ (ffecomGfrt ix);
 335 static void ffecom_member_phase1_ (ffestorag mst, ffestorag st);
 336 static void ffecom_member_phase2_ (ffestorag mst, ffestorag st);
 337 static void ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size,
 338                                       ffebld source);
 339 static void ffecom_push_dummy_decls_ (ffebld dumlist,
 340                                       bool stmtfunc);
 341 static void ffecom_start_progunit_ (void);
 342 static ffesymbol ffecom_sym_transform_ (ffesymbol s);
 343 static ffesymbol ffecom_sym_transform_assign_ (ffesymbol s);
 344 static void ffecom_transform_common_ (ffesymbol s);
 345 static void ffecom_transform_equiv_ (ffestorag st);
 346 static tree ffecom_transform_namelist_ (ffesymbol s);
 347 static void ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
 348                                        tree t);
 349 static void ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
 350                                        tree *size, tree tree);
 351 static tree ffecom_tree_divide_ (tree tree_type, tree left, tree right,
 352                                  tree dest_tree, ffebld dest,
 353                                  bool *dest_used, tree hook);
 354 static tree ffecom_type_localvar_ (ffesymbol s,
 355                                    ffeinfoBasictype bt,
 356                                    ffeinfoKindtype kt);
 357 static tree ffecom_type_namelist_ (void);
 358 static tree ffecom_type_vardesc_ (void);
 359 static tree ffecom_vardesc_ (ffebld expr);
 360 static tree ffecom_vardesc_array_ (ffesymbol s);
 361 static tree ffecom_vardesc_dims_ (ffesymbol s);
 362 static tree ffecom_convert_narrow_ (tree type, tree expr);
 363 static tree ffecom_convert_widen_ (tree type, tree expr);
 364
 365 /* These are static functions that parallel those found in the C front
 366    end and thus have the same names.  */
 367
 368 static tree bison_rule_compstmt_ (void);
 369 static void bison_rule_pushlevel_ (void);
 370 static void delete_block (tree block);
 371 static int duplicate_decls (tree newdecl, tree olddecl);
 372 static void finish_decl (tree decl, tree init, bool is_top_level);
 373 static void finish_function (int nested);
 374 static const char *ffe_printable_name (tree decl, int v);
 375 static void ffe_print_error_function (diagnostic_context *, const char *);
 376 static tree lookup_name_current_level (tree name);
 377 static struct binding_level *make_binding_level (void);
 378 static void pop_f_function_context (void);
 379 static void push_f_function_context (void);
 380 static void push_parm_decl (tree parm);
 381 static tree pushdecl_top_level (tree decl);
 382 static int kept_level_p (void);
 383 static tree storedecls (tree decls);
 384 static void store_parm_decls (int is_main_program);
 385 static tree start_decl (tree decl, bool is_top_level);
 386 static void start_function (tree name, tree type, int nested, int public);
 387 static void ffecom_file_ (const char *name);
 388 static void ffecom_close_include_ (FILE *f);
 389 static int ffecom_decode_include_option_ (char *spec);
 390 static FILE *ffecom_open_include_ (char *name, ffewhereLine l,
 391                                    ffewhereColumn c);
 392
 393 /* Static objects accessed by functions in this module. */
 394
 395 static ffesymbol ffecom_primary_entry_ = NULL;
 396 static ffesymbol ffecom_nested_entry_ = NULL;
 397 static ffeinfoKind ffecom_primary_entry_kind_;
 398 static bool ffecom_primary_entry_is_proc_;
 399 static tree ffecom_outer_function_decl_;
 400 static tree ffecom_previous_function_decl_;
 401 static tree ffecom_which_entrypoint_decl_;
 402 static tree ffecom_float_zero_ = NULL_TREE;
 403 static tree ffecom_float_half_ = NULL_TREE;
 404 static tree ffecom_double_zero_ = NULL_TREE;
 405 static tree ffecom_double_half_ = NULL_TREE;
 406 static tree ffecom_func_result_;/* For functions. */
 407 static tree ffecom_func_length_;/* For CHARACTER fns. */
 408 static ffebld ffecom_list_blockdata_;
 409 static ffebld ffecom_list_common_;
 410 static ffebld ffecom_master_arglist_;
 411 static ffeinfoBasictype ffecom_master_bt_;
 412 static ffeinfoKindtype ffecom_master_kt_;
 413 static ffetargetCharacterSize ffecom_master_size_;
 414 static int ffecom_num_fns_ = 0;
 415 static int ffecom_num_entrypoints_ = 0;
 416 static bool ffecom_is_altreturning_ = FALSE;
 417 static tree ffecom_multi_type_node_;
 418 static tree ffecom_multi_retval_;
 419 static tree
 420   ffecom_multi_fields_[FFEINFO_basictype][FFEINFO_kindtype];
 421 static bool ffecom_member_namelisted_;  /* _member_phase1_ namelisted? */
 422 static bool ffecom_doing_entry_ = FALSE;
 423 static bool ffecom_transform_only_dummies_ = FALSE;
 424 static int ffecom_typesize_pointer_;
 425 static int ffecom_typesize_integer1_;
 426
 427 /* Holds pointer-to-function expressions.  */
 428
 429 static tree ffecom_gfrt_[FFECOM_gfrt]
 430 =
 431 {
 432 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NULL_TREE,
 433 #include "com-rt.def"
 434 #undef DEFGFRT
 435 };
 436
 437 /* Holds the external names of the functions.  */
 438
 439 static const char *const ffecom_gfrt_name_[FFECOM_gfrt]
 440 =
 441 {
 442 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NAME,
 443 #include "com-rt.def"
 444 #undef DEFGFRT
 445 };
 446
 447 /* Whether the function returns.  */
 448
 449 static const bool ffecom_gfrt_volatile_[FFECOM_gfrt]
 450 =
 451 {
 452 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) VOLATILE,
 453 #include "com-rt.def"
 454 #undef DEFGFRT
 455 };
 456
 457 /* Whether the function returns type complex.  */
 458
 459 static const bool ffecom_gfrt_complex_[FFECOM_gfrt]
 460 =
 461 {
 462 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) COMPLEX,
 463 #include "com-rt.def"
 464 #undef DEFGFRT
 465 };
 466
 467 /* Whether the function is const
 468    (i.e., has no side effects and only depends on its arguments).  */
 469
 470 static const bool ffecom_gfrt_const_[FFECOM_gfrt]
 471 =
 472 {
 473 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) CONST,
 474 #include "com-rt.def"
 475 #undef DEFGFRT
 476 };
 477
 478 /* Type code for the function return value.  */
 479
 480 static const ffecomRttype_ ffecom_gfrt_type_[FFECOM_gfrt]
 481 =
 482 {
 483 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) TYPE,
 484 #include "com-rt.def"
 485 #undef DEFGFRT
 486 };
 487
 488 /* String of codes for the function's arguments.  */
 489
 490 static const char *const ffecom_gfrt_argstring_[FFECOM_gfrt]
 491 =
 492 {
 493 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) ARGS,
 494 #include "com-rt.def"
 495 #undef DEFGFRT
 496 };
 497
 498 /* Internal macros. */
 499
 500 /* We let tm.h override the types used here, to handle trivial differences
 501    such as the choice of unsigned int or long unsigned int for size_t.
 502    When machines start needing nontrivial differences in the size type,
 503    it would be best to do something here to figure out automatically
 504    from other information what type to use.  */
 505
 506 #ifndef SIZE_TYPE
 507 #define SIZE_TYPE "long unsigned int"
 508 #endif
 509
 510 #define ffecom_concat_list_count_(catlist) ((catlist).count)
 511 #define ffecom_concat_list_expr_(catlist,i) ((catlist).exprs[(i)])
 512 #define ffecom_concat_list_maxlen_(catlist) ((catlist).maxlen)
 513 #define ffecom_concat_list_minlen_(catlist) ((catlist).minlen)
 514
 515 #define ffecom_char_args_(i,l,e) ffecom_char_args_x_((i),(l),(e),FALSE)
 516 #define ffecom_char_args_with_null_(i,l,e) ffecom_char_args_x_((i),(l),(e),TRUE)
 517
 518 /* For each binding contour we allocate a binding_level structure
 519  * which records the names defined in that contour.
 520  * Contours include:
 521  *  0) the global one
 522  *  1) one for each function definition,
 523  *     where internal declarations of the parameters appear.
 524  *
 525  * The current meaning of a name can be found by searching the levels from
 526  * the current one out to the global one.
 527  */
 528
 529 /* Note that the information in the `names' component of the global contour
 530    is duplicated in the IDENTIFIER_GLOBAL_VALUEs of all identifiers.  */
 531
 532 struct binding_level
 533   {
 534     /* A chain of _DECL nodes for all variables, constants, functions,
 535        and typedef types.  These are in the reverse of the order supplied.
 536      */
 537     tree names;
 538
 539     /* For each level (except not the global one),
 540        a chain of BLOCK nodes for all the levels
 541        that were entered and exited one level down.  */
 542     tree blocks;
 543
 544     /* The BLOCK node for this level, if one has been preallocated.
 545        If 0, the BLOCK is allocated (if needed) when the level is popped.  */
 546     tree this_block;
 547
 548     /* The binding level which this one is contained in (inherits from).  */
 549     struct binding_level *level_chain;
 550
 551     /* 0: no ffecom_prepare_* functions called at this level yet;
 552        1: ffecom_prepare* functions called, except not ffecom_prepare_end;
 553        2: ffecom_prepare_end called.  */
 554     int prep_state;
 555   };
 556
 557 #define NULL_BINDING_LEVEL (struct binding_level *) NULL
 558
 559 /* The binding level currently in effect.  */
 560
 561 static struct binding_level *current_binding_level;
 562
 563 /* A chain of binding_level structures awaiting reuse.  */
 564
 565 static struct binding_level *free_binding_level;
 566
 567 /* The outermost binding level, for names of file scope.
 568    This is created when the compiler is started and exists
 569    through the entire run.  */
 570
 571 static struct binding_level *global_binding_level;
 572
 573 /* Binding level structures are initialized by copying this one.  */
 574
 575 static const struct binding_level clear_binding_level
 576 =
 577 {NULL, NULL, NULL, NULL_BINDING_LEVEL, 0};
 578
 579 /* Language-dependent contents of an identifier.  */
 580
 581 struct lang_identifier
 582   {
 583     struct tree_identifier ignore;
 584     tree global_value, local_value, label_value;
 585     bool invented;
 586   };
 587
 588 /* Macros for access to language-specific slots in an identifier.  */
 589 /* Each of these slots contains a DECL node or null.  */
 590
 591 /* This represents the value which the identifier has in the
 592    file-scope namespace.  */
 593 #define IDENTIFIER_GLOBAL_VALUE(NODE)   \
 594   (((struct lang_identifier *)(NODE))->global_value)
 595 /* This represents the value which the identifier has in the current
 596    scope.  */
 597 #define IDENTIFIER_LOCAL_VALUE(NODE)    \
 598   (((struct lang_identifier *)(NODE))->local_value)
 599 /* This represents the value which the identifier has as a label in
 600    the current label scope.  */
 601 #define IDENTIFIER_LABEL_VALUE(NODE)    \
 602   (((struct lang_identifier *)(NODE))->label_value)
 603 /* This is nonzero if the identifier was "made up" by g77 code.  */
 604 #define IDENTIFIER_INVENTED(NODE)       \
 605   (((struct lang_identifier *)(NODE))->invented)
 606
 607 /* In identifiers, C uses the following fields in a special way:
 608    TREE_PUBLIC        to record that there was a previous local extern decl.
 609    TREE_USED          to record that such a decl was used.
 610    TREE_ADDRESSABLE   to record that the address of such a decl was used.  */
 611
 612 /* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function
 613    that have names.  Here so we can clear out their names' definitions
 614    at the end of the function.  */
 615
 616 static tree named_labels;
 617
 618 /* A list of LABEL_DECLs from outer contexts that are currently shadowed.  */
 619
 620 static tree shadowed_labels;
 621 \f
 622 /* Return the subscript expression, modified to do range-checking.
 623
 624    `array' is the array to be checked against.
 625    `element' is the subscript expression to check.
 626    `dim' is the dimension number (starting at 0).
 627    `total_dims' is the total number of dimensions (0 for CHARACTER substring).
 628 */
 629
 630 static tree
 631 ffecom_subscript_check_ (tree array, tree element, int dim, int total_dims,
 632                          const char *array_name)
 633 {
 634   tree low = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
 635   tree high = TYPE_MAX_VALUE (TYPE_DOMAIN (array));
 636   tree cond;
 637   tree die;
 638   tree args;
 639
 640   if (element == error_mark_node)
 641     return element;
 642
 643   if (TREE_TYPE (low) != TREE_TYPE (element))
 644     {
 645       if (TYPE_PRECISION (TREE_TYPE (low))
 646           > TYPE_PRECISION (TREE_TYPE (element)))
 647         element = convert (TREE_TYPE (low), element);
 648       else
 649         {
 650           low = convert (TREE_TYPE (element), low);
 651           if (high)
 652             high = convert (TREE_TYPE (element), high);
 653         }
 654     }
 655
 656   element = ffecom_save_tree (element);
 657   if (total_dims == 0)
 658     {
 659       /* Special handling for substring range checks.  Fortran allows the
 660          end subscript < begin subscript, which means that expressions like
 661        string(1:0) are valid (and yield a null string).  In view of this,
 662        enforce two simpler conditions:
 663           1) element<=high for end-substring;
 664           2) element>=low for start-substring.
 665        Run-time character movement will enforce remaining conditions.
 666
 667        More complicated checks would be better, but present structure only
 668        provides one index element at a time, so it is not possible to
 669        enforce a check of both i and j in string(i:j).  If it were, the
 670        complete set of rules would read,
 671          if ( ((j<i) && ((low<=i<=high) || (low<=j<=high))) ||
 672               ((low<=i<=high) && (low<=j<=high)) )
 673            ok ;
 674          else
 675            range error ;
 676       */
 677       if (dim)
 678         cond = ffecom_2 (LE_EXPR, integer_type_node, element, high);
 679       else
 680         cond = ffecom_2 (LE_EXPR, integer_type_node, low, element);
 681     }
 682   else
 683     {
 684       /* Array reference substring range checking.  */
 685
 686       cond = ffecom_2 (LE_EXPR, integer_type_node,
 687                      low,
 688                      element);
 689       if (high)
 690         {
 691           cond = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
 692                          cond,
 693                          ffecom_2 (LE_EXPR, integer_type_node,
 694                                    element,
 695                                    high));
 696         }
 697     }
 698
 699   {
 700     int len;
 701     char *proc;
 702     char *var;
 703     tree arg3;
 704     tree arg2;
 705     tree arg1;
 706     tree arg4;
 707
 708     switch (total_dims)
 709       {
 710       case 0:
 711         var = concat (array_name, "[", (dim ? "end" : "start"),
 712                       "-substring]", NULL);
 713         len = strlen (var) + 1;
 714         arg1 = build_string (len, var);
 715         free (var);
 716         break;
 717
 718       case 1:
 719         len = strlen (array_name) + 1;
 720         arg1 = build_string (len, array_name);
 721         break;
 722
 723       default:
 724         var = xmalloc (strlen (array_name) + 40);
 725         sprintf (var, "%s[subscript-%d-of-%d]",
 726                  array_name,
 727                  dim + 1, total_dims);
 728         len = strlen (var) + 1;
 729         arg1 = build_string (len, var);
 730         free (var);
 731         break;
 732       }
 733
 734     TREE_TYPE (arg1)
 735       = build_type_variant (build_array_type (char_type_node,
 736                                               build_range_type
 737                                               (integer_type_node,
 738                                                integer_one_node,
 739                                                build_int_2 (len, 0))),
 740                             1, 0);
 741     TREE_CONSTANT (arg1) = 1;
 742     TREE_STATIC (arg1) = 1;
 743     arg1 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg1)),
 744                      arg1);
 745
 746     /* s_rnge adds one to the element to print it, so bias against
 747        that -- want to print a faithful *subscript* value.  */
 748     arg2 = convert (ffecom_f2c_ftnint_type_node,
 749                     ffecom_2 (MINUS_EXPR,
 750                               TREE_TYPE (element),
 751                               element,
 752                               convert (TREE_TYPE (element),
 753                                        integer_one_node)));
 754
 755     proc = concat (input_filename, "/",
 756                    IDENTIFIER_POINTER (DECL_NAME (current_function_decl)),
 757                    NULL);
 758     len = strlen (proc) + 1;
 759     arg3 = build_string (len, proc);
 760
 761     free (proc);
 762
 763     TREE_TYPE (arg3)
 764       = build_type_variant (build_array_type (char_type_node,
 765                                               build_range_type
 766                                               (integer_type_node,
 767                                                integer_one_node,
 768                                                build_int_2 (len, 0))),
 769                             1, 0);
 770     TREE_CONSTANT (arg3) = 1;
 771     TREE_STATIC (arg3) = 1;
 772     arg3 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg3)),
 773                      arg3);
 774
 775     arg4 = convert (ffecom_f2c_ftnint_type_node,
 776                     build_int_2 (lineno, 0));
 777
 778     arg1 = build_tree_list (NULL_TREE, arg1);
 779     arg2 = build_tree_list (NULL_TREE, arg2);
 780     arg3 = build_tree_list (NULL_TREE, arg3);
 781     arg4 = build_tree_list (NULL_TREE, arg4);
 782     TREE_CHAIN (arg3) = arg4;
 783     TREE_CHAIN (arg2) = arg3;
 784     TREE_CHAIN (arg1) = arg2;
 785
 786     args = arg1;
 787   }
 788   die = ffecom_call_gfrt (FFECOM_gfrtRANGE,
 789                           args, NULL_TREE);
 790   TREE_SIDE_EFFECTS (die) = 1;
 791
 792   element = ffecom_3 (COND_EXPR,
 793                       TREE_TYPE (element),
 794                       cond,
 795                       element,
 796                       die);
 797
 798   return element;
 799 }
 800
 801 /* Return the computed element of an array reference.
 802
 803    `item' is NULL_TREE, or the transformed pointer to the array.
 804    `expr' is the original opARRAYREF expression, which is transformed
 805      if `item' is NULL_TREE.
 806    `want_ptr' is non-zero if a pointer to the element, instead of
 807      the element itself, is to be returned.  */
 808
 809 static tree
 810 ffecom_arrayref_ (tree item, ffebld expr, int want_ptr)
 811 {
 812   ffebld dims[FFECOM_dimensionsMAX];
 813   int i;
 814   int total_dims;
 815   int flatten = ffe_is_flatten_arrays ();
 816   int need_ptr;
 817   tree array;
 818   tree element;
 819   tree tree_type;
 820   tree tree_type_x;
 821   const char *array_name;
 822   ffetype type;
 823   ffebld list;
 824
 825   if (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER)
 826     array_name = ffesymbol_text (ffebld_symter (ffebld_left (expr)));
 827   else
 828     array_name = "[expr?]";
 829
 830   /* Build up ARRAY_REFs in reverse order (since we're column major
 831      here in Fortran land). */
 832
 833   for (i = 0, list = ffebld_right (expr);
 834        list != NULL;
 835        ++i, list = ffebld_trail (list))
 836     {
 837       dims[i] = ffebld_head (list);
 838       type = ffeinfo_type (ffebld_basictype (dims[i]),
 839                            ffebld_kindtype (dims[i]));
 840       if (! flatten
 841           && ffecom_typesize_pointer_ > ffecom_typesize_integer1_
 842           && ffetype_size (type) > ffecom_typesize_integer1_)
 843         /* E.g. ARRAY(INDEX), given INTEGER*8 INDEX, on a system with 64-bit
 844            pointers and 32-bit integers.  Do the full 64-bit pointer
 845            arithmetic, for codes using arrays for nonstandard heap-like
 846            work.  */
 847         flatten = 1;
 848     }
 849
 850   total_dims = i;
 851
 852   need_ptr = want_ptr || flatten;
 853
 854   if (! item)
 855     {
 856       if (need_ptr)
 857         item = ffecom_ptr_to_expr (ffebld_left (expr));
 858       else
 859         item = ffecom_expr (ffebld_left (expr));
 860
 861       if (item == error_mark_node)
 862         return item;
 863
 864       if (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereFLEETING
 865           && ! ffe_mark_addressable (item))
 866         return error_mark_node;
 867     }
 868
 869   if (item == error_mark_node)
 870     return item;
 871
 872   if (need_ptr)
 873     {
 874       tree min;
 875
 876       for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
 877            i >= 0;
 878            --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array)))
 879         {
 880           min = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
 881           element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
 882           if (flag_bounds_check)
 883             element = ffecom_subscript_check_ (array, element, i, total_dims,
 884                                                array_name);
 885           if (element == error_mark_node)
 886             return element;
 887
 888           /* Widen integral arithmetic as desired while preserving
 889              signedness.  */
 890           tree_type = TREE_TYPE (element);
 891           tree_type_x = tree_type;
 892           if (tree_type
 893               && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
 894               && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
 895             tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
 896
 897           if (TREE_TYPE (min) != tree_type_x)
 898             min = convert (tree_type_x, min);
 899           if (TREE_TYPE (element) != tree_type_x)
 900             element = convert (tree_type_x, element);
 901
 902           item = ffecom_2 (PLUS_EXPR,
 903                            build_pointer_type (TREE_TYPE (array)),
 904                            item,
 905                            size_binop (MULT_EXPR,
 906                                        size_in_bytes (TREE_TYPE (array)),
 907                                        convert (sizetype,
 908                                                 fold (build (MINUS_EXPR,
 909                                                              tree_type_x,
 910                                                              element, min)))));
 911         }
 912       if (! want_ptr)
 913         {
 914           item = ffecom_1 (INDIRECT_REF,
 915                            TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
 916                            item);
 917         }
 918     }
 919   else
 920     {
 921       for (--i;
 922            i >= 0;
 923            --i)
 924         {
 925           array = TYPE_MAIN_VARIANT (TREE_TYPE (item));
 926
 927           element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
 928           if (flag_bounds_check)
 929             element = ffecom_subscript_check_ (array, element, i, total_dims,
 930                                                array_name);
 931           if (element == error_mark_node)
 932             return element;
 933
 934           /* Widen integral arithmetic as desired while preserving
 935              signedness.  */
 936           tree_type = TREE_TYPE (element);
 937           tree_type_x = tree_type;
 938           if (tree_type
 939               && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
 940               && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
 941             tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
 942
 943           element = convert (tree_type_x, element);
 944
 945           item = ffecom_2 (ARRAY_REF,
 946                            TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
 947                            item,
 948                            element);
 949         }
 950     }
 951
 952   return item;
 953 }
 954
 955 /* This is like gcc's stabilize_reference -- in fact, most of the code
 956    comes from that -- but it handles the situation where the reference
 957    is going to have its subparts picked at, and it shouldn't change
 958    (or trigger extra invocations of functions in the subtrees) due to
 959    this.  save_expr is a bit overzealous, because we don't need the
 960    entire thing calculated and saved like a temp.  So, for DECLs, no
 961    change is needed, because these are stable aggregates, and ARRAY_REF
 962    and such might well be stable too, but for things like calculations,
 963    we do need to calculate a snapshot of a value before picking at it.  */
 964
 965 static tree
 966 ffecom_stabilize_aggregate_ (tree ref)
 967 {
 968   tree result;
 969   enum tree_code code = TREE_CODE (ref);
 970
 971   switch (code)
 972     {
 973     case VAR_DECL:
 974     case PARM_DECL:
 975     case RESULT_DECL:
 976       /* No action is needed in this case.  */
 977       return ref;
 978
 979     case NOP_EXPR:
 980     case CONVERT_EXPR:
 981     case FLOAT_EXPR:
 982     case FIX_TRUNC_EXPR:
 983     case FIX_FLOOR_EXPR:
 984     case FIX_ROUND_EXPR:
 985     case FIX_CEIL_EXPR:
 986       result = build_nt (code, stabilize_reference (TREE_OPERAND (ref, 0)));
 987       break;
 988
 989     case INDIRECT_REF:
 990       result = build_nt (INDIRECT_REF,
 991                          stabilize_reference_1 (TREE_OPERAND (ref, 0)));
 992       break;
 993
 994     case COMPONENT_REF:
 995       result = build_nt (COMPONENT_REF,
 996                          stabilize_reference (TREE_OPERAND (ref, 0)),
 997                          TREE_OPERAND (ref, 1));
 998       break;
 999
1000     case BIT_FIELD_REF:
1001       result = build_nt (BIT_FIELD_REF,
1002                          stabilize_reference (TREE_OPERAND (ref, 0)),
1003                          stabilize_reference_1 (TREE_OPERAND (ref, 1)),
1004                          stabilize_reference_1 (TREE_OPERAND (ref, 2)));
1005       break;
1006
1007     case ARRAY_REF:
1008       result = build_nt (ARRAY_REF,
1009                          stabilize_reference (TREE_OPERAND (ref, 0)),
1010                          stabilize_reference_1 (TREE_OPERAND (ref, 1)));
1011       break;
1012
1013     case COMPOUND_EXPR:
1014       result = build_nt (COMPOUND_EXPR,
1015                          stabilize_reference_1 (TREE_OPERAND (ref, 0)),
1016                          stabilize_reference (TREE_OPERAND (ref, 1)));
1017       break;
1018
1019     case RTL_EXPR:
1020       abort ();
1021
1022
1023     default:
1024       return save_expr (ref);
1025
1026     case ERROR_MARK:
1027       return error_mark_node;
1028     }
1029
1030   TREE_TYPE (result) = TREE_TYPE (ref);
1031   TREE_READONLY (result) = TREE_READONLY (ref);
1032   TREE_SIDE_EFFECTS (result) = TREE_SIDE_EFFECTS (ref);
1033   TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref);
1034
1035   return result;
1036 }
1037
1038 /* A rip-off of gcc's convert.c convert_to_complex function,
1039    reworked to handle complex implemented as C structures
1040    (RECORD_TYPE with two fields, real and imaginary `r' and `i').  */
1041
1042 static tree
1043 ffecom_convert_to_complex_ (tree type, tree expr)
1044 {
1045   register enum tree_code form = TREE_CODE (TREE_TYPE (expr));
1046   tree subtype;
1047
1048   assert (TREE_CODE (type) == RECORD_TYPE);
1049
1050   subtype = TREE_TYPE (TYPE_FIELDS (type));
1051
1052   if (form == REAL_TYPE || form == INTEGER_TYPE || form == ENUMERAL_TYPE)
1053     {
1054       expr = convert (subtype, expr);
1055       return ffecom_2 (COMPLEX_EXPR, type, expr,
1056                        convert (subtype, integer_zero_node));
1057     }
1058
1059   if (form == RECORD_TYPE)
1060     {
1061       tree elt_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr)));
1062       if (TYPE_MAIN_VARIANT (elt_type) == TYPE_MAIN_VARIANT (subtype))
1063         return expr;
1064       else
1065         {
1066           expr = save_expr (expr);
1067           return ffecom_2 (COMPLEX_EXPR,
1068                            type,
1069                            convert (subtype,
1070                                     ffecom_1 (REALPART_EXPR,
1071                                               TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1072                                               expr)),
1073                            convert (subtype,
1074                                     ffecom_1 (IMAGPART_EXPR,
1075                                               TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1076                                               expr)));
1077         }
1078     }
1079
1080   if (form == POINTER_TYPE || form == REFERENCE_TYPE)
1081     error ("pointer value used where a complex was expected");
1082   else
1083     error ("aggregate value used where a complex was expected");
1084
1085   return ffecom_2 (COMPLEX_EXPR, type,
1086                    convert (subtype, integer_zero_node),
1087                    convert (subtype, integer_zero_node));
1088 }
1089
1090 /* Like gcc's convert(), but crashes if widening might happen.  */
1091
1092 static tree
1093 ffecom_convert_narrow_ (type, expr)
1094      tree type, expr;
1095 {
1096   register tree e = expr;
1097   register enum tree_code code = TREE_CODE (type);
1098
1099   if (type == TREE_TYPE (e)
1100       || TREE_CODE (e) == ERROR_MARK)
1101     return e;
1102   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1103     return fold (build1 (NOP_EXPR, type, e));
1104   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1105       || code == ERROR_MARK)
1106     return error_mark_node;
1107   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1108     {
1109       assert ("void value not ignored as it ought to be" == NULL);
1110       return error_mark_node;
1111     }
1112   assert (code != VOID_TYPE);
1113   if ((code != RECORD_TYPE)
1114       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1115     assert ("converting COMPLEX to REAL" == NULL);
1116   assert (code != ENUMERAL_TYPE);
1117   if (code == INTEGER_TYPE)
1118     {
1119       assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1120                && TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)))
1121               || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1122                   && (TYPE_PRECISION (type)
1123                       == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1124       return fold (convert_to_integer (type, e));
1125     }
1126   if (code == POINTER_TYPE)
1127     {
1128       assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1129       return fold (convert_to_pointer (type, e));
1130     }
1131   if (code == REAL_TYPE)
1132     {
1133       assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1134       assert (TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)));
1135       return fold (convert_to_real (type, e));
1136     }
1137   if (code == COMPLEX_TYPE)
1138     {
1139       assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1140       assert (TYPE_PRECISION (TREE_TYPE (type)) <= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1141       return fold (convert_to_complex (type, e));
1142     }
1143   if (code == RECORD_TYPE)
1144     {
1145       assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1146       /* Check that at least the first field name agrees.  */
1147       assert (DECL_NAME (TYPE_FIELDS (type))
1148               == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1149       assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1150               <= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1151       if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1152           == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1153         return e;
1154       return fold (ffecom_convert_to_complex_ (type, e));
1155     }
1156
1157   assert ("conversion to non-scalar type requested" == NULL);
1158   return error_mark_node;
1159 }
1160
1161 /* Like gcc's convert(), but crashes if narrowing might happen.  */
1162
1163 static tree
1164 ffecom_convert_widen_ (type, expr)
1165      tree type, expr;
1166 {
1167   register tree e = expr;
1168   register enum tree_code code = TREE_CODE (type);
1169
1170   if (type == TREE_TYPE (e)
1171       || TREE_CODE (e) == ERROR_MARK)
1172     return e;
1173   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1174     return fold (build1 (NOP_EXPR, type, e));
1175   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1176       || code == ERROR_MARK)
1177     return error_mark_node;
1178   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1179     {
1180       assert ("void value not ignored as it ought to be" == NULL);
1181       return error_mark_node;
1182     }
1183   assert (code != VOID_TYPE);
1184   if ((code != RECORD_TYPE)
1185       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1186     assert ("narrowing COMPLEX to REAL" == NULL);
1187   assert (code != ENUMERAL_TYPE);
1188   if (code == INTEGER_TYPE)
1189     {
1190       assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1191                && TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)))
1192               || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1193                   && (TYPE_PRECISION (type)
1194                       == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1195       return fold (convert_to_integer (type, e));
1196     }
1197   if (code == POINTER_TYPE)
1198     {
1199       assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1200       return fold (convert_to_pointer (type, e));
1201     }
1202   if (code == REAL_TYPE)
1203     {
1204       assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1205       assert (TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)));
1206       return fold (convert_to_real (type, e));
1207     }
1208   if (code == COMPLEX_TYPE)
1209     {
1210       assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1211       assert (TYPE_PRECISION (TREE_TYPE (type)) >= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1212       return fold (convert_to_complex (type, e));
1213     }
1214   if (code == RECORD_TYPE)
1215     {
1216       assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1217       /* Check that at least the first field name agrees.  */
1218       assert (DECL_NAME (TYPE_FIELDS (type))
1219               == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1220       assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1221               >= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1222       if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1223           == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1224         return e;
1225       return fold (ffecom_convert_to_complex_ (type, e));
1226     }
1227
1228   assert ("conversion to non-scalar type requested" == NULL);
1229   return error_mark_node;
1230 }
1231
1232 /* Handles making a COMPLEX type, either the standard
1233    (but buggy?) gbe way, or the safer (but less elegant?)
1234    f2c way.  */
1235
1236 static tree
1237 ffecom_make_complex_type_ (tree subtype)
1238 {
1239   tree type;
1240   tree realfield;
1241   tree imagfield;
1242
1243   if (ffe_is_emulate_complex ())
1244     {
1245       type = make_node (RECORD_TYPE);
1246       realfield = ffecom_decl_field (type, NULL_TREE, "r", subtype);
1247       imagfield = ffecom_decl_field (type, realfield, "i", subtype);
1248       TYPE_FIELDS (type) = realfield;
1249       layout_type (type);
1250     }
1251   else
1252     {
1253       type = make_node (COMPLEX_TYPE);
1254       TREE_TYPE (type) = subtype;
1255       layout_type (type);
1256     }
1257
1258   return type;
1259 }
1260
1261 /* Chooses either the gbe or the f2c way to build a
1262    complex constant.  */
1263
1264 static tree
1265 ffecom_build_complex_constant_ (tree type, tree realpart, tree imagpart)
1266 {
1267   tree bothparts;
1268
1269   if (ffe_is_emulate_complex ())
1270     {
1271       bothparts = build_tree_list (TYPE_FIELDS (type), realpart);
1272       TREE_CHAIN (bothparts) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), imagpart);
1273       bothparts = build (CONSTRUCTOR, type, NULL_TREE, bothparts);
1274     }
1275   else
1276     {
1277       bothparts = build_complex (type, realpart, imagpart);
1278     }
1279
1280   return bothparts;
1281 }
1282
1283 static tree
1284 ffecom_arglist_expr_ (const char *c, ffebld expr)
1285 {
1286   tree list;
1287   tree *plist = &list;
1288   tree trail = NULL_TREE;       /* Append char length args here. */
1289   tree *ptrail = &trail;
1290   tree length;
1291   ffebld exprh;
1292   tree item;
1293   bool ptr = FALSE;
1294   tree wanted = NULL_TREE;
1295   static const char zed[] = "0";
1296
1297   if (c == NULL)
1298     c = &zed[0];
1299
1300   while (expr != NULL)
1301     {
1302       if (*c != '\0')
1303         {
1304           ptr = FALSE;
1305           if (*c == '&')
1306             {
1307               ptr = TRUE;
1308               ++c;
1309             }
1310           switch (*(c++))
1311             {
1312             case '\0':
1313               ptr = TRUE;
1314               wanted = NULL_TREE;
1315               break;
1316
1317             case 'a':
1318               assert (ptr);
1319               wanted = NULL_TREE;
1320               break;
1321
1322             case 'c':
1323               wanted = ffecom_f2c_complex_type_node;
1324               break;
1325
1326             case 'd':
1327               wanted = ffecom_f2c_doublereal_type_node;
1328               break;
1329
1330             case 'e':
1331               wanted = ffecom_f2c_doublecomplex_type_node;
1332               break;
1333
1334             case 'f':
1335               wanted = ffecom_f2c_real_type_node;
1336               break;
1337
1338             case 'i':
1339               wanted = ffecom_f2c_integer_type_node;
1340               break;
1341
1342             case 'j':
1343               wanted = ffecom_f2c_longint_type_node;
1344               break;
1345
1346             default:
1347               assert ("bad argstring code" == NULL);
1348               wanted = NULL_TREE;
1349               break;
1350             }
1351         }
1352
1353       exprh = ffebld_head (expr);
1354       if (exprh == NULL)
1355         wanted = NULL_TREE;
1356
1357       if ((wanted == NULL_TREE)
1358           || (ptr
1359               && (TYPE_MODE
1360                   (ffecom_tree_type[ffeinfo_basictype (ffebld_info (exprh))]
1361                    [ffeinfo_kindtype (ffebld_info (exprh))])
1362                    == TYPE_MODE (wanted))))
1363         *plist
1364           = build_tree_list (NULL_TREE,
1365                              ffecom_arg_ptr_to_expr (exprh,
1366                                                      &length));
1367       else
1368         {
1369           item = ffecom_arg_expr (exprh, &length);
1370           item = ffecom_convert_widen_ (wanted, item);
1371           if (ptr)
1372             {
1373               item = ffecom_1 (ADDR_EXPR,
1374                                build_pointer_type (TREE_TYPE (item)),
1375                                item);
1376             }
1377           *plist
1378             = build_tree_list (NULL_TREE,
1379                                item);
1380         }
1381
1382       plist = &TREE_CHAIN (*plist);
1383       expr = ffebld_trail (expr);
1384       if (length != NULL_TREE)
1385         {
1386           *ptrail = build_tree_list (NULL_TREE, length);
1387           ptrail = &TREE_CHAIN (*ptrail);
1388         }
1389     }
1390
1391   /* We've run out of args in the call; if the implementation expects
1392      more, supply null pointers for them, which the implementation can
1393      check to see if an arg was omitted. */
1394
1395   while (*c != '\0' && *c != '0')
1396     {
1397       if (*c == '&')
1398         ++c;
1399       else
1400         assert ("missing arg to run-time routine!" == NULL);
1401
1402       switch (*(c++))
1403         {
1404         case '\0':
1405         case 'a':
1406         case 'c':
1407         case 'd':
1408         case 'e':
1409         case 'f':
1410         case 'i':
1411         case 'j':
1412           break;
1413
1414         default:
1415           assert ("bad arg string code" == NULL);
1416           break;
1417         }
1418       *plist
1419         = build_tree_list (NULL_TREE,
1420                            null_pointer_node);
1421       plist = &TREE_CHAIN (*plist);
1422     }
1423
1424   *plist = trail;
1425
1426   return list;
1427 }
1428
1429 static tree
1430 ffecom_widest_expr_type_ (ffebld list)
1431 {
1432   ffebld item;
1433   ffebld widest = NULL;
1434   ffetype type;
1435   ffetype widest_type = NULL;
1436   tree t;
1437
1438   for (; list != NULL; list = ffebld_trail (list))
1439     {
1440       item = ffebld_head (list);
1441       if (item == NULL)
1442         continue;
1443       if ((widest != NULL)
1444           && (ffeinfo_basictype (ffebld_info (item))
1445               != ffeinfo_basictype (ffebld_info (widest))))
1446         continue;
1447       type = ffeinfo_type (ffeinfo_basictype (ffebld_info (item)),
1448                            ffeinfo_kindtype (ffebld_info (item)));
1449       if ((widest == FFEINFO_kindtypeNONE)
1450           || (ffetype_size (type)
1451               > ffetype_size (widest_type)))
1452         {
1453           widest = item;
1454           widest_type = type;
1455         }
1456     }
1457
1458   assert (widest != NULL);
1459   t = ffecom_tree_type[ffeinfo_basictype (ffebld_info (widest))]
1460     [ffeinfo_kindtype (ffebld_info (widest))];
1461   assert (t != NULL_TREE);
1462   return t;
1463 }
1464
1465 /* Check whether a partial overlap between two expressions is possible.
1466
1467    Can *starting* to write a portion of expr1 change the value
1468    computed (perhaps already, *partially*) by expr2?
1469
1470    Currently, this is a concern only for a COMPLEX expr1.  But if it
1471    isn't in COMMON or local EQUIVALENCE, since we don't support
1472    aliasing of arguments, it isn't a concern.  */
1473
1474 static bool
1475 ffecom_possible_partial_overlap_ (ffebld expr1, ffebld expr2 ATTRIBUTE_UNUSED)
1476 {
1477   ffesymbol sym;
1478   ffestorag st;
1479
1480   switch (ffebld_op (expr1))
1481     {
1482     case FFEBLD_opSYMTER:
1483       sym = ffebld_symter (expr1);
1484       break;
1485
1486     case FFEBLD_opARRAYREF:
1487       if (ffebld_op (ffebld_left (expr1)) != FFEBLD_opSYMTER)
1488         return FALSE;
1489       sym = ffebld_symter (ffebld_left (expr1));
1490       break;
1491
1492     default:
1493       return FALSE;
1494     }
1495
1496   if (ffesymbol_where (sym) != FFEINFO_whereCOMMON
1497       && (ffesymbol_where (sym) != FFEINFO_whereLOCAL
1498           || ! (st = ffesymbol_storage (sym))
1499           || ! ffestorag_parent (st)))
1500     return FALSE;
1501
1502   /* It's in COMMON or local EQUIVALENCE.  */
1503
1504   return TRUE;
1505 }
1506
1507 /* Check whether dest and source might overlap.  ffebld versions of these
1508    might or might not be passed, will be NULL if not.
1509
1510    The test is really whether source_tree is modifiable and, if modified,
1511    might overlap destination such that the value(s) in the destination might
1512    change before it is finally modified.  dest_* are the canonized
1513    destination itself.  */
1514
1515 static bool
1516 ffecom_overlap_ (tree dest_decl, tree dest_offset, tree dest_size,
1517                  tree source_tree, ffebld source UNUSED,
1518                  bool scalar_arg)
1519 {
1520   tree source_decl;
1521   tree source_offset;
1522   tree source_size;
1523   tree t;
1524
1525   if (source_tree == NULL_TREE)
1526     return FALSE;
1527
1528   switch (TREE_CODE (source_tree))
1529     {
1530     case ERROR_MARK:
1531     case IDENTIFIER_NODE:
1532     case INTEGER_CST:
1533     case REAL_CST:
1534     case COMPLEX_CST:
1535     case STRING_CST:
1536     case CONST_DECL:
1537     case VAR_DECL:
1538     case RESULT_DECL:
1539     case FIELD_DECL:
1540     case MINUS_EXPR:
1541     case MULT_EXPR:
1542     case TRUNC_DIV_EXPR:
1543     case CEIL_DIV_EXPR:
1544     case FLOOR_DIV_EXPR:
1545     case ROUND_DIV_EXPR:
1546     case TRUNC_MOD_EXPR:
1547     case CEIL_MOD_EXPR:
1548     case FLOOR_MOD_EXPR:
1549     case ROUND_MOD_EXPR:
1550     case RDIV_EXPR:
1551     case EXACT_DIV_EXPR:
1552     case FIX_TRUNC_EXPR:
1553     case FIX_CEIL_EXPR:
1554     case FIX_FLOOR_EXPR:
1555     case FIX_ROUND_EXPR:
1556     case FLOAT_EXPR:
1557     case NEGATE_EXPR:
1558     case MIN_EXPR:
1559     case MAX_EXPR:
1560     case ABS_EXPR:
1561     case FFS_EXPR:
1562     case LSHIFT_EXPR:
1563     case RSHIFT_EXPR:
1564     case LROTATE_EXPR:
1565     case RROTATE_EXPR:
1566     case BIT_IOR_EXPR:
1567     case BIT_XOR_EXPR:
1568     case BIT_AND_EXPR:
1569     case BIT_ANDTC_EXPR:
1570     case BIT_NOT_EXPR:
1571     case TRUTH_ANDIF_EXPR:
1572     case TRUTH_ORIF_EXPR:
1573     case TRUTH_AND_EXPR:
1574     case TRUTH_OR_EXPR:
1575     case TRUTH_XOR_EXPR:
1576     case TRUTH_NOT_EXPR:
1577     case LT_EXPR:
1578     case LE_EXPR:
1579     case GT_EXPR:
1580     case GE_EXPR:
1581     case EQ_EXPR:
1582     case NE_EXPR:
1583     case COMPLEX_EXPR:
1584     case CONJ_EXPR:
1585     case REALPART_EXPR:
1586     case IMAGPART_EXPR:
1587     case LABEL_EXPR:
1588     case COMPONENT_REF:
1589       return FALSE;
1590
1591     case COMPOUND_EXPR:
1592       return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1593                               TREE_OPERAND (source_tree, 1), NULL,
1594                               scalar_arg);
1595
1596     case MODIFY_EXPR:
1597       return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1598                               TREE_OPERAND (source_tree, 0), NULL,
1599                               scalar_arg);
1600
1601     case CONVERT_EXPR:
1602     case NOP_EXPR:
1603     case NON_LVALUE_EXPR:
1604     case PLUS_EXPR:
1605       if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1606         return TRUE;
1607
1608       ffecom_tree_canonize_ptr_ (&source_decl, &source_offset,
1609                                  source_tree);
1610       source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1611       break;
1612
1613     case COND_EXPR:
1614       return
1615         ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1616                          TREE_OPERAND (source_tree, 1), NULL,
1617                          scalar_arg)
1618           || ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1619                               TREE_OPERAND (source_tree, 2), NULL,
1620                               scalar_arg);
1621
1622
1623     case ADDR_EXPR:
1624       ffecom_tree_canonize_ref_ (&source_decl, &source_offset,
1625                                  &source_size,
1626                                  TREE_OPERAND (source_tree, 0));
1627       break;
1628
1629     case PARM_DECL:
1630       if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1631         return TRUE;
1632
1633       source_decl = source_tree;
1634       source_offset = bitsize_zero_node;
1635       source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1636       break;
1637
1638     case SAVE_EXPR:
1639     case REFERENCE_EXPR:
1640     case PREDECREMENT_EXPR:
1641     case PREINCREMENT_EXPR:
1642     case POSTDECREMENT_EXPR:
1643     case POSTINCREMENT_EXPR:
1644     case INDIRECT_REF:
1645     case ARRAY_REF:
1646     case CALL_EXPR:
1647     default:
1648       return TRUE;
1649     }
1650
1651   /* Come here when source_decl, source_offset, and source_size filled
1652      in appropriately.  */
1653
1654   if (source_decl == NULL_TREE)
1655     return FALSE;               /* No decl involved, so no overlap. */
1656
1657   if (source_decl != dest_decl)
1658     return FALSE;               /* Different decl, no overlap. */
1659
1660   if (TREE_CODE (dest_size) == ERROR_MARK)
1661     return TRUE;                /* Assignment into entire assumed-size
1662                                    array?  Shouldn't happen.... */
1663
1664   t = ffecom_2 (LE_EXPR, integer_type_node,
1665                 ffecom_2 (PLUS_EXPR, TREE_TYPE (dest_offset),
1666                           dest_offset,
1667                           convert (TREE_TYPE (dest_offset),
1668                                    dest_size)),
1669                 convert (TREE_TYPE (dest_offset),
1670                          source_offset));
1671
1672   if (integer_onep (t))
1673     return FALSE;               /* Destination precedes source. */
1674
1675   if (!scalar_arg
1676       || (source_size == NULL_TREE)
1677       || (TREE_CODE (source_size) == ERROR_MARK)
1678       || integer_zerop (source_size))
1679     return TRUE;                /* No way to tell if dest follows source. */
1680
1681   t = ffecom_2 (LE_EXPR, integer_type_node,
1682                 ffecom_2 (PLUS_EXPR, TREE_TYPE (source_offset),
1683                           source_offset,
1684                           convert (TREE_TYPE (source_offset),
1685                                    source_size)),
1686                 convert (TREE_TYPE (source_offset),
1687                          dest_offset));
1688
1689   if (integer_onep (t))
1690     return FALSE;               /* Destination follows source. */
1691
1692   return TRUE;          /* Destination and source overlap. */
1693 }
1694
1695 /* Check whether dest might overlap any of a list of arguments or is
1696    in a COMMON area the callee might know about (and thus modify).  */
1697
1698 static bool
1699 ffecom_args_overlapping_ (tree dest_tree, ffebld dest UNUSED,
1700                           tree args, tree callee_commons,
1701                           bool scalar_args)
1702 {
1703   tree arg;
1704   tree dest_decl;
1705   tree dest_offset;
1706   tree dest_size;
1707
1708   ffecom_tree_canonize_ref_ (&dest_decl, &dest_offset, &dest_size,
1709                              dest_tree);
1710
1711   if (dest_decl == NULL_TREE)
1712     return FALSE;               /* Seems unlikely! */
1713
1714   /* If the decl cannot be determined reliably, or if its in COMMON
1715      and the callee isn't known to not futz with COMMON via other
1716      means, overlap might happen.  */
1717
1718   if ((TREE_CODE (dest_decl) == ERROR_MARK)
1719       || ((callee_commons != NULL_TREE)
1720           && TREE_PUBLIC (dest_decl)))
1721     return TRUE;
1722
1723   for (; args != NULL_TREE; args = TREE_CHAIN (args))
1724     {
1725       if (((arg = TREE_VALUE (args)) != NULL_TREE)
1726           && ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1727                               arg, NULL, scalar_args))
1728         return TRUE;
1729     }
1730
1731   return FALSE;
1732 }
1733
1734 /* Build a string for a variable name as used by NAMELIST.  This means that
1735    if we're using the f2c library, we build an uppercase string, since
1736    f2c does this.  */
1737
1738 static tree
1739 ffecom_build_f2c_string_ (int i, const char *s)
1740 {
1741   if (!ffe_is_f2c_library ())
1742     return build_string (i, s);
1743
1744   {
1745     char *tmp;
1746     const char *p;
1747     char *q;
1748     char space[34];
1749     tree t;
1750
1751     if (((size_t) i) > ARRAY_SIZE (space))
1752       tmp = malloc_new_ks (malloc_pool_image (), "f2c_string", i);
1753     else
1754       tmp = &space[0];
1755
1756     for (p = s, q = tmp; *p != '\0'; ++p, ++q)
1757       *q = TOUPPER (*p);
1758     *q = '\0';
1759
1760     t = build_string (i, tmp);
1761
1762     if (((size_t) i) > ARRAY_SIZE (space))
1763       malloc_kill_ks (malloc_pool_image (), tmp, i);
1764
1765     return t;
1766   }
1767 }
1768
1769 /* Returns CALL_EXPR or equivalent with given type (pass NULL_TREE for
1770    type to just get whatever the function returns), handling the
1771    f2c value-returning convention, if required, by prepending
1772    to the arglist a pointer to a temporary to receive the return value.  */
1773
1774 static tree
1775 ffecom_call_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1776               tree type, tree args, tree dest_tree,
1777               ffebld dest, bool *dest_used, tree callee_commons,
1778               bool scalar_args, tree hook)
1779 {
1780   tree item;
1781   tree tempvar;
1782
1783   if (dest_used != NULL)
1784     *dest_used = FALSE;
1785
1786   if (is_f2c_complex)
1787     {
1788       if ((dest_used == NULL)
1789           || (dest == NULL)
1790           || (ffeinfo_basictype (ffebld_info (dest))
1791               != FFEINFO_basictypeCOMPLEX)
1792           || (ffeinfo_kindtype (ffebld_info (dest)) != kt)
1793           || ((type != NULL_TREE) && (TREE_TYPE (dest_tree) != type))
1794           || ffecom_args_overlapping_ (dest_tree, dest, args,
1795                                        callee_commons,
1796                                        scalar_args))
1797         {
1798 #ifdef HOHO
1799           tempvar = ffecom_make_tempvar (ffecom_tree_type
1800                                          [FFEINFO_basictypeCOMPLEX][kt],
1801                                          FFETARGET_charactersizeNONE,
1802                                          -1);
1803 #else
1804           tempvar = hook;
1805           assert (tempvar);
1806 #endif
1807         }
1808       else
1809         {
1810           *dest_used = TRUE;
1811           tempvar = dest_tree;
1812           type = NULL_TREE;
1813         }
1814
1815       item
1816         = build_tree_list (NULL_TREE,
1817                            ffecom_1 (ADDR_EXPR,
1818                                      build_pointer_type (TREE_TYPE (tempvar)),
1819                                      tempvar));
1820       TREE_CHAIN (item) = args;
1821
1822       item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1823                         item, NULL_TREE);
1824
1825       if (tempvar != dest_tree)
1826         item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item, tempvar);
1827     }
1828   else
1829     item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1830                       args, NULL_TREE);
1831
1832   if ((type != NULL_TREE) && (TREE_TYPE (item) != type))
1833     item = ffecom_convert_narrow_ (type, item);
1834
1835   return item;
1836 }
1837
1838 /* Given two arguments, transform them and make a call to the given
1839    function via ffecom_call_.  */
1840
1841 static tree
1842 ffecom_call_binop_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1843                     tree type, ffebld left, ffebld right,
1844                     tree dest_tree, ffebld dest, bool *dest_used,
1845                     tree callee_commons, bool scalar_args, bool ref, tree hook)
1846 {
1847   tree left_tree;
1848   tree right_tree;
1849   tree left_length;
1850   tree right_length;
1851
1852   if (ref)
1853     {
1854       /* Pass arguments by reference.  */
1855       left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
1856       right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
1857     }
1858   else
1859     {
1860       /* Pass arguments by value.  */
1861       left_tree = ffecom_arg_expr (left, &left_length);
1862       right_tree = ffecom_arg_expr (right, &right_length);
1863     }
1864
1865
1866   left_tree = build_tree_list (NULL_TREE, left_tree);
1867   right_tree = build_tree_list (NULL_TREE, right_tree);
1868   TREE_CHAIN (left_tree) = right_tree;
1869
1870   if (left_length != NULL_TREE)
1871     {
1872       left_length = build_tree_list (NULL_TREE, left_length);
1873       TREE_CHAIN (right_tree) = left_length;
1874     }
1875
1876   if (right_length != NULL_TREE)
1877     {
1878       right_length = build_tree_list (NULL_TREE, right_length);
1879       if (left_length != NULL_TREE)
1880         TREE_CHAIN (left_length) = right_length;
1881       else
1882         TREE_CHAIN (right_tree) = right_length;
1883     }
1884
1885   return ffecom_call_ (fn, kt, is_f2c_complex, type, left_tree,
1886                        dest_tree, dest, dest_used, callee_commons,
1887                        scalar_args, hook);
1888 }
1889
1890 /* Return ptr/length args for char subexpression
1891
1892    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
1893    subexpressions by constructing the appropriate trees for the ptr-to-
1894    character-text and length-of-character-text arguments in a calling
1895    sequence.
1896
1897    Note that if with_null is TRUE, and the expression is an opCONTER,
1898    a null byte is appended to the string.  */
1899
1900 static void
1901 ffecom_char_args_x_ (tree *xitem, tree *length, ffebld expr, bool with_null)
1902 {
1903   tree item;
1904   tree high;
1905   ffetargetCharacter1 val;
1906   ffetargetCharacterSize newlen;
1907
1908   switch (ffebld_op (expr))
1909     {
1910     case FFEBLD_opCONTER:
1911       val = ffebld_constant_character1 (ffebld_conter (expr));
1912       newlen = ffetarget_length_character1 (val);
1913       if (with_null)
1914         {
1915           /* Begin FFETARGET-NULL-KLUDGE.  */
1916           if (newlen != 0)
1917             ++newlen;
1918         }
1919       *length = build_int_2 (newlen, 0);
1920       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
1921       high = build_int_2 (newlen, 0);
1922       TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
1923       item = build_string (newlen,
1924                            ffetarget_text_character1 (val));
1925       /* End FFETARGET-NULL-KLUDGE.  */
1926       TREE_TYPE (item)
1927         = build_type_variant
1928           (build_array_type
1929            (char_type_node,
1930             build_range_type
1931             (ffecom_f2c_ftnlen_type_node,
1932              ffecom_f2c_ftnlen_one_node,
1933              high)),
1934            1, 0);
1935       TREE_CONSTANT (item) = 1;
1936       TREE_STATIC (item) = 1;
1937       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
1938                        item);
1939       break;
1940
1941     case FFEBLD_opSYMTER:
1942       {
1943         ffesymbol s = ffebld_symter (expr);
1944
1945         item = ffesymbol_hook (s).decl_tree;
1946         if (item == NULL_TREE)
1947           {
1948             s = ffecom_sym_transform_ (s);
1949             item = ffesymbol_hook (s).decl_tree;
1950           }
1951         if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
1952           {
1953             if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
1954               *length = ffesymbol_hook (s).length_tree;
1955             else
1956               {
1957                 *length = build_int_2 (ffesymbol_size (s), 0);
1958                 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
1959               }
1960           }
1961         else if (item == error_mark_node)
1962           *length = error_mark_node;
1963         else
1964           /* FFEINFO_kindFUNCTION.  */
1965           *length = NULL_TREE;
1966         if (!ffesymbol_hook (s).addr
1967             && (item != error_mark_node))
1968           item = ffecom_1 (ADDR_EXPR,
1969                            build_pointer_type (TREE_TYPE (item)),
1970                            item);
1971       }
1972       break;
1973
1974     case FFEBLD_opARRAYREF:
1975       {
1976         ffecom_char_args_ (&item, length, ffebld_left (expr));
1977
1978         if (item == error_mark_node || *length == error_mark_node)
1979           {
1980             item = *length = error_mark_node;
1981             break;
1982           }
1983
1984         item = ffecom_arrayref_ (item, expr, 1);
1985       }
1986       break;
1987
1988     case FFEBLD_opSUBSTR:
1989       {
1990         ffebld start;
1991         ffebld end;
1992         ffebld thing = ffebld_right (expr);
1993         tree start_tree;
1994         tree end_tree;
1995         const char *char_name;
1996         ffebld left_symter;
1997         tree array;
1998
1999         assert (ffebld_op (thing) == FFEBLD_opITEM);
2000         start = ffebld_head (thing);
2001         thing = ffebld_trail (thing);
2002         assert (ffebld_trail (thing) == NULL);
2003         end = ffebld_head (thing);
2004
2005         /* Determine name for pretty-printing range-check errors.  */
2006         for (left_symter = ffebld_left (expr);
2007              left_symter && ffebld_op (left_symter) == FFEBLD_opARRAYREF;
2008              left_symter = ffebld_left (left_symter))
2009           ;
2010         if (ffebld_op (left_symter) == FFEBLD_opSYMTER)
2011           char_name = ffesymbol_text (ffebld_symter (left_symter));
2012         else
2013           char_name = "[expr?]";
2014
2015         ffecom_char_args_ (&item, length, ffebld_left (expr));
2016
2017         if (item == error_mark_node || *length == error_mark_node)
2018           {
2019             item = *length = error_mark_node;
2020             break;
2021           }
2022
2023         array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
2024
2025         /* ~~~~Handle INTEGER*8 start/end, a la FFEBLD_opARRAYREF.  */
2026
2027         if (start == NULL)
2028           {
2029             if (end == NULL)
2030               ;
2031             else
2032               {
2033                 end_tree = ffecom_expr (end);
2034                 if (flag_bounds_check)
2035                   end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2036                                                       char_name);
2037                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2038                                     end_tree);
2039
2040                 if (end_tree == error_mark_node)
2041                   {
2042                     item = *length = error_mark_node;
2043                     break;
2044                   }
2045
2046                 *length = end_tree;
2047               }
2048           }
2049         else
2050           {
2051             start_tree = ffecom_expr (start);
2052             if (flag_bounds_check)
2053               start_tree = ffecom_subscript_check_ (array, start_tree, 0, 0,
2054                                                     char_name);
2055             start_tree = convert (ffecom_f2c_ftnlen_type_node,
2056                                   start_tree);
2057
2058             if (start_tree == error_mark_node)
2059               {
2060                 item = *length = error_mark_node;
2061                 break;
2062               }
2063
2064             start_tree = ffecom_save_tree (start_tree);
2065
2066             item = ffecom_2 (PLUS_EXPR, TREE_TYPE (item),
2067                              item,
2068                              ffecom_2 (MINUS_EXPR,
2069                                        TREE_TYPE (start_tree),
2070                                        start_tree,
2071                                        ffecom_f2c_ftnlen_one_node));
2072
2073             if (end == NULL)
2074               {
2075                 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2076                                     ffecom_f2c_ftnlen_one_node,
2077                                     ffecom_2 (MINUS_EXPR,
2078                                               ffecom_f2c_ftnlen_type_node,
2079                                               *length,
2080                                               start_tree));
2081               }
2082             else
2083               {
2084                 end_tree = ffecom_expr (end);
2085                 if (flag_bounds_check)
2086                   end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2087                                                       char_name);
2088                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2089                                     end_tree);
2090
2091                 if (end_tree == error_mark_node)
2092                   {
2093                     item = *length = error_mark_node;
2094                     break;
2095                   }
2096
2097                 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2098                                     ffecom_f2c_ftnlen_one_node,
2099                                     ffecom_2 (MINUS_EXPR,
2100                                               ffecom_f2c_ftnlen_type_node,
2101                                               end_tree, start_tree));
2102               }
2103           }
2104       }
2105       break;
2106
2107     case FFEBLD_opFUNCREF:
2108       {
2109         ffesymbol s = ffebld_symter (ffebld_left (expr));
2110         tree tempvar;
2111         tree args;
2112         ffetargetCharacterSize size = ffeinfo_size (ffebld_info (expr));
2113         ffecomGfrt ix;
2114
2115         if (size == FFETARGET_charactersizeNONE)
2116           /* ~~Kludge alert!  This should someday be fixed. */
2117           size = 24;
2118
2119         *length = build_int_2 (size, 0);
2120         TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2121
2122         if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
2123             == FFEINFO_whereINTRINSIC)
2124           {
2125             if (size == 1)
2126               {
2127                 /* Invocation of an intrinsic returning CHARACTER*1.  */
2128                 item = ffecom_expr_intrinsic_ (expr, NULL_TREE,
2129                                                NULL, NULL);
2130                 break;
2131               }
2132             ix = ffeintrin_gfrt_direct (ffebld_symter_implementation (ffebld_left (expr)));
2133             assert (ix != FFECOM_gfrt);
2134             item = ffecom_gfrt_tree_ (ix);
2135           }
2136         else
2137           {
2138             ix = FFECOM_gfrt;
2139             item = ffesymbol_hook (s).decl_tree;
2140             if (item == NULL_TREE)
2141               {
2142                 s = ffecom_sym_transform_ (s);
2143                 item = ffesymbol_hook (s).decl_tree;
2144               }
2145             if (item == error_mark_node)
2146               {
2147                 item = *length = error_mark_node;
2148                 break;
2149               }
2150
2151             if (!ffesymbol_hook (s).addr)
2152               item = ffecom_1_fn (item);
2153           }
2154
2155 #ifdef HOHO
2156         tempvar = ffecom_push_tempvar (char_type_node, size, -1, TRUE);
2157 #else
2158         tempvar = ffebld_nonter_hook (expr);
2159         assert (tempvar);
2160 #endif
2161         tempvar = ffecom_1 (ADDR_EXPR,
2162                             build_pointer_type (TREE_TYPE (tempvar)),
2163                             tempvar);
2164
2165         args = build_tree_list (NULL_TREE, tempvar);
2166
2167         if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)       /* Sfunc args by value. */
2168           TREE_CHAIN (args) = ffecom_list_expr (ffebld_right (expr));
2169         else
2170           {
2171             TREE_CHAIN (args) = build_tree_list (NULL_TREE, *length);
2172             if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
2173               {
2174                 TREE_CHAIN (TREE_CHAIN (args))
2175                   = ffecom_arglist_expr_ (ffecom_gfrt_args_ (ix),
2176                                           ffebld_right (expr));
2177               }
2178             else
2179               {
2180                 TREE_CHAIN (TREE_CHAIN (args))
2181                   = ffecom_list_ptr_to_expr (ffebld_right (expr));
2182               }
2183           }
2184
2185         item = ffecom_3s (CALL_EXPR,
2186                           TREE_TYPE (TREE_TYPE (TREE_TYPE (item))),
2187                           item, args, NULL_TREE);
2188         item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item,
2189                          tempvar);
2190       }
2191       break;
2192
2193     case FFEBLD_opCONVERT:
2194
2195       ffecom_char_args_ (&item, length, ffebld_left (expr));
2196
2197       if (item == error_mark_node || *length == error_mark_node)
2198         {
2199           item = *length = error_mark_node;
2200           break;
2201         }
2202
2203       if ((ffebld_size_known (ffebld_left (expr))
2204            == FFETARGET_charactersizeNONE)
2205           || (ffebld_size_known (ffebld_left (expr)) < (ffebld_size (expr))))
2206         {                       /* Possible blank-padding needed, copy into
2207                                    temporary. */
2208           tree tempvar;
2209           tree args;
2210           tree newlen;
2211
2212 #ifdef HOHO
2213           tempvar = ffecom_make_tempvar (char_type_node,
2214                                          ffebld_size (expr), -1);
2215 #else
2216           tempvar = ffebld_nonter_hook (expr);
2217           assert (tempvar);
2218 #endif
2219           tempvar = ffecom_1 (ADDR_EXPR,
2220                               build_pointer_type (TREE_TYPE (tempvar)),
2221                               tempvar);
2222
2223           newlen = build_int_2 (ffebld_size (expr), 0);
2224           TREE_TYPE (newlen) = ffecom_f2c_ftnlen_type_node;
2225
2226           args = build_tree_list (NULL_TREE, tempvar);
2227           TREE_CHAIN (args) = build_tree_list (NULL_TREE, item);
2228           TREE_CHAIN (TREE_CHAIN (args)) = build_tree_list (NULL_TREE, newlen);
2229           TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (args)))
2230             = build_tree_list (NULL_TREE, *length);
2231
2232           item = ffecom_call_gfrt (FFECOM_gfrtCOPY, args, NULL_TREE);
2233           TREE_SIDE_EFFECTS (item) = 1;
2234           item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), fold (item),
2235                            tempvar);
2236           *length = newlen;
2237         }
2238       else
2239         {                       /* Just truncate the length. */
2240           *length = build_int_2 (ffebld_size (expr), 0);
2241           TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2242         }
2243       break;
2244
2245     default:
2246       assert ("bad op for single char arg expr" == NULL);
2247       item = NULL_TREE;
2248       break;
2249     }
2250
2251   *xitem = item;
2252 }
2253
2254 /* Check the size of the type to be sure it doesn't overflow the
2255    "portable" capacities of the compiler back end.  `dummy' types
2256    can generally overflow the normal sizes as long as the computations
2257    themselves don't overflow.  A particular target of the back end
2258    must still enforce its size requirements, though, and the back
2259    end takes care of this in stor-layout.c.  */
2260
2261 static tree
2262 ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy)
2263 {
2264   if (TREE_CODE (type) == ERROR_MARK)
2265     return type;
2266
2267   if (TYPE_SIZE (type) == NULL_TREE)
2268     return type;
2269
2270   if (TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST)
2271     return type;
2272
2273   /* An array is too large if size is negative or the type_size overflows
2274      or its "upper half" is larger than 3 (which would make the signed
2275      byte size and offset computations overflow).  */
2276
2277   if ((tree_int_cst_sgn (TYPE_SIZE (type)) < 0)
2278       || (!dummy && (TREE_INT_CST_HIGH (TYPE_SIZE (type)) > 3
2279                      || TREE_OVERFLOW (TYPE_SIZE (type)))))
2280     {
2281       ffebad_start (FFEBAD_ARRAY_LARGE);
2282       ffebad_string (ffesymbol_text (s));
2283       ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s));
2284       ffebad_finish ();
2285
2286       return error_mark_node;
2287     }
2288
2289   return type;
2290 }
2291
2292 /* Builds a length argument (PARM_DECL).  Also wraps type in an array type
2293    where the dimension info is (1:size) where <size> is ffesymbol_size(s) if
2294    known, length_arg if not known (FFETARGET_charactersizeNONE).  */
2295
2296 static tree
2297 ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s)
2298 {
2299   ffetargetCharacterSize sz = ffesymbol_size (s);
2300   tree highval;
2301   tree tlen;
2302   tree type = *xtype;
2303
2304   if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
2305     tlen = NULL_TREE;           /* A statement function, no length passed. */
2306   else
2307     {
2308       if (ffesymbol_where (s) == FFEINFO_whereDUMMY)
2309         tlen = ffecom_get_invented_identifier ("__g77_length_%s",
2310                                                ffesymbol_text (s));
2311       else
2312         tlen = ffecom_get_invented_identifier ("__g77_%s", "length");
2313       tlen = build_decl (PARM_DECL, tlen, ffecom_f2c_ftnlen_type_node);
2314       DECL_ARTIFICIAL (tlen) = 1;
2315     }
2316
2317   if (sz == FFETARGET_charactersizeNONE)
2318     {
2319       assert (tlen != NULL_TREE);
2320       highval = variable_size (tlen);
2321     }
2322   else
2323     {
2324       highval = build_int_2 (sz, 0);
2325       TREE_TYPE (highval) = ffecom_f2c_ftnlen_type_node;
2326     }
2327
2328   type = build_array_type (type,
2329                            build_range_type (ffecom_f2c_ftnlen_type_node,
2330                                              ffecom_f2c_ftnlen_one_node,
2331                                              highval));
2332
2333   *xtype = type;
2334   return tlen;
2335 }
2336
2337 /* ffecom_concat_list_gather_ -- Gather list of concatenated string exprs
2338
2339    ffecomConcatList_ catlist;
2340    ffebld expr;  // expr of CHARACTER basictype.
2341    ffetargetCharacterSize max;  // max chars to gather or _...NONE if no max
2342    catlist = ffecom_concat_list_gather_(catlist,expr,max);
2343
2344    Scans expr for character subexpressions, updates and returns catlist
2345    accordingly.  */
2346
2347 static ffecomConcatList_
2348 ffecom_concat_list_gather_ (ffecomConcatList_ catlist, ffebld expr,
2349                             ffetargetCharacterSize max)
2350 {
2351   ffetargetCharacterSize sz;
2352
2353  recurse:
2354
2355   if (expr == NULL)
2356     return catlist;
2357
2358   if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen >= max))
2359     return catlist;             /* Don't append any more items. */
2360
2361   switch (ffebld_op (expr))
2362     {
2363     case FFEBLD_opCONTER:
2364     case FFEBLD_opSYMTER:
2365     case FFEBLD_opARRAYREF:
2366     case FFEBLD_opFUNCREF:
2367     case FFEBLD_opSUBSTR:
2368     case FFEBLD_opCONVERT:      /* Callers should strip this off beforehand
2369                                    if they don't need to preserve it. */
2370       if (catlist.count == catlist.max)
2371         {                       /* Make a (larger) list. */
2372           ffebld *newx;
2373           int newmax;
2374
2375           newmax = (catlist.max == 0) ? 8 : catlist.max * 2;
2376           newx = malloc_new_ks (malloc_pool_image (), "catlist",
2377                                 newmax * sizeof (newx[0]));
2378           if (catlist.max != 0)
2379             {
2380               memcpy (newx, catlist.exprs, catlist.max * sizeof (newx[0]));
2381               malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2382                               catlist.max * sizeof (newx[0]));
2383             }
2384           catlist.max = newmax;
2385           catlist.exprs = newx;
2386         }
2387       if ((sz = ffebld_size_known (expr)) != FFETARGET_charactersizeNONE)
2388         catlist.minlen += sz;
2389       else
2390         ++catlist.minlen;       /* Not true for F90; can be 0 length. */
2391       if ((sz = ffebld_size_max (expr)) == FFETARGET_charactersizeNONE)
2392         catlist.maxlen = sz;
2393       else
2394         catlist.maxlen += sz;
2395       if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen > max))
2396         {                       /* This item overlaps (or is beyond) the end
2397                                    of the destination. */
2398           switch (ffebld_op (expr))
2399             {
2400             case FFEBLD_opCONTER:
2401             case FFEBLD_opSYMTER:
2402             case FFEBLD_opARRAYREF:
2403             case FFEBLD_opFUNCREF:
2404             case FFEBLD_opSUBSTR:
2405               /* ~~Do useful truncations here. */
2406               break;
2407
2408             default:
2409               assert ("op changed or inconsistent switches!" == NULL);
2410               break;
2411             }
2412         }
2413       catlist.exprs[catlist.count++] = expr;
2414       return catlist;
2415
2416     case FFEBLD_opPAREN:
2417       expr = ffebld_left (expr);
2418       goto recurse;             /* :::::::::::::::::::: */
2419
2420     case FFEBLD_opCONCATENATE:
2421       catlist = ffecom_concat_list_gather_ (catlist, ffebld_left (expr), max);
2422       expr = ffebld_right (expr);
2423       goto recurse;             /* :::::::::::::::::::: */
2424
2425 #if 0                           /* Breaks passing small actual arg to larger
2426                                    dummy arg of sfunc */
2427     case FFEBLD_opCONVERT:
2428       expr = ffebld_left (expr);
2429       {
2430         ffetargetCharacterSize cmax;
2431
2432         cmax = catlist.len + ffebld_size_known (expr);
2433
2434         if ((max == FFETARGET_charactersizeNONE) || (max > cmax))
2435           max = cmax;
2436       }
2437       goto recurse;             /* :::::::::::::::::::: */
2438 #endif
2439
2440     case FFEBLD_opANY:
2441       return catlist;
2442
2443     default:
2444       assert ("bad op in _gather_" == NULL);
2445       return catlist;
2446     }
2447 }
2448
2449 /* ffecom_concat_list_kill_ -- Kill list of concatenated string exprs
2450
2451    ffecomConcatList_ catlist;
2452    ffecom_concat_list_kill_(catlist);
2453
2454    Anything allocated within the list info is deallocated.  */
2455
2456 static void
2457 ffecom_concat_list_kill_ (ffecomConcatList_ catlist)
2458 {
2459   if (catlist.max != 0)
2460     malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2461                     catlist.max * sizeof (catlist.exprs[0]));
2462 }
2463
2464 /* Make list of concatenated string exprs.
2465
2466    Returns a flattened list of concatenated subexpressions given a
2467    tree of such expressions.  */
2468
2469 static ffecomConcatList_
2470 ffecom_concat_list_new_ (ffebld expr, ffetargetCharacterSize max)
2471 {
2472   ffecomConcatList_ catlist;
2473
2474   catlist.maxlen = catlist.minlen = catlist.max = catlist.count = 0;
2475   return ffecom_concat_list_gather_ (catlist, expr, max);
2476 }
2477
2478 /* Provide some kind of useful info on member of aggregate area,
2479    since current g77/gcc technology does not provide debug info
2480    on these members.  */
2481
2482 static void
2483 ffecom_debug_kludge_ (tree aggr, const char *aggr_type, ffesymbol member,
2484                       tree member_type UNUSED, ffetargetOffset offset)
2485 {
2486   tree value;
2487   tree decl;
2488   int len;
2489   char *buff;
2490   char space[120];
2491 #if 0
2492   tree type_id;
2493
2494   for (type_id = member_type;
2495        TREE_CODE (type_id) != IDENTIFIER_NODE;
2496        )
2497     {
2498       switch (TREE_CODE (type_id))
2499         {
2500         case INTEGER_TYPE:
2501         case REAL_TYPE:
2502           type_id = TYPE_NAME (type_id);
2503           break;
2504
2505         case ARRAY_TYPE:
2506         case COMPLEX_TYPE:
2507           type_id = TREE_TYPE (type_id);
2508           break;
2509
2510         default:
2511           assert ("no IDENTIFIER_NODE for type!" == NULL);
2512           type_id = error_mark_node;
2513           break;
2514         }
2515     }
2516 #endif
2517
2518   if (ffecom_transform_only_dummies_
2519       || !ffe_is_debug_kludge ())
2520     return;     /* Can't do this yet, maybe later. */
2521
2522   len = 60
2523     + strlen (aggr_type)
2524     + IDENTIFIER_LENGTH (DECL_NAME (aggr));
2525 #if 0
2526     + IDENTIFIER_LENGTH (type_id);
2527 #endif
2528
2529   if (((size_t) len) >= ARRAY_SIZE (space))
2530     buff = malloc_new_ks (malloc_pool_image (), "debug_kludge", len + 1);
2531   else
2532     buff = &space[0];
2533
2534   sprintf (&buff[0], "At (%s) `%s' plus %ld bytes",
2535            aggr_type,
2536            IDENTIFIER_POINTER (DECL_NAME (aggr)),
2537            (long int) offset);
2538
2539   value = build_string (len, buff);
2540   TREE_TYPE (value)
2541     = build_type_variant (build_array_type (char_type_node,
2542                                             build_range_type
2543                                             (integer_type_node,
2544                                              integer_one_node,
2545                                              build_int_2 (strlen (buff), 0))),
2546                           1, 0);
2547   decl = build_decl (VAR_DECL,
2548                      ffecom_get_identifier_ (ffesymbol_text (member)),
2549                      TREE_TYPE (value));
2550   TREE_CONSTANT (decl) = 1;
2551   TREE_STATIC (decl) = 1;
2552   DECL_INITIAL (decl) = error_mark_node;
2553   DECL_IN_SYSTEM_HEADER (decl) = 1;     /* Don't let -Wunused complain. */
2554   decl = start_decl (decl, FALSE);
2555   finish_decl (decl, value, FALSE);
2556
2557   if (buff != &space[0])
2558     malloc_kill_ks (malloc_pool_image (), buff, len + 1);
2559 }
2560
2561 /* ffecom_do_entry_ -- Do compilation of a particular entrypoint
2562
2563    ffesymbol fn;  // the SUBROUTINE, FUNCTION, or ENTRY symbol itself
2564    int i;  // entry# for this entrypoint (used by master fn)
2565    ffecom_do_entrypoint_(s,i);
2566
2567    Makes a public entry point that calls our private master fn (already
2568    compiled).  */
2569
2570 static void
2571 ffecom_do_entry_ (ffesymbol fn, int entrynum)
2572 {
2573   ffebld item;
2574   tree type;                    /* Type of function. */
2575   tree multi_retval;            /* Var holding return value (union). */
2576   tree result;                  /* Var holding result. */
2577   ffeinfoBasictype bt;
2578   ffeinfoKindtype kt;
2579   ffeglobal g;
2580   ffeglobalType gt;
2581   bool charfunc;                /* All entry points return same type
2582                                    CHARACTER. */
2583   bool cmplxfunc;               /* Use f2c way of returning COMPLEX. */
2584   bool multi;                   /* Master fn has multiple return types. */
2585   bool altreturning = FALSE;    /* This entry point has alternate returns. */
2586   int old_lineno = lineno;
2587   const char *old_input_filename = input_filename;
2588
2589   input_filename = ffesymbol_where_filename (fn);
2590   lineno = ffesymbol_where_filelinenum (fn);
2591
2592   ffecom_doing_entry_ = TRUE;   /* Don't bother with array dimensions. */
2593
2594   switch (ffecom_primary_entry_kind_)
2595     {
2596     case FFEINFO_kindFUNCTION:
2597
2598       /* Determine actual return type for function. */
2599
2600       gt = FFEGLOBAL_typeFUNC;
2601       bt = ffesymbol_basictype (fn);
2602       kt = ffesymbol_kindtype (fn);
2603       if (bt == FFEINFO_basictypeNONE)
2604         {
2605           ffeimplic_establish_symbol (fn);
2606           if (ffesymbol_funcresult (fn) != NULL)
2607             ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
2608           bt = ffesymbol_basictype (fn);
2609           kt = ffesymbol_kindtype (fn);
2610         }
2611
2612       if (bt == FFEINFO_basictypeCHARACTER)
2613         charfunc = TRUE, cmplxfunc = FALSE;
2614       else if ((bt == FFEINFO_basictypeCOMPLEX)
2615                && ffesymbol_is_f2c (fn))
2616         charfunc = FALSE, cmplxfunc = TRUE;
2617       else
2618         charfunc = cmplxfunc = FALSE;
2619
2620       if (charfunc)
2621         type = ffecom_tree_fun_type_void;
2622       else if (ffesymbol_is_f2c (fn))
2623         type = ffecom_tree_fun_type[bt][kt];
2624       else
2625         type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
2626
2627       if ((type == NULL_TREE)
2628           || (TREE_TYPE (type) == NULL_TREE))
2629         type = ffecom_tree_fun_type_void;       /* _sym_exec_transition. */
2630
2631       multi = (ffecom_master_bt_ == FFEINFO_basictypeNONE);
2632       break;
2633
2634     case FFEINFO_kindSUBROUTINE:
2635       gt = FFEGLOBAL_typeSUBR;
2636       bt = FFEINFO_basictypeNONE;
2637       kt = FFEINFO_kindtypeNONE;
2638       if (ffecom_is_altreturning_)
2639         {                       /* Am _I_ altreturning? */
2640           for (item = ffesymbol_dummyargs (fn);
2641                item != NULL;
2642                item = ffebld_trail (item))
2643             {
2644               if (ffebld_op (ffebld_head (item)) == FFEBLD_opSTAR)
2645                 {
2646                   altreturning = TRUE;
2647                   break;
2648                 }
2649             }
2650           if (altreturning)
2651             type = ffecom_tree_subr_type;
2652           else
2653             type = ffecom_tree_fun_type_void;
2654         }
2655       else
2656         type = ffecom_tree_fun_type_void;
2657       charfunc = FALSE;
2658       cmplxfunc = FALSE;
2659       multi = FALSE;
2660       break;
2661
2662     default:
2663       assert ("say what??" == NULL);
2664       /* Fall through. */
2665     case FFEINFO_kindANY:
2666       gt = FFEGLOBAL_typeANY;
2667       bt = FFEINFO_basictypeNONE;
2668       kt = FFEINFO_kindtypeNONE;
2669       type = error_mark_node;
2670       charfunc = FALSE;
2671       cmplxfunc = FALSE;
2672       multi = FALSE;
2673       break;
2674     }
2675
2676   /* build_decl uses the current lineno and input_filename to set the decl
2677      source info.  So, I've putzed with ffestd and ffeste code to update that
2678      source info to point to the appropriate statement just before calling
2679      ffecom_do_entrypoint (which calls this fn).  */
2680
2681   start_function (ffecom_get_external_identifier_ (fn),
2682                   type,
2683                   0,            /* nested/inline */
2684                   1);           /* TREE_PUBLIC */
2685
2686   if (((g = ffesymbol_global (fn)) != NULL)
2687       && ((ffeglobal_type (g) == gt)
2688           || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
2689     {
2690       ffeglobal_set_hook (g, current_function_decl);
2691     }
2692
2693   /* Reset args in master arg list so they get retransitioned. */
2694
2695   for (item = ffecom_master_arglist_;
2696        item != NULL;
2697        item = ffebld_trail (item))
2698     {
2699       ffebld arg;
2700       ffesymbol s;
2701
2702       arg = ffebld_head (item);
2703       if (ffebld_op (arg) != FFEBLD_opSYMTER)
2704         continue;               /* Alternate return or some such thing. */
2705       s = ffebld_symter (arg);
2706       ffesymbol_hook (s).decl_tree = NULL_TREE;
2707       ffesymbol_hook (s).length_tree = NULL_TREE;
2708     }
2709
2710   /* Build dummy arg list for this entry point. */
2711
2712   if (charfunc || cmplxfunc)
2713     {                           /* Prepend arg for where result goes. */
2714       tree type;
2715       tree length;
2716
2717       if (charfunc)
2718         type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
2719       else
2720         type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
2721
2722       result = ffecom_get_invented_identifier ("__g77_%s", "result");
2723
2724       /* Make length arg _and_ enhance type info for CHAR arg itself.  */
2725
2726       if (charfunc)
2727         length = ffecom_char_enhance_arg_ (&type, fn);
2728       else
2729         length = NULL_TREE;     /* Not ref'd if !charfunc. */
2730
2731       type = build_pointer_type (type);
2732       result = build_decl (PARM_DECL, result, type);
2733
2734       push_parm_decl (result);
2735       ffecom_func_result_ = result;
2736
2737       if (charfunc)
2738         {
2739           push_parm_decl (length);
2740           ffecom_func_length_ = length;
2741         }
2742     }
2743   else
2744     result = DECL_RESULT (current_function_decl);
2745
2746   ffecom_push_dummy_decls_ (ffesymbol_dummyargs (fn), FALSE);
2747
2748   store_parm_decls (0);
2749
2750   ffecom_start_compstmt ();
2751   /* Disallow temp vars at this level.  */
2752   current_binding_level->prep_state = 2;
2753
2754   /* Make local var to hold return type for multi-type master fn. */
2755
2756   if (multi)
2757     {
2758       multi_retval = ffecom_get_invented_identifier ("__g77_%s",
2759                                                      "multi_retval");
2760       multi_retval = build_decl (VAR_DECL, multi_retval,
2761                                  ffecom_multi_type_node_);
2762       multi_retval = start_decl (multi_retval, FALSE);
2763       finish_decl (multi_retval, NULL_TREE, FALSE);
2764     }
2765   else
2766     multi_retval = NULL_TREE;   /* Not actually ref'd if !multi. */
2767
2768   /* Here we emit the actual code for the entry point. */
2769
2770   {
2771     ffebld list;
2772     ffebld arg;
2773     ffesymbol s;
2774     tree arglist = NULL_TREE;
2775     tree *plist = &arglist;
2776     tree prepend;
2777     tree call;
2778     tree actarg;
2779     tree master_fn;
2780
2781     /* Prepare actual arg list based on master arg list. */
2782
2783     for (list = ffecom_master_arglist_;
2784          list != NULL;
2785          list = ffebld_trail (list))
2786       {
2787         arg = ffebld_head (list);
2788         if (ffebld_op (arg) != FFEBLD_opSYMTER)
2789           continue;
2790         s = ffebld_symter (arg);
2791         if (ffesymbol_hook (s).decl_tree == NULL_TREE
2792             || ffesymbol_hook (s).decl_tree == error_mark_node)
2793           actarg = null_pointer_node;   /* We don't have this arg. */
2794         else
2795           actarg = ffesymbol_hook (s).decl_tree;
2796         *plist = build_tree_list (NULL_TREE, actarg);
2797         plist = &TREE_CHAIN (*plist);
2798       }
2799
2800     /* This code appends the length arguments for character
2801        variables/arrays.  */
2802
2803     for (list = ffecom_master_arglist_;
2804          list != NULL;
2805          list = ffebld_trail (list))
2806       {
2807         arg = ffebld_head (list);
2808         if (ffebld_op (arg) != FFEBLD_opSYMTER)
2809           continue;
2810         s = ffebld_symter (arg);
2811         if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
2812           continue;             /* Only looking for CHARACTER arguments. */
2813         if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
2814           continue;             /* Only looking for variables and arrays. */
2815         if (ffesymbol_hook (s).length_tree == NULL_TREE
2816             || ffesymbol_hook (s).length_tree == error_mark_node)
2817           actarg = ffecom_f2c_ftnlen_zero_node; /* We don't have this arg. */
2818         else
2819           actarg = ffesymbol_hook (s).length_tree;
2820         *plist = build_tree_list (NULL_TREE, actarg);
2821         plist = &TREE_CHAIN (*plist);
2822       }
2823
2824     /* Prepend character-value return info to actual arg list. */
2825
2826     if (charfunc)
2827       {
2828         prepend = build_tree_list (NULL_TREE, ffecom_func_result_);
2829         TREE_CHAIN (prepend)
2830           = build_tree_list (NULL_TREE, ffecom_func_length_);
2831         TREE_CHAIN (TREE_CHAIN (prepend)) = arglist;
2832         arglist = prepend;
2833       }
2834
2835     /* Prepend multi-type return value to actual arg list. */
2836
2837     if (multi)
2838       {
2839         prepend
2840           = build_tree_list (NULL_TREE,
2841                              ffecom_1 (ADDR_EXPR,
2842                               build_pointer_type (TREE_TYPE (multi_retval)),
2843                                        multi_retval));
2844         TREE_CHAIN (prepend) = arglist;
2845         arglist = prepend;
2846       }
2847
2848     /* Prepend my entry-point number to the actual arg list. */
2849
2850     prepend = build_tree_list (NULL_TREE, build_int_2 (entrynum, 0));
2851     TREE_CHAIN (prepend) = arglist;
2852     arglist = prepend;
2853
2854     /* Build the call to the master function. */
2855
2856     master_fn = ffecom_1_fn (ffecom_previous_function_decl_);
2857     call = ffecom_3s (CALL_EXPR,
2858                       TREE_TYPE (TREE_TYPE (TREE_TYPE (master_fn))),
2859                       master_fn, arglist, NULL_TREE);
2860
2861     /* Decide whether the master function is a function or subroutine, and
2862        handle the return value for my entry point. */
2863
2864     if (charfunc || ((ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
2865                      && !altreturning))
2866       {
2867         expand_expr_stmt (call);
2868         expand_null_return ();
2869       }
2870     else if (multi && cmplxfunc)
2871       {
2872         expand_expr_stmt (call);
2873         result
2874           = ffecom_1 (INDIRECT_REF,
2875                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
2876                       result);
2877         result = ffecom_modify (NULL_TREE, result,
2878                                 ffecom_2 (COMPONENT_REF, TREE_TYPE (result),
2879                                           multi_retval,
2880                                           ffecom_multi_fields_[bt][kt]));
2881         expand_expr_stmt (result);
2882         expand_null_return ();
2883       }
2884     else if (multi)
2885       {
2886         expand_expr_stmt (call);
2887         result
2888           = ffecom_modify (NULL_TREE, result,
2889                            convert (TREE_TYPE (result),
2890                                     ffecom_2 (COMPONENT_REF,
2891                                               ffecom_tree_type[bt][kt],
2892                                               multi_retval,
2893                                               ffecom_multi_fields_[bt][kt])));
2894         expand_return (result);
2895       }
2896     else if (cmplxfunc)
2897       {
2898         result
2899           = ffecom_1 (INDIRECT_REF,
2900                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
2901                       result);
2902         result = ffecom_modify (NULL_TREE, result, call);
2903         expand_expr_stmt (result);
2904         expand_null_return ();
2905       }
2906     else
2907       {
2908         result = ffecom_modify (NULL_TREE,
2909                                 result,
2910                                 convert (TREE_TYPE (result),
2911                                          call));
2912         expand_return (result);
2913       }
2914   }
2915
2916   ffecom_end_compstmt ();
2917
2918   finish_function (0);
2919
2920   lineno = old_lineno;
2921   input_filename = old_input_filename;
2922
2923   ffecom_doing_entry_ = FALSE;
2924 }
2925
2926 /* Transform expr into gcc tree with possible destination
2927
2928    Recursive descent on expr while making corresponding tree nodes and
2929    attaching type info and such.  If destination supplied and compatible
2930    with temporary that would be made in certain cases, temporary isn't
2931    made, destination used instead, and dest_used flag set TRUE.  */
2932
2933 static tree
2934 ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
2935               bool *dest_used, bool assignp, bool widenp)
2936 {
2937   tree item;
2938   tree list;
2939   tree args;
2940   ffeinfoBasictype bt;
2941   ffeinfoKindtype kt;
2942   tree t;
2943   tree dt;                      /* decl_tree for an ffesymbol. */
2944   tree tree_type, tree_type_x;
2945   tree left, right;
2946   ffesymbol s;
2947   enum tree_code code;
2948
2949   assert (expr != NULL);
2950
2951   if (dest_used != NULL)
2952     *dest_used = FALSE;
2953
2954   bt = ffeinfo_basictype (ffebld_info (expr));
2955   kt = ffeinfo_kindtype (ffebld_info (expr));
2956   tree_type = ffecom_tree_type[bt][kt];
2957
2958   /* Widen integral arithmetic as desired while preserving signedness.  */
2959   tree_type_x = NULL_TREE;
2960   if (widenp && tree_type
2961       && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
2962       && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
2963     tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
2964
2965   switch (ffebld_op (expr))
2966     {
2967     case FFEBLD_opACCTER:
2968       {
2969         ffebitCount i;
2970         ffebit bits = ffebld_accter_bits (expr);
2971         ffetargetOffset source_offset = 0;
2972         ffetargetOffset dest_offset = ffebld_accter_pad (expr);
2973         tree purpose;
2974
2975         assert (dest_offset == 0
2976                 || (bt == FFEINFO_basictypeCHARACTER
2977                     && kt == FFEINFO_kindtypeCHARACTER1));
2978
2979         list = item = NULL;
2980         for (;;)
2981           {
2982             ffebldConstantUnion cu;
2983             ffebitCount length;
2984             bool value;
2985             ffebldConstantArray ca = ffebld_accter (expr);
2986
2987             ffebit_test (bits, source_offset, &value, &length);
2988             if (length == 0)
2989               break;
2990
2991             if (value)
2992               {
2993                 for (i = 0; i < length; ++i)
2994                   {
2995                     cu = ffebld_constantarray_get (ca, bt, kt,
2996                                                    source_offset + i);
2997
2998                     t = ffecom_constantunion (&cu, bt, kt, tree_type);
2999
3000                     if (i == 0
3001                         && dest_offset != 0)
3002                       purpose = build_int_2 (dest_offset, 0);
3003                     else
3004                       purpose = NULL_TREE;
3005
3006                     if (list == NULL_TREE)
3007                       list = item = build_tree_list (purpose, t);
3008                     else
3009                       {
3010                         TREE_CHAIN (item) = build_tree_list (purpose, t);
3011                         item = TREE_CHAIN (item);
3012                       }
3013                   }
3014               }
3015             source_offset += length;
3016             dest_offset += length;
3017           }
3018       }
3019
3020       item = build_int_2 ((ffebld_accter_size (expr)
3021                            + ffebld_accter_pad (expr)) - 1, 0);
3022       ffebit_kill (ffebld_accter_bits (expr));
3023       TREE_TYPE (item) = ffecom_integer_type_node;
3024       item
3025         = build_array_type
3026           (tree_type,
3027            build_range_type (ffecom_integer_type_node,
3028                              ffecom_integer_zero_node,
3029                              item));
3030       list = build (CONSTRUCTOR, item, NULL_TREE, list);
3031       TREE_CONSTANT (list) = 1;
3032       TREE_STATIC (list) = 1;
3033       return list;
3034
3035     case FFEBLD_opARRTER:
3036       {
3037         ffetargetOffset i;
3038
3039         list = NULL_TREE;
3040         if (ffebld_arrter_pad (expr) == 0)
3041           item = NULL_TREE;
3042         else
3043           {
3044             assert (bt == FFEINFO_basictypeCHARACTER
3045                     && kt == FFEINFO_kindtypeCHARACTER1);
3046
3047             /* Becomes PURPOSE first time through loop.  */
3048             item = build_int_2 (ffebld_arrter_pad (expr), 0);
3049           }
3050
3051         for (i = 0; i < ffebld_arrter_size (expr); ++i)
3052           {
3053             ffebldConstantUnion cu
3054             = ffebld_constantarray_get (ffebld_arrter (expr), bt, kt, i);
3055
3056             t = ffecom_constantunion (&cu, bt, kt, tree_type);
3057
3058             if (list == NULL_TREE)
3059               /* Assume item is PURPOSE first time through loop.  */
3060               list = item = build_tree_list (item, t);
3061             else
3062               {
3063                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
3064                 item = TREE_CHAIN (item);
3065               }
3066           }
3067       }
3068
3069       item = build_int_2 ((ffebld_arrter_size (expr)
3070                           + ffebld_arrter_pad (expr)) - 1, 0);
3071       TREE_TYPE (item) = ffecom_integer_type_node;
3072       item
3073         = build_array_type
3074           (tree_type,
3075            build_range_type (ffecom_integer_type_node,
3076                              ffecom_integer_zero_node,
3077                              item));
3078       list = build (CONSTRUCTOR, item, NULL_TREE, list);
3079       TREE_CONSTANT (list) = 1;
3080       TREE_STATIC (list) = 1;
3081       return list;
3082
3083     case FFEBLD_opCONTER:
3084       assert (ffebld_conter_pad (expr) == 0);
3085       item
3086         = ffecom_constantunion (&ffebld_constant_union (ffebld_conter (expr)),
3087                                 bt, kt, tree_type);
3088       return item;
3089
3090     case FFEBLD_opSYMTER:
3091       if ((ffebld_symter_generic (expr) != FFEINTRIN_genNONE)
3092           || (ffebld_symter_specific (expr) != FFEINTRIN_specNONE))
3093         return ffecom_ptr_to_expr (expr);       /* Same as %REF(intrinsic). */
3094       s = ffebld_symter (expr);
3095       t = ffesymbol_hook (s).decl_tree;
3096
3097       if (assignp)
3098         {                       /* ASSIGN'ed-label expr. */
3099           if (ffe_is_ugly_assign ())
3100             {
3101               /* User explicitly wants ASSIGN'ed variables to be at the same
3102                  memory address as the variables when used in non-ASSIGN
3103                  contexts.  That can make old, arcane, non-standard code
3104                  work, but don't try to do it when a pointer wouldn't fit
3105                  in the normal variable (take other approach, and warn,
3106                  instead).  */
3107
3108               if (t == NULL_TREE)
3109                 {
3110                   s = ffecom_sym_transform_ (s);
3111                   t = ffesymbol_hook (s).decl_tree;
3112                   assert (t != NULL_TREE);
3113                 }
3114
3115               if (t == error_mark_node)
3116                 return t;
3117
3118               if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t)))
3119                   >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
3120                 {
3121                   if (ffesymbol_hook (s).addr)
3122                     t = ffecom_1 (INDIRECT_REF,
3123                                   TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3124                   return t;
3125                 }
3126
3127               if (ffesymbol_hook (s).assign_tree == NULL_TREE)
3128                 {
3129                   /* xgettext:no-c-format */
3130                   ffebad_start_msg ("ASSIGN'ed label cannot fit into `%A' at %0 -- using wider sibling",
3131                                     FFEBAD_severityWARNING);
3132                   ffebad_string (ffesymbol_text (s));
3133                   ffebad_here (0, ffesymbol_where_line (s),
3134                                ffesymbol_where_column (s));
3135                   ffebad_finish ();
3136                 }
3137             }
3138
3139           /* Don't use the normal variable's tree for ASSIGN, though mark
3140              it as in the system header (housekeeping).  Use an explicit,
3141              specially created sibling that is known to be wide enough
3142              to hold pointers to labels.  */
3143
3144           if (t != NULL_TREE
3145               && TREE_CODE (t) == VAR_DECL)
3146             DECL_IN_SYSTEM_HEADER (t) = 1;      /* Don't let -Wunused complain. */
3147
3148           t = ffesymbol_hook (s).assign_tree;
3149           if (t == NULL_TREE)
3150             {
3151               s = ffecom_sym_transform_assign_ (s);
3152               t = ffesymbol_hook (s).assign_tree;
3153               assert (t != NULL_TREE);
3154             }
3155         }
3156       else
3157         {
3158           if (t == NULL_TREE)
3159             {
3160               s = ffecom_sym_transform_ (s);
3161               t = ffesymbol_hook (s).decl_tree;
3162               assert (t != NULL_TREE);
3163             }
3164           if (ffesymbol_hook (s).addr)
3165             t = ffecom_1 (INDIRECT_REF,
3166                           TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3167         }
3168       return t;
3169
3170     case FFEBLD_opARRAYREF:
3171       return ffecom_arrayref_ (NULL_TREE, expr, 0);
3172
3173     case FFEBLD_opUPLUS:
3174       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3175       return ffecom_1 (NOP_EXPR, tree_type, left);
3176
3177     case FFEBLD_opPAREN:
3178       /* ~~~Make sure Fortran rules respected here */
3179       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3180       return ffecom_1 (NOP_EXPR, tree_type, left);
3181
3182     case FFEBLD_opUMINUS:
3183       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3184       if (tree_type_x)
3185         {
3186           tree_type = tree_type_x;
3187           left = convert (tree_type, left);
3188         }
3189       return ffecom_1 (NEGATE_EXPR, tree_type, left);
3190
3191     case FFEBLD_opADD:
3192       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3193       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3194       if (tree_type_x)
3195         {
3196           tree_type = tree_type_x;
3197           left = convert (tree_type, left);
3198           right = convert (tree_type, right);
3199         }
3200       return ffecom_2 (PLUS_EXPR, tree_type, left, right);
3201
3202     case FFEBLD_opSUBTRACT:
3203       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3204       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3205       if (tree_type_x)
3206         {
3207           tree_type = tree_type_x;
3208           left = convert (tree_type, left);
3209           right = convert (tree_type, right);
3210         }
3211       return ffecom_2 (MINUS_EXPR, tree_type, left, right);
3212
3213     case FFEBLD_opMULTIPLY:
3214       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3215       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3216       if (tree_type_x)
3217         {
3218           tree_type = tree_type_x;
3219           left = convert (tree_type, left);
3220           right = convert (tree_type, right);
3221         }
3222       return ffecom_2 (MULT_EXPR, tree_type, left, right);
3223
3224     case FFEBLD_opDIVIDE:
3225       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3226       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3227       if (tree_type_x)
3228         {
3229           tree_type = tree_type_x;
3230           left = convert (tree_type, left);
3231           right = convert (tree_type, right);
3232         }
3233       return ffecom_tree_divide_ (tree_type, left, right,
3234                                   dest_tree, dest, dest_used,
3235                                   ffebld_nonter_hook (expr));
3236
3237     case FFEBLD_opPOWER:
3238       {
3239         ffebld left = ffebld_left (expr);
3240         ffebld right = ffebld_right (expr);
3241         ffecomGfrt code;
3242         ffeinfoKindtype rtkt;
3243         ffeinfoKindtype ltkt;
3244         bool ref = TRUE;
3245
3246         switch (ffeinfo_basictype (ffebld_info (right)))
3247           {
3248
3249           case FFEINFO_basictypeINTEGER:
3250             if (1 || optimize)
3251               {
3252                 item = ffecom_expr_power_integer_ (expr);
3253                 if (item != NULL_TREE)
3254                   return item;
3255               }
3256
3257             rtkt = FFEINFO_kindtypeINTEGER1;
3258             switch (ffeinfo_basictype (ffebld_info (left)))
3259               {
3260               case FFEINFO_basictypeINTEGER:
3261                 if ((ffeinfo_kindtype (ffebld_info (left))
3262                     == FFEINFO_kindtypeINTEGER4)
3263                     || (ffeinfo_kindtype (ffebld_info (right))
3264                         == FFEINFO_kindtypeINTEGER4))
3265                   {
3266                     code = FFECOM_gfrtPOW_QQ;
3267                     ltkt = FFEINFO_kindtypeINTEGER4;
3268                     rtkt = FFEINFO_kindtypeINTEGER4;
3269                   }
3270                 else
3271                   {
3272                     code = FFECOM_gfrtPOW_II;
3273                     ltkt = FFEINFO_kindtypeINTEGER1;
3274                   }
3275                 break;
3276
3277               case FFEINFO_basictypeREAL:
3278                 if (ffeinfo_kindtype (ffebld_info (left))
3279                     == FFEINFO_kindtypeREAL1)
3280                   {
3281                     code = FFECOM_gfrtPOW_RI;
3282                     ltkt = FFEINFO_kindtypeREAL1;
3283                   }
3284                 else
3285                   {
3286                     code = FFECOM_gfrtPOW_DI;
3287                     ltkt = FFEINFO_kindtypeREAL2;
3288                   }
3289                 break;
3290
3291               case FFEINFO_basictypeCOMPLEX:
3292                 if (ffeinfo_kindtype (ffebld_info (left))
3293                     == FFEINFO_kindtypeREAL1)
3294                   {
3295                     code = FFECOM_gfrtPOW_CI;   /* Overlapping result okay. */
3296                     ltkt = FFEINFO_kindtypeREAL1;
3297                   }
3298                 else
3299                   {
3300                     code = FFECOM_gfrtPOW_ZI;   /* Overlapping result okay. */
3301                     ltkt = FFEINFO_kindtypeREAL2;
3302                   }
3303                 break;
3304
3305               default:
3306                 assert ("bad pow_*i" == NULL);
3307                 code = FFECOM_gfrtPOW_CI;       /* Overlapping result okay. */
3308                 ltkt = FFEINFO_kindtypeREAL1;
3309                 break;
3310               }
3311             if (ffeinfo_kindtype (ffebld_info (left)) != ltkt)
3312               left = ffeexpr_convert (left, NULL, NULL,
3313                                       ffeinfo_basictype (ffebld_info (left)),
3314                                       ltkt, 0,
3315                                       FFETARGET_charactersizeNONE,
3316                                       FFEEXPR_contextLET);
3317             if (ffeinfo_kindtype (ffebld_info (right)) != rtkt)
3318               right = ffeexpr_convert (right, NULL, NULL,
3319                                        FFEINFO_basictypeINTEGER,
3320                                        rtkt, 0,
3321                                        FFETARGET_charactersizeNONE,
3322                                        FFEEXPR_contextLET);
3323             break;
3324
3325           case FFEINFO_basictypeREAL:
3326             if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3327               left = ffeexpr_convert (left, NULL, NULL, FFEINFO_basictypeREAL,
3328                                       FFEINFO_kindtypeREALDOUBLE, 0,
3329                                       FFETARGET_charactersizeNONE,
3330                                       FFEEXPR_contextLET);
3331             if (ffeinfo_kindtype (ffebld_info (right))
3332                 == FFEINFO_kindtypeREAL1)
3333               right = ffeexpr_convert (right, NULL, NULL,
3334                                        FFEINFO_basictypeREAL,
3335                                        FFEINFO_kindtypeREALDOUBLE, 0,
3336                                        FFETARGET_charactersizeNONE,
3337                                        FFEEXPR_contextLET);
3338             /* We used to call FFECOM_gfrtPOW_DD here,
3339                which passes arguments by reference.  */
3340             code = FFECOM_gfrtL_POW;
3341             /* Pass arguments by value. */
3342             ref  = FALSE;
3343             break;
3344
3345           case FFEINFO_basictypeCOMPLEX:
3346             if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3347               left = ffeexpr_convert (left, NULL, NULL,
3348                                       FFEINFO_basictypeCOMPLEX,
3349                                       FFEINFO_kindtypeREALDOUBLE, 0,
3350                                       FFETARGET_charactersizeNONE,
3351                                       FFEEXPR_contextLET);
3352             if (ffeinfo_kindtype (ffebld_info (right))
3353                 == FFEINFO_kindtypeREAL1)
3354               right = ffeexpr_convert (right, NULL, NULL,
3355                                        FFEINFO_basictypeCOMPLEX,
3356                                        FFEINFO_kindtypeREALDOUBLE, 0,
3357                                        FFETARGET_charactersizeNONE,
3358                                        FFEEXPR_contextLET);
3359             code = FFECOM_gfrtPOW_ZZ;   /* Overlapping result okay. */
3360             ref = TRUE;                 /* Pass arguments by reference. */
3361             break;
3362
3363           default:
3364             assert ("bad pow_x*" == NULL);
3365             code = FFECOM_gfrtPOW_II;
3366             break;
3367           }
3368         return ffecom_call_binop_ (ffecom_gfrt_tree_ (code),
3369                                    ffecom_gfrt_kindtype (code),
3370                                    (ffe_is_f2c_library ()
3371                                     && ffecom_gfrt_complex_[code]),
3372                                    tree_type, left, right,
3373                                    dest_tree, dest, dest_used,
3374                                    NULL_TREE, FALSE, ref,
3375                                    ffebld_nonter_hook (expr));
3376       }
3377
3378     case FFEBLD_opNOT:
3379       switch (bt)
3380         {
3381         case FFEINFO_basictypeLOGICAL:
3382           item = ffecom_truth_value_invert (ffecom_expr (ffebld_left (expr)));
3383           return convert (tree_type, item);
3384
3385         case FFEINFO_basictypeINTEGER:
3386           return ffecom_1 (BIT_NOT_EXPR, tree_type,
3387                            ffecom_expr (ffebld_left (expr)));
3388
3389         default:
3390           assert ("NOT bad basictype" == NULL);
3391           /* Fall through. */
3392         case FFEINFO_basictypeANY:
3393           return error_mark_node;
3394         }
3395       break;
3396
3397     case FFEBLD_opFUNCREF:
3398       assert (ffeinfo_basictype (ffebld_info (expr))
3399               != FFEINFO_basictypeCHARACTER);
3400       /* Fall through.   */
3401     case FFEBLD_opSUBRREF:
3402       if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
3403           == FFEINFO_whereINTRINSIC)
3404         {                       /* Invocation of an intrinsic. */
3405           item = ffecom_expr_intrinsic_ (expr, dest_tree, dest,
3406                                          dest_used);
3407           return item;
3408         }
3409       s = ffebld_symter (ffebld_left (expr));
3410       dt = ffesymbol_hook (s).decl_tree;
3411       if (dt == NULL_TREE)
3412         {
3413           s = ffecom_sym_transform_ (s);
3414           dt = ffesymbol_hook (s).decl_tree;
3415         }
3416       if (dt == error_mark_node)
3417         return dt;
3418
3419       if (ffesymbol_hook (s).addr)
3420         item = dt;
3421       else
3422         item = ffecom_1_fn (dt);
3423
3424       if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
3425         args = ffecom_list_expr (ffebld_right (expr));
3426       else
3427         args = ffecom_list_ptr_to_expr (ffebld_right (expr));
3428
3429       if (args == error_mark_node)
3430         return error_mark_node;
3431
3432       item = ffecom_call_ (item, kt,
3433                            ffesymbol_is_f2c (s)
3434                            && (bt == FFEINFO_basictypeCOMPLEX)
3435                            && (ffesymbol_where (s)
3436                                != FFEINFO_whereCONSTANT),
3437                            tree_type,
3438                            args,
3439                            dest_tree, dest, dest_used,
3440                            error_mark_node, FALSE,
3441                            ffebld_nonter_hook (expr));
3442       TREE_SIDE_EFFECTS (item) = 1;
3443       return item;
3444
3445     case FFEBLD_opAND:
3446       switch (bt)
3447         {
3448         case FFEINFO_basictypeLOGICAL:
3449           item
3450             = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3451                        ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3452                      ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3453           return convert (tree_type, item);
3454
3455         case FFEINFO_basictypeINTEGER:
3456           return ffecom_2 (BIT_AND_EXPR, tree_type,
3457                            ffecom_expr (ffebld_left (expr)),
3458                            ffecom_expr (ffebld_right (expr)));
3459
3460         default:
3461           assert ("AND bad basictype" == NULL);
3462           /* Fall through. */
3463         case FFEINFO_basictypeANY:
3464           return error_mark_node;
3465         }
3466       break;
3467
3468     case FFEBLD_opOR:
3469       switch (bt)
3470         {
3471         case FFEINFO_basictypeLOGICAL:
3472           item
3473             = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
3474                        ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3475                      ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3476           return convert (tree_type, item);
3477
3478         case FFEINFO_basictypeINTEGER:
3479           return ffecom_2 (BIT_IOR_EXPR, tree_type,
3480                            ffecom_expr (ffebld_left (expr)),
3481                            ffecom_expr (ffebld_right (expr)));
3482
3483         default:
3484           assert ("OR bad basictype" == NULL);
3485           /* Fall through. */
3486         case FFEINFO_basictypeANY:
3487           return error_mark_node;
3488         }
3489       break;
3490
3491     case FFEBLD_opXOR:
3492     case FFEBLD_opNEQV:
3493       switch (bt)
3494         {
3495         case FFEINFO_basictypeLOGICAL:
3496           item
3497             = ffecom_2 (NE_EXPR, integer_type_node,
3498                         ffecom_expr (ffebld_left (expr)),
3499                         ffecom_expr (ffebld_right (expr)));
3500           return convert (tree_type, ffecom_truth_value (item));
3501
3502         case FFEINFO_basictypeINTEGER:
3503           return ffecom_2 (BIT_XOR_EXPR, tree_type,
3504                            ffecom_expr (ffebld_left (expr)),
3505                            ffecom_expr (ffebld_right (expr)));
3506
3507         default:
3508           assert ("XOR/NEQV bad basictype" == NULL);
3509           /* Fall through. */
3510         case FFEINFO_basictypeANY:
3511           return error_mark_node;
3512         }
3513       break;
3514
3515     case FFEBLD_opEQV:
3516       switch (bt)
3517         {
3518         case FFEINFO_basictypeLOGICAL:
3519           item
3520             = ffecom_2 (EQ_EXPR, integer_type_node,
3521                         ffecom_expr (ffebld_left (expr)),
3522                         ffecom_expr (ffebld_right (expr)));
3523           return convert (tree_type, ffecom_truth_value (item));
3524
3525         case FFEINFO_basictypeINTEGER:
3526           return
3527             ffecom_1 (BIT_NOT_EXPR, tree_type,
3528                       ffecom_2 (BIT_XOR_EXPR, tree_type,
3529                                 ffecom_expr (ffebld_left (expr)),
3530                                 ffecom_expr (ffebld_right (expr))));
3531
3532         default:
3533           assert ("EQV bad basictype" == NULL);
3534           /* Fall through. */
3535         case FFEINFO_basictypeANY:
3536           return error_mark_node;
3537         }
3538       break;
3539
3540     case FFEBLD_opCONVERT:
3541       if (ffebld_op (ffebld_left (expr)) == FFEBLD_opANY)
3542         return error_mark_node;
3543
3544       switch (bt)
3545         {
3546         case FFEINFO_basictypeLOGICAL:
3547         case FFEINFO_basictypeINTEGER:
3548         case FFEINFO_basictypeREAL:
3549           return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3550
3551         case FFEINFO_basictypeCOMPLEX:
3552           switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3553             {
3554             case FFEINFO_basictypeINTEGER:
3555             case FFEINFO_basictypeLOGICAL:
3556             case FFEINFO_basictypeREAL:
3557               item = ffecom_expr (ffebld_left (expr));
3558               if (item == error_mark_node)
3559                 return error_mark_node;
3560               /* convert() takes care of converting to the subtype first,
3561                  at least in gcc-2.7.2. */
3562               item = convert (tree_type, item);
3563               return item;
3564
3565             case FFEINFO_basictypeCOMPLEX:
3566               return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3567
3568             default:
3569               assert ("CONVERT COMPLEX bad basictype" == NULL);
3570               /* Fall through. */
3571             case FFEINFO_basictypeANY:
3572               return error_mark_node;
3573             }
3574           break;
3575
3576         default:
3577           assert ("CONVERT bad basictype" == NULL);
3578           /* Fall through. */
3579         case FFEINFO_basictypeANY:
3580           return error_mark_node;
3581         }
3582       break;
3583
3584     case FFEBLD_opLT:
3585       code = LT_EXPR;
3586       goto relational;          /* :::::::::::::::::::: */
3587
3588     case FFEBLD_opLE:
3589       code = LE_EXPR;
3590       goto relational;          /* :::::::::::::::::::: */
3591
3592     case FFEBLD_opEQ:
3593       code = EQ_EXPR;
3594       goto relational;          /* :::::::::::::::::::: */
3595
3596     case FFEBLD_opNE:
3597       code = NE_EXPR;
3598       goto relational;          /* :::::::::::::::::::: */
3599
3600     case FFEBLD_opGT:
3601       code = GT_EXPR;
3602       goto relational;          /* :::::::::::::::::::: */
3603
3604     case FFEBLD_opGE:
3605       code = GE_EXPR;
3606
3607     relational:         /* :::::::::::::::::::: */
3608       switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3609         {
3610         case FFEINFO_basictypeLOGICAL:
3611         case FFEINFO_basictypeINTEGER:
3612         case FFEINFO_basictypeREAL:
3613           item = ffecom_2 (code, integer_type_node,
3614                            ffecom_expr (ffebld_left (expr)),
3615                            ffecom_expr (ffebld_right (expr)));
3616           return convert (tree_type, item);
3617
3618         case FFEINFO_basictypeCOMPLEX:
3619           assert (code == EQ_EXPR || code == NE_EXPR);
3620           {
3621             tree real_type;
3622             tree arg1 = ffecom_expr (ffebld_left (expr));
3623             tree arg2 = ffecom_expr (ffebld_right (expr));
3624
3625             if (arg1 == error_mark_node || arg2 == error_mark_node)
3626               return error_mark_node;
3627
3628             arg1 = ffecom_save_tree (arg1);
3629             arg2 = ffecom_save_tree (arg2);
3630
3631             if (TREE_CODE (TREE_TYPE (arg1)) == COMPLEX_TYPE)
3632               {
3633                 real_type = TREE_TYPE (TREE_TYPE (arg1));
3634                 assert (real_type == TREE_TYPE (TREE_TYPE (arg2)));
3635               }
3636             else
3637               {
3638                 real_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg1)));
3639                 assert (real_type == TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg2))));
3640               }
3641
3642             item
3643               = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3644                           ffecom_2 (EQ_EXPR, integer_type_node,
3645                                   ffecom_1 (REALPART_EXPR, real_type, arg1),
3646                                  ffecom_1 (REALPART_EXPR, real_type, arg2)),
3647                           ffecom_2 (EQ_EXPR, integer_type_node,
3648                                   ffecom_1 (IMAGPART_EXPR, real_type, arg1),
3649                                     ffecom_1 (IMAGPART_EXPR, real_type,
3650                                               arg2)));
3651             if (code == EQ_EXPR)
3652               item = ffecom_truth_value (item);
3653             else
3654               item = ffecom_truth_value_invert (item);
3655             return convert (tree_type, item);
3656           }
3657
3658         case FFEINFO_basictypeCHARACTER:
3659           {
3660             ffebld left = ffebld_left (expr);
3661             ffebld right = ffebld_right (expr);
3662             tree left_tree;
3663             tree right_tree;
3664             tree left_length;
3665             tree right_length;
3666
3667             /* f2c run-time functions do the implicit blank-padding for us,
3668                so we don't usually have to implement blank-padding ourselves.
3669                (The exception is when we pass an argument to a separately
3670                compiled statement function -- if we know the arg is not the
3671                same length as the dummy, we must truncate or extend it.  If
3672                we "inline" statement functions, that necessity goes away as
3673                well.)
3674
3675                Strip off the CONVERT operators that blank-pad.  (Truncation by
3676                CONVERT shouldn't happen here, but it can happen in
3677                assignments.) */
3678
3679             while (ffebld_op (left) == FFEBLD_opCONVERT)
3680               left = ffebld_left (left);
3681             while (ffebld_op (right) == FFEBLD_opCONVERT)
3682               right = ffebld_left (right);
3683
3684             left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
3685             right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
3686
3687             if (left_tree == error_mark_node || left_length == error_mark_node
3688                 || right_tree == error_mark_node
3689                 || right_length == error_mark_node)
3690               return error_mark_node;
3691
3692             if ((ffebld_size_known (left) == 1)
3693                 && (ffebld_size_known (right) == 1))
3694               {
3695                 left_tree
3696                   = ffecom_1 (INDIRECT_REF,
3697                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3698                               left_tree);
3699                 right_tree
3700                   = ffecom_1 (INDIRECT_REF,
3701                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3702                               right_tree);
3703
3704                 item
3705                   = ffecom_2 (code, integer_type_node,
3706                               ffecom_2 (ARRAY_REF,
3707                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3708                                         left_tree,
3709                                         integer_one_node),
3710                               ffecom_2 (ARRAY_REF,
3711                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3712                                         right_tree,
3713                                         integer_one_node));
3714               }
3715             else
3716               {
3717                 item = build_tree_list (NULL_TREE, left_tree);
3718                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, right_tree);
3719                 TREE_CHAIN (TREE_CHAIN (item)) = build_tree_list (NULL_TREE,
3720                                                                left_length);
3721                 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
3722                   = build_tree_list (NULL_TREE, right_length);
3723                 item = ffecom_call_gfrt (FFECOM_gfrtCMP, item, NULL_TREE);
3724                 item = ffecom_2 (code, integer_type_node,
3725                                  item,
3726                                  convert (TREE_TYPE (item),
3727                                           integer_zero_node));
3728               }
3729             item = convert (tree_type, item);
3730           }
3731
3732           return item;
3733
3734         default:
3735           assert ("relational bad basictype" == NULL);
3736           /* Fall through. */
3737         case FFEINFO_basictypeANY:
3738           return error_mark_node;
3739         }
3740       break;
3741
3742     case FFEBLD_opPERCENT_LOC:
3743       item = ffecom_arg_ptr_to_expr (ffebld_left (expr), &list);
3744       return convert (tree_type, item);
3745
3746     case FFEBLD_opPERCENT_VAL:
3747       item = ffecom_arg_expr (ffebld_left (expr), &list);
3748       return convert (tree_type, item);
3749
3750     case FFEBLD_opITEM:
3751     case FFEBLD_opSTAR:
3752     case FFEBLD_opBOUNDS:
3753     case FFEBLD_opREPEAT:
3754     case FFEBLD_opLABTER:
3755     case FFEBLD_opLABTOK:
3756     case FFEBLD_opIMPDO:
3757     case FFEBLD_opCONCATENATE:
3758     case FFEBLD_opSUBSTR:
3759     default:
3760       assert ("bad op" == NULL);
3761       /* Fall through. */
3762     case FFEBLD_opANY:
3763       return error_mark_node;
3764     }
3765
3766 #if 1
3767   assert ("didn't think anything got here anymore!!" == NULL);
3768 #else
3769   switch (ffebld_arity (expr))
3770     {
3771     case 2:
3772       TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3773       TREE_OPERAND (item, 1) = ffecom_expr (ffebld_right (expr));
3774       if (TREE_OPERAND (item, 0) == error_mark_node
3775           || TREE_OPERAND (item, 1) == error_mark_node)
3776         return error_mark_node;
3777       break;
3778
3779     case 1:
3780       TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3781       if (TREE_OPERAND (item, 0) == error_mark_node)
3782         return error_mark_node;
3783       break;
3784
3785     default:
3786       break;
3787     }
3788
3789   return fold (item);
3790 #endif
3791 }
3792
3793 /* Returns the tree that does the intrinsic invocation.
3794
3795    Note: this function applies only to intrinsics returning
3796    CHARACTER*1 or non-CHARACTER results, and to intrinsic
3797    subroutines.  */
3798
3799 static tree
3800 ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
3801                         ffebld dest, bool *dest_used)
3802 {
3803   tree expr_tree;
3804   tree saved_expr1;             /* For those who need it. */
3805   tree saved_expr2;             /* For those who need it. */
3806   ffeinfoBasictype bt;
3807   ffeinfoKindtype kt;
3808   tree tree_type;
3809   tree arg1_type;
3810   tree real_type;               /* REAL type corresponding to COMPLEX. */
3811   tree tempvar;
3812   ffebld list = ffebld_right (expr);    /* List of (some) args. */
3813   ffebld arg1;                  /* For handy reference. */
3814   ffebld arg2;
3815   ffebld arg3;
3816   ffeintrinImp codegen_imp;
3817   ffecomGfrt gfrt;
3818
3819   assert (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER);
3820
3821   if (dest_used != NULL)
3822     *dest_used = FALSE;
3823
3824   bt = ffeinfo_basictype (ffebld_info (expr));
3825   kt = ffeinfo_kindtype (ffebld_info (expr));
3826   tree_type = ffecom_tree_type[bt][kt];
3827
3828   if (list != NULL)
3829     {
3830       arg1 = ffebld_head (list);
3831       if (arg1 != NULL && ffebld_op (arg1) == FFEBLD_opANY)
3832         return error_mark_node;
3833       if ((list = ffebld_trail (list)) != NULL)
3834         {
3835           arg2 = ffebld_head (list);
3836           if (arg2 != NULL && ffebld_op (arg2) == FFEBLD_opANY)
3837             return error_mark_node;
3838           if ((list = ffebld_trail (list)) != NULL)
3839             {
3840               arg3 = ffebld_head (list);
3841               if (arg3 != NULL && ffebld_op (arg3) == FFEBLD_opANY)
3842                 return error_mark_node;
3843             }
3844           else
3845             arg3 = NULL;
3846         }
3847       else
3848         arg2 = arg3 = NULL;
3849     }
3850   else
3851     arg1 = arg2 = arg3 = NULL;
3852
3853   /* <list> ends up at the opITEM of the 3rd arg, or NULL if there are < 3
3854      args.  This is used by the MAX/MIN expansions. */
3855
3856   if (arg1 != NULL)
3857     arg1_type = ffecom_tree_type
3858       [ffeinfo_basictype (ffebld_info (arg1))]
3859       [ffeinfo_kindtype (ffebld_info (arg1))];
3860   else
3861     arg1_type = NULL_TREE;      /* Really not needed, but might catch bugs
3862                                    here. */
3863
3864   /* There are several ways for each of the cases in the following switch
3865      statements to exit (from simplest to use to most complicated):
3866
3867      break;  (when expr_tree == NULL)
3868
3869      A standard call is made to the specific intrinsic just as if it had been
3870      passed in as a dummy procedure and called as any old procedure.  This
3871      method can produce slower code but in some cases it's the easiest way for
3872      now.  However, if a (presumably faster) direct call is available,
3873      that is used, so this is the easiest way in many more cases now.
3874
3875      gfrt = FFECOM_gfrtWHATEVER;
3876      break;
3877
3878      gfrt contains the gfrt index of a library function to call, passing the
3879      argument(s) by value rather than by reference.  Used when a more
3880      careful choice of library function is needed than that provided
3881      by the vanilla `break;'.
3882
3883      return expr_tree;
3884
3885      The expr_tree has been completely set up and is ready to be returned
3886      as is.  No further actions are taken.  Use this when the tree is not
3887      in the simple form for one of the arity_n labels.   */
3888
3889   /* For info on how the switch statement cases were written, see the files
3890      enclosed in comments below the switch statement. */
3891
3892   codegen_imp = ffebld_symter_implementation (ffebld_left (expr));
3893   gfrt = ffeintrin_gfrt_direct (codegen_imp);
3894   if (gfrt == FFECOM_gfrt)
3895     gfrt = ffeintrin_gfrt_indirect (codegen_imp);
3896
3897   switch (codegen_imp)
3898     {
3899     case FFEINTRIN_impABS:
3900     case FFEINTRIN_impCABS:
3901     case FFEINTRIN_impCDABS:
3902     case FFEINTRIN_impDABS:
3903     case FFEINTRIN_impIABS:
3904       if (ffeinfo_basictype (ffebld_info (arg1))
3905           == FFEINFO_basictypeCOMPLEX)
3906         {
3907           if (kt == FFEINFO_kindtypeREAL1)
3908             gfrt = FFECOM_gfrtCABS;
3909           else if (kt == FFEINFO_kindtypeREAL2)
3910             gfrt = FFECOM_gfrtCDABS;
3911           break;
3912         }
3913       return ffecom_1 (ABS_EXPR, tree_type,
3914                        convert (tree_type, ffecom_expr (arg1)));
3915
3916     case FFEINTRIN_impACOS:
3917     case FFEINTRIN_impDACOS:
3918       break;
3919
3920     case FFEINTRIN_impAIMAG:
3921     case FFEINTRIN_impDIMAG:
3922     case FFEINTRIN_impIMAGPART:
3923       if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
3924         arg1_type = TREE_TYPE (arg1_type);
3925       else
3926         arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
3927
3928       return
3929         convert (tree_type,
3930                  ffecom_1 (IMAGPART_EXPR, arg1_type,
3931                            ffecom_expr (arg1)));
3932
3933     case FFEINTRIN_impAINT:
3934     case FFEINTRIN_impDINT:
3935 #if 0
3936       /* ~~Someday implement FIX_TRUNC_EXPR yielding same type as arg.  */
3937       return ffecom_1 (FIX_TRUNC_EXPR, tree_type, ffecom_expr (arg1));
3938 #else /* in the meantime, must use floor to avoid range problems with ints */
3939       /* r__1 = r1 >= 0 ? floor(r1) : -floor(-r1); */
3940       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
3941       return
3942         convert (tree_type,
3943                  ffecom_3 (COND_EXPR, double_type_node,
3944                            ffecom_truth_value
3945                            (ffecom_2 (GE_EXPR, integer_type_node,
3946                                       saved_expr1,
3947                                       convert (arg1_type,
3948                                                ffecom_float_zero_))),
3949                            ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
3950                                              build_tree_list (NULL_TREE,
3951                                                   convert (double_type_node,
3952                                                            saved_expr1)),
3953                                              NULL_TREE),
3954                            ffecom_1 (NEGATE_EXPR, double_type_node,
3955                                      ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
3956                                                  build_tree_list (NULL_TREE,
3957                                                   convert (double_type_node,
3958                                                       ffecom_1 (NEGATE_EXPR,
3959                                                                 arg1_type,
3960                                                                saved_expr1))),
3961                                                        NULL_TREE)
3962                                      ))
3963                  );
3964 #endif
3965
3966     case FFEINTRIN_impANINT:
3967     case FFEINTRIN_impDNINT:
3968 #if 0                           /* This way of doing it won't handle real
3969                                    numbers of large magnitudes. */
3970       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
3971       expr_tree = convert (tree_type,
3972                            convert (integer_type_node,
3973                                     ffecom_3 (COND_EXPR, tree_type,
3974                                               ffecom_truth_value
3975                                               (ffecom_2 (GE_EXPR,
3976                                                          integer_type_node,
3977                                                          saved_expr1,
3978                                                        ffecom_float_zero_)),
3979                                               ffecom_2 (PLUS_EXPR,
3980                                                         tree_type,
3981                                                         saved_expr1,
3982                                                         ffecom_float_half_),
3983                                               ffecom_2 (MINUS_EXPR,
3984                                                         tree_type,
3985                                                         saved_expr1,
3986                                                      ffecom_float_half_))));
3987       return expr_tree;
3988 #else /* So we instead call floor. */
3989       /* r__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1) */
3990       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
3991       return
3992         convert (tree_type,
3993                  ffecom_3 (COND_EXPR, double_type_node,
3994                            ffecom_truth_value
3995                            (ffecom_2 (GE_EXPR, integer_type_node,
3996                                       saved_expr1,
3997                                       convert (arg1_type,
3998                                                ffecom_float_zero_))),
3999                            ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4000                                              build_tree_list (NULL_TREE,
4001                                                   convert (double_type_node,
4002                                                            ffecom_2 (PLUS_EXPR,
4003                                                                      arg1_type,
4004                                                                      saved_expr1,
4005                                                                      convert (arg1_type,
4006                                                                               ffecom_float_half_)))),
4007                                              NULL_TREE),
4008                            ffecom_1 (NEGATE_EXPR, double_type_node,
4009                                      ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4010                                                        build_tree_list (NULL_TREE,
4011                                                                         convert (double_type_node,
4012                                                                                  ffecom_2 (MINUS_EXPR,
4013                                                                                            arg1_type,
4014                                                                                            convert (arg1_type,
4015                                                                                                     ffecom_float_half_),
4016                                                                                            saved_expr1))),
4017                                                        NULL_TREE))
4018                            )
4019                  );
4020 #endif
4021
4022     case FFEINTRIN_impASIN:
4023     case FFEINTRIN_impDASIN:
4024     case FFEINTRIN_impATAN:
4025     case FFEINTRIN_impDATAN:
4026     case FFEINTRIN_impATAN2:
4027     case FFEINTRIN_impDATAN2:
4028       break;
4029
4030     case FFEINTRIN_impCHAR:
4031     case FFEINTRIN_impACHAR:
4032 #ifdef HOHO
4033       tempvar = ffecom_make_tempvar (char_type_node, 1, -1);
4034 #else
4035       tempvar = ffebld_nonter_hook (expr);
4036       assert (tempvar);
4037 #endif
4038       {
4039         tree tmv = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (tempvar)));
4040
4041         expr_tree = ffecom_modify (tmv,
4042                                    ffecom_2 (ARRAY_REF, tmv, tempvar,
4043                                              integer_one_node),
4044                                    convert (tmv, ffecom_expr (arg1)));
4045       }
4046       expr_tree = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar),
4047                             expr_tree,
4048                             tempvar);
4049       expr_tree = ffecom_1 (ADDR_EXPR,
4050                             build_pointer_type (TREE_TYPE (expr_tree)),
4051                             expr_tree);
4052       return expr_tree;
4053
4054     case FFEINTRIN_impCMPLX:
4055     case FFEINTRIN_impDCMPLX:
4056       if (arg2 == NULL)
4057         return
4058           convert (tree_type, ffecom_expr (arg1));
4059
4060       real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4061       return
4062         ffecom_2 (COMPLEX_EXPR, tree_type,
4063                   convert (real_type, ffecom_expr (arg1)),
4064                   convert (real_type,
4065                            ffecom_expr (arg2)));
4066
4067     case FFEINTRIN_impCOMPLEX:
4068       return
4069         ffecom_2 (COMPLEX_EXPR, tree_type,
4070                   ffecom_expr (arg1),
4071                   ffecom_expr (arg2));
4072
4073     case FFEINTRIN_impCONJG:
4074     case FFEINTRIN_impDCONJG:
4075       {
4076         tree arg1_tree;
4077
4078         real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4079         arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4080         return
4081           ffecom_2 (COMPLEX_EXPR, tree_type,
4082                     ffecom_1 (REALPART_EXPR, real_type, arg1_tree),
4083                     ffecom_1 (NEGATE_EXPR, real_type,
4084                               ffecom_1 (IMAGPART_EXPR, real_type, arg1_tree)));
4085       }
4086
4087     case FFEINTRIN_impCOS:
4088     case FFEINTRIN_impCCOS:
4089     case FFEINTRIN_impCDCOS:
4090     case FFEINTRIN_impDCOS:
4091       if (bt == FFEINFO_basictypeCOMPLEX)
4092         {
4093           if (kt == FFEINFO_kindtypeREAL1)
4094             gfrt = FFECOM_gfrtCCOS;     /* Overlapping result okay. */
4095           else if (kt == FFEINFO_kindtypeREAL2)
4096             gfrt = FFECOM_gfrtCDCOS;    /* Overlapping result okay. */
4097         }
4098       break;
4099
4100     case FFEINTRIN_impCOSH:
4101     case FFEINTRIN_impDCOSH:
4102       break;
4103
4104     case FFEINTRIN_impDBLE:
4105     case FFEINTRIN_impDFLOAT:
4106     case FFEINTRIN_impDREAL:
4107     case FFEINTRIN_impFLOAT:
4108     case FFEINTRIN_impIDINT:
4109     case FFEINTRIN_impIFIX:
4110     case FFEINTRIN_impINT2:
4111     case FFEINTRIN_impINT8:
4112     case FFEINTRIN_impINT:
4113     case FFEINTRIN_impLONG:
4114     case FFEINTRIN_impREAL:
4115     case FFEINTRIN_impSHORT:
4116     case FFEINTRIN_impSNGL:
4117       return convert (tree_type, ffecom_expr (arg1));
4118
4119     case FFEINTRIN_impDIM:
4120     case FFEINTRIN_impDDIM:
4121     case FFEINTRIN_impIDIM:
4122       saved_expr1 = ffecom_save_tree (convert (tree_type,
4123                                                ffecom_expr (arg1)));
4124       saved_expr2 = ffecom_save_tree (convert (tree_type,
4125                                                ffecom_expr (arg2)));
4126       return
4127         ffecom_3 (COND_EXPR, tree_type,
4128                   ffecom_truth_value
4129                   (ffecom_2 (GT_EXPR, integer_type_node,
4130                              saved_expr1,
4131                              saved_expr2)),
4132                   ffecom_2 (MINUS_EXPR, tree_type,
4133                             saved_expr1,
4134                             saved_expr2),
4135                   convert (tree_type, ffecom_float_zero_));
4136
4137     case FFEINTRIN_impDPROD:
4138       return
4139         ffecom_2 (MULT_EXPR, tree_type,
4140                   convert (tree_type, ffecom_expr (arg1)),
4141                   convert (tree_type, ffecom_expr (arg2)));
4142
4143     case FFEINTRIN_impEXP:
4144     case FFEINTRIN_impCDEXP:
4145     case FFEINTRIN_impCEXP:
4146     case FFEINTRIN_impDEXP:
4147       if (bt == FFEINFO_basictypeCOMPLEX)
4148         {
4149           if (kt == FFEINFO_kindtypeREAL1)
4150             gfrt = FFECOM_gfrtCEXP;     /* Overlapping result okay. */
4151           else if (kt == FFEINFO_kindtypeREAL2)
4152             gfrt = FFECOM_gfrtCDEXP;    /* Overlapping result okay. */
4153         }
4154       break;
4155
4156     case FFEINTRIN_impICHAR:
4157     case FFEINTRIN_impIACHAR:
4158 #if 0                           /* The simple approach. */
4159       ffecom_char_args_ (&expr_tree, &saved_expr1 /* Ignored */ , arg1);
4160       expr_tree
4161         = ffecom_1 (INDIRECT_REF,
4162                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4163                     expr_tree);
4164       expr_tree
4165         = ffecom_2 (ARRAY_REF,
4166                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4167                     expr_tree,
4168                     integer_one_node);
4169       return convert (tree_type, expr_tree);
4170 #else /* The more interesting (and more optimal) approach. */
4171       expr_tree = ffecom_intrinsic_ichar_ (tree_type, arg1, &saved_expr1);
4172       expr_tree = ffecom_3 (COND_EXPR, tree_type,
4173                             saved_expr1,
4174                             expr_tree,
4175                             convert (tree_type, integer_zero_node));
4176       return expr_tree;
4177 #endif
4178
4179     case FFEINTRIN_impINDEX:
4180       break;
4181
4182     case FFEINTRIN_impLEN:
4183 #if 0
4184       break;                                    /* The simple approach. */
4185 #else
4186       return ffecom_intrinsic_len_ (arg1);      /* The more optimal approach. */
4187 #endif
4188
4189     case FFEINTRIN_impLGE:
4190     case FFEINTRIN_impLGT:
4191     case FFEINTRIN_impLLE:
4192     case FFEINTRIN_impLLT:
4193       break;
4194
4195     case FFEINTRIN_impLOG:
4196     case FFEINTRIN_impALOG:
4197     case FFEINTRIN_impCDLOG:
4198     case FFEINTRIN_impCLOG:
4199     case FFEINTRIN_impDLOG:
4200       if (bt == FFEINFO_basictypeCOMPLEX)
4201         {
4202           if (kt == FFEINFO_kindtypeREAL1)
4203             gfrt = FFECOM_gfrtCLOG;     /* Overlapping result okay. */
4204           else if (kt == FFEINFO_kindtypeREAL2)
4205             gfrt = FFECOM_gfrtCDLOG;    /* Overlapping result okay. */
4206         }
4207       break;
4208
4209     case FFEINTRIN_impLOG10:
4210     case FFEINTRIN_impALOG10:
4211     case FFEINTRIN_impDLOG10:
4212       if (gfrt != FFECOM_gfrt)
4213         break;  /* Already picked one, stick with it. */
4214
4215       if (kt == FFEINFO_kindtypeREAL1)
4216         /* We used to call FFECOM_gfrtALOG10 here.  */
4217         gfrt = FFECOM_gfrtL_LOG10;
4218       else if (kt == FFEINFO_kindtypeREAL2)
4219         /* We used to call FFECOM_gfrtDLOG10 here.  */
4220         gfrt = FFECOM_gfrtL_LOG10;
4221       break;
4222
4223     case FFEINTRIN_impMAX:
4224     case FFEINTRIN_impAMAX0:
4225     case FFEINTRIN_impAMAX1:
4226     case FFEINTRIN_impDMAX1:
4227     case FFEINTRIN_impMAX0:
4228     case FFEINTRIN_impMAX1:
4229       if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4230         arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4231       else
4232         arg1_type = tree_type;
4233       expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4234                             convert (arg1_type, ffecom_expr (arg1)),
4235                             convert (arg1_type, ffecom_expr (arg2)));
4236       for (; list != NULL; list = ffebld_trail (list))
4237         {
4238           if ((ffebld_head (list) == NULL)
4239               || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4240             continue;
4241           expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4242                                 expr_tree,
4243                                 convert (arg1_type,
4244                                          ffecom_expr (ffebld_head (list))));
4245         }
4246       return convert (tree_type, expr_tree);
4247
4248     case FFEINTRIN_impMIN:
4249     case FFEINTRIN_impAMIN0:
4250     case FFEINTRIN_impAMIN1:
4251     case FFEINTRIN_impDMIN1:
4252     case FFEINTRIN_impMIN0:
4253     case FFEINTRIN_impMIN1:
4254       if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4255         arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4256       else
4257         arg1_type = tree_type;
4258       expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4259                             convert (arg1_type, ffecom_expr (arg1)),
4260                             convert (arg1_type, ffecom_expr (arg2)));
4261       for (; list != NULL; list = ffebld_trail (list))
4262         {
4263           if ((ffebld_head (list) == NULL)
4264               || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4265             continue;
4266           expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4267                                 expr_tree,
4268                                 convert (arg1_type,
4269                                          ffecom_expr (ffebld_head (list))));
4270         }
4271       return convert (tree_type, expr_tree);
4272
4273     case FFEINTRIN_impMOD:
4274     case FFEINTRIN_impAMOD:
4275     case FFEINTRIN_impDMOD:
4276       if (bt != FFEINFO_basictypeREAL)
4277         return ffecom_2 (TRUNC_MOD_EXPR, tree_type,
4278                          convert (tree_type, ffecom_expr (arg1)),
4279                          convert (tree_type, ffecom_expr (arg2)));
4280
4281       if (kt == FFEINFO_kindtypeREAL1)
4282         /* We used to call FFECOM_gfrtAMOD here.  */
4283         gfrt = FFECOM_gfrtL_FMOD;
4284       else if (kt == FFEINFO_kindtypeREAL2)
4285         /* We used to call FFECOM_gfrtDMOD here.  */
4286         gfrt = FFECOM_gfrtL_FMOD;
4287       break;
4288
4289     case FFEINTRIN_impNINT:
4290     case FFEINTRIN_impIDNINT:
4291 #if 0
4292       /* ~~Ideally FIX_ROUND_EXPR would be implemented, but it ain't yet.  */
4293       return ffecom_1 (FIX_ROUND_EXPR, tree_type, ffecom_expr (arg1));
4294 #else
4295       /* i__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1); */
4296       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4297       return
4298         convert (ffecom_integer_type_node,
4299                  ffecom_3 (COND_EXPR, arg1_type,
4300                            ffecom_truth_value
4301                            (ffecom_2 (GE_EXPR, integer_type_node,
4302                                       saved_expr1,
4303                                       convert (arg1_type,
4304                                                ffecom_float_zero_))),
4305                            ffecom_2 (PLUS_EXPR, arg1_type,
4306                                      saved_expr1,
4307                                      convert (arg1_type,
4308                                               ffecom_float_half_)),
4309                            ffecom_2 (MINUS_EXPR, arg1_type,
4310                                      saved_expr1,
4311                                      convert (arg1_type,
4312                                               ffecom_float_half_))));
4313 #endif
4314
4315     case FFEINTRIN_impSIGN:
4316     case FFEINTRIN_impDSIGN:
4317     case FFEINTRIN_impISIGN:
4318       {
4319         tree arg2_tree = ffecom_expr (arg2);
4320
4321         saved_expr1
4322           = ffecom_save_tree
4323           (ffecom_1 (ABS_EXPR, tree_type,
4324                      convert (tree_type,
4325                               ffecom_expr (arg1))));
4326         expr_tree
4327           = ffecom_3 (COND_EXPR, tree_type,
4328                       ffecom_truth_value
4329                       (ffecom_2 (GE_EXPR, integer_type_node,
4330                                  arg2_tree,
4331                                  convert (TREE_TYPE (arg2_tree),
4332                                           integer_zero_node))),
4333                       saved_expr1,
4334                       ffecom_1 (NEGATE_EXPR, tree_type, saved_expr1));
4335         /* Make sure SAVE_EXPRs get referenced early enough. */
4336         expr_tree
4337           = ffecom_2 (COMPOUND_EXPR, tree_type,
4338                       convert (void_type_node, saved_expr1),
4339                       expr_tree);
4340       }
4341       return expr_tree;
4342
4343     case FFEINTRIN_impSIN:
4344     case FFEINTRIN_impCDSIN:
4345     case FFEINTRIN_impCSIN:
4346     case FFEINTRIN_impDSIN:
4347       if (bt == FFEINFO_basictypeCOMPLEX)
4348         {
4349           if (kt == FFEINFO_kindtypeREAL1)
4350             gfrt = FFECOM_gfrtCSIN;     /* Overlapping result okay. */
4351           else if (kt == FFEINFO_kindtypeREAL2)
4352             gfrt = FFECOM_gfrtCDSIN;    /* Overlapping result okay. */
4353         }
4354       break;
4355
4356     case FFEINTRIN_impSINH:
4357     case FFEINTRIN_impDSINH:
4358       break;
4359
4360     case FFEINTRIN_impSQRT:
4361     case FFEINTRIN_impCDSQRT:
4362     case FFEINTRIN_impCSQRT:
4363     case FFEINTRIN_impDSQRT:
4364       if (bt == FFEINFO_basictypeCOMPLEX)
4365         {
4366           if (kt == FFEINFO_kindtypeREAL1)
4367             gfrt = FFECOM_gfrtCSQRT;    /* Overlapping result okay. */
4368           else if (kt == FFEINFO_kindtypeREAL2)
4369             gfrt = FFECOM_gfrtCDSQRT;   /* Overlapping result okay. */
4370         }
4371       break;
4372
4373     case FFEINTRIN_impTAN:
4374     case FFEINTRIN_impDTAN:
4375     case FFEINTRIN_impTANH:
4376     case FFEINTRIN_impDTANH:
4377       break;
4378
4379     case FFEINTRIN_impREALPART:
4380       if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
4381         arg1_type = TREE_TYPE (arg1_type);
4382       else
4383         arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
4384
4385       return
4386         convert (tree_type,
4387                  ffecom_1 (REALPART_EXPR, arg1_type,
4388                            ffecom_expr (arg1)));
4389
4390     case FFEINTRIN_impIAND:
4391     case FFEINTRIN_impAND:
4392       return ffecom_2 (BIT_AND_EXPR, tree_type,
4393                        convert (tree_type,
4394                                 ffecom_expr (arg1)),
4395                        convert (tree_type,
4396                                 ffecom_expr (arg2)));
4397
4398     case FFEINTRIN_impIOR:
4399     case FFEINTRIN_impOR:
4400       return ffecom_2 (BIT_IOR_EXPR, tree_type,
4401                        convert (tree_type,
4402                                 ffecom_expr (arg1)),
4403                        convert (tree_type,
4404                                 ffecom_expr (arg2)));
4405
4406     case FFEINTRIN_impIEOR:
4407     case FFEINTRIN_impXOR:
4408       return ffecom_2 (BIT_XOR_EXPR, tree_type,
4409                        convert (tree_type,
4410                                 ffecom_expr (arg1)),
4411                        convert (tree_type,
4412                                 ffecom_expr (arg2)));
4413
4414     case FFEINTRIN_impLSHIFT:
4415       return ffecom_2 (LSHIFT_EXPR, tree_type,
4416                        ffecom_expr (arg1),
4417                        convert (integer_type_node,
4418                                 ffecom_expr (arg2)));
4419
4420     case FFEINTRIN_impRSHIFT:
4421       return ffecom_2 (RSHIFT_EXPR, tree_type,
4422                        ffecom_expr (arg1),
4423                        convert (integer_type_node,
4424                                 ffecom_expr (arg2)));
4425
4426     case FFEINTRIN_impNOT:
4427       return ffecom_1 (BIT_NOT_EXPR, tree_type, ffecom_expr (arg1));
4428
4429     case FFEINTRIN_impBIT_SIZE:
4430       return convert (tree_type, TYPE_SIZE (arg1_type));
4431
4432     case FFEINTRIN_impBTEST:
4433       {
4434         ffetargetLogical1 target_true;
4435         ffetargetLogical1 target_false;
4436         tree true_tree;
4437         tree false_tree;
4438
4439         ffetarget_logical1 (&target_true, TRUE);
4440         ffetarget_logical1 (&target_false, FALSE);
4441         if (target_true == 1)
4442           true_tree = convert (tree_type, integer_one_node);
4443         else
4444           true_tree = convert (tree_type, build_int_2 (target_true, 0));
4445         if (target_false == 0)
4446           false_tree = convert (tree_type, integer_zero_node);
4447         else
4448           false_tree = convert (tree_type, build_int_2 (target_false, 0));
4449
4450         return
4451           ffecom_3 (COND_EXPR, tree_type,
4452                     ffecom_truth_value
4453                     (ffecom_2 (EQ_EXPR, integer_type_node,
4454                                ffecom_2 (BIT_AND_EXPR, arg1_type,
4455                                          ffecom_expr (arg1),
4456                                          ffecom_2 (LSHIFT_EXPR, arg1_type,
4457                                                    convert (arg1_type,
4458                                                           integer_one_node),
4459                                                    convert (integer_type_node,
4460                                                             ffecom_expr (arg2)))),
4461                                convert (arg1_type,
4462                                         integer_zero_node))),
4463                     false_tree,
4464                     true_tree);
4465       }
4466
4467     case FFEINTRIN_impIBCLR:
4468       return
4469         ffecom_2 (BIT_AND_EXPR, tree_type,
4470                   ffecom_expr (arg1),
4471                   ffecom_1 (BIT_NOT_EXPR, tree_type,
4472                             ffecom_2 (LSHIFT_EXPR, tree_type,
4473                                       convert (tree_type,
4474                                                integer_one_node),
4475                                       convert (integer_type_node,
4476                                                ffecom_expr (arg2)))));
4477
4478     case FFEINTRIN_impIBITS:
4479       {
4480         tree arg3_tree = ffecom_save_tree (convert (integer_type_node,
4481                                                     ffecom_expr (arg3)));
4482         tree uns_type
4483         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4484
4485         expr_tree
4486           = ffecom_2 (BIT_AND_EXPR, tree_type,
4487                       ffecom_2 (RSHIFT_EXPR, tree_type,
4488                                 ffecom_expr (arg1),
4489                                 convert (integer_type_node,
4490                                          ffecom_expr (arg2))),
4491                       convert (tree_type,
4492                                ffecom_2 (RSHIFT_EXPR, uns_type,
4493                                          ffecom_1 (BIT_NOT_EXPR,
4494                                                    uns_type,
4495                                                    convert (uns_type,
4496                                                         integer_zero_node)),
4497                                          ffecom_2 (MINUS_EXPR,
4498                                                    integer_type_node,
4499                                                    TYPE_SIZE (uns_type),
4500                                                    arg3_tree))));
4501         /* Fix up, because the RSHIFT_EXPR above can't shift over TYPE_SIZE.  */
4502         expr_tree
4503           = ffecom_3 (COND_EXPR, tree_type,
4504                       ffecom_truth_value
4505                       (ffecom_2 (NE_EXPR, integer_type_node,
4506                                  arg3_tree,
4507                                  integer_zero_node)),
4508                       expr_tree,
4509                       convert (tree_type, integer_zero_node));
4510       }
4511       return expr_tree;
4512
4513     case FFEINTRIN_impIBSET:
4514       return
4515         ffecom_2 (BIT_IOR_EXPR, tree_type,
4516                   ffecom_expr (arg1),
4517                   ffecom_2 (LSHIFT_EXPR, tree_type,
4518                             convert (tree_type, integer_one_node),
4519                             convert (integer_type_node,
4520                                      ffecom_expr (arg2))));
4521
4522     case FFEINTRIN_impISHFT:
4523       {
4524         tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4525         tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4526                                                     ffecom_expr (arg2)));
4527         tree uns_type
4528         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4529
4530         expr_tree
4531           = ffecom_3 (COND_EXPR, tree_type,
4532                       ffecom_truth_value
4533                       (ffecom_2 (GE_EXPR, integer_type_node,
4534                                  arg2_tree,
4535                                  integer_zero_node)),
4536                       ffecom_2 (LSHIFT_EXPR, tree_type,
4537                                 arg1_tree,
4538                                 arg2_tree),
4539                       convert (tree_type,
4540                                ffecom_2 (RSHIFT_EXPR, uns_type,
4541                                          convert (uns_type, arg1_tree),
4542                                          ffecom_1 (NEGATE_EXPR,
4543                                                    integer_type_node,
4544                                                    arg2_tree))));
4545         /* Fix up, because {L|R}SHIFT_EXPR don't go over TYPE_SIZE bounds.  */
4546         expr_tree
4547           = ffecom_3 (COND_EXPR, tree_type,
4548                       ffecom_truth_value
4549                       (ffecom_2 (NE_EXPR, integer_type_node,
4550                                  ffecom_1 (ABS_EXPR,
4551                                            integer_type_node,
4552                                            arg2_tree),
4553                                  TYPE_SIZE (uns_type))),
4554                       expr_tree,
4555                       convert (tree_type, integer_zero_node));
4556         /* Make sure SAVE_EXPRs get referenced early enough. */
4557         expr_tree
4558           = ffecom_2 (COMPOUND_EXPR, tree_type,
4559                       convert (void_type_node, arg1_tree),
4560                       ffecom_2 (COMPOUND_EXPR, tree_type,
4561                                 convert (void_type_node, arg2_tree),
4562                                 expr_tree));
4563       }
4564       return expr_tree;
4565
4566     case FFEINTRIN_impISHFTC:
4567       {
4568         tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4569         tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4570                                                     ffecom_expr (arg2)));
4571         tree arg3_tree = (arg3 == NULL) ? TYPE_SIZE (tree_type)
4572         : ffecom_save_tree (convert (integer_type_node, ffecom_expr (arg3)));
4573         tree shift_neg;
4574         tree shift_pos;
4575         tree mask_arg1;
4576         tree masked_arg1;
4577         tree uns_type
4578         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4579
4580         mask_arg1
4581           = ffecom_2 (LSHIFT_EXPR, tree_type,
4582                       ffecom_1 (BIT_NOT_EXPR, tree_type,
4583                                 convert (tree_type, integer_zero_node)),
4584                       arg3_tree);
4585         /* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE.  */
4586         mask_arg1
4587           = ffecom_3 (COND_EXPR, tree_type,
4588                       ffecom_truth_value
4589                       (ffecom_2 (NE_EXPR, integer_type_node,
4590                                  arg3_tree,
4591                                  TYPE_SIZE (uns_type))),
4592                       mask_arg1,
4593                       convert (tree_type, integer_zero_node));
4594         mask_arg1 = ffecom_save_tree (mask_arg1);
4595         masked_arg1
4596           = ffecom_2 (BIT_AND_EXPR, tree_type,
4597                       arg1_tree,
4598                       ffecom_1 (BIT_NOT_EXPR, tree_type,
4599                                 mask_arg1));
4600         masked_arg1 = ffecom_save_tree (masked_arg1);
4601         shift_neg
4602           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4603                       convert (tree_type,
4604                                ffecom_2 (RSHIFT_EXPR, uns_type,
4605                                          convert (uns_type, masked_arg1),
4606                                          ffecom_1 (NEGATE_EXPR,
4607                                                    integer_type_node,
4608                                                    arg2_tree))),
4609                       ffecom_2 (LSHIFT_EXPR, tree_type,
4610                                 arg1_tree,
4611                                 ffecom_2 (PLUS_EXPR, integer_type_node,
4612                                           arg2_tree,
4613                                           arg3_tree)));
4614         shift_pos
4615           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4616                       ffecom_2 (LSHIFT_EXPR, tree_type,
4617                                 arg1_tree,
4618                                 arg2_tree),
4619                       convert (tree_type,
4620                                ffecom_2 (RSHIFT_EXPR, uns_type,
4621                                          convert (uns_type, masked_arg1),
4622                                          ffecom_2 (MINUS_EXPR,
4623                                                    integer_type_node,
4624                                                    arg3_tree,
4625                                                    arg2_tree))));
4626         expr_tree
4627           = ffecom_3 (COND_EXPR, tree_type,
4628                       ffecom_truth_value
4629                       (ffecom_2 (LT_EXPR, integer_type_node,
4630                                  arg2_tree,
4631                                  integer_zero_node)),
4632                       shift_neg,
4633                       shift_pos);
4634         expr_tree
4635           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4636                       ffecom_2 (BIT_AND_EXPR, tree_type,
4637                                 mask_arg1,
4638                                 arg1_tree),
4639                       ffecom_2 (BIT_AND_EXPR, tree_type,
4640                                 ffecom_1 (BIT_NOT_EXPR, tree_type,
4641                                           mask_arg1),
4642                                 expr_tree));
4643         expr_tree
4644           = ffecom_3 (COND_EXPR, tree_type,
4645                       ffecom_truth_value
4646                       (ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
4647                                  ffecom_2 (EQ_EXPR, integer_type_node,
4648                                            ffecom_1 (ABS_EXPR,
4649                                                      integer_type_node,
4650                                                      arg2_tree),
4651                                            arg3_tree),
4652                                  ffecom_2 (EQ_EXPR, integer_type_node,
4653                                            arg2_tree,
4654                                            integer_zero_node))),
4655                       arg1_tree,
4656                       expr_tree);
4657         /* Make sure SAVE_EXPRs get referenced early enough. */
4658         expr_tree
4659           = ffecom_2 (COMPOUND_EXPR, tree_type,
4660                       convert (void_type_node, arg1_tree),
4661                       ffecom_2 (COMPOUND_EXPR, tree_type,
4662                                 convert (void_type_node, arg2_tree),
4663                                 ffecom_2 (COMPOUND_EXPR, tree_type,
4664                                           convert (void_type_node,
4665                                                    mask_arg1),
4666                                           ffecom_2 (COMPOUND_EXPR, tree_type,
4667                                                     convert (void_type_node,
4668                                                              masked_arg1),
4669                                                     expr_tree))));
4670         expr_tree
4671           = ffecom_2 (COMPOUND_EXPR, tree_type,
4672                       convert (void_type_node,
4673                                arg3_tree),
4674                       expr_tree);
4675       }
4676       return expr_tree;
4677
4678     case FFEINTRIN_impLOC:
4679       {
4680         tree arg1_tree = ffecom_expr (arg1);
4681
4682         expr_tree
4683           = convert (tree_type,
4684                      ffecom_1 (ADDR_EXPR,
4685                                build_pointer_type (TREE_TYPE (arg1_tree)),
4686                                arg1_tree));
4687       }
4688       return expr_tree;
4689
4690     case FFEINTRIN_impMVBITS:
4691       {
4692         tree arg1_tree;
4693         tree arg2_tree;
4694         tree arg3_tree;
4695         ffebld arg4 = ffebld_head (ffebld_trail (list));
4696         tree arg4_tree;
4697         tree arg4_type;
4698         ffebld arg5 = ffebld_head (ffebld_trail (ffebld_trail (list)));
4699         tree arg5_tree;
4700         tree prep_arg1;
4701         tree prep_arg4;
4702         tree arg5_plus_arg3;
4703
4704         arg2_tree = convert (integer_type_node,
4705                              ffecom_expr (arg2));
4706         arg3_tree = ffecom_save_tree (convert (integer_type_node,
4707                                                ffecom_expr (arg3)));
4708         arg4_tree = ffecom_expr_rw (NULL_TREE, arg4);
4709         arg4_type = TREE_TYPE (arg4_tree);
4710
4711         arg1_tree = ffecom_save_tree (convert (arg4_type,
4712                                                ffecom_expr (arg1)));
4713
4714         arg5_tree = ffecom_save_tree (convert (integer_type_node,
4715                                                ffecom_expr (arg5)));
4716
4717         prep_arg1
4718           = ffecom_2 (LSHIFT_EXPR, arg4_type,
4719                       ffecom_2 (BIT_AND_EXPR, arg4_type,
4720                                 ffecom_2 (RSHIFT_EXPR, arg4_type,
4721                                           arg1_tree,
4722                                           arg2_tree),
4723                                 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4724                                           ffecom_2 (LSHIFT_EXPR, arg4_type,
4725                                                     ffecom_1 (BIT_NOT_EXPR,
4726                                                               arg4_type,
4727                                                               convert
4728                                                               (arg4_type,
4729                                                         integer_zero_node)),
4730                                                     arg3_tree))),
4731                       arg5_tree);
4732         arg5_plus_arg3
4733           = ffecom_save_tree (ffecom_2 (PLUS_EXPR, arg4_type,
4734                                         arg5_tree,
4735                                         arg3_tree));
4736         prep_arg4
4737           = ffecom_2 (LSHIFT_EXPR, arg4_type,
4738                       ffecom_1 (BIT_NOT_EXPR, arg4_type,
4739                                 convert (arg4_type,
4740                                          integer_zero_node)),
4741                       arg5_plus_arg3);
4742         /* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE.  */
4743         prep_arg4
4744           = ffecom_3 (COND_EXPR, arg4_type,
4745                       ffecom_truth_value
4746                       (ffecom_2 (NE_EXPR, integer_type_node,
4747                                  arg5_plus_arg3,
4748                                  convert (TREE_TYPE (arg5_plus_arg3),
4749                                           TYPE_SIZE (arg4_type)))),
4750                       prep_arg4,
4751                       convert (arg4_type, integer_zero_node));
4752         prep_arg4
4753           = ffecom_2 (BIT_AND_EXPR, arg4_type,
4754                       arg4_tree,
4755                       ffecom_2 (BIT_IOR_EXPR, arg4_type,
4756                                 prep_arg4,
4757                                 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4758                                           ffecom_2 (LSHIFT_EXPR, arg4_type,
4759                                                     ffecom_1 (BIT_NOT_EXPR,
4760                                                               arg4_type,
4761                                                               convert
4762                                                               (arg4_type,
4763                                                         integer_zero_node)),
4764                                                     arg5_tree))));
4765         prep_arg1
4766           = ffecom_2 (BIT_IOR_EXPR, arg4_type,
4767                       prep_arg1,
4768                       prep_arg4);
4769         /* Fix up (twice), because LSHIFT_EXPR above
4770            can't shift over TYPE_SIZE.  */
4771         prep_arg1
4772           = ffecom_3 (COND_EXPR, arg4_type,
4773                       ffecom_truth_value
4774                       (ffecom_2 (NE_EXPR, integer_type_node,
4775                                  arg3_tree,
4776                                  convert (TREE_TYPE (arg3_tree),
4777                                           integer_zero_node))),
4778                       prep_arg1,
4779                       arg4_tree);
4780         prep_arg1
4781           = ffecom_3 (COND_EXPR, arg4_type,
4782                       ffecom_truth_value
4783                       (ffecom_2 (NE_EXPR, integer_type_node,
4784                                  arg3_tree,
4785                                  convert (TREE_TYPE (arg3_tree),
4786                                           TYPE_SIZE (arg4_type)))),
4787                       prep_arg1,
4788                       arg1_tree);
4789         expr_tree
4790           = ffecom_2s (MODIFY_EXPR, void_type_node,
4791                        arg4_tree,
4792                        prep_arg1);
4793         /* Make sure SAVE_EXPRs get referenced early enough. */
4794         expr_tree
4795           = ffecom_2 (COMPOUND_EXPR, void_type_node,
4796                       arg1_tree,
4797                       ffecom_2 (COMPOUND_EXPR, void_type_node,
4798                                 arg3_tree,
4799                                 ffecom_2 (COMPOUND_EXPR, void_type_node,
4800                                           arg5_tree,
4801                                           ffecom_2 (COMPOUND_EXPR, void_type_node,
4802                                                     arg5_plus_arg3,
4803                                                     expr_tree))));
4804         expr_tree
4805           = ffecom_2 (COMPOUND_EXPR, void_type_node,
4806                       arg4_tree,
4807                       expr_tree);
4808
4809       }
4810       return expr_tree;
4811
4812     case FFEINTRIN_impDERF:
4813     case FFEINTRIN_impERF:
4814     case FFEINTRIN_impDERFC:
4815     case FFEINTRIN_impERFC:
4816       break;
4817
4818     case FFEINTRIN_impIARGC:
4819       /* extern int xargc; i__1 = xargc - 1; */
4820       expr_tree = ffecom_2 (MINUS_EXPR, TREE_TYPE (ffecom_tree_xargc_),
4821                             ffecom_tree_xargc_,
4822                             convert (TREE_TYPE (ffecom_tree_xargc_),
4823                                      integer_one_node));
4824       return expr_tree;
4825
4826     case FFEINTRIN_impSIGNAL_func:
4827     case FFEINTRIN_impSIGNAL_subr:
4828       {
4829         tree arg1_tree;
4830         tree arg2_tree;
4831         tree arg3_tree;
4832
4833         arg1_tree = convert (ffecom_f2c_integer_type_node,
4834                              ffecom_expr (arg1));
4835         arg1_tree = ffecom_1 (ADDR_EXPR,
4836                               build_pointer_type (TREE_TYPE (arg1_tree)),
4837                               arg1_tree);
4838
4839         /* Pass procedure as a pointer to it, anything else by value.  */
4840         if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
4841           arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
4842         else
4843           arg2_tree = ffecom_ptr_to_expr (arg2);
4844         arg2_tree = convert (TREE_TYPE (null_pointer_node),
4845                              arg2_tree);
4846
4847         if (arg3 != NULL)
4848           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
4849         else
4850           arg3_tree = NULL_TREE;
4851
4852         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4853         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4854         TREE_CHAIN (arg1_tree) = arg2_tree;
4855
4856         expr_tree
4857           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4858                           ffecom_gfrt_kindtype (gfrt),
4859                           FALSE,
4860                           ((codegen_imp == FFEINTRIN_impSIGNAL_subr) ?
4861                            NULL_TREE :
4862                            tree_type),
4863                           arg1_tree,
4864                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4865                           ffebld_nonter_hook (expr));
4866
4867         if (arg3_tree != NULL_TREE)
4868           expr_tree
4869             = ffecom_modify (NULL_TREE, arg3_tree,
4870                              convert (TREE_TYPE (arg3_tree),
4871                                       expr_tree));
4872       }
4873       return expr_tree;
4874
4875     case FFEINTRIN_impALARM:
4876       {
4877         tree arg1_tree;
4878         tree arg2_tree;
4879         tree arg3_tree;
4880
4881         arg1_tree = convert (ffecom_f2c_integer_type_node,
4882                              ffecom_expr (arg1));
4883         arg1_tree = ffecom_1 (ADDR_EXPR,
4884                               build_pointer_type (TREE_TYPE (arg1_tree)),
4885                               arg1_tree);
4886
4887         /* Pass procedure as a pointer to it, anything else by value.  */
4888         if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
4889           arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
4890         else
4891           arg2_tree = ffecom_ptr_to_expr (arg2);
4892         arg2_tree = convert (TREE_TYPE (null_pointer_node),
4893                              arg2_tree);
4894
4895         if (arg3 != NULL)
4896           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
4897         else
4898           arg3_tree = NULL_TREE;
4899
4900         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4901         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4902         TREE_CHAIN (arg1_tree) = arg2_tree;
4903
4904         expr_tree
4905           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4906                           ffecom_gfrt_kindtype (gfrt),
4907                           FALSE,
4908                           NULL_TREE,
4909                           arg1_tree,
4910                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4911                           ffebld_nonter_hook (expr));
4912
4913         if (arg3_tree != NULL_TREE)
4914           expr_tree
4915             = ffecom_modify (NULL_TREE, arg3_tree,
4916                              convert (TREE_TYPE (arg3_tree),
4917                                       expr_tree));
4918       }
4919       return expr_tree;
4920
4921     case FFEINTRIN_impCHDIR_subr:
4922     case FFEINTRIN_impFDATE_subr:
4923     case FFEINTRIN_impFGET_subr:
4924     case FFEINTRIN_impFPUT_subr:
4925     case FFEINTRIN_impGETCWD_subr:
4926     case FFEINTRIN_impHOSTNM_subr:
4927     case FFEINTRIN_impSYSTEM_subr:
4928     case FFEINTRIN_impUNLINK_subr:
4929       {
4930         tree arg1_len = integer_zero_node;
4931         tree arg1_tree;
4932         tree arg2_tree;
4933
4934         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
4935
4936         if (arg2 != NULL)
4937           arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
4938         else
4939           arg2_tree = NULL_TREE;
4940
4941         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4942         arg1_len = build_tree_list (NULL_TREE, arg1_len);
4943         TREE_CHAIN (arg1_tree) = arg1_len;
4944
4945         expr_tree
4946           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4947                           ffecom_gfrt_kindtype (gfrt),
4948                           FALSE,
4949                           NULL_TREE,
4950                           arg1_tree,
4951                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4952                           ffebld_nonter_hook (expr));
4953
4954         if (arg2_tree != NULL_TREE)
4955           expr_tree
4956             = ffecom_modify (NULL_TREE, arg2_tree,
4957                              convert (TREE_TYPE (arg2_tree),
4958                                       expr_tree));
4959       }
4960       return expr_tree;
4961
4962     case FFEINTRIN_impEXIT:
4963       if (arg1 != NULL)
4964         break;
4965
4966       expr_tree = build_tree_list (NULL_TREE,
4967                                    ffecom_1 (ADDR_EXPR,
4968                                              build_pointer_type
4969                                              (ffecom_integer_type_node),
4970                                              integer_zero_node));
4971
4972       return
4973         ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4974                       ffecom_gfrt_kindtype (gfrt),
4975                       FALSE,
4976                       void_type_node,
4977                       expr_tree,
4978                       NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4979                       ffebld_nonter_hook (expr));
4980
4981     case FFEINTRIN_impFLUSH:
4982       if (arg1 == NULL)
4983         gfrt = FFECOM_gfrtFLUSH;
4984       else
4985         gfrt = FFECOM_gfrtFLUSH1;
4986       break;
4987
4988     case FFEINTRIN_impCHMOD_subr:
4989     case FFEINTRIN_impLINK_subr:
4990     case FFEINTRIN_impRENAME_subr:
4991     case FFEINTRIN_impSYMLNK_subr:
4992       {
4993         tree arg1_len = integer_zero_node;
4994         tree arg1_tree;
4995         tree arg2_len = integer_zero_node;
4996         tree arg2_tree;
4997         tree arg3_tree;
4998
4999         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5000         arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
5001         if (arg3 != NULL)
5002           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5003         else
5004           arg3_tree = NULL_TREE;
5005
5006         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5007         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5008         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5009         arg2_len = build_tree_list (NULL_TREE, arg2_len);
5010         TREE_CHAIN (arg1_tree) = arg2_tree;
5011         TREE_CHAIN (arg2_tree) = arg1_len;
5012         TREE_CHAIN (arg1_len) = arg2_len;
5013         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5014                                   ffecom_gfrt_kindtype (gfrt),
5015                                   FALSE,
5016                                   NULL_TREE,
5017                                   arg1_tree,
5018                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5019                                   ffebld_nonter_hook (expr));
5020         if (arg3_tree != NULL_TREE)
5021           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5022                                      convert (TREE_TYPE (arg3_tree),
5023                                               expr_tree));
5024       }
5025       return expr_tree;
5026
5027     case FFEINTRIN_impLSTAT_subr:
5028     case FFEINTRIN_impSTAT_subr:
5029       {
5030         tree arg1_len = integer_zero_node;
5031         tree arg1_tree;
5032         tree arg2_tree;
5033         tree arg3_tree;
5034
5035         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5036
5037         arg2_tree = ffecom_ptr_to_expr (arg2);
5038
5039         if (arg3 != NULL)
5040           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5041         else
5042           arg3_tree = NULL_TREE;
5043
5044         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5045         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5046         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5047         TREE_CHAIN (arg1_tree) = arg2_tree;
5048         TREE_CHAIN (arg2_tree) = arg1_len;
5049         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5050                                   ffecom_gfrt_kindtype (gfrt),
5051                                   FALSE,
5052                                   NULL_TREE,
5053                                   arg1_tree,
5054                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5055                                   ffebld_nonter_hook (expr));
5056         if (arg3_tree != NULL_TREE)
5057           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5058                                      convert (TREE_TYPE (arg3_tree),
5059                                               expr_tree));
5060       }
5061       return expr_tree;
5062
5063     case FFEINTRIN_impFGETC_subr:
5064     case FFEINTRIN_impFPUTC_subr:
5065       {
5066         tree arg1_tree;
5067         tree arg2_tree;
5068         tree arg2_len = integer_zero_node;
5069         tree arg3_tree;
5070
5071         arg1_tree = convert (ffecom_f2c_integer_type_node,
5072                              ffecom_expr (arg1));
5073         arg1_tree = ffecom_1 (ADDR_EXPR,
5074                               build_pointer_type (TREE_TYPE (arg1_tree)),
5075                               arg1_tree);
5076
5077         arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
5078         if (arg3 != NULL)
5079           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5080         else
5081           arg3_tree = NULL_TREE;
5082
5083         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5084         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5085         arg2_len = build_tree_list (NULL_TREE, arg2_len);
5086         TREE_CHAIN (arg1_tree) = arg2_tree;
5087         TREE_CHAIN (arg2_tree) = arg2_len;
5088
5089         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5090                                   ffecom_gfrt_kindtype (gfrt),
5091                                   FALSE,
5092                                   NULL_TREE,
5093                                   arg1_tree,
5094                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5095                                   ffebld_nonter_hook (expr));
5096         if (arg3_tree != NULL_TREE)
5097           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5098                                      convert (TREE_TYPE (arg3_tree),
5099                                               expr_tree));
5100       }
5101       return expr_tree;
5102
5103     case FFEINTRIN_impFSTAT_subr:
5104       {
5105         tree arg1_tree;
5106         tree arg2_tree;
5107         tree arg3_tree;
5108
5109         arg1_tree = convert (ffecom_f2c_integer_type_node,
5110                              ffecom_expr (arg1));
5111         arg1_tree = ffecom_1 (ADDR_EXPR,
5112                               build_pointer_type (TREE_TYPE (arg1_tree)),
5113                               arg1_tree);
5114
5115         arg2_tree = convert (ffecom_f2c_ptr_to_integer_type_node,
5116                              ffecom_ptr_to_expr (arg2));
5117
5118         if (arg3 == NULL)
5119           arg3_tree = NULL_TREE;
5120         else
5121           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5122
5123         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5124         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5125         TREE_CHAIN (arg1_tree) = arg2_tree;
5126         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5127                                   ffecom_gfrt_kindtype (gfrt),
5128                                   FALSE,
5129                                   NULL_TREE,
5130                                   arg1_tree,
5131                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5132                                   ffebld_nonter_hook (expr));
5133         if (arg3_tree != NULL_TREE) {
5134           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5135                                      convert (TREE_TYPE (arg3_tree),
5136                                               expr_tree));
5137         }
5138       }
5139       return expr_tree;
5140
5141     case FFEINTRIN_impKILL_subr:
5142       {
5143         tree arg1_tree;
5144         tree arg2_tree;
5145         tree arg3_tree;
5146
5147         arg1_tree = convert (ffecom_f2c_integer_type_node,
5148                              ffecom_expr (arg1));
5149         arg1_tree = ffecom_1 (ADDR_EXPR,
5150                               build_pointer_type (TREE_TYPE (arg1_tree)),
5151                               arg1_tree);
5152
5153         arg2_tree = convert (ffecom_f2c_integer_type_node,
5154                              ffecom_expr (arg2));
5155         arg2_tree = ffecom_1 (ADDR_EXPR,
5156                               build_pointer_type (TREE_TYPE (arg2_tree)),
5157                               arg2_tree);
5158
5159         if (arg3 == NULL)
5160           arg3_tree = NULL_TREE;
5161         else
5162           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5163
5164         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5165         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5166         TREE_CHAIN (arg1_tree) = arg2_tree;
5167         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5168                                   ffecom_gfrt_kindtype (gfrt),
5169                                   FALSE,
5170                                   NULL_TREE,
5171                                   arg1_tree,
5172                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5173                                   ffebld_nonter_hook (expr));
5174         if (arg3_tree != NULL_TREE) {
5175           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5176                                      convert (TREE_TYPE (arg3_tree),
5177                                               expr_tree));
5178         }
5179       }
5180       return expr_tree;
5181
5182     case FFEINTRIN_impCTIME_subr:
5183     case FFEINTRIN_impTTYNAM_subr:
5184       {
5185         tree arg1_len = integer_zero_node;
5186         tree arg1_tree;
5187         tree arg2_tree;
5188
5189         arg1_tree = ffecom_arg_ptr_to_expr (arg2, &arg1_len);
5190
5191         arg2_tree = convert (((codegen_imp == FFEINTRIN_impCTIME_subr) ?
5192                               ffecom_f2c_longint_type_node :
5193                               ffecom_f2c_integer_type_node),
5194                              ffecom_expr (arg1));
5195         arg2_tree = ffecom_1 (ADDR_EXPR,
5196                               build_pointer_type (TREE_TYPE (arg2_tree)),
5197                               arg2_tree);
5198
5199         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5200         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5201         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5202         TREE_CHAIN (arg1_len) = arg2_tree;
5203         TREE_CHAIN (arg1_tree) = arg1_len;
5204
5205         expr_tree
5206           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5207                           ffecom_gfrt_kindtype (gfrt),
5208                           FALSE,
5209                           NULL_TREE,
5210                           arg1_tree,
5211                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5212                           ffebld_nonter_hook (expr));
5213         TREE_SIDE_EFFECTS (expr_tree) = 1;
5214       }
5215       return expr_tree;
5216
5217     case FFEINTRIN_impIRAND:
5218     case FFEINTRIN_impRAND:
5219       /* Arg defaults to 0 (normal random case) */
5220       {
5221         tree arg1_tree;
5222
5223         if (arg1 == NULL)
5224           arg1_tree = ffecom_integer_zero_node;
5225         else
5226           arg1_tree = ffecom_expr (arg1);
5227         arg1_tree = convert (ffecom_f2c_integer_type_node,
5228                              arg1_tree);
5229         arg1_tree = ffecom_1 (ADDR_EXPR,
5230                               build_pointer_type (TREE_TYPE (arg1_tree)),
5231                               arg1_tree);
5232         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5233
5234         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5235                                   ffecom_gfrt_kindtype (gfrt),
5236                                   FALSE,
5237                                   ((codegen_imp == FFEINTRIN_impIRAND) ?
5238                                    ffecom_f2c_integer_type_node :
5239                                    ffecom_f2c_real_type_node),
5240                                   arg1_tree,
5241                                   dest_tree, dest, dest_used,
5242                                   NULL_TREE, TRUE,
5243                                   ffebld_nonter_hook (expr));
5244       }
5245       return expr_tree;
5246
5247     case FFEINTRIN_impFTELL_subr:
5248     case FFEINTRIN_impUMASK_subr:
5249       {
5250         tree arg1_tree;
5251         tree arg2_tree;
5252
5253         arg1_tree = convert (ffecom_f2c_integer_type_node,
5254                              ffecom_expr (arg1));
5255         arg1_tree = ffecom_1 (ADDR_EXPR,
5256                               build_pointer_type (TREE_TYPE (arg1_tree)),
5257                               arg1_tree);
5258
5259         if (arg2 == NULL)
5260           arg2_tree = NULL_TREE;
5261         else
5262           arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
5263
5264         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5265                                   ffecom_gfrt_kindtype (gfrt),
5266                                   FALSE,
5267                                   NULL_TREE,
5268                                   build_tree_list (NULL_TREE, arg1_tree),
5269                                   NULL_TREE, NULL, NULL, NULL_TREE,
5270                                   TRUE,
5271                                   ffebld_nonter_hook (expr));
5272         if (arg2_tree != NULL_TREE) {
5273           expr_tree = ffecom_modify (NULL_TREE, arg2_tree,
5274                                      convert (TREE_TYPE (arg2_tree),
5275                                               expr_tree));
5276         }
5277       }
5278       return expr_tree;
5279
5280     case FFEINTRIN_impCPU_TIME:
5281     case FFEINTRIN_impSECOND_subr:
5282       {
5283         tree arg1_tree;
5284
5285         arg1_tree = ffecom_expr_w (NULL_TREE, arg1);
5286
5287         expr_tree
5288           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5289                           ffecom_gfrt_kindtype (gfrt),
5290                           FALSE,
5291                           NULL_TREE,
5292                           NULL_TREE,
5293                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5294                           ffebld_nonter_hook (expr));
5295
5296         expr_tree
5297           = ffecom_modify (NULL_TREE, arg1_tree,
5298                            convert (TREE_TYPE (arg1_tree),
5299                                     expr_tree));
5300       }
5301       return expr_tree;
5302
5303     case FFEINTRIN_impDTIME_subr:
5304     case FFEINTRIN_impETIME_subr:
5305       {
5306         tree arg1_tree;
5307         tree result_tree;
5308
5309         result_tree = ffecom_expr_w (NULL_TREE, arg2);
5310
5311         arg1_tree = ffecom_ptr_to_expr (arg1);
5312
5313         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5314                                   ffecom_gfrt_kindtype (gfrt),
5315                                   FALSE,
5316                                   NULL_TREE,
5317                                   build_tree_list (NULL_TREE, arg1_tree),
5318                                   NULL_TREE, NULL, NULL, NULL_TREE,
5319                                   TRUE,
5320                                   ffebld_nonter_hook (expr));
5321         expr_tree = ffecom_modify (NULL_TREE, result_tree,
5322                                    convert (TREE_TYPE (result_tree),
5323                                             expr_tree));
5324       }
5325       return expr_tree;
5326
5327       /* Straightforward calls of libf2c routines: */
5328     case FFEINTRIN_impABORT:
5329     case FFEINTRIN_impACCESS:
5330     case FFEINTRIN_impBESJ0:
5331     case FFEINTRIN_impBESJ1:
5332     case FFEINTRIN_impBESJN:
5333     case FFEINTRIN_impBESY0:
5334     case FFEINTRIN_impBESY1:
5335     case FFEINTRIN_impBESYN:
5336     case FFEINTRIN_impCHDIR_func:
5337     case FFEINTRIN_impCHMOD_func:
5338     case FFEINTRIN_impDATE:
5339     case FFEINTRIN_impDATE_AND_TIME:
5340     case FFEINTRIN_impDBESJ0:
5341     case FFEINTRIN_impDBESJ1:
5342     case FFEINTRIN_impDBESJN:
5343     case FFEINTRIN_impDBESY0:
5344     case FFEINTRIN_impDBESY1:
5345     case FFEINTRIN_impDBESYN:
5346     case FFEINTRIN_impDTIME_func:
5347     case FFEINTRIN_impETIME_func:
5348     case FFEINTRIN_impFGETC_func:
5349     case FFEINTRIN_impFGET_func:
5350     case FFEINTRIN_impFNUM:
5351     case FFEINTRIN_impFPUTC_func:
5352     case FFEINTRIN_impFPUT_func:
5353     case FFEINTRIN_impFSEEK:
5354     case FFEINTRIN_impFSTAT_func:
5355     case FFEINTRIN_impFTELL_func:
5356     case FFEINTRIN_impGERROR:
5357     case FFEINTRIN_impGETARG:
5358     case FFEINTRIN_impGETCWD_func:
5359     case FFEINTRIN_impGETENV:
5360     case FFEINTRIN_impGETGID:
5361     case FFEINTRIN_impGETLOG:
5362     case FFEINTRIN_impGETPID:
5363     case FFEINTRIN_impGETUID:
5364     case FFEINTRIN_impGMTIME:
5365     case FFEINTRIN_impHOSTNM_func:
5366     case FFEINTRIN_impIDATE_unix:
5367     case FFEINTRIN_impIDATE_vxt:
5368     case FFEINTRIN_impIERRNO:
5369     case FFEINTRIN_impISATTY:
5370     case FFEINTRIN_impITIME:
5371     case FFEINTRIN_impKILL_func:
5372     case FFEINTRIN_impLINK_func:
5373     case FFEINTRIN_impLNBLNK:
5374     case FFEINTRIN_impLSTAT_func:
5375     case FFEINTRIN_impLTIME:
5376     case FFEINTRIN_impMCLOCK8:
5377     case FFEINTRIN_impMCLOCK:
5378     case FFEINTRIN_impPERROR:
5379     case FFEINTRIN_impRENAME_func:
5380     case FFEINTRIN_impSECNDS:
5381     case FFEINTRIN_impSECOND_func:
5382     case FFEINTRIN_impSLEEP:
5383     case FFEINTRIN_impSRAND:
5384     case FFEINTRIN_impSTAT_func:
5385     case FFEINTRIN_impSYMLNK_func:
5386     case FFEINTRIN_impSYSTEM_CLOCK:
5387     case FFEINTRIN_impSYSTEM_func:
5388     case FFEINTRIN_impTIME8:
5389     case FFEINTRIN_impTIME_unix:
5390     case FFEINTRIN_impTIME_vxt:
5391     case FFEINTRIN_impUMASK_func:
5392     case FFEINTRIN_impUNLINK_func:
5393       break;
5394
5395     case FFEINTRIN_impCTIME_func:       /* CHARACTER functions not handled here. */
5396     case FFEINTRIN_impFDATE_func:       /* CHARACTER functions not handled here. */
5397     case FFEINTRIN_impTTYNAM_func:      /* CHARACTER functions not handled here. */
5398     case FFEINTRIN_impNONE:
5399     case FFEINTRIN_imp:         /* Hush up gcc warning. */
5400       fprintf (stderr, "No %s implementation.\n",
5401                ffeintrin_name_implementation (ffebld_symter_implementation (ffebld_left (expr))));
5402       assert ("unimplemented intrinsic" == NULL);
5403       return error_mark_node;
5404     }
5405
5406   assert (gfrt != FFECOM_gfrt); /* Must have an implementation! */
5407
5408   expr_tree = ffecom_arglist_expr_ (ffecom_gfrt_args_ (gfrt),
5409                                     ffebld_right (expr));
5410
5411   return ffecom_call_ (ffecom_gfrt_tree_ (gfrt), ffecom_gfrt_kindtype (gfrt),
5412                        (ffe_is_f2c_library () && ffecom_gfrt_complex_[gfrt]),
5413                        tree_type,
5414                        expr_tree, dest_tree, dest, dest_used,
5415                        NULL_TREE, TRUE,
5416                        ffebld_nonter_hook (expr));
5417
5418   /* See bottom of this file for f2c transforms used to determine
5419      many of the above implementations.  The info seems to confuse
5420      Emacs's C mode indentation, which is why it's been moved to
5421      the bottom of this source file.  */
5422 }
5423
5424 /* For power (exponentiation) where right-hand operand is type INTEGER,
5425    generate in-line code to do it the fast way (which, if the operand
5426    is a constant, might just mean a series of multiplies).  */
5427
5428 static tree
5429 ffecom_expr_power_integer_ (ffebld expr)
5430 {
5431   tree l = ffecom_expr (ffebld_left (expr));
5432   tree r = ffecom_expr (ffebld_right (expr));
5433   tree ltype = TREE_TYPE (l);
5434   tree rtype = TREE_TYPE (r);
5435   tree result = NULL_TREE;
5436
5437   if (l == error_mark_node
5438       || r == error_mark_node)
5439     return error_mark_node;
5440
5441   if (TREE_CODE (r) == INTEGER_CST)
5442     {
5443       int sgn = tree_int_cst_sgn (r);
5444
5445       if (sgn == 0)
5446         return convert (ltype, integer_one_node);
5447
5448       if ((TREE_CODE (ltype) == INTEGER_TYPE)
5449           && (sgn < 0))
5450         {
5451           /* Reciprocal of integer is either 0, -1, or 1, so after
5452              calculating that (which we leave to the back end to do
5453              or not do optimally), don't bother with any multiplying.  */
5454
5455           result = ffecom_tree_divide_ (ltype,
5456                                         convert (ltype, integer_one_node),
5457                                         l,
5458                                         NULL_TREE, NULL, NULL, NULL_TREE);
5459           r = ffecom_1 (NEGATE_EXPR,
5460                         rtype,
5461                         r);
5462           if ((TREE_INT_CST_LOW (r) & 1) == 0)
5463             result = ffecom_1 (ABS_EXPR, rtype,
5464                                result);
5465         }
5466
5467       /* Generate appropriate series of multiplies, preceded
5468          by divide if the exponent is negative.  */
5469
5470       l = save_expr (l);
5471
5472       if (sgn < 0)
5473         {
5474           l = ffecom_tree_divide_ (ltype,
5475                                    convert (ltype, integer_one_node),
5476                                    l,
5477                                    NULL_TREE, NULL, NULL,
5478                                    ffebld_nonter_hook (expr));
5479           r = ffecom_1 (NEGATE_EXPR, rtype, r);
5480           assert (TREE_CODE (r) == INTEGER_CST);
5481
5482           if (tree_int_cst_sgn (r) < 0)
5483             {                   /* The "most negative" number.  */
5484               r = ffecom_1 (NEGATE_EXPR, rtype,
5485                             ffecom_2 (RSHIFT_EXPR, rtype,
5486                                       r,
5487                                       integer_one_node));
5488               l = save_expr (l);
5489               l = ffecom_2 (MULT_EXPR, ltype,
5490                             l,
5491                             l);
5492             }
5493         }
5494
5495       for (;;)
5496         {
5497           if (TREE_INT_CST_LOW (r) & 1)
5498             {
5499               if (result == NULL_TREE)
5500                 result = l;
5501               else
5502                 result = ffecom_2 (MULT_EXPR, ltype,
5503                                    result,
5504                                    l);
5505             }
5506
5507           r = ffecom_2 (RSHIFT_EXPR, rtype,
5508                         r,
5509                         integer_one_node);
5510           if (integer_zerop (r))
5511             break;
5512           assert (TREE_CODE (r) == INTEGER_CST);
5513
5514           l = save_expr (l);
5515           l = ffecom_2 (MULT_EXPR, ltype,
5516                         l,
5517                         l);
5518         }
5519       return result;
5520     }
5521
5522   /* Though rhs isn't a constant, in-line code cannot be expanded
5523      while transforming dummies
5524      because the back end cannot be easily convinced to generate
5525      stores (MODIFY_EXPR), handle temporaries, and so on before
5526      all the appropriate rtx's have been generated for things like
5527      dummy args referenced in rhs -- which doesn't happen until
5528      store_parm_decls() is called (expand_function_start, I believe,
5529      does the actual rtx-stuffing of PARM_DECLs).
5530
5531      So, in this case, let the caller generate the call to the
5532      run-time-library function to evaluate the power for us.  */
5533
5534   if (ffecom_transform_only_dummies_)
5535     return NULL_TREE;
5536
5537   /* Right-hand operand not a constant, expand in-line code to figure
5538      out how to do the multiplies, &c.
5539
5540      The returned expression is expressed this way in GNU C, where l and
5541      r are the "inputs":
5542
5543      ({ typeof (r) rtmp = r;
5544         typeof (l) ltmp = l;
5545         typeof (l) result;
5546
5547         if (rtmp == 0)
5548           result = 1;
5549         else
5550           {
5551             if ((basetypeof (l) == basetypeof (int))
5552                 && (rtmp < 0))
5553               {
5554                 result = ((typeof (l)) 1) / ltmp;
5555                 if ((ltmp < 0) && (((-rtmp) & 1) == 0))
5556                   result = -result;
5557               }
5558             else
5559               {
5560                 result = 1;
5561                 if ((basetypeof (l) != basetypeof (int))
5562                     && (rtmp < 0))
5563                   {
5564                     ltmp = ((typeof (l)) 1) / ltmp;
5565                     rtmp = -rtmp;
5566                     if (rtmp < 0)
5567                       {
5568                         rtmp = -(rtmp >> 1);
5569                         ltmp *= ltmp;
5570                       }
5571                   }
5572                 for (;;)
5573                   {
5574                     if (rtmp & 1)
5575                       result *= ltmp;
5576                     if ((rtmp >>= 1) == 0)
5577                       break;
5578                     ltmp *= ltmp;
5579                   }
5580               }
5581           }
5582         result;
5583      })
5584
5585      Note that some of the above is compile-time collapsable, such as
5586      the first part of the if statements that checks the base type of
5587      l against int.  The if statements are phrased that way to suggest
5588      an easy way to generate the if/else constructs here, knowing that
5589      the back end should (and probably does) eliminate the resulting
5590      dead code (either the int case or the non-int case), something
5591      it couldn't do without the redundant phrasing, requiring explicit
5592      dead-code elimination here, which would be kind of difficult to
5593      read.  */
5594
5595   {
5596     tree rtmp;
5597     tree ltmp;
5598     tree divide;
5599     tree basetypeof_l_is_int;
5600     tree se;
5601     tree t;
5602
5603     basetypeof_l_is_int
5604       = build_int_2 ((TREE_CODE (ltype) == INTEGER_TYPE), 0);
5605
5606     se = expand_start_stmt_expr (/*has_scope=*/1);
5607
5608     ffecom_start_compstmt ();
5609
5610 #ifndef HAHA
5611     rtmp = ffecom_make_tempvar ("power_r", rtype,
5612                                 FFETARGET_charactersizeNONE, -1);
5613     ltmp = ffecom_make_tempvar ("power_l", ltype,
5614                                 FFETARGET_charactersizeNONE, -1);
5615     result = ffecom_make_tempvar ("power_res", ltype,
5616                                   FFETARGET_charactersizeNONE, -1);
5617     if (TREE_CODE (ltype) == COMPLEX_TYPE
5618         || TREE_CODE (ltype) == RECORD_TYPE)
5619       divide = ffecom_make_tempvar ("power_div", ltype,
5620                                     FFETARGET_charactersizeNONE, -1);
5621     else
5622       divide = NULL_TREE;
5623 #else  /* HAHA */
5624     {
5625       tree hook;
5626
5627       hook = ffebld_nonter_hook (expr);
5628       assert (hook);
5629       assert (TREE_CODE (hook) == TREE_VEC);
5630       assert (TREE_VEC_LENGTH (hook) == 4);
5631       rtmp = TREE_VEC_ELT (hook, 0);
5632       ltmp = TREE_VEC_ELT (hook, 1);
5633       result = TREE_VEC_ELT (hook, 2);
5634       divide = TREE_VEC_ELT (hook, 3);
5635       if (TREE_CODE (ltype) == COMPLEX_TYPE
5636           || TREE_CODE (ltype) == RECORD_TYPE)
5637         assert (divide);
5638       else
5639         assert (! divide);
5640     }
5641 #endif  /* HAHA */
5642
5643     expand_expr_stmt (ffecom_modify (void_type_node,
5644                                      rtmp,
5645                                      r));
5646     expand_expr_stmt (ffecom_modify (void_type_node,
5647                                      ltmp,
5648                                      l));
5649     expand_start_cond (ffecom_truth_value
5650                        (ffecom_2 (EQ_EXPR, integer_type_node,
5651                                   rtmp,
5652                                   convert (rtype, integer_zero_node))),
5653                        0);
5654     expand_expr_stmt (ffecom_modify (void_type_node,
5655                                      result,
5656                                      convert (ltype, integer_one_node)));
5657     expand_start_else ();
5658     if (! integer_zerop (basetypeof_l_is_int))
5659       {
5660         expand_start_cond (ffecom_2 (LT_EXPR, integer_type_node,
5661                                      rtmp,
5662                                      convert (rtype,
5663                                               integer_zero_node)),
5664                            0);
5665         expand_expr_stmt (ffecom_modify (void_type_node,
5666                                          result,
5667                                          ffecom_tree_divide_
5668                                          (ltype,
5669                                           convert (ltype, integer_one_node),
5670                                           ltmp,
5671                                           NULL_TREE, NULL, NULL,
5672                                           divide)));
5673         expand_start_cond (ffecom_truth_value
5674                            (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5675                                       ffecom_2 (LT_EXPR, integer_type_node,
5676                                                 ltmp,
5677                                                 convert (ltype,
5678                                                          integer_zero_node)),
5679                                       ffecom_2 (EQ_EXPR, integer_type_node,
5680                                                 ffecom_2 (BIT_AND_EXPR,
5681                                                           rtype,
5682                                                           ffecom_1 (NEGATE_EXPR,
5683                                                                     rtype,
5684                                                                     rtmp),
5685                                                           convert (rtype,
5686                                                                    integer_one_node)),
5687                                                 convert (rtype,
5688                                                          integer_zero_node)))),
5689                            0);
5690         expand_expr_stmt (ffecom_modify (void_type_node,
5691                                          result,
5692                                          ffecom_1 (NEGATE_EXPR,
5693                                                    ltype,
5694                                                    result)));
5695         expand_end_cond ();
5696         expand_start_else ();
5697       }
5698     expand_expr_stmt (ffecom_modify (void_type_node,
5699                                      result,
5700                                      convert (ltype, integer_one_node)));
5701     expand_start_cond (ffecom_truth_value
5702                        (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5703                                   ffecom_truth_value_invert
5704                                   (basetypeof_l_is_int),
5705                                   ffecom_2 (LT_EXPR, integer_type_node,
5706                                             rtmp,
5707                                             convert (rtype,
5708                                                      integer_zero_node)))),
5709                        0);
5710     expand_expr_stmt (ffecom_modify (void_type_node,
5711                                      ltmp,
5712                                      ffecom_tree_divide_
5713                                      (ltype,
5714                                       convert (ltype, integer_one_node),
5715                                       ltmp,
5716                                       NULL_TREE, NULL, NULL,
5717                                       divide)));
5718     expand_expr_stmt (ffecom_modify (void_type_node,
5719                                      rtmp,
5720                                      ffecom_1 (NEGATE_EXPR, rtype,
5721                                                rtmp)));
5722     expand_start_cond (ffecom_truth_value
5723                        (ffecom_2 (LT_EXPR, integer_type_node,
5724                                   rtmp,
5725                                   convert (rtype, integer_zero_node))),
5726                        0);
5727     expand_expr_stmt (ffecom_modify (void_type_node,
5728                                      rtmp,
5729                                      ffecom_1 (NEGATE_EXPR, rtype,
5730                                                ffecom_2 (RSHIFT_EXPR,
5731                                                          rtype,
5732                                                          rtmp,
5733                                                          integer_one_node))));
5734     expand_expr_stmt (ffecom_modify (void_type_node,
5735                                      ltmp,
5736                                      ffecom_2 (MULT_EXPR, ltype,
5737                                                ltmp,
5738                                                ltmp)));
5739     expand_end_cond ();
5740     expand_end_cond ();
5741     expand_start_loop (1);
5742     expand_start_cond (ffecom_truth_value
5743                        (ffecom_2 (BIT_AND_EXPR, rtype,
5744                                   rtmp,
5745                                   convert (rtype, integer_one_node))),
5746                        0);
5747     expand_expr_stmt (ffecom_modify (void_type_node,
5748                                      result,
5749                                      ffecom_2 (MULT_EXPR, ltype,
5750                                                result,
5751                                                ltmp)));
5752     expand_end_cond ();
5753     expand_exit_loop_if_false (NULL,
5754                                ffecom_truth_value
5755                                (ffecom_modify (rtype,
5756                                                rtmp,
5757                                                ffecom_2 (RSHIFT_EXPR,
5758                                                          rtype,
5759                                                          rtmp,
5760                                                          integer_one_node))));
5761     expand_expr_stmt (ffecom_modify (void_type_node,
5762                                      ltmp,
5763                                      ffecom_2 (MULT_EXPR, ltype,
5764                                                ltmp,
5765                                                ltmp)));
5766     expand_end_loop ();
5767     expand_end_cond ();
5768     if (!integer_zerop (basetypeof_l_is_int))
5769       expand_end_cond ();
5770     expand_expr_stmt (result);
5771
5772     t = ffecom_end_compstmt ();
5773
5774     result = expand_end_stmt_expr (se);
5775
5776     /* This code comes from c-parse.in, after its expand_end_stmt_expr.  */
5777
5778     if (TREE_CODE (t) == BLOCK)
5779       {
5780         /* Make a BIND_EXPR for the BLOCK already made.  */
5781         result = build (BIND_EXPR, TREE_TYPE (result),
5782                         NULL_TREE, result, t);
5783         /* Remove the block from the tree at this point.
5784            It gets put back at the proper place
5785            when the BIND_EXPR is expanded.  */
5786         delete_block (t);
5787       }
5788     else
5789       result = t;
5790   }
5791
5792   return result;
5793 }
5794
5795 /* ffecom_expr_transform_ -- Transform symbols in expr
5796
5797    ffebld expr;  // FFE expression.
5798    ffecom_expr_transform_ (expr);
5799
5800    Recursive descent on expr while transforming any untransformed SYMTERs.  */
5801
5802 static void
5803 ffecom_expr_transform_ (ffebld expr)
5804 {
5805   tree t;
5806   ffesymbol s;
5807
5808  tail_recurse:
5809
5810   if (expr == NULL)
5811     return;
5812
5813   switch (ffebld_op (expr))
5814     {
5815     case FFEBLD_opSYMTER:
5816       s = ffebld_symter (expr);
5817       t = ffesymbol_hook (s).decl_tree;
5818       if ((t == NULL_TREE)
5819           && ((ffesymbol_kind (s) != FFEINFO_kindNONE)
5820               || ((ffesymbol_where (s) != FFEINFO_whereNONE)
5821                   && (ffesymbol_where (s) != FFEINFO_whereINTRINSIC))))
5822         {
5823           s = ffecom_sym_transform_ (s);
5824           t = ffesymbol_hook (s).decl_tree;     /* Sfunc expr non-dummy,
5825                                                    DIMENSION expr? */
5826         }
5827       break;                    /* Ok if (t == NULL) here. */
5828
5829     case FFEBLD_opITEM:
5830       ffecom_expr_transform_ (ffebld_head (expr));
5831       expr = ffebld_trail (expr);
5832       goto tail_recurse;        /* :::::::::::::::::::: */
5833
5834     default:
5835       break;
5836     }
5837
5838   switch (ffebld_arity (expr))
5839     {
5840     case 2:
5841       ffecom_expr_transform_ (ffebld_left (expr));
5842       expr = ffebld_right (expr);
5843       goto tail_recurse;        /* :::::::::::::::::::: */
5844
5845     case 1:
5846       expr = ffebld_left (expr);
5847       goto tail_recurse;        /* :::::::::::::::::::: */
5848
5849     default:
5850       break;
5851     }
5852
5853   return;
5854 }
5855
5856 /* Make a type based on info in live f2c.h file.  */
5857
5858 static void
5859 ffecom_f2c_make_type_ (tree *type, int tcode, const char *name)
5860 {
5861   switch (tcode)
5862     {
5863     case FFECOM_f2ccodeCHAR:
5864       *type = make_signed_type (CHAR_TYPE_SIZE);
5865       break;
5866
5867     case FFECOM_f2ccodeSHORT:
5868       *type = make_signed_type (SHORT_TYPE_SIZE);
5869       break;
5870
5871     case FFECOM_f2ccodeINT:
5872       *type = make_signed_type (INT_TYPE_SIZE);
5873       break;
5874
5875     case FFECOM_f2ccodeLONG:
5876       *type = make_signed_type (LONG_TYPE_SIZE);
5877       break;
5878
5879     case FFECOM_f2ccodeLONGLONG:
5880       *type = make_signed_type (LONG_LONG_TYPE_SIZE);
5881       break;
5882
5883     case FFECOM_f2ccodeCHARPTR:
5884       *type = build_pointer_type (DEFAULT_SIGNED_CHAR
5885                                   ? signed_char_type_node
5886                                   : unsigned_char_type_node);
5887       break;
5888
5889     case FFECOM_f2ccodeFLOAT:
5890       *type = make_node (REAL_TYPE);
5891       TYPE_PRECISION (*type) = FLOAT_TYPE_SIZE;
5892       layout_type (*type);
5893       break;
5894
5895     case FFECOM_f2ccodeDOUBLE:
5896       *type = make_node (REAL_TYPE);
5897       TYPE_PRECISION (*type) = DOUBLE_TYPE_SIZE;
5898       layout_type (*type);
5899       break;
5900
5901     case FFECOM_f2ccodeLONGDOUBLE:
5902       *type = make_node (REAL_TYPE);
5903       TYPE_PRECISION (*type) = LONG_DOUBLE_TYPE_SIZE;
5904       layout_type (*type);
5905       break;
5906
5907     case FFECOM_f2ccodeTWOREALS:
5908       *type = ffecom_make_complex_type_ (ffecom_f2c_real_type_node);
5909       break;
5910
5911     case FFECOM_f2ccodeTWODOUBLEREALS:
5912       *type = ffecom_make_complex_type_ (ffecom_f2c_doublereal_type_node);
5913       break;
5914
5915     default:
5916       assert ("unexpected FFECOM_f2ccodeXYZZY!" == NULL);
5917       *type = error_mark_node;
5918       return;
5919     }
5920
5921   pushdecl (build_decl (TYPE_DECL,
5922                         ffecom_get_invented_identifier ("__g77_f2c_%s", name),
5923                         *type));
5924 }
5925
5926 /* Set the f2c list-directed-I/O code for whatever (integral) type has the
5927    given size.  */
5928
5929 static void
5930 ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
5931                           int code)
5932 {
5933   int j;
5934   tree t;
5935
5936   for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
5937     if ((t = ffecom_tree_type[bt][j]) != NULL_TREE
5938         && compare_tree_int (TYPE_SIZE (t), size) == 0)
5939       {
5940         assert (code != -1);
5941         ffecom_f2c_typecode_[bt][j] = code;
5942         code = -1;
5943       }
5944 }
5945
5946 /* Finish up globals after doing all program units in file
5947
5948    Need to handle only uninitialized COMMON areas.  */
5949
5950 static ffeglobal
5951 ffecom_finish_global_ (ffeglobal global)
5952 {
5953   tree cbtype;
5954   tree cbt;
5955   tree size;
5956
5957   if (ffeglobal_type (global) != FFEGLOBAL_typeCOMMON)
5958       return global;
5959
5960   if (ffeglobal_common_init (global))
5961       return global;
5962
5963   cbt = ffeglobal_hook (global);
5964   if ((cbt == NULL_TREE)
5965       || !ffeglobal_common_have_size (global))
5966     return global;              /* No need to make common, never ref'd. */
5967
5968   DECL_EXTERNAL (cbt) = 0;
5969
5970   /* Give the array a size now.  */
5971
5972   size = build_int_2 ((ffeglobal_common_size (global)
5973                       + ffeglobal_common_pad (global)) - 1,
5974                       0);
5975
5976   cbtype = TREE_TYPE (cbt);
5977   TYPE_DOMAIN (cbtype) = build_range_type (integer_type_node,
5978                                            integer_zero_node,
5979                                            size);
5980   if (!TREE_TYPE (size))
5981     TREE_TYPE (size) = TYPE_DOMAIN (cbtype);
5982   layout_type (cbtype);
5983
5984   cbt = start_decl (cbt, FALSE);
5985   assert (cbt == ffeglobal_hook (global));
5986
5987   finish_decl (cbt, NULL_TREE, FALSE);
5988
5989   return global;
5990 }
5991
5992 /* Finish up any untransformed symbols.  */
5993
5994 static ffesymbol
5995 ffecom_finish_symbol_transform_ (ffesymbol s)
5996 {
5997   if ((s == NULL) || (TREE_CODE (current_function_decl) == ERROR_MARK))
5998     return s;
5999
6000   /* It's easy to know to transform an untransformed symbol, to make sure
6001      we put out debugging info for it.  But COMMON variables, unlike
6002      EQUIVALENCE ones, aren't given declarations in addition to the
6003      tree expressions that specify offsets, because COMMON variables
6004      can be referenced in the outer scope where only dummy arguments
6005      (PARM_DECLs) should really be seen.  To be safe, just don't do any
6006      VAR_DECLs for COMMON variables when we transform them for real
6007      use, and therefore we do all the VAR_DECL creating here.  */
6008
6009   if (ffesymbol_hook (s).decl_tree == NULL_TREE)
6010     {
6011       if (ffesymbol_kind (s) != FFEINFO_kindNONE
6012           || (ffesymbol_where (s) != FFEINFO_whereNONE
6013               && ffesymbol_where (s) != FFEINFO_whereINTRINSIC
6014               && ffesymbol_where (s) != FFEINFO_whereDUMMY))
6015         /* Not transformed, and not CHARACTER*(*), and not a dummy
6016            argument, which can happen only if the entry point names
6017            it "rides in on" are all invalidated for other reasons.  */
6018         s = ffecom_sym_transform_ (s);
6019     }
6020
6021   if ((ffesymbol_where (s) == FFEINFO_whereCOMMON)
6022       && (ffesymbol_hook (s).decl_tree != error_mark_node))
6023     {
6024       /* This isn't working, at least for dbxout.  The .s file looks
6025          okay to me (burley), but in gdb 4.9 at least, the variables
6026          appear to reside somewhere outside of the common area, so
6027          it doesn't make sense to mislead anyone by generating the info
6028          on those variables until this is fixed.  NOTE: Same problem
6029          with EQUIVALENCE, sadly...see similar #if later.  */
6030       ffecom_member_phase2_ (ffesymbol_storage (ffesymbol_common (s)),
6031                              ffesymbol_storage (s));
6032     }
6033
6034   return s;
6035 }
6036
6037 /* Append underscore(s) to name before calling get_identifier.  "us"
6038    is nonzero if the name already contains an underscore and thus
6039    needs two underscores appended.  */
6040
6041 static tree
6042 ffecom_get_appended_identifier_ (char us, const char *name)
6043 {
6044   int i;
6045   char *newname;
6046   tree id;
6047
6048   newname = xmalloc ((i = strlen (name)) + 1
6049                      + ffe_is_underscoring ()
6050                      + us);
6051   memcpy (newname, name, i);
6052   newname[i] = '_';
6053   newname[i + us] = '_';
6054   newname[i + 1 + us] = '\0';
6055   id = get_identifier (newname);
6056
6057   free (newname);
6058
6059   return id;
6060 }
6061
6062 /* Decide whether to append underscore to name before calling
6063    get_identifier.  */
6064
6065 static tree
6066 ffecom_get_external_identifier_ (ffesymbol s)
6067 {
6068   char us;
6069   const char *name = ffesymbol_text (s);
6070
6071   /* If name is a built-in name, just return it as is.  */
6072
6073   if (!ffe_is_underscoring ()
6074       || (strcmp (name, FFETARGET_nameBLANK_COMMON) == 0)
6075 #if FFETARGET_isENFORCED_MAIN_NAME
6076       || (strcmp (name, FFETARGET_nameENFORCED_NAME) == 0)
6077 #else
6078       || (strcmp (name, FFETARGET_nameUNNAMED_MAIN) == 0)
6079 #endif
6080       || (strcmp (name, FFETARGET_nameUNNAMED_BLOCK_DATA) == 0))
6081     return get_identifier (name);
6082
6083   us = ffe_is_second_underscore ()
6084     ? (strchr (name, '_') != NULL)
6085       : 0;
6086
6087   return ffecom_get_appended_identifier_ (us, name);
6088 }
6089
6090 /* Decide whether to append underscore to internal name before calling
6091    get_identifier.
6092
6093    This is for non-external, top-function-context names only.  Transform
6094    identifier so it doesn't conflict with the transformed result
6095    of using a _different_ external name.  E.g. if "CALL FOO" is
6096    transformed into "FOO_();", then the variable in "FOO_ = 3"
6097    must be transformed into something that does not conflict, since
6098    these two things should be independent.
6099
6100    The transformation is as follows.  If the name does not contain
6101    an underscore, there is no possible conflict, so just return.
6102    If the name does contain an underscore, then transform it just
6103    like we transform an external identifier.  */
6104
6105 static tree
6106 ffecom_get_identifier_ (const char *name)
6107 {
6108   /* If name does not contain an underscore, just return it as is.  */
6109
6110   if (!ffe_is_underscoring ()
6111       || (strchr (name, '_') == NULL))
6112     return get_identifier (name);
6113
6114   return ffecom_get_appended_identifier_ (ffe_is_second_underscore (),
6115                                           name);
6116 }
6117
6118 /* ffecom_gen_sfuncdef_ -- Generate definition of statement function
6119
6120    tree t;
6121    ffesymbol s;  // kindFUNCTION, whereIMMEDIATE.
6122    t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s),
6123          ffesymbol_kindtype(s));
6124
6125    Call after setting up containing function and getting trees for all
6126    other symbols.  */
6127
6128 static tree
6129 ffecom_gen_sfuncdef_ (ffesymbol s, ffeinfoBasictype bt, ffeinfoKindtype kt)
6130 {
6131   ffebld expr = ffesymbol_sfexpr (s);
6132   tree type;
6133   tree func;
6134   tree result;
6135   bool charfunc = (bt == FFEINFO_basictypeCHARACTER);
6136   static bool recurse = FALSE;
6137   int old_lineno = lineno;
6138   const char *old_input_filename = input_filename;
6139
6140   ffecom_nested_entry_ = s;
6141
6142   /* For now, we don't have a handy pointer to where the sfunc is actually
6143      defined, though that should be easy to add to an ffesymbol. (The
6144      token/where info available might well point to the place where the type
6145      of the sfunc is declared, especially if that precedes the place where
6146      the sfunc itself is defined, which is typically the case.)  We should
6147      put out a null pointer rather than point somewhere wrong, but I want to
6148      see how it works at this point.  */
6149
6150   input_filename = ffesymbol_where_filename (s);
6151   lineno = ffesymbol_where_filelinenum (s);
6152
6153   /* Pretransform the expression so any newly discovered things belong to the
6154      outer program unit, not to the statement function. */
6155
6156   ffecom_expr_transform_ (expr);
6157
6158   /* Make sure no recursive invocation of this fn (a specific case of failing
6159      to pretransform an sfunc's expression, i.e. where its expression
6160      references another untransformed sfunc) happens. */
6161
6162   assert (!recurse);
6163   recurse = TRUE;
6164
6165   push_f_function_context ();
6166
6167   if (charfunc)
6168     type = void_type_node;
6169   else
6170     {
6171       type = ffecom_tree_type[bt][kt];
6172       if (type == NULL_TREE)
6173         type = integer_type_node;       /* _sym_exec_transition reports
6174                                            error. */
6175     }
6176
6177   start_function (ffecom_get_identifier_ (ffesymbol_text (s)),
6178                   build_function_type (type, NULL_TREE),
6179                   1,            /* nested/inline */
6180                   0);           /* TREE_PUBLIC */
6181
6182   /* We don't worry about COMPLEX return values here, because this is
6183      entirely internal to our code, and gcc has the ability to return COMPLEX
6184      directly as a value.  */
6185
6186   if (charfunc)
6187     {                           /* Prepend arg for where result goes. */
6188       tree type;
6189
6190       type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
6191
6192       result = ffecom_get_invented_identifier ("__g77_%s", "result");
6193
6194       ffecom_char_enhance_arg_ (&type, s);      /* Ignore returned length. */
6195
6196       type = build_pointer_type (type);
6197       result = build_decl (PARM_DECL, result, type);
6198
6199       push_parm_decl (result);
6200     }
6201   else
6202     result = NULL_TREE;         /* Not ref'd if !charfunc. */
6203
6204   ffecom_push_dummy_decls_ (ffesymbol_dummyargs (s), TRUE);
6205
6206   store_parm_decls (0);
6207
6208   ffecom_start_compstmt ();
6209
6210   if (expr != NULL)
6211     {
6212       if (charfunc)
6213         {
6214           ffetargetCharacterSize sz = ffesymbol_size (s);
6215           tree result_length;
6216
6217           result_length = build_int_2 (sz, 0);
6218           TREE_TYPE (result_length) = ffecom_f2c_ftnlen_type_node;
6219
6220           ffecom_prepare_let_char_ (sz, expr);
6221
6222           ffecom_prepare_end ();
6223
6224           ffecom_let_char_ (result, result_length, sz, expr);
6225           expand_null_return ();
6226         }
6227       else
6228         {
6229           ffecom_prepare_expr (expr);
6230
6231           ffecom_prepare_end ();
6232
6233           expand_return (ffecom_modify (NULL_TREE,
6234                                         DECL_RESULT (current_function_decl),
6235                                         ffecom_expr (expr)));
6236         }
6237     }
6238
6239   ffecom_end_compstmt ();
6240
6241   func = current_function_decl;
6242   finish_function (1);
6243
6244   pop_f_function_context ();
6245
6246   recurse = FALSE;
6247
6248   lineno = old_lineno;
6249   input_filename = old_input_filename;
6250
6251   ffecom_nested_entry_ = NULL;
6252
6253   return func;
6254 }
6255
6256 static const char *
6257 ffecom_gfrt_args_ (ffecomGfrt ix)
6258 {
6259   return ffecom_gfrt_argstring_[ix];
6260 }
6261
6262 static tree
6263 ffecom_gfrt_tree_ (ffecomGfrt ix)
6264 {
6265   if (ffecom_gfrt_[ix] == NULL_TREE)
6266     ffecom_make_gfrt_ (ix);
6267
6268   return ffecom_1 (ADDR_EXPR,
6269                    build_pointer_type (TREE_TYPE (ffecom_gfrt_[ix])),
6270                    ffecom_gfrt_[ix]);
6271 }
6272
6273 /* Return initialize-to-zero expression for this VAR_DECL.  */
6274
6275 /* A somewhat evil way to prevent the garbage collector
6276    from collecting 'tree' structures.  */
6277 #define NUM_TRACKED_CHUNK 63
6278 static struct tree_ggc_tracker
6279 {
6280   struct tree_ggc_tracker *next;
6281   tree trees[NUM_TRACKED_CHUNK];
6282 } *tracker_head = NULL;
6283
6284 static void
6285 mark_tracker_head (void *arg)
6286 {
6287   struct tree_ggc_tracker *head;
6288   int i;
6289
6290   for (head = * (struct tree_ggc_tracker **) arg;
6291        head != NULL;
6292        head = head->next)
6293   {
6294     ggc_mark (head);
6295     for (i = 0; i < NUM_TRACKED_CHUNK; i++)
6296       ggc_mark_tree (head->trees[i]);
6297   }
6298 }
6299
6300 void
6301 ffecom_save_tree_forever (tree t)
6302 {
6303   int i;
6304   if (tracker_head != NULL)
6305     for (i = 0; i < NUM_TRACKED_CHUNK; i++)
6306       if (tracker_head->trees[i] == NULL)
6307         {
6308           tracker_head->trees[i] = t;
6309           return;
6310         }
6311
6312   {
6313     /* Need to allocate a new block.  */
6314     struct tree_ggc_tracker *old_head = tracker_head;
6315
6316     tracker_head = ggc_alloc (sizeof (*tracker_head));
6317     tracker_head->next = old_head;
6318     tracker_head->trees[0] = t;
6319     for (i = 1; i < NUM_TRACKED_CHUNK; i++)
6320       tracker_head->trees[i] = NULL;
6321   }
6322 }
6323
6324 static tree
6325 ffecom_init_zero_ (tree decl)
6326 {
6327   tree init;
6328   int incremental = TREE_STATIC (decl);
6329   tree type = TREE_TYPE (decl);
6330
6331   if (incremental)
6332     {
6333       make_decl_rtl (decl, NULL);
6334       assemble_variable (decl, TREE_PUBLIC (decl) ? 1 : 0, 0, 1);
6335     }
6336
6337   if ((TREE_CODE (type) != ARRAY_TYPE)
6338       && (TREE_CODE (type) != RECORD_TYPE)
6339       && (TREE_CODE (type) != UNION_TYPE)
6340       && !incremental)
6341     init = convert (type, integer_zero_node);
6342   else if (!incremental)
6343     {
6344       init = build (CONSTRUCTOR, type, NULL_TREE, NULL_TREE);
6345       TREE_CONSTANT (init) = 1;
6346       TREE_STATIC (init) = 1;
6347     }
6348   else
6349     {
6350       assemble_zeros (int_size_in_bytes (type));
6351       init = error_mark_node;
6352     }
6353
6354   return init;
6355 }
6356
6357 static tree
6358 ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
6359                          tree *maybe_tree)
6360 {
6361   tree expr_tree;
6362   tree length_tree;
6363
6364   switch (ffebld_op (arg))
6365     {
6366     case FFEBLD_opCONTER:       /* For F90, check 0-length. */
6367       if (ffetarget_length_character1
6368           (ffebld_constant_character1
6369            (ffebld_conter (arg))) == 0)
6370         {
6371           *maybe_tree = integer_zero_node;
6372           return convert (tree_type, integer_zero_node);
6373         }
6374
6375       *maybe_tree = integer_one_node;
6376       expr_tree = build_int_2 (*ffetarget_text_character1
6377                                (ffebld_constant_character1
6378                                 (ffebld_conter (arg))),
6379                                0);
6380       TREE_TYPE (expr_tree) = tree_type;
6381       return expr_tree;
6382
6383     case FFEBLD_opSYMTER:
6384     case FFEBLD_opARRAYREF:
6385     case FFEBLD_opFUNCREF:
6386     case FFEBLD_opSUBSTR:
6387       ffecom_char_args_ (&expr_tree, &length_tree, arg);
6388
6389       if ((expr_tree == error_mark_node)
6390           || (length_tree == error_mark_node))
6391         {
6392           *maybe_tree = error_mark_node;
6393           return error_mark_node;
6394         }
6395
6396       if (integer_zerop (length_tree))
6397         {
6398           *maybe_tree = integer_zero_node;
6399           return convert (tree_type, integer_zero_node);
6400         }
6401
6402       expr_tree
6403         = ffecom_1 (INDIRECT_REF,
6404                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6405                     expr_tree);
6406       expr_tree
6407         = ffecom_2 (ARRAY_REF,
6408                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6409                     expr_tree,
6410                     integer_one_node);
6411       expr_tree = convert (tree_type, expr_tree);
6412
6413       if (TREE_CODE (length_tree) == INTEGER_CST)
6414         *maybe_tree = integer_one_node;
6415       else                      /* Must check length at run time.  */
6416         *maybe_tree
6417           = ffecom_truth_value
6418             (ffecom_2 (GT_EXPR, integer_type_node,
6419                        length_tree,
6420                        ffecom_f2c_ftnlen_zero_node));
6421       return expr_tree;
6422
6423     case FFEBLD_opPAREN:
6424     case FFEBLD_opCONVERT:
6425       if (ffeinfo_size (ffebld_info (arg)) == 0)
6426         {
6427           *maybe_tree = integer_zero_node;
6428           return convert (tree_type, integer_zero_node);
6429         }
6430       return ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6431                                       maybe_tree);
6432
6433     case FFEBLD_opCONCATENATE:
6434       {
6435         tree maybe_left;
6436         tree maybe_right;
6437         tree expr_left;
6438         tree expr_right;
6439
6440         expr_left = ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6441                                              &maybe_left);
6442         expr_right = ffecom_intrinsic_ichar_ (tree_type, ffebld_right (arg),
6443                                               &maybe_right);
6444         *maybe_tree = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
6445                                 maybe_left,
6446                                 maybe_right);
6447         expr_tree = ffecom_3 (COND_EXPR, tree_type,
6448                               maybe_left,
6449                               expr_left,
6450                               expr_right);
6451         return expr_tree;
6452       }
6453
6454     default:
6455       assert ("bad op in ICHAR" == NULL);
6456       return error_mark_node;
6457     }
6458 }
6459
6460 /* ffecom_intrinsic_len_ -- Return length info for char arg (LEN())
6461
6462    tree length_arg;
6463    ffebld expr;
6464    length_arg = ffecom_intrinsic_len_ (expr);
6465
6466    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
6467    subexpressions by constructing the appropriate tree for the
6468    length-of-character-text argument in a calling sequence.  */
6469
6470 static tree
6471 ffecom_intrinsic_len_ (ffebld expr)
6472 {
6473   ffetargetCharacter1 val;
6474   tree length;
6475
6476   switch (ffebld_op (expr))
6477     {
6478     case FFEBLD_opCONTER:
6479       val = ffebld_constant_character1 (ffebld_conter (expr));
6480       length = build_int_2 (ffetarget_length_character1 (val), 0);
6481       TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6482       break;
6483
6484     case FFEBLD_opSYMTER:
6485       {
6486         ffesymbol s = ffebld_symter (expr);
6487         tree item;
6488
6489         item = ffesymbol_hook (s).decl_tree;
6490         if (item == NULL_TREE)
6491           {
6492             s = ffecom_sym_transform_ (s);
6493             item = ffesymbol_hook (s).decl_tree;
6494           }
6495         if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
6496           {
6497             if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
6498               length = ffesymbol_hook (s).length_tree;
6499             else
6500               {
6501                 length = build_int_2 (ffesymbol_size (s), 0);
6502                 TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6503               }
6504           }
6505         else if (item == error_mark_node)
6506           length = error_mark_node;
6507         else                    /* FFEINFO_kindFUNCTION: */
6508           length = NULL_TREE;
6509       }
6510       break;
6511
6512     case FFEBLD_opARRAYREF:
6513       length = ffecom_intrinsic_len_ (ffebld_left (expr));
6514       break;
6515
6516     case FFEBLD_opSUBSTR:
6517       {
6518         ffebld start;
6519         ffebld end;
6520         ffebld thing = ffebld_right (expr);
6521         tree start_tree;
6522         tree end_tree;
6523
6524         assert (ffebld_op (thing) == FFEBLD_opITEM);
6525         start = ffebld_head (thing);
6526         thing = ffebld_trail (thing);
6527         assert (ffebld_trail (thing) == NULL);
6528         end = ffebld_head (thing);
6529
6530         length = ffecom_intrinsic_len_ (ffebld_left (expr));
6531
6532         if (length == error_mark_node)
6533           break;
6534
6535         if (start == NULL)
6536           {
6537             if (end == NULL)
6538               ;
6539             else
6540               {
6541                 length = convert (ffecom_f2c_ftnlen_type_node,
6542                                   ffecom_expr (end));
6543               }
6544           }
6545         else
6546           {
6547             start_tree = convert (ffecom_f2c_ftnlen_type_node,
6548                                   ffecom_expr (start));
6549
6550             if (start_tree == error_mark_node)
6551               {
6552                 length = error_mark_node;
6553                 break;
6554               }
6555
6556             if (end == NULL)
6557               {
6558                 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6559                                    ffecom_f2c_ftnlen_one_node,
6560                                    ffecom_2 (MINUS_EXPR,
6561                                              ffecom_f2c_ftnlen_type_node,
6562                                              length,
6563                                              start_tree));
6564               }
6565             else
6566               {
6567                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
6568                                     ffecom_expr (end));
6569
6570                 if (end_tree == error_mark_node)
6571                   {
6572                     length = error_mark_node;
6573                     break;
6574                   }
6575
6576                 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6577                                    ffecom_f2c_ftnlen_one_node,
6578                                    ffecom_2 (MINUS_EXPR,
6579                                              ffecom_f2c_ftnlen_type_node,
6580                                              end_tree, start_tree));
6581               }
6582           }
6583       }
6584       break;
6585
6586     case FFEBLD_opCONCATENATE:
6587       length
6588         = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6589                     ffecom_intrinsic_len_ (ffebld_left (expr)),
6590                     ffecom_intrinsic_len_ (ffebld_right (expr)));
6591       break;
6592
6593     case FFEBLD_opFUNCREF:
6594     case FFEBLD_opCONVERT:
6595       length = build_int_2 (ffebld_size (expr), 0);
6596       TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6597       break;
6598
6599     default:
6600       assert ("bad op for single char arg expr" == NULL);
6601       length = ffecom_f2c_ftnlen_zero_node;
6602       break;
6603     }
6604
6605   assert (length != NULL_TREE);
6606
6607   return length;
6608 }
6609
6610 /* Handle CHARACTER assignments.
6611
6612    Generates code to do the assignment.  Used by ordinary assignment
6613    statement handler ffecom_let_stmt and by statement-function
6614    handler to generate code for a statement function.  */
6615
6616 static void
6617 ffecom_let_char_ (tree dest_tree, tree dest_length,
6618                   ffetargetCharacterSize dest_size, ffebld source)
6619 {
6620   ffecomConcatList_ catlist;
6621   tree source_length;
6622   tree source_tree;
6623   tree expr_tree;
6624
6625   if ((dest_tree == error_mark_node)
6626       || (dest_length == error_mark_node))
6627     return;
6628
6629   assert (dest_tree != NULL_TREE);
6630   assert (dest_length != NULL_TREE);
6631
6632   /* Source might be an opCONVERT, which just means it is a different size
6633      than the destination.  Since the underlying implementation here handles
6634      that (directly or via the s_copy or s_cat run-time-library functions),
6635      we don't need the "convenience" of an opCONVERT that tells us to
6636      truncate or blank-pad, particularly since the resulting implementation
6637      would probably be slower than otherwise. */
6638
6639   while (ffebld_op (source) == FFEBLD_opCONVERT)
6640     source = ffebld_left (source);
6641
6642   catlist = ffecom_concat_list_new_ (source, dest_size);
6643   switch (ffecom_concat_list_count_ (catlist))
6644     {
6645     case 0:                     /* Shouldn't happen, but in case it does... */
6646       ffecom_concat_list_kill_ (catlist);
6647       source_tree = null_pointer_node;
6648       source_length = ffecom_f2c_ftnlen_zero_node;
6649       expr_tree = build_tree_list (NULL_TREE, dest_tree);
6650       TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6651       TREE_CHAIN (TREE_CHAIN (expr_tree))
6652         = build_tree_list (NULL_TREE, dest_length);
6653       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6654         = build_tree_list (NULL_TREE, source_length);
6655
6656       expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6657       TREE_SIDE_EFFECTS (expr_tree) = 1;
6658
6659       expand_expr_stmt (expr_tree);
6660
6661       return;
6662
6663     case 1:                     /* The (fairly) easy case. */
6664       ffecom_char_args_ (&source_tree, &source_length,
6665                          ffecom_concat_list_expr_ (catlist, 0));
6666       ffecom_concat_list_kill_ (catlist);
6667       assert (source_tree != NULL_TREE);
6668       assert (source_length != NULL_TREE);
6669
6670       if ((source_tree == error_mark_node)
6671           || (source_length == error_mark_node))
6672         return;
6673
6674       if (dest_size == 1)
6675         {
6676           dest_tree
6677             = ffecom_1 (INDIRECT_REF,
6678                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6679                                                       (dest_tree))),
6680                         dest_tree);
6681           dest_tree
6682             = ffecom_2 (ARRAY_REF,
6683                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6684                                                       (dest_tree))),
6685                         dest_tree,
6686                         integer_one_node);
6687           source_tree
6688             = ffecom_1 (INDIRECT_REF,
6689                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6690                                                       (source_tree))),
6691                         source_tree);
6692           source_tree
6693             = ffecom_2 (ARRAY_REF,
6694                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6695                                                       (source_tree))),
6696                         source_tree,
6697                         integer_one_node);
6698
6699           expr_tree = ffecom_modify (void_type_node, dest_tree, source_tree);
6700
6701           expand_expr_stmt (expr_tree);
6702
6703           return;
6704         }
6705
6706       expr_tree = build_tree_list (NULL_TREE, dest_tree);
6707       TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6708       TREE_CHAIN (TREE_CHAIN (expr_tree))
6709         = build_tree_list (NULL_TREE, dest_length);
6710       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6711         = build_tree_list (NULL_TREE, source_length);
6712
6713       expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6714       TREE_SIDE_EFFECTS (expr_tree) = 1;
6715
6716       expand_expr_stmt (expr_tree);
6717
6718       return;
6719
6720     default:                    /* Must actually concatenate things. */
6721       break;
6722     }
6723
6724   /* Heavy-duty concatenation. */
6725
6726   {
6727     int count = ffecom_concat_list_count_ (catlist);
6728     int i;
6729     tree lengths;
6730     tree items;
6731     tree length_array;
6732     tree item_array;
6733     tree citem;
6734     tree clength;
6735
6736 #ifdef HOHO
6737     length_array
6738       = lengths
6739       = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
6740                              FFETARGET_charactersizeNONE, count, TRUE);
6741     item_array = items = ffecom_push_tempvar (ffecom_f2c_address_type_node,
6742                                               FFETARGET_charactersizeNONE,
6743                                               count, TRUE);
6744 #else
6745     {
6746       tree hook;
6747
6748       hook = ffebld_nonter_hook (source);
6749       assert (hook);
6750       assert (TREE_CODE (hook) == TREE_VEC);
6751       assert (TREE_VEC_LENGTH (hook) == 2);
6752       length_array = lengths = TREE_VEC_ELT (hook, 0);
6753       item_array = items = TREE_VEC_ELT (hook, 1);
6754     }
6755 #endif
6756
6757     for (i = 0; i < count; ++i)
6758       {
6759         ffecom_char_args_ (&citem, &clength,
6760                            ffecom_concat_list_expr_ (catlist, i));
6761         if ((citem == error_mark_node)
6762             || (clength == error_mark_node))
6763           {
6764             ffecom_concat_list_kill_ (catlist);
6765             return;
6766           }
6767
6768         items
6769           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
6770                       ffecom_modify (void_type_node,
6771                                      ffecom_2 (ARRAY_REF,
6772                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
6773                                                item_array,
6774                                                build_int_2 (i, 0)),
6775                                      citem),
6776                       items);
6777         lengths
6778           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
6779                       ffecom_modify (void_type_node,
6780                                      ffecom_2 (ARRAY_REF,
6781                    TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
6782                                                length_array,
6783                                                build_int_2 (i, 0)),
6784                                      clength),
6785                       lengths);
6786       }
6787
6788     expr_tree = build_tree_list (NULL_TREE, dest_tree);
6789     TREE_CHAIN (expr_tree)
6790       = build_tree_list (NULL_TREE,
6791                          ffecom_1 (ADDR_EXPR,
6792                                    build_pointer_type (TREE_TYPE (items)),
6793                                    items));
6794     TREE_CHAIN (TREE_CHAIN (expr_tree))
6795       = build_tree_list (NULL_TREE,
6796                          ffecom_1 (ADDR_EXPR,
6797                                    build_pointer_type (TREE_TYPE (lengths)),
6798                                    lengths));
6799     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6800       = build_tree_list
6801         (NULL_TREE,
6802          ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
6803                    convert (ffecom_f2c_ftnlen_type_node,
6804                             build_int_2 (count, 0))));
6805     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree))))
6806       = build_tree_list (NULL_TREE, dest_length);
6807
6808     expr_tree = ffecom_call_gfrt (FFECOM_gfrtCAT, expr_tree, NULL_TREE);
6809     TREE_SIDE_EFFECTS (expr_tree) = 1;
6810
6811     expand_expr_stmt (expr_tree);
6812   }
6813
6814   ffecom_concat_list_kill_ (catlist);
6815 }
6816
6817 /* ffecom_make_gfrt_ -- Make initial info for run-time routine
6818
6819    ffecomGfrt ix;
6820    ffecom_make_gfrt_(ix);
6821
6822    Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL
6823    for the indicated run-time routine (ix).  */
6824
6825 static void
6826 ffecom_make_gfrt_ (ffecomGfrt ix)
6827 {
6828   tree t;
6829   tree ttype;
6830
6831   switch (ffecom_gfrt_type_[ix])
6832     {
6833     case FFECOM_rttypeVOID_:
6834       ttype = void_type_node;
6835       break;
6836
6837     case FFECOM_rttypeVOIDSTAR_:
6838       ttype = TREE_TYPE (null_pointer_node);    /* `void *'. */
6839       break;
6840
6841     case FFECOM_rttypeFTNINT_:
6842       ttype = ffecom_f2c_ftnint_type_node;
6843       break;
6844
6845     case FFECOM_rttypeINTEGER_:
6846       ttype = ffecom_f2c_integer_type_node;
6847       break;
6848
6849     case FFECOM_rttypeLONGINT_:
6850       ttype = ffecom_f2c_longint_type_node;
6851       break;
6852
6853     case FFECOM_rttypeLOGICAL_:
6854       ttype = ffecom_f2c_logical_type_node;
6855       break;
6856
6857     case FFECOM_rttypeREAL_F2C_:
6858       ttype = double_type_node;
6859       break;
6860
6861     case FFECOM_rttypeREAL_GNU_:
6862       ttype = float_type_node;
6863       break;
6864
6865     case FFECOM_rttypeCOMPLEX_F2C_:
6866       ttype = void_type_node;
6867       break;
6868
6869     case FFECOM_rttypeCOMPLEX_GNU_:
6870       ttype = ffecom_f2c_complex_type_node;
6871       break;
6872
6873     case FFECOM_rttypeDOUBLE_:
6874       ttype = double_type_node;
6875       break;
6876
6877     case FFECOM_rttypeDOUBLEREAL_:
6878       ttype = ffecom_f2c_doublereal_type_node;
6879       break;
6880
6881     case FFECOM_rttypeDBLCMPLX_F2C_:
6882       ttype = void_type_node;
6883       break;
6884
6885     case FFECOM_rttypeDBLCMPLX_GNU_:
6886       ttype = ffecom_f2c_doublecomplex_type_node;
6887       break;
6888
6889     case FFECOM_rttypeCHARACTER_:
6890       ttype = void_type_node;
6891       break;
6892
6893     default:
6894       ttype = NULL;
6895       assert ("bad rttype" == NULL);
6896       break;
6897     }
6898
6899   ttype = build_function_type (ttype, NULL_TREE);
6900   t = build_decl (FUNCTION_DECL,
6901                   get_identifier (ffecom_gfrt_name_[ix]),
6902                   ttype);
6903   DECL_EXTERNAL (t) = 1;
6904   TREE_READONLY (t) = ffecom_gfrt_const_[ix] ? 1 : 0;
6905   TREE_PUBLIC (t) = 1;
6906   TREE_THIS_VOLATILE (t) = ffecom_gfrt_volatile_[ix] ? 1 : 0;
6907
6908   /* Sanity check:  A function that's const cannot be volatile.  */
6909
6910   assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_volatile_[ix] : 1);
6911
6912   /* Sanity check: A function that's const cannot return complex.  */
6913
6914   assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_complex_[ix] : 1);
6915
6916   t = start_decl (t, TRUE);
6917
6918   finish_decl (t, NULL_TREE, TRUE);
6919
6920   ffecom_gfrt_[ix] = t;
6921 }
6922
6923 /* Phase 1 pass over each member of a COMMON/EQUIVALENCE group.  */
6924
6925 static void
6926 ffecom_member_phase1_ (ffestorag mst UNUSED, ffestorag st)
6927 {
6928   ffesymbol s = ffestorag_symbol (st);
6929
6930   if (ffesymbol_namelisted (s))
6931     ffecom_member_namelisted_ = TRUE;
6932 }
6933
6934 /* Phase 2 pass over each member of a COMMON/EQUIVALENCE group.  Declare
6935    the member so debugger will see it.  Otherwise nobody should be
6936    referencing the member.  */
6937
6938 static void
6939 ffecom_member_phase2_ (ffestorag mst, ffestorag st)
6940 {
6941   ffesymbol s;
6942   tree t;
6943   tree mt;
6944   tree type;
6945
6946   if ((mst == NULL)
6947       || ((mt = ffestorag_hook (mst)) == NULL)
6948       || (mt == error_mark_node))
6949     return;
6950
6951   if ((st == NULL)
6952       || ((s = ffestorag_symbol (st)) == NULL))
6953     return;
6954
6955   type = ffecom_type_localvar_ (s,
6956                                 ffesymbol_basictype (s),
6957                                 ffesymbol_kindtype (s));
6958   if (type == error_mark_node)
6959     return;
6960
6961   t = build_decl (VAR_DECL,
6962                   ffecom_get_identifier_ (ffesymbol_text (s)),
6963                   type);
6964
6965   TREE_STATIC (t) = TREE_STATIC (mt);
6966   DECL_INITIAL (t) = NULL_TREE;
6967   TREE_ASM_WRITTEN (t) = 1;
6968   TREE_USED (t) = 1;
6969
6970   SET_DECL_RTL (t,
6971                 gen_rtx (MEM, TYPE_MODE (type),
6972                          plus_constant (XEXP (DECL_RTL (mt), 0),
6973                                         ffestorag_modulo (mst)
6974                                         + ffestorag_offset (st)
6975                                         - ffestorag_offset (mst))));
6976
6977   t = start_decl (t, FALSE);
6978
6979   finish_decl (t, NULL_TREE, FALSE);
6980 }
6981
6982 /* Prepare source expression for assignment into a destination perhaps known
6983    to be of a specific size.  */
6984
6985 static void
6986 ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size, ffebld source)
6987 {
6988   ffecomConcatList_ catlist;
6989   int count;
6990   int i;
6991   tree ltmp;
6992   tree itmp;
6993   tree tempvar = NULL_TREE;
6994
6995   while (ffebld_op (source) == FFEBLD_opCONVERT)
6996     source = ffebld_left (source);
6997
6998   catlist = ffecom_concat_list_new_ (source, dest_size);
6999   count = ffecom_concat_list_count_ (catlist);
7000
7001   if (count >= 2)
7002     {
7003       ltmp
7004         = ffecom_make_tempvar ("let_char_len", ffecom_f2c_ftnlen_type_node,
7005                                FFETARGET_charactersizeNONE, count);
7006       itmp
7007         = ffecom_make_tempvar ("let_char_item", ffecom_f2c_address_type_node,
7008                                FFETARGET_charactersizeNONE, count);
7009
7010       tempvar = make_tree_vec (2);
7011       TREE_VEC_ELT (tempvar, 0) = ltmp;
7012       TREE_VEC_ELT (tempvar, 1) = itmp;
7013     }
7014
7015   for (i = 0; i < count; ++i)
7016     ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist, i));
7017
7018   ffecom_concat_list_kill_ (catlist);
7019
7020   if (tempvar)
7021     {
7022       ffebld_nonter_set_hook (source, tempvar);
7023       current_binding_level->prep_state = 1;
7024     }
7025 }
7026
7027 /* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order
7028
7029    Ignores STAR (alternate-return) dummies.  All other get exec-transitioned
7030    (which generates their trees) and then their trees get push_parm_decl'd.
7031
7032    The second arg is TRUE if the dummies are for a statement function, in
7033    which case lengths are not pushed for character arguments (since they are
7034    always known by both the caller and the callee, though the code allows
7035    for someday permitting CHAR*(*) stmtfunc dummies).  */
7036
7037 static void
7038 ffecom_push_dummy_decls_ (ffebld dummy_list, bool stmtfunc)
7039 {
7040   ffebld dummy;
7041   ffebld dumlist;
7042   ffesymbol s;
7043   tree parm;
7044
7045   ffecom_transform_only_dummies_ = TRUE;
7046
7047   /* First push the parms corresponding to actual dummy "contents".  */
7048
7049   for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7050     {
7051       dummy = ffebld_head (dumlist);
7052       switch (ffebld_op (dummy))
7053         {
7054         case FFEBLD_opSTAR:
7055         case FFEBLD_opANY:
7056           continue;             /* Forget alternate returns. */
7057
7058         default:
7059           break;
7060         }
7061       assert (ffebld_op (dummy) == FFEBLD_opSYMTER);
7062       s = ffebld_symter (dummy);
7063       parm = ffesymbol_hook (s).decl_tree;
7064       if (parm == NULL_TREE)
7065         {
7066           s = ffecom_sym_transform_ (s);
7067           parm = ffesymbol_hook (s).decl_tree;
7068           assert (parm != NULL_TREE);
7069         }
7070       if (parm != error_mark_node)
7071         push_parm_decl (parm);
7072     }
7073
7074   /* Then, for CHARACTER dummies, push the parms giving their lengths.  */
7075
7076   for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7077     {
7078       dummy = ffebld_head (dumlist);
7079       switch (ffebld_op (dummy))
7080         {
7081         case FFEBLD_opSTAR:
7082         case FFEBLD_opANY:
7083           continue;             /* Forget alternate returns, they mean
7084                                    NOTHING! */
7085
7086         default:
7087           break;
7088         }
7089       s = ffebld_symter (dummy);
7090       if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
7091         continue;               /* Only looking for CHARACTER arguments. */
7092       if (stmtfunc && (ffesymbol_size (s) != FFETARGET_charactersizeNONE))
7093         continue;               /* Stmtfunc arg with known size needs no
7094                                    length param. */
7095       if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
7096         continue;               /* Only looking for variables and arrays. */
7097       parm = ffesymbol_hook (s).length_tree;
7098       assert (parm != NULL_TREE);
7099       if (parm != error_mark_node)
7100         push_parm_decl (parm);
7101     }
7102
7103   ffecom_transform_only_dummies_ = FALSE;
7104 }
7105
7106 /* ffecom_start_progunit_ -- Beginning of program unit
7107
7108    Does GNU back end stuff necessary to teach it about the start of its
7109    equivalent of a Fortran program unit.  */
7110
7111 static void
7112 ffecom_start_progunit_ ()
7113 {
7114   ffesymbol fn = ffecom_primary_entry_;
7115   ffebld arglist;
7116   tree id;                      /* Identifier (name) of function. */
7117   tree type;                    /* Type of function. */
7118   tree result;                  /* Result of function. */
7119   ffeinfoBasictype bt;
7120   ffeinfoKindtype kt;
7121   ffeglobal g;
7122   ffeglobalType gt;
7123   ffeglobalType egt = FFEGLOBAL_type;
7124   bool charfunc;
7125   bool cmplxfunc;
7126   bool altentries = (ffecom_num_entrypoints_ != 0);
7127   bool multi
7128   = altentries
7129   && (ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
7130   && (ffecom_master_bt_ == FFEINFO_basictypeNONE);
7131   bool main_program = FALSE;
7132   int old_lineno = lineno;
7133   const char *old_input_filename = input_filename;
7134
7135   assert (fn != NULL);
7136   assert (ffesymbol_hook (fn).decl_tree == NULL_TREE);
7137
7138   input_filename = ffesymbol_where_filename (fn);
7139   lineno = ffesymbol_where_filelinenum (fn);
7140
7141   switch (ffecom_primary_entry_kind_)
7142     {
7143     case FFEINFO_kindPROGRAM:
7144       main_program = TRUE;
7145       gt = FFEGLOBAL_typeMAIN;
7146       bt = FFEINFO_basictypeNONE;
7147       kt = FFEINFO_kindtypeNONE;
7148       type = ffecom_tree_fun_type_void;
7149       charfunc = FALSE;
7150       cmplxfunc = FALSE;
7151       break;
7152
7153     case FFEINFO_kindBLOCKDATA:
7154       gt = FFEGLOBAL_typeBDATA;
7155       bt = FFEINFO_basictypeNONE;
7156       kt = FFEINFO_kindtypeNONE;
7157       type = ffecom_tree_fun_type_void;
7158       charfunc = FALSE;
7159       cmplxfunc = FALSE;
7160       break;
7161
7162     case FFEINFO_kindFUNCTION:
7163       gt = FFEGLOBAL_typeFUNC;
7164       egt = FFEGLOBAL_typeEXT;
7165       bt = ffesymbol_basictype (fn);
7166       kt = ffesymbol_kindtype (fn);
7167       if (bt == FFEINFO_basictypeNONE)
7168         {
7169           ffeimplic_establish_symbol (fn);
7170           if (ffesymbol_funcresult (fn) != NULL)
7171             ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
7172           bt = ffesymbol_basictype (fn);
7173           kt = ffesymbol_kindtype (fn);
7174         }
7175
7176       if (multi)
7177         charfunc = cmplxfunc = FALSE;
7178       else if (bt == FFEINFO_basictypeCHARACTER)
7179         charfunc = TRUE, cmplxfunc = FALSE;
7180       else if ((bt == FFEINFO_basictypeCOMPLEX)
7181                && ffesymbol_is_f2c (fn)
7182                && !altentries)
7183         charfunc = FALSE, cmplxfunc = TRUE;
7184       else
7185         charfunc = cmplxfunc = FALSE;
7186
7187       if (multi || charfunc)
7188         type = ffecom_tree_fun_type_void;
7189       else if (ffesymbol_is_f2c (fn) && !altentries)
7190         type = ffecom_tree_fun_type[bt][kt];
7191       else
7192         type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
7193
7194       if ((type == NULL_TREE)
7195           || (TREE_TYPE (type) == NULL_TREE))
7196         type = ffecom_tree_fun_type_void;       /* _sym_exec_transition. */
7197       break;
7198
7199     case FFEINFO_kindSUBROUTINE:
7200       gt = FFEGLOBAL_typeSUBR;
7201       egt = FFEGLOBAL_typeEXT;
7202       bt = FFEINFO_basictypeNONE;
7203       kt = FFEINFO_kindtypeNONE;
7204       if (ffecom_is_altreturning_)
7205         type = ffecom_tree_subr_type;
7206       else
7207         type = ffecom_tree_fun_type_void;
7208       charfunc = FALSE;
7209       cmplxfunc = FALSE;
7210       break;
7211
7212     default:
7213       assert ("say what??" == NULL);
7214       /* Fall through. */
7215     case FFEINFO_kindANY:
7216       gt = FFEGLOBAL_typeANY;
7217       bt = FFEINFO_basictypeNONE;
7218       kt = FFEINFO_kindtypeNONE;
7219       type = error_mark_node;
7220       charfunc = FALSE;
7221       cmplxfunc = FALSE;
7222       break;
7223     }
7224
7225   if (altentries)
7226     {
7227       id = ffecom_get_invented_identifier ("__g77_masterfun_%s",
7228                                            ffesymbol_text (fn));
7229     }
7230 #if FFETARGET_isENFORCED_MAIN
7231   else if (main_program)
7232     id = get_identifier (FFETARGET_nameENFORCED_MAIN_NAME);
7233 #endif
7234   else
7235     id = ffecom_get_external_identifier_ (fn);
7236
7237   start_function (id,
7238                   type,
7239                   0,            /* nested/inline */
7240                   !altentries); /* TREE_PUBLIC */
7241
7242   TREE_USED (current_function_decl) = 1;        /* Avoid spurious warning if altentries. */
7243
7244   if (!altentries
7245       && ((g = ffesymbol_global (fn)) != NULL)
7246       && ((ffeglobal_type (g) == gt)
7247           || (ffeglobal_type (g) == egt)))
7248     {
7249       ffeglobal_set_hook (g, current_function_decl);
7250     }
7251
7252   /* Arg handling needs exec-transitioned ffesymbols to work with.  But
7253      exec-transitioning needs current_function_decl to be filled in.  So we
7254      do these things in two phases. */
7255
7256   if (altentries)
7257     {                           /* 1st arg identifies which entrypoint. */
7258       ffecom_which_entrypoint_decl_
7259         = build_decl (PARM_DECL,
7260                       ffecom_get_invented_identifier ("__g77_%s",
7261                                                       "which_entrypoint"),
7262                       integer_type_node);
7263       push_parm_decl (ffecom_which_entrypoint_decl_);
7264     }
7265
7266   if (charfunc
7267       || cmplxfunc
7268       || multi)
7269     {                           /* Arg for result (return value). */
7270       tree type;
7271       tree length;
7272
7273       if (charfunc)
7274         type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
7275       else if (cmplxfunc)
7276         type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
7277       else
7278         type = ffecom_multi_type_node_;
7279
7280       result = ffecom_get_invented_identifier ("__g77_%s", "result");
7281
7282       /* Make length arg _and_ enhance type info for CHAR arg itself.  */
7283
7284       if (charfunc)
7285         length = ffecom_char_enhance_arg_ (&type, fn);
7286       else
7287         length = NULL_TREE;     /* Not ref'd if !charfunc. */
7288
7289       type = build_pointer_type (type);
7290       result = build_decl (PARM_DECL, result, type);
7291
7292       push_parm_decl (result);
7293       if (multi)
7294         ffecom_multi_retval_ = result;
7295       else
7296         ffecom_func_result_ = result;
7297
7298       if (charfunc)
7299         {
7300           push_parm_decl (length);
7301           ffecom_func_length_ = length;
7302         }
7303     }
7304
7305   if (ffecom_primary_entry_is_proc_)
7306     {
7307       if (altentries)
7308         arglist = ffecom_master_arglist_;
7309       else
7310         arglist = ffesymbol_dummyargs (fn);
7311       ffecom_push_dummy_decls_ (arglist, FALSE);
7312     }
7313
7314   if (TREE_CODE (current_function_decl) != ERROR_MARK)
7315     store_parm_decls (main_program ? 1 : 0);
7316
7317   ffecom_start_compstmt ();
7318   /* Disallow temp vars at this level.  */
7319   current_binding_level->prep_state = 2;
7320
7321   lineno = old_lineno;
7322   input_filename = old_input_filename;
7323
7324   /* This handles any symbols still untransformed, in case -g specified.
7325      This used to be done in ffecom_finish_progunit, but it turns out to
7326      be necessary to do it here so that statement functions are
7327      expanded before code.  But don't bother for BLOCK DATA.  */
7328
7329   if (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
7330     ffesymbol_drive (ffecom_finish_symbol_transform_);
7331 }
7332
7333 /* ffecom_sym_transform_ -- Transform FFE sym into backend sym
7334
7335    ffesymbol s;
7336    ffecom_sym_transform_(s);
7337
7338    The ffesymbol_hook info for s is updated with appropriate backend info
7339    on the symbol.  */
7340
7341 static ffesymbol
7342 ffecom_sym_transform_ (ffesymbol s)
7343 {
7344   tree t;                       /* Transformed thingy. */
7345   tree tlen;                    /* Length if CHAR*(*). */
7346   bool addr;                    /* Is t the address of the thingy? */
7347   ffeinfoBasictype bt;
7348   ffeinfoKindtype kt;
7349   ffeglobal g;
7350   int old_lineno = lineno;
7351   const char *old_input_filename = input_filename;
7352
7353   /* Must ensure special ASSIGN variables are declared at top of outermost
7354      block, else they'll end up in the innermost block when their first
7355      ASSIGN is seen, which leaves them out of scope when they're the
7356      subject of a GOTO or I/O statement.
7357
7358      We make this variable even if -fugly-assign.  Just let it go unused,
7359      in case it turns out there are cases where we really want to use this
7360      variable anyway (e.g. ASSIGN to INTEGER*2 variable).  */
7361
7362   if (! ffecom_transform_only_dummies_
7363       && ffesymbol_assigned (s)
7364       && ! ffesymbol_hook (s).assign_tree)
7365     s = ffecom_sym_transform_assign_ (s);
7366
7367   if (ffesymbol_sfdummyparent (s) == NULL)
7368     {
7369       input_filename = ffesymbol_where_filename (s);
7370       lineno = ffesymbol_where_filelinenum (s);
7371     }
7372   else
7373     {
7374       ffesymbol sf = ffesymbol_sfdummyparent (s);
7375
7376       input_filename = ffesymbol_where_filename (sf);
7377       lineno = ffesymbol_where_filelinenum (sf);
7378     }
7379
7380   bt = ffeinfo_basictype (ffebld_info (s));
7381   kt = ffeinfo_kindtype (ffebld_info (s));
7382
7383   t = NULL_TREE;
7384   tlen = NULL_TREE;
7385   addr = FALSE;
7386
7387   switch (ffesymbol_kind (s))
7388     {
7389     case FFEINFO_kindNONE:
7390       switch (ffesymbol_where (s))
7391         {
7392         case FFEINFO_whereDUMMY:        /* Subroutine or function. */
7393           assert (ffecom_transform_only_dummies_);
7394
7395           /* Before 0.4, this could be ENTITY/DUMMY, but see
7396              ffestu_sym_end_transition -- no longer true (in particular, if
7397              it could be an ENTITY, it _will_ be made one, so that
7398              possibility won't come through here).  So we never make length
7399              arg for CHARACTER type.  */
7400
7401           t = build_decl (PARM_DECL,
7402                           ffecom_get_identifier_ (ffesymbol_text (s)),
7403                           ffecom_tree_ptr_to_subr_type);
7404           DECL_ARTIFICIAL (t) = 1;
7405           addr = TRUE;
7406           break;
7407
7408         case FFEINFO_whereGLOBAL:       /* Subroutine or function. */
7409           assert (!ffecom_transform_only_dummies_);
7410
7411           if (((g = ffesymbol_global (s)) != NULL)
7412               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7413                   || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7414                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
7415               && (ffeglobal_hook (g) != NULL_TREE)
7416               && ffe_is_globals ())
7417             {
7418               t = ffeglobal_hook (g);
7419               break;
7420             }
7421
7422           t = build_decl (FUNCTION_DECL,
7423                           ffecom_get_external_identifier_ (s),
7424                           ffecom_tree_subr_type);       /* Assume subr. */
7425           DECL_EXTERNAL (t) = 1;
7426           TREE_PUBLIC (t) = 1;
7427
7428           t = start_decl (t, FALSE);
7429           finish_decl (t, NULL_TREE, FALSE);
7430
7431           if ((g != NULL)
7432               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7433                   || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7434                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
7435             ffeglobal_set_hook (g, t);
7436
7437           ffecom_save_tree_forever (t);
7438
7439           break;
7440
7441         default:
7442           assert ("NONE where unexpected" == NULL);
7443           /* Fall through. */
7444         case FFEINFO_whereANY:
7445           break;
7446         }
7447       break;
7448
7449     case FFEINFO_kindENTITY:
7450       switch (ffeinfo_where (ffesymbol_info (s)))
7451         {
7452
7453         case FFEINFO_whereCONSTANT:
7454           /* ~~Debugging info needed? */
7455           assert (!ffecom_transform_only_dummies_);
7456           t = error_mark_node;  /* Shouldn't ever see this in expr. */
7457           break;
7458
7459         case FFEINFO_whereLOCAL:
7460           assert (!ffecom_transform_only_dummies_);
7461
7462           {
7463             ffestorag st = ffesymbol_storage (s);
7464             tree type;
7465
7466             if ((st != NULL)
7467                 && (ffestorag_size (st) == 0))
7468               {
7469                 t = error_mark_node;
7470                 break;
7471               }
7472
7473             type = ffecom_type_localvar_ (s, bt, kt);
7474
7475             if (type == error_mark_node)
7476               {
7477                 t = error_mark_node;
7478                 break;
7479               }
7480
7481             if ((st != NULL)
7482                 && (ffestorag_parent (st) != NULL))
7483               {                 /* Child of EQUIVALENCE parent. */
7484                 ffestorag est;
7485                 tree et;
7486                 ffetargetOffset offset;
7487
7488                 est = ffestorag_parent (st);
7489                 ffecom_transform_equiv_ (est);
7490
7491                 et = ffestorag_hook (est);
7492                 assert (et != NULL_TREE);
7493
7494                 if (! TREE_STATIC (et))
7495                   put_var_into_stack (et);
7496
7497                 offset = ffestorag_modulo (est)
7498                   + ffestorag_offset (ffesymbol_storage (s))
7499                   - ffestorag_offset (est);
7500
7501                 ffecom_debug_kludge_ (et, "EQUIVALENCE", s, type, offset);
7502
7503                 /* (t_type *) (((char *) &et) + offset) */
7504
7505                 t = convert (string_type_node,  /* (char *) */
7506                              ffecom_1 (ADDR_EXPR,
7507                                        build_pointer_type (TREE_TYPE (et)),
7508                                        et));
7509                 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
7510                               t,
7511                               build_int_2 (offset, 0));
7512                 t = convert (build_pointer_type (type),
7513                              t);
7514                 TREE_CONSTANT (t) = staticp (et);
7515
7516                 addr = TRUE;
7517               }
7518             else
7519               {
7520                 tree initexpr;
7521                 bool init = ffesymbol_is_init (s);
7522
7523                 t = build_decl (VAR_DECL,
7524                                 ffecom_get_identifier_ (ffesymbol_text (s)),
7525                                 type);
7526
7527                 if (init
7528                     || ffesymbol_namelisted (s)
7529 #ifdef FFECOM_sizeMAXSTACKITEM
7530                     || ((st != NULL)
7531                         && (ffestorag_size (st) > FFECOM_sizeMAXSTACKITEM))
7532 #endif
7533                     || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
7534                         && (ffecom_primary_entry_kind_
7535                             != FFEINFO_kindBLOCKDATA)
7536                         && (ffesymbol_is_save (s) || ffe_is_saveall ())))
7537                   TREE_STATIC (t) = !ffesymbol_attr (s, FFESYMBOL_attrADJUSTABLE);
7538                 else
7539                   TREE_STATIC (t) = 0;  /* No need to make static. */
7540
7541                 if (init || ffe_is_init_local_zero ())
7542                   DECL_INITIAL (t) = error_mark_node;
7543
7544                 /* Keep -Wunused from complaining about var if it
7545                    is used as sfunc arg or DATA implied-DO.  */
7546                 if (ffesymbol_attrs (s) & FFESYMBOL_attrsSFARG)
7547                   DECL_IN_SYSTEM_HEADER (t) = 1;
7548
7549                 t = start_decl (t, FALSE);
7550
7551                 if (init)
7552                   {
7553                     if (ffesymbol_init (s) != NULL)
7554                       initexpr = ffecom_expr (ffesymbol_init (s));
7555                     else
7556                       initexpr = ffecom_init_zero_ (t);
7557                   }
7558                 else if (ffe_is_init_local_zero ())
7559                   initexpr = ffecom_init_zero_ (t);
7560                 else
7561                   initexpr = NULL_TREE; /* Not ref'd if !init. */
7562
7563                 finish_decl (t, initexpr, FALSE);
7564
7565                 if (st != NULL && DECL_SIZE (t) != error_mark_node)
7566                   {
7567                     assert (TREE_CODE (DECL_SIZE_UNIT (t)) == INTEGER_CST);
7568                     assert (0 == compare_tree_int (DECL_SIZE_UNIT (t),
7569                                                    ffestorag_size (st)));
7570                   }
7571               }
7572           }
7573           break;
7574
7575         case FFEINFO_whereRESULT:
7576           assert (!ffecom_transform_only_dummies_);
7577
7578           if (bt == FFEINFO_basictypeCHARACTER)
7579             {                   /* Result is already in list of dummies, use
7580                                    it (& length). */
7581               t = ffecom_func_result_;
7582               tlen = ffecom_func_length_;
7583               addr = TRUE;
7584               break;
7585             }
7586           if ((ffecom_num_entrypoints_ == 0)
7587               && (bt == FFEINFO_basictypeCOMPLEX)
7588               && (ffesymbol_is_f2c (ffecom_primary_entry_)))
7589             {                   /* Result is already in list of dummies, use
7590                                    it. */
7591               t = ffecom_func_result_;
7592               addr = TRUE;
7593               break;
7594             }
7595           if (ffecom_func_result_ != NULL_TREE)
7596             {
7597               t = ffecom_func_result_;
7598               break;
7599             }
7600           if ((ffecom_num_entrypoints_ != 0)
7601               && (ffecom_master_bt_ == FFEINFO_basictypeNONE))
7602             {
7603               assert (ffecom_multi_retval_ != NULL_TREE);
7604               t = ffecom_1 (INDIRECT_REF, ffecom_multi_type_node_,
7605                             ffecom_multi_retval_);
7606               t = ffecom_2 (COMPONENT_REF, ffecom_tree_type[bt][kt],
7607                             t, ffecom_multi_fields_[bt][kt]);
7608
7609               break;
7610             }
7611
7612           t = build_decl (VAR_DECL,
7613                           ffecom_get_identifier_ (ffesymbol_text (s)),
7614                           ffecom_tree_type[bt][kt]);
7615           TREE_STATIC (t) = 0;  /* Put result on stack. */
7616           t = start_decl (t, FALSE);
7617           finish_decl (t, NULL_TREE, FALSE);
7618
7619           ffecom_func_result_ = t;
7620
7621           break;
7622
7623         case FFEINFO_whereDUMMY:
7624           {
7625             tree type;
7626             ffebld dl;
7627             ffebld dim;
7628             tree low;
7629             tree high;
7630             tree old_sizes;
7631             bool adjustable = FALSE;    /* Conditionally adjustable? */
7632
7633             type = ffecom_tree_type[bt][kt];
7634             if (ffesymbol_sfdummyparent (s) != NULL)
7635               {
7636                 if (current_function_decl == ffecom_outer_function_decl_)
7637                   {                     /* Exec transition before sfunc
7638                                            context; get it later. */
7639                     break;
7640                   }
7641                 t = ffecom_get_identifier_ (ffesymbol_text
7642                                             (ffesymbol_sfdummyparent (s)));
7643               }
7644             else
7645               t = ffecom_get_identifier_ (ffesymbol_text (s));
7646
7647             assert (ffecom_transform_only_dummies_);
7648
7649             old_sizes = get_pending_sizes ();
7650             put_pending_sizes (old_sizes);
7651
7652             if (bt == FFEINFO_basictypeCHARACTER)
7653               tlen = ffecom_char_enhance_arg_ (&type, s);
7654             type = ffecom_check_size_overflow_ (s, type, TRUE);
7655
7656             for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
7657               {
7658                 if (type == error_mark_node)
7659                   break;
7660
7661                 dim = ffebld_head (dl);
7662                 assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
7663                 if ((ffebld_left (dim) == NULL) || ffecom_doing_entry_)
7664                   low = ffecom_integer_one_node;
7665                 else
7666                   low = ffecom_expr (ffebld_left (dim));
7667                 assert (ffebld_right (dim) != NULL);
7668                 if ((ffebld_op (ffebld_right (dim)) == FFEBLD_opSTAR)
7669                     || ffecom_doing_entry_)
7670                   {
7671                     /* Used to just do high=low.  But for ffecom_tree_
7672                        canonize_ref_, it probably is important to correctly
7673                        assess the size.  E.g. given COMPLEX C(*),CFUNC and
7674                        C(2)=CFUNC(C), overlap can happen, while it can't
7675                        for, say, C(1)=CFUNC(C(2)).  */
7676                     /* Even more recently used to set to INT_MAX, but that
7677                        broke when some overflow checking went into the back
7678                        end.  Now we just leave the upper bound unspecified.  */
7679                     high = NULL;
7680                   }
7681                 else
7682                   high = ffecom_expr (ffebld_right (dim));
7683
7684                 /* Determine whether array is conditionally adjustable,
7685                    to decide whether back-end magic is needed.
7686
7687                    Normally the front end uses the back-end function
7688                    variable_size to wrap SAVE_EXPR's around expressions
7689                    affecting the size/shape of an array so that the
7690                    size/shape info doesn't change during execution
7691                    of the compiled code even though variables and
7692                    functions referenced in those expressions might.
7693
7694                    variable_size also makes sure those saved expressions
7695                    get evaluated immediately upon entry to the
7696                    compiled procedure -- the front end normally doesn't
7697                    have to worry about that.
7698
7699                    However, there is a problem with this that affects
7700                    g77's implementation of entry points, and that is
7701                    that it is _not_ true that each invocation of the
7702                    compiled procedure is permitted to evaluate
7703                    array size/shape info -- because it is possible
7704                    that, for some invocations, that info is invalid (in
7705                    which case it is "promised" -- i.e. a violation of
7706                    the Fortran standard -- that the compiled code
7707                    won't reference the array or its size/shape
7708                    during that particular invocation).
7709
7710                    To phrase this in C terms, consider this gcc function:
7711
7712                      void foo (int *n, float (*a)[*n])
7713                      {
7714                        // a is "pointer to array ...", fyi.
7715                      }
7716
7717                    Suppose that, for some invocations, it is permitted
7718                    for a caller of foo to do this:
7719
7720                        foo (NULL, NULL);
7721
7722                    Now the _written_ code for foo can take such a call
7723                    into account by either testing explicitly for whether
7724                    (a == NULL) || (n == NULL) -- presumably it is
7725                    not permitted to reference *a in various fashions
7726                    if (n == NULL) I suppose -- or it can avoid it by
7727                    looking at other info (other arguments, static/global
7728                    data, etc.).
7729
7730                    However, this won't work in gcc 2.5.8 because it'll
7731                    automatically emit the code to save the "*n"
7732                    expression, which'll yield a NULL dereference for
7733                    the "foo (NULL, NULL)" call, something the code
7734                    for foo cannot prevent.
7735
7736                    g77 definitely needs to avoid executing such
7737                    code anytime the pointer to the adjustable array
7738                    is NULL, because even if its bounds expressions
7739                    don't have any references to possible "absent"
7740                    variables like "*n" -- say all variable references
7741                    are to COMMON variables, i.e. global (though in C,
7742                    local static could actually make sense) -- the
7743                    expressions could yield other run-time problems
7744                    for allowably "dead" values in those variables.
7745
7746                    For example, let's consider a more complicated
7747                    version of foo:
7748
7749                      extern int i;
7750                      extern int j;
7751
7752                      void foo (float (*a)[i/j])
7753                      {
7754                        ...
7755                      }
7756
7757                    The above is (essentially) quite valid for Fortran
7758                    but, again, for a call like "foo (NULL);", it is
7759                    permitted for i and j to be undefined when the
7760                    call is made.  If j happened to be zero, for
7761                    example, emitting the code to evaluate "i/j"
7762                    could result in a run-time error.
7763
7764                    Offhand, though I don't have my F77 or F90
7765                    standards handy, it might even be valid for a
7766                    bounds expression to contain a function reference,
7767                    in which case I doubt it is permitted for an
7768                    implementation to invoke that function in the
7769                    Fortran case involved here (invocation of an
7770                    alternate ENTRY point that doesn't have the adjustable
7771                    array as one of its arguments).
7772
7773                    So, the code that the compiler would normally emit
7774                    to preevaluate the size/shape info for an
7775                    adjustable array _must not_ be executed at run time
7776                    in certain cases.  Specifically, for Fortran,
7777                    the case is when the pointer to the adjustable
7778                    array == NULL.  (For gnu-ish C, it might be nice
7779                    for the source code itself to specify an expression
7780                    that, if TRUE, inhibits execution of the code.  Or
7781                    reverse the sense for elegance.)
7782
7783                    (Note that g77 could use a different test than NULL,
7784                    actually, since it happens to always pass an
7785                    integer to the called function that specifies which
7786                    entry point is being invoked.  Hmm, this might
7787                    solve the next problem.)
7788
7789                    One way a user could, I suppose, write "foo" so
7790                    it works is to insert COND_EXPR's for the
7791                    size/shape info so the dangerous stuff isn't
7792                    actually done, as in:
7793
7794                      void foo (int *n, float (*a)[(a == NULL) ? 0 : *n])
7795                      {
7796                        ...
7797                      }
7798
7799                    The next problem is that the front end needs to
7800                    be able to tell the back end about the array's
7801                    decl _before_ it tells it about the conditional
7802                    expression to inhibit evaluation of size/shape info,
7803                    as shown above.
7804
7805                    To solve this, the front end needs to be able
7806                    to give the back end the expression to inhibit
7807                    generation of the preevaluation code _after_
7808                    it makes the decl for the adjustable array.
7809
7810                    Until then, the above example using the COND_EXPR
7811                    doesn't pass muster with gcc because the "(a == NULL)"
7812                    part has a reference to "a", which is still
7813                    undefined at that point.
7814
7815                    g77 will therefore use a different mechanism in the
7816                    meantime.  */
7817
7818                 if (!adjustable
7819                     && ((TREE_CODE (low) != INTEGER_CST)
7820                         || (high && TREE_CODE (high) != INTEGER_CST)))
7821                   adjustable = TRUE;
7822
7823 #if 0                           /* Old approach -- see below. */
7824                 if (TREE_CODE (low) != INTEGER_CST)
7825                   low = ffecom_3 (COND_EXPR, integer_type_node,
7826                                   ffecom_adjarray_passed_ (s),
7827                                   low,
7828                                   ffecom_integer_zero_node);
7829
7830                 if (high && TREE_CODE (high) != INTEGER_CST)
7831                   high = ffecom_3 (COND_EXPR, integer_type_node,
7832                                    ffecom_adjarray_passed_ (s),
7833                                    high,
7834                                    ffecom_integer_zero_node);
7835 #endif
7836
7837                 /* ~~~gcc/stor-layout.c (layout_type) should do this,
7838                    probably.  Fixes 950302-1.f.  */
7839
7840                 if (TREE_CODE (low) != INTEGER_CST)
7841                   low = variable_size (low);
7842
7843                 /* ~~~Similarly, this fixes dumb0.f.  The C front end
7844                    does this, which is why dumb0.c would work.  */
7845
7846                 if (high && TREE_CODE (high) != INTEGER_CST)
7847                   high = variable_size (high);
7848
7849                 type
7850                   = build_array_type
7851                     (type,
7852                      build_range_type (ffecom_integer_type_node,
7853                                        low, high));
7854                 type = ffecom_check_size_overflow_ (s, type, TRUE);
7855               }
7856
7857             if (type == error_mark_node)
7858               {
7859                 t = error_mark_node;
7860                 break;
7861               }
7862
7863             if ((ffesymbol_sfdummyparent (s) == NULL)
7864                  || (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER))
7865               {
7866                 type = build_pointer_type (type);
7867                 addr = TRUE;
7868               }
7869
7870             t = build_decl (PARM_DECL, t, type);
7871             DECL_ARTIFICIAL (t) = 1;
7872
7873             /* If this arg is present in every entry point's list of
7874                dummy args, then we're done.  */
7875
7876             if (ffesymbol_numentries (s)
7877                 == (ffecom_num_entrypoints_ + 1))
7878               break;
7879
7880 #if 1
7881
7882             /* If variable_size in stor-layout has been called during
7883                the above, then get_pending_sizes should have the
7884                yet-to-be-evaluated saved expressions pending.
7885                Make the whole lot of them get emitted, conditionally
7886                on whether the array decl ("t" above) is not NULL.  */
7887
7888             {
7889               tree sizes = get_pending_sizes ();
7890               tree tem;
7891
7892               for (tem = sizes;
7893                    tem != old_sizes;
7894                    tem = TREE_CHAIN (tem))
7895                 {
7896                   tree temv = TREE_VALUE (tem);
7897
7898                   if (sizes == tem)
7899                     sizes = temv;
7900                   else
7901                     sizes
7902                       = ffecom_2 (COMPOUND_EXPR,
7903                                   TREE_TYPE (sizes),
7904                                   temv,
7905                                   sizes);
7906                 }
7907
7908               if (sizes != tem)
7909                 {
7910                   sizes
7911                     = ffecom_3 (COND_EXPR,
7912                                 TREE_TYPE (sizes),
7913                                 ffecom_2 (NE_EXPR,
7914                                           integer_type_node,
7915                                           t,
7916                                           null_pointer_node),
7917                                 sizes,
7918                                 convert (TREE_TYPE (sizes),
7919                                          integer_zero_node));
7920                   sizes = ffecom_save_tree (sizes);
7921
7922                   sizes
7923                     = tree_cons (NULL_TREE, sizes, tem);
7924                 }
7925
7926               if (sizes)
7927                 put_pending_sizes (sizes);
7928             }
7929
7930 #else
7931 #if 0
7932             if (adjustable
7933                 && (ffesymbol_numentries (s)
7934                     != ffecom_num_entrypoints_ + 1))
7935               DECL_SOMETHING (t)
7936                 = ffecom_2 (NE_EXPR, integer_type_node,
7937                             t,
7938                             null_pointer_node);
7939 #else
7940 #if 0
7941             if (adjustable
7942                 && (ffesymbol_numentries (s)
7943                     != ffecom_num_entrypoints_ + 1))
7944               {
7945                 ffebad_start (FFEBAD_MISSING_ADJARRAY_UNSUPPORTED);
7946                 ffebad_here (0, ffesymbol_where_line (s),
7947                              ffesymbol_where_column (s));
7948                 ffebad_string (ffesymbol_text (s));
7949                 ffebad_finish ();
7950               }
7951 #endif
7952 #endif
7953 #endif
7954           }
7955           break;
7956
7957         case FFEINFO_whereCOMMON:
7958           {
7959             ffesymbol cs;
7960             ffeglobal cg;
7961             tree ct;
7962             ffestorag st = ffesymbol_storage (s);
7963             tree type;
7964
7965             cs = ffesymbol_common (s);  /* The COMMON area itself.  */
7966             if (st != NULL)     /* Else not laid out. */
7967               {
7968                 ffecom_transform_common_ (cs);
7969                 st = ffesymbol_storage (s);
7970               }
7971
7972             type = ffecom_type_localvar_ (s, bt, kt);
7973
7974             cg = ffesymbol_global (cs); /* The global COMMON info.  */
7975             if ((cg == NULL)
7976                 || (ffeglobal_type (cg) != FFEGLOBAL_typeCOMMON))
7977               ct = NULL_TREE;
7978             else
7979               ct = ffeglobal_hook (cg); /* The common area's tree.  */
7980
7981             if ((ct == NULL_TREE)
7982                 || (st == NULL)
7983                 || (type == error_mark_node))
7984               t = error_mark_node;
7985             else
7986               {
7987                 ffetargetOffset offset;
7988                 ffestorag cst;
7989
7990                 cst = ffestorag_parent (st);
7991                 assert (cst == ffesymbol_storage (cs));
7992
7993                 offset = ffestorag_modulo (cst)
7994                   + ffestorag_offset (st)
7995                   - ffestorag_offset (cst);
7996
7997                 ffecom_debug_kludge_ (ct, "COMMON", s, type, offset);
7998
7999                 /* (t_type *) (((char *) &ct) + offset) */
8000
8001                 t = convert (string_type_node,  /* (char *) */
8002                              ffecom_1 (ADDR_EXPR,
8003                                        build_pointer_type (TREE_TYPE (ct)),
8004                                        ct));
8005                 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
8006                               t,
8007                               build_int_2 (offset, 0));
8008                 t = convert (build_pointer_type (type),
8009                              t);
8010                 TREE_CONSTANT (t) = 1;
8011
8012                 addr = TRUE;
8013               }
8014           }
8015           break;
8016
8017         case FFEINFO_whereIMMEDIATE:
8018         case FFEINFO_whereGLOBAL:
8019         case FFEINFO_whereFLEETING:
8020         case FFEINFO_whereFLEETING_CADDR:
8021         case FFEINFO_whereFLEETING_IADDR:
8022         case FFEINFO_whereINTRINSIC:
8023         case FFEINFO_whereCONSTANT_SUBOBJECT:
8024         default:
8025           assert ("ENTITY where unheard of" == NULL);
8026           /* Fall through. */
8027         case FFEINFO_whereANY:
8028           t = error_mark_node;
8029           break;
8030         }
8031       break;
8032
8033     case FFEINFO_kindFUNCTION:
8034       switch (ffeinfo_where (ffesymbol_info (s)))
8035         {
8036         case FFEINFO_whereLOCAL:        /* Me. */
8037           assert (!ffecom_transform_only_dummies_);
8038           t = current_function_decl;
8039           break;
8040
8041         case FFEINFO_whereGLOBAL:
8042           assert (!ffecom_transform_only_dummies_);
8043
8044           if (((g = ffesymbol_global (s)) != NULL)
8045               && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8046                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8047               && (ffeglobal_hook (g) != NULL_TREE)
8048               && ffe_is_globals ())
8049             {
8050               t = ffeglobal_hook (g);
8051               break;
8052             }
8053
8054           if (ffesymbol_is_f2c (s)
8055               && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8056             t = ffecom_tree_fun_type[bt][kt];
8057           else
8058             t = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
8059
8060           t = build_decl (FUNCTION_DECL,
8061                           ffecom_get_external_identifier_ (s),
8062                           t);
8063           DECL_EXTERNAL (t) = 1;
8064           TREE_PUBLIC (t) = 1;
8065
8066           t = start_decl (t, FALSE);
8067           finish_decl (t, NULL_TREE, FALSE);
8068
8069           if ((g != NULL)
8070               && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8071                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8072             ffeglobal_set_hook (g, t);
8073
8074           ffecom_save_tree_forever (t);
8075
8076           break;
8077
8078         case FFEINFO_whereDUMMY:
8079           assert (ffecom_transform_only_dummies_);
8080
8081           if (ffesymbol_is_f2c (s)
8082               && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8083             t = ffecom_tree_ptr_to_fun_type[bt][kt];
8084           else
8085             t = build_pointer_type
8086               (build_function_type (ffecom_tree_type[bt][kt], NULL_TREE));
8087
8088           t = build_decl (PARM_DECL,
8089                           ffecom_get_identifier_ (ffesymbol_text (s)),
8090                           t);
8091           DECL_ARTIFICIAL (t) = 1;
8092           addr = TRUE;
8093           break;
8094
8095         case FFEINFO_whereCONSTANT:     /* Statement function. */
8096           assert (!ffecom_transform_only_dummies_);
8097           t = ffecom_gen_sfuncdef_ (s, bt, kt);
8098           break;
8099
8100         case FFEINFO_whereINTRINSIC:
8101           assert (!ffecom_transform_only_dummies_);
8102           break;                /* Let actual references generate their
8103                                    decls. */
8104
8105         default:
8106           assert ("FUNCTION where unheard of" == NULL);
8107           /* Fall through. */
8108         case FFEINFO_whereANY:
8109           t = error_mark_node;
8110           break;
8111         }
8112       break;
8113
8114     case FFEINFO_kindSUBROUTINE:
8115       switch (ffeinfo_where (ffesymbol_info (s)))
8116         {
8117         case FFEINFO_whereLOCAL:        /* Me. */
8118           assert (!ffecom_transform_only_dummies_);
8119           t = current_function_decl;
8120           break;
8121
8122         case FFEINFO_whereGLOBAL:
8123           assert (!ffecom_transform_only_dummies_);
8124
8125           if (((g = ffesymbol_global (s)) != NULL)
8126               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8127                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8128               && (ffeglobal_hook (g) != NULL_TREE)
8129               && ffe_is_globals ())
8130             {
8131               t = ffeglobal_hook (g);
8132               break;
8133             }
8134
8135           t = build_decl (FUNCTION_DECL,
8136                           ffecom_get_external_identifier_ (s),
8137                           ffecom_tree_subr_type);
8138           DECL_EXTERNAL (t) = 1;
8139           TREE_PUBLIC (t) = 1;
8140
8141           t = start_decl (t, FALSE);
8142           finish_decl (t, NULL_TREE, FALSE);
8143
8144           if ((g != NULL)
8145               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8146                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8147             ffeglobal_set_hook (g, t);
8148
8149           ffecom_save_tree_forever (t);
8150
8151           break;
8152
8153         case FFEINFO_whereDUMMY:
8154           assert (ffecom_transform_only_dummies_);
8155
8156           t = build_decl (PARM_DECL,
8157                           ffecom_get_identifier_ (ffesymbol_text (s)),
8158                           ffecom_tree_ptr_to_subr_type);
8159           DECL_ARTIFICIAL (t) = 1;
8160           addr = TRUE;
8161           break;
8162
8163         case FFEINFO_whereINTRINSIC:
8164           assert (!ffecom_transform_only_dummies_);
8165           break;                /* Let actual references generate their
8166                                    decls. */
8167
8168         default:
8169           assert ("SUBROUTINE where unheard of" == NULL);
8170           /* Fall through. */
8171         case FFEINFO_whereANY:
8172           t = error_mark_node;
8173           break;
8174         }
8175       break;
8176
8177     case FFEINFO_kindPROGRAM:
8178       switch (ffeinfo_where (ffesymbol_info (s)))
8179         {
8180         case FFEINFO_whereLOCAL:        /* Me. */
8181           assert (!ffecom_transform_only_dummies_);
8182           t = current_function_decl;
8183           break;
8184
8185         case FFEINFO_whereCOMMON:
8186         case FFEINFO_whereDUMMY:
8187         case FFEINFO_whereGLOBAL:
8188         case FFEINFO_whereRESULT:
8189         case FFEINFO_whereFLEETING:
8190         case FFEINFO_whereFLEETING_CADDR:
8191         case FFEINFO_whereFLEETING_IADDR:
8192         case FFEINFO_whereIMMEDIATE:
8193         case FFEINFO_whereINTRINSIC:
8194         case FFEINFO_whereCONSTANT:
8195         case FFEINFO_whereCONSTANT_SUBOBJECT:
8196         default:
8197           assert ("PROGRAM where unheard of" == NULL);
8198           /* Fall through. */
8199         case FFEINFO_whereANY:
8200           t = error_mark_node;
8201           break;
8202         }
8203       break;
8204
8205     case FFEINFO_kindBLOCKDATA:
8206       switch (ffeinfo_where (ffesymbol_info (s)))
8207         {
8208         case FFEINFO_whereLOCAL:        /* Me. */
8209           assert (!ffecom_transform_only_dummies_);
8210           t = current_function_decl;
8211           break;
8212
8213         case FFEINFO_whereGLOBAL:
8214           assert (!ffecom_transform_only_dummies_);
8215
8216           t = build_decl (FUNCTION_DECL,
8217                           ffecom_get_external_identifier_ (s),
8218                           ffecom_tree_blockdata_type);
8219           DECL_EXTERNAL (t) = 1;
8220           TREE_PUBLIC (t) = 1;
8221
8222           t = start_decl (t, FALSE);
8223           finish_decl (t, NULL_TREE, FALSE);
8224
8225           ffecom_save_tree_forever (t);
8226
8227           break;
8228
8229         case FFEINFO_whereCOMMON:
8230         case FFEINFO_whereDUMMY:
8231         case FFEINFO_whereRESULT:
8232         case FFEINFO_whereFLEETING:
8233         case FFEINFO_whereFLEETING_CADDR:
8234         case FFEINFO_whereFLEETING_IADDR:
8235         case FFEINFO_whereIMMEDIATE:
8236         case FFEINFO_whereINTRINSIC:
8237         case FFEINFO_whereCONSTANT:
8238         case FFEINFO_whereCONSTANT_SUBOBJECT:
8239         default:
8240           assert ("BLOCKDATA where unheard of" == NULL);
8241           /* Fall through. */
8242         case FFEINFO_whereANY:
8243           t = error_mark_node;
8244           break;
8245         }
8246       break;
8247
8248     case FFEINFO_kindCOMMON:
8249       switch (ffeinfo_where (ffesymbol_info (s)))
8250         {
8251         case FFEINFO_whereLOCAL:
8252           assert (!ffecom_transform_only_dummies_);
8253           ffecom_transform_common_ (s);
8254           break;
8255
8256         case FFEINFO_whereNONE:
8257         case FFEINFO_whereCOMMON:
8258         case FFEINFO_whereDUMMY:
8259         case FFEINFO_whereGLOBAL:
8260         case FFEINFO_whereRESULT:
8261         case FFEINFO_whereFLEETING:
8262         case FFEINFO_whereFLEETING_CADDR:
8263         case FFEINFO_whereFLEETING_IADDR:
8264         case FFEINFO_whereIMMEDIATE:
8265         case FFEINFO_whereINTRINSIC:
8266         case FFEINFO_whereCONSTANT:
8267         case FFEINFO_whereCONSTANT_SUBOBJECT:
8268         default:
8269           assert ("COMMON where unheard of" == NULL);
8270           /* Fall through. */
8271         case FFEINFO_whereANY:
8272           t = error_mark_node;
8273           break;
8274         }
8275       break;
8276
8277     case FFEINFO_kindCONSTRUCT:
8278       switch (ffeinfo_where (ffesymbol_info (s)))
8279         {
8280         case FFEINFO_whereLOCAL:
8281           assert (!ffecom_transform_only_dummies_);
8282           break;
8283
8284         case FFEINFO_whereNONE:
8285         case FFEINFO_whereCOMMON:
8286         case FFEINFO_whereDUMMY:
8287         case FFEINFO_whereGLOBAL:
8288         case FFEINFO_whereRESULT:
8289         case FFEINFO_whereFLEETING:
8290         case FFEINFO_whereFLEETING_CADDR:
8291         case FFEINFO_whereFLEETING_IADDR:
8292         case FFEINFO_whereIMMEDIATE:
8293         case FFEINFO_whereINTRINSIC:
8294         case FFEINFO_whereCONSTANT:
8295         case FFEINFO_whereCONSTANT_SUBOBJECT:
8296         default:
8297           assert ("CONSTRUCT where unheard of" == NULL);
8298           /* Fall through. */
8299         case FFEINFO_whereANY:
8300           t = error_mark_node;
8301           break;
8302         }
8303       break;
8304
8305     case FFEINFO_kindNAMELIST:
8306       switch (ffeinfo_where (ffesymbol_info (s)))
8307         {
8308         case FFEINFO_whereLOCAL:
8309           assert (!ffecom_transform_only_dummies_);
8310           t = ffecom_transform_namelist_ (s);
8311           break;
8312
8313         case FFEINFO_whereNONE:
8314         case FFEINFO_whereCOMMON:
8315         case FFEINFO_whereDUMMY:
8316         case FFEINFO_whereGLOBAL:
8317         case FFEINFO_whereRESULT:
8318         case FFEINFO_whereFLEETING:
8319         case FFEINFO_whereFLEETING_CADDR:
8320         case FFEINFO_whereFLEETING_IADDR:
8321         case FFEINFO_whereIMMEDIATE:
8322         case FFEINFO_whereINTRINSIC:
8323         case FFEINFO_whereCONSTANT:
8324         case FFEINFO_whereCONSTANT_SUBOBJECT:
8325         default:
8326           assert ("NAMELIST where unheard of" == NULL);
8327           /* Fall through. */
8328         case FFEINFO_whereANY:
8329           t = error_mark_node;
8330           break;
8331         }
8332       break;
8333
8334     default:
8335       assert ("kind unheard of" == NULL);
8336       /* Fall through. */
8337     case FFEINFO_kindANY:
8338       t = error_mark_node;
8339       break;
8340     }
8341
8342   ffesymbol_hook (s).decl_tree = t;
8343   ffesymbol_hook (s).length_tree = tlen;
8344   ffesymbol_hook (s).addr = addr;
8345
8346   lineno = old_lineno;
8347   input_filename = old_input_filename;
8348
8349   return s;
8350 }
8351
8352 /* Transform into ASSIGNable symbol.
8353
8354    Symbol has already been transformed, but for whatever reason, the
8355    resulting decl_tree has been deemed not usable for an ASSIGN target.
8356    (E.g. it isn't wide enough to hold a pointer.)  So, here we invent
8357    another local symbol of type void * and stuff that in the assign_tree
8358    argument.  The F77/F90 standards allow this implementation.  */
8359
8360 static ffesymbol
8361 ffecom_sym_transform_assign_ (ffesymbol s)
8362 {
8363   tree t;                       /* Transformed thingy. */
8364   int old_lineno = lineno;
8365   const char *old_input_filename = input_filename;
8366
8367   if (ffesymbol_sfdummyparent (s) == NULL)
8368     {
8369       input_filename = ffesymbol_where_filename (s);
8370       lineno = ffesymbol_where_filelinenum (s);
8371     }
8372   else
8373     {
8374       ffesymbol sf = ffesymbol_sfdummyparent (s);
8375
8376       input_filename = ffesymbol_where_filename (sf);
8377       lineno = ffesymbol_where_filelinenum (sf);
8378     }
8379
8380   assert (!ffecom_transform_only_dummies_);
8381
8382   t = build_decl (VAR_DECL,
8383                   ffecom_get_invented_identifier ("__g77_ASSIGN_%s",
8384                                                    ffesymbol_text (s)),
8385                   TREE_TYPE (null_pointer_node));
8386
8387   switch (ffesymbol_where (s))
8388     {
8389     case FFEINFO_whereLOCAL:
8390       /* Unlike for regular vars, SAVE status is easy to determine for
8391          ASSIGNed vars, since there's no initialization, there's no
8392          effective storage association (so "SAVE J" does not apply to
8393          K even given "EQUIVALENCE (J,K)"), there's no size issue
8394          to worry about, etc.  */
8395       if ((ffesymbol_is_save (s) || ffe_is_saveall ())
8396           && (ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8397           && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA))
8398         TREE_STATIC (t) = 1;    /* SAVEd in proc, make static. */
8399       else
8400         TREE_STATIC (t) = 0;    /* No need to make static. */
8401       break;
8402
8403     case FFEINFO_whereCOMMON:
8404       TREE_STATIC (t) = 1;      /* Assume COMMONs always SAVEd. */
8405       break;
8406
8407     case FFEINFO_whereDUMMY:
8408       /* Note that twinning a DUMMY means the caller won't see
8409          the ASSIGNed value.  But both F77 and F90 allow implementations
8410          to do this, i.e. disallow Fortran code that would try and
8411          take advantage of actually putting a label into a variable
8412          via a dummy argument (or any other storage association, for
8413          that matter).  */
8414       TREE_STATIC (t) = 0;
8415       break;
8416
8417     default:
8418       TREE_STATIC (t) = 0;
8419       break;
8420     }
8421
8422   t = start_decl (t, FALSE);
8423   finish_decl (t, NULL_TREE, FALSE);
8424
8425   ffesymbol_hook (s).assign_tree = t;
8426
8427   lineno = old_lineno;
8428   input_filename = old_input_filename;
8429
8430   return s;
8431 }
8432
8433 /* Implement COMMON area in back end.
8434
8435    Because COMMON-based variables can be referenced in the dimension
8436    expressions of dummy (adjustable) arrays, and because dummies
8437    (in the gcc back end) need to be put in the outer binding level
8438    of a function (which has two binding levels, the outer holding
8439    the dummies and the inner holding the other vars), special care
8440    must be taken to handle COMMON areas.
8441
8442    The current strategy is basically to always tell the back end about
8443    the COMMON area as a top-level external reference to just a block
8444    of storage of the master type of that area (e.g. integer, real,
8445    character, whatever -- not a structure).  As a distinct action,
8446    if initial values are provided, tell the back end about the area
8447    as a top-level non-external (initialized) area and remember not to
8448    allow further initialization or expansion of the area.  Meanwhile,
8449    if no initialization happens at all, tell the back end about
8450    the largest size we've seen declared so the space does get reserved.
8451    (This function doesn't handle all that stuff, but it does some
8452    of the important things.)
8453
8454    Meanwhile, for COMMON variables themselves, just keep creating
8455    references like *((float *) (&common_area + offset)) each time
8456    we reference the variable.  In other words, don't make a VAR_DECL
8457    or any kind of component reference (like we used to do before 0.4),
8458    though we might do that as well just for debugging purposes (and
8459    stuff the rtl with the appropriate offset expression).  */
8460
8461 static void
8462 ffecom_transform_common_ (ffesymbol s)
8463 {
8464   ffestorag st = ffesymbol_storage (s);
8465   ffeglobal g = ffesymbol_global (s);
8466   tree cbt;
8467   tree cbtype;
8468   tree init;
8469   tree high;
8470   bool is_init = ffestorag_is_init (st);
8471
8472   assert (st != NULL);
8473
8474   if ((g == NULL)
8475       || (ffeglobal_type (g) != FFEGLOBAL_typeCOMMON))
8476     return;
8477
8478   /* First update the size of the area in global terms.  */
8479
8480   ffeglobal_size_common (s, ffestorag_size (st));
8481
8482   if (!ffeglobal_common_init (g))
8483     is_init = FALSE;    /* No explicit init, don't let erroneous joins init. */
8484
8485   cbt = ffeglobal_hook (g);
8486
8487   /* If we already have declared this common block for a previous program
8488      unit, and either we already initialized it or we don't have new
8489      initialization for it, just return what we have without changing it.  */
8490
8491   if ((cbt != NULL_TREE)
8492       && (!is_init
8493           || !DECL_EXTERNAL (cbt)))
8494     {
8495       if (st->hook == NULL) ffestorag_set_hook (st, cbt);
8496       return;
8497     }
8498
8499   /* Process inits.  */
8500
8501   if (is_init)
8502     {
8503       if (ffestorag_init (st) != NULL)
8504         {
8505           ffebld sexp;
8506
8507           /* Set the padding for the expression, so ffecom_expr
8508              knows to insert that many zeros.  */
8509           switch (ffebld_op (sexp = ffestorag_init (st)))
8510             {
8511             case FFEBLD_opCONTER:
8512               ffebld_conter_set_pad (sexp, ffestorag_modulo (st));
8513               break;
8514
8515             case FFEBLD_opARRTER:
8516               ffebld_arrter_set_pad (sexp, ffestorag_modulo (st));
8517               break;
8518
8519             case FFEBLD_opACCTER:
8520               ffebld_accter_set_pad (sexp, ffestorag_modulo (st));
8521               break;
8522
8523             default:
8524               assert ("bad op for cmn init (pad)" == NULL);
8525               break;
8526             }
8527
8528           init = ffecom_expr (sexp);
8529           if (init == error_mark_node)
8530             {                   /* Hopefully the back end complained! */
8531               init = NULL_TREE;
8532               if (cbt != NULL_TREE)
8533                 return;
8534             }
8535         }
8536       else
8537         init = error_mark_node;
8538     }
8539   else
8540     init = NULL_TREE;
8541
8542   /* cbtype must be permanently allocated!  */
8543
8544   /* Allocate the MAX of the areas so far, seen filewide.  */
8545   high = build_int_2 ((ffeglobal_common_size (g)
8546                        + ffeglobal_common_pad (g)) - 1, 0);
8547   TREE_TYPE (high) = ffecom_integer_type_node;
8548
8549   if (init)
8550     cbtype = build_array_type (char_type_node,
8551                                build_range_type (integer_type_node,
8552                                                  integer_zero_node,
8553                                                  high));
8554   else
8555     cbtype = build_array_type (char_type_node, NULL_TREE);
8556
8557   if (cbt == NULL_TREE)
8558     {
8559       cbt
8560         = build_decl (VAR_DECL,
8561                       ffecom_get_external_identifier_ (s),
8562                       cbtype);
8563       TREE_STATIC (cbt) = 1;
8564       TREE_PUBLIC (cbt) = 1;
8565     }
8566   else
8567     {
8568       assert (is_init);
8569       TREE_TYPE (cbt) = cbtype;
8570     }
8571   DECL_EXTERNAL (cbt) = init ? 0 : 1;
8572   DECL_INITIAL (cbt) = init ? error_mark_node : NULL_TREE;
8573
8574   cbt = start_decl (cbt, TRUE);
8575   if (ffeglobal_hook (g) != NULL)
8576     assert (cbt == ffeglobal_hook (g));
8577
8578   assert (!init || !DECL_EXTERNAL (cbt));
8579
8580   /* Make sure that any type can live in COMMON and be referenced
8581      without getting a bus error.  We could pick the most restrictive
8582      alignment of all entities actually placed in the COMMON, but
8583      this seems easy enough.  */
8584
8585   DECL_ALIGN (cbt) = BIGGEST_ALIGNMENT;
8586   DECL_USER_ALIGN (cbt) = 0;
8587
8588   if (is_init && (ffestorag_init (st) == NULL))
8589     init = ffecom_init_zero_ (cbt);
8590
8591   finish_decl (cbt, init, TRUE);
8592
8593   if (is_init)
8594     ffestorag_set_init (st, ffebld_new_any ());
8595
8596   if (init)
8597     {
8598       assert (DECL_SIZE_UNIT (cbt) != NULL_TREE);
8599       assert (TREE_CODE (DECL_SIZE_UNIT (cbt)) == INTEGER_CST);
8600       assert (0 == compare_tree_int (DECL_SIZE_UNIT (cbt),
8601                                      (ffeglobal_common_size (g)
8602                                       + ffeglobal_common_pad (g))));
8603     }
8604
8605   ffeglobal_set_hook (g, cbt);
8606
8607   ffestorag_set_hook (st, cbt);
8608
8609   ffecom_save_tree_forever (cbt);
8610 }
8611
8612 /* Make master area for local EQUIVALENCE.  */
8613
8614 static void
8615 ffecom_transform_equiv_ (ffestorag eqst)
8616 {
8617   tree eqt;
8618   tree eqtype;
8619   tree init;
8620   tree high;
8621   bool is_init = ffestorag_is_init (eqst);
8622
8623   assert (eqst != NULL);
8624
8625   eqt = ffestorag_hook (eqst);
8626
8627   if (eqt != NULL_TREE)
8628     return;
8629
8630   /* Process inits.  */
8631
8632   if (is_init)
8633     {
8634       if (ffestorag_init (eqst) != NULL)
8635         {
8636           ffebld sexp;
8637
8638           /* Set the padding for the expression, so ffecom_expr
8639              knows to insert that many zeros.  */
8640           switch (ffebld_op (sexp = ffestorag_init (eqst)))
8641             {
8642             case FFEBLD_opCONTER:
8643               ffebld_conter_set_pad (sexp, ffestorag_modulo (eqst));
8644               break;
8645
8646             case FFEBLD_opARRTER:
8647               ffebld_arrter_set_pad (sexp, ffestorag_modulo (eqst));
8648               break;
8649
8650             case FFEBLD_opACCTER:
8651               ffebld_accter_set_pad (sexp, ffestorag_modulo (eqst));
8652               break;
8653
8654             default:
8655               assert ("bad op for eqv init (pad)" == NULL);
8656               break;
8657             }
8658
8659           init = ffecom_expr (sexp);
8660           if (init == error_mark_node)
8661             init = NULL_TREE;   /* Hopefully the back end complained! */
8662         }
8663       else
8664         init = error_mark_node;
8665     }
8666   else if (ffe_is_init_local_zero ())
8667     init = error_mark_node;
8668   else
8669     init = NULL_TREE;
8670
8671   ffecom_member_namelisted_ = FALSE;
8672   ffestorag_drive (ffestorag_list_equivs (eqst),
8673                    &ffecom_member_phase1_,
8674                    eqst);
8675
8676   high = build_int_2 ((ffestorag_size (eqst)
8677                        + ffestorag_modulo (eqst)) - 1, 0);
8678   TREE_TYPE (high) = ffecom_integer_type_node;
8679
8680   eqtype = build_array_type (char_type_node,
8681                              build_range_type (ffecom_integer_type_node,
8682                                                ffecom_integer_zero_node,
8683                                                high));
8684
8685   eqt = build_decl (VAR_DECL,
8686                     ffecom_get_invented_identifier ("__g77_equiv_%s",
8687                                                     ffesymbol_text
8688                                                     (ffestorag_symbol (eqst))),
8689                     eqtype);
8690   DECL_EXTERNAL (eqt) = 0;
8691   if (is_init
8692       || ffecom_member_namelisted_
8693 #ifdef FFECOM_sizeMAXSTACKITEM
8694       || (ffestorag_size (eqst) > FFECOM_sizeMAXSTACKITEM)
8695 #endif
8696       || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8697           && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
8698           && (ffestorag_is_save (eqst) || ffe_is_saveall ())))
8699     TREE_STATIC (eqt) = 1;
8700   else
8701     TREE_STATIC (eqt) = 0;
8702   TREE_PUBLIC (eqt) = 0;
8703   TREE_ADDRESSABLE (eqt) = 1;  /* Ensure non-register allocation */
8704   DECL_CONTEXT (eqt) = current_function_decl;
8705   if (init)
8706     DECL_INITIAL (eqt) = error_mark_node;
8707   else
8708     DECL_INITIAL (eqt) = NULL_TREE;
8709
8710   eqt = start_decl (eqt, FALSE);
8711
8712   /* Make sure that any type can live in EQUIVALENCE and be referenced
8713      without getting a bus error.  We could pick the most restrictive
8714      alignment of all entities actually placed in the EQUIVALENCE, but
8715      this seems easy enough.  */
8716
8717   DECL_ALIGN (eqt) = BIGGEST_ALIGNMENT;
8718   DECL_USER_ALIGN (eqt) = 0;
8719
8720   if ((!is_init && ffe_is_init_local_zero ())
8721       || (is_init && (ffestorag_init (eqst) == NULL)))
8722     init = ffecom_init_zero_ (eqt);
8723
8724   finish_decl (eqt, init, FALSE);
8725
8726   if (is_init)
8727     ffestorag_set_init (eqst, ffebld_new_any ());
8728
8729   {
8730     assert (TREE_CODE (DECL_SIZE_UNIT (eqt)) == INTEGER_CST);
8731     assert (0 == compare_tree_int (DECL_SIZE_UNIT (eqt),
8732                                    (ffestorag_size (eqst)
8733                                     + ffestorag_modulo (eqst))));
8734   }
8735
8736   ffestorag_set_hook (eqst, eqt);
8737
8738   ffestorag_drive (ffestorag_list_equivs (eqst),
8739                    &ffecom_member_phase2_,
8740                    eqst);
8741 }
8742
8743 /* Implement NAMELIST in back end.  See f2c/format.c for more info.  */
8744
8745 static tree
8746 ffecom_transform_namelist_ (ffesymbol s)
8747 {
8748   tree nmlt;
8749   tree nmltype = ffecom_type_namelist_ ();
8750   tree nmlinits;
8751   tree nameinit;
8752   tree varsinit;
8753   tree nvarsinit;
8754   tree field;
8755   tree high;
8756   int i;
8757   static int mynumber = 0;
8758
8759   nmlt = build_decl (VAR_DECL,
8760                      ffecom_get_invented_identifier ("__g77_namelist_%d",
8761                                                      mynumber++),
8762                      nmltype);
8763   TREE_STATIC (nmlt) = 1;
8764   DECL_INITIAL (nmlt) = error_mark_node;
8765
8766   nmlt = start_decl (nmlt, FALSE);
8767
8768   /* Process inits.  */
8769
8770   i = strlen (ffesymbol_text (s));
8771
8772   high = build_int_2 (i, 0);
8773   TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
8774
8775   nameinit = ffecom_build_f2c_string_ (i + 1,
8776                                        ffesymbol_text (s));
8777   TREE_TYPE (nameinit)
8778     = build_type_variant
8779     (build_array_type
8780      (char_type_node,
8781       build_range_type (ffecom_f2c_ftnlen_type_node,
8782                         ffecom_f2c_ftnlen_one_node,
8783                         high)),
8784      1, 0);
8785   TREE_CONSTANT (nameinit) = 1;
8786   TREE_STATIC (nameinit) = 1;
8787   nameinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (nameinit)),
8788                        nameinit);
8789
8790   varsinit = ffecom_vardesc_array_ (s);
8791   varsinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (varsinit)),
8792                        varsinit);
8793   TREE_CONSTANT (varsinit) = 1;
8794   TREE_STATIC (varsinit) = 1;
8795
8796   {
8797     ffebld b;
8798
8799     for (i = 0, b = ffesymbol_namelist (s); b != NULL; b = ffebld_trail (b))
8800       ++i;
8801   }
8802   nvarsinit = build_int_2 (i, 0);
8803   TREE_TYPE (nvarsinit) = integer_type_node;
8804   TREE_CONSTANT (nvarsinit) = 1;
8805   TREE_STATIC (nvarsinit) = 1;
8806
8807   nmlinits = build_tree_list ((field = TYPE_FIELDS (nmltype)), nameinit);
8808   TREE_CHAIN (nmlinits) = build_tree_list ((field = TREE_CHAIN (field)),
8809                                            varsinit);
8810   TREE_CHAIN (TREE_CHAIN (nmlinits))
8811     = build_tree_list ((field = TREE_CHAIN (field)), nvarsinit);
8812
8813   nmlinits = build (CONSTRUCTOR, nmltype, NULL_TREE, nmlinits);
8814   TREE_CONSTANT (nmlinits) = 1;
8815   TREE_STATIC (nmlinits) = 1;
8816
8817   finish_decl (nmlt, nmlinits, FALSE);
8818
8819   nmlt = ffecom_1 (ADDR_EXPR, build_pointer_type (nmltype), nmlt);
8820
8821   return nmlt;
8822 }
8823
8824 /* A subroutine of ffecom_tree_canonize_ref_.  The incoming tree is
8825    analyzed on the assumption it is calculating a pointer to be
8826    indirected through.  It must return the proper decl and offset,
8827    taking into account different units of measurements for offsets.  */
8828
8829 static void
8830 ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
8831                            tree t)
8832 {
8833   switch (TREE_CODE (t))
8834     {
8835     case NOP_EXPR:
8836     case CONVERT_EXPR:
8837     case NON_LVALUE_EXPR:
8838       ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
8839       break;
8840
8841     case PLUS_EXPR:
8842       ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
8843       if ((*decl == NULL_TREE)
8844           || (*decl == error_mark_node))
8845         break;
8846
8847       if (TREE_CODE (TREE_OPERAND (t, 1)) == INTEGER_CST)
8848         {
8849           /* An offset into COMMON.  */
8850           *offset = fold (build (PLUS_EXPR, TREE_TYPE (*offset),
8851                                  *offset, TREE_OPERAND (t, 1)));
8852           /* Convert offset (presumably in bytes) into canonical units
8853              (presumably bits).  */
8854           *offset = size_binop (MULT_EXPR,
8855                                 convert (bitsizetype, *offset),
8856                                 TYPE_SIZE (TREE_TYPE (TREE_TYPE (t))));
8857           break;
8858         }
8859       /* Not a COMMON reference, so an unrecognized pattern.  */
8860       *decl = error_mark_node;
8861       break;
8862
8863     case PARM_DECL:
8864       *decl = t;
8865       *offset = bitsize_zero_node;
8866       break;
8867
8868     case ADDR_EXPR:
8869       if (TREE_CODE (TREE_OPERAND (t, 0)) == VAR_DECL)
8870         {
8871           /* A reference to COMMON.  */
8872           *decl = TREE_OPERAND (t, 0);
8873           *offset = bitsize_zero_node;
8874           break;
8875         }
8876       /* Fall through.  */
8877     default:
8878       /* Not a COMMON reference, so an unrecognized pattern.  */
8879       *decl = error_mark_node;
8880       break;
8881     }
8882 }
8883
8884 /* Given a tree that is possibly intended for use as an lvalue, return
8885    information representing a canonical view of that tree as a decl, an
8886    offset into that decl, and a size for the lvalue.
8887
8888    If there's no applicable decl, NULL_TREE is returned for the decl,
8889    and the other fields are left undefined.
8890
8891    If the tree doesn't fit the recognizable forms, an ERROR_MARK node
8892    is returned for the decl, and the other fields are left undefined.
8893
8894    Otherwise, the decl returned currently is either a VAR_DECL or a
8895    PARM_DECL.
8896
8897    The offset returned is always valid, but of course not necessarily
8898    a constant, and not necessarily converted into the appropriate
8899    type, leaving that up to the caller (so as to avoid that overhead
8900    if the decls being looked at are different anyway).
8901
8902    If the size cannot be determined (e.g. an adjustable array),
8903    an ERROR_MARK node is returned for the size.  Otherwise, the
8904    size returned is valid, not necessarily a constant, and not
8905    necessarily converted into the appropriate type as with the
8906    offset.
8907
8908    Note that the offset and size expressions are expressed in the
8909    base storage units (usually bits) rather than in the units of
8910    the type of the decl, because two decls with different types
8911    might overlap but with apparently non-overlapping array offsets,
8912    whereas converting the array offsets to consistant offsets will
8913    reveal the overlap.  */
8914
8915 static void
8916 ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
8917                            tree *size, tree t)
8918 {
8919   /* The default path is to report a nonexistant decl.  */
8920   *decl = NULL_TREE;
8921
8922   if (t == NULL_TREE)
8923     return;
8924
8925   switch (TREE_CODE (t))
8926     {
8927     case ERROR_MARK:
8928     case IDENTIFIER_NODE:
8929     case INTEGER_CST:
8930     case REAL_CST:
8931     case COMPLEX_CST:
8932     case STRING_CST:
8933     case CONST_DECL:
8934     case PLUS_EXPR:
8935     case MINUS_EXPR:
8936     case MULT_EXPR:
8937     case TRUNC_DIV_EXPR:
8938     case CEIL_DIV_EXPR:
8939     case FLOOR_DIV_EXPR:
8940     case ROUND_DIV_EXPR:
8941     case TRUNC_MOD_EXPR:
8942     case CEIL_MOD_EXPR:
8943     case FLOOR_MOD_EXPR:
8944     case ROUND_MOD_EXPR:
8945     case RDIV_EXPR:
8946     case EXACT_DIV_EXPR:
8947     case FIX_TRUNC_EXPR:
8948     case FIX_CEIL_EXPR:
8949     case FIX_FLOOR_EXPR:
8950     case FIX_ROUND_EXPR:
8951     case FLOAT_EXPR:
8952     case NEGATE_EXPR:
8953     case MIN_EXPR:
8954     case MAX_EXPR:
8955     case ABS_EXPR:
8956     case FFS_EXPR:
8957     case LSHIFT_EXPR:
8958     case RSHIFT_EXPR:
8959     case LROTATE_EXPR:
8960     case RROTATE_EXPR:
8961     case BIT_IOR_EXPR:
8962     case BIT_XOR_EXPR:
8963     case BIT_AND_EXPR:
8964     case BIT_ANDTC_EXPR:
8965     case BIT_NOT_EXPR:
8966     case TRUTH_ANDIF_EXPR:
8967     case TRUTH_ORIF_EXPR:
8968     case TRUTH_AND_EXPR:
8969     case TRUTH_OR_EXPR:
8970     case TRUTH_XOR_EXPR:
8971     case TRUTH_NOT_EXPR:
8972     case LT_EXPR:
8973     case LE_EXPR:
8974     case GT_EXPR:
8975     case GE_EXPR:
8976     case EQ_EXPR:
8977     case NE_EXPR:
8978     case COMPLEX_EXPR:
8979     case CONJ_EXPR:
8980     case REALPART_EXPR:
8981     case IMAGPART_EXPR:
8982     case LABEL_EXPR:
8983     case COMPONENT_REF:
8984     case COMPOUND_EXPR:
8985     case ADDR_EXPR:
8986       return;
8987
8988     case VAR_DECL:
8989     case PARM_DECL:
8990       *decl = t;
8991       *offset = bitsize_zero_node;
8992       *size = TYPE_SIZE (TREE_TYPE (t));
8993       return;
8994
8995     case ARRAY_REF:
8996       {
8997         tree array = TREE_OPERAND (t, 0);
8998         tree element = TREE_OPERAND (t, 1);
8999         tree init_offset;
9000
9001         if ((array == NULL_TREE)
9002             || (element == NULL_TREE))
9003           {
9004             *decl = error_mark_node;
9005             return;
9006           }
9007
9008         ffecom_tree_canonize_ref_ (decl, &init_offset, size,
9009                                    array);
9010         if ((*decl == NULL_TREE)
9011             || (*decl == error_mark_node))
9012           return;
9013
9014         /* Calculate ((element - base) * NBBY) + init_offset.  */
9015         *offset = fold (build (MINUS_EXPR, TREE_TYPE (element),
9016                                element,
9017                                TYPE_MIN_VALUE (TYPE_DOMAIN
9018                                                (TREE_TYPE (array)))));
9019
9020         *offset = size_binop (MULT_EXPR,
9021                               convert (bitsizetype, *offset),
9022                               TYPE_SIZE (TREE_TYPE (TREE_TYPE (array))));
9023
9024         *offset = size_binop (PLUS_EXPR, init_offset, *offset);
9025
9026         *size = TYPE_SIZE (TREE_TYPE (t));
9027         return;
9028       }
9029
9030     case INDIRECT_REF:
9031
9032       /* Most of this code is to handle references to COMMON.  And so
9033          far that is useful only for calling library functions, since
9034          external (user) functions might reference common areas.  But
9035          even calling an external function, it's worthwhile to decode
9036          COMMON references because if not storing into COMMON, we don't
9037          want COMMON-based arguments to gratuitously force use of a
9038          temporary.  */
9039
9040       *size = TYPE_SIZE (TREE_TYPE (t));
9041
9042       ffecom_tree_canonize_ptr_ (decl, offset,
9043                                  TREE_OPERAND (t, 0));
9044
9045       return;
9046
9047     case CONVERT_EXPR:
9048     case NOP_EXPR:
9049     case MODIFY_EXPR:
9050     case NON_LVALUE_EXPR:
9051     case RESULT_DECL:
9052     case FIELD_DECL:
9053     case COND_EXPR:             /* More cases than we can handle. */
9054     case SAVE_EXPR:
9055     case REFERENCE_EXPR:
9056     case PREDECREMENT_EXPR:
9057     case PREINCREMENT_EXPR:
9058     case POSTDECREMENT_EXPR:
9059     case POSTINCREMENT_EXPR:
9060     case CALL_EXPR:
9061     default:
9062       *decl = error_mark_node;
9063       return;
9064     }
9065 }
9066
9067 /* Do divide operation appropriate to type of operands.  */
9068
9069 static tree
9070 ffecom_tree_divide_ (tree tree_type, tree left, tree right,
9071                      tree dest_tree, ffebld dest, bool *dest_used,
9072                      tree hook)
9073 {
9074   if ((left == error_mark_node)
9075       || (right == error_mark_node))
9076     return error_mark_node;
9077
9078   switch (TREE_CODE (tree_type))
9079     {
9080     case INTEGER_TYPE:
9081       return ffecom_2 (TRUNC_DIV_EXPR, tree_type,
9082                        left,
9083                        right);
9084
9085     case COMPLEX_TYPE:
9086       if (! optimize_size)
9087         return ffecom_2 (RDIV_EXPR, tree_type,
9088                          left,
9089                          right);
9090       {
9091         ffecomGfrt ix;
9092
9093         if (TREE_TYPE (tree_type)
9094             == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9095           ix = FFECOM_gfrtDIV_CC;       /* Overlapping result okay. */
9096         else
9097           ix = FFECOM_gfrtDIV_ZZ;       /* Overlapping result okay. */
9098
9099         left = ffecom_1 (ADDR_EXPR,
9100                          build_pointer_type (TREE_TYPE (left)),
9101                          left);
9102         left = build_tree_list (NULL_TREE, left);
9103         right = ffecom_1 (ADDR_EXPR,
9104                           build_pointer_type (TREE_TYPE (right)),
9105                           right);
9106         right = build_tree_list (NULL_TREE, right);
9107         TREE_CHAIN (left) = right;
9108
9109         return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9110                              ffecom_gfrt_kindtype (ix),
9111                              ffe_is_f2c_library (),
9112                              tree_type,
9113                              left,
9114                              dest_tree, dest, dest_used,
9115                              NULL_TREE, TRUE, hook);
9116       }
9117       break;
9118
9119     case RECORD_TYPE:
9120       {
9121         ffecomGfrt ix;
9122
9123         if (TREE_TYPE (TYPE_FIELDS (tree_type))
9124             == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9125           ix = FFECOM_gfrtDIV_CC;       /* Overlapping result okay. */
9126         else
9127           ix = FFECOM_gfrtDIV_ZZ;       /* Overlapping result okay. */
9128
9129         left = ffecom_1 (ADDR_EXPR,
9130                          build_pointer_type (TREE_TYPE (left)),
9131                          left);
9132         left = build_tree_list (NULL_TREE, left);
9133         right = ffecom_1 (ADDR_EXPR,
9134                           build_pointer_type (TREE_TYPE (right)),
9135                           right);
9136         right = build_tree_list (NULL_TREE, right);
9137         TREE_CHAIN (left) = right;
9138
9139         return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9140                              ffecom_gfrt_kindtype (ix),
9141                              ffe_is_f2c_library (),
9142                              tree_type,
9143                              left,
9144                              dest_tree, dest, dest_used,
9145                              NULL_TREE, TRUE, hook);
9146       }
9147       break;
9148
9149     default:
9150       return ffecom_2 (RDIV_EXPR, tree_type,
9151                        left,
9152                        right);
9153     }
9154 }
9155
9156 /* Build type info for non-dummy variable.  */
9157
9158 static tree
9159 ffecom_type_localvar_ (ffesymbol s, ffeinfoBasictype bt,
9160                        ffeinfoKindtype kt)
9161 {
9162   tree type;
9163   ffebld dl;
9164   ffebld dim;
9165   tree lowt;
9166   tree hight;
9167
9168   type = ffecom_tree_type[bt][kt];
9169   if (bt == FFEINFO_basictypeCHARACTER)
9170     {
9171       hight = build_int_2 (ffesymbol_size (s), 0);
9172       TREE_TYPE (hight) = ffecom_f2c_ftnlen_type_node;
9173
9174       type
9175         = build_array_type
9176           (type,
9177            build_range_type (ffecom_f2c_ftnlen_type_node,
9178                              ffecom_f2c_ftnlen_one_node,
9179                              hight));
9180       type = ffecom_check_size_overflow_ (s, type, FALSE);
9181     }
9182
9183   for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
9184     {
9185       if (type == error_mark_node)
9186         break;
9187
9188       dim = ffebld_head (dl);
9189       assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
9190
9191       if (ffebld_left (dim) == NULL)
9192         lowt = integer_one_node;
9193       else
9194         lowt = ffecom_expr (ffebld_left (dim));
9195
9196       if (TREE_CODE (lowt) != INTEGER_CST)
9197         lowt = variable_size (lowt);
9198
9199       assert (ffebld_right (dim) != NULL);
9200       hight = ffecom_expr (ffebld_right (dim));
9201
9202       if (TREE_CODE (hight) != INTEGER_CST)
9203         hight = variable_size (hight);
9204
9205       type = build_array_type (type,
9206                                build_range_type (ffecom_integer_type_node,
9207                                                  lowt, hight));
9208       type = ffecom_check_size_overflow_ (s, type, FALSE);
9209     }
9210
9211   return type;
9212 }
9213
9214 /* Build Namelist type.  */
9215
9216 static tree
9217 ffecom_type_namelist_ ()
9218 {
9219   static tree type = NULL_TREE;
9220
9221   if (type == NULL_TREE)
9222     {
9223       static tree namefield, varsfield, nvarsfield;
9224       tree vardesctype;
9225
9226       vardesctype = ffecom_type_vardesc_ ();
9227
9228       type = make_node (RECORD_TYPE);
9229
9230       vardesctype = build_pointer_type (build_pointer_type (vardesctype));
9231
9232       namefield = ffecom_decl_field (type, NULL_TREE, "name",
9233                                      string_type_node);
9234       varsfield = ffecom_decl_field (type, namefield, "vars", vardesctype);
9235       nvarsfield = ffecom_decl_field (type, varsfield, "nvars",
9236                                       integer_type_node);
9237
9238       TYPE_FIELDS (type) = namefield;
9239       layout_type (type);
9240
9241       ggc_add_tree_root (&type, 1);
9242     }
9243
9244   return type;
9245 }
9246
9247 /* Build Vardesc type.  */
9248
9249 static tree
9250 ffecom_type_vardesc_ ()
9251 {
9252   static tree type = NULL_TREE;
9253   static tree namefield, addrfield, dimsfield, typefield;
9254
9255   if (type == NULL_TREE)
9256     {
9257       type = make_node (RECORD_TYPE);
9258
9259       namefield = ffecom_decl_field (type, NULL_TREE, "name",
9260                                      string_type_node);
9261       addrfield = ffecom_decl_field (type, namefield, "addr",
9262                                      string_type_node);
9263       dimsfield = ffecom_decl_field (type, addrfield, "dims",
9264                                      ffecom_f2c_ptr_to_ftnlen_type_node);
9265       typefield = ffecom_decl_field (type, dimsfield, "type",
9266                                      integer_type_node);
9267
9268       TYPE_FIELDS (type) = namefield;
9269       layout_type (type);
9270
9271       ggc_add_tree_root (&type, 1);
9272     }
9273
9274   return type;
9275 }
9276
9277 static tree
9278 ffecom_vardesc_ (ffebld expr)
9279 {
9280   ffesymbol s;
9281
9282   assert (ffebld_op (expr) == FFEBLD_opSYMTER);
9283   s = ffebld_symter (expr);
9284
9285   if (ffesymbol_hook (s).vardesc_tree == NULL_TREE)
9286     {
9287       int i;
9288       tree vardesctype = ffecom_type_vardesc_ ();
9289       tree var;
9290       tree nameinit;
9291       tree dimsinit;
9292       tree addrinit;
9293       tree typeinit;
9294       tree field;
9295       tree varinits;
9296       static int mynumber = 0;
9297
9298       var = build_decl (VAR_DECL,
9299                         ffecom_get_invented_identifier ("__g77_vardesc_%d",
9300                                                         mynumber++),
9301                         vardesctype);
9302       TREE_STATIC (var) = 1;
9303       DECL_INITIAL (var) = error_mark_node;
9304
9305       var = start_decl (var, FALSE);
9306
9307       /* Process inits.  */
9308
9309       nameinit = ffecom_build_f2c_string_ ((i = strlen (ffesymbol_text (s)))
9310                                            + 1,
9311                                            ffesymbol_text (s));
9312       TREE_TYPE (nameinit)
9313         = build_type_variant
9314         (build_array_type
9315          (char_type_node,
9316           build_range_type (integer_type_node,
9317                             integer_one_node,
9318                             build_int_2 (i, 0))),
9319          1, 0);
9320       TREE_CONSTANT (nameinit) = 1;
9321       TREE_STATIC (nameinit) = 1;
9322       nameinit = ffecom_1 (ADDR_EXPR,
9323                            build_pointer_type (TREE_TYPE (nameinit)),
9324                            nameinit);
9325
9326       addrinit = ffecom_arg_ptr_to_expr (expr, &typeinit);
9327
9328       dimsinit = ffecom_vardesc_dims_ (s);
9329
9330       if (typeinit == NULL_TREE)
9331         {
9332           ffeinfoBasictype bt = ffesymbol_basictype (s);
9333           ffeinfoKindtype kt = ffesymbol_kindtype (s);
9334           int tc = ffecom_f2c_typecode (bt, kt);
9335
9336           assert (tc != -1);
9337           typeinit = build_int_2 (tc, (tc < 0) ? -1 : 0);
9338         }
9339       else
9340         typeinit = ffecom_1 (NEGATE_EXPR, TREE_TYPE (typeinit), typeinit);
9341
9342       varinits = build_tree_list ((field = TYPE_FIELDS (vardesctype)),
9343                                   nameinit);
9344       TREE_CHAIN (varinits) = build_tree_list ((field = TREE_CHAIN (field)),
9345                                                addrinit);
9346       TREE_CHAIN (TREE_CHAIN (varinits))
9347         = build_tree_list ((field = TREE_CHAIN (field)), dimsinit);
9348       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (varinits)))
9349         = build_tree_list ((field = TREE_CHAIN (field)), typeinit);
9350
9351       varinits = build (CONSTRUCTOR, vardesctype, NULL_TREE, varinits);
9352       TREE_CONSTANT (varinits) = 1;
9353       TREE_STATIC (varinits) = 1;
9354
9355       finish_decl (var, varinits, FALSE);
9356
9357       var = ffecom_1 (ADDR_EXPR, build_pointer_type (vardesctype), var);
9358
9359       ffesymbol_hook (s).vardesc_tree = var;
9360     }
9361
9362   return ffesymbol_hook (s).vardesc_tree;
9363 }
9364
9365 static tree
9366 ffecom_vardesc_array_ (ffesymbol s)
9367 {
9368   ffebld b;
9369   tree list;
9370   tree item = NULL_TREE;
9371   tree var;
9372   int i;
9373   static int mynumber = 0;
9374
9375   for (i = 0, list = NULL_TREE, b = ffesymbol_namelist (s);
9376        b != NULL;
9377        b = ffebld_trail (b), ++i)
9378     {
9379       tree t;
9380
9381       t = ffecom_vardesc_ (ffebld_head (b));
9382
9383       if (list == NULL_TREE)
9384         list = item = build_tree_list (NULL_TREE, t);
9385       else
9386         {
9387           TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9388           item = TREE_CHAIN (item);
9389         }
9390     }
9391
9392   item = build_array_type (build_pointer_type (ffecom_type_vardesc_ ()),
9393                            build_range_type (integer_type_node,
9394                                              integer_one_node,
9395                                              build_int_2 (i, 0)));
9396   list = build (CONSTRUCTOR, item, NULL_TREE, list);
9397   TREE_CONSTANT (list) = 1;
9398   TREE_STATIC (list) = 1;
9399
9400   var = ffecom_get_invented_identifier ("__g77_vardesc_array_%d", mynumber++);
9401   var = build_decl (VAR_DECL, var, item);
9402   TREE_STATIC (var) = 1;
9403   DECL_INITIAL (var) = error_mark_node;
9404   var = start_decl (var, FALSE);
9405   finish_decl (var, list, FALSE);
9406
9407   return var;
9408 }
9409
9410 static tree
9411 ffecom_vardesc_dims_ (ffesymbol s)
9412 {
9413   if (ffesymbol_dims (s) == NULL)
9414     return convert (ffecom_f2c_ptr_to_ftnlen_type_node,
9415                     integer_zero_node);
9416
9417   {
9418     ffebld b;
9419     ffebld e;
9420     tree list;
9421     tree backlist;
9422     tree item = NULL_TREE;
9423     tree var;
9424     tree numdim;
9425     tree numelem;
9426     tree baseoff = NULL_TREE;
9427     static int mynumber = 0;
9428
9429     numdim = build_int_2 ((int) ffesymbol_rank (s), 0);
9430     TREE_TYPE (numdim) = ffecom_f2c_ftnlen_type_node;
9431
9432     numelem = ffecom_expr (ffesymbol_arraysize (s));
9433     TREE_TYPE (numelem) = ffecom_f2c_ftnlen_type_node;
9434
9435     list = NULL_TREE;
9436     backlist = NULL_TREE;
9437     for (b = ffesymbol_dims (s), e = ffesymbol_extents (s);
9438          b != NULL;
9439          b = ffebld_trail (b), e = ffebld_trail (e))
9440       {
9441         tree t;
9442         tree low;
9443         tree back;
9444
9445         if (ffebld_trail (b) == NULL)
9446           t = NULL_TREE;
9447         else
9448           {
9449             t = convert (ffecom_f2c_ftnlen_type_node,
9450                          ffecom_expr (ffebld_head (e)));
9451
9452             if (list == NULL_TREE)
9453               list = item = build_tree_list (NULL_TREE, t);
9454             else
9455               {
9456                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9457                 item = TREE_CHAIN (item);
9458               }
9459           }
9460
9461         if (ffebld_left (ffebld_head (b)) == NULL)
9462           low = ffecom_integer_one_node;
9463         else
9464           low = ffecom_expr (ffebld_left (ffebld_head (b)));
9465         low = convert (ffecom_f2c_ftnlen_type_node, low);
9466
9467         back = build_tree_list (low, t);
9468         TREE_CHAIN (back) = backlist;
9469         backlist = back;
9470       }
9471
9472     for (item = backlist; item != NULL_TREE; item = TREE_CHAIN (item))
9473       {
9474         if (TREE_VALUE (item) == NULL_TREE)
9475           baseoff = TREE_PURPOSE (item);
9476         else
9477           baseoff = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
9478                               TREE_PURPOSE (item),
9479                               ffecom_2 (MULT_EXPR,
9480                                         ffecom_f2c_ftnlen_type_node,
9481                                         TREE_VALUE (item),
9482                                         baseoff));
9483       }
9484
9485     /* backlist now dead, along with all TREE_PURPOSEs on it.  */
9486
9487     baseoff = build_tree_list (NULL_TREE, baseoff);
9488     TREE_CHAIN (baseoff) = list;
9489
9490     numelem = build_tree_list (NULL_TREE, numelem);
9491     TREE_CHAIN (numelem) = baseoff;
9492
9493     numdim = build_tree_list (NULL_TREE, numdim);
9494     TREE_CHAIN (numdim) = numelem;
9495
9496     item = build_array_type (ffecom_f2c_ftnlen_type_node,
9497                              build_range_type (integer_type_node,
9498                                                integer_zero_node,
9499                                                build_int_2
9500                                                ((int) ffesymbol_rank (s)
9501                                                 + 2, 0)));
9502     list = build (CONSTRUCTOR, item, NULL_TREE, numdim);
9503     TREE_CONSTANT (list) = 1;
9504     TREE_STATIC (list) = 1;
9505
9506     var = ffecom_get_invented_identifier ("__g77_dims_%d", mynumber++);
9507     var = build_decl (VAR_DECL, var, item);
9508     TREE_STATIC (var) = 1;
9509     DECL_INITIAL (var) = error_mark_node;
9510     var = start_decl (var, FALSE);
9511     finish_decl (var, list, FALSE);
9512
9513     var = ffecom_1 (ADDR_EXPR, build_pointer_type (item), var);
9514
9515     return var;
9516   }
9517 }
9518
9519 /* Essentially does a "fold (build1 (code, type, node))" while checking
9520    for certain housekeeping things.
9521
9522    NOTE: for building an ADDR_EXPR around a FUNCTION_DECL, use
9523    ffecom_1_fn instead.  */
9524
9525 tree
9526 ffecom_1 (enum tree_code code, tree type, tree node)
9527 {
9528   tree item;
9529
9530   if ((node == error_mark_node)
9531       || (type == error_mark_node))
9532     return error_mark_node;
9533
9534   if (code == ADDR_EXPR)
9535     {
9536       if (!ffe_mark_addressable (node))
9537         assert ("can't mark_addressable this node!" == NULL);
9538     }
9539
9540   switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9541     {
9542       tree realtype;
9543
9544     case REALPART_EXPR:
9545       item = build (COMPONENT_REF, type, node, TYPE_FIELDS (TREE_TYPE (node)));
9546       break;
9547
9548     case IMAGPART_EXPR:
9549       item = build (COMPONENT_REF, type, node, TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (node))));
9550       break;
9551
9552
9553     case NEGATE_EXPR:
9554       if (TREE_CODE (type) != RECORD_TYPE)
9555         {
9556           item = build1 (code, type, node);
9557           break;
9558         }
9559       node = ffecom_stabilize_aggregate_ (node);
9560       realtype = TREE_TYPE (TYPE_FIELDS (type));
9561       item =
9562         ffecom_2 (COMPLEX_EXPR, type,
9563                   ffecom_1 (NEGATE_EXPR, realtype,
9564                             ffecom_1 (REALPART_EXPR, realtype,
9565                                       node)),
9566                   ffecom_1 (NEGATE_EXPR, realtype,
9567                             ffecom_1 (IMAGPART_EXPR, realtype,
9568                                       node)));
9569       break;
9570
9571     default:
9572       item = build1 (code, type, node);
9573       break;
9574     }
9575
9576   if (TREE_SIDE_EFFECTS (node))
9577     TREE_SIDE_EFFECTS (item) = 1;
9578   if (code == ADDR_EXPR && staticp (node))
9579     TREE_CONSTANT (item) = 1;
9580   else if (code == INDIRECT_REF)
9581     TREE_READONLY (item) = TYPE_READONLY (type);
9582   return fold (item);
9583 }
9584
9585 /* Like ffecom_1 (ADDR_EXPR, TREE_TYPE (node), node), except
9586    handles TREE_CODE (node) == FUNCTION_DECL.  In particular,
9587    does not set TREE_ADDRESSABLE (because calling an inline
9588    function does not mean the function needs to be separately
9589    compiled).  */
9590
9591 tree
9592 ffecom_1_fn (tree node)
9593 {
9594   tree item;
9595   tree type;
9596
9597   if (node == error_mark_node)
9598     return error_mark_node;
9599
9600   type = build_type_variant (TREE_TYPE (node),
9601                              TREE_READONLY (node),
9602                              TREE_THIS_VOLATILE (node));
9603   item = build1 (ADDR_EXPR,
9604                  build_pointer_type (type), node);
9605   if (TREE_SIDE_EFFECTS (node))
9606     TREE_SIDE_EFFECTS (item) = 1;
9607   if (staticp (node))
9608     TREE_CONSTANT (item) = 1;
9609   return fold (item);
9610 }
9611
9612 /* Essentially does a "fold (build (code, type, node1, node2))" while
9613    checking for certain housekeeping things.  */
9614
9615 tree
9616 ffecom_2 (enum tree_code code, tree type, tree node1,
9617           tree node2)
9618 {
9619   tree item;
9620
9621   if ((node1 == error_mark_node)
9622       || (node2 == error_mark_node)
9623       || (type == error_mark_node))
9624     return error_mark_node;
9625
9626   switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9627     {
9628       tree a, b, c, d, realtype;
9629
9630     case CONJ_EXPR:
9631       assert ("no CONJ_EXPR support yet" == NULL);
9632       return error_mark_node;
9633
9634     case COMPLEX_EXPR:
9635       item = build_tree_list (TYPE_FIELDS (type), node1);
9636       TREE_CHAIN (item) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), node2);
9637       item = build (CONSTRUCTOR, type, NULL_TREE, item);
9638       break;
9639
9640     case PLUS_EXPR:
9641       if (TREE_CODE (type) != RECORD_TYPE)
9642         {
9643           item = build (code, type, node1, node2);
9644           break;
9645         }
9646       node1 = ffecom_stabilize_aggregate_ (node1);
9647       node2 = ffecom_stabilize_aggregate_ (node2);
9648       realtype = TREE_TYPE (TYPE_FIELDS (type));
9649       item =
9650         ffecom_2 (COMPLEX_EXPR, type,
9651                   ffecom_2 (PLUS_EXPR, realtype,
9652                             ffecom_1 (REALPART_EXPR, realtype,
9653                                       node1),
9654                             ffecom_1 (REALPART_EXPR, realtype,
9655                                       node2)),
9656                   ffecom_2 (PLUS_EXPR, realtype,
9657                             ffecom_1 (IMAGPART_EXPR, realtype,
9658                                       node1),
9659                             ffecom_1 (IMAGPART_EXPR, realtype,
9660                                       node2)));
9661       break;
9662
9663     case MINUS_EXPR:
9664       if (TREE_CODE (type) != RECORD_TYPE)
9665         {
9666           item = build (code, type, node1, node2);
9667           break;
9668         }
9669       node1 = ffecom_stabilize_aggregate_ (node1);
9670       node2 = ffecom_stabilize_aggregate_ (node2);
9671       realtype = TREE_TYPE (TYPE_FIELDS (type));
9672       item =
9673         ffecom_2 (COMPLEX_EXPR, type,
9674                   ffecom_2 (MINUS_EXPR, realtype,
9675                             ffecom_1 (REALPART_EXPR, realtype,
9676                                       node1),
9677                             ffecom_1 (REALPART_EXPR, realtype,
9678                                       node2)),
9679                   ffecom_2 (MINUS_EXPR, realtype,
9680                             ffecom_1 (IMAGPART_EXPR, realtype,
9681                                       node1),
9682                             ffecom_1 (IMAGPART_EXPR, realtype,
9683                                       node2)));
9684       break;
9685
9686     case MULT_EXPR:
9687       if (TREE_CODE (type) != RECORD_TYPE)
9688         {
9689           item = build (code, type, node1, node2);
9690           break;
9691         }
9692       node1 = ffecom_stabilize_aggregate_ (node1);
9693       node2 = ffecom_stabilize_aggregate_ (node2);
9694       realtype = TREE_TYPE (TYPE_FIELDS (type));
9695       a = save_expr (ffecom_1 (REALPART_EXPR, realtype,
9696                                node1));
9697       b = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
9698                                node1));
9699       c = save_expr (ffecom_1 (REALPART_EXPR, realtype,
9700                                node2));
9701       d = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
9702                                node2));
9703       item =
9704         ffecom_2 (COMPLEX_EXPR, type,
9705                   ffecom_2 (MINUS_EXPR, realtype,
9706                             ffecom_2 (MULT_EXPR, realtype,
9707                                       a,
9708                                       c),
9709                             ffecom_2 (MULT_EXPR, realtype,
9710                                       b,
9711                                       d)),
9712                   ffecom_2 (PLUS_EXPR, realtype,
9713                             ffecom_2 (MULT_EXPR, realtype,
9714                                       a,
9715                                       d),
9716                             ffecom_2 (MULT_EXPR, realtype,
9717                                       c,
9718                                       b)));
9719       break;
9720
9721     case EQ_EXPR:
9722       if ((TREE_CODE (node1) != RECORD_TYPE)
9723           && (TREE_CODE (node2) != RECORD_TYPE))
9724         {
9725           item = build (code, type, node1, node2);
9726           break;
9727         }
9728       assert (TREE_CODE (node1) == RECORD_TYPE);
9729       assert (TREE_CODE (node2) == RECORD_TYPE);
9730       node1 = ffecom_stabilize_aggregate_ (node1);
9731       node2 = ffecom_stabilize_aggregate_ (node2);
9732       realtype = TREE_TYPE (TYPE_FIELDS (type));
9733       item =
9734         ffecom_2 (TRUTH_ANDIF_EXPR, type,
9735                   ffecom_2 (code, type,
9736                             ffecom_1 (REALPART_EXPR, realtype,
9737                                       node1),
9738                             ffecom_1 (REALPART_EXPR, realtype,
9739                                       node2)),
9740                   ffecom_2 (code, type,
9741                             ffecom_1 (IMAGPART_EXPR, realtype,
9742                                       node1),
9743                             ffecom_1 (IMAGPART_EXPR, realtype,
9744                                       node2)));
9745       break;
9746
9747     case NE_EXPR:
9748       if ((TREE_CODE (node1) != RECORD_TYPE)
9749           && (TREE_CODE (node2) != RECORD_TYPE))
9750         {
9751           item = build (code, type, node1, node2);
9752           break;
9753         }
9754       assert (TREE_CODE (node1) == RECORD_TYPE);
9755       assert (TREE_CODE (node2) == RECORD_TYPE);
9756       node1 = ffecom_stabilize_aggregate_ (node1);
9757       node2 = ffecom_stabilize_aggregate_ (node2);
9758       realtype = TREE_TYPE (TYPE_FIELDS (type));
9759       item =
9760         ffecom_2 (TRUTH_ORIF_EXPR, type,
9761                   ffecom_2 (code, type,
9762                             ffecom_1 (REALPART_EXPR, realtype,
9763                                       node1),
9764                             ffecom_1 (REALPART_EXPR, realtype,
9765                                       node2)),
9766                   ffecom_2 (code, type,
9767                             ffecom_1 (IMAGPART_EXPR, realtype,
9768                                       node1),
9769                             ffecom_1 (IMAGPART_EXPR, realtype,
9770                                       node2)));
9771       break;
9772
9773     default:
9774       item = build (code, type, node1, node2);
9775       break;
9776     }
9777
9778   if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2))
9779     TREE_SIDE_EFFECTS (item) = 1;
9780   return fold (item);
9781 }
9782
9783 /* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint
9784
9785    ffesymbol s;  // the ENTRY point itself
9786    if (ffecom_2pass_advise_entrypoint(s))
9787        // the ENTRY point has been accepted
9788
9789    Does whatever compiler needs to do when it learns about the entrypoint,
9790    like determine the return type of the master function, count the
9791    number of entrypoints, etc.  Returns FALSE if the return type is
9792    not compatible with the return type(s) of other entrypoint(s).
9793
9794    NOTE: for every call to this fn that returns TRUE, _do_entrypoint must
9795    later (after _finish_progunit) be called with the same entrypoint(s)
9796    as passed to this fn for which TRUE was returned.
9797
9798    03-Jan-92  JCB  2.0
9799       Return FALSE if the return type conflicts with previous entrypoints.  */
9800
9801 bool
9802 ffecom_2pass_advise_entrypoint (ffesymbol entry)
9803 {
9804   ffebld list;                  /* opITEM. */
9805   ffebld mlist;                 /* opITEM. */
9806   ffebld plist;                 /* opITEM. */
9807   ffebld arg;                   /* ffebld_head(opITEM). */
9808   ffebld item;                  /* opITEM. */
9809   ffesymbol s;                  /* ffebld_symter(arg). */
9810   ffeinfoBasictype bt = ffesymbol_basictype (entry);
9811   ffeinfoKindtype kt = ffesymbol_kindtype (entry);
9812   ffetargetCharacterSize size = ffesymbol_size (entry);
9813   bool ok;
9814
9815   if (ffecom_num_entrypoints_ == 0)
9816     {                           /* First entrypoint, make list of main
9817                                    arglist's dummies. */
9818       assert (ffecom_primary_entry_ != NULL);
9819
9820       ffecom_master_bt_ = ffesymbol_basictype (ffecom_primary_entry_);
9821       ffecom_master_kt_ = ffesymbol_kindtype (ffecom_primary_entry_);
9822       ffecom_master_size_ = ffesymbol_size (ffecom_primary_entry_);
9823
9824       for (plist = NULL, list = ffesymbol_dummyargs (ffecom_primary_entry_);
9825            list != NULL;
9826            list = ffebld_trail (list))
9827         {
9828           arg = ffebld_head (list);
9829           if (ffebld_op (arg) != FFEBLD_opSYMTER)
9830             continue;           /* Alternate return or some such thing. */
9831           item = ffebld_new_item (arg, NULL);
9832           if (plist == NULL)
9833             ffecom_master_arglist_ = item;
9834           else
9835             ffebld_set_trail (plist, item);
9836           plist = item;
9837         }
9838     }
9839
9840   /* If necessary, scan entry arglist for alternate returns.  Do this scan
9841      apparently redundantly (it's done below to UNIONize the arglists) so
9842      that we don't complain about RETURN 1 if an offending ENTRY is the only
9843      one with an alternate return.  */
9844
9845   if (!ffecom_is_altreturning_)
9846     {
9847       for (list = ffesymbol_dummyargs (entry);
9848            list != NULL;
9849            list = ffebld_trail (list))
9850         {
9851           arg = ffebld_head (list);
9852           if (ffebld_op (arg) == FFEBLD_opSTAR)
9853             {
9854               ffecom_is_altreturning_ = TRUE;
9855               break;
9856             }
9857         }
9858     }
9859
9860   /* Now check type compatibility. */
9861
9862   switch (ffecom_master_bt_)
9863     {
9864     case FFEINFO_basictypeNONE:
9865       ok = (bt != FFEINFO_basictypeCHARACTER);
9866       break;
9867
9868     case FFEINFO_basictypeCHARACTER:
9869       ok
9870         = (bt == FFEINFO_basictypeCHARACTER)
9871         && (kt == ffecom_master_kt_)
9872         && (size == ffecom_master_size_);
9873       break;
9874
9875     case FFEINFO_basictypeANY:
9876       return FALSE;             /* Just don't bother. */
9877
9878     default:
9879       if (bt == FFEINFO_basictypeCHARACTER)
9880         {
9881           ok = FALSE;
9882           break;
9883         }
9884       ok = TRUE;
9885       if ((bt != ffecom_master_bt_) || (kt != ffecom_master_kt_))
9886         {
9887           ffecom_master_bt_ = FFEINFO_basictypeNONE;
9888           ffecom_master_kt_ = FFEINFO_kindtypeNONE;
9889         }
9890       break;
9891     }
9892
9893   if (!ok)
9894     {
9895       ffebad_start (FFEBAD_ENTRY_CONFLICTS);
9896       ffest_ffebad_here_current_stmt (0);
9897       ffebad_finish ();
9898       return FALSE;             /* Can't handle entrypoint. */
9899     }
9900
9901   /* Entrypoint type compatible with previous types. */
9902
9903   ++ffecom_num_entrypoints_;
9904
9905   /* Master-arg-list = UNION(Master-arg-list,entry-arg-list). */
9906
9907   for (list = ffesymbol_dummyargs (entry);
9908        list != NULL;
9909        list = ffebld_trail (list))
9910     {
9911       arg = ffebld_head (list);
9912       if (ffebld_op (arg) != FFEBLD_opSYMTER)
9913         continue;               /* Alternate return or some such thing. */
9914       s = ffebld_symter (arg);
9915       for (plist = NULL, mlist = ffecom_master_arglist_;
9916            mlist != NULL;
9917            plist = mlist, mlist = ffebld_trail (mlist))
9918         {                       /* plist points to previous item for easy
9919                                    appending of arg. */
9920           if (ffebld_symter (ffebld_head (mlist)) == s)
9921             break;              /* Already have this arg in the master list. */
9922         }
9923       if (mlist != NULL)
9924         continue;               /* Already have this arg in the master list. */
9925
9926       /* Append this arg to the master list. */
9927
9928       item = ffebld_new_item (arg, NULL);
9929       if (plist == NULL)
9930         ffecom_master_arglist_ = item;
9931       else
9932         ffebld_set_trail (plist, item);
9933     }
9934
9935   return TRUE;
9936 }
9937
9938 /* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint
9939
9940    ffesymbol s;  // the ENTRY point itself
9941    ffecom_2pass_do_entrypoint(s);
9942
9943    Does whatever compiler needs to do to make the entrypoint actually
9944    happen.  Must be called for each entrypoint after
9945    ffecom_finish_progunit is called.  */
9946
9947 void
9948 ffecom_2pass_do_entrypoint (ffesymbol entry)
9949 {
9950   static int mfn_num = 0;
9951   static int ent_num;
9952
9953   if (mfn_num != ffecom_num_fns_)
9954     {                           /* First entrypoint for this program unit. */
9955       ent_num = 1;
9956       mfn_num = ffecom_num_fns_;
9957       ffecom_do_entry_ (ffecom_primary_entry_, 0);
9958     }
9959   else
9960     ++ent_num;
9961
9962   --ffecom_num_entrypoints_;
9963
9964   ffecom_do_entry_ (entry, ent_num);
9965 }
9966
9967 /* Essentially does a "fold (build (code, type, node1, node2))" while
9968    checking for certain housekeeping things.  Always sets
9969    TREE_SIDE_EFFECTS.  */
9970
9971 tree
9972 ffecom_2s (enum tree_code code, tree type, tree node1,
9973            tree node2)
9974 {
9975   tree item;
9976
9977   if ((node1 == error_mark_node)
9978       || (node2 == error_mark_node)
9979       || (type == error_mark_node))
9980     return error_mark_node;
9981
9982   item = build (code, type, node1, node2);
9983   TREE_SIDE_EFFECTS (item) = 1;
9984   return fold (item);
9985 }
9986
9987 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
9988    checking for certain housekeeping things.  */
9989
9990 tree
9991 ffecom_3 (enum tree_code code, tree type, tree node1,
9992           tree node2, tree node3)
9993 {
9994   tree item;
9995
9996   if ((node1 == error_mark_node)
9997       || (node2 == error_mark_node)
9998       || (node3 == error_mark_node)
9999       || (type == error_mark_node))
10000     return error_mark_node;
10001
10002   item = build (code, type, node1, node2, node3);
10003   if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2)
10004       || (node3 != NULL_TREE && TREE_SIDE_EFFECTS (node3)))
10005     TREE_SIDE_EFFECTS (item) = 1;
10006   return fold (item);
10007 }
10008
10009 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10010    checking for certain housekeeping things.  Always sets
10011    TREE_SIDE_EFFECTS.  */
10012
10013 tree
10014 ffecom_3s (enum tree_code code, tree type, tree node1,
10015            tree node2, tree node3)
10016 {
10017   tree item;
10018
10019   if ((node1 == error_mark_node)
10020       || (node2 == error_mark_node)
10021       || (node3 == error_mark_node)
10022       || (type == error_mark_node))
10023     return error_mark_node;
10024
10025   item = build (code, type, node1, node2, node3);
10026   TREE_SIDE_EFFECTS (item) = 1;
10027   return fold (item);
10028 }
10029
10030 /* ffecom_arg_expr -- Transform argument expr into gcc tree
10031
10032    See use by ffecom_list_expr.
10033
10034    If expression is NULL, returns an integer zero tree.  If it is not
10035    a CHARACTER expression, returns whatever ffecom_expr
10036    returns and sets the length return value to NULL_TREE.  Otherwise
10037    generates code to evaluate the character expression, returns the proper
10038    pointer to the result, but does NOT set the length return value to a tree
10039    that specifies the length of the result.  (In other words, the length
10040    variable is always set to NULL_TREE, because a length is never passed.)
10041
10042    21-Dec-91  JCB  1.1
10043       Don't set returned length, since nobody needs it (yet; someday if
10044       we allow CHARACTER*(*) dummies to statement functions, we'll need
10045       it).  */
10046
10047 tree
10048 ffecom_arg_expr (ffebld expr, tree *length)
10049 {
10050   tree ign;
10051
10052   *length = NULL_TREE;
10053
10054   if (expr == NULL)
10055     return integer_zero_node;
10056
10057   if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10058     return ffecom_expr (expr);
10059
10060   return ffecom_arg_ptr_to_expr (expr, &ign);
10061 }
10062
10063 /* Transform expression into constant argument-pointer-to-expression tree.
10064
10065    If the expression can be transformed into a argument-pointer-to-expression
10066    tree that is constant, that is done, and the tree returned.  Else
10067    NULL_TREE is returned.
10068
10069    That way, a caller can attempt to provide compile-time initialization
10070    of a variable and, if that fails, *then* choose to start a new block
10071    and resort to using temporaries, as appropriate.  */
10072
10073 tree
10074 ffecom_arg_ptr_to_const_expr (ffebld expr, tree *length)
10075 {
10076   if (! expr)
10077     return integer_zero_node;
10078
10079   if (ffebld_op (expr) == FFEBLD_opANY)
10080     {
10081       if (length)
10082         *length = error_mark_node;
10083       return error_mark_node;
10084     }
10085
10086   if (ffebld_arity (expr) == 0
10087       && (ffebld_op (expr) != FFEBLD_opSYMTER
10088           || ffebld_where (expr) == FFEINFO_whereCOMMON
10089           || ffebld_where (expr) == FFEINFO_whereGLOBAL
10090           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10091     {
10092       tree t;
10093
10094       t = ffecom_arg_ptr_to_expr (expr, length);
10095       assert (TREE_CONSTANT (t));
10096       assert (! length || TREE_CONSTANT (*length));
10097       return t;
10098     }
10099
10100   if (length
10101       && ffebld_size (expr) != FFETARGET_charactersizeNONE)
10102     *length = build_int_2 (ffebld_size (expr), 0);
10103   else if (length)
10104     *length = NULL_TREE;
10105   return NULL_TREE;
10106 }
10107
10108 /* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree
10109
10110    See use by ffecom_list_ptr_to_expr.
10111
10112    If expression is NULL, returns an integer zero tree.  If it is not
10113    a CHARACTER expression, returns whatever ffecom_ptr_to_expr
10114    returns and sets the length return value to NULL_TREE.  Otherwise
10115    generates code to evaluate the character expression, returns the proper
10116    pointer to the result, AND sets the length return value to a tree that
10117    specifies the length of the result.
10118
10119    If the length argument is NULL, this is a slightly special
10120    case of building a FORMAT expression, that is, an expression that
10121    will be used at run time without regard to length.  For the current
10122    implementation, which uses the libf2c library, this means it is nice
10123    to append a null byte to the end of the expression, where feasible,
10124    to make sure any diagnostic about the FORMAT string terminates at
10125    some useful point.
10126
10127    For now, treat %REF(char-expr) as the same as char-expr with a NULL
10128    length argument.  This might even be seen as a feature, if a null
10129    byte can always be appended.  */
10130
10131 tree
10132 ffecom_arg_ptr_to_expr (ffebld expr, tree *length)
10133 {
10134   tree item;
10135   tree ign_length;
10136   ffecomConcatList_ catlist;
10137
10138   if (length != NULL)
10139     *length = NULL_TREE;
10140
10141   if (expr == NULL)
10142     return integer_zero_node;
10143
10144   switch (ffebld_op (expr))
10145     {
10146     case FFEBLD_opPERCENT_VAL:
10147       if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10148         return ffecom_expr (ffebld_left (expr));
10149       {
10150         tree temp_exp;
10151         tree temp_length;
10152
10153         temp_exp = ffecom_arg_ptr_to_expr (ffebld_left (expr), &temp_length);
10154         if (temp_exp == error_mark_node)
10155           return error_mark_node;
10156
10157         return ffecom_1 (INDIRECT_REF, TREE_TYPE (TREE_TYPE (temp_exp)),
10158                          temp_exp);
10159       }
10160
10161     case FFEBLD_opPERCENT_REF:
10162       if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10163         return ffecom_ptr_to_expr (ffebld_left (expr));
10164       if (length != NULL)
10165         {
10166           ign_length = NULL_TREE;
10167           length = &ign_length;
10168         }
10169       expr = ffebld_left (expr);
10170       break;
10171
10172     case FFEBLD_opPERCENT_DESCR:
10173       switch (ffeinfo_basictype (ffebld_info (expr)))
10174         {
10175 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10176         case FFEINFO_basictypeHOLLERITH:
10177 #endif
10178         case FFEINFO_basictypeCHARACTER:
10179           break;                /* Passed by descriptor anyway. */
10180
10181         default:
10182           item = ffecom_ptr_to_expr (expr);
10183           if (item != error_mark_node)
10184             *length = TYPE_SIZE (TREE_TYPE (TREE_TYPE (item)));
10185           break;
10186         }
10187       break;
10188
10189     default:
10190       break;
10191     }
10192
10193 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10194   if ((ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeHOLLERITH)
10195       && (length != NULL))
10196     {                           /* Pass Hollerith by descriptor. */
10197       ffetargetHollerith h;
10198
10199       assert (ffebld_op (expr) == FFEBLD_opCONTER);
10200       h = ffebld_cu_val_hollerith (ffebld_constant_union
10201                                    (ffebld_conter (expr)));
10202       *length
10203         = build_int_2 (h.length, 0);
10204       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10205     }
10206 #endif
10207
10208   if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10209     return ffecom_ptr_to_expr (expr);
10210
10211   assert (ffeinfo_kindtype (ffebld_info (expr))
10212           == FFEINFO_kindtypeCHARACTER1);
10213
10214   while (ffebld_op (expr) == FFEBLD_opPAREN)
10215     expr = ffebld_left (expr);
10216
10217   catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
10218   switch (ffecom_concat_list_count_ (catlist))
10219     {
10220     case 0:                     /* Shouldn't happen, but in case it does... */
10221       if (length != NULL)
10222         {
10223           *length = ffecom_f2c_ftnlen_zero_node;
10224           TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10225         }
10226       ffecom_concat_list_kill_ (catlist);
10227       return null_pointer_node;
10228
10229     case 1:                     /* The (fairly) easy case. */
10230       if (length == NULL)
10231         ffecom_char_args_with_null_ (&item, &ign_length,
10232                                      ffecom_concat_list_expr_ (catlist, 0));
10233       else
10234         ffecom_char_args_ (&item, length,
10235                            ffecom_concat_list_expr_ (catlist, 0));
10236       ffecom_concat_list_kill_ (catlist);
10237       assert (item != NULL_TREE);
10238       return item;
10239
10240     default:                    /* Must actually concatenate things. */
10241       break;
10242     }
10243
10244   {
10245     int count = ffecom_concat_list_count_ (catlist);
10246     int i;
10247     tree lengths;
10248     tree items;
10249     tree length_array;
10250     tree item_array;
10251     tree citem;
10252     tree clength;
10253     tree temporary;
10254     tree num;
10255     tree known_length;
10256     ffetargetCharacterSize sz;
10257
10258     sz = ffecom_concat_list_maxlen_ (catlist);
10259     /* ~~Kludge! */
10260     assert (sz != FFETARGET_charactersizeNONE);
10261
10262 #ifdef HOHO
10263     length_array
10264       = lengths
10265       = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
10266                              FFETARGET_charactersizeNONE, count, TRUE);
10267     item_array
10268       = items
10269       = ffecom_push_tempvar (ffecom_f2c_address_type_node,
10270                              FFETARGET_charactersizeNONE, count, TRUE);
10271     temporary = ffecom_push_tempvar (char_type_node,
10272                                      sz, -1, TRUE);
10273 #else
10274     {
10275       tree hook;
10276
10277       hook = ffebld_nonter_hook (expr);
10278       assert (hook);
10279       assert (TREE_CODE (hook) == TREE_VEC);
10280       assert (TREE_VEC_LENGTH (hook) == 3);
10281       length_array = lengths = TREE_VEC_ELT (hook, 0);
10282       item_array = items = TREE_VEC_ELT (hook, 1);
10283       temporary = TREE_VEC_ELT (hook, 2);
10284     }
10285 #endif
10286
10287     known_length = ffecom_f2c_ftnlen_zero_node;
10288
10289     for (i = 0; i < count; ++i)
10290       {
10291         if ((i == count)
10292             && (length == NULL))
10293           ffecom_char_args_with_null_ (&citem, &clength,
10294                                        ffecom_concat_list_expr_ (catlist, i));
10295         else
10296           ffecom_char_args_ (&citem, &clength,
10297                              ffecom_concat_list_expr_ (catlist, i));
10298         if ((citem == error_mark_node)
10299             || (clength == error_mark_node))
10300           {
10301             ffecom_concat_list_kill_ (catlist);
10302             *length = error_mark_node;
10303             return error_mark_node;
10304           }
10305
10306         items
10307           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
10308                       ffecom_modify (void_type_node,
10309                                      ffecom_2 (ARRAY_REF,
10310                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
10311                                                item_array,
10312                                                build_int_2 (i, 0)),
10313                                      citem),
10314                       items);
10315         clength = ffecom_save_tree (clength);
10316         if (length != NULL)
10317           known_length
10318             = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
10319                         known_length,
10320                         clength);
10321         lengths
10322           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
10323                       ffecom_modify (void_type_node,
10324                                      ffecom_2 (ARRAY_REF,
10325                    TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
10326                                                length_array,
10327                                                build_int_2 (i, 0)),
10328                                      clength),
10329                       lengths);
10330       }
10331
10332     temporary = ffecom_1 (ADDR_EXPR,
10333                           build_pointer_type (TREE_TYPE (temporary)),
10334                           temporary);
10335
10336     item = build_tree_list (NULL_TREE, temporary);
10337     TREE_CHAIN (item)
10338       = build_tree_list (NULL_TREE,
10339                          ffecom_1 (ADDR_EXPR,
10340                                    build_pointer_type (TREE_TYPE (items)),
10341                                    items));
10342     TREE_CHAIN (TREE_CHAIN (item))
10343       = build_tree_list (NULL_TREE,
10344                          ffecom_1 (ADDR_EXPR,
10345                                    build_pointer_type (TREE_TYPE (lengths)),
10346                                    lengths));
10347     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
10348       = build_tree_list
10349         (NULL_TREE,
10350          ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
10351                    convert (ffecom_f2c_ftnlen_type_node,
10352                             build_int_2 (count, 0))));
10353     num = build_int_2 (sz, 0);
10354     TREE_TYPE (num) = ffecom_f2c_ftnlen_type_node;
10355     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item))))
10356       = build_tree_list (NULL_TREE, num);
10357
10358     item = ffecom_call_gfrt (FFECOM_gfrtCAT, item, NULL_TREE);
10359     TREE_SIDE_EFFECTS (item) = 1;
10360     item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (temporary),
10361                      item,
10362                      temporary);
10363
10364     if (length != NULL)
10365       *length = known_length;
10366   }
10367
10368   ffecom_concat_list_kill_ (catlist);
10369   assert (item != NULL_TREE);
10370   return item;
10371 }
10372
10373 /* Generate call to run-time function.
10374
10375    The first arg is the GNU Fortran Run-Time function index, the second
10376    arg is the list of arguments to pass to it.  Returned is the expression
10377    (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the
10378    result (which may be void).  */
10379
10380 tree
10381 ffecom_call_gfrt (ffecomGfrt ix, tree args, tree hook)
10382 {
10383   return ffecom_call_ (ffecom_gfrt_tree_ (ix),
10384                        ffecom_gfrt_kindtype (ix),
10385                        ffe_is_f2c_library () && ffecom_gfrt_complex_[ix],
10386                        NULL_TREE, args, NULL_TREE, NULL,
10387                        NULL, NULL_TREE, TRUE, hook);
10388 }
10389
10390 /* Transform constant-union to tree.  */
10391
10392 tree
10393 ffecom_constantunion (ffebldConstantUnion *cu, ffeinfoBasictype bt,
10394                       ffeinfoKindtype kt, tree tree_type)
10395 {
10396   tree item;
10397
10398   switch (bt)
10399     {
10400     case FFEINFO_basictypeINTEGER:
10401       {
10402         int val;
10403
10404         switch (kt)
10405           {
10406 #if FFETARGET_okINTEGER1
10407           case FFEINFO_kindtypeINTEGER1:
10408             val = ffebld_cu_val_integer1 (*cu);
10409             break;
10410 #endif
10411
10412 #if FFETARGET_okINTEGER2
10413           case FFEINFO_kindtypeINTEGER2:
10414             val = ffebld_cu_val_integer2 (*cu);
10415             break;
10416 #endif
10417
10418 #if FFETARGET_okINTEGER3
10419           case FFEINFO_kindtypeINTEGER3:
10420             val = ffebld_cu_val_integer3 (*cu);
10421             break;
10422 #endif
10423
10424 #if FFETARGET_okINTEGER4
10425           case FFEINFO_kindtypeINTEGER4:
10426             val = ffebld_cu_val_integer4 (*cu);
10427             break;
10428 #endif
10429
10430           default:
10431             assert ("bad INTEGER constant kind type" == NULL);
10432             /* Fall through. */
10433           case FFEINFO_kindtypeANY:
10434             return error_mark_node;
10435           }
10436         item = build_int_2 (val, (val < 0) ? -1 : 0);
10437         TREE_TYPE (item) = tree_type;
10438       }
10439       break;
10440
10441     case FFEINFO_basictypeLOGICAL:
10442       {
10443         int val;
10444
10445         switch (kt)
10446           {
10447 #if FFETARGET_okLOGICAL1
10448           case FFEINFO_kindtypeLOGICAL1:
10449             val = ffebld_cu_val_logical1 (*cu);
10450             break;
10451 #endif
10452
10453 #if FFETARGET_okLOGICAL2
10454           case FFEINFO_kindtypeLOGICAL2:
10455             val = ffebld_cu_val_logical2 (*cu);
10456             break;
10457 #endif
10458
10459 #if FFETARGET_okLOGICAL3
10460           case FFEINFO_kindtypeLOGICAL3:
10461             val = ffebld_cu_val_logical3 (*cu);
10462             break;
10463 #endif
10464
10465 #if FFETARGET_okLOGICAL4
10466           case FFEINFO_kindtypeLOGICAL4:
10467             val = ffebld_cu_val_logical4 (*cu);
10468             break;
10469 #endif
10470
10471           default:
10472             assert ("bad LOGICAL constant kind type" == NULL);
10473             /* Fall through. */
10474           case FFEINFO_kindtypeANY:
10475             return error_mark_node;
10476           }
10477         item = build_int_2 (val, (val < 0) ? -1 : 0);
10478         TREE_TYPE (item) = tree_type;
10479       }
10480       break;
10481
10482     case FFEINFO_basictypeREAL:
10483       {
10484         REAL_VALUE_TYPE val;
10485
10486         switch (kt)
10487           {
10488 #if FFETARGET_okREAL1
10489           case FFEINFO_kindtypeREAL1:
10490             val = ffetarget_value_real1 (ffebld_cu_val_real1 (*cu));
10491             break;
10492 #endif
10493
10494 #if FFETARGET_okREAL2
10495           case FFEINFO_kindtypeREAL2:
10496             val = ffetarget_value_real2 (ffebld_cu_val_real2 (*cu));
10497             break;
10498 #endif
10499
10500 #if FFETARGET_okREAL3
10501           case FFEINFO_kindtypeREAL3:
10502             val = ffetarget_value_real3 (ffebld_cu_val_real3 (*cu));
10503             break;
10504 #endif
10505
10506 #if FFETARGET_okREAL4
10507           case FFEINFO_kindtypeREAL4:
10508             val = ffetarget_value_real4 (ffebld_cu_val_real4 (*cu));
10509             break;
10510 #endif
10511
10512           default:
10513             assert ("bad REAL constant kind type" == NULL);
10514             /* Fall through. */
10515           case FFEINFO_kindtypeANY:
10516             return error_mark_node;
10517           }
10518         item = build_real (tree_type, val);
10519       }
10520       break;
10521
10522     case FFEINFO_basictypeCOMPLEX:
10523       {
10524         REAL_VALUE_TYPE real;
10525         REAL_VALUE_TYPE imag;
10526         tree el_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
10527
10528         switch (kt)
10529           {
10530 #if FFETARGET_okCOMPLEX1
10531           case FFEINFO_kindtypeREAL1:
10532             real = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).real);
10533             imag = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).imaginary);
10534             break;
10535 #endif
10536
10537 #if FFETARGET_okCOMPLEX2
10538           case FFEINFO_kindtypeREAL2:
10539             real = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).real);
10540             imag = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).imaginary);
10541             break;
10542 #endif
10543
10544 #if FFETARGET_okCOMPLEX3
10545           case FFEINFO_kindtypeREAL3:
10546             real = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).real);
10547             imag = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).imaginary);
10548             break;
10549 #endif
10550
10551 #if FFETARGET_okCOMPLEX4
10552           case FFEINFO_kindtypeREAL4:
10553             real = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).real);
10554             imag = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).imaginary);
10555             break;
10556 #endif
10557
10558           default:
10559             assert ("bad REAL constant kind type" == NULL);
10560             /* Fall through. */
10561           case FFEINFO_kindtypeANY:
10562             return error_mark_node;
10563           }
10564         item = ffecom_build_complex_constant_ (tree_type,
10565                                                build_real (el_type, real),
10566                                                build_real (el_type, imag));
10567       }
10568       break;
10569
10570     case FFEINFO_basictypeCHARACTER:
10571       {                         /* Happens only in DATA and similar contexts. */
10572         ffetargetCharacter1 val;
10573
10574         switch (kt)
10575           {
10576 #if FFETARGET_okCHARACTER1
10577           case FFEINFO_kindtypeLOGICAL1:
10578             val = ffebld_cu_val_character1 (*cu);
10579             break;
10580 #endif
10581
10582           default:
10583             assert ("bad CHARACTER constant kind type" == NULL);
10584             /* Fall through. */
10585           case FFEINFO_kindtypeANY:
10586             return error_mark_node;
10587           }
10588         item = build_string (ffetarget_length_character1 (val),
10589                              ffetarget_text_character1 (val));
10590         TREE_TYPE (item)
10591           = build_type_variant (build_array_type (char_type_node,
10592                                                   build_range_type
10593                                                   (integer_type_node,
10594                                                    integer_one_node,
10595                                                    build_int_2
10596                                                 (ffetarget_length_character1
10597                                                  (val), 0))),
10598                                 1, 0);
10599       }
10600       break;
10601
10602     case FFEINFO_basictypeHOLLERITH:
10603       {
10604         ffetargetHollerith h;
10605
10606         h = ffebld_cu_val_hollerith (*cu);
10607
10608         /* If not at least as wide as default INTEGER, widen it.  */
10609         if (h.length >= FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE)
10610           item = build_string (h.length, h.text);
10611         else
10612           {
10613             char str[FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE];
10614
10615             memcpy (str, h.text, h.length);
10616             memset (&str[h.length], ' ',
10617                     FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE
10618                     - h.length);
10619             item = build_string (FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE,
10620                                  str);
10621           }
10622         TREE_TYPE (item)
10623           = build_type_variant (build_array_type (char_type_node,
10624                                                   build_range_type
10625                                                   (integer_type_node,
10626                                                    integer_one_node,
10627                                                    build_int_2
10628                                                    (h.length, 0))),
10629                                 1, 0);
10630       }
10631       break;
10632
10633     case FFEINFO_basictypeTYPELESS:
10634       {
10635         ffetargetInteger1 ival;
10636         ffetargetTypeless tless;
10637         ffebad error;
10638
10639         tless = ffebld_cu_val_typeless (*cu);
10640         error = ffetarget_convert_integer1_typeless (&ival, tless);
10641         assert (error == FFEBAD);
10642
10643         item = build_int_2 ((int) ival, 0);
10644       }
10645       break;
10646
10647     default:
10648       assert ("not yet on constant type" == NULL);
10649       /* Fall through. */
10650     case FFEINFO_basictypeANY:
10651       return error_mark_node;
10652     }
10653
10654   TREE_CONSTANT (item) = 1;
10655
10656   return item;
10657 }
10658
10659 /* Transform expression into constant tree.
10660
10661    If the expression can be transformed into a tree that is constant,
10662    that is done, and the tree returned.  Else NULL_TREE is returned.
10663
10664    That way, a caller can attempt to provide compile-time initialization
10665    of a variable and, if that fails, *then* choose to start a new block
10666    and resort to using temporaries, as appropriate.  */
10667
10668 tree
10669 ffecom_const_expr (ffebld expr)
10670 {
10671   if (! expr)
10672     return integer_zero_node;
10673
10674   if (ffebld_op (expr) == FFEBLD_opANY)
10675     return error_mark_node;
10676
10677   if (ffebld_arity (expr) == 0
10678       && (ffebld_op (expr) != FFEBLD_opSYMTER
10679 #if NEWCOMMON
10680           /* ~~Enable once common/equivalence is handled properly?  */
10681           || ffebld_where (expr) == FFEINFO_whereCOMMON
10682 #endif
10683           || ffebld_where (expr) == FFEINFO_whereGLOBAL
10684           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10685     {
10686       tree t;
10687
10688       t = ffecom_expr (expr);
10689       assert (TREE_CONSTANT (t));
10690       return t;
10691     }
10692
10693   return NULL_TREE;
10694 }
10695
10696 /* Handy way to make a field in a struct/union.  */
10697
10698 tree
10699 ffecom_decl_field (tree context, tree prevfield,
10700                    const char *name, tree type)
10701 {
10702   tree field;
10703
10704   field = build_decl (FIELD_DECL, get_identifier (name), type);
10705   DECL_CONTEXT (field) = context;
10706   DECL_ALIGN (field) = 0;
10707   DECL_USER_ALIGN (field) = 0;
10708   if (prevfield != NULL_TREE)
10709     TREE_CHAIN (prevfield) = field;
10710
10711   return field;
10712 }
10713
10714 void
10715 ffecom_close_include (FILE *f)
10716 {
10717   ffecom_close_include_ (f);
10718 }
10719
10720 int
10721 ffecom_decode_include_option (char *spec)
10722 {
10723   return ffecom_decode_include_option_ (spec);
10724 }
10725
10726 /* End a compound statement (block).  */
10727
10728 tree
10729 ffecom_end_compstmt (void)
10730 {
10731   return bison_rule_compstmt_ ();
10732 }
10733
10734 /* ffecom_end_transition -- Perform end transition on all symbols
10735
10736    ffecom_end_transition();
10737
10738    Calls ffecom_sym_end_transition for each global and local symbol.  */
10739
10740 void
10741 ffecom_end_transition ()
10742 {
10743   ffebld item;
10744
10745   if (ffe_is_ffedebug ())
10746     fprintf (dmpout, "; end_stmt_transition\n");
10747
10748   ffecom_list_blockdata_ = NULL;
10749   ffecom_list_common_ = NULL;
10750
10751   ffesymbol_drive (ffecom_sym_end_transition);
10752   if (ffe_is_ffedebug ())
10753     {
10754       ffestorag_report ();
10755     }
10756
10757   ffecom_start_progunit_ ();
10758
10759   for (item = ffecom_list_blockdata_;
10760        item != NULL;
10761        item = ffebld_trail (item))
10762     {
10763       ffebld callee;
10764       ffesymbol s;
10765       tree dt;
10766       tree t;
10767       tree var;
10768       static int number = 0;
10769
10770       callee = ffebld_head (item);
10771       s = ffebld_symter (callee);
10772       t = ffesymbol_hook (s).decl_tree;
10773       if (t == NULL_TREE)
10774         {
10775           s = ffecom_sym_transform_ (s);
10776           t = ffesymbol_hook (s).decl_tree;
10777         }
10778
10779       dt = build_pointer_type (TREE_TYPE (t));
10780
10781       var = build_decl (VAR_DECL,
10782                         ffecom_get_invented_identifier ("__g77_forceload_%d",
10783                                                         number++),
10784                         dt);
10785       DECL_EXTERNAL (var) = 0;
10786       TREE_STATIC (var) = 1;
10787       TREE_PUBLIC (var) = 0;
10788       DECL_INITIAL (var) = error_mark_node;
10789       TREE_USED (var) = 1;
10790
10791       var = start_decl (var, FALSE);
10792
10793       t = ffecom_1 (ADDR_EXPR, dt, t);
10794
10795       finish_decl (var, t, FALSE);
10796     }
10797
10798   /* This handles any COMMON areas that weren't referenced but have, for
10799      example, important initial data.  */
10800
10801   for (item = ffecom_list_common_;
10802        item != NULL;
10803        item = ffebld_trail (item))
10804     ffecom_transform_common_ (ffebld_symter (ffebld_head (item)));
10805
10806   ffecom_list_common_ = NULL;
10807 }
10808
10809 /* ffecom_exec_transition -- Perform exec transition on all symbols
10810
10811    ffecom_exec_transition();
10812
10813    Calls ffecom_sym_exec_transition for each global and local symbol.
10814    Make sure error updating not inhibited.  */
10815
10816 void
10817 ffecom_exec_transition ()
10818 {
10819   bool inhibited;
10820
10821   if (ffe_is_ffedebug ())
10822     fprintf (dmpout, "; exec_stmt_transition\n");
10823
10824   inhibited = ffebad_inhibit ();
10825   ffebad_set_inhibit (FALSE);
10826
10827   ffesymbol_drive (ffecom_sym_exec_transition); /* Don't retract! */
10828   ffeequiv_exec_transition ();  /* Handle all pending EQUIVALENCEs. */
10829   if (ffe_is_ffedebug ())
10830     {
10831       ffestorag_report ();
10832     }
10833
10834   if (inhibited)
10835     ffebad_set_inhibit (TRUE);
10836 }
10837
10838 /* Handle assignment statement.
10839
10840    Convert dest and source using ffecom_expr, then join them
10841    with an ASSIGN op and pass the whole thing to expand_expr_stmt.  */
10842
10843 void
10844 ffecom_expand_let_stmt (ffebld dest, ffebld source)
10845 {
10846   tree dest_tree;
10847   tree dest_length;
10848   tree source_tree;
10849   tree expr_tree;
10850
10851   if (ffeinfo_basictype (ffebld_info (dest)) != FFEINFO_basictypeCHARACTER)
10852     {
10853       bool dest_used;
10854       tree assign_temp;
10855
10856       /* This attempts to replicate the test below, but must not be
10857          true when the test below is false.  (Always err on the side
10858          of creating unused temporaries, to avoid ICEs.)  */
10859       if (ffebld_op (dest) != FFEBLD_opSYMTER
10860           || ((dest_tree = ffesymbol_hook (ffebld_symter (dest)).decl_tree)
10861               && (TREE_CODE (dest_tree) != VAR_DECL
10862                   || TREE_ADDRESSABLE (dest_tree))))
10863         {
10864           ffecom_prepare_expr_ (source, dest);
10865           dest_used = TRUE;
10866         }
10867       else
10868         {
10869           ffecom_prepare_expr_ (source, NULL);
10870           dest_used = FALSE;
10871         }
10872
10873       ffecom_prepare_expr_w (NULL_TREE, dest);
10874
10875       /* For COMPLEX assignment like C1=C2, if partial overlap is possible,
10876          create a temporary through which the assignment is to take place,
10877          since MODIFY_EXPR doesn't handle partial overlap properly.  */
10878       if (ffebld_basictype (dest) == FFEINFO_basictypeCOMPLEX
10879           && ffecom_possible_partial_overlap_ (dest, source))
10880         {
10881           assign_temp = ffecom_make_tempvar ("complex_let",
10882                                              ffecom_tree_type
10883                                              [ffebld_basictype (dest)]
10884                                              [ffebld_kindtype (dest)],
10885                                              FFETARGET_charactersizeNONE,
10886                                              -1);
10887         }
10888       else
10889         assign_temp = NULL_TREE;
10890
10891       ffecom_prepare_end ();
10892
10893       dest_tree = ffecom_expr_w (NULL_TREE, dest);
10894       if (dest_tree == error_mark_node)
10895         return;
10896
10897       if ((TREE_CODE (dest_tree) != VAR_DECL)
10898           || TREE_ADDRESSABLE (dest_tree))
10899         source_tree = ffecom_expr_ (source, dest_tree, dest, &dest_used,
10900                                     FALSE, FALSE);
10901       else
10902         {
10903           assert (! dest_used);
10904           dest_used = FALSE;
10905           source_tree = ffecom_expr (source);
10906         }
10907       if (source_tree == error_mark_node)
10908         return;
10909
10910       if (dest_used)
10911         expr_tree = source_tree;
10912       else if (assign_temp)
10913         {
10914 #ifdef MOVE_EXPR
10915           /* The back end understands a conceptual move (evaluate source;
10916              store into dest), so use that, in case it can determine
10917              that it is going to use, say, two registers as temporaries
10918              anyway.  So don't use the temp (and someday avoid generating
10919              it, once this code starts triggering regularly).  */
10920           expr_tree = ffecom_2s (MOVE_EXPR, void_type_node,
10921                                  dest_tree,
10922                                  source_tree);
10923 #else
10924           expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
10925                                  assign_temp,
10926                                  source_tree);
10927           expand_expr_stmt (expr_tree);
10928           expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
10929                                  dest_tree,
10930                                  assign_temp);
10931 #endif
10932         }
10933       else
10934         expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
10935                                dest_tree,
10936                                source_tree);
10937
10938       expand_expr_stmt (expr_tree);
10939       return;
10940     }
10941
10942   ffecom_prepare_let_char_ (ffebld_size_known (dest), source);
10943   ffecom_prepare_expr_w (NULL_TREE, dest);
10944
10945   ffecom_prepare_end ();
10946
10947   ffecom_char_args_ (&dest_tree, &dest_length, dest);
10948   ffecom_let_char_ (dest_tree, dest_length, ffebld_size_known (dest),
10949                     source);
10950 }
10951
10952 /* ffecom_expr -- Transform expr into gcc tree
10953
10954    tree t;
10955    ffebld expr;  // FFE expression.
10956    tree = ffecom_expr(expr);
10957
10958    Recursive descent on expr while making corresponding tree nodes and
10959    attaching type info and such.  */
10960
10961 tree
10962 ffecom_expr (ffebld expr)
10963 {
10964   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, FALSE, FALSE);
10965 }
10966
10967 /* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT.  */
10968
10969 tree
10970 ffecom_expr_assign (ffebld expr)
10971 {
10972   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
10973 }
10974
10975 /* Like ffecom_expr_rw, but return tree usable for ASSIGN.  */
10976
10977 tree
10978 ffecom_expr_assign_w (ffebld expr)
10979 {
10980   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
10981 }
10982
10983 /* Transform expr for use as into read/write tree and stabilize the
10984    reference.  Not for use on CHARACTER expressions.
10985
10986    Recursive descent on expr while making corresponding tree nodes and
10987    attaching type info and such.  */
10988
10989 tree
10990 ffecom_expr_rw (tree type, ffebld expr)
10991 {
10992   assert (expr != NULL);
10993   /* Different target types not yet supported.  */
10994   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
10995
10996   return stabilize_reference (ffecom_expr (expr));
10997 }
10998
10999 /* Transform expr for use as into write tree and stabilize the
11000    reference.  Not for use on CHARACTER expressions.
11001
11002    Recursive descent on expr while making corresponding tree nodes and
11003    attaching type info and such.  */
11004
11005 tree
11006 ffecom_expr_w (tree type, ffebld expr)
11007 {
11008   assert (expr != NULL);
11009   /* Different target types not yet supported.  */
11010   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
11011
11012   return stabilize_reference (ffecom_expr (expr));
11013 }
11014
11015 /* Do global stuff.  */
11016
11017 void
11018 ffecom_finish_compile ()
11019 {
11020   assert (ffecom_outer_function_decl_ == NULL_TREE);
11021   assert (current_function_decl == NULL_TREE);
11022
11023   ffeglobal_drive (ffecom_finish_global_);
11024 }
11025
11026 /* Public entry point for front end to access finish_decl.  */
11027
11028 void
11029 ffecom_finish_decl (tree decl, tree init, bool is_top_level)
11030 {
11031   assert (!is_top_level);
11032   finish_decl (decl, init, FALSE);
11033 }
11034
11035 /* Finish a program unit.  */
11036
11037 void
11038 ffecom_finish_progunit ()
11039 {
11040   ffecom_end_compstmt ();
11041
11042   ffecom_previous_function_decl_ = current_function_decl;
11043   ffecom_which_entrypoint_decl_ = NULL_TREE;
11044
11045   finish_function (0);
11046 }
11047
11048 /* Wrapper for get_identifier.  pattern is sprintf-like.  */
11049
11050 tree
11051 ffecom_get_invented_identifier (const char *pattern, ...)
11052 {
11053   tree decl;
11054   char *nam;
11055   va_list ap;
11056
11057   va_start (ap, pattern);
11058   if (vasprintf (&nam, pattern, ap) == 0)
11059     abort ();
11060   va_end (ap);
11061   decl = get_identifier (nam);
11062   free (nam);
11063   IDENTIFIER_INVENTED (decl) = 1;
11064   return decl;
11065 }
11066
11067 ffeinfoBasictype
11068 ffecom_gfrt_basictype (ffecomGfrt gfrt)
11069 {
11070   assert (gfrt < FFECOM_gfrt);
11071
11072   switch (ffecom_gfrt_type_[gfrt])
11073     {
11074     case FFECOM_rttypeVOID_:
11075     case FFECOM_rttypeVOIDSTAR_:
11076       return FFEINFO_basictypeNONE;
11077
11078     case FFECOM_rttypeFTNINT_:
11079       return FFEINFO_basictypeINTEGER;
11080
11081     case FFECOM_rttypeINTEGER_:
11082       return FFEINFO_basictypeINTEGER;
11083
11084     case FFECOM_rttypeLONGINT_:
11085       return FFEINFO_basictypeINTEGER;
11086
11087     case FFECOM_rttypeLOGICAL_:
11088       return FFEINFO_basictypeLOGICAL;
11089
11090     case FFECOM_rttypeREAL_F2C_:
11091     case FFECOM_rttypeREAL_GNU_:
11092       return FFEINFO_basictypeREAL;
11093
11094     case FFECOM_rttypeCOMPLEX_F2C_:
11095     case FFECOM_rttypeCOMPLEX_GNU_:
11096       return FFEINFO_basictypeCOMPLEX;
11097
11098     case FFECOM_rttypeDOUBLE_:
11099     case FFECOM_rttypeDOUBLEREAL_:
11100       return FFEINFO_basictypeREAL;
11101
11102     case FFECOM_rttypeDBLCMPLX_F2C_:
11103     case FFECOM_rttypeDBLCMPLX_GNU_:
11104       return FFEINFO_basictypeCOMPLEX;
11105
11106     case FFECOM_rttypeCHARACTER_:
11107       return FFEINFO_basictypeCHARACTER;
11108
11109     default:
11110       return FFEINFO_basictypeANY;
11111     }
11112 }
11113
11114 ffeinfoKindtype
11115 ffecom_gfrt_kindtype (ffecomGfrt gfrt)
11116 {
11117   assert (gfrt < FFECOM_gfrt);
11118
11119   switch (ffecom_gfrt_type_[gfrt])
11120     {
11121     case FFECOM_rttypeVOID_:
11122     case FFECOM_rttypeVOIDSTAR_:
11123       return FFEINFO_kindtypeNONE;
11124
11125     case FFECOM_rttypeFTNINT_:
11126       return FFEINFO_kindtypeINTEGER1;
11127
11128     case FFECOM_rttypeINTEGER_:
11129       return FFEINFO_kindtypeINTEGER1;
11130
11131     case FFECOM_rttypeLONGINT_:
11132       return FFEINFO_kindtypeINTEGER4;
11133
11134     case FFECOM_rttypeLOGICAL_:
11135       return FFEINFO_kindtypeLOGICAL1;
11136
11137     case FFECOM_rttypeREAL_F2C_:
11138     case FFECOM_rttypeREAL_GNU_:
11139       return FFEINFO_kindtypeREAL1;
11140
11141     case FFECOM_rttypeCOMPLEX_F2C_:
11142     case FFECOM_rttypeCOMPLEX_GNU_:
11143       return FFEINFO_kindtypeREAL1;
11144
11145     case FFECOM_rttypeDOUBLE_:
11146     case FFECOM_rttypeDOUBLEREAL_:
11147       return FFEINFO_kindtypeREAL2;
11148
11149     case FFECOM_rttypeDBLCMPLX_F2C_:
11150     case FFECOM_rttypeDBLCMPLX_GNU_:
11151       return FFEINFO_kindtypeREAL2;
11152
11153     case FFECOM_rttypeCHARACTER_:
11154       return FFEINFO_kindtypeCHARACTER1;
11155
11156     default:
11157       return FFEINFO_kindtypeANY;
11158     }
11159 }
11160
11161 void
11162 ffecom_init_0 ()
11163 {
11164   tree endlink;
11165   int i;
11166   int j;
11167   tree t;
11168   tree field;
11169   ffetype type;
11170   ffetype base_type;
11171   tree double_ftype_double;
11172   tree float_ftype_float;
11173   tree ldouble_ftype_ldouble;
11174   tree ffecom_tree_ptr_to_fun_type_void;
11175
11176   /* This block of code comes from the now-obsolete cktyps.c.  It checks
11177      whether the compiler environment is buggy in known ways, some of which
11178      would, if not explicitly checked here, result in subtle bugs in g77.  */
11179
11180   if (ffe_is_do_internal_checks ())
11181     {
11182       static const char names[][12]
11183         =
11184       {"bar", "bletch", "foo", "foobar"};
11185       const char *name;
11186       unsigned long ul;
11187       double fl;
11188
11189       name = bsearch ("foo", &names[0], ARRAY_SIZE (names), sizeof (names[0]),
11190                       (int (*)(const void *, const void *)) strcmp);
11191       if (name != &names[0][2])
11192         {
11193           assert ("bsearch doesn't work, #define FFEPROJ_BSEARCH 0 in proj.h"
11194                   == NULL);
11195           abort ();
11196         }
11197
11198       ul = strtoul ("123456789", NULL, 10);
11199       if (ul != 123456789L)
11200         {
11201           assert ("strtoul doesn't have enough range, #define FFEPROJ_STRTOUL 0\
11202  in proj.h" == NULL);
11203           abort ();
11204         }
11205
11206       fl = atof ("56.789");
11207       if ((fl < 56.788) || (fl > 56.79))
11208         {
11209           assert ("atof not type double, fix your #include <stdio.h>"
11210                   == NULL);
11211           abort ();
11212         }
11213     }
11214
11215   ffecom_outer_function_decl_ = NULL_TREE;
11216   current_function_decl = NULL_TREE;
11217   named_labels = NULL_TREE;
11218   current_binding_level = NULL_BINDING_LEVEL;
11219   free_binding_level = NULL_BINDING_LEVEL;
11220   /* Make the binding_level structure for global names.  */
11221   pushlevel (0);
11222   global_binding_level = current_binding_level;
11223   current_binding_level->prep_state = 2;
11224
11225   build_common_tree_nodes (1);
11226
11227   /* Define `int' and `char' first so that dbx will output them first.  */
11228   pushdecl (build_decl (TYPE_DECL, get_identifier ("int"),
11229                         integer_type_node));
11230   /* CHARACTER*1 is unsigned in ICHAR contexts.  */
11231   char_type_node = make_unsigned_type (CHAR_TYPE_SIZE);
11232   pushdecl (build_decl (TYPE_DECL, get_identifier ("char"),
11233                         char_type_node));
11234   pushdecl (build_decl (TYPE_DECL, get_identifier ("long int"),
11235                         long_integer_type_node));
11236   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned int"),
11237                         unsigned_type_node));
11238   pushdecl (build_decl (TYPE_DECL, get_identifier ("long unsigned int"),
11239                         long_unsigned_type_node));
11240   pushdecl (build_decl (TYPE_DECL, get_identifier ("long long int"),
11241                         long_long_integer_type_node));
11242   pushdecl (build_decl (TYPE_DECL, get_identifier ("long long unsigned int"),
11243                         long_long_unsigned_type_node));
11244   pushdecl (build_decl (TYPE_DECL, get_identifier ("short int"),
11245                         short_integer_type_node));
11246   pushdecl (build_decl (TYPE_DECL, get_identifier ("short unsigned int"),
11247                         short_unsigned_type_node));
11248
11249   /* Set the sizetype before we make other types.  This *should* be the
11250      first type we create.  */
11251
11252   set_sizetype
11253     (TREE_TYPE (IDENTIFIER_GLOBAL_VALUE (get_identifier (SIZE_TYPE))));
11254   ffecom_typesize_pointer_
11255     = TREE_INT_CST_LOW (TYPE_SIZE (sizetype)) / BITS_PER_UNIT;
11256
11257   build_common_tree_nodes_2 (0);
11258
11259   /* Define both `signed char' and `unsigned char'.  */
11260   pushdecl (build_decl (TYPE_DECL, get_identifier ("signed char"),
11261                         signed_char_type_node));
11262
11263   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned char"),
11264                         unsigned_char_type_node));
11265
11266   pushdecl (build_decl (TYPE_DECL, get_identifier ("float"),
11267                         float_type_node));
11268   pushdecl (build_decl (TYPE_DECL, get_identifier ("double"),
11269                         double_type_node));
11270   pushdecl (build_decl (TYPE_DECL, get_identifier ("long double"),
11271                         long_double_type_node));
11272
11273   /* For now, override what build_common_tree_nodes has done.  */
11274   complex_integer_type_node = ffecom_make_complex_type_ (integer_type_node);
11275   complex_float_type_node = ffecom_make_complex_type_ (float_type_node);
11276   complex_double_type_node = ffecom_make_complex_type_ (double_type_node);
11277   complex_long_double_type_node
11278     = ffecom_make_complex_type_ (long_double_type_node);
11279
11280   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex int"),
11281                         complex_integer_type_node));
11282   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex float"),
11283                         complex_float_type_node));
11284   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex double"),
11285                         complex_double_type_node));
11286   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex long double"),
11287                         complex_long_double_type_node));
11288
11289   pushdecl (build_decl (TYPE_DECL, get_identifier ("void"),
11290                         void_type_node));
11291   /* We are not going to have real types in C with less than byte alignment,
11292      so we might as well not have any types that claim to have it.  */
11293   TYPE_ALIGN (void_type_node) = BITS_PER_UNIT;
11294   TYPE_USER_ALIGN (void_type_node) = 0;
11295
11296   string_type_node = build_pointer_type (char_type_node);
11297
11298   ffecom_tree_fun_type_void
11299     = build_function_type (void_type_node, NULL_TREE);
11300
11301   ffecom_tree_ptr_to_fun_type_void
11302     = build_pointer_type (ffecom_tree_fun_type_void);
11303
11304   endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE);
11305
11306   float_ftype_float
11307     = build_function_type (float_type_node,
11308                            tree_cons (NULL_TREE, float_type_node, endlink));
11309
11310   double_ftype_double
11311     = build_function_type (double_type_node,
11312                            tree_cons (NULL_TREE, double_type_node, endlink));
11313
11314   ldouble_ftype_ldouble
11315     = build_function_type (long_double_type_node,
11316                            tree_cons (NULL_TREE, long_double_type_node,
11317                                       endlink));
11318
11319   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11320     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11321       {
11322         ffecom_tree_type[i][j] = NULL_TREE;
11323         ffecom_tree_fun_type[i][j] = NULL_TREE;
11324         ffecom_tree_ptr_to_fun_type[i][j] = NULL_TREE;
11325         ffecom_f2c_typecode_[i][j] = -1;
11326       }
11327
11328   /* Set up standard g77 types.  Note that INTEGER and LOGICAL are set
11329      to size FLOAT_TYPE_SIZE because they have to be the same size as
11330      REAL, which also is FLOAT_TYPE_SIZE, according to the standard.
11331      Compiler options and other such stuff that change the ways these
11332      types are set should not affect this particular setup.  */
11333
11334   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1]
11335     = t = make_signed_type (FLOAT_TYPE_SIZE);
11336   pushdecl (build_decl (TYPE_DECL, get_identifier ("integer"),
11337                         t));
11338   type = ffetype_new ();
11339   base_type = type;
11340   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER1,
11341                     type);
11342   ffetype_set_ams (type,
11343                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11344                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11345   ffetype_set_star (base_type,
11346                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11347                     type);
11348   ffetype_set_kind (base_type, 1, type);
11349   ffecom_typesize_integer1_ = ffetype_size (type);
11350   assert (ffetype_size (type) == sizeof (ffetargetInteger1));
11351
11352   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER1]
11353     = t = make_unsigned_type (FLOAT_TYPE_SIZE); /* HOLLERITH means unsigned. */
11354   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned"),
11355                         t));
11356
11357   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER2]
11358     = t = make_signed_type (CHAR_TYPE_SIZE);
11359   pushdecl (build_decl (TYPE_DECL, get_identifier ("byte"),
11360                         t));
11361   type = ffetype_new ();
11362   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER2,
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, 3, type);
11371   assert (ffetype_size (type) == sizeof (ffetargetInteger2));
11372
11373   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER2]
11374     = t = make_unsigned_type (CHAR_TYPE_SIZE);
11375   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned byte"),
11376                         t));
11377
11378   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER3]
11379     = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11380   pushdecl (build_decl (TYPE_DECL, get_identifier ("word"),
11381                         t));
11382   type = ffetype_new ();
11383   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER3,
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, 6, type);
11392   assert (ffetype_size (type) == sizeof (ffetargetInteger3));
11393
11394   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER3]
11395     = t = make_unsigned_type (CHAR_TYPE_SIZE * 2);
11396   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned word"),
11397                         t));
11398
11399   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER4]
11400     = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11401   pushdecl (build_decl (TYPE_DECL, get_identifier ("integer4"),
11402                         t));
11403   type = ffetype_new ();
11404   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER4,
11405                     type);
11406   ffetype_set_ams (type,
11407                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11408                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11409   ffetype_set_star (base_type,
11410                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11411                     type);
11412   ffetype_set_kind (base_type, 2, type);
11413   assert (ffetype_size (type) == sizeof (ffetargetInteger4));
11414
11415   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER4]
11416     = t = make_unsigned_type (FLOAT_TYPE_SIZE * 2);
11417   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned4"),
11418                         t));
11419
11420 #if 0
11421   if (ffe_is_do_internal_checks ()
11422       && LONG_TYPE_SIZE != FLOAT_TYPE_SIZE
11423       && LONG_TYPE_SIZE != CHAR_TYPE_SIZE
11424       && LONG_TYPE_SIZE != SHORT_TYPE_SIZE
11425       && LONG_TYPE_SIZE != LONG_LONG_TYPE_SIZE)
11426     {
11427       fprintf (stderr, "Sorry, no g77 support for LONG_TYPE_SIZE (%d bits) yet.\n",
11428                LONG_TYPE_SIZE);
11429     }
11430 #endif
11431
11432   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL1]
11433     = t = make_signed_type (FLOAT_TYPE_SIZE);
11434   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical"),
11435                         t));
11436   type = ffetype_new ();
11437   base_type = type;
11438   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL1,
11439                     type);
11440   ffetype_set_ams (type,
11441                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11442                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11443   ffetype_set_star (base_type,
11444                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11445                     type);
11446   ffetype_set_kind (base_type, 1, type);
11447   assert (ffetype_size (type) == sizeof (ffetargetLogical1));
11448
11449   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL2]
11450     = t = make_signed_type (CHAR_TYPE_SIZE);
11451   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical2"),
11452                         t));
11453   type = ffetype_new ();
11454   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL2,
11455                     type);
11456   ffetype_set_ams (type,
11457                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11458                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11459   ffetype_set_star (base_type,
11460                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11461                     type);
11462   ffetype_set_kind (base_type, 3, type);
11463   assert (ffetype_size (type) == sizeof (ffetargetLogical2));
11464
11465   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL3]
11466     = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11467   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical3"),
11468                         t));
11469   type = ffetype_new ();
11470   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL3,
11471                     type);
11472   ffetype_set_ams (type,
11473                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11474                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11475   ffetype_set_star (base_type,
11476                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11477                     type);
11478   ffetype_set_kind (base_type, 6, type);
11479   assert (ffetype_size (type) == sizeof (ffetargetLogical3));
11480
11481   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL4]
11482     = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11483   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical4"),
11484                         t));
11485   type = ffetype_new ();
11486   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL4,
11487                     type);
11488   ffetype_set_ams (type,
11489                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11490                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11491   ffetype_set_star (base_type,
11492                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11493                     type);
11494   ffetype_set_kind (base_type, 2, type);
11495   assert (ffetype_size (type) == sizeof (ffetargetLogical4));
11496
11497   ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11498     = t = make_node (REAL_TYPE);
11499   TYPE_PRECISION (t) = FLOAT_TYPE_SIZE;
11500   pushdecl (build_decl (TYPE_DECL, get_identifier ("real"),
11501                         t));
11502   layout_type (t);
11503   type = ffetype_new ();
11504   base_type = type;
11505   ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL1,
11506                     type);
11507   ffetype_set_ams (type,
11508                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11509                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11510   ffetype_set_star (base_type,
11511                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11512                     type);
11513   ffetype_set_kind (base_type, 1, type);
11514   ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11515     = FFETARGET_f2cTYREAL;
11516   assert (ffetype_size (type) == sizeof (ffetargetReal1));
11517
11518   ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREALDOUBLE]
11519     = t = make_node (REAL_TYPE);
11520   TYPE_PRECISION (t) = FLOAT_TYPE_SIZE * 2;     /* Always twice REAL. */
11521   pushdecl (build_decl (TYPE_DECL, get_identifier ("double precision"),
11522                         t));
11523   layout_type (t);
11524   type = ffetype_new ();
11525   ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE,
11526                     type);
11527   ffetype_set_ams (type,
11528                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11529                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11530   ffetype_set_star (base_type,
11531                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11532                     type);
11533   ffetype_set_kind (base_type, 2, type);
11534   ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]
11535     = FFETARGET_f2cTYDREAL;
11536   assert (ffetype_size (type) == sizeof (ffetargetReal2));
11537
11538   ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11539     = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]);
11540   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex"),
11541                         t));
11542   type = ffetype_new ();
11543   base_type = type;
11544   ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL1,
11545                     type);
11546   ffetype_set_ams (type,
11547                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11548                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11549   ffetype_set_star (base_type,
11550                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11551                     type);
11552   ffetype_set_kind (base_type, 1, type);
11553   ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11554     = FFETARGET_f2cTYCOMPLEX;
11555   assert (ffetype_size (type) == sizeof (ffetargetComplex1));
11556
11557   ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREALDOUBLE]
11558     = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]);
11559   pushdecl (build_decl (TYPE_DECL, get_identifier ("double complex"),
11560                         t));
11561   type = ffetype_new ();
11562   ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREALDOUBLE,
11563                     type);
11564   ffetype_set_ams (type,
11565                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11566                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11567   ffetype_set_star (base_type,
11568                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11569                     type);
11570   ffetype_set_kind (base_type, 2,
11571                     type);
11572   ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL2]
11573     = FFETARGET_f2cTYDCOMPLEX;
11574   assert (ffetype_size (type) == sizeof (ffetargetComplex2));
11575
11576   /* Make function and ptr-to-function types for non-CHARACTER types. */
11577
11578   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11579     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11580       {
11581         if ((t = ffecom_tree_type[i][j]) != NULL_TREE)
11582           {
11583             if (i == FFEINFO_basictypeINTEGER)
11584               {
11585                 /* Figure out the smallest INTEGER type that can hold
11586                    a pointer on this machine. */
11587                 if (GET_MODE_SIZE (TYPE_MODE (t))
11588                     >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
11589                   {
11590                     if ((ffecom_pointer_kind_ == FFEINFO_kindtypeNONE)
11591                         || (GET_MODE_SIZE (TYPE_MODE (ffecom_tree_type[i][ffecom_pointer_kind_]))
11592                             > GET_MODE_SIZE (TYPE_MODE (t))))
11593                       ffecom_pointer_kind_ = j;
11594                   }
11595               }
11596             else if (i == FFEINFO_basictypeCOMPLEX)
11597               t = void_type_node;
11598             /* For f2c compatibility, REAL functions are really
11599                implemented as DOUBLE PRECISION.  */
11600             else if ((i == FFEINFO_basictypeREAL)
11601                      && (j == FFEINFO_kindtypeREAL1))
11602               t = ffecom_tree_type
11603                 [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2];
11604
11605             t = ffecom_tree_fun_type[i][j] = build_function_type (t,
11606                                                                   NULL_TREE);
11607             ffecom_tree_ptr_to_fun_type[i][j] = build_pointer_type (t);
11608           }
11609       }
11610
11611   /* Set up pointer types.  */
11612
11613   if (ffecom_pointer_kind_ == FFEINFO_basictypeNONE)
11614     fatal_error ("no INTEGER type can hold a pointer on this configuration");
11615   else if (0 && ffe_is_do_internal_checks ())
11616     fprintf (stderr, "Pointer type kt=%d\n", ffecom_pointer_kind_);
11617   ffetype_set_kind (ffeinfo_type (FFEINFO_basictypeINTEGER,
11618                                   FFEINFO_kindtypeINTEGERDEFAULT),
11619                     7,
11620                     ffeinfo_type (FFEINFO_basictypeINTEGER,
11621                                   ffecom_pointer_kind_));
11622
11623   if (ffe_is_ugly_assign ())
11624     ffecom_label_kind_ = ffecom_pointer_kind_;  /* Require ASSIGN etc to this. */
11625   else
11626     ffecom_label_kind_ = FFEINFO_kindtypeINTEGERDEFAULT;
11627   if (0 && ffe_is_do_internal_checks ())
11628     fprintf (stderr, "Label type kt=%d\n", ffecom_label_kind_);
11629
11630   ffecom_integer_type_node
11631     = ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1];
11632   ffecom_integer_zero_node = convert (ffecom_integer_type_node,
11633                                       integer_zero_node);
11634   ffecom_integer_one_node = convert (ffecom_integer_type_node,
11635                                      integer_one_node);
11636
11637   /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional.
11638      Turns out that by TYLONG, runtime/libI77/lio.h really means
11639      "whatever size an ftnint is".  For consistency and sanity,
11640      com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen
11641      all are INTEGER, which we also make out of whatever back-end
11642      integer type is FLOAT_TYPE_SIZE bits wide.  This change, from
11643      LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to
11644      accommodate machines like the Alpha.  Note that this suggests
11645      f2c and libf2c are missing a distinction perhaps needed on
11646      some machines between "int" and "long int".  -- burley 0.5.5 950215 */
11647
11648   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, FLOAT_TYPE_SIZE,
11649                             FFETARGET_f2cTYLONG);
11650   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, SHORT_TYPE_SIZE,
11651                             FFETARGET_f2cTYSHORT);
11652   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, CHAR_TYPE_SIZE,
11653                             FFETARGET_f2cTYINT1);
11654   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, LONG_LONG_TYPE_SIZE,
11655                             FFETARGET_f2cTYQUAD);
11656   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, FLOAT_TYPE_SIZE,
11657                             FFETARGET_f2cTYLOGICAL);
11658   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, SHORT_TYPE_SIZE,
11659                             FFETARGET_f2cTYLOGICAL2);
11660   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, CHAR_TYPE_SIZE,
11661                             FFETARGET_f2cTYLOGICAL1);
11662   /* ~~~Not really such a type in libf2c, e.g. I/O support?  */
11663   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, LONG_LONG_TYPE_SIZE,
11664                             FFETARGET_f2cTYQUAD);
11665
11666   /* CHARACTER stuff is all special-cased, so it is not handled in the above
11667      loop.  CHARACTER items are built as arrays of unsigned char.  */
11668
11669   ffecom_tree_type[FFEINFO_basictypeCHARACTER]
11670     [FFEINFO_kindtypeCHARACTER1] = t = char_type_node;
11671   type = ffetype_new ();
11672   base_type = type;
11673   ffeinfo_set_type (FFEINFO_basictypeCHARACTER,
11674                     FFEINFO_kindtypeCHARACTER1,
11675                     type);
11676   ffetype_set_ams (type,
11677                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11678                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11679   ffetype_set_kind (base_type, 1, type);
11680   assert (ffetype_size (type)
11681           == sizeof (((ffetargetCharacter1) { 0, NULL }).text[0]));
11682
11683   ffecom_tree_fun_type[FFEINFO_basictypeCHARACTER]
11684     [FFEINFO_kindtypeCHARACTER1] = ffecom_tree_fun_type_void;
11685   ffecom_tree_ptr_to_fun_type[FFEINFO_basictypeCHARACTER]
11686     [FFEINFO_kindtypeCHARACTER1]
11687     = ffecom_tree_ptr_to_fun_type_void;
11688   ffecom_f2c_typecode_[FFEINFO_basictypeCHARACTER][FFEINFO_kindtypeCHARACTER1]
11689     = FFETARGET_f2cTYCHAR;
11690
11691   ffecom_f2c_typecode_[FFEINFO_basictypeANY][FFEINFO_kindtypeANY]
11692     = 0;
11693
11694   /* Make multi-return-value type and fields. */
11695
11696   ffecom_multi_type_node_ = make_node (UNION_TYPE);
11697
11698   field = NULL_TREE;
11699
11700   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11701     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11702       {
11703         char name[30];
11704
11705         if (ffecom_tree_type[i][j] == NULL_TREE)
11706           continue;             /* Not supported. */
11707         sprintf (&name[0], "bt_%s_kt_%s",
11708                  ffeinfo_basictype_string ((ffeinfoBasictype) i),
11709                  ffeinfo_kindtype_string ((ffeinfoKindtype) j));
11710         ffecom_multi_fields_[i][j] = build_decl (FIELD_DECL,
11711                                                  get_identifier (name),
11712                                                  ffecom_tree_type[i][j]);
11713         DECL_CONTEXT (ffecom_multi_fields_[i][j])
11714           = ffecom_multi_type_node_;
11715         DECL_ALIGN (ffecom_multi_fields_[i][j]) = 0;
11716         DECL_USER_ALIGN (ffecom_multi_fields_[i][j]) = 0;
11717         TREE_CHAIN (ffecom_multi_fields_[i][j]) = field;
11718         field = ffecom_multi_fields_[i][j];
11719       }
11720
11721   TYPE_FIELDS (ffecom_multi_type_node_) = field;
11722   layout_type (ffecom_multi_type_node_);
11723
11724   /* Subroutines usually return integer because they might have alternate
11725      returns. */
11726
11727   ffecom_tree_subr_type
11728     = build_function_type (integer_type_node, NULL_TREE);
11729   ffecom_tree_ptr_to_subr_type
11730     = build_pointer_type (ffecom_tree_subr_type);
11731   ffecom_tree_blockdata_type
11732     = build_function_type (void_type_node, NULL_TREE);
11733
11734   builtin_function ("__builtin_sqrtf", float_ftype_float,
11735                     BUILT_IN_SQRTF, BUILT_IN_NORMAL, "sqrtf");
11736   builtin_function ("__builtin_sqrt", double_ftype_double,
11737                     BUILT_IN_SQRT, BUILT_IN_NORMAL, "sqrt");
11738   builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble,
11739                     BUILT_IN_SQRTL, BUILT_IN_NORMAL, "sqrtl");
11740   builtin_function ("__builtin_sinf", float_ftype_float,
11741                     BUILT_IN_SINF, BUILT_IN_NORMAL, "sinf");
11742   builtin_function ("__builtin_sin", double_ftype_double,
11743                     BUILT_IN_SIN, BUILT_IN_NORMAL, "sin");
11744   builtin_function ("__builtin_sinl", ldouble_ftype_ldouble,
11745                     BUILT_IN_SINL, BUILT_IN_NORMAL, "sinl");
11746   builtin_function ("__builtin_cosf", float_ftype_float,
11747                     BUILT_IN_COSF, BUILT_IN_NORMAL, "cosf");
11748   builtin_function ("__builtin_cos", double_ftype_double,
11749                     BUILT_IN_COS, BUILT_IN_NORMAL, "cos");
11750   builtin_function ("__builtin_cosl", ldouble_ftype_ldouble,
11751                     BUILT_IN_COSL, BUILT_IN_NORMAL, "cosl");
11752
11753   pedantic_lvalues = FALSE;
11754
11755   ffecom_f2c_make_type_ (&ffecom_f2c_integer_type_node,
11756                          FFECOM_f2cINTEGER,
11757                          "integer");
11758   ffecom_f2c_make_type_ (&ffecom_f2c_address_type_node,
11759                          FFECOM_f2cADDRESS,
11760                          "address");
11761   ffecom_f2c_make_type_ (&ffecom_f2c_real_type_node,
11762                          FFECOM_f2cREAL,
11763                          "real");
11764   ffecom_f2c_make_type_ (&ffecom_f2c_doublereal_type_node,
11765                          FFECOM_f2cDOUBLEREAL,
11766                          "doublereal");
11767   ffecom_f2c_make_type_ (&ffecom_f2c_complex_type_node,
11768                          FFECOM_f2cCOMPLEX,
11769                          "complex");
11770   ffecom_f2c_make_type_ (&ffecom_f2c_doublecomplex_type_node,
11771                          FFECOM_f2cDOUBLECOMPLEX,
11772                          "doublecomplex");
11773   ffecom_f2c_make_type_ (&ffecom_f2c_longint_type_node,
11774                          FFECOM_f2cLONGINT,
11775                          "longint");
11776   ffecom_f2c_make_type_ (&ffecom_f2c_logical_type_node,
11777                          FFECOM_f2cLOGICAL,
11778                          "logical");
11779   ffecom_f2c_make_type_ (&ffecom_f2c_flag_type_node,
11780                          FFECOM_f2cFLAG,
11781                          "flag");
11782   ffecom_f2c_make_type_ (&ffecom_f2c_ftnlen_type_node,
11783                          FFECOM_f2cFTNLEN,
11784                          "ftnlen");
11785   ffecom_f2c_make_type_ (&ffecom_f2c_ftnint_type_node,
11786                          FFECOM_f2cFTNINT,
11787                          "ftnint");
11788
11789   ffecom_f2c_ftnlen_zero_node
11790     = convert (ffecom_f2c_ftnlen_type_node, integer_zero_node);
11791
11792   ffecom_f2c_ftnlen_one_node
11793     = convert (ffecom_f2c_ftnlen_type_node, integer_one_node);
11794
11795   ffecom_f2c_ftnlen_two_node = build_int_2 (2, 0);
11796   TREE_TYPE (ffecom_f2c_ftnlen_two_node) = ffecom_integer_type_node;
11797
11798   ffecom_f2c_ptr_to_ftnlen_type_node
11799     = build_pointer_type (ffecom_f2c_ftnlen_type_node);
11800
11801   ffecom_f2c_ptr_to_ftnint_type_node
11802     = build_pointer_type (ffecom_f2c_ftnint_type_node);
11803
11804   ffecom_f2c_ptr_to_integer_type_node
11805     = build_pointer_type (ffecom_f2c_integer_type_node);
11806
11807   ffecom_f2c_ptr_to_real_type_node
11808     = build_pointer_type (ffecom_f2c_real_type_node);
11809
11810   ffecom_float_zero_ = build_real (float_type_node, dconst0);
11811   ffecom_double_zero_ = build_real (double_type_node, dconst0);
11812   {
11813     REAL_VALUE_TYPE point_5;
11814
11815     REAL_ARITHMETIC (point_5, RDIV_EXPR, dconst1, dconst2);
11816     ffecom_float_half_ = build_real (float_type_node, point_5);
11817     ffecom_double_half_ = build_real (double_type_node, point_5);
11818   }
11819
11820   /* Do "extern int xargc;".  */
11821
11822   ffecom_tree_xargc_ = build_decl (VAR_DECL,
11823                                    get_identifier ("f__xargc"),
11824                                    integer_type_node);
11825   DECL_EXTERNAL (ffecom_tree_xargc_) = 1;
11826   TREE_STATIC (ffecom_tree_xargc_) = 1;
11827   TREE_PUBLIC (ffecom_tree_xargc_) = 1;
11828   ffecom_tree_xargc_ = start_decl (ffecom_tree_xargc_, FALSE);
11829   finish_decl (ffecom_tree_xargc_, NULL_TREE, FALSE);
11830
11831 #if 0   /* This is being fixed, and seems to be working now. */
11832   if ((FLOAT_TYPE_SIZE != 32)
11833       || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))) != 32))
11834     {
11835       warning ("configuration: REAL, INTEGER, and LOGICAL are %d bits wide,",
11836                (int) FLOAT_TYPE_SIZE);
11837       warning ("and pointers are %d bits wide, but g77 doesn't yet work",
11838           (int) TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))));
11839       warning ("properly unless they all are 32 bits wide");
11840       warning ("Please keep this in mind before you report bugs.");
11841     }
11842 #endif
11843
11844 #if 0   /* Code in ste.c that would crash has been commented out. */
11845   if (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)
11846       < TYPE_PRECISION (string_type_node))
11847     /* I/O will probably crash.  */
11848     warning ("configuration: char * holds %d bits, but ftnlen only %d",
11849              TYPE_PRECISION (string_type_node),
11850              TYPE_PRECISION (ffecom_f2c_ftnlen_type_node));
11851 #endif
11852
11853 #if 0   /* ASSIGN-related stuff has been changed to accommodate this. */
11854   if (TYPE_PRECISION (ffecom_integer_type_node)
11855       < TYPE_PRECISION (string_type_node))
11856     /* ASSIGN 10 TO I will crash.  */
11857     warning ("configuration: char * holds %d bits, but INTEGER only %d --\n\
11858  ASSIGN statement might fail",
11859              TYPE_PRECISION (string_type_node),
11860              TYPE_PRECISION (ffecom_integer_type_node));
11861 #endif
11862 }
11863
11864 /* ffecom_init_2 -- Initialize
11865
11866    ffecom_init_2();  */
11867
11868 void
11869 ffecom_init_2 ()
11870 {
11871   assert (ffecom_outer_function_decl_ == NULL_TREE);
11872   assert (current_function_decl == NULL_TREE);
11873   assert (ffecom_which_entrypoint_decl_ == NULL_TREE);
11874
11875   ffecom_master_arglist_ = NULL;
11876   ++ffecom_num_fns_;
11877   ffecom_primary_entry_ = NULL;
11878   ffecom_is_altreturning_ = FALSE;
11879   ffecom_func_result_ = NULL_TREE;
11880   ffecom_multi_retval_ = NULL_TREE;
11881 }
11882
11883 /* ffecom_list_expr -- Transform list of exprs into gcc tree
11884
11885    tree t;
11886    ffebld expr;  // FFE opITEM list.
11887    tree = ffecom_list_expr(expr);
11888
11889    List of actual args is transformed into corresponding gcc backend list.  */
11890
11891 tree
11892 ffecom_list_expr (ffebld expr)
11893 {
11894   tree list;
11895   tree *plist = &list;
11896   tree trail = NULL_TREE;       /* Append char length args here. */
11897   tree *ptrail = &trail;
11898   tree length;
11899
11900   while (expr != NULL)
11901     {
11902       tree texpr = ffecom_arg_expr (ffebld_head (expr), &length);
11903
11904       if (texpr == error_mark_node)
11905         return error_mark_node;
11906
11907       *plist = build_tree_list (NULL_TREE, texpr);
11908       plist = &TREE_CHAIN (*plist);
11909       expr = ffebld_trail (expr);
11910       if (length != NULL_TREE)
11911         {
11912           *ptrail = build_tree_list (NULL_TREE, length);
11913           ptrail = &TREE_CHAIN (*ptrail);
11914         }
11915     }
11916
11917   *plist = trail;
11918
11919   return list;
11920 }
11921
11922 /* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree
11923
11924    tree t;
11925    ffebld expr;  // FFE opITEM list.
11926    tree = ffecom_list_ptr_to_expr(expr);
11927
11928    List of actual args is transformed into corresponding gcc backend list for
11929    use in calling an external procedure (vs. a statement function).  */
11930
11931 tree
11932 ffecom_list_ptr_to_expr (ffebld expr)
11933 {
11934   tree list;
11935   tree *plist = &list;
11936   tree trail = NULL_TREE;       /* Append char length args here. */
11937   tree *ptrail = &trail;
11938   tree length;
11939
11940   while (expr != NULL)
11941     {
11942       tree texpr = ffecom_arg_ptr_to_expr (ffebld_head (expr), &length);
11943
11944       if (texpr == error_mark_node)
11945         return error_mark_node;
11946
11947       *plist = build_tree_list (NULL_TREE, texpr);
11948       plist = &TREE_CHAIN (*plist);
11949       expr = ffebld_trail (expr);
11950       if (length != NULL_TREE)
11951         {
11952           *ptrail = build_tree_list (NULL_TREE, length);
11953           ptrail = &TREE_CHAIN (*ptrail);
11954         }
11955     }
11956
11957   *plist = trail;
11958
11959   return list;
11960 }
11961
11962 /* Obtain gcc's LABEL_DECL tree for label.  */
11963
11964 tree
11965 ffecom_lookup_label (ffelab label)
11966 {
11967   tree glabel;
11968
11969   if (ffelab_hook (label) == NULL_TREE)
11970     {
11971       char labelname[16];
11972
11973       switch (ffelab_type (label))
11974         {
11975         case FFELAB_typeLOOPEND:
11976         case FFELAB_typeNOTLOOP:
11977         case FFELAB_typeENDIF:
11978           sprintf (labelname, "%" ffelabValue_f "u", ffelab_value (label));
11979           glabel = build_decl (LABEL_DECL, get_identifier (labelname),
11980                                void_type_node);
11981           DECL_CONTEXT (glabel) = current_function_decl;
11982           DECL_MODE (glabel) = VOIDmode;
11983           break;
11984
11985         case FFELAB_typeFORMAT:
11986           glabel = build_decl (VAR_DECL,
11987                                ffecom_get_invented_identifier
11988                                ("__g77_format_%d", (int) ffelab_value (label)),
11989                                build_type_variant (build_array_type
11990                                                    (char_type_node,
11991                                                     NULL_TREE),
11992                                                    1, 0));
11993           TREE_CONSTANT (glabel) = 1;
11994           TREE_STATIC (glabel) = 1;
11995           DECL_CONTEXT (glabel) = current_function_decl;
11996           DECL_INITIAL (glabel) = NULL;
11997           make_decl_rtl (glabel, NULL);
11998           expand_decl (glabel);
11999
12000           ffecom_save_tree_forever (glabel);
12001
12002           break;
12003
12004         case FFELAB_typeANY:
12005           glabel = error_mark_node;
12006           break;
12007
12008         default:
12009           assert ("bad label type" == NULL);
12010           glabel = NULL;
12011           break;
12012         }
12013       ffelab_set_hook (label, glabel);
12014     }
12015   else
12016     {
12017       glabel = ffelab_hook (label);
12018     }
12019
12020   return glabel;
12021 }
12022
12023 /* Stabilizes the arguments.  Don't use this if the lhs and rhs come from
12024    a single source specification (as in the fourth argument of MVBITS).
12025    If the type is NULL_TREE, the type of lhs is used to make the type of
12026    the MODIFY_EXPR.  */
12027
12028 tree
12029 ffecom_modify (tree newtype, tree lhs,
12030                tree rhs)
12031 {
12032   if (lhs == error_mark_node || rhs == error_mark_node)
12033     return error_mark_node;
12034
12035   if (newtype == NULL_TREE)
12036     newtype = TREE_TYPE (lhs);
12037
12038   if (TREE_SIDE_EFFECTS (lhs))
12039     lhs = stabilize_reference (lhs);
12040
12041   return ffecom_2s (MODIFY_EXPR, newtype, lhs, rhs);
12042 }
12043
12044 /* Register source file name.  */
12045
12046 void
12047 ffecom_file (const char *name)
12048 {
12049   ffecom_file_ (name);
12050 }
12051
12052 /* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed
12053
12054    ffestorag st;
12055    ffecom_notify_init_storage(st);
12056
12057    Gets called when all possible units in an aggregate storage area (a LOCAL
12058    with equivalences or a COMMON) have been initialized.  The initialization
12059    info either is in ffestorag_init or, if that is NULL,
12060    ffestorag_accretion:
12061
12062    ffestorag_init may contain an opCONTER or opARRTER.  opCONTER may occur
12063    even for an array if the array is one element in length!
12064
12065    ffestorag_accretion will contain an opACCTER.  It is much like an
12066    opARRTER except it has an ffebit object in it instead of just a size.
12067    The back end can use the info in the ffebit object, if it wants, to
12068    reduce the amount of actual initialization, but in any case it should
12069    kill the ffebit object when done.  Also, set accretion to NULL but
12070    init to a non-NULL value.
12071
12072    After performing initialization, DO NOT set init to NULL, because that'll
12073    tell the front end it is ok for more initialization to happen.  Instead,
12074    set init to an opANY expression or some such thing that you can use to
12075    tell that you've already initialized the object.
12076
12077    27-Oct-91  JCB  1.1
12078       Support two-pass FFE.  */
12079
12080 void
12081 ffecom_notify_init_storage (ffestorag st)
12082 {
12083   ffebld init;                  /* The initialization expression. */
12084
12085   if (ffestorag_init (st) == NULL)
12086     {
12087       init = ffestorag_accretion (st);
12088       assert (init != NULL);
12089       ffestorag_set_accretion (st, NULL);
12090       ffestorag_set_accretes (st, 0);
12091       ffestorag_set_init (st, init);
12092     }
12093 }
12094
12095 /* ffecom_notify_init_symbol -- A symbol is now fully init'ed
12096
12097    ffesymbol s;
12098    ffecom_notify_init_symbol(s);
12099
12100    Gets called when all possible units in a symbol (not placed in COMMON
12101    or involved in EQUIVALENCE, unless it as yet has no ffestorag object)
12102    have been initialized.  The initialization info either is in
12103    ffesymbol_init or, if that is NULL, ffesymbol_accretion:
12104
12105    ffesymbol_init may contain an opCONTER or opARRTER.  opCONTER may occur
12106    even for an array if the array is one element in length!
12107
12108    ffesymbol_accretion will contain an opACCTER.  It is much like an
12109    opARRTER except it has an ffebit object in it instead of just a size.
12110    The back end can use the info in the ffebit object, if it wants, to
12111    reduce the amount of actual initialization, but in any case it should
12112    kill the ffebit object when done.  Also, set accretion to NULL but
12113    init to a non-NULL value.
12114
12115    After performing initialization, DO NOT set init to NULL, because that'll
12116    tell the front end it is ok for more initialization to happen.  Instead,
12117    set init to an opANY expression or some such thing that you can use to
12118    tell that you've already initialized the object.
12119
12120    27-Oct-91  JCB  1.1
12121       Support two-pass FFE.  */
12122
12123 void
12124 ffecom_notify_init_symbol (ffesymbol s)
12125 {
12126   ffebld init;                  /* The initialization expression. */
12127
12128   if (ffesymbol_storage (s) == NULL)
12129     return;                     /* Do nothing until COMMON/EQUIVALENCE
12130                                    possibilities checked. */
12131
12132   if ((ffesymbol_init (s) == NULL)
12133       && ((init = ffesymbol_accretion (s)) != NULL))
12134     {
12135       ffesymbol_set_accretion (s, NULL);
12136       ffesymbol_set_accretes (s, 0);
12137       ffesymbol_set_init (s, init);
12138     }
12139 }
12140
12141 /* ffecom_notify_primary_entry -- Learn which is the primary entry point
12142
12143    ffesymbol s;
12144    ffecom_notify_primary_entry(s);
12145
12146    Gets called when implicit or explicit PROGRAM statement seen or when
12147    FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary
12148    global symbol that serves as the entry point.  */
12149
12150 void
12151 ffecom_notify_primary_entry (ffesymbol s)
12152 {
12153   ffecom_primary_entry_ = s;
12154   ffecom_primary_entry_kind_ = ffesymbol_kind (s);
12155
12156   if ((ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
12157       || (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE))
12158     ffecom_primary_entry_is_proc_ = TRUE;
12159   else
12160     ffecom_primary_entry_is_proc_ = FALSE;
12161
12162   if (!ffe_is_silent ())
12163     {
12164       if (ffecom_primary_entry_kind_ == FFEINFO_kindPROGRAM)
12165         fprintf (stderr, "%s:\n", ffesymbol_text (s));
12166       else
12167         fprintf (stderr, "  %s:\n", ffesymbol_text (s));
12168     }
12169
12170   if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
12171     {
12172       ffebld list;
12173       ffebld arg;
12174
12175       for (list = ffesymbol_dummyargs (s);
12176            list != NULL;
12177            list = ffebld_trail (list))
12178         {
12179           arg = ffebld_head (list);
12180           if (ffebld_op (arg) == FFEBLD_opSTAR)
12181             {
12182               ffecom_is_altreturning_ = TRUE;
12183               break;
12184             }
12185         }
12186     }
12187 }
12188
12189 FILE *
12190 ffecom_open_include (char *name, ffewhereLine l, ffewhereColumn c)
12191 {
12192   return ffecom_open_include_ (name, l, c);
12193 }
12194
12195 /* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front
12196
12197    tree t;
12198    ffebld expr;  // FFE expression.
12199    tree = ffecom_ptr_to_expr(expr);
12200
12201    Like ffecom_expr, but sticks address-of in front of most things.  */
12202
12203 tree
12204 ffecom_ptr_to_expr (ffebld expr)
12205 {
12206   tree item;
12207   ffeinfoBasictype bt;
12208   ffeinfoKindtype kt;
12209   ffesymbol s;
12210
12211   assert (expr != NULL);
12212
12213   switch (ffebld_op (expr))
12214     {
12215     case FFEBLD_opSYMTER:
12216       s = ffebld_symter (expr);
12217       if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
12218         {
12219           ffecomGfrt ix;
12220
12221           ix = ffeintrin_gfrt_indirect (ffebld_symter_implementation (expr));
12222           assert (ix != FFECOM_gfrt);
12223           if ((item = ffecom_gfrt_[ix]) == NULL_TREE)
12224             {
12225               ffecom_make_gfrt_ (ix);
12226               item = ffecom_gfrt_[ix];
12227             }
12228         }
12229       else
12230         {
12231           item = ffesymbol_hook (s).decl_tree;
12232           if (item == NULL_TREE)
12233             {
12234               s = ffecom_sym_transform_ (s);
12235               item = ffesymbol_hook (s).decl_tree;
12236             }
12237         }
12238       assert (item != NULL);
12239       if (item == error_mark_node)
12240         return item;
12241       if (!ffesymbol_hook (s).addr)
12242         item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12243                          item);
12244       return item;
12245
12246     case FFEBLD_opARRAYREF:
12247       return ffecom_arrayref_ (NULL_TREE, expr, 1);
12248
12249     case FFEBLD_opCONTER:
12250
12251       bt = ffeinfo_basictype (ffebld_info (expr));
12252       kt = ffeinfo_kindtype (ffebld_info (expr));
12253
12254       item = ffecom_constantunion (&ffebld_constant_union
12255                                    (ffebld_conter (expr)), bt, kt,
12256                                    ffecom_tree_type[bt][kt]);
12257       if (item == error_mark_node)
12258         return error_mark_node;
12259       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12260                        item);
12261       return item;
12262
12263     case FFEBLD_opANY:
12264       return error_mark_node;
12265
12266     default:
12267       bt = ffeinfo_basictype (ffebld_info (expr));
12268       kt = ffeinfo_kindtype (ffebld_info (expr));
12269
12270       item = ffecom_expr (expr);
12271       if (item == error_mark_node)
12272         return error_mark_node;
12273
12274       /* The back end currently optimizes a bit too zealously for us, in that
12275          we fail JCB001 if the following block of code is omitted.  It checks
12276          to see if the transformed expression is a symbol or array reference,
12277          and encloses it in a SAVE_EXPR if that is the case.  */
12278
12279       STRIP_NOPS (item);
12280       if ((TREE_CODE (item) == VAR_DECL)
12281           || (TREE_CODE (item) == PARM_DECL)
12282           || (TREE_CODE (item) == RESULT_DECL)
12283           || (TREE_CODE (item) == INDIRECT_REF)
12284           || (TREE_CODE (item) == ARRAY_REF)
12285           || (TREE_CODE (item) == COMPONENT_REF)
12286 #ifdef OFFSET_REF
12287           || (TREE_CODE (item) == OFFSET_REF)
12288 #endif
12289           || (TREE_CODE (item) == BUFFER_REF)
12290           || (TREE_CODE (item) == REALPART_EXPR)
12291           || (TREE_CODE (item) == IMAGPART_EXPR))
12292         {
12293           item = ffecom_save_tree (item);
12294         }
12295
12296       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12297                        item);
12298       return item;
12299     }
12300
12301   assert ("fall-through error" == NULL);
12302   return error_mark_node;
12303 }
12304
12305 /* Obtain a temp var with given data type.
12306
12307    size is FFETARGET_charactersizeNONE for a non-CHARACTER type
12308    or >= 0 for a CHARACTER type.
12309
12310    elements is -1 for a scalar or > 0 for an array of type.  */
12311
12312 tree
12313 ffecom_make_tempvar (const char *commentary, tree type,
12314                      ffetargetCharacterSize size, int elements)
12315 {
12316   tree t;
12317   static int mynumber;
12318
12319   assert (current_binding_level->prep_state < 2);
12320
12321   if (type == error_mark_node)
12322     return error_mark_node;
12323
12324   if (size != FFETARGET_charactersizeNONE)
12325     type = build_array_type (type,
12326                              build_range_type (ffecom_f2c_ftnlen_type_node,
12327                                                ffecom_f2c_ftnlen_one_node,
12328                                                build_int_2 (size, 0)));
12329   if (elements != -1)
12330     type = build_array_type (type,
12331                              build_range_type (integer_type_node,
12332                                                integer_zero_node,
12333                                                build_int_2 (elements - 1,
12334                                                             0)));
12335   t = build_decl (VAR_DECL,
12336                   ffecom_get_invented_identifier ("__g77_%s_%d",
12337                                                   commentary,
12338                                                   mynumber++),
12339                   type);
12340
12341   t = start_decl (t, FALSE);
12342   finish_decl (t, NULL_TREE, FALSE);
12343
12344   return t;
12345 }
12346
12347 /* Prepare argument pointer to expression.
12348
12349    Like ffecom_prepare_expr, except for expressions to be evaluated
12350    via ffecom_arg_ptr_to_expr.  */
12351
12352 void
12353 ffecom_prepare_arg_ptr_to_expr (ffebld expr)
12354 {
12355   /* ~~For now, it seems to be the same thing.  */
12356   ffecom_prepare_expr (expr);
12357   return;
12358 }
12359
12360 /* End of preparations.  */
12361
12362 bool
12363 ffecom_prepare_end (void)
12364 {
12365   int prep_state = current_binding_level->prep_state;
12366
12367   assert (prep_state < 2);
12368   current_binding_level->prep_state = 2;
12369
12370   return (prep_state == 1) ? TRUE : FALSE;
12371 }
12372
12373 /* Prepare expression.
12374
12375    This is called before any code is generated for the current block.
12376    It scans the expression, declares any temporaries that might be needed
12377    during evaluation of the expression, and stores those temporaries in
12378    the appropriate "hook" fields of the expression.  `dest', if not NULL,
12379    specifies the destination that ffecom_expr_ will see, in case that
12380    helps avoid generating unused temporaries.
12381
12382    ~~Improve to avoid allocating unused temporaries by taking `dest'
12383    into account vis-a-vis aliasing requirements of complex/character
12384    functions.  */
12385
12386 void
12387 ffecom_prepare_expr_ (ffebld expr, ffebld dest UNUSED)
12388 {
12389   ffeinfoBasictype bt;
12390   ffeinfoKindtype kt;
12391   ffetargetCharacterSize sz;
12392   tree tempvar = NULL_TREE;
12393
12394   assert (current_binding_level->prep_state < 2);
12395
12396   if (! expr)
12397     return;
12398
12399   bt = ffeinfo_basictype (ffebld_info (expr));
12400   kt = ffeinfo_kindtype (ffebld_info (expr));
12401   sz = ffeinfo_size (ffebld_info (expr));
12402
12403   /* Generate whatever temporaries are needed to represent the result
12404      of the expression.  */
12405
12406   if (bt == FFEINFO_basictypeCHARACTER)
12407     {
12408       while (ffebld_op (expr) == FFEBLD_opPAREN)
12409         expr = ffebld_left (expr);
12410     }
12411
12412   switch (ffebld_op (expr))
12413     {
12414     default:
12415       /* Don't make temps for SYMTER, CONTER, etc.  */
12416       if (ffebld_arity (expr) == 0)
12417         break;
12418
12419       switch (bt)
12420         {
12421         case FFEINFO_basictypeCOMPLEX:
12422           if (ffebld_op (expr) == FFEBLD_opFUNCREF)
12423             {
12424               ffesymbol s;
12425
12426               if (ffebld_op (ffebld_left (expr)) != FFEBLD_opSYMTER)
12427                 break;
12428
12429               s = ffebld_symter (ffebld_left (expr));
12430               if (ffesymbol_where (s) == FFEINFO_whereCONSTANT
12431                   || (ffesymbol_where (s) != FFEINFO_whereINTRINSIC
12432                       && ! ffesymbol_is_f2c (s))
12433                   || (ffesymbol_where (s) == FFEINFO_whereINTRINSIC
12434                       && ! ffe_is_f2c_library ()))
12435                 break;
12436             }
12437           else if (ffebld_op (expr) == FFEBLD_opPOWER)
12438             {
12439               /* Requires special treatment.  There's no POW_CC function
12440                  in libg2c, so POW_ZZ is used, which means we always
12441                  need a double-complex temp, not a single-complex.  */
12442               kt = FFEINFO_kindtypeREAL2;
12443             }
12444           else if (ffebld_op (expr) != FFEBLD_opDIVIDE)
12445             /* The other ops don't need temps for complex operands.  */
12446             break;
12447
12448           /* ~~~Avoid making temps for some intrinsics, such as AIMAG(C),
12449              REAL(C).  See 19990325-0.f, routine `check', for cases.  */
12450           tempvar = ffecom_make_tempvar ("complex",
12451                                          ffecom_tree_type
12452                                          [FFEINFO_basictypeCOMPLEX][kt],
12453                                          FFETARGET_charactersizeNONE,
12454                                          -1);
12455           break;
12456
12457         case FFEINFO_basictypeCHARACTER:
12458           if (ffebld_op (expr) != FFEBLD_opFUNCREF)
12459             break;
12460
12461           if (sz == FFETARGET_charactersizeNONE)
12462             /* ~~Kludge alert!  This should someday be fixed. */
12463             sz = 24;
12464
12465           tempvar = ffecom_make_tempvar ("char", char_type_node, sz, -1);
12466           break;
12467
12468         default:
12469           break;
12470         }
12471       break;
12472
12473 #ifdef HAHA
12474     case FFEBLD_opPOWER:
12475       {
12476         tree rtype, ltype;
12477         tree rtmp, ltmp, result;
12478
12479         ltype = ffecom_type_expr (ffebld_left (expr));
12480         rtype = ffecom_type_expr (ffebld_right (expr));
12481
12482         rtmp = ffecom_make_tempvar (rtype, FFETARGET_charactersizeNONE, -1);
12483         ltmp = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
12484         result = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
12485
12486         tempvar = make_tree_vec (3);
12487         TREE_VEC_ELT (tempvar, 0) = rtmp;
12488         TREE_VEC_ELT (tempvar, 1) = ltmp;
12489         TREE_VEC_ELT (tempvar, 2) = result;
12490       }
12491       break;
12492 #endif  /* HAHA */
12493
12494     case FFEBLD_opCONCATENATE:
12495       {
12496         /* This gets special handling, because only one set of temps
12497            is needed for a tree of these -- the tree is treated as
12498            a flattened list of concatenations when generating code.  */
12499
12500         ffecomConcatList_ catlist;
12501         tree ltmp, itmp, result;
12502         int count;
12503         int i;
12504
12505         catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
12506         count = ffecom_concat_list_count_ (catlist);
12507
12508         if (count >= 2)
12509           {
12510             ltmp
12511               = ffecom_make_tempvar ("concat_len",
12512                                      ffecom_f2c_ftnlen_type_node,
12513                                      FFETARGET_charactersizeNONE, count);
12514             itmp
12515               = ffecom_make_tempvar ("concat_item",
12516                                      ffecom_f2c_address_type_node,
12517                                      FFETARGET_charactersizeNONE, count);
12518             result
12519               = ffecom_make_tempvar ("concat_res",
12520                                      char_type_node,
12521                                      ffecom_concat_list_maxlen_ (catlist),
12522                                      -1);
12523
12524             tempvar = make_tree_vec (3);
12525             TREE_VEC_ELT (tempvar, 0) = ltmp;
12526             TREE_VEC_ELT (tempvar, 1) = itmp;
12527             TREE_VEC_ELT (tempvar, 2) = result;
12528           }
12529
12530         for (i = 0; i < count; ++i)
12531           ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist,
12532                                                                     i));
12533
12534         ffecom_concat_list_kill_ (catlist);
12535
12536         if (tempvar)
12537           {
12538             ffebld_nonter_set_hook (expr, tempvar);
12539             current_binding_level->prep_state = 1;
12540           }
12541       }
12542       return;
12543
12544     case FFEBLD_opCONVERT:
12545       if (bt == FFEINFO_basictypeCHARACTER
12546           && ((ffebld_size_known (ffebld_left (expr))
12547                == FFETARGET_charactersizeNONE)
12548               || (ffebld_size_known (ffebld_left (expr)) >= sz)))
12549         tempvar = ffecom_make_tempvar ("convert", char_type_node, sz, -1);
12550       break;
12551     }
12552
12553   if (tempvar)
12554     {
12555       ffebld_nonter_set_hook (expr, tempvar);
12556       current_binding_level->prep_state = 1;
12557     }
12558
12559   /* Prepare subexpressions for this expr.  */
12560
12561   switch (ffebld_op (expr))
12562     {
12563     case FFEBLD_opPERCENT_LOC:
12564       ffecom_prepare_ptr_to_expr (ffebld_left (expr));
12565       break;
12566
12567     case FFEBLD_opPERCENT_VAL:
12568     case FFEBLD_opPERCENT_REF:
12569       ffecom_prepare_expr (ffebld_left (expr));
12570       break;
12571
12572     case FFEBLD_opPERCENT_DESCR:
12573       ffecom_prepare_arg_ptr_to_expr (ffebld_left (expr));
12574       break;
12575
12576     case FFEBLD_opITEM:
12577       {
12578         ffebld item;
12579
12580         for (item = expr;
12581              item != NULL;
12582              item = ffebld_trail (item))
12583           if (ffebld_head (item) != NULL)
12584             ffecom_prepare_expr (ffebld_head (item));
12585       }
12586       break;
12587
12588     default:
12589       /* Need to handle character conversion specially.  */
12590       switch (ffebld_arity (expr))
12591         {
12592         case 2:
12593           ffecom_prepare_expr (ffebld_left (expr));
12594           ffecom_prepare_expr (ffebld_right (expr));
12595           break;
12596
12597         case 1:
12598           ffecom_prepare_expr (ffebld_left (expr));
12599           break;
12600
12601         default:
12602           break;
12603         }
12604     }
12605
12606   return;
12607 }
12608
12609 /* Prepare expression for reading and writing.
12610
12611    Like ffecom_prepare_expr, except for expressions to be evaluated
12612    via ffecom_expr_rw.  */
12613
12614 void
12615 ffecom_prepare_expr_rw (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 writing.
12626
12627    Like ffecom_prepare_expr, except for expressions to be evaluated
12628    via ffecom_expr_w.  */
12629
12630 void
12631 ffecom_prepare_expr_w (tree type, ffebld expr)
12632 {
12633   /* This is all we support for now.  */
12634   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
12635
12636   /* ~~For now, it seems to be the same thing.  */
12637   ffecom_prepare_expr (expr);
12638   return;
12639 }
12640
12641 /* Prepare expression for returning.
12642
12643    Like ffecom_prepare_expr, except for expressions to be evaluated
12644    via ffecom_return_expr.  */
12645
12646 void
12647 ffecom_prepare_return_expr (ffebld expr)
12648 {
12649   assert (current_binding_level->prep_state < 2);
12650
12651   if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE
12652       && ffecom_is_altreturning_
12653       && expr != NULL)
12654     ffecom_prepare_expr (expr);
12655 }
12656
12657 /* Prepare pointer to expression.
12658
12659    Like ffecom_prepare_expr, except for expressions to be evaluated
12660    via ffecom_ptr_to_expr.  */
12661
12662 void
12663 ffecom_prepare_ptr_to_expr (ffebld expr)
12664 {
12665   /* ~~For now, it seems to be the same thing.  */
12666   ffecom_prepare_expr (expr);
12667   return;
12668 }
12669
12670 /* Transform expression into constant pointer-to-expression tree.
12671
12672    If the expression can be transformed into a pointer-to-expression tree
12673    that is constant, that is done, and the tree returned.  Else NULL_TREE
12674    is returned.
12675
12676    That way, a caller can attempt to provide compile-time initialization
12677    of a variable and, if that fails, *then* choose to start a new block
12678    and resort to using temporaries, as appropriate.  */
12679
12680 tree
12681 ffecom_ptr_to_const_expr (ffebld expr)
12682 {
12683   if (! expr)
12684     return integer_zero_node;
12685
12686   if (ffebld_op (expr) == FFEBLD_opANY)
12687     return error_mark_node;
12688
12689   if (ffebld_arity (expr) == 0
12690       && (ffebld_op (expr) != FFEBLD_opSYMTER
12691           || ffebld_where (expr) == FFEINFO_whereCOMMON
12692           || ffebld_where (expr) == FFEINFO_whereGLOBAL
12693           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
12694     {
12695       tree t;
12696
12697       t = ffecom_ptr_to_expr (expr);
12698       assert (TREE_CONSTANT (t));
12699       return t;
12700     }
12701
12702   return NULL_TREE;
12703 }
12704
12705 /* ffecom_return_expr -- Returns return-value expr given alt return expr
12706
12707    tree rtn;  // NULL_TREE means use expand_null_return()
12708    ffebld expr;  // NULL if no alt return expr to RETURN stmt
12709    rtn = ffecom_return_expr(expr);
12710
12711    Based on the program unit type and other info (like return function
12712    type, return master function type when alternate ENTRY points,
12713    whether subroutine has any alternate RETURN points, etc), returns the
12714    appropriate expression to be returned to the caller, or NULL_TREE
12715    meaning no return value or the caller expects it to be returned somewhere
12716    else (which is handled by other parts of this module).  */
12717
12718 tree
12719 ffecom_return_expr (ffebld expr)
12720 {
12721   tree rtn;
12722
12723   switch (ffecom_primary_entry_kind_)
12724     {
12725     case FFEINFO_kindPROGRAM:
12726     case FFEINFO_kindBLOCKDATA:
12727       rtn = NULL_TREE;
12728       break;
12729
12730     case FFEINFO_kindSUBROUTINE:
12731       if (!ffecom_is_altreturning_)
12732         rtn = NULL_TREE;        /* No alt returns, never an expr. */
12733       else if (expr == NULL)
12734         rtn = integer_zero_node;
12735       else
12736         rtn = ffecom_expr (expr);
12737       break;
12738
12739     case FFEINFO_kindFUNCTION:
12740       if ((ffecom_multi_retval_ != NULL_TREE)
12741           || (ffesymbol_basictype (ffecom_primary_entry_)
12742               == FFEINFO_basictypeCHARACTER)
12743           || ((ffesymbol_basictype (ffecom_primary_entry_)
12744                == FFEINFO_basictypeCOMPLEX)
12745               && (ffecom_num_entrypoints_ == 0)
12746               && ffesymbol_is_f2c (ffecom_primary_entry_)))
12747         {                       /* Value is returned by direct assignment
12748                                    into (implicit) dummy. */
12749           rtn = NULL_TREE;
12750           break;
12751         }
12752       rtn = ffecom_func_result_;
12753 #if 0
12754       /* Spurious error if RETURN happens before first reference!  So elide
12755          this code.  In particular, for debugging registry, rtn should always
12756          be non-null after all, but TREE_USED won't be set until we encounter
12757          a reference in the code.  Perfectly okay (but weird) code that,
12758          e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in
12759          this diagnostic for no reason.  Have people use -O -Wuninitialized
12760          and leave it to the back end to find obviously weird cases.  */
12761
12762       /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid
12763          situation; if the return value has never been referenced, it won't
12764          have a tree under 2pass mode. */
12765       if ((rtn == NULL_TREE)
12766           || !TREE_USED (rtn))
12767         {
12768           ffebad_start (FFEBAD_RETURN_VALUE_UNSET);
12769           ffebad_here (0, ffesymbol_where_line (ffecom_primary_entry_),
12770                        ffesymbol_where_column (ffecom_primary_entry_));
12771           ffebad_string (ffesymbol_text (ffesymbol_funcresult
12772                                          (ffecom_primary_entry_)));
12773           ffebad_finish ();
12774         }
12775 #endif
12776       break;
12777
12778     default:
12779       assert ("bad unit kind" == NULL);
12780     case FFEINFO_kindANY:
12781       rtn = error_mark_node;
12782       break;
12783     }
12784
12785   return rtn;
12786 }
12787
12788 /* Do save_expr only if tree is not error_mark_node.  */
12789
12790 tree
12791 ffecom_save_tree (tree t)
12792 {
12793   return save_expr (t);
12794 }
12795
12796 /* Start a compound statement (block).  */
12797
12798 void
12799 ffecom_start_compstmt (void)
12800 {
12801   bison_rule_pushlevel_ ();
12802 }
12803
12804 /* Public entry point for front end to access start_decl.  */
12805
12806 tree
12807 ffecom_start_decl (tree decl, bool is_initialized)
12808 {
12809   DECL_INITIAL (decl) = is_initialized ? error_mark_node : NULL_TREE;
12810   return start_decl (decl, FALSE);
12811 }
12812
12813 /* ffecom_sym_commit -- Symbol's state being committed to reality
12814
12815    ffesymbol s;
12816    ffecom_sym_commit(s);
12817
12818    Does whatever the backend needs when a symbol is committed after having
12819    been backtrackable for a period of time.  */
12820
12821 void
12822 ffecom_sym_commit (ffesymbol s UNUSED)
12823 {
12824   assert (!ffesymbol_retractable ());
12825 }
12826
12827 /* ffecom_sym_end_transition -- Perform end transition on all symbols
12828
12829    ffecom_sym_end_transition();
12830
12831    Does backend-specific stuff and also calls ffest_sym_end_transition
12832    to do the necessary FFE stuff.
12833
12834    Backtracking is never enabled when this fn is called, so don't worry
12835    about it.  */
12836
12837 ffesymbol
12838 ffecom_sym_end_transition (ffesymbol s)
12839 {
12840   ffestorag st;
12841
12842   assert (!ffesymbol_retractable ());
12843
12844   s = ffest_sym_end_transition (s);
12845
12846   if ((ffesymbol_kind (s) == FFEINFO_kindBLOCKDATA)
12847       && (ffesymbol_where (s) == FFEINFO_whereGLOBAL))
12848     {
12849       ffecom_list_blockdata_
12850         = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
12851                                               FFEINTRIN_specNONE,
12852                                               FFEINTRIN_impNONE),
12853                            ffecom_list_blockdata_);
12854     }
12855
12856   /* This is where we finally notice that a symbol has partial initialization
12857      and finalize it. */
12858
12859   if (ffesymbol_accretion (s) != NULL)
12860     {
12861       assert (ffesymbol_init (s) == NULL);
12862       ffecom_notify_init_symbol (s);
12863     }
12864   else if (((st = ffesymbol_storage (s)) != NULL)
12865            && ((st = ffestorag_parent (st)) != NULL)
12866            && (ffestorag_accretion (st) != NULL))
12867     {
12868       assert (ffestorag_init (st) == NULL);
12869       ffecom_notify_init_storage (st);
12870     }
12871
12872   if ((ffesymbol_kind (s) == FFEINFO_kindCOMMON)
12873       && (ffesymbol_where (s) == FFEINFO_whereLOCAL)
12874       && (ffesymbol_storage (s) != NULL))
12875     {
12876       ffecom_list_common_
12877         = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
12878                                               FFEINTRIN_specNONE,
12879                                               FFEINTRIN_impNONE),
12880                            ffecom_list_common_);
12881     }
12882
12883   return s;
12884 }
12885
12886 /* ffecom_sym_exec_transition -- Perform exec transition on all symbols
12887
12888    ffecom_sym_exec_transition();
12889
12890    Does backend-specific stuff and also calls ffest_sym_exec_transition
12891    to do the necessary FFE stuff.
12892
12893    See the long-winded description in ffecom_sym_learned for info
12894    on handling the situation where backtracking is inhibited.  */
12895
12896 ffesymbol
12897 ffecom_sym_exec_transition (ffesymbol s)
12898 {
12899   s = ffest_sym_exec_transition (s);
12900
12901   return s;
12902 }
12903
12904 /* ffecom_sym_learned -- Initial or more info gained on symbol after exec
12905
12906    ffesymbol s;
12907    s = ffecom_sym_learned(s);
12908
12909    Called when a new symbol is seen after the exec transition or when more
12910    info (perhaps) is gained for an UNCERTAIN symbol.  The symbol state when
12911    it arrives here is that all its latest info is updated already, so its
12912    state may be UNCERTAIN or UNDERSTOOD, it might already have the hook
12913    field filled in if its gone through here or exec_transition first, and
12914    so on.
12915
12916    The backend probably wants to check ffesymbol_retractable() to see if
12917    backtracking is in effect.  If so, the FFE's changes to the symbol may
12918    be retracted (undone) or committed (ratified), at which time the
12919    appropriate ffecom_sym_retract or _commit function will be called
12920    for that function.
12921
12922    If the backend has its own backtracking mechanism, great, use it so that
12923    committal is a simple operation.  Though it doesn't make much difference,
12924    I suppose: the reason for tentative symbol evolution in the FFE is to
12925    enable error detection in weird incorrect statements early and to disable
12926    incorrect error detection on a correct statement.  The backend is not
12927    likely to introduce any information that'll get involved in these
12928    considerations, so it is probably just fine that the implementation
12929    model for this fn and for _exec_transition is to not do anything
12930    (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE
12931    and instead wait until ffecom_sym_commit is called (which it never
12932    will be as long as we're using ambiguity-detecting statement analysis in
12933    the FFE, which we are initially to shake out the code, but don't depend
12934    on this), otherwise go ahead and do whatever is needed.
12935
12936    In essence, then, when this fn and _exec_transition get called while
12937    backtracking is enabled, a general mechanism would be to flag which (or
12938    both) of these were called (and in what order? neat question as to what
12939    might happen that I'm too lame to think through right now) and then when
12940    _commit is called reproduce the original calling sequence, if any, for
12941    the two fns (at which point backtracking will, of course, be disabled).  */
12942
12943 ffesymbol
12944 ffecom_sym_learned (ffesymbol s)
12945 {
12946   ffestorag_exec_layout (s);
12947
12948   return s;
12949 }
12950
12951 /* ffecom_sym_retract -- Symbol's state being retracted from reality
12952
12953    ffesymbol s;
12954    ffecom_sym_retract(s);
12955
12956    Does whatever the backend needs when a symbol is retracted after having
12957    been backtrackable for a period of time.  */
12958
12959 void
12960 ffecom_sym_retract (ffesymbol s UNUSED)
12961 {
12962   assert (!ffesymbol_retractable ());
12963
12964 #if 0                           /* GCC doesn't commit any backtrackable sins,
12965                                    so nothing needed here. */
12966   switch (ffesymbol_hook (s).state)
12967     {
12968     case 0:                     /* nothing happened yet. */
12969       break;
12970
12971     case 1:                     /* exec transition happened. */
12972       break;
12973
12974     case 2:                     /* learned happened. */
12975       break;
12976
12977     case 3:                     /* learned then exec. */
12978       break;
12979
12980     case 4:                     /* exec then learned. */
12981       break;
12982
12983     default:
12984       assert ("bad hook state" == NULL);
12985       break;
12986     }
12987 #endif
12988 }
12989
12990 /* Create temporary gcc label.  */
12991
12992 tree
12993 ffecom_temp_label ()
12994 {
12995   tree glabel;
12996   static int mynumber = 0;
12997
12998   glabel = build_decl (LABEL_DECL,
12999                        ffecom_get_invented_identifier ("__g77_label_%d",
13000                                                        mynumber++),
13001                        void_type_node);
13002   DECL_CONTEXT (glabel) = current_function_decl;
13003   DECL_MODE (glabel) = VOIDmode;
13004
13005   return glabel;
13006 }
13007
13008 /* Return an expression that is usable as an arg in a conditional context
13009    (IF, DO WHILE, .NOT., and so on).
13010
13011    Use the one provided for the back end as of >2.6.0.  */
13012
13013 tree
13014 ffecom_truth_value (tree expr)
13015 {
13016   return ffe_truthvalue_conversion (expr);
13017 }
13018
13019 /* Return the inversion of a truth value (the inversion of what
13020    ffecom_truth_value builds).
13021
13022    Apparently invert_truthvalue, which is properly in the back end, is
13023    enough for now, so just use it.  */
13024
13025 tree
13026 ffecom_truth_value_invert (tree expr)
13027 {
13028   return invert_truthvalue (ffecom_truth_value (expr));
13029 }
13030
13031 /* Return the tree that is the type of the expression, as would be
13032    returned in TREE_TYPE(ffecom_expr(expr)), without otherwise
13033    transforming the expression, generating temporaries, etc.  */
13034
13035 tree
13036 ffecom_type_expr (ffebld expr)
13037 {
13038   ffeinfoBasictype bt;
13039   ffeinfoKindtype kt;
13040   tree tree_type;
13041
13042   assert (expr != NULL);
13043
13044   bt = ffeinfo_basictype (ffebld_info (expr));
13045   kt = ffeinfo_kindtype (ffebld_info (expr));
13046   tree_type = ffecom_tree_type[bt][kt];
13047
13048   switch (ffebld_op (expr))
13049     {
13050     case FFEBLD_opCONTER:
13051     case FFEBLD_opSYMTER:
13052     case FFEBLD_opARRAYREF:
13053     case FFEBLD_opUPLUS:
13054     case FFEBLD_opPAREN:
13055     case FFEBLD_opUMINUS:
13056     case FFEBLD_opADD:
13057     case FFEBLD_opSUBTRACT:
13058     case FFEBLD_opMULTIPLY:
13059     case FFEBLD_opDIVIDE:
13060     case FFEBLD_opPOWER:
13061     case FFEBLD_opNOT:
13062     case FFEBLD_opFUNCREF:
13063     case FFEBLD_opSUBRREF:
13064     case FFEBLD_opAND:
13065     case FFEBLD_opOR:
13066     case FFEBLD_opXOR:
13067     case FFEBLD_opNEQV:
13068     case FFEBLD_opEQV:
13069     case FFEBLD_opCONVERT:
13070     case FFEBLD_opLT:
13071     case FFEBLD_opLE:
13072     case FFEBLD_opEQ:
13073     case FFEBLD_opNE:
13074     case FFEBLD_opGT:
13075     case FFEBLD_opGE:
13076     case FFEBLD_opPERCENT_LOC:
13077       return tree_type;
13078
13079     case FFEBLD_opACCTER:
13080     case FFEBLD_opARRTER:
13081     case FFEBLD_opITEM:
13082     case FFEBLD_opSTAR:
13083     case FFEBLD_opBOUNDS:
13084     case FFEBLD_opREPEAT:
13085     case FFEBLD_opLABTER:
13086     case FFEBLD_opLABTOK:
13087     case FFEBLD_opIMPDO:
13088     case FFEBLD_opCONCATENATE:
13089     case FFEBLD_opSUBSTR:
13090     default:
13091       assert ("bad op for ffecom_type_expr" == NULL);
13092       /* Fall through. */
13093     case FFEBLD_opANY:
13094       return error_mark_node;
13095     }
13096 }
13097
13098 /* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points
13099
13100    If the PARM_DECL already exists, return it, else create it.  It's an
13101    integer_type_node argument for the master function that implements a
13102    subroutine or function with more than one entrypoint and is bound at
13103    run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for
13104    first ENTRY statement, and so on).  */
13105
13106 tree
13107 ffecom_which_entrypoint_decl ()
13108 {
13109   assert (ffecom_which_entrypoint_decl_ != NULL_TREE);
13110
13111   return ffecom_which_entrypoint_decl_;
13112 }
13113 \f
13114 /* The following sections consists of private and public functions
13115    that have the same names and perform roughly the same functions
13116    as counterparts in the C front end.  Changes in the C front end
13117    might affect how things should be done here.  Only functions
13118    needed by the back end should be public here; the rest should
13119    be private (static in the C sense).  Functions needed by other
13120    g77 front-end modules should be accessed by them via public
13121    ffecom_* names, which should themselves call private versions
13122    in this section so the private versions are easy to recognize
13123    when upgrading to a new gcc and finding interesting changes
13124    in the front end.
13125
13126    Functions named after rule "foo:" in c-parse.y are named
13127    "bison_rule_foo_" so they are easy to find.  */
13128
13129 static void
13130 bison_rule_pushlevel_ ()
13131 {
13132   emit_line_note (input_filename, lineno);
13133   pushlevel (0);
13134   clear_last_expr ();
13135   expand_start_bindings (0);
13136 }
13137
13138 static tree
13139 bison_rule_compstmt_ ()
13140 {
13141   tree t;
13142   int keep = kept_level_p ();
13143
13144   /* Make the temps go away.  */
13145   if (! keep)
13146     current_binding_level->names = NULL_TREE;
13147
13148   emit_line_note (input_filename, lineno);
13149   expand_end_bindings (getdecls (), keep, 0);
13150   t = poplevel (keep, 1, 0);
13151
13152   return t;
13153 }
13154
13155 /* Return a definition for a builtin function named NAME and whose data type
13156    is TYPE.  TYPE should be a function type with argument types.
13157    FUNCTION_CODE tells later passes how to compile calls to this function.
13158    See tree.h for its possible values.
13159
13160    If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
13161    the name to be called if we can't opencode the function.  */
13162
13163 tree
13164 builtin_function (const char *name, tree type, int function_code,
13165                   enum built_in_class class,
13166                   const char *library_name)
13167 {
13168   tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type);
13169   DECL_EXTERNAL (decl) = 1;
13170   TREE_PUBLIC (decl) = 1;
13171   if (library_name)
13172     SET_DECL_ASSEMBLER_NAME (decl, get_identifier (library_name));
13173   make_decl_rtl (decl, NULL);
13174   pushdecl (decl);
13175   DECL_BUILT_IN_CLASS (decl) = class;
13176   DECL_FUNCTION_CODE (decl) = function_code;
13177
13178   return decl;
13179 }
13180
13181 /* Handle when a new declaration NEWDECL
13182    has the same name as an old one OLDDECL
13183    in the same binding contour.
13184    Prints an error message if appropriate.
13185
13186    If safely possible, alter OLDDECL to look like NEWDECL, and return 1.
13187    Otherwise, return 0.  */
13188
13189 static int
13190 duplicate_decls (tree newdecl, tree olddecl)
13191 {
13192   int types_match = 1;
13193   int new_is_definition = (TREE_CODE (newdecl) == FUNCTION_DECL
13194                            && DECL_INITIAL (newdecl) != 0);
13195   tree oldtype = TREE_TYPE (olddecl);
13196   tree newtype = TREE_TYPE (newdecl);
13197
13198   if (olddecl == newdecl)
13199     return 1;
13200
13201   if (TREE_CODE (newtype) == ERROR_MARK
13202       || TREE_CODE (oldtype) == ERROR_MARK)
13203     types_match = 0;
13204
13205   /* New decl is completely inconsistent with the old one =>
13206      tell caller to replace the old one.
13207      This is always an error except in the case of shadowing a builtin.  */
13208   if (TREE_CODE (olddecl) != TREE_CODE (newdecl))
13209     return 0;
13210
13211   /* For real parm decl following a forward decl,
13212      return 1 so old decl will be reused.  */
13213   if (types_match && TREE_CODE (newdecl) == PARM_DECL
13214       && TREE_ASM_WRITTEN (olddecl) && ! TREE_ASM_WRITTEN (newdecl))
13215     return 1;
13216
13217   /* The new declaration is the same kind of object as the old one.
13218      The declarations may partially match.  Print warnings if they don't
13219      match enough.  Ultimately, copy most of the information from the new
13220      decl to the old one, and keep using the old one.  */
13221
13222   if (TREE_CODE (olddecl) == FUNCTION_DECL
13223       && DECL_BUILT_IN (olddecl))
13224     {
13225       /* A function declaration for a built-in function.  */
13226       if (!TREE_PUBLIC (newdecl))
13227         return 0;
13228       else if (!types_match)
13229         {
13230           /* Accept the return type of the new declaration if same modes.  */
13231           tree oldreturntype = TREE_TYPE (TREE_TYPE (olddecl));
13232           tree newreturntype = TREE_TYPE (TREE_TYPE (newdecl));
13233
13234           if (TYPE_MODE (oldreturntype) == TYPE_MODE (newreturntype))
13235             {
13236               /* Function types may be shared, so we can't just modify
13237                  the return type of olddecl's function type.  */
13238               tree newtype
13239                 = build_function_type (newreturntype,
13240                                        TYPE_ARG_TYPES (TREE_TYPE (olddecl)));
13241
13242               types_match = 1;
13243               if (types_match)
13244                 TREE_TYPE (olddecl) = newtype;
13245             }
13246         }
13247       if (!types_match)
13248         return 0;
13249     }
13250   else if (TREE_CODE (olddecl) == FUNCTION_DECL
13251            && DECL_SOURCE_LINE (olddecl) == 0)
13252     {
13253       /* A function declaration for a predeclared function
13254          that isn't actually built in.  */
13255       if (!TREE_PUBLIC (newdecl))
13256         return 0;
13257       else if (!types_match)
13258         {
13259           /* If the types don't match, preserve volatility indication.
13260              Later on, we will discard everything else about the
13261              default declaration.  */
13262           TREE_THIS_VOLATILE (newdecl) |= TREE_THIS_VOLATILE (olddecl);
13263         }
13264     }
13265
13266   /* Copy all the DECL_... slots specified in the new decl
13267      except for any that we copy here from the old type.
13268
13269      Past this point, we don't change OLDTYPE and NEWTYPE
13270      even if we change the types of NEWDECL and OLDDECL.  */
13271
13272   if (types_match)
13273     {
13274       /* Merge the data types specified in the two decls.  */
13275       if (TREE_CODE (newdecl) != FUNCTION_DECL || !DECL_BUILT_IN (olddecl))
13276         TREE_TYPE (newdecl)
13277           = TREE_TYPE (olddecl)
13278             = TREE_TYPE (newdecl);
13279
13280       /* Lay the type out, unless already done.  */
13281       if (oldtype != TREE_TYPE (newdecl))
13282         {
13283           if (TREE_TYPE (newdecl) != error_mark_node)
13284             layout_type (TREE_TYPE (newdecl));
13285           if (TREE_CODE (newdecl) != FUNCTION_DECL
13286               && TREE_CODE (newdecl) != TYPE_DECL
13287               && TREE_CODE (newdecl) != CONST_DECL)
13288             layout_decl (newdecl, 0);
13289         }
13290       else
13291         {
13292           /* Since the type is OLDDECL's, make OLDDECL's size go with.  */
13293           DECL_SIZE (newdecl) = DECL_SIZE (olddecl);
13294           DECL_SIZE_UNIT (newdecl) = DECL_SIZE_UNIT (olddecl);
13295           if (TREE_CODE (olddecl) != FUNCTION_DECL)
13296             if (DECL_ALIGN (olddecl) > DECL_ALIGN (newdecl))
13297               {
13298                 DECL_ALIGN (newdecl) = DECL_ALIGN (olddecl);
13299                 DECL_USER_ALIGN (newdecl) |= DECL_USER_ALIGN (olddecl);
13300               }
13301         }
13302
13303       /* Keep the old rtl since we can safely use it.  */
13304       COPY_DECL_RTL (olddecl, newdecl);
13305
13306       /* Merge the type qualifiers.  */
13307       if (DECL_BUILT_IN_NONANSI (olddecl) && TREE_THIS_VOLATILE (olddecl)
13308           && !TREE_THIS_VOLATILE (newdecl))
13309         TREE_THIS_VOLATILE (olddecl) = 0;
13310       if (TREE_READONLY (newdecl))
13311         TREE_READONLY (olddecl) = 1;
13312       if (TREE_THIS_VOLATILE (newdecl))
13313         {
13314           TREE_THIS_VOLATILE (olddecl) = 1;
13315           if (TREE_CODE (newdecl) == VAR_DECL)
13316             make_var_volatile (newdecl);
13317         }
13318
13319       /* Keep source location of definition rather than declaration.
13320          Likewise, keep decl at outer scope.  */
13321       if ((DECL_INITIAL (newdecl) == 0 && DECL_INITIAL (olddecl) != 0)
13322           || (DECL_CONTEXT (newdecl) != 0 && DECL_CONTEXT (olddecl) == 0))
13323         {
13324           DECL_SOURCE_LINE (newdecl) = DECL_SOURCE_LINE (olddecl);
13325           DECL_SOURCE_FILE (newdecl) = DECL_SOURCE_FILE (olddecl);
13326
13327           if (DECL_CONTEXT (olddecl) == 0
13328               && TREE_CODE (newdecl) != FUNCTION_DECL)
13329             DECL_CONTEXT (newdecl) = 0;
13330         }
13331
13332       /* Merge the unused-warning information.  */
13333       if (DECL_IN_SYSTEM_HEADER (olddecl))
13334         DECL_IN_SYSTEM_HEADER (newdecl) = 1;
13335       else if (DECL_IN_SYSTEM_HEADER (newdecl))
13336         DECL_IN_SYSTEM_HEADER (olddecl) = 1;
13337
13338       /* Merge the initialization information.  */
13339       if (DECL_INITIAL (newdecl) == 0)
13340         DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13341
13342       /* Merge the section attribute.
13343          We want to issue an error if the sections conflict but that must be
13344          done later in decl_attributes since we are called before attributes
13345          are assigned.  */
13346       if (DECL_SECTION_NAME (newdecl) == NULL_TREE)
13347         DECL_SECTION_NAME (newdecl) = DECL_SECTION_NAME (olddecl);
13348
13349       if (TREE_CODE (newdecl) == FUNCTION_DECL)
13350         {
13351           DECL_STATIC_CONSTRUCTOR(newdecl) |= DECL_STATIC_CONSTRUCTOR(olddecl);
13352           DECL_STATIC_DESTRUCTOR (newdecl) |= DECL_STATIC_DESTRUCTOR (olddecl);
13353         }
13354     }
13355   /* If cannot merge, then use the new type and qualifiers,
13356      and don't preserve the old rtl.  */
13357   else
13358     {
13359       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13360       TREE_READONLY (olddecl) = TREE_READONLY (newdecl);
13361       TREE_THIS_VOLATILE (olddecl) = TREE_THIS_VOLATILE (newdecl);
13362       TREE_SIDE_EFFECTS (olddecl) = TREE_SIDE_EFFECTS (newdecl);
13363     }
13364
13365   /* Merge the storage class information.  */
13366   /* For functions, static overrides non-static.  */
13367   if (TREE_CODE (newdecl) == FUNCTION_DECL)
13368     {
13369       TREE_PUBLIC (newdecl) &= TREE_PUBLIC (olddecl);
13370       /* This is since we don't automatically
13371          copy the attributes of NEWDECL into OLDDECL.  */
13372       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13373       /* If this clears `static', clear it in the identifier too.  */
13374       if (! TREE_PUBLIC (olddecl))
13375         TREE_PUBLIC (DECL_NAME (olddecl)) = 0;
13376     }
13377   if (DECL_EXTERNAL (newdecl))
13378     {
13379       TREE_STATIC (newdecl) = TREE_STATIC (olddecl);
13380       DECL_EXTERNAL (newdecl) = DECL_EXTERNAL (olddecl);
13381       /* An extern decl does not override previous storage class.  */
13382       TREE_PUBLIC (newdecl) = TREE_PUBLIC (olddecl);
13383     }
13384   else
13385     {
13386       TREE_STATIC (olddecl) = TREE_STATIC (newdecl);
13387       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13388     }
13389
13390   /* If either decl says `inline', this fn is inline,
13391      unless its definition was passed already.  */
13392   if (DECL_INLINE (newdecl) && DECL_INITIAL (olddecl) == 0)
13393     DECL_INLINE (olddecl) = 1;
13394   DECL_INLINE (newdecl) = DECL_INLINE (olddecl);
13395
13396   /* Get rid of any built-in function if new arg types don't match it
13397      or if we have a function definition.  */
13398   if (TREE_CODE (newdecl) == FUNCTION_DECL
13399       && DECL_BUILT_IN (olddecl)
13400       && (!types_match || new_is_definition))
13401     {
13402       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13403       DECL_BUILT_IN_CLASS (olddecl) = NOT_BUILT_IN;
13404     }
13405
13406   /* If redeclaring a builtin function, and not a definition,
13407      it stays built in.
13408      Also preserve various other info from the definition.  */
13409   if (TREE_CODE (newdecl) == FUNCTION_DECL && !new_is_definition)
13410     {
13411       if (DECL_BUILT_IN (olddecl))
13412         {
13413           DECL_BUILT_IN_CLASS (newdecl) = DECL_BUILT_IN_CLASS (olddecl);
13414           DECL_FUNCTION_CODE (newdecl) = DECL_FUNCTION_CODE (olddecl);
13415         }
13416
13417       DECL_RESULT (newdecl) = DECL_RESULT (olddecl);
13418       DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13419       DECL_SAVED_INSNS (newdecl) = DECL_SAVED_INSNS (olddecl);
13420       DECL_ARGUMENTS (newdecl) = DECL_ARGUMENTS (olddecl);
13421     }
13422
13423   /* Copy most of the decl-specific fields of NEWDECL into OLDDECL.
13424      But preserve olddecl's DECL_UID.  */
13425   {
13426     register unsigned olddecl_uid = DECL_UID (olddecl);
13427
13428     memcpy ((char *) olddecl + sizeof (struct tree_common),
13429             (char *) newdecl + sizeof (struct tree_common),
13430             sizeof (struct tree_decl) - sizeof (struct tree_common));
13431     DECL_UID (olddecl) = olddecl_uid;
13432   }
13433
13434   return 1;
13435 }
13436
13437 /* Finish processing of a declaration;
13438    install its initial value.
13439    If the length of an array type is not known before,
13440    it must be determined now, from the initial value, or it is an error.  */
13441
13442 static void
13443 finish_decl (tree decl, tree init, bool is_top_level)
13444 {
13445   register tree type = TREE_TYPE (decl);
13446   int was_incomplete = (DECL_SIZE (decl) == 0);
13447   bool at_top_level = (current_binding_level == global_binding_level);
13448   bool top_level = is_top_level || at_top_level;
13449
13450   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13451      level anyway.  */
13452   assert (!is_top_level || !at_top_level);
13453
13454   if (TREE_CODE (decl) == PARM_DECL)
13455     assert (init == NULL_TREE);
13456   /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it
13457      overlaps DECL_ARG_TYPE.  */
13458   else if (init == NULL_TREE)
13459     assert (DECL_INITIAL (decl) == NULL_TREE);
13460   else
13461     assert (DECL_INITIAL (decl) == error_mark_node);
13462
13463   if (init != NULL_TREE)
13464     {
13465       if (TREE_CODE (decl) != TYPE_DECL)
13466         DECL_INITIAL (decl) = init;
13467       else
13468         {
13469           /* typedef foo = bar; store the type of bar as the type of foo.  */
13470           TREE_TYPE (decl) = TREE_TYPE (init);
13471           DECL_INITIAL (decl) = init = 0;
13472         }
13473     }
13474
13475   /* Deduce size of array from initialization, if not already known */
13476
13477   if (TREE_CODE (type) == ARRAY_TYPE
13478       && TYPE_DOMAIN (type) == 0
13479       && TREE_CODE (decl) != TYPE_DECL)
13480     {
13481       assert (top_level);
13482       assert (was_incomplete);
13483
13484       layout_decl (decl, 0);
13485     }
13486
13487   if (TREE_CODE (decl) == VAR_DECL)
13488     {
13489       if (DECL_SIZE (decl) == NULL_TREE
13490           && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
13491         layout_decl (decl, 0);
13492
13493       if (DECL_SIZE (decl) == NULL_TREE
13494           && (TREE_STATIC (decl)
13495               ?
13496       /* A static variable with an incomplete type is an error if it is
13497          initialized. Also if it is not file scope. Otherwise, let it
13498          through, but if it is not `extern' then it may cause an error
13499          message later.  */
13500               (DECL_INITIAL (decl) != 0 || DECL_CONTEXT (decl) != 0)
13501               :
13502       /* An automatic variable with an incomplete type is an error.  */
13503               !DECL_EXTERNAL (decl)))
13504         {
13505           assert ("storage size not known" == NULL);
13506           abort ();
13507         }
13508
13509       if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl))
13510           && (DECL_SIZE (decl) != 0)
13511           && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST))
13512         {
13513           assert ("storage size not constant" == NULL);
13514           abort ();
13515         }
13516     }
13517
13518   /* Output the assembler code and/or RTL code for variables and functions,
13519      unless the type is an undefined structure or union. If not, it will get
13520      done when the type is completed.  */
13521
13522   if (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == FUNCTION_DECL)
13523     {
13524       rest_of_decl_compilation (decl, NULL,
13525                                 DECL_CONTEXT (decl) == 0,
13526                                 0);
13527
13528       if (DECL_CONTEXT (decl) != 0)
13529         {
13530           /* Recompute the RTL of a local array now if it used to be an
13531              incomplete type.  */
13532           if (was_incomplete
13533               && !TREE_STATIC (decl) && !DECL_EXTERNAL (decl))
13534             {
13535               /* If we used it already as memory, it must stay in memory.  */
13536               TREE_ADDRESSABLE (decl) = TREE_USED (decl);
13537               /* If it's still incomplete now, no init will save it.  */
13538               if (DECL_SIZE (decl) == 0)
13539                 DECL_INITIAL (decl) = 0;
13540               expand_decl (decl);
13541             }
13542           /* Compute and store the initial value.  */
13543           if (TREE_CODE (decl) != FUNCTION_DECL)
13544             expand_decl_init (decl);
13545         }
13546     }
13547   else if (TREE_CODE (decl) == TYPE_DECL)
13548     {
13549       rest_of_decl_compilation (decl, NULL,
13550                                 DECL_CONTEXT (decl) == 0,
13551                                 0);
13552     }
13553
13554   /* At the end of a declaration, throw away any variable type sizes of types
13555      defined inside that declaration.  There is no use computing them in the
13556      following function definition.  */
13557   if (current_binding_level == global_binding_level)
13558     get_pending_sizes ();
13559 }
13560
13561 /* Finish up a function declaration and compile that function
13562    all the way to assembler language output.  The free the storage
13563    for the function definition.
13564
13565    This is called after parsing the body of the function definition.
13566
13567    NESTED is nonzero if the function being finished is nested in another.  */
13568
13569 static void
13570 finish_function (int nested)
13571 {
13572   register tree fndecl = current_function_decl;
13573
13574   assert (fndecl != NULL_TREE);
13575   if (TREE_CODE (fndecl) != ERROR_MARK)
13576     {
13577       if (nested)
13578         assert (DECL_CONTEXT (fndecl) != NULL_TREE);
13579       else
13580         assert (DECL_CONTEXT (fndecl) == NULL_TREE);
13581     }
13582
13583 /*  TREE_READONLY (fndecl) = 1;
13584     This caused &foo to be of type ptr-to-const-function
13585     which then got a warning when stored in a ptr-to-function variable.  */
13586
13587   poplevel (1, 0, 1);
13588
13589   if (TREE_CODE (fndecl) != ERROR_MARK)
13590     {
13591       BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
13592
13593       /* Must mark the RESULT_DECL as being in this function.  */
13594
13595       DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl;
13596
13597       /* Obey `register' declarations if `setjmp' is called in this fn.  */
13598       /* Generate rtl for function exit.  */
13599       expand_function_end (input_filename, lineno, 0);
13600
13601       /* If this is a nested function, protect the local variables in the stack
13602          above us from being collected while we're compiling this function.  */
13603       if (nested)
13604         ggc_push_context ();
13605
13606       /* Run the optimizers and output the assembler code for this function.  */
13607       rest_of_compilation (fndecl);
13608
13609       /* Undo the GC context switch.  */
13610       if (nested)
13611         ggc_pop_context ();
13612     }
13613
13614   if (TREE_CODE (fndecl) != ERROR_MARK
13615       && !nested
13616       && DECL_SAVED_INSNS (fndecl) == 0)
13617     {
13618       /* Stop pointing to the local nodes about to be freed.  */
13619       /* But DECL_INITIAL must remain nonzero so we know this was an actual
13620          function definition.  */
13621       /* For a nested function, this is done in pop_f_function_context.  */
13622       /* If rest_of_compilation set this to 0, leave it 0.  */
13623       if (DECL_INITIAL (fndecl) != 0)
13624         DECL_INITIAL (fndecl) = error_mark_node;
13625       DECL_ARGUMENTS (fndecl) = 0;
13626     }
13627
13628   if (!nested)
13629     {
13630       /* Let the error reporting routines know that we're outside a function.
13631          For a nested function, this value is used in pop_c_function_context
13632          and then reset via pop_function_context.  */
13633       ffecom_outer_function_decl_ = current_function_decl = NULL;
13634     }
13635 }
13636
13637 /* Plug-in replacement for identifying the name of a decl and, for a
13638    function, what we call it in diagnostics.  For now, "program unit"
13639    should suffice, since it's a bit of a hassle to figure out which
13640    of several kinds of things it is.  Note that it could conceivably
13641    be a statement function, which probably isn't really a program unit
13642    per se, but if that comes up, it should be easy to check (being a
13643    nested function and all).  */
13644
13645 static const char *
13646 ffe_printable_name (tree decl, int v)
13647 {
13648   /* Just to keep GCC quiet about the unused variable.
13649      In theory, differing values of V should produce different
13650      output.  */
13651   switch (v)
13652     {
13653     default:
13654       if (TREE_CODE (decl) == ERROR_MARK)
13655         return "erroneous code";
13656       return IDENTIFIER_POINTER (DECL_NAME (decl));
13657     }
13658 }
13659
13660 /* g77's function to print out name of current function that caused
13661    an error.  */
13662
13663 static void
13664 ffe_print_error_function (diagnostic_context *context __attribute__((unused)),
13665                           const char *file)
13666 {
13667   static ffeglobal last_g = NULL;
13668   static ffesymbol last_s = NULL;
13669   ffeglobal g;
13670   ffesymbol s;
13671   const char *kind;
13672
13673   if ((ffecom_primary_entry_ == NULL)
13674       || (ffesymbol_global (ffecom_primary_entry_) == NULL))
13675     {
13676       g = NULL;
13677       s = NULL;
13678       kind = NULL;
13679     }
13680   else
13681     {
13682       g = ffesymbol_global (ffecom_primary_entry_);
13683       if (ffecom_nested_entry_ == NULL)
13684         {
13685           s = ffecom_primary_entry_;
13686           kind = _(ffeinfo_kind_message (ffesymbol_kind (s)));
13687         }
13688       else
13689         {
13690           s = ffecom_nested_entry_;
13691           kind = _("In statement function");
13692         }
13693     }
13694
13695   if ((last_g != g) || (last_s != s))
13696     {
13697       if (file)
13698         fprintf (stderr, "%s: ", file);
13699
13700       if (s == NULL)
13701         fprintf (stderr, _("Outside of any program unit:\n"));
13702       else
13703         {
13704           const char *name = ffesymbol_text (s);
13705
13706           fprintf (stderr, "%s `%s':\n", kind, name);
13707         }
13708
13709       last_g = g;
13710       last_s = s;
13711     }
13712 }
13713
13714 /* Similar to `lookup_name' but look only at current binding level.  */
13715
13716 static tree
13717 lookup_name_current_level (tree name)
13718 {
13719   register tree t;
13720
13721   if (current_binding_level == global_binding_level)
13722     return IDENTIFIER_GLOBAL_VALUE (name);
13723
13724   if (IDENTIFIER_LOCAL_VALUE (name) == 0)
13725     return 0;
13726
13727   for (t = current_binding_level->names; t; t = TREE_CHAIN (t))
13728     if (DECL_NAME (t) == name)
13729       break;
13730
13731   return t;
13732 }
13733
13734 /* Create a new `struct binding_level'.  */
13735
13736 static struct binding_level *
13737 make_binding_level ()
13738 {
13739   /* NOSTRICT */
13740   return (struct binding_level *) xmalloc (sizeof (struct binding_level));
13741 }
13742
13743 /* Save and restore the variables in this file and elsewhere
13744    that keep track of the progress of compilation of the current function.
13745    Used for nested functions.  */
13746
13747 struct f_function
13748 {
13749   struct f_function *next;
13750   tree named_labels;
13751   tree shadowed_labels;
13752   struct binding_level *binding_level;
13753 };
13754
13755 struct f_function *f_function_chain;
13756
13757 /* Restore the variables used during compilation of a C function.  */
13758
13759 static void
13760 pop_f_function_context ()
13761 {
13762   struct f_function *p = f_function_chain;
13763   tree link;
13764
13765   /* Bring back all the labels that were shadowed.  */
13766   for (link = shadowed_labels; link; link = TREE_CHAIN (link))
13767     if (DECL_NAME (TREE_VALUE (link)) != 0)
13768       IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link)))
13769         = TREE_VALUE (link);
13770
13771   if (current_function_decl != error_mark_node
13772       && DECL_SAVED_INSNS (current_function_decl) == 0)
13773     {
13774       /* Stop pointing to the local nodes about to be freed.  */
13775       /* But DECL_INITIAL must remain nonzero so we know this was an actual
13776          function definition.  */
13777       DECL_INITIAL (current_function_decl) = error_mark_node;
13778       DECL_ARGUMENTS (current_function_decl) = 0;
13779     }
13780
13781   pop_function_context ();
13782
13783   f_function_chain = p->next;
13784
13785   named_labels = p->named_labels;
13786   shadowed_labels = p->shadowed_labels;
13787   current_binding_level = p->binding_level;
13788
13789   free (p);
13790 }
13791
13792 /* Save and reinitialize the variables
13793    used during compilation of a C function.  */
13794
13795 static void
13796 push_f_function_context ()
13797 {
13798   struct f_function *p
13799   = (struct f_function *) xmalloc (sizeof (struct f_function));
13800
13801   push_function_context ();
13802
13803   p->next = f_function_chain;
13804   f_function_chain = p;
13805
13806   p->named_labels = named_labels;
13807   p->shadowed_labels = shadowed_labels;
13808   p->binding_level = current_binding_level;
13809 }
13810
13811 static void
13812 push_parm_decl (tree parm)
13813 {
13814   int old_immediate_size_expand = immediate_size_expand;
13815
13816   /* Don't try computing parm sizes now -- wait till fn is called.  */
13817
13818   immediate_size_expand = 0;
13819
13820   /* Fill in arg stuff.  */
13821
13822   DECL_ARG_TYPE (parm) = TREE_TYPE (parm);
13823   DECL_ARG_TYPE_AS_WRITTEN (parm) = TREE_TYPE (parm);
13824   TREE_READONLY (parm) = 1;     /* All implementation args are read-only. */
13825
13826   parm = pushdecl (parm);
13827
13828   immediate_size_expand = old_immediate_size_expand;
13829
13830   finish_decl (parm, NULL_TREE, FALSE);
13831 }
13832
13833 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate.  */
13834
13835 static tree
13836 pushdecl_top_level (x)
13837      tree x;
13838 {
13839   register tree t;
13840   register struct binding_level *b = current_binding_level;
13841   register tree f = current_function_decl;
13842
13843   current_binding_level = global_binding_level;
13844   current_function_decl = NULL_TREE;
13845   t = pushdecl (x);
13846   current_binding_level = b;
13847   current_function_decl = f;
13848   return t;
13849 }
13850
13851 /* Store the list of declarations of the current level.
13852    This is done for the parameter declarations of a function being defined,
13853    after they are modified in the light of any missing parameters.  */
13854
13855 static tree
13856 storedecls (decls)
13857      tree decls;
13858 {
13859   return current_binding_level->names = decls;
13860 }
13861
13862 /* Store the parameter declarations into the current function declaration.
13863    This is called after parsing the parameter declarations, before
13864    digesting the body of the function.
13865
13866    For an old-style definition, modify the function's type
13867    to specify at least the number of arguments.  */
13868
13869 static void
13870 store_parm_decls (int is_main_program UNUSED)
13871 {
13872   register tree fndecl = current_function_decl;
13873
13874   if (fndecl == error_mark_node)
13875     return;
13876
13877   /* This is a chain of PARM_DECLs from old-style parm declarations.  */
13878   DECL_ARGUMENTS (fndecl) = storedecls (nreverse (getdecls ()));
13879
13880   /* Initialize the RTL code for the function.  */
13881
13882   init_function_start (fndecl, input_filename, lineno);
13883
13884   /* Set up parameters and prepare for return, for the function.  */
13885
13886   expand_function_start (fndecl, 0);
13887 }
13888
13889 static tree
13890 start_decl (tree decl, bool is_top_level)
13891 {
13892   register tree tem;
13893   bool at_top_level = (current_binding_level == global_binding_level);
13894   bool top_level = is_top_level || at_top_level;
13895
13896   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13897      level anyway.  */
13898   assert (!is_top_level || !at_top_level);
13899
13900   if (DECL_INITIAL (decl) != NULL_TREE)
13901     {
13902       assert (DECL_INITIAL (decl) == error_mark_node);
13903       assert (!DECL_EXTERNAL (decl));
13904     }
13905   else if (top_level)
13906     assert ((TREE_STATIC (decl) == 1) || DECL_EXTERNAL (decl) == 1);
13907
13908   /* For Fortran, we by default put things in .common when possible.  */
13909   DECL_COMMON (decl) = 1;
13910
13911   /* Add this decl to the current binding level. TEM may equal DECL or it may
13912      be a previous decl of the same name.  */
13913   if (is_top_level)
13914     tem = pushdecl_top_level (decl);
13915   else
13916     tem = pushdecl (decl);
13917
13918   /* For a local variable, define the RTL now.  */
13919   if (!top_level
13920   /* But not if this is a duplicate decl and we preserved the rtl from the
13921      previous one (which may or may not happen).  */
13922       && !DECL_RTL_SET_P (tem))
13923     {
13924       if (TYPE_SIZE (TREE_TYPE (tem)) != 0)
13925         expand_decl (tem);
13926       else if (TREE_CODE (TREE_TYPE (tem)) == ARRAY_TYPE
13927                && DECL_INITIAL (tem) != 0)
13928         expand_decl (tem);
13929     }
13930
13931   return tem;
13932 }
13933
13934 /* Create the FUNCTION_DECL for a function definition.
13935    DECLSPECS and DECLARATOR are the parts of the declaration;
13936    they describe the function's name and the type it returns,
13937    but twisted together in a fashion that parallels the syntax of C.
13938
13939    This function creates a binding context for the function body
13940    as well as setting up the FUNCTION_DECL in current_function_decl.
13941
13942    Returns 1 on success.  If the DECLARATOR is not suitable for a function
13943    (it defines a datum instead), we return 0, which tells
13944    ffe_parse_file to report a parse error.
13945
13946    NESTED is nonzero for a function nested within another function.  */
13947
13948 static void
13949 start_function (tree name, tree type, int nested, int public)
13950 {
13951   tree decl1;
13952   tree restype;
13953   int old_immediate_size_expand = immediate_size_expand;
13954
13955   named_labels = 0;
13956   shadowed_labels = 0;
13957
13958   /* Don't expand any sizes in the return type of the function.  */
13959   immediate_size_expand = 0;
13960
13961   if (nested)
13962     {
13963       assert (!public);
13964       assert (current_function_decl != NULL_TREE);
13965       assert (DECL_CONTEXT (current_function_decl) == NULL_TREE);
13966     }
13967   else
13968     {
13969       assert (current_function_decl == NULL_TREE);
13970     }
13971
13972   if (TREE_CODE (type) == ERROR_MARK)
13973     decl1 = current_function_decl = error_mark_node;
13974   else
13975     {
13976       decl1 = build_decl (FUNCTION_DECL,
13977                           name,
13978                           type);
13979       TREE_PUBLIC (decl1) = public ? 1 : 0;
13980       if (nested)
13981         DECL_INLINE (decl1) = 1;
13982       TREE_STATIC (decl1) = 1;
13983       DECL_EXTERNAL (decl1) = 0;
13984
13985       announce_function (decl1);
13986
13987       /* Make the init_value nonzero so pushdecl knows this is not tentative.
13988          error_mark_node is replaced below (in poplevel) with the BLOCK.  */
13989       DECL_INITIAL (decl1) = error_mark_node;
13990
13991       /* Record the decl so that the function name is defined. If we already have
13992          a decl for this name, and it is a FUNCTION_DECL, use the old decl.  */
13993
13994       current_function_decl = pushdecl (decl1);
13995     }
13996
13997   if (!nested)
13998     ffecom_outer_function_decl_ = current_function_decl;
13999
14000   pushlevel (0);
14001   current_binding_level->prep_state = 2;
14002
14003   if (TREE_CODE (current_function_decl) != ERROR_MARK)
14004     {
14005       make_decl_rtl (current_function_decl, NULL);
14006
14007       restype = TREE_TYPE (TREE_TYPE (current_function_decl));
14008       DECL_RESULT (current_function_decl)
14009         = build_decl (RESULT_DECL, NULL_TREE, restype);
14010     }
14011
14012   if (!nested && (TREE_CODE (current_function_decl) != ERROR_MARK))
14013     TREE_ADDRESSABLE (current_function_decl) = 1;
14014
14015   immediate_size_expand = old_immediate_size_expand;
14016 }
14017 \f
14018 /* Here are the public functions the GNU back end needs.  */
14019
14020 tree
14021 convert (type, expr)
14022      tree type, expr;
14023 {
14024   register tree e = expr;
14025   register enum tree_code code = TREE_CODE (type);
14026
14027   if (type == TREE_TYPE (e)
14028       || TREE_CODE (e) == ERROR_MARK)
14029     return e;
14030   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
14031     return fold (build1 (NOP_EXPR, type, e));
14032   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
14033       || code == ERROR_MARK)
14034     return error_mark_node;
14035   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
14036     {
14037       assert ("void value not ignored as it ought to be" == NULL);
14038       return error_mark_node;
14039     }
14040   if (code == VOID_TYPE)
14041     return build1 (CONVERT_EXPR, type, e);
14042   if ((code != RECORD_TYPE)
14043       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
14044     e = ffecom_1 (REALPART_EXPR, TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e))),
14045                   e);
14046   if (code == INTEGER_TYPE || code == ENUMERAL_TYPE)
14047     return fold (convert_to_integer (type, e));
14048   if (code == POINTER_TYPE)
14049     return fold (convert_to_pointer (type, e));
14050   if (code == REAL_TYPE)
14051     return fold (convert_to_real (type, e));
14052   if (code == COMPLEX_TYPE)
14053     return fold (convert_to_complex (type, e));
14054   if (code == RECORD_TYPE)
14055     return fold (ffecom_convert_to_complex_ (type, e));
14056
14057   assert ("conversion to non-scalar type requested" == NULL);
14058   return error_mark_node;
14059 }
14060
14061 /* Return the list of declarations of the current level.
14062    Note that this list is in reverse order unless/until
14063    you nreverse it; and when you do nreverse it, you must
14064    store the result back using `storedecls' or you will lose.  */
14065
14066 tree
14067 getdecls ()
14068 {
14069   return current_binding_level->names;
14070 }
14071
14072 /* Nonzero if we are currently in the global binding level.  */
14073
14074 int
14075 global_bindings_p ()
14076 {
14077   return current_binding_level == global_binding_level;
14078 }
14079
14080 /* Mark ARG for GC.  */
14081 static void
14082 mark_binding_level (void *arg)
14083 {
14084   struct binding_level *level = *(struct binding_level **) arg;
14085
14086   while (level)
14087     {
14088       ggc_mark_tree (level->names);
14089       ggc_mark_tree (level->blocks);
14090       ggc_mark_tree (level->this_block);
14091       level = level->level_chain;
14092     }
14093 }
14094
14095 static void
14096 ffecom_init_decl_processing ()
14097 {
14098   static tree *const tree_roots[] = {
14099     &current_function_decl,
14100     &string_type_node,
14101     &ffecom_tree_fun_type_void,
14102     &ffecom_integer_zero_node,
14103     &ffecom_integer_one_node,
14104     &ffecom_tree_subr_type,
14105     &ffecom_tree_ptr_to_subr_type,
14106     &ffecom_tree_blockdata_type,
14107     &ffecom_tree_xargc_,
14108     &ffecom_f2c_integer_type_node,
14109     &ffecom_f2c_ptr_to_integer_type_node,
14110     &ffecom_f2c_address_type_node,
14111     &ffecom_f2c_real_type_node,
14112     &ffecom_f2c_ptr_to_real_type_node,
14113     &ffecom_f2c_doublereal_type_node,
14114     &ffecom_f2c_complex_type_node,
14115     &ffecom_f2c_doublecomplex_type_node,
14116     &ffecom_f2c_longint_type_node,
14117     &ffecom_f2c_logical_type_node,
14118     &ffecom_f2c_flag_type_node,
14119     &ffecom_f2c_ftnlen_type_node,
14120     &ffecom_f2c_ftnlen_zero_node,
14121     &ffecom_f2c_ftnlen_one_node,
14122     &ffecom_f2c_ftnlen_two_node,
14123     &ffecom_f2c_ptr_to_ftnlen_type_node,
14124     &ffecom_f2c_ftnint_type_node,
14125     &ffecom_f2c_ptr_to_ftnint_type_node,
14126     &ffecom_outer_function_decl_,
14127     &ffecom_previous_function_decl_,
14128     &ffecom_which_entrypoint_decl_,
14129     &ffecom_float_zero_,
14130     &ffecom_float_half_,
14131     &ffecom_double_zero_,
14132     &ffecom_double_half_,
14133     &ffecom_func_result_,
14134     &ffecom_func_length_,
14135     &ffecom_multi_type_node_,
14136     &ffecom_multi_retval_,
14137     &named_labels,
14138     &shadowed_labels
14139   };
14140   size_t i;
14141
14142   malloc_init ();
14143
14144   /* Record our roots.  */
14145   for (i = 0; i < ARRAY_SIZE (tree_roots); i++)
14146     ggc_add_tree_root (tree_roots[i], 1);
14147   ggc_add_tree_root (&ffecom_tree_type[0][0],
14148                      FFEINFO_basictype*FFEINFO_kindtype);
14149   ggc_add_tree_root (&ffecom_tree_fun_type[0][0],
14150                      FFEINFO_basictype*FFEINFO_kindtype);
14151   ggc_add_tree_root (&ffecom_tree_ptr_to_fun_type[0][0],
14152                      FFEINFO_basictype*FFEINFO_kindtype);
14153   ggc_add_tree_root (ffecom_gfrt_, FFECOM_gfrt);
14154   ggc_add_root (&current_binding_level, 1, sizeof current_binding_level,
14155                 mark_binding_level);
14156   ggc_add_root (&free_binding_level, 1, sizeof current_binding_level,
14157                 mark_binding_level);
14158   ggc_add_root (&tracker_head, 1, sizeof tracker_head, mark_tracker_head);
14159
14160   ffe_init_0 ();
14161 }
14162
14163 /* Delete the node BLOCK from the current binding level.
14164    This is used for the block inside a stmt expr ({...})
14165    so that the block can be reinserted where appropriate.  */
14166
14167 static void
14168 delete_block (block)
14169      tree block;
14170 {
14171   tree t;
14172   if (current_binding_level->blocks == block)
14173     current_binding_level->blocks = TREE_CHAIN (block);
14174   for (t = current_binding_level->blocks; t;)
14175     {
14176       if (TREE_CHAIN (t) == block)
14177         TREE_CHAIN (t) = TREE_CHAIN (block);
14178       else
14179         t = TREE_CHAIN (t);
14180     }
14181   TREE_CHAIN (block) = NULL;
14182   /* Clear TREE_USED which is always set by poplevel.
14183      The flag is set again if insert_block is called.  */
14184   TREE_USED (block) = 0;
14185 }
14186
14187 void
14188 insert_block (block)
14189      tree block;
14190 {
14191   TREE_USED (block) = 1;
14192   current_binding_level->blocks
14193     = chainon (current_binding_level->blocks, block);
14194 }
14195
14196 /* Each front end provides its own.  */
14197 static const char *ffe_init PARAMS ((const char *));
14198 static void ffe_finish PARAMS ((void));
14199 static void ffe_init_options PARAMS ((void));
14200 static void ffe_print_identifier PARAMS ((FILE *, tree, int));
14201 static void ffe_mark_tree (tree);
14202
14203 #undef  LANG_HOOKS_NAME
14204 #define LANG_HOOKS_NAME                 "GNU F77"
14205 #undef  LANG_HOOKS_INIT
14206 #define LANG_HOOKS_INIT                 ffe_init
14207 #undef  LANG_HOOKS_FINISH
14208 #define LANG_HOOKS_FINISH               ffe_finish
14209 #undef  LANG_HOOKS_INIT_OPTIONS
14210 #define LANG_HOOKS_INIT_OPTIONS         ffe_init_options
14211 #undef  LANG_HOOKS_DECODE_OPTION
14212 #define LANG_HOOKS_DECODE_OPTION        ffe_decode_option
14213 #undef  LANG_HOOKS_PARSE_FILE
14214 #define LANG_HOOKS_PARSE_FILE           ffe_parse_file
14215 #undef  LANG_HOOKS_MARK_TREE
14216 #define LANG_HOOKS_MARK_TREE            ffe_mark_tree
14217 #undef  LANG_HOOKS_MARK_ADDRESSABLE
14218 #define LANG_HOOKS_MARK_ADDRESSABLE     ffe_mark_addressable
14219 #undef  LANG_HOOKS_PRINT_IDENTIFIER
14220 #define LANG_HOOKS_PRINT_IDENTIFIER     ffe_print_identifier
14221 #undef  LANG_HOOKS_DECL_PRINTABLE_NAME
14222 #define LANG_HOOKS_DECL_PRINTABLE_NAME  ffe_printable_name
14223 #undef  LANG_HOOKS_PRINT_ERROR_FUNCTION
14224 #define LANG_HOOKS_PRINT_ERROR_FUNCTION ffe_print_error_function
14225 #undef  LANG_HOOKS_TRUTHVALUE_CONVERSION
14226 #define LANG_HOOKS_TRUTHVALUE_CONVERSION ffe_truthvalue_conversion
14227
14228 #undef  LANG_HOOKS_TYPE_FOR_MODE
14229 #define LANG_HOOKS_TYPE_FOR_MODE        ffe_type_for_mode
14230 #undef  LANG_HOOKS_TYPE_FOR_SIZE
14231 #define LANG_HOOKS_TYPE_FOR_SIZE        ffe_type_for_size
14232 #undef  LANG_HOOKS_SIGNED_TYPE
14233 #define LANG_HOOKS_SIGNED_TYPE          ffe_signed_type
14234 #undef  LANG_HOOKS_UNSIGNED_TYPE
14235 #define LANG_HOOKS_UNSIGNED_TYPE        ffe_unsigned_type
14236 #undef  LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE
14237 #define LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE ffe_signed_or_unsigned_type
14238
14239 /* We do not wish to use alias-set based aliasing at all.  Used in the
14240    extreme (every object with its own set, with equivalences recorded) it
14241    might be helpful, but there are problems when it comes to inlining.  We
14242    get on ok with flag_argument_noalias, and alias-set aliasing does
14243    currently limit how stack slots can be reused, which is a lose.  */
14244 #undef LANG_HOOKS_GET_ALIAS_SET
14245 #define LANG_HOOKS_GET_ALIAS_SET hook_get_alias_set_0
14246
14247 const struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER;
14248
14249 /* Table indexed by tree code giving a string containing a character
14250    classifying the tree code.  Possibilities are
14251    t, d, s, c, r, <, 1, 2 and e.  See tree.def for details.  */
14252
14253 #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) TYPE,
14254
14255 const char tree_code_type[] = {
14256 #include "tree.def"
14257 };
14258 #undef DEFTREECODE
14259
14260 /* Table indexed by tree code giving number of expression
14261    operands beyond the fixed part of the node structure.
14262    Not used for types or decls.  */
14263
14264 #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) LENGTH,
14265
14266 const unsigned char tree_code_length[] = {
14267 #include "tree.def"
14268 };
14269 #undef DEFTREECODE
14270
14271 /* Names of tree components.
14272    Used for printing out the tree and error messages.  */
14273 #define DEFTREECODE(SYM, NAME, TYPE, LEN) NAME,
14274
14275 const char *const tree_code_name[] = {
14276 #include "tree.def"
14277 };
14278 #undef DEFTREECODE
14279
14280 static const char *
14281 ffe_init (filename)
14282      const char *filename;
14283 {
14284   /* Open input file.  */
14285   if (filename == 0 || !strcmp (filename, "-"))
14286     {
14287       finput = stdin;
14288       filename = "stdin";
14289     }
14290   else
14291     finput = fopen (filename, "r");
14292   if (finput == 0)
14293     fatal_io_error ("can't open %s", filename);
14294
14295 #ifdef IO_BUFFER_SIZE
14296   setvbuf (finput, (char *) xmalloc (IO_BUFFER_SIZE), _IOFBF, IO_BUFFER_SIZE);
14297 #endif
14298
14299   ffecom_init_decl_processing ();
14300
14301   /* If the file is output from cpp, it should contain a first line
14302      `# 1 "real-filename"', and the current design of gcc (toplev.c
14303      in particular and the way it sets up information relied on by
14304      INCLUDE) requires that we read this now, and store the
14305      "real-filename" info in master_input_filename.  Ask the lexer
14306      to try doing this.  */
14307   ffelex_hash_kludge (finput);
14308
14309   /* FIXME: The ffelex_hash_kludge code needs to be cleaned up to
14310      return the new file name.  */
14311   if (main_input_filename)
14312     filename = main_input_filename;
14313
14314   return filename;
14315 }
14316
14317 static void
14318 ffe_finish ()
14319 {
14320   ffe_terminate_0 ();
14321
14322   if (ffe_is_ffedebug ())
14323     malloc_pool_display (malloc_pool_image ());
14324
14325   fclose (finput);
14326 }
14327
14328 static void
14329 ffe_init_options ()
14330 {
14331   /* Set default options for Fortran.  */
14332   flag_move_all_movables = 1;
14333   flag_reduce_all_givs = 1;
14334   flag_argument_noalias = 2;
14335   flag_merge_constants = 2;
14336   flag_errno_math = 0;
14337   flag_complex_divide_method = 1;
14338 }
14339
14340 static bool
14341 ffe_mark_addressable (exp)
14342      tree exp;
14343 {
14344   register tree x = exp;
14345   while (1)
14346     switch (TREE_CODE (x))
14347       {
14348       case ADDR_EXPR:
14349       case COMPONENT_REF:
14350       case ARRAY_REF:
14351         x = TREE_OPERAND (x, 0);
14352         break;
14353
14354       case CONSTRUCTOR:
14355         TREE_ADDRESSABLE (x) = 1;
14356         return true;
14357
14358       case VAR_DECL:
14359       case CONST_DECL:
14360       case PARM_DECL:
14361       case RESULT_DECL:
14362         if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x)
14363             && DECL_NONLOCAL (x))
14364           {
14365             if (TREE_PUBLIC (x))
14366               {
14367                 assert ("address of global register var requested" == NULL);
14368                 return false;
14369               }
14370             assert ("address of register variable requested" == NULL);
14371           }
14372         else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x))
14373           {
14374             if (TREE_PUBLIC (x))
14375               {
14376                 assert ("address of global register var requested" == NULL);
14377                 return false;
14378               }
14379             assert ("address of register var requested" == NULL);
14380           }
14381         put_var_into_stack (x);
14382
14383         /* drops in */
14384       case FUNCTION_DECL:
14385         TREE_ADDRESSABLE (x) = 1;
14386 #if 0                           /* poplevel deals with this now.  */
14387         if (DECL_CONTEXT (x) == 0)
14388           TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x)) = 1;
14389 #endif
14390
14391       default:
14392         return true;
14393       }
14394 }
14395
14396 /* Exit a binding level.
14397    Pop the level off, and restore the state of the identifier-decl mappings
14398    that were in effect when this level was entered.
14399
14400    If KEEP is nonzero, this level had explicit declarations, so
14401    and create a "block" (a BLOCK node) for the level
14402    to record its declarations and subblocks for symbol table output.
14403
14404    If FUNCTIONBODY is nonzero, this level is the body of a function,
14405    so create a block as if KEEP were set and also clear out all
14406    label names.
14407
14408    If REVERSE is nonzero, reverse the order of decls before putting
14409    them into the BLOCK.  */
14410
14411 tree
14412 poplevel (keep, reverse, functionbody)
14413      int keep;
14414      int reverse;
14415      int functionbody;
14416 {
14417   register tree link;
14418   /* The chain of decls was accumulated in reverse order.
14419      Put it into forward order, just for cleanliness.  */
14420   tree decls;
14421   tree subblocks = current_binding_level->blocks;
14422   tree block = 0;
14423   tree decl;
14424   int block_previously_created;
14425
14426   /* Get the decls in the order they were written.
14427      Usually current_binding_level->names is in reverse order.
14428      But parameter decls were previously put in forward order.  */
14429
14430   if (reverse)
14431     current_binding_level->names
14432       = decls = nreverse (current_binding_level->names);
14433   else
14434     decls = current_binding_level->names;
14435
14436   /* Output any nested inline functions within this block
14437      if they weren't already output.  */
14438
14439   for (decl = decls; decl; decl = TREE_CHAIN (decl))
14440     if (TREE_CODE (decl) == FUNCTION_DECL
14441         && ! TREE_ASM_WRITTEN (decl)
14442         && DECL_INITIAL (decl) != 0
14443         && TREE_ADDRESSABLE (decl))
14444       {
14445         /* If this decl was copied from a file-scope decl
14446            on account of a block-scope extern decl,
14447            propagate TREE_ADDRESSABLE to the file-scope decl.
14448
14449            DECL_ABSTRACT_ORIGIN can be set to itself if warn_return_type is
14450            true, since then the decl goes through save_for_inline_copying.  */
14451         if (DECL_ABSTRACT_ORIGIN (decl) != 0
14452             && DECL_ABSTRACT_ORIGIN (decl) != decl)
14453           TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl)) = 1;
14454         else if (DECL_SAVED_INSNS (decl) != 0)
14455           {
14456             push_function_context ();
14457             output_inline_function (decl);
14458             pop_function_context ();
14459           }
14460       }
14461
14462   /* If there were any declarations or structure tags in that level,
14463      or if this level is a function body,
14464      create a BLOCK to record them for the life of this function.  */
14465
14466   block = 0;
14467   block_previously_created = (current_binding_level->this_block != 0);
14468   if (block_previously_created)
14469     block = current_binding_level->this_block;
14470   else if (keep || functionbody)
14471     block = make_node (BLOCK);
14472   if (block != 0)
14473     {
14474       BLOCK_VARS (block) = decls;
14475       BLOCK_SUBBLOCKS (block) = subblocks;
14476     }
14477
14478   /* In each subblock, record that this is its superior.  */
14479
14480   for (link = subblocks; link; link = TREE_CHAIN (link))
14481     BLOCK_SUPERCONTEXT (link) = block;
14482
14483   /* Clear out the meanings of the local variables of this level.  */
14484
14485   for (link = decls; link; link = TREE_CHAIN (link))
14486     {
14487       if (DECL_NAME (link) != 0)
14488         {
14489           /* If the ident. was used or addressed via a local extern decl,
14490              don't forget that fact.  */
14491           if (DECL_EXTERNAL (link))
14492             {
14493               if (TREE_USED (link))
14494                 TREE_USED (DECL_NAME (link)) = 1;
14495               if (TREE_ADDRESSABLE (link))
14496                 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (link)) = 1;
14497             }
14498           IDENTIFIER_LOCAL_VALUE (DECL_NAME (link)) = 0;
14499         }
14500     }
14501
14502   /* If the level being exited is the top level of a function,
14503      check over all the labels, and clear out the current
14504      (function local) meanings of their names.  */
14505
14506   if (functionbody)
14507     {
14508       /* If this is the top level block of a function,
14509          the vars are the function's parameters.
14510          Don't leave them in the BLOCK because they are
14511          found in the FUNCTION_DECL instead.  */
14512
14513       BLOCK_VARS (block) = 0;
14514     }
14515
14516   /* Pop the current level, and free the structure for reuse.  */
14517
14518   {
14519     register struct binding_level *level = current_binding_level;
14520     current_binding_level = current_binding_level->level_chain;
14521
14522     level->level_chain = free_binding_level;
14523     free_binding_level = level;
14524   }
14525
14526   /* Dispose of the block that we just made inside some higher level.  */
14527   if (functionbody
14528       && current_function_decl != error_mark_node)
14529     DECL_INITIAL (current_function_decl) = block;
14530   else if (block)
14531     {
14532       if (!block_previously_created)
14533         current_binding_level->blocks
14534           = chainon (current_binding_level->blocks, block);
14535     }
14536   /* If we did not make a block for the level just exited,
14537      any blocks made for inner levels
14538      (since they cannot be recorded as subblocks in that level)
14539      must be carried forward so they will later become subblocks
14540      of something else.  */
14541   else if (subblocks)
14542     current_binding_level->blocks
14543       = chainon (current_binding_level->blocks, subblocks);
14544
14545   if (block)
14546     TREE_USED (block) = 1;
14547   return block;
14548 }
14549
14550 static void
14551 ffe_print_identifier (file, node, indent)
14552      FILE *file;
14553      tree node;
14554      int indent;
14555 {
14556   print_node (file, "global", IDENTIFIER_GLOBAL_VALUE (node), indent + 4);
14557   print_node (file, "local", IDENTIFIER_LOCAL_VALUE (node), indent + 4);
14558 }
14559
14560 /* Record a decl-node X as belonging to the current lexical scope.
14561    Check for errors (such as an incompatible declaration for the same
14562    name already seen in the same scope).
14563
14564    Returns either X or an old decl for the same name.
14565    If an old decl is returned, it may have been smashed
14566    to agree with what X says.  */
14567
14568 tree
14569 pushdecl (x)
14570      tree x;
14571 {
14572   register tree t;
14573   register tree name = DECL_NAME (x);
14574   register struct binding_level *b = current_binding_level;
14575
14576   if ((TREE_CODE (x) == FUNCTION_DECL)
14577       && (DECL_INITIAL (x) == 0)
14578       && DECL_EXTERNAL (x))
14579     DECL_CONTEXT (x) = NULL_TREE;
14580   else
14581     DECL_CONTEXT (x) = current_function_decl;
14582
14583   if (name)
14584     {
14585       if (IDENTIFIER_INVENTED (name))
14586         {
14587           DECL_ARTIFICIAL (x) = 1;
14588           DECL_IN_SYSTEM_HEADER (x) = 1;
14589         }
14590
14591       t = lookup_name_current_level (name);
14592
14593       assert ((t == NULL_TREE) || (DECL_CONTEXT (x) == NULL_TREE));
14594
14595       /* Don't push non-parms onto list for parms until we understand
14596          why we're doing this and whether it works.  */
14597
14598       assert ((b == global_binding_level)
14599               || !ffecom_transform_only_dummies_
14600               || TREE_CODE (x) == PARM_DECL);
14601
14602       if ((t != NULL_TREE) && duplicate_decls (x, t))
14603         return t;
14604
14605       /* If we are processing a typedef statement, generate a whole new
14606          ..._TYPE node (which will be just an variant of the existing
14607          ..._TYPE node with identical properties) and then install the
14608          TYPE_DECL node generated to represent the typedef name as the
14609          TYPE_NAME of this brand new (duplicate) ..._TYPE node.
14610
14611          The whole point here is to end up with a situation where each and every
14612          ..._TYPE node the compiler creates will be uniquely associated with
14613          AT MOST one node representing a typedef name. This way, even though
14614          the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL
14615          (i.e. "typedef name") nodes very early on, later parts of the
14616          compiler can always do the reverse translation and get back the
14617          corresponding typedef name.  For example, given:
14618
14619          typedef struct S MY_TYPE; MY_TYPE object;
14620
14621          Later parts of the compiler might only know that `object' was of type
14622          `struct S' if it were not for code just below.  With this code
14623          however, later parts of the compiler see something like:
14624
14625          struct S' == struct S typedef struct S' MY_TYPE; struct S' object;
14626
14627          And they can then deduce (from the node for type struct S') that the
14628          original object declaration was:
14629
14630          MY_TYPE object;
14631
14632          Being able to do this is important for proper support of protoize, and
14633          also for generating precise symbolic debugging information which
14634          takes full account of the programmer's (typedef) vocabulary.
14635
14636          Obviously, we don't want to generate a duplicate ..._TYPE node if the
14637          TYPE_DECL node that we are now processing really represents a
14638          standard built-in type.
14639
14640          Since all standard types are effectively declared at line zero in the
14641          source file, we can easily check to see if we are working on a
14642          standard type by checking the current value of lineno.  */
14643
14644       if (TREE_CODE (x) == TYPE_DECL)
14645         {
14646           if (DECL_SOURCE_LINE (x) == 0)
14647             {
14648               if (TYPE_NAME (TREE_TYPE (x)) == 0)
14649                 TYPE_NAME (TREE_TYPE (x)) = x;
14650             }
14651           else if (TREE_TYPE (x) != error_mark_node)
14652             {
14653               tree tt = TREE_TYPE (x);
14654
14655               tt = build_type_copy (tt);
14656               TYPE_NAME (tt) = x;
14657               TREE_TYPE (x) = tt;
14658             }
14659         }
14660
14661       /* This name is new in its binding level. Install the new declaration
14662          and return it.  */
14663       if (b == global_binding_level)
14664         IDENTIFIER_GLOBAL_VALUE (name) = x;
14665       else
14666         IDENTIFIER_LOCAL_VALUE (name) = x;
14667     }
14668
14669   /* Put decls on list in reverse order. We will reverse them later if
14670      necessary.  */
14671   TREE_CHAIN (x) = b->names;
14672   b->names = x;
14673
14674   return x;
14675 }
14676
14677 /* Nonzero if the current level needs to have a BLOCK made.  */
14678
14679 static int
14680 kept_level_p ()
14681 {
14682   tree decl;
14683
14684   for (decl = current_binding_level->names;
14685        decl;
14686        decl = TREE_CHAIN (decl))
14687     {
14688       if (TREE_USED (decl) || TREE_CODE (decl) != VAR_DECL
14689           || (DECL_NAME (decl) && ! DECL_ARTIFICIAL (decl)))
14690         /* Currently, there aren't supposed to be non-artificial names
14691            at other than the top block for a function -- they're
14692            believed to always be temps.  But it's wise to check anyway.  */
14693         return 1;
14694     }
14695   return 0;
14696 }
14697
14698 /* Enter a new binding level.
14699    If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
14700    not for that of tags.  */
14701
14702 void
14703 pushlevel (tag_transparent)
14704      int tag_transparent;
14705 {
14706   register struct binding_level *newlevel = NULL_BINDING_LEVEL;
14707
14708   assert (! tag_transparent);
14709
14710   if (current_binding_level == global_binding_level)
14711     {
14712       named_labels = 0;
14713     }
14714
14715   /* Reuse or create a struct for this binding level.  */
14716
14717   if (free_binding_level)
14718     {
14719       newlevel = free_binding_level;
14720       free_binding_level = free_binding_level->level_chain;
14721     }
14722   else
14723     {
14724       newlevel = make_binding_level ();
14725     }
14726
14727   /* Add this level to the front of the chain (stack) of levels that
14728      are active.  */
14729
14730   *newlevel = clear_binding_level;
14731   newlevel->level_chain = current_binding_level;
14732   current_binding_level = newlevel;
14733 }
14734
14735 /* Set the BLOCK node for the innermost scope
14736    (the one we are currently in).  */
14737
14738 void
14739 set_block (block)
14740      register tree block;
14741 {
14742   current_binding_level->this_block = block;
14743   current_binding_level->names = chainon (current_binding_level->names,
14744                                           BLOCK_VARS (block));
14745   current_binding_level->blocks = chainon (current_binding_level->blocks,
14746                                            BLOCK_SUBBLOCKS (block));
14747 }
14748
14749 static tree
14750 ffe_signed_or_unsigned_type (unsignedp, type)
14751      int unsignedp;
14752      tree type;
14753 {
14754   tree type2;
14755
14756   if (! INTEGRAL_TYPE_P (type))
14757     return type;
14758   if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node))
14759     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
14760   if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node))
14761     return unsignedp ? unsigned_type_node : integer_type_node;
14762   if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node))
14763     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
14764   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node))
14765     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
14766   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node))
14767     return (unsignedp ? long_long_unsigned_type_node
14768             : long_long_integer_type_node);
14769
14770   type2 = ffe_type_for_size (TYPE_PRECISION (type), unsignedp);
14771   if (type2 == NULL_TREE)
14772     return type;
14773
14774   return type2;
14775 }
14776
14777 static tree
14778 ffe_signed_type (type)
14779      tree type;
14780 {
14781   tree type1 = TYPE_MAIN_VARIANT (type);
14782   ffeinfoKindtype kt;
14783   tree type2;
14784
14785   if (type1 == unsigned_char_type_node || type1 == char_type_node)
14786     return signed_char_type_node;
14787   if (type1 == unsigned_type_node)
14788     return integer_type_node;
14789   if (type1 == short_unsigned_type_node)
14790     return short_integer_type_node;
14791   if (type1 == long_unsigned_type_node)
14792     return long_integer_type_node;
14793   if (type1 == long_long_unsigned_type_node)
14794     return long_long_integer_type_node;
14795 #if 0   /* gcc/c-* files only */
14796   if (type1 == unsigned_intDI_type_node)
14797     return intDI_type_node;
14798   if (type1 == unsigned_intSI_type_node)
14799     return intSI_type_node;
14800   if (type1 == unsigned_intHI_type_node)
14801     return intHI_type_node;
14802   if (type1 == unsigned_intQI_type_node)
14803     return intQI_type_node;
14804 #endif
14805
14806   type2 = ffe_type_for_size (TYPE_PRECISION (type1), 0);
14807   if (type2 != NULL_TREE)
14808     return type2;
14809
14810   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
14811     {
14812       type2 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
14813
14814       if (type1 == type2)
14815         return ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
14816     }
14817
14818   return type;
14819 }
14820
14821 /* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
14822    or validate its data type for an `if' or `while' statement or ?..: exp.
14823
14824    This preparation consists of taking the ordinary
14825    representation of an expression expr and producing a valid tree
14826    boolean expression describing whether expr is nonzero.  We could
14827    simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
14828    but we optimize comparisons, &&, ||, and !.
14829
14830    The resulting type should always be `integer_type_node'.  */
14831
14832 static tree
14833 ffe_truthvalue_conversion (expr)
14834      tree expr;
14835 {
14836   if (TREE_CODE (expr) == ERROR_MARK)
14837     return expr;
14838
14839 #if 0 /* This appears to be wrong for C++.  */
14840   /* These really should return error_mark_node after 2.4 is stable.
14841      But not all callers handle ERROR_MARK properly.  */
14842   switch (TREE_CODE (TREE_TYPE (expr)))
14843     {
14844     case RECORD_TYPE:
14845       error ("struct type value used where scalar is required");
14846       return integer_zero_node;
14847
14848     case UNION_TYPE:
14849       error ("union type value used where scalar is required");
14850       return integer_zero_node;
14851
14852     case ARRAY_TYPE:
14853       error ("array type value used where scalar is required");
14854       return integer_zero_node;
14855
14856     default:
14857       break;
14858     }
14859 #endif /* 0 */
14860
14861   switch (TREE_CODE (expr))
14862     {
14863       /* It is simpler and generates better code to have only TRUTH_*_EXPR
14864          or comparison expressions as truth values at this level.  */
14865 #if 0
14866     case COMPONENT_REF:
14867       /* A one-bit unsigned bit-field is already acceptable.  */
14868       if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr, 1)))
14869           && TREE_UNSIGNED (TREE_OPERAND (expr, 1)))
14870         return expr;
14871       break;
14872 #endif
14873
14874     case EQ_EXPR:
14875       /* It is simpler and generates better code to have only TRUTH_*_EXPR
14876          or comparison expressions as truth values at this level.  */
14877 #if 0
14878       if (integer_zerop (TREE_OPERAND (expr, 1)))
14879         return build_unary_op (TRUTH_NOT_EXPR, TREE_OPERAND (expr, 0), 0);
14880 #endif
14881     case NE_EXPR: case LE_EXPR: case GE_EXPR: case LT_EXPR: case GT_EXPR:
14882     case TRUTH_ANDIF_EXPR:
14883     case TRUTH_ORIF_EXPR:
14884     case TRUTH_AND_EXPR:
14885     case TRUTH_OR_EXPR:
14886     case TRUTH_XOR_EXPR:
14887       TREE_TYPE (expr) = integer_type_node;
14888       return expr;
14889
14890     case ERROR_MARK:
14891       return expr;
14892
14893     case INTEGER_CST:
14894       return integer_zerop (expr) ? integer_zero_node : integer_one_node;
14895
14896     case REAL_CST:
14897       return real_zerop (expr) ? integer_zero_node : integer_one_node;
14898
14899     case ADDR_EXPR:
14900       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 0)))
14901         return build (COMPOUND_EXPR, integer_type_node,
14902                       TREE_OPERAND (expr, 0), integer_one_node);
14903       else
14904         return integer_one_node;
14905
14906     case COMPLEX_EXPR:
14907       return ffecom_2 ((TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1))
14908                         ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
14909                        integer_type_node,
14910                        ffe_truthvalue_conversion (TREE_OPERAND (expr, 0)),
14911                        ffe_truthvalue_conversion (TREE_OPERAND (expr, 1)));
14912
14913     case NEGATE_EXPR:
14914     case ABS_EXPR:
14915     case FLOAT_EXPR:
14916     case FFS_EXPR:
14917       /* These don't change whether an object is non-zero or zero.  */
14918       return ffe_truthvalue_conversion (TREE_OPERAND (expr, 0));
14919
14920     case LROTATE_EXPR:
14921     case RROTATE_EXPR:
14922       /* These don't change whether an object is zero or non-zero, but
14923          we can't ignore them if their second arg has side-effects.  */
14924       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1)))
14925         return build (COMPOUND_EXPR, integer_type_node, TREE_OPERAND (expr, 1),
14926                       ffe_truthvalue_conversion (TREE_OPERAND (expr, 0)));
14927       else
14928         return ffe_truthvalue_conversion (TREE_OPERAND (expr, 0));
14929
14930     case COND_EXPR:
14931       /* Distribute the conversion into the arms of a COND_EXPR.  */
14932       return fold (build (COND_EXPR, integer_type_node, TREE_OPERAND (expr, 0),
14933                           ffe_truthvalue_conversion (TREE_OPERAND (expr, 1)),
14934                           ffe_truthvalue_conversion (TREE_OPERAND (expr, 2))));
14935
14936     case CONVERT_EXPR:
14937       /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
14938          since that affects how `default_conversion' will behave.  */
14939       if (TREE_CODE (TREE_TYPE (expr)) == REFERENCE_TYPE
14940           || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) == REFERENCE_TYPE)
14941         break;
14942       /* fall through... */
14943     case NOP_EXPR:
14944       /* If this is widening the argument, we can ignore it.  */
14945       if (TYPE_PRECISION (TREE_TYPE (expr))
14946           >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr, 0))))
14947         return ffe_truthvalue_conversion (TREE_OPERAND (expr, 0));
14948       break;
14949
14950     case MINUS_EXPR:
14951       /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize
14952          this case.  */
14953       if (TARGET_FLOAT_FORMAT == IEEE_FLOAT_FORMAT
14954           && TREE_CODE (TREE_TYPE (expr)) == REAL_TYPE)
14955         break;
14956       /* fall through... */
14957     case BIT_XOR_EXPR:
14958       /* This and MINUS_EXPR can be changed into a comparison of the
14959          two objects.  */
14960       if (TREE_TYPE (TREE_OPERAND (expr, 0))
14961           == TREE_TYPE (TREE_OPERAND (expr, 1)))
14962         return ffecom_2 (NE_EXPR, integer_type_node,
14963                          TREE_OPERAND (expr, 0),
14964                          TREE_OPERAND (expr, 1));
14965       return ffecom_2 (NE_EXPR, integer_type_node,
14966                        TREE_OPERAND (expr, 0),
14967                        fold (build1 (NOP_EXPR,
14968                                      TREE_TYPE (TREE_OPERAND (expr, 0)),
14969                                      TREE_OPERAND (expr, 1))));
14970
14971     case BIT_AND_EXPR:
14972       if (integer_onep (TREE_OPERAND (expr, 1)))
14973         return expr;
14974       break;
14975
14976     case MODIFY_EXPR:
14977 #if 0                           /* No such thing in Fortran. */
14978       if (warn_parentheses && C_EXP_ORIGINAL_CODE (expr) == MODIFY_EXPR)
14979         warning ("suggest parentheses around assignment used as truth value");
14980 #endif
14981       break;
14982
14983     default:
14984       break;
14985     }
14986
14987   if (TREE_CODE (TREE_TYPE (expr)) == COMPLEX_TYPE)
14988     return (ffecom_2
14989             ((TREE_SIDE_EFFECTS (expr)
14990               ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
14991              integer_type_node,
14992              ffe_truthvalue_conversion (ffecom_1 (REALPART_EXPR,
14993                                                   TREE_TYPE (TREE_TYPE (expr)),
14994                                                   expr)),
14995              ffe_truthvalue_conversion (ffecom_1 (IMAGPART_EXPR,
14996                                                   TREE_TYPE (TREE_TYPE (expr)),
14997                                                   expr))));
14998
14999   return ffecom_2 (NE_EXPR, integer_type_node,
15000                    expr,
15001                    convert (TREE_TYPE (expr), integer_zero_node));
15002 }
15003
15004 static tree
15005 ffe_type_for_mode (mode, unsignedp)
15006      enum machine_mode mode;
15007      int unsignedp;
15008 {
15009   int i;
15010   int j;
15011   tree t;
15012
15013   if (mode == TYPE_MODE (integer_type_node))
15014     return unsignedp ? unsigned_type_node : integer_type_node;
15015
15016   if (mode == TYPE_MODE (signed_char_type_node))
15017     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15018
15019   if (mode == TYPE_MODE (short_integer_type_node))
15020     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15021
15022   if (mode == TYPE_MODE (long_integer_type_node))
15023     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15024
15025   if (mode == TYPE_MODE (long_long_integer_type_node))
15026     return unsignedp ? long_long_unsigned_type_node : long_long_integer_type_node;
15027
15028 #if HOST_BITS_PER_WIDE_INT >= 64
15029   if (mode == TYPE_MODE (intTI_type_node))
15030     return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
15031 #endif
15032
15033   if (mode == TYPE_MODE (float_type_node))
15034     return float_type_node;
15035
15036   if (mode == TYPE_MODE (double_type_node))
15037     return double_type_node;
15038
15039   if (mode == TYPE_MODE (build_pointer_type (char_type_node)))
15040     return build_pointer_type (char_type_node);
15041
15042   if (mode == TYPE_MODE (build_pointer_type (integer_type_node)))
15043     return build_pointer_type (integer_type_node);
15044
15045   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
15046     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
15047       {
15048         if (((t = ffecom_tree_type[i][j]) != NULL_TREE)
15049             && (mode == TYPE_MODE (t)))
15050           {
15051             if ((i == FFEINFO_basictypeINTEGER) && unsignedp)
15052               return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][j];
15053             else
15054               return t;
15055           }
15056       }
15057
15058   return 0;
15059 }
15060
15061 static tree
15062 ffe_type_for_size (bits, unsignedp)
15063      unsigned bits;
15064      int unsignedp;
15065 {
15066   ffeinfoKindtype kt;
15067   tree type_node;
15068
15069   if (bits == TYPE_PRECISION (integer_type_node))
15070     return unsignedp ? unsigned_type_node : integer_type_node;
15071
15072   if (bits == TYPE_PRECISION (signed_char_type_node))
15073     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15074
15075   if (bits == TYPE_PRECISION (short_integer_type_node))
15076     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15077
15078   if (bits == TYPE_PRECISION (long_integer_type_node))
15079     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15080
15081   if (bits == TYPE_PRECISION (long_long_integer_type_node))
15082     return (unsignedp ? long_long_unsigned_type_node
15083             : long_long_integer_type_node);
15084
15085   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15086     {
15087       type_node = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15088
15089       if ((type_node != NULL_TREE) && (bits == TYPE_PRECISION (type_node)))
15090         return unsignedp ? ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]
15091           : type_node;
15092     }
15093
15094   return 0;
15095 }
15096
15097 static tree
15098 ffe_unsigned_type (type)
15099      tree type;
15100 {
15101   tree type1 = TYPE_MAIN_VARIANT (type);
15102   ffeinfoKindtype kt;
15103   tree type2;
15104
15105   if (type1 == signed_char_type_node || type1 == char_type_node)
15106     return unsigned_char_type_node;
15107   if (type1 == integer_type_node)
15108     return unsigned_type_node;
15109   if (type1 == short_integer_type_node)
15110     return short_unsigned_type_node;
15111   if (type1 == long_integer_type_node)
15112     return long_unsigned_type_node;
15113   if (type1 == long_long_integer_type_node)
15114     return long_long_unsigned_type_node;
15115 #if 0   /* gcc/c-* files only */
15116   if (type1 == intDI_type_node)
15117     return unsigned_intDI_type_node;
15118   if (type1 == intSI_type_node)
15119     return unsigned_intSI_type_node;
15120   if (type1 == intHI_type_node)
15121     return unsigned_intHI_type_node;
15122   if (type1 == intQI_type_node)
15123     return unsigned_intQI_type_node;
15124 #endif
15125
15126   type2 = ffe_type_for_size (TYPE_PRECISION (type1), 1);
15127   if (type2 != NULL_TREE)
15128     return type2;
15129
15130   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15131     {
15132       type2 = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15133
15134       if (type1 == type2)
15135         return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
15136     }
15137
15138   return type;
15139 }
15140
15141 static void
15142 ffe_mark_tree (t)
15143      tree t;
15144 {
15145   if (TREE_CODE (t) == IDENTIFIER_NODE)
15146     {
15147       struct lang_identifier *i = (struct lang_identifier *) t;
15148       ggc_mark_tree (IDENTIFIER_GLOBAL_VALUE (i));
15149       ggc_mark_tree (IDENTIFIER_LOCAL_VALUE (i));
15150       ggc_mark_tree (IDENTIFIER_LABEL_VALUE (i));
15151     }
15152   else if (TYPE_P (t) && TYPE_LANG_SPECIFIC (t))
15153     ggc_mark (TYPE_LANG_SPECIFIC (t));
15154 }
15155 \f
15156 /* From gcc/cccp.c, the code to handle -I.  */
15157
15158 /* Skip leading "./" from a directory name.
15159    This may yield the empty string, which represents the current directory.  */
15160
15161 static const char *
15162 skip_redundant_dir_prefix (const char *dir)
15163 {
15164   while (dir[0] == '.' && dir[1] == '/')
15165     for (dir += 2; *dir == '/'; dir++)
15166       continue;
15167   if (dir[0] == '.' && !dir[1])
15168     dir++;
15169   return dir;
15170 }
15171
15172 /* The file_name_map structure holds a mapping of file names for a
15173    particular directory.  This mapping is read from the file named
15174    FILE_NAME_MAP_FILE in that directory.  Such a file can be used to
15175    map filenames on a file system with severe filename restrictions,
15176    such as DOS.  The format of the file name map file is just a series
15177    of lines with two tokens on each line.  The first token is the name
15178    to map, and the second token is the actual name to use.  */
15179
15180 struct file_name_map
15181 {
15182   struct file_name_map *map_next;
15183   char *map_from;
15184   char *map_to;
15185 };
15186
15187 #define FILE_NAME_MAP_FILE "header.gcc"
15188
15189 /* Current maximum length of directory names in the search path
15190    for include files.  (Altered as we get more of them.)  */
15191
15192 static int max_include_len = 0;
15193
15194 struct file_name_list
15195   {
15196     struct file_name_list *next;
15197     char *fname;
15198     /* Mapping of file names for this directory.  */
15199     struct file_name_map *name_map;
15200     /* Non-zero if name_map is valid.  */
15201     int got_name_map;
15202   };
15203
15204 static struct file_name_list *include = NULL;   /* First dir to search */
15205 static struct file_name_list *last_include = NULL;      /* Last in chain */
15206
15207 /* I/O buffer structure.
15208    The `fname' field is nonzero for source files and #include files
15209    and for the dummy text used for -D and -U.
15210    It is zero for rescanning results of macro expansion
15211    and for expanding macro arguments.  */
15212 #define INPUT_STACK_MAX 400
15213 static struct file_buf {
15214   const char *fname;
15215   /* Filename specified with #line command.  */
15216   const char *nominal_fname;
15217   /* Record where in the search path this file was found.
15218      For #include_next.  */
15219   struct file_name_list *dir;
15220   ffewhereLine line;
15221   ffewhereColumn column;
15222 } instack[INPUT_STACK_MAX];
15223
15224 static int last_error_tick = 0;    /* Incremented each time we print it.  */
15225 static int input_file_stack_tick = 0;  /* Incremented when status changes.  */
15226
15227 /* Current nesting level of input sources.
15228    `instack[indepth]' is the level currently being read.  */
15229 static int indepth = -1;
15230
15231 typedef struct file_buf FILE_BUF;
15232
15233 /* Nonzero means -I- has been seen,
15234    so don't look for #include "foo" the source-file directory.  */
15235 static int ignore_srcdir;
15236
15237 #ifndef INCLUDE_LEN_FUDGE
15238 #define INCLUDE_LEN_FUDGE 0
15239 #endif
15240
15241 static void append_include_chain (struct file_name_list *first,
15242                                   struct file_name_list *last);
15243 static FILE *open_include_file (char *filename,
15244                                 struct file_name_list *searchptr);
15245 static void print_containing_files (ffebadSeverity sev);
15246 static char *read_filename_string (int ch, FILE *f);
15247 static struct file_name_map *read_name_map (const char *dirname);
15248
15249 /* Append a chain of `struct file_name_list's
15250    to the end of the main include chain.
15251    FIRST is the beginning of the chain to append, and LAST is the end.  */
15252
15253 static void
15254 append_include_chain (first, last)
15255      struct file_name_list *first, *last;
15256 {
15257   struct file_name_list *dir;
15258
15259   if (!first || !last)
15260     return;
15261
15262   if (include == 0)
15263     include = first;
15264   else
15265     last_include->next = first;
15266
15267   for (dir = first; ; dir = dir->next) {
15268     int len = strlen (dir->fname) + INCLUDE_LEN_FUDGE;
15269     if (len > max_include_len)
15270       max_include_len = len;
15271     if (dir == last)
15272       break;
15273   }
15274
15275   last->next = NULL;
15276   last_include = last;
15277 }
15278
15279 /* Try to open include file FILENAME.  SEARCHPTR is the directory
15280    being tried from the include file search path.  This function maps
15281    filenames on file systems based on information read by
15282    read_name_map.  */
15283
15284 static FILE *
15285 open_include_file (filename, searchptr)
15286      char *filename;
15287      struct file_name_list *searchptr;
15288 {
15289   register struct file_name_map *map;
15290   register char *from;
15291   char *p, *dir;
15292
15293   if (searchptr && ! searchptr->got_name_map)
15294     {
15295       searchptr->name_map = read_name_map (searchptr->fname
15296                                            ? searchptr->fname : ".");
15297       searchptr->got_name_map = 1;
15298     }
15299
15300   /* First check the mapping for the directory we are using.  */
15301   if (searchptr && searchptr->name_map)
15302     {
15303       from = filename;
15304       if (searchptr->fname)
15305         from += strlen (searchptr->fname) + 1;
15306       for (map = searchptr->name_map; map; map = map->map_next)
15307         {
15308           if (! strcmp (map->map_from, from))
15309             {
15310               /* Found a match.  */
15311               return fopen (map->map_to, "r");
15312             }
15313         }
15314     }
15315
15316   /* Try to find a mapping file for the particular directory we are
15317      looking in.  Thus #include <sys/types.h> will look up sys/types.h
15318      in /usr/include/header.gcc and look up types.h in
15319      /usr/include/sys/header.gcc.  */
15320   p = strrchr (filename, '/');
15321 #ifdef DIR_SEPARATOR
15322   if (! p) p = strrchr (filename, DIR_SEPARATOR);
15323   else {
15324     char *tmp = strrchr (filename, DIR_SEPARATOR);
15325     if (tmp != NULL && tmp > p) p = tmp;
15326   }
15327 #endif
15328   if (! p)
15329     p = filename;
15330   if (searchptr
15331       && searchptr->fname
15332       && strlen (searchptr->fname) == (size_t) (p - filename)
15333       && ! strncmp (searchptr->fname, filename, (int) (p - filename)))
15334     {
15335       /* FILENAME is in SEARCHPTR, which we've already checked.  */
15336       return fopen (filename, "r");
15337     }
15338
15339   if (p == filename)
15340     {
15341       from = filename;
15342       map = read_name_map (".");
15343     }
15344   else
15345     {
15346       dir = (char *) xmalloc (p - filename + 1);
15347       memcpy (dir, filename, p - filename);
15348       dir[p - filename] = '\0';
15349       from = p + 1;
15350       map = read_name_map (dir);
15351       free (dir);
15352     }
15353   for (; map; map = map->map_next)
15354     if (! strcmp (map->map_from, from))
15355       return fopen (map->map_to, "r");
15356
15357   return fopen (filename, "r");
15358 }
15359
15360 /* Print the file names and line numbers of the #include
15361    commands which led to the current file.  */
15362
15363 static void
15364 print_containing_files (ffebadSeverity sev)
15365 {
15366   FILE_BUF *ip = NULL;
15367   int i;
15368   int first = 1;
15369   const char *str1;
15370   const char *str2;
15371
15372   /* If stack of files hasn't changed since we last printed
15373      this info, don't repeat it.  */
15374   if (last_error_tick == input_file_stack_tick)
15375     return;
15376
15377   for (i = indepth; i >= 0; i--)
15378     if (instack[i].fname != NULL) {
15379       ip = &instack[i];
15380       break;
15381     }
15382
15383   /* Give up if we don't find a source file.  */
15384   if (ip == NULL)
15385     return;
15386
15387   /* Find the other, outer source files.  */
15388   for (i--; i >= 0; i--)
15389     if (instack[i].fname != NULL)
15390       {
15391         ip = &instack[i];
15392         if (first)
15393           {
15394             first = 0;
15395             str1 = "In file included";
15396           }
15397         else
15398           {
15399             str1 = "...          ...";
15400           }
15401
15402         if (i == 1)
15403           str2 = ":";
15404         else
15405           str2 = "";
15406
15407         /* xgettext:no-c-format */
15408         ffebad_start_msg ("%A from %B at %0%C", sev);
15409         ffebad_here (0, ip->line, ip->column);
15410         ffebad_string (str1);
15411         ffebad_string (ip->nominal_fname);
15412         ffebad_string (str2);
15413         ffebad_finish ();
15414       }
15415
15416   /* Record we have printed the status as of this time.  */
15417   last_error_tick = input_file_stack_tick;
15418 }
15419
15420 /* Read a space delimited string of unlimited length from a stdio
15421    file.  */
15422
15423 static char *
15424 read_filename_string (ch, f)
15425      int ch;
15426      FILE *f;
15427 {
15428   char *alloc, *set;
15429   int len;
15430
15431   len = 20;
15432   set = alloc = xmalloc (len + 1);
15433   if (! ISSPACE (ch))
15434     {
15435       *set++ = ch;
15436       while ((ch = getc (f)) != EOF && ! ISSPACE (ch))
15437         {
15438           if (set - alloc == len)
15439             {
15440               len *= 2;
15441               alloc = xrealloc (alloc, len + 1);
15442               set = alloc + len / 2;
15443             }
15444           *set++ = ch;
15445         }
15446     }
15447   *set = '\0';
15448   ungetc (ch, f);
15449   return alloc;
15450 }
15451
15452 /* Read the file name map file for DIRNAME.  */
15453
15454 static struct file_name_map *
15455 read_name_map (dirname)
15456      const char *dirname;
15457 {
15458   /* This structure holds a linked list of file name maps, one per
15459      directory.  */
15460   struct file_name_map_list
15461     {
15462       struct file_name_map_list *map_list_next;
15463       char *map_list_name;
15464       struct file_name_map *map_list_map;
15465     };
15466   static struct file_name_map_list *map_list;
15467   register struct file_name_map_list *map_list_ptr;
15468   char *name;
15469   FILE *f;
15470   size_t dirlen;
15471   int separator_needed;
15472
15473   dirname = skip_redundant_dir_prefix (dirname);
15474
15475   for (map_list_ptr = map_list; map_list_ptr;
15476        map_list_ptr = map_list_ptr->map_list_next)
15477     if (! strcmp (map_list_ptr->map_list_name, dirname))
15478       return map_list_ptr->map_list_map;
15479
15480   map_list_ptr = ((struct file_name_map_list *)
15481                   xmalloc (sizeof (struct file_name_map_list)));
15482   map_list_ptr->map_list_name = xstrdup (dirname);
15483   map_list_ptr->map_list_map = NULL;
15484
15485   dirlen = strlen (dirname);
15486   separator_needed = dirlen != 0 && dirname[dirlen - 1] != '/';
15487   name = (char *) xmalloc (dirlen + strlen (FILE_NAME_MAP_FILE) + 2);
15488   strcpy (name, dirname);
15489   name[dirlen] = '/';
15490   strcpy (name + dirlen + separator_needed, FILE_NAME_MAP_FILE);
15491   f = fopen (name, "r");
15492   free (name);
15493   if (!f)
15494     map_list_ptr->map_list_map = NULL;
15495   else
15496     {
15497       int ch;
15498
15499       while ((ch = getc (f)) != EOF)
15500         {
15501           char *from, *to;
15502           struct file_name_map *ptr;
15503
15504           if (ISSPACE (ch))
15505             continue;
15506           from = read_filename_string (ch, f);
15507           while ((ch = getc (f)) != EOF && ISSPACE (ch) && ch != '\n')
15508             ;
15509           to = read_filename_string (ch, f);
15510
15511           ptr = ((struct file_name_map *)
15512                  xmalloc (sizeof (struct file_name_map)));
15513           ptr->map_from = from;
15514
15515           /* Make the real filename absolute.  */
15516           if (*to == '/')
15517             ptr->map_to = to;
15518           else
15519             {
15520               ptr->map_to = xmalloc (dirlen + strlen (to) + 2);
15521               strcpy (ptr->map_to, dirname);
15522               ptr->map_to[dirlen] = '/';
15523               strcpy (ptr->map_to + dirlen + separator_needed, to);
15524               free (to);
15525             }
15526
15527           ptr->map_next = map_list_ptr->map_list_map;
15528           map_list_ptr->map_list_map = ptr;
15529
15530           while ((ch = getc (f)) != '\n')
15531             if (ch == EOF)
15532               break;
15533         }
15534       fclose (f);
15535     }
15536
15537   map_list_ptr->map_list_next = map_list;
15538   map_list = map_list_ptr;
15539
15540   return map_list_ptr->map_list_map;
15541 }
15542
15543 static void
15544 ffecom_file_ (const char *name)
15545 {
15546   FILE_BUF *fp;
15547
15548   /* Do partial setup of input buffer for the sake of generating
15549      early #line directives (when -g is in effect).  */
15550
15551   fp = &instack[++indepth];
15552   memset ((char *) fp, 0, sizeof (FILE_BUF));
15553   if (name == NULL)
15554     name = "";
15555   fp->nominal_fname = fp->fname = name;
15556 }
15557
15558 static void
15559 ffecom_close_include_ (FILE *f)
15560 {
15561   fclose (f);
15562
15563   indepth--;
15564   input_file_stack_tick++;
15565
15566   ffewhere_line_kill (instack[indepth].line);
15567   ffewhere_column_kill (instack[indepth].column);
15568 }
15569
15570 static int
15571 ffecom_decode_include_option_ (char *spec)
15572 {
15573   struct file_name_list *dirtmp;
15574
15575   if (! ignore_srcdir && !strcmp (spec, "-"))
15576     ignore_srcdir = 1;
15577   else
15578     {
15579       dirtmp = (struct file_name_list *)
15580         xmalloc (sizeof (struct file_name_list));
15581       dirtmp->next = 0;         /* New one goes on the end */
15582       dirtmp->fname = spec;
15583       dirtmp->got_name_map = 0;
15584       if (spec[0] == 0)
15585         error ("directory name must immediately follow -I");
15586       else
15587         append_include_chain (dirtmp, dirtmp);
15588     }
15589   return 1;
15590 }
15591
15592 /* Open INCLUDEd file.  */
15593
15594 static FILE *
15595 ffecom_open_include_ (char *name, ffewhereLine l, ffewhereColumn c)
15596 {
15597   char *fbeg = name;
15598   size_t flen = strlen (fbeg);
15599   struct file_name_list *search_start = include; /* Chain of dirs to search */
15600   struct file_name_list dsp[1]; /* First in chain, if #include "..." */
15601   struct file_name_list *searchptr = 0;
15602   char *fname;          /* Dynamically allocated fname buffer */
15603   FILE *f;
15604   FILE_BUF *fp;
15605
15606   if (flen == 0)
15607     return NULL;
15608
15609   dsp[0].fname = NULL;
15610
15611   /* If -I- was specified, don't search current dir, only spec'd ones. */
15612   if (!ignore_srcdir)
15613     {
15614       for (fp = &instack[indepth]; fp >= instack; fp--)
15615         {
15616           int n;
15617           char *ep;
15618           const char *nam;
15619
15620           if ((nam = fp->nominal_fname) != NULL)
15621             {
15622               /* Found a named file.  Figure out dir of the file,
15623                  and put it in front of the search list.  */
15624               dsp[0].next = search_start;
15625               search_start = dsp;
15626 #ifndef VMS
15627               ep = strrchr (nam, '/');
15628 #ifdef DIR_SEPARATOR
15629             if (ep == NULL) ep = strrchr (nam, DIR_SEPARATOR);
15630             else {
15631               char *tmp = strrchr (nam, DIR_SEPARATOR);
15632               if (tmp != NULL && tmp > ep) ep = tmp;
15633             }
15634 #endif
15635 #else                           /* VMS */
15636               ep = strrchr (nam, ']');
15637               if (ep == NULL) ep = strrchr (nam, '>');
15638               if (ep == NULL) ep = strrchr (nam, ':');
15639               if (ep != NULL) ep++;
15640 #endif                          /* VMS */
15641               if (ep != NULL)
15642                 {
15643                   n = ep - nam;
15644                   dsp[0].fname = (char *) xmalloc (n + 1);
15645                   strncpy (dsp[0].fname, nam, n);
15646                   dsp[0].fname[n] = '\0';
15647                   if (n + INCLUDE_LEN_FUDGE > max_include_len)
15648                     max_include_len = n + INCLUDE_LEN_FUDGE;
15649                 }
15650               else
15651                 dsp[0].fname = NULL; /* Current directory */
15652               dsp[0].got_name_map = 0;
15653               break;
15654             }
15655         }
15656     }
15657
15658   /* Allocate this permanently, because it gets stored in the definitions
15659      of macros.  */
15660   fname = xmalloc (max_include_len + flen + 4);
15661   /* + 2 above for slash and terminating null.  */
15662   /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED
15663      for g77 yet).  */
15664
15665   /* If specified file name is absolute, just open it.  */
15666
15667   if (*fbeg == '/'
15668 #ifdef DIR_SEPARATOR
15669       || *fbeg == DIR_SEPARATOR
15670 #endif
15671       )
15672     {
15673       strncpy (fname, (char *) fbeg, flen);
15674       fname[flen] = 0;
15675       f = open_include_file (fname, NULL);
15676     }
15677   else
15678     {
15679       f = NULL;
15680
15681       /* Search directory path, trying to open the file.
15682          Copy each filename tried into FNAME.  */
15683
15684       for (searchptr = search_start; searchptr; searchptr = searchptr->next)
15685         {
15686           if (searchptr->fname)
15687             {
15688               /* The empty string in a search path is ignored.
15689                  This makes it possible to turn off entirely
15690                  a standard piece of the list.  */
15691               if (searchptr->fname[0] == 0)
15692                 continue;
15693               strcpy (fname, skip_redundant_dir_prefix (searchptr->fname));
15694               if (fname[0] && fname[strlen (fname) - 1] != '/')
15695                 strcat (fname, "/");
15696               fname[strlen (fname) + flen] = 0;
15697             }
15698           else
15699             fname[0] = 0;
15700
15701           strncat (fname, fbeg, flen);
15702 #ifdef VMS
15703           /* Change this 1/2 Unix 1/2 VMS file specification into a
15704              full VMS file specification */
15705           if (searchptr->fname && (searchptr->fname[0] != 0))
15706             {
15707               /* Fix up the filename */
15708               hack_vms_include_specification (fname);
15709             }
15710           else
15711             {
15712               /* This is a normal VMS filespec, so use it unchanged.  */
15713               strncpy (fname, (char *) fbeg, flen);
15714               fname[flen] = 0;
15715 #if 0   /* Not for g77.  */
15716               /* if it's '#include filename', add the missing .h */
15717               if (strchr (fname, '.') == NULL)
15718                 strcat (fname, ".h");
15719 #endif
15720             }
15721 #endif /* VMS */
15722           f = open_include_file (fname, searchptr);
15723 #ifdef EACCES
15724           if (f == NULL && errno == EACCES)
15725             {
15726               print_containing_files (FFEBAD_severityWARNING);
15727               /* xgettext:no-c-format */
15728               ffebad_start_msg ("At %0, INCLUDE file %A exists, but is not readable",
15729                                 FFEBAD_severityWARNING);
15730               ffebad_string (fname);
15731               ffebad_here (0, l, c);
15732               ffebad_finish ();
15733             }
15734 #endif
15735           if (f != NULL)
15736             break;
15737         }
15738     }
15739
15740   if (f == NULL)
15741     {
15742       /* A file that was not found.  */
15743
15744       strncpy (fname, (char *) fbeg, flen);
15745       fname[flen] = 0;
15746       print_containing_files (ffebad_severity (FFEBAD_OPEN_INCLUDE));
15747       ffebad_start (FFEBAD_OPEN_INCLUDE);
15748       ffebad_here (0, l, c);
15749       ffebad_string (fname);
15750       ffebad_finish ();
15751     }
15752
15753   if (dsp[0].fname != NULL)
15754     free (dsp[0].fname);
15755
15756   if (f == NULL)
15757     return NULL;
15758
15759   if (indepth >= (INPUT_STACK_MAX - 1))
15760     {
15761       print_containing_files (FFEBAD_severityFATAL);
15762       /* xgettext:no-c-format */
15763       ffebad_start_msg ("At %0, INCLUDE nesting too deep",
15764                         FFEBAD_severityFATAL);
15765       ffebad_string (fname);
15766       ffebad_here (0, l, c);
15767       ffebad_finish ();
15768       return NULL;
15769     }
15770
15771   instack[indepth].line = ffewhere_line_use (l);
15772   instack[indepth].column = ffewhere_column_use (c);
15773
15774   fp = &instack[indepth + 1];
15775   memset ((char *) fp, 0, sizeof (FILE_BUF));
15776   fp->nominal_fname = fp->fname = fname;
15777   fp->dir = searchptr;
15778
15779   indepth++;
15780   input_file_stack_tick++;
15781
15782   return f;
15783 }
15784
15785 /**INDENT* (Do not reformat this comment even with -fca option.)
15786    Data-gathering files: Given the source file listed below, compiled with
15787    f2c I obtained the output file listed after that, and from the output
15788    file I derived the above code.
15789
15790 -------- (begin input file to f2c)
15791         implicit none
15792         character*10 A1,A2
15793         complex C1,C2
15794         integer I1,I2
15795         real R1,R2
15796         double precision D1,D2
15797 C
15798         call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2)
15799 c /
15800         call fooI(I1/I2)
15801         call fooR(R1/I1)
15802         call fooD(D1/I1)
15803         call fooC(C1/I1)
15804         call fooR(R1/R2)
15805         call fooD(R1/D1)
15806         call fooD(D1/D2)
15807         call fooD(D1/R1)
15808         call fooC(C1/C2)
15809         call fooC(C1/R1)
15810         call fooZ(C1/D1)
15811 c **
15812         call fooI(I1**I2)
15813         call fooR(R1**I1)
15814         call fooD(D1**I1)
15815         call fooC(C1**I1)
15816         call fooR(R1**R2)
15817         call fooD(R1**D1)
15818         call fooD(D1**D2)
15819         call fooD(D1**R1)
15820         call fooC(C1**C2)
15821         call fooC(C1**R1)
15822         call fooZ(C1**D1)
15823 c FFEINTRIN_impABS
15824         call fooR(ABS(R1))
15825 c FFEINTRIN_impACOS
15826         call fooR(ACOS(R1))
15827 c FFEINTRIN_impAIMAG
15828         call fooR(AIMAG(C1))
15829 c FFEINTRIN_impAINT
15830         call fooR(AINT(R1))
15831 c FFEINTRIN_impALOG
15832         call fooR(ALOG(R1))
15833 c FFEINTRIN_impALOG10
15834         call fooR(ALOG10(R1))
15835 c FFEINTRIN_impAMAX0
15836         call fooR(AMAX0(I1,I2))
15837 c FFEINTRIN_impAMAX1
15838         call fooR(AMAX1(R1,R2))
15839 c FFEINTRIN_impAMIN0
15840         call fooR(AMIN0(I1,I2))
15841 c FFEINTRIN_impAMIN1
15842         call fooR(AMIN1(R1,R2))
15843 c FFEINTRIN_impAMOD
15844         call fooR(AMOD(R1,R2))
15845 c FFEINTRIN_impANINT
15846         call fooR(ANINT(R1))
15847 c FFEINTRIN_impASIN
15848         call fooR(ASIN(R1))
15849 c FFEINTRIN_impATAN
15850         call fooR(ATAN(R1))
15851 c FFEINTRIN_impATAN2
15852         call fooR(ATAN2(R1,R2))
15853 c FFEINTRIN_impCABS
15854         call fooR(CABS(C1))
15855 c FFEINTRIN_impCCOS
15856         call fooC(CCOS(C1))
15857 c FFEINTRIN_impCEXP
15858         call fooC(CEXP(C1))
15859 c FFEINTRIN_impCHAR
15860         call fooA(CHAR(I1))
15861 c FFEINTRIN_impCLOG
15862         call fooC(CLOG(C1))
15863 c FFEINTRIN_impCONJG
15864         call fooC(CONJG(C1))
15865 c FFEINTRIN_impCOS
15866         call fooR(COS(R1))
15867 c FFEINTRIN_impCOSH
15868         call fooR(COSH(R1))
15869 c FFEINTRIN_impCSIN
15870         call fooC(CSIN(C1))
15871 c FFEINTRIN_impCSQRT
15872         call fooC(CSQRT(C1))
15873 c FFEINTRIN_impDABS
15874         call fooD(DABS(D1))
15875 c FFEINTRIN_impDACOS
15876         call fooD(DACOS(D1))
15877 c FFEINTRIN_impDASIN
15878         call fooD(DASIN(D1))
15879 c FFEINTRIN_impDATAN
15880         call fooD(DATAN(D1))
15881 c FFEINTRIN_impDATAN2
15882         call fooD(DATAN2(D1,D2))
15883 c FFEINTRIN_impDCOS
15884         call fooD(DCOS(D1))
15885 c FFEINTRIN_impDCOSH
15886         call fooD(DCOSH(D1))
15887 c FFEINTRIN_impDDIM
15888         call fooD(DDIM(D1,D2))
15889 c FFEINTRIN_impDEXP
15890         call fooD(DEXP(D1))
15891 c FFEINTRIN_impDIM
15892         call fooR(DIM(R1,R2))
15893 c FFEINTRIN_impDINT
15894         call fooD(DINT(D1))
15895 c FFEINTRIN_impDLOG
15896         call fooD(DLOG(D1))
15897 c FFEINTRIN_impDLOG10
15898         call fooD(DLOG10(D1))
15899 c FFEINTRIN_impDMAX1
15900         call fooD(DMAX1(D1,D2))
15901 c FFEINTRIN_impDMIN1
15902         call fooD(DMIN1(D1,D2))
15903 c FFEINTRIN_impDMOD
15904         call fooD(DMOD(D1,D2))
15905 c FFEINTRIN_impDNINT
15906         call fooD(DNINT(D1))
15907 c FFEINTRIN_impDPROD
15908         call fooD(DPROD(R1,R2))
15909 c FFEINTRIN_impDSIGN
15910         call fooD(DSIGN(D1,D2))
15911 c FFEINTRIN_impDSIN
15912         call fooD(DSIN(D1))
15913 c FFEINTRIN_impDSINH
15914         call fooD(DSINH(D1))
15915 c FFEINTRIN_impDSQRT
15916         call fooD(DSQRT(D1))
15917 c FFEINTRIN_impDTAN
15918         call fooD(DTAN(D1))
15919 c FFEINTRIN_impDTANH
15920         call fooD(DTANH(D1))
15921 c FFEINTRIN_impEXP
15922         call fooR(EXP(R1))
15923 c FFEINTRIN_impIABS
15924         call fooI(IABS(I1))
15925 c FFEINTRIN_impICHAR
15926         call fooI(ICHAR(A1))
15927 c FFEINTRIN_impIDIM
15928         call fooI(IDIM(I1,I2))
15929 c FFEINTRIN_impIDNINT
15930         call fooI(IDNINT(D1))
15931 c FFEINTRIN_impINDEX
15932         call fooI(INDEX(A1,A2))
15933 c FFEINTRIN_impISIGN
15934         call fooI(ISIGN(I1,I2))
15935 c FFEINTRIN_impLEN
15936         call fooI(LEN(A1))
15937 c FFEINTRIN_impLGE
15938         call fooL(LGE(A1,A2))
15939 c FFEINTRIN_impLGT
15940         call fooL(LGT(A1,A2))
15941 c FFEINTRIN_impLLE
15942         call fooL(LLE(A1,A2))
15943 c FFEINTRIN_impLLT
15944         call fooL(LLT(A1,A2))
15945 c FFEINTRIN_impMAX0
15946         call fooI(MAX0(I1,I2))
15947 c FFEINTRIN_impMAX1
15948         call fooI(MAX1(R1,R2))
15949 c FFEINTRIN_impMIN0
15950         call fooI(MIN0(I1,I2))
15951 c FFEINTRIN_impMIN1
15952         call fooI(MIN1(R1,R2))
15953 c FFEINTRIN_impMOD
15954         call fooI(MOD(I1,I2))
15955 c FFEINTRIN_impNINT
15956         call fooI(NINT(R1))
15957 c FFEINTRIN_impSIGN
15958         call fooR(SIGN(R1,R2))
15959 c FFEINTRIN_impSIN
15960         call fooR(SIN(R1))
15961 c FFEINTRIN_impSINH
15962         call fooR(SINH(R1))
15963 c FFEINTRIN_impSQRT
15964         call fooR(SQRT(R1))
15965 c FFEINTRIN_impTAN
15966         call fooR(TAN(R1))
15967 c FFEINTRIN_impTANH
15968         call fooR(TANH(R1))
15969 c FFEINTRIN_imp_CMPLX_C
15970         call fooC(cmplx(C1,C2))
15971 c FFEINTRIN_imp_CMPLX_D
15972         call fooZ(cmplx(D1,D2))
15973 c FFEINTRIN_imp_CMPLX_I
15974         call fooC(cmplx(I1,I2))
15975 c FFEINTRIN_imp_CMPLX_R
15976         call fooC(cmplx(R1,R2))
15977 c FFEINTRIN_imp_DBLE_C
15978         call fooD(dble(C1))
15979 c FFEINTRIN_imp_DBLE_D
15980         call fooD(dble(D1))
15981 c FFEINTRIN_imp_DBLE_I
15982         call fooD(dble(I1))
15983 c FFEINTRIN_imp_DBLE_R
15984         call fooD(dble(R1))
15985 c FFEINTRIN_imp_INT_C
15986         call fooI(int(C1))
15987 c FFEINTRIN_imp_INT_D
15988         call fooI(int(D1))
15989 c FFEINTRIN_imp_INT_I
15990         call fooI(int(I1))
15991 c FFEINTRIN_imp_INT_R
15992         call fooI(int(R1))
15993 c FFEINTRIN_imp_REAL_C
15994         call fooR(real(C1))
15995 c FFEINTRIN_imp_REAL_D
15996         call fooR(real(D1))
15997 c FFEINTRIN_imp_REAL_I
15998         call fooR(real(I1))
15999 c FFEINTRIN_imp_REAL_R
16000         call fooR(real(R1))
16001 c
16002 c FFEINTRIN_imp_INT_D:
16003 c
16004 c FFEINTRIN_specIDINT
16005         call fooI(IDINT(D1))
16006 c
16007 c FFEINTRIN_imp_INT_R:
16008 c
16009 c FFEINTRIN_specIFIX
16010         call fooI(IFIX(R1))
16011 c FFEINTRIN_specINT
16012         call fooI(INT(R1))
16013 c
16014 c FFEINTRIN_imp_REAL_D:
16015 c
16016 c FFEINTRIN_specSNGL
16017         call fooR(SNGL(D1))
16018 c
16019 c FFEINTRIN_imp_REAL_I:
16020 c
16021 c FFEINTRIN_specFLOAT
16022         call fooR(FLOAT(I1))
16023 c FFEINTRIN_specREAL
16024         call fooR(REAL(I1))
16025 c
16026         end
16027 -------- (end input file to f2c)
16028
16029 -------- (begin output from providing above input file as input to:
16030 --------  `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
16031 --------     -e "s:^#.*$::g"')
16032
16033 //  -- translated by f2c (version 19950223).
16034    You must link the resulting object file with the libraries:
16035         -lf2c -lm   (in that order)
16036 //
16037
16038
16039 // f2c.h  --  Standard Fortran to C header file //
16040
16041 ///  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
16042
16043         - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
16044
16045
16046
16047
16048 // F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems //
16049 // we assume short, float are OK //
16050 typedef long int // long int // integer;
16051 typedef char *address;
16052 typedef short int shortint;
16053 typedef float real;
16054 typedef double doublereal;
16055 typedef struct { real r, i; } complex;
16056 typedef struct { doublereal r, i; } doublecomplex;
16057 typedef long int // long int // logical;
16058 typedef short int shortlogical;
16059 typedef char logical1;
16060 typedef char integer1;
16061 // typedef long long longint; // // system-dependent //
16062
16063
16064
16065
16066 // Extern is for use with -E //
16067
16068
16069
16070
16071 // I/O stuff //
16072
16073
16074
16075
16076
16077
16078
16079
16080 typedef long int // int or long int // flag;
16081 typedef long int // int or long int // ftnlen;
16082 typedef long int // int or long int // ftnint;
16083
16084
16085 //external read, write//
16086 typedef struct
16087 {       flag cierr;
16088         ftnint ciunit;
16089         flag ciend;
16090         char *cifmt;
16091         ftnint cirec;
16092 } cilist;
16093
16094 //internal read, write//
16095 typedef struct
16096 {       flag icierr;
16097         char *iciunit;
16098         flag iciend;
16099         char *icifmt;
16100         ftnint icirlen;
16101         ftnint icirnum;
16102 } icilist;
16103
16104 //open//
16105 typedef struct
16106 {       flag oerr;
16107         ftnint ounit;
16108         char *ofnm;
16109         ftnlen ofnmlen;
16110         char *osta;
16111         char *oacc;
16112         char *ofm;
16113         ftnint orl;
16114         char *oblnk;
16115 } olist;
16116
16117 //close//
16118 typedef struct
16119 {       flag cerr;
16120         ftnint cunit;
16121         char *csta;
16122 } cllist;
16123
16124 //rewind, backspace, endfile//
16125 typedef struct
16126 {       flag aerr;
16127         ftnint aunit;
16128 } alist;
16129
16130 // inquire //
16131 typedef struct
16132 {       flag inerr;
16133         ftnint inunit;
16134         char *infile;
16135         ftnlen infilen;
16136         ftnint  *inex;  //parameters in standard's order//
16137         ftnint  *inopen;
16138         ftnint  *innum;
16139         ftnint  *innamed;
16140         char    *inname;
16141         ftnlen  innamlen;
16142         char    *inacc;
16143         ftnlen  inacclen;
16144         char    *inseq;
16145         ftnlen  inseqlen;
16146         char    *indir;
16147         ftnlen  indirlen;
16148         char    *infmt;
16149         ftnlen  infmtlen;
16150         char    *inform;
16151         ftnint  informlen;
16152         char    *inunf;
16153         ftnlen  inunflen;
16154         ftnint  *inrecl;
16155         ftnint  *innrec;
16156         char    *inblank;
16157         ftnlen  inblanklen;
16158 } inlist;
16159
16160
16161
16162 union Multitype {       // for multiple entry points //
16163         integer1 g;
16164         shortint h;
16165         integer i;
16166         // longint j; //
16167         real r;
16168         doublereal d;
16169         complex c;
16170         doublecomplex z;
16171         };
16172
16173 typedef union Multitype Multitype;
16174
16175 typedef long Long;      // No longer used; formerly in Namelist //
16176
16177 struct Vardesc {        // for Namelist //
16178         char *name;
16179         char *addr;
16180         ftnlen *dims;
16181         int  type;
16182         };
16183 typedef struct Vardesc Vardesc;
16184
16185 struct Namelist {
16186         char *name;
16187         Vardesc **vars;
16188         int nvars;
16189         };
16190 typedef struct Namelist Namelist;
16191
16192
16193
16194
16195
16196
16197
16198
16199 // procedure parameter types for -A and -C++ //
16200
16201
16202
16203
16204 typedef int // Unknown procedure type // (*U_fp)();
16205 typedef shortint (*J_fp)();
16206 typedef integer (*I_fp)();
16207 typedef real (*R_fp)();
16208 typedef doublereal (*D_fp)(), (*E_fp)();
16209 typedef // Complex // void  (*C_fp)();
16210 typedef // Double Complex // void  (*Z_fp)();
16211 typedef logical (*L_fp)();
16212 typedef shortlogical (*K_fp)();
16213 typedef // Character // void  (*H_fp)();
16214 typedef // Subroutine // int (*S_fp)();
16215
16216 // E_fp is for real functions when -R is not specified //
16217 typedef void  C_f;      // complex function //
16218 typedef void  H_f;      // character function //
16219 typedef void  Z_f;      // double complex function //
16220 typedef doublereal E_f; // real function with -R not specified //
16221
16222 // undef any lower-case symbols that your C compiler predefines, e.g.: //
16223
16224
16225 // (No such symbols should be defined in a strict ANSI C compiler.
16226    We can avoid trouble with f2c-translated code by using
16227    gcc -ansi.) //
16228
16229
16230
16231
16232
16233
16234
16235
16236
16237
16238
16239
16240
16241
16242
16243
16244
16245
16246
16247
16248
16249
16250
16251 // Main program // MAIN__()
16252 {
16253     // System generated locals //
16254     integer i__1;
16255     real r__1, r__2;
16256     doublereal d__1, d__2;
16257     complex q__1;
16258     doublecomplex z__1, z__2, z__3;
16259     logical L__1;
16260     char ch__1[1];
16261
16262     // Builtin functions //
16263     void c_div();
16264     integer pow_ii();
16265     double pow_ri(), pow_di();
16266     void pow_ci();
16267     double pow_dd();
16268     void pow_zz();
16269     double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
16270             asin(), atan(), atan2(), c_abs();
16271     void c_cos(), c_exp(), c_log(), r_cnjg();
16272     double cos(), cosh();
16273     void c_sin(), c_sqrt();
16274     double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
16275             d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
16276     integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
16277     logical l_ge(), l_gt(), l_le(), l_lt();
16278     integer i_nint();
16279     double r_sign();
16280
16281     // Local variables //
16282     extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
16283             fool_(), fooz_(), getem_();
16284     static char a1[10], a2[10];
16285     static complex c1, c2;
16286     static doublereal d1, d2;
16287     static integer i1, i2;
16288     static real r1, r2;
16289
16290
16291     getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L);
16292 // / //
16293     i__1 = i1 / i2;
16294     fooi_(&i__1);
16295     r__1 = r1 / i1;
16296     foor_(&r__1);
16297     d__1 = d1 / i1;
16298     food_(&d__1);
16299     d__1 = (doublereal) i1;
16300     q__1.r = c1.r / d__1, q__1.i = c1.i / d__1;
16301     fooc_(&q__1);
16302     r__1 = r1 / r2;
16303     foor_(&r__1);
16304     d__1 = r1 / d1;
16305     food_(&d__1);
16306     d__1 = d1 / d2;
16307     food_(&d__1);
16308     d__1 = d1 / r1;
16309     food_(&d__1);
16310     c_div(&q__1, &c1, &c2);
16311     fooc_(&q__1);
16312     q__1.r = c1.r / r1, q__1.i = c1.i / r1;
16313     fooc_(&q__1);
16314     z__1.r = c1.r / d1, z__1.i = c1.i / d1;
16315     fooz_(&z__1);
16316 // ** //
16317     i__1 = pow_ii(&i1, &i2);
16318     fooi_(&i__1);
16319     r__1 = pow_ri(&r1, &i1);
16320     foor_(&r__1);
16321     d__1 = pow_di(&d1, &i1);
16322     food_(&d__1);
16323     pow_ci(&q__1, &c1, &i1);
16324     fooc_(&q__1);
16325     d__1 = (doublereal) r1;
16326     d__2 = (doublereal) r2;
16327     r__1 = pow_dd(&d__1, &d__2);
16328     foor_(&r__1);
16329     d__2 = (doublereal) r1;
16330     d__1 = pow_dd(&d__2, &d1);
16331     food_(&d__1);
16332     d__1 = pow_dd(&d1, &d2);
16333     food_(&d__1);
16334     d__2 = (doublereal) r1;
16335     d__1 = pow_dd(&d1, &d__2);
16336     food_(&d__1);
16337     z__2.r = c1.r, z__2.i = c1.i;
16338     z__3.r = c2.r, z__3.i = c2.i;
16339     pow_zz(&z__1, &z__2, &z__3);
16340     q__1.r = z__1.r, q__1.i = z__1.i;
16341     fooc_(&q__1);
16342     z__2.r = c1.r, z__2.i = c1.i;
16343     z__3.r = r1, z__3.i = 0.;
16344     pow_zz(&z__1, &z__2, &z__3);
16345     q__1.r = z__1.r, q__1.i = z__1.i;
16346     fooc_(&q__1);
16347     z__2.r = c1.r, z__2.i = c1.i;
16348     z__3.r = d1, z__3.i = 0.;
16349     pow_zz(&z__1, &z__2, &z__3);
16350     fooz_(&z__1);
16351 // FFEINTRIN_impABS //
16352     r__1 = (doublereal)((  r1  ) >= 0 ? (  r1  ) : -(  r1  ))  ;
16353     foor_(&r__1);
16354 // FFEINTRIN_impACOS //
16355     r__1 = acos(r1);
16356     foor_(&r__1);
16357 // FFEINTRIN_impAIMAG //
16358     r__1 = r_imag(&c1);
16359     foor_(&r__1);
16360 // FFEINTRIN_impAINT //
16361     r__1 = r_int(&r1);
16362     foor_(&r__1);
16363 // FFEINTRIN_impALOG //
16364     r__1 = log(r1);
16365     foor_(&r__1);
16366 // FFEINTRIN_impALOG10 //
16367     r__1 = r_lg10(&r1);
16368     foor_(&r__1);
16369 // FFEINTRIN_impAMAX0 //
16370     r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16371     foor_(&r__1);
16372 // FFEINTRIN_impAMAX1 //
16373     r__1 = (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16374     foor_(&r__1);
16375 // FFEINTRIN_impAMIN0 //
16376     r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16377     foor_(&r__1);
16378 // FFEINTRIN_impAMIN1 //
16379     r__1 = (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16380     foor_(&r__1);
16381 // FFEINTRIN_impAMOD //
16382     r__1 = r_mod(&r1, &r2);
16383     foor_(&r__1);
16384 // FFEINTRIN_impANINT //
16385     r__1 = r_nint(&r1);
16386     foor_(&r__1);
16387 // FFEINTRIN_impASIN //
16388     r__1 = asin(r1);
16389     foor_(&r__1);
16390 // FFEINTRIN_impATAN //
16391     r__1 = atan(r1);
16392     foor_(&r__1);
16393 // FFEINTRIN_impATAN2 //
16394     r__1 = atan2(r1, r2);
16395     foor_(&r__1);
16396 // FFEINTRIN_impCABS //
16397     r__1 = c_abs(&c1);
16398     foor_(&r__1);
16399 // FFEINTRIN_impCCOS //
16400     c_cos(&q__1, &c1);
16401     fooc_(&q__1);
16402 // FFEINTRIN_impCEXP //
16403     c_exp(&q__1, &c1);
16404     fooc_(&q__1);
16405 // FFEINTRIN_impCHAR //
16406     *(unsigned char *)&ch__1[0] = i1;
16407     fooa_(ch__1, 1L);
16408 // FFEINTRIN_impCLOG //
16409     c_log(&q__1, &c1);
16410     fooc_(&q__1);
16411 // FFEINTRIN_impCONJG //
16412     r_cnjg(&q__1, &c1);
16413     fooc_(&q__1);
16414 // FFEINTRIN_impCOS //
16415     r__1 = cos(r1);
16416     foor_(&r__1);
16417 // FFEINTRIN_impCOSH //
16418     r__1 = cosh(r1);
16419     foor_(&r__1);
16420 // FFEINTRIN_impCSIN //
16421     c_sin(&q__1, &c1);
16422     fooc_(&q__1);
16423 // FFEINTRIN_impCSQRT //
16424     c_sqrt(&q__1, &c1);
16425     fooc_(&q__1);
16426 // FFEINTRIN_impDABS //
16427     d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ;
16428     food_(&d__1);
16429 // FFEINTRIN_impDACOS //
16430     d__1 = acos(d1);
16431     food_(&d__1);
16432 // FFEINTRIN_impDASIN //
16433     d__1 = asin(d1);
16434     food_(&d__1);
16435 // FFEINTRIN_impDATAN //
16436     d__1 = atan(d1);
16437     food_(&d__1);
16438 // FFEINTRIN_impDATAN2 //
16439     d__1 = atan2(d1, d2);
16440     food_(&d__1);
16441 // FFEINTRIN_impDCOS //
16442     d__1 = cos(d1);
16443     food_(&d__1);
16444 // FFEINTRIN_impDCOSH //
16445     d__1 = cosh(d1);
16446     food_(&d__1);
16447 // FFEINTRIN_impDDIM //
16448     d__1 = d_dim(&d1, &d2);
16449     food_(&d__1);
16450 // FFEINTRIN_impDEXP //
16451     d__1 = exp(d1);
16452     food_(&d__1);
16453 // FFEINTRIN_impDIM //
16454     r__1 = r_dim(&r1, &r2);
16455     foor_(&r__1);
16456 // FFEINTRIN_impDINT //
16457     d__1 = d_int(&d1);
16458     food_(&d__1);
16459 // FFEINTRIN_impDLOG //
16460     d__1 = log(d1);
16461     food_(&d__1);
16462 // FFEINTRIN_impDLOG10 //
16463     d__1 = d_lg10(&d1);
16464     food_(&d__1);
16465 // FFEINTRIN_impDMAX1 //
16466     d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ;
16467     food_(&d__1);
16468 // FFEINTRIN_impDMIN1 //
16469     d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ;
16470     food_(&d__1);
16471 // FFEINTRIN_impDMOD //
16472     d__1 = d_mod(&d1, &d2);
16473     food_(&d__1);
16474 // FFEINTRIN_impDNINT //
16475     d__1 = d_nint(&d1);
16476     food_(&d__1);
16477 // FFEINTRIN_impDPROD //
16478     d__1 = (doublereal) r1 * r2;
16479     food_(&d__1);
16480 // FFEINTRIN_impDSIGN //
16481     d__1 = d_sign(&d1, &d2);
16482     food_(&d__1);
16483 // FFEINTRIN_impDSIN //
16484     d__1 = sin(d1);
16485     food_(&d__1);
16486 // FFEINTRIN_impDSINH //
16487     d__1 = sinh(d1);
16488     food_(&d__1);
16489 // FFEINTRIN_impDSQRT //
16490     d__1 = sqrt(d1);
16491     food_(&d__1);
16492 // FFEINTRIN_impDTAN //
16493     d__1 = tan(d1);
16494     food_(&d__1);
16495 // FFEINTRIN_impDTANH //
16496     d__1 = tanh(d1);
16497     food_(&d__1);
16498 // FFEINTRIN_impEXP //
16499     r__1 = exp(r1);
16500     foor_(&r__1);
16501 // FFEINTRIN_impIABS //
16502     i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ;
16503     fooi_(&i__1);
16504 // FFEINTRIN_impICHAR //
16505     i__1 = *(unsigned char *)a1;
16506     fooi_(&i__1);
16507 // FFEINTRIN_impIDIM //
16508     i__1 = i_dim(&i1, &i2);
16509     fooi_(&i__1);
16510 // FFEINTRIN_impIDNINT //
16511     i__1 = i_dnnt(&d1);
16512     fooi_(&i__1);
16513 // FFEINTRIN_impINDEX //
16514     i__1 = i_indx(a1, a2, 10L, 10L);
16515     fooi_(&i__1);
16516 // FFEINTRIN_impISIGN //
16517     i__1 = i_sign(&i1, &i2);
16518     fooi_(&i__1);
16519 // FFEINTRIN_impLEN //
16520     i__1 = i_len(a1, 10L);
16521     fooi_(&i__1);
16522 // FFEINTRIN_impLGE //
16523     L__1 = l_ge(a1, a2, 10L, 10L);
16524     fool_(&L__1);
16525 // FFEINTRIN_impLGT //
16526     L__1 = l_gt(a1, a2, 10L, 10L);
16527     fool_(&L__1);
16528 // FFEINTRIN_impLLE //
16529     L__1 = l_le(a1, a2, 10L, 10L);
16530     fool_(&L__1);
16531 // FFEINTRIN_impLLT //
16532     L__1 = l_lt(a1, a2, 10L, 10L);
16533     fool_(&L__1);
16534 // FFEINTRIN_impMAX0 //
16535     i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16536     fooi_(&i__1);
16537 // FFEINTRIN_impMAX1 //
16538     i__1 = (integer) (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16539     fooi_(&i__1);
16540 // FFEINTRIN_impMIN0 //
16541     i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16542     fooi_(&i__1);
16543 // FFEINTRIN_impMIN1 //
16544     i__1 = (integer) (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16545     fooi_(&i__1);
16546 // FFEINTRIN_impMOD //
16547     i__1 = i1 % i2;
16548     fooi_(&i__1);
16549 // FFEINTRIN_impNINT //
16550     i__1 = i_nint(&r1);
16551     fooi_(&i__1);
16552 // FFEINTRIN_impSIGN //
16553     r__1 = r_sign(&r1, &r2);
16554     foor_(&r__1);
16555 // FFEINTRIN_impSIN //
16556     r__1 = sin(r1);
16557     foor_(&r__1);
16558 // FFEINTRIN_impSINH //
16559     r__1 = sinh(r1);
16560     foor_(&r__1);
16561 // FFEINTRIN_impSQRT //
16562     r__1 = sqrt(r1);
16563     foor_(&r__1);
16564 // FFEINTRIN_impTAN //
16565     r__1 = tan(r1);
16566     foor_(&r__1);
16567 // FFEINTRIN_impTANH //
16568     r__1 = tanh(r1);
16569     foor_(&r__1);
16570 // FFEINTRIN_imp_CMPLX_C //
16571     r__1 = c1.r;
16572     r__2 = c2.r;
16573     q__1.r = r__1, q__1.i = r__2;
16574     fooc_(&q__1);
16575 // FFEINTRIN_imp_CMPLX_D //
16576     z__1.r = d1, z__1.i = d2;
16577     fooz_(&z__1);
16578 // FFEINTRIN_imp_CMPLX_I //
16579     r__1 = (real) i1;
16580     r__2 = (real) i2;
16581     q__1.r = r__1, q__1.i = r__2;
16582     fooc_(&q__1);
16583 // FFEINTRIN_imp_CMPLX_R //
16584     q__1.r = r1, q__1.i = r2;
16585     fooc_(&q__1);
16586 // FFEINTRIN_imp_DBLE_C //
16587     d__1 = (doublereal) c1.r;
16588     food_(&d__1);
16589 // FFEINTRIN_imp_DBLE_D //
16590     d__1 = d1;
16591     food_(&d__1);
16592 // FFEINTRIN_imp_DBLE_I //
16593     d__1 = (doublereal) i1;
16594     food_(&d__1);
16595 // FFEINTRIN_imp_DBLE_R //
16596     d__1 = (doublereal) r1;
16597     food_(&d__1);
16598 // FFEINTRIN_imp_INT_C //
16599     i__1 = (integer) c1.r;
16600     fooi_(&i__1);
16601 // FFEINTRIN_imp_INT_D //
16602     i__1 = (integer) d1;
16603     fooi_(&i__1);
16604 // FFEINTRIN_imp_INT_I //
16605     i__1 = i1;
16606     fooi_(&i__1);
16607 // FFEINTRIN_imp_INT_R //
16608     i__1 = (integer) r1;
16609     fooi_(&i__1);
16610 // FFEINTRIN_imp_REAL_C //
16611     r__1 = c1.r;
16612     foor_(&r__1);
16613 // FFEINTRIN_imp_REAL_D //
16614     r__1 = (real) d1;
16615     foor_(&r__1);
16616 // FFEINTRIN_imp_REAL_I //
16617     r__1 = (real) i1;
16618     foor_(&r__1);
16619 // FFEINTRIN_imp_REAL_R //
16620     r__1 = r1;
16621     foor_(&r__1);
16622
16623 // FFEINTRIN_imp_INT_D: //
16624
16625 // FFEINTRIN_specIDINT //
16626     i__1 = (integer) d1;
16627     fooi_(&i__1);
16628
16629 // FFEINTRIN_imp_INT_R: //
16630
16631 // FFEINTRIN_specIFIX //
16632     i__1 = (integer) r1;
16633     fooi_(&i__1);
16634 // FFEINTRIN_specINT //
16635     i__1 = (integer) r1;
16636     fooi_(&i__1);
16637
16638 // FFEINTRIN_imp_REAL_D: //
16639
16640 // FFEINTRIN_specSNGL //
16641     r__1 = (real) d1;
16642     foor_(&r__1);
16643
16644 // FFEINTRIN_imp_REAL_I: //
16645
16646 // FFEINTRIN_specFLOAT //
16647     r__1 = (real) i1;
16648     foor_(&r__1);
16649 // FFEINTRIN_specREAL //
16650     r__1 = (real) i1;
16651     foor_(&r__1);
16652
16653 } // MAIN__ //
16654
16655 -------- (end output file from f2c)
16656
16657 */