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 void ffecom_init_decl_processing PARAMS ((void));
 265 static tree ffecom_arglist_expr_ (const char *argstring, ffebld args);
 266 static tree ffecom_widest_expr_type_ (ffebld list);
 267 static bool ffecom_overlap_ (tree dest_decl, tree dest_offset,
 268                              tree dest_size, tree source_tree,
 269                              ffebld source, bool scalar_arg);
 270 static bool ffecom_args_overlapping_ (tree dest_tree, ffebld dest,
 271                                       tree args, tree callee_commons,
 272                                       bool scalar_args);
 273 static tree ffecom_build_f2c_string_ (int i, const char *s);
 274 static tree ffecom_call_ (tree fn, ffeinfoKindtype kt,
 275                           bool is_f2c_complex, tree type,
 276                           tree args, tree dest_tree,
 277                           ffebld dest, bool *dest_used,
 278                           tree callee_commons, bool scalar_args, tree hook);
 279 static tree ffecom_call_binop_ (tree fn, ffeinfoKindtype kt,
 280                                 bool is_f2c_complex, tree type,
 281                                 ffebld left, ffebld right,
 282                                 tree dest_tree, ffebld dest,
 283                                 bool *dest_used, tree callee_commons,
 284                                 bool scalar_args, bool ref, tree hook);
 285 static void ffecom_char_args_x_ (tree *xitem, tree *length,
 286                                  ffebld expr, bool with_null);
 287 static tree ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy);
 288 static tree ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s);
 289 static ffecomConcatList_
 290   ffecom_concat_list_gather_ (ffecomConcatList_ catlist,
 291                               ffebld expr,
 292                               ffetargetCharacterSize max);
 293 static void ffecom_concat_list_kill_ (ffecomConcatList_ catlist);
 294 static ffecomConcatList_ ffecom_concat_list_new_ (ffebld expr,
 295                                                 ffetargetCharacterSize max);
 296 static void ffecom_debug_kludge_ (tree aggr, const char *aggr_type,
 297                                   ffesymbol member, tree member_type,
 298                                   ffetargetOffset offset);
 299 static void ffecom_do_entry_ (ffesymbol fn, int entrynum);
 300 static tree ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
 301                           bool *dest_used, bool assignp, bool widenp);
 302 static tree ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
 303                                     ffebld dest, bool *dest_used);
 304 static tree ffecom_expr_power_integer_ (ffebld expr);
 305 static void ffecom_expr_transform_ (ffebld expr);
 306 static void ffecom_f2c_make_type_ (tree *type, int tcode, const char *name);
 307 static void ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
 308                                       int code);
 309 static ffeglobal ffecom_finish_global_ (ffeglobal global);
 310 static ffesymbol ffecom_finish_symbol_transform_ (ffesymbol s);
 311 static tree ffecom_get_appended_identifier_ (char us, const char *text);
 312 static tree ffecom_get_external_identifier_ (ffesymbol s);
 313 static tree ffecom_get_identifier_ (const char *text);
 314 static tree ffecom_gen_sfuncdef_ (ffesymbol s,
 315                                   ffeinfoBasictype bt,
 316                                   ffeinfoKindtype kt);
 317 static const char *ffecom_gfrt_args_ (ffecomGfrt ix);
 318 static tree ffecom_gfrt_tree_ (ffecomGfrt ix);
 319 static tree ffecom_init_zero_ (tree decl);
 320 static tree ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
 321                                      tree *maybe_tree);
 322 static tree ffecom_intrinsic_len_ (ffebld expr);
 323 static void ffecom_let_char_ (tree dest_tree,
 324                               tree dest_length,
 325                               ffetargetCharacterSize dest_size,
 326                               ffebld source);
 327 static void ffecom_make_gfrt_ (ffecomGfrt ix);
 328 static void ffecom_member_phase1_ (ffestorag mst, ffestorag st);
 329 static void ffecom_member_phase2_ (ffestorag mst, ffestorag st);
 330 static void ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size,
 331                                       ffebld source);
 332 static void ffecom_push_dummy_decls_ (ffebld dumlist,
 333                                       bool stmtfunc);
 334 static void ffecom_start_progunit_ (void);
 335 static ffesymbol ffecom_sym_transform_ (ffesymbol s);
 336 static ffesymbol ffecom_sym_transform_assign_ (ffesymbol s);
 337 static void ffecom_transform_common_ (ffesymbol s);
 338 static void ffecom_transform_equiv_ (ffestorag st);
 339 static tree ffecom_transform_namelist_ (ffesymbol s);
 340 static void ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
 341                                        tree t);
 342 static void ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
 343                                        tree *size, tree tree);
 344 static tree ffecom_tree_divide_ (tree tree_type, tree left, tree right,
 345                                  tree dest_tree, ffebld dest,
 346                                  bool *dest_used, tree hook);
 347 static tree ffecom_type_localvar_ (ffesymbol s,
 348                                    ffeinfoBasictype bt,
 349                                    ffeinfoKindtype kt);
 350 static tree ffecom_type_namelist_ (void);
 351 static tree ffecom_type_vardesc_ (void);
 352 static tree ffecom_vardesc_ (ffebld expr);
 353 static tree ffecom_vardesc_array_ (ffesymbol s);
 354 static tree ffecom_vardesc_dims_ (ffesymbol s);
 355 static tree ffecom_convert_narrow_ (tree type, tree expr);
 356 static tree ffecom_convert_widen_ (tree type, tree expr);
 357
 358 /* These are static functions that parallel those found in the C front
 359    end and thus have the same names.  */
 360
 361 static tree bison_rule_compstmt_ (void);
 362 static void bison_rule_pushlevel_ (void);
 363 static void delete_block (tree block);
 364 static int duplicate_decls (tree newdecl, tree olddecl);
 365 static void finish_decl (tree decl, tree init, bool is_top_level);
 366 static void finish_function (int nested);
 367 static const char *ffe_printable_name (tree decl, int v);
 368 static tree lookup_name_current_level (tree name);
 369 static struct binding_level *make_binding_level (void);
 370 static void pop_f_function_context (void);
 371 static void push_f_function_context (void);
 372 static void push_parm_decl (tree parm);
 373 static tree pushdecl_top_level (tree decl);
 374 static int kept_level_p (void);
 375 static tree storedecls (tree decls);
 376 static void store_parm_decls (int is_main_program);
 377 static tree start_decl (tree decl, bool is_top_level);
 378 static void start_function (tree name, tree type, int nested, int public);
 379 static void ffecom_file_ (const char *name);
 380 static void ffecom_close_include_ (FILE *f);
 381 static int ffecom_decode_include_option_ (char *spec);
 382 static FILE *ffecom_open_include_ (char *name, ffewhereLine l,
 383                                    ffewhereColumn c);
 384
 385 /* Static objects accessed by functions in this module. */
 386
 387 static ffesymbol ffecom_primary_entry_ = NULL;
 388 static ffesymbol ffecom_nested_entry_ = NULL;
 389 static ffeinfoKind ffecom_primary_entry_kind_;
 390 static bool ffecom_primary_entry_is_proc_;
 391 static tree ffecom_outer_function_decl_;
 392 static tree ffecom_previous_function_decl_;
 393 static tree ffecom_which_entrypoint_decl_;
 394 static tree ffecom_float_zero_ = NULL_TREE;
 395 static tree ffecom_float_half_ = NULL_TREE;
 396 static tree ffecom_double_zero_ = NULL_TREE;
 397 static tree ffecom_double_half_ = NULL_TREE;
 398 static tree ffecom_func_result_;/* For functions. */
 399 static tree ffecom_func_length_;/* For CHARACTER fns. */
 400 static ffebld ffecom_list_blockdata_;
 401 static ffebld ffecom_list_common_;
 402 static ffebld ffecom_master_arglist_;
 403 static ffeinfoBasictype ffecom_master_bt_;
 404 static ffeinfoKindtype ffecom_master_kt_;
 405 static ffetargetCharacterSize ffecom_master_size_;
 406 static int ffecom_num_fns_ = 0;
 407 static int ffecom_num_entrypoints_ = 0;
 408 static bool ffecom_is_altreturning_ = FALSE;
 409 static tree ffecom_multi_type_node_;
 410 static tree ffecom_multi_retval_;
 411 static tree
 412   ffecom_multi_fields_[FFEINFO_basictype][FFEINFO_kindtype];
 413 static bool ffecom_member_namelisted_;  /* _member_phase1_ namelisted? */
 414 static bool ffecom_doing_entry_ = FALSE;
 415 static bool ffecom_transform_only_dummies_ = FALSE;
 416 static int ffecom_typesize_pointer_;
 417 static int ffecom_typesize_integer1_;
 418
 419 /* Holds pointer-to-function expressions.  */
 420
 421 static tree ffecom_gfrt_[FFECOM_gfrt]
 422 =
 423 {
 424 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NULL_TREE,
 425 #include "com-rt.def"
 426 #undef DEFGFRT
 427 };
 428
 429 /* Holds the external names of the functions.  */
 430
 431 static const char *const ffecom_gfrt_name_[FFECOM_gfrt]
 432 =
 433 {
 434 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NAME,
 435 #include "com-rt.def"
 436 #undef DEFGFRT
 437 };
 438
 439 /* Whether the function returns.  */
 440
 441 static const bool ffecom_gfrt_volatile_[FFECOM_gfrt]
 442 =
 443 {
 444 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) VOLATILE,
 445 #include "com-rt.def"
 446 #undef DEFGFRT
 447 };
 448
 449 /* Whether the function returns type complex.  */
 450
 451 static const bool ffecom_gfrt_complex_[FFECOM_gfrt]
 452 =
 453 {
 454 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) COMPLEX,
 455 #include "com-rt.def"
 456 #undef DEFGFRT
 457 };
 458
 459 /* Whether the function is const
 460    (i.e., has no side effects and only depends on its arguments).  */
 461
 462 static const bool ffecom_gfrt_const_[FFECOM_gfrt]
 463 =
 464 {
 465 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) CONST,
 466 #include "com-rt.def"
 467 #undef DEFGFRT
 468 };
 469
 470 /* Type code for the function return value.  */
 471
 472 static const ffecomRttype_ ffecom_gfrt_type_[FFECOM_gfrt]
 473 =
 474 {
 475 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) TYPE,
 476 #include "com-rt.def"
 477 #undef DEFGFRT
 478 };
 479
 480 /* String of codes for the function's arguments.  */
 481
 482 static const char *const ffecom_gfrt_argstring_[FFECOM_gfrt]
 483 =
 484 {
 485 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) ARGS,
 486 #include "com-rt.def"
 487 #undef DEFGFRT
 488 };
 489
 490 /* Internal macros. */
 491
 492 /* We let tm.h override the types used here, to handle trivial differences
 493    such as the choice of unsigned int or long unsigned int for size_t.
 494    When machines start needing nontrivial differences in the size type,
 495    it would be best to do something here to figure out automatically
 496    from other information what type to use.  */
 497
 498 #ifndef SIZE_TYPE
 499 #define SIZE_TYPE "long unsigned int"
 500 #endif
 501
 502 #define ffecom_concat_list_count_(catlist) ((catlist).count)
 503 #define ffecom_concat_list_expr_(catlist,i) ((catlist).exprs[(i)])
 504 #define ffecom_concat_list_maxlen_(catlist) ((catlist).maxlen)
 505 #define ffecom_concat_list_minlen_(catlist) ((catlist).minlen)
 506
 507 #define ffecom_char_args_(i,l,e) ffecom_char_args_x_((i),(l),(e),FALSE)
 508 #define ffecom_char_args_with_null_(i,l,e) ffecom_char_args_x_((i),(l),(e),TRUE)
 509
 510 /* For each binding contour we allocate a binding_level structure
 511  * which records the names defined in that contour.
 512  * Contours include:
 513  *  0) the global one
 514  *  1) one for each function definition,
 515  *     where internal declarations of the parameters appear.
 516  *
 517  * The current meaning of a name can be found by searching the levels from
 518  * the current one out to the global one.
 519  */
 520
 521 /* Note that the information in the `names' component of the global contour
 522    is duplicated in the IDENTIFIER_GLOBAL_VALUEs of all identifiers.  */
 523
 524 struct binding_level
 525   {
 526     /* A chain of _DECL nodes for all variables, constants, functions,
 527        and typedef types.  These are in the reverse of the order supplied.
 528      */
 529     tree names;
 530
 531     /* For each level (except not the global one),
 532        a chain of BLOCK nodes for all the levels
 533        that were entered and exited one level down.  */
 534     tree blocks;
 535
 536     /* The BLOCK node for this level, if one has been preallocated.
 537        If 0, the BLOCK is allocated (if needed) when the level is popped.  */
 538     tree this_block;
 539
 540     /* The binding level which this one is contained in (inherits from).  */
 541     struct binding_level *level_chain;
 542
 543     /* 0: no ffecom_prepare_* functions called at this level yet;
 544        1: ffecom_prepare* functions called, except not ffecom_prepare_end;
 545        2: ffecom_prepare_end called.  */
 546     int prep_state;
 547   };
 548
 549 #define NULL_BINDING_LEVEL (struct binding_level *) NULL
 550
 551 /* The binding level currently in effect.  */
 552
 553 static struct binding_level *current_binding_level;
 554
 555 /* A chain of binding_level structures awaiting reuse.  */
 556
 557 static struct binding_level *free_binding_level;
 558
 559 /* The outermost binding level, for names of file scope.
 560    This is created when the compiler is started and exists
 561    through the entire run.  */
 562
 563 static struct binding_level *global_binding_level;
 564
 565 /* Binding level structures are initialized by copying this one.  */
 566
 567 static const struct binding_level clear_binding_level
 568 =
 569 {NULL, NULL, NULL, NULL_BINDING_LEVEL, 0};
 570
 571 /* Language-dependent contents of an identifier.  */
 572
 573 struct lang_identifier
 574   {
 575     struct tree_identifier ignore;
 576     tree global_value, local_value, label_value;
 577     bool invented;
 578   };
 579
 580 /* Macros for access to language-specific slots in an identifier.  */
 581 /* Each of these slots contains a DECL node or null.  */
 582
 583 /* This represents the value which the identifier has in the
 584    file-scope namespace.  */
 585 #define IDENTIFIER_GLOBAL_VALUE(NODE)   \
 586   (((struct lang_identifier *)(NODE))->global_value)
 587 /* This represents the value which the identifier has in the current
 588    scope.  */
 589 #define IDENTIFIER_LOCAL_VALUE(NODE)    \
 590   (((struct lang_identifier *)(NODE))->local_value)
 591 /* This represents the value which the identifier has as a label in
 592    the current label scope.  */
 593 #define IDENTIFIER_LABEL_VALUE(NODE)    \
 594   (((struct lang_identifier *)(NODE))->label_value)
 595 /* This is nonzero if the identifier was "made up" by g77 code.  */
 596 #define IDENTIFIER_INVENTED(NODE)       \
 597   (((struct lang_identifier *)(NODE))->invented)
 598
 599 /* In identifiers, C uses the following fields in a special way:
 600    TREE_PUBLIC        to record that there was a previous local extern decl.
 601    TREE_USED          to record that such a decl was used.
 602    TREE_ADDRESSABLE   to record that the address of such a decl was used.  */
 603
 604 /* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function
 605    that have names.  Here so we can clear out their names' definitions
 606    at the end of the function.  */
 607
 608 static tree named_labels;
 609
 610 /* A list of LABEL_DECLs from outer contexts that are currently shadowed.  */
 611
 612 static tree shadowed_labels;
 613 \f
 614 /* Return the subscript expression, modified to do range-checking.
 615
 616    `array' is the array to be checked against.
 617    `element' is the subscript expression to check.
 618    `dim' is the dimension number (starting at 0).
 619    `total_dims' is the total number of dimensions (0 for CHARACTER substring).
 620 */
 621
 622 static tree
 623 ffecom_subscript_check_ (tree array, tree element, int dim, int total_dims,
 624                          const char *array_name)
 625 {
 626   tree low = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
 627   tree high = TYPE_MAX_VALUE (TYPE_DOMAIN (array));
 628   tree cond;
 629   tree die;
 630   tree args;
 631
 632   if (element == error_mark_node)
 633     return element;
 634
 635   if (TREE_TYPE (low) != TREE_TYPE (element))
 636     {
 637       if (TYPE_PRECISION (TREE_TYPE (low))
 638           > TYPE_PRECISION (TREE_TYPE (element)))
 639         element = convert (TREE_TYPE (low), element);
 640       else
 641         {
 642           low = convert (TREE_TYPE (element), low);
 643           if (high)
 644             high = convert (TREE_TYPE (element), high);
 645         }
 646     }
 647
 648   element = ffecom_save_tree (element);
 649   if (total_dims == 0)
 650     {
 651       /* Special handling for substring range checks.  Fortran allows the
 652          end subscript < begin subscript, which means that expressions like
 653        string(1:0) are valid (and yield a null string).  In view of this,
 654        enforce two simpler conditions:
 655           1) element<=high for end-substring;
 656           2) element>=low for start-substring.
 657        Run-time character movement will enforce remaining conditions.
 658
 659        More complicated checks would be better, but present structure only
 660        provides one index element at a time, so it is not possible to
 661        enforce a check of both i and j in string(i:j).  If it were, the
 662        complete set of rules would read,
 663          if ( ((j<i) && ((low<=i<=high) || (low<=j<=high))) ||
 664               ((low<=i<=high) && (low<=j<=high)) )
 665            ok ;
 666          else
 667            range error ;
 668       */
 669       if (dim)
 670         cond = ffecom_2 (LE_EXPR, integer_type_node, element, high);
 671       else
 672         cond = ffecom_2 (LE_EXPR, integer_type_node, low, element);
 673     }
 674   else
 675     {
 676       /* Array reference substring range checking.  */
 677
 678       cond = ffecom_2 (LE_EXPR, integer_type_node,
 679                      low,
 680                      element);
 681       if (high)
 682         {
 683           cond = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
 684                          cond,
 685                          ffecom_2 (LE_EXPR, integer_type_node,
 686                                    element,
 687                                    high));
 688         }
 689     }
 690
 691   {
 692     int len;
 693     char *proc;
 694     char *var;
 695     tree arg3;
 696     tree arg2;
 697     tree arg1;
 698     tree arg4;
 699
 700     switch (total_dims)
 701       {
 702       case 0:
 703         var = concat (array_name, "[", (dim ? "end" : "start"),
 704                       "-substring]", NULL);
 705         len = strlen (var) + 1;
 706         arg1 = build_string (len, var);
 707         free (var);
 708         break;
 709
 710       case 1:
 711         len = strlen (array_name) + 1;
 712         arg1 = build_string (len, array_name);
 713         break;
 714
 715       default:
 716         var = xmalloc (strlen (array_name) + 40);
 717         sprintf (var, "%s[subscript-%d-of-%d]",
 718                  array_name,
 719                  dim + 1, total_dims);
 720         len = strlen (var) + 1;
 721         arg1 = build_string (len, var);
 722         free (var);
 723         break;
 724       }
 725
 726     TREE_TYPE (arg1)
 727       = build_type_variant (build_array_type (char_type_node,
 728                                               build_range_type
 729                                               (integer_type_node,
 730                                                integer_one_node,
 731                                                build_int_2 (len, 0))),
 732                             1, 0);
 733     TREE_CONSTANT (arg1) = 1;
 734     TREE_STATIC (arg1) = 1;
 735     arg1 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg1)),
 736                      arg1);
 737
 738     /* s_rnge adds one to the element to print it, so bias against
 739        that -- want to print a faithful *subscript* value.  */
 740     arg2 = convert (ffecom_f2c_ftnint_type_node,
 741                     ffecom_2 (MINUS_EXPR,
 742                               TREE_TYPE (element),
 743                               element,
 744                               convert (TREE_TYPE (element),
 745                                        integer_one_node)));
 746
 747     proc = concat (input_filename, "/",
 748                    IDENTIFIER_POINTER (DECL_NAME (current_function_decl)),
 749                    NULL);
 750     len = strlen (proc) + 1;
 751     arg3 = build_string (len, proc);
 752
 753     free (proc);
 754
 755     TREE_TYPE (arg3)
 756       = build_type_variant (build_array_type (char_type_node,
 757                                               build_range_type
 758                                               (integer_type_node,
 759                                                integer_one_node,
 760                                                build_int_2 (len, 0))),
 761                             1, 0);
 762     TREE_CONSTANT (arg3) = 1;
 763     TREE_STATIC (arg3) = 1;
 764     arg3 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg3)),
 765                      arg3);
 766
 767     arg4 = convert (ffecom_f2c_ftnint_type_node,
 768                     build_int_2 (lineno, 0));
 769
 770     arg1 = build_tree_list (NULL_TREE, arg1);
 771     arg2 = build_tree_list (NULL_TREE, arg2);
 772     arg3 = build_tree_list (NULL_TREE, arg3);
 773     arg4 = build_tree_list (NULL_TREE, arg4);
 774     TREE_CHAIN (arg3) = arg4;
 775     TREE_CHAIN (arg2) = arg3;
 776     TREE_CHAIN (arg1) = arg2;
 777
 778     args = arg1;
 779   }
 780   die = ffecom_call_gfrt (FFECOM_gfrtRANGE,
 781                           args, NULL_TREE);
 782   TREE_SIDE_EFFECTS (die) = 1;
 783
 784   element = ffecom_3 (COND_EXPR,
 785                       TREE_TYPE (element),
 786                       cond,
 787                       element,
 788                       die);
 789
 790   return element;
 791 }
 792
 793 /* Return the computed element of an array reference.
 794
 795    `item' is NULL_TREE, or the transformed pointer to the array.
 796    `expr' is the original opARRAYREF expression, which is transformed
 797      if `item' is NULL_TREE.
 798    `want_ptr' is non-zero if a pointer to the element, instead of
 799      the element itself, is to be returned.  */
 800
 801 static tree
 802 ffecom_arrayref_ (tree item, ffebld expr, int want_ptr)
 803 {
 804   ffebld dims[FFECOM_dimensionsMAX];
 805   int i;
 806   int total_dims;
 807   int flatten = ffe_is_flatten_arrays ();
 808   int need_ptr;
 809   tree array;
 810   tree element;
 811   tree tree_type;
 812   tree tree_type_x;
 813   const char *array_name;
 814   ffetype type;
 815   ffebld list;
 816
 817   if (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER)
 818     array_name = ffesymbol_text (ffebld_symter (ffebld_left (expr)));
 819   else
 820     array_name = "[expr?]";
 821
 822   /* Build up ARRAY_REFs in reverse order (since we're column major
 823      here in Fortran land). */
 824
 825   for (i = 0, list = ffebld_right (expr);
 826        list != NULL;
 827        ++i, list = ffebld_trail (list))
 828     {
 829       dims[i] = ffebld_head (list);
 830       type = ffeinfo_type (ffebld_basictype (dims[i]),
 831                            ffebld_kindtype (dims[i]));
 832       if (! flatten
 833           && ffecom_typesize_pointer_ > ffecom_typesize_integer1_
 834           && ffetype_size (type) > ffecom_typesize_integer1_)
 835         /* E.g. ARRAY(INDEX), given INTEGER*8 INDEX, on a system with 64-bit
 836            pointers and 32-bit integers.  Do the full 64-bit pointer
 837            arithmetic, for codes using arrays for nonstandard heap-like
 838            work.  */
 839         flatten = 1;
 840     }
 841
 842   total_dims = i;
 843
 844   need_ptr = want_ptr || flatten;
 845
 846   if (! item)
 847     {
 848       if (need_ptr)
 849         item = ffecom_ptr_to_expr (ffebld_left (expr));
 850       else
 851         item = ffecom_expr (ffebld_left (expr));
 852
 853       if (item == error_mark_node)
 854         return item;
 855
 856       if (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereFLEETING
 857           && ! mark_addressable (item))
 858         return error_mark_node;
 859     }
 860
 861   if (item == error_mark_node)
 862     return item;
 863
 864   if (need_ptr)
 865     {
 866       tree min;
 867
 868       for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
 869            i >= 0;
 870            --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array)))
 871         {
 872           min = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
 873           element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
 874           if (flag_bounds_check)
 875             element = ffecom_subscript_check_ (array, element, i, total_dims,
 876                                                array_name);
 877           if (element == error_mark_node)
 878             return element;
 879
 880           /* Widen integral arithmetic as desired while preserving
 881              signedness.  */
 882           tree_type = TREE_TYPE (element);
 883           tree_type_x = tree_type;
 884           if (tree_type
 885               && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
 886               && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
 887             tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
 888
 889           if (TREE_TYPE (min) != tree_type_x)
 890             min = convert (tree_type_x, min);
 891           if (TREE_TYPE (element) != tree_type_x)
 892             element = convert (tree_type_x, element);
 893
 894           item = ffecom_2 (PLUS_EXPR,
 895                            build_pointer_type (TREE_TYPE (array)),
 896                            item,
 897                            size_binop (MULT_EXPR,
 898                                        size_in_bytes (TREE_TYPE (array)),
 899                                        convert (sizetype,
 900                                                 fold (build (MINUS_EXPR,
 901                                                              tree_type_x,
 902                                                              element, min)))));
 903         }
 904       if (! want_ptr)
 905         {
 906           item = ffecom_1 (INDIRECT_REF,
 907                            TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
 908                            item);
 909         }
 910     }
 911   else
 912     {
 913       for (--i;
 914            i >= 0;
 915            --i)
 916         {
 917           array = TYPE_MAIN_VARIANT (TREE_TYPE (item));
 918
 919           element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
 920           if (flag_bounds_check)
 921             element = ffecom_subscript_check_ (array, element, i, total_dims,
 922                                                array_name);
 923           if (element == error_mark_node)
 924             return element;
 925
 926           /* Widen integral arithmetic as desired while preserving
 927              signedness.  */
 928           tree_type = TREE_TYPE (element);
 929           tree_type_x = tree_type;
 930           if (tree_type
 931               && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
 932               && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
 933             tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
 934
 935           element = convert (tree_type_x, element);
 936
 937           item = ffecom_2 (ARRAY_REF,
 938                            TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
 939                            item,
 940                            element);
 941         }
 942     }
 943
 944   return item;
 945 }
 946
 947 /* This is like gcc's stabilize_reference -- in fact, most of the code
 948    comes from that -- but it handles the situation where the reference
 949    is going to have its subparts picked at, and it shouldn't change
 950    (or trigger extra invocations of functions in the subtrees) due to
 951    this.  save_expr is a bit overzealous, because we don't need the
 952    entire thing calculated and saved like a temp.  So, for DECLs, no
 953    change is needed, because these are stable aggregates, and ARRAY_REF
 954    and such might well be stable too, but for things like calculations,
 955    we do need to calculate a snapshot of a value before picking at it.  */
 956
 957 static tree
 958 ffecom_stabilize_aggregate_ (tree ref)
 959 {
 960   tree result;
 961   enum tree_code code = TREE_CODE (ref);
 962
 963   switch (code)
 964     {
 965     case VAR_DECL:
 966     case PARM_DECL:
 967     case RESULT_DECL:
 968       /* No action is needed in this case.  */
 969       return ref;
 970
 971     case NOP_EXPR:
 972     case CONVERT_EXPR:
 973     case FLOAT_EXPR:
 974     case FIX_TRUNC_EXPR:
 975     case FIX_FLOOR_EXPR:
 976     case FIX_ROUND_EXPR:
 977     case FIX_CEIL_EXPR:
 978       result = build_nt (code, stabilize_reference (TREE_OPERAND (ref, 0)));
 979       break;
 980
 981     case INDIRECT_REF:
 982       result = build_nt (INDIRECT_REF,
 983                          stabilize_reference_1 (TREE_OPERAND (ref, 0)));
 984       break;
 985
 986     case COMPONENT_REF:
 987       result = build_nt (COMPONENT_REF,
 988                          stabilize_reference (TREE_OPERAND (ref, 0)),
 989                          TREE_OPERAND (ref, 1));
 990       break;
 991
 992     case BIT_FIELD_REF:
 993       result = build_nt (BIT_FIELD_REF,
 994                          stabilize_reference (TREE_OPERAND (ref, 0)),
 995                          stabilize_reference_1 (TREE_OPERAND (ref, 1)),
 996                          stabilize_reference_1 (TREE_OPERAND (ref, 2)));
 997       break;
 998
 999     case ARRAY_REF:
1000       result = build_nt (ARRAY_REF,
1001                          stabilize_reference (TREE_OPERAND (ref, 0)),
1002                          stabilize_reference_1 (TREE_OPERAND (ref, 1)));
1003       break;
1004
1005     case COMPOUND_EXPR:
1006       result = build_nt (COMPOUND_EXPR,
1007                          stabilize_reference_1 (TREE_OPERAND (ref, 0)),
1008                          stabilize_reference (TREE_OPERAND (ref, 1)));
1009       break;
1010
1011     case RTL_EXPR:
1012       abort ();
1013
1014
1015     default:
1016       return save_expr (ref);
1017
1018     case ERROR_MARK:
1019       return error_mark_node;
1020     }
1021
1022   TREE_TYPE (result) = TREE_TYPE (ref);
1023   TREE_READONLY (result) = TREE_READONLY (ref);
1024   TREE_SIDE_EFFECTS (result) = TREE_SIDE_EFFECTS (ref);
1025   TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref);
1026
1027   return result;
1028 }
1029
1030 /* A rip-off of gcc's convert.c convert_to_complex function,
1031    reworked to handle complex implemented as C structures
1032    (RECORD_TYPE with two fields, real and imaginary `r' and `i').  */
1033
1034 static tree
1035 ffecom_convert_to_complex_ (tree type, tree expr)
1036 {
1037   register enum tree_code form = TREE_CODE (TREE_TYPE (expr));
1038   tree subtype;
1039
1040   assert (TREE_CODE (type) == RECORD_TYPE);
1041
1042   subtype = TREE_TYPE (TYPE_FIELDS (type));
1043
1044   if (form == REAL_TYPE || form == INTEGER_TYPE || form == ENUMERAL_TYPE)
1045     {
1046       expr = convert (subtype, expr);
1047       return ffecom_2 (COMPLEX_EXPR, type, expr,
1048                        convert (subtype, integer_zero_node));
1049     }
1050
1051   if (form == RECORD_TYPE)
1052     {
1053       tree elt_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr)));
1054       if (TYPE_MAIN_VARIANT (elt_type) == TYPE_MAIN_VARIANT (subtype))
1055         return expr;
1056       else
1057         {
1058           expr = save_expr (expr);
1059           return ffecom_2 (COMPLEX_EXPR,
1060                            type,
1061                            convert (subtype,
1062                                     ffecom_1 (REALPART_EXPR,
1063                                               TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1064                                               expr)),
1065                            convert (subtype,
1066                                     ffecom_1 (IMAGPART_EXPR,
1067                                               TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1068                                               expr)));
1069         }
1070     }
1071
1072   if (form == POINTER_TYPE || form == REFERENCE_TYPE)
1073     error ("pointer value used where a complex was expected");
1074   else
1075     error ("aggregate value used where a complex was expected");
1076
1077   return ffecom_2 (COMPLEX_EXPR, type,
1078                    convert (subtype, integer_zero_node),
1079                    convert (subtype, integer_zero_node));
1080 }
1081
1082 /* Like gcc's convert(), but crashes if widening might happen.  */
1083
1084 static tree
1085 ffecom_convert_narrow_ (type, expr)
1086      tree type, expr;
1087 {
1088   register tree e = expr;
1089   register enum tree_code code = TREE_CODE (type);
1090
1091   if (type == TREE_TYPE (e)
1092       || TREE_CODE (e) == ERROR_MARK)
1093     return e;
1094   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1095     return fold (build1 (NOP_EXPR, type, e));
1096   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1097       || code == ERROR_MARK)
1098     return error_mark_node;
1099   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1100     {
1101       assert ("void value not ignored as it ought to be" == NULL);
1102       return error_mark_node;
1103     }
1104   assert (code != VOID_TYPE);
1105   if ((code != RECORD_TYPE)
1106       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1107     assert ("converting COMPLEX to REAL" == NULL);
1108   assert (code != ENUMERAL_TYPE);
1109   if (code == INTEGER_TYPE)
1110     {
1111       assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1112                && TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)))
1113               || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1114                   && (TYPE_PRECISION (type)
1115                       == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1116       return fold (convert_to_integer (type, e));
1117     }
1118   if (code == POINTER_TYPE)
1119     {
1120       assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1121       return fold (convert_to_pointer (type, e));
1122     }
1123   if (code == REAL_TYPE)
1124     {
1125       assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1126       assert (TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)));
1127       return fold (convert_to_real (type, e));
1128     }
1129   if (code == COMPLEX_TYPE)
1130     {
1131       assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1132       assert (TYPE_PRECISION (TREE_TYPE (type)) <= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1133       return fold (convert_to_complex (type, e));
1134     }
1135   if (code == RECORD_TYPE)
1136     {
1137       assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1138       /* Check that at least the first field name agrees.  */
1139       assert (DECL_NAME (TYPE_FIELDS (type))
1140               == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1141       assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1142               <= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1143       if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1144           == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1145         return e;
1146       return fold (ffecom_convert_to_complex_ (type, e));
1147     }
1148
1149   assert ("conversion to non-scalar type requested" == NULL);
1150   return error_mark_node;
1151 }
1152
1153 /* Like gcc's convert(), but crashes if narrowing might happen.  */
1154
1155 static tree
1156 ffecom_convert_widen_ (type, expr)
1157      tree type, expr;
1158 {
1159   register tree e = expr;
1160   register enum tree_code code = TREE_CODE (type);
1161
1162   if (type == TREE_TYPE (e)
1163       || TREE_CODE (e) == ERROR_MARK)
1164     return e;
1165   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1166     return fold (build1 (NOP_EXPR, type, e));
1167   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1168       || code == ERROR_MARK)
1169     return error_mark_node;
1170   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1171     {
1172       assert ("void value not ignored as it ought to be" == NULL);
1173       return error_mark_node;
1174     }
1175   assert (code != VOID_TYPE);
1176   if ((code != RECORD_TYPE)
1177       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1178     assert ("narrowing COMPLEX to REAL" == NULL);
1179   assert (code != ENUMERAL_TYPE);
1180   if (code == INTEGER_TYPE)
1181     {
1182       assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1183                && TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)))
1184               || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1185                   && (TYPE_PRECISION (type)
1186                       == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1187       return fold (convert_to_integer (type, e));
1188     }
1189   if (code == POINTER_TYPE)
1190     {
1191       assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1192       return fold (convert_to_pointer (type, e));
1193     }
1194   if (code == REAL_TYPE)
1195     {
1196       assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1197       assert (TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)));
1198       return fold (convert_to_real (type, e));
1199     }
1200   if (code == COMPLEX_TYPE)
1201     {
1202       assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1203       assert (TYPE_PRECISION (TREE_TYPE (type)) >= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1204       return fold (convert_to_complex (type, e));
1205     }
1206   if (code == RECORD_TYPE)
1207     {
1208       assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1209       /* Check that at least the first field name agrees.  */
1210       assert (DECL_NAME (TYPE_FIELDS (type))
1211               == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1212       assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1213               >= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1214       if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1215           == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1216         return e;
1217       return fold (ffecom_convert_to_complex_ (type, e));
1218     }
1219
1220   assert ("conversion to non-scalar type requested" == NULL);
1221   return error_mark_node;
1222 }
1223
1224 /* Handles making a COMPLEX type, either the standard
1225    (but buggy?) gbe way, or the safer (but less elegant?)
1226    f2c way.  */
1227
1228 static tree
1229 ffecom_make_complex_type_ (tree subtype)
1230 {
1231   tree type;
1232   tree realfield;
1233   tree imagfield;
1234
1235   if (ffe_is_emulate_complex ())
1236     {
1237       type = make_node (RECORD_TYPE);
1238       realfield = ffecom_decl_field (type, NULL_TREE, "r", subtype);
1239       imagfield = ffecom_decl_field (type, realfield, "i", subtype);
1240       TYPE_FIELDS (type) = realfield;
1241       layout_type (type);
1242     }
1243   else
1244     {
1245       type = make_node (COMPLEX_TYPE);
1246       TREE_TYPE (type) = subtype;
1247       layout_type (type);
1248     }
1249
1250   return type;
1251 }
1252
1253 /* Chooses either the gbe or the f2c way to build a
1254    complex constant.  */
1255
1256 static tree
1257 ffecom_build_complex_constant_ (tree type, tree realpart, tree imagpart)
1258 {
1259   tree bothparts;
1260
1261   if (ffe_is_emulate_complex ())
1262     {
1263       bothparts = build_tree_list (TYPE_FIELDS (type), realpart);
1264       TREE_CHAIN (bothparts) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), imagpart);
1265       bothparts = build (CONSTRUCTOR, type, NULL_TREE, bothparts);
1266     }
1267   else
1268     {
1269       bothparts = build_complex (type, realpart, imagpart);
1270     }
1271
1272   return bothparts;
1273 }
1274
1275 static tree
1276 ffecom_arglist_expr_ (const char *c, ffebld expr)
1277 {
1278   tree list;
1279   tree *plist = &list;
1280   tree trail = NULL_TREE;       /* Append char length args here. */
1281   tree *ptrail = &trail;
1282   tree length;
1283   ffebld exprh;
1284   tree item;
1285   bool ptr = FALSE;
1286   tree wanted = NULL_TREE;
1287   static const char zed[] = "0";
1288
1289   if (c == NULL)
1290     c = &zed[0];
1291
1292   while (expr != NULL)
1293     {
1294       if (*c != '\0')
1295         {
1296           ptr = FALSE;
1297           if (*c == '&')
1298             {
1299               ptr = TRUE;
1300               ++c;
1301             }
1302           switch (*(c++))
1303             {
1304             case '\0':
1305               ptr = TRUE;
1306               wanted = NULL_TREE;
1307               break;
1308
1309             case 'a':
1310               assert (ptr);
1311               wanted = NULL_TREE;
1312               break;
1313
1314             case 'c':
1315               wanted = ffecom_f2c_complex_type_node;
1316               break;
1317
1318             case 'd':
1319               wanted = ffecom_f2c_doublereal_type_node;
1320               break;
1321
1322             case 'e':
1323               wanted = ffecom_f2c_doublecomplex_type_node;
1324               break;
1325
1326             case 'f':
1327               wanted = ffecom_f2c_real_type_node;
1328               break;
1329
1330             case 'i':
1331               wanted = ffecom_f2c_integer_type_node;
1332               break;
1333
1334             case 'j':
1335               wanted = ffecom_f2c_longint_type_node;
1336               break;
1337
1338             default:
1339               assert ("bad argstring code" == NULL);
1340               wanted = NULL_TREE;
1341               break;
1342             }
1343         }
1344
1345       exprh = ffebld_head (expr);
1346       if (exprh == NULL)
1347         wanted = NULL_TREE;
1348
1349       if ((wanted == NULL_TREE)
1350           || (ptr
1351               && (TYPE_MODE
1352                   (ffecom_tree_type[ffeinfo_basictype (ffebld_info (exprh))]
1353                    [ffeinfo_kindtype (ffebld_info (exprh))])
1354                    == TYPE_MODE (wanted))))
1355         *plist
1356           = build_tree_list (NULL_TREE,
1357                              ffecom_arg_ptr_to_expr (exprh,
1358                                                      &length));
1359       else
1360         {
1361           item = ffecom_arg_expr (exprh, &length);
1362           item = ffecom_convert_widen_ (wanted, item);
1363           if (ptr)
1364             {
1365               item = ffecom_1 (ADDR_EXPR,
1366                                build_pointer_type (TREE_TYPE (item)),
1367                                item);
1368             }
1369           *plist
1370             = build_tree_list (NULL_TREE,
1371                                item);
1372         }
1373
1374       plist = &TREE_CHAIN (*plist);
1375       expr = ffebld_trail (expr);
1376       if (length != NULL_TREE)
1377         {
1378           *ptrail = build_tree_list (NULL_TREE, length);
1379           ptrail = &TREE_CHAIN (*ptrail);
1380         }
1381     }
1382
1383   /* We've run out of args in the call; if the implementation expects
1384      more, supply null pointers for them, which the implementation can
1385      check to see if an arg was omitted. */
1386
1387   while (*c != '\0' && *c != '0')
1388     {
1389       if (*c == '&')
1390         ++c;
1391       else
1392         assert ("missing arg to run-time routine!" == NULL);
1393
1394       switch (*(c++))
1395         {
1396         case '\0':
1397         case 'a':
1398         case 'c':
1399         case 'd':
1400         case 'e':
1401         case 'f':
1402         case 'i':
1403         case 'j':
1404           break;
1405
1406         default:
1407           assert ("bad arg string code" == NULL);
1408           break;
1409         }
1410       *plist
1411         = build_tree_list (NULL_TREE,
1412                            null_pointer_node);
1413       plist = &TREE_CHAIN (*plist);
1414     }
1415
1416   *plist = trail;
1417
1418   return list;
1419 }
1420
1421 static tree
1422 ffecom_widest_expr_type_ (ffebld list)
1423 {
1424   ffebld item;
1425   ffebld widest = NULL;
1426   ffetype type;
1427   ffetype widest_type = NULL;
1428   tree t;
1429
1430   for (; list != NULL; list = ffebld_trail (list))
1431     {
1432       item = ffebld_head (list);
1433       if (item == NULL)
1434         continue;
1435       if ((widest != NULL)
1436           && (ffeinfo_basictype (ffebld_info (item))
1437               != ffeinfo_basictype (ffebld_info (widest))))
1438         continue;
1439       type = ffeinfo_type (ffeinfo_basictype (ffebld_info (item)),
1440                            ffeinfo_kindtype (ffebld_info (item)));
1441       if ((widest == FFEINFO_kindtypeNONE)
1442           || (ffetype_size (type)
1443               > ffetype_size (widest_type)))
1444         {
1445           widest = item;
1446           widest_type = type;
1447         }
1448     }
1449
1450   assert (widest != NULL);
1451   t = ffecom_tree_type[ffeinfo_basictype (ffebld_info (widest))]
1452     [ffeinfo_kindtype (ffebld_info (widest))];
1453   assert (t != NULL_TREE);
1454   return t;
1455 }
1456
1457 /* Check whether a partial overlap between two expressions is possible.
1458
1459    Can *starting* to write a portion of expr1 change the value
1460    computed (perhaps already, *partially*) by expr2?
1461
1462    Currently, this is a concern only for a COMPLEX expr1.  But if it
1463    isn't in COMMON or local EQUIVALENCE, since we don't support
1464    aliasing of arguments, it isn't a concern.  */
1465
1466 static bool
1467 ffecom_possible_partial_overlap_ (ffebld expr1, ffebld expr2 ATTRIBUTE_UNUSED)
1468 {
1469   ffesymbol sym;
1470   ffestorag st;
1471
1472   switch (ffebld_op (expr1))
1473     {
1474     case FFEBLD_opSYMTER:
1475       sym = ffebld_symter (expr1);
1476       break;
1477
1478     case FFEBLD_opARRAYREF:
1479       if (ffebld_op (ffebld_left (expr1)) != FFEBLD_opSYMTER)
1480         return FALSE;
1481       sym = ffebld_symter (ffebld_left (expr1));
1482       break;
1483
1484     default:
1485       return FALSE;
1486     }
1487
1488   if (ffesymbol_where (sym) != FFEINFO_whereCOMMON
1489       && (ffesymbol_where (sym) != FFEINFO_whereLOCAL
1490           || ! (st = ffesymbol_storage (sym))
1491           || ! ffestorag_parent (st)))
1492     return FALSE;
1493
1494   /* It's in COMMON or local EQUIVALENCE.  */
1495
1496   return TRUE;
1497 }
1498
1499 /* Check whether dest and source might overlap.  ffebld versions of these
1500    might or might not be passed, will be NULL if not.
1501
1502    The test is really whether source_tree is modifiable and, if modified,
1503    might overlap destination such that the value(s) in the destination might
1504    change before it is finally modified.  dest_* are the canonized
1505    destination itself.  */
1506
1507 static bool
1508 ffecom_overlap_ (tree dest_decl, tree dest_offset, tree dest_size,
1509                  tree source_tree, ffebld source UNUSED,
1510                  bool scalar_arg)
1511 {
1512   tree source_decl;
1513   tree source_offset;
1514   tree source_size;
1515   tree t;
1516
1517   if (source_tree == NULL_TREE)
1518     return FALSE;
1519
1520   switch (TREE_CODE (source_tree))
1521     {
1522     case ERROR_MARK:
1523     case IDENTIFIER_NODE:
1524     case INTEGER_CST:
1525     case REAL_CST:
1526     case COMPLEX_CST:
1527     case STRING_CST:
1528     case CONST_DECL:
1529     case VAR_DECL:
1530     case RESULT_DECL:
1531     case FIELD_DECL:
1532     case MINUS_EXPR:
1533     case MULT_EXPR:
1534     case TRUNC_DIV_EXPR:
1535     case CEIL_DIV_EXPR:
1536     case FLOOR_DIV_EXPR:
1537     case ROUND_DIV_EXPR:
1538     case TRUNC_MOD_EXPR:
1539     case CEIL_MOD_EXPR:
1540     case FLOOR_MOD_EXPR:
1541     case ROUND_MOD_EXPR:
1542     case RDIV_EXPR:
1543     case EXACT_DIV_EXPR:
1544     case FIX_TRUNC_EXPR:
1545     case FIX_CEIL_EXPR:
1546     case FIX_FLOOR_EXPR:
1547     case FIX_ROUND_EXPR:
1548     case FLOAT_EXPR:
1549     case NEGATE_EXPR:
1550     case MIN_EXPR:
1551     case MAX_EXPR:
1552     case ABS_EXPR:
1553     case FFS_EXPR:
1554     case LSHIFT_EXPR:
1555     case RSHIFT_EXPR:
1556     case LROTATE_EXPR:
1557     case RROTATE_EXPR:
1558     case BIT_IOR_EXPR:
1559     case BIT_XOR_EXPR:
1560     case BIT_AND_EXPR:
1561     case BIT_ANDTC_EXPR:
1562     case BIT_NOT_EXPR:
1563     case TRUTH_ANDIF_EXPR:
1564     case TRUTH_ORIF_EXPR:
1565     case TRUTH_AND_EXPR:
1566     case TRUTH_OR_EXPR:
1567     case TRUTH_XOR_EXPR:
1568     case TRUTH_NOT_EXPR:
1569     case LT_EXPR:
1570     case LE_EXPR:
1571     case GT_EXPR:
1572     case GE_EXPR:
1573     case EQ_EXPR:
1574     case NE_EXPR:
1575     case COMPLEX_EXPR:
1576     case CONJ_EXPR:
1577     case REALPART_EXPR:
1578     case IMAGPART_EXPR:
1579     case LABEL_EXPR:
1580     case COMPONENT_REF:
1581       return FALSE;
1582
1583     case COMPOUND_EXPR:
1584       return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1585                               TREE_OPERAND (source_tree, 1), NULL,
1586                               scalar_arg);
1587
1588     case MODIFY_EXPR:
1589       return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1590                               TREE_OPERAND (source_tree, 0), NULL,
1591                               scalar_arg);
1592
1593     case CONVERT_EXPR:
1594     case NOP_EXPR:
1595     case NON_LVALUE_EXPR:
1596     case PLUS_EXPR:
1597       if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1598         return TRUE;
1599
1600       ffecom_tree_canonize_ptr_ (&source_decl, &source_offset,
1601                                  source_tree);
1602       source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1603       break;
1604
1605     case COND_EXPR:
1606       return
1607         ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1608                          TREE_OPERAND (source_tree, 1), NULL,
1609                          scalar_arg)
1610           || ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1611                               TREE_OPERAND (source_tree, 2), NULL,
1612                               scalar_arg);
1613
1614
1615     case ADDR_EXPR:
1616       ffecom_tree_canonize_ref_ (&source_decl, &source_offset,
1617                                  &source_size,
1618                                  TREE_OPERAND (source_tree, 0));
1619       break;
1620
1621     case PARM_DECL:
1622       if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1623         return TRUE;
1624
1625       source_decl = source_tree;
1626       source_offset = bitsize_zero_node;
1627       source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1628       break;
1629
1630     case SAVE_EXPR:
1631     case REFERENCE_EXPR:
1632     case PREDECREMENT_EXPR:
1633     case PREINCREMENT_EXPR:
1634     case POSTDECREMENT_EXPR:
1635     case POSTINCREMENT_EXPR:
1636     case INDIRECT_REF:
1637     case ARRAY_REF:
1638     case CALL_EXPR:
1639     default:
1640       return TRUE;
1641     }
1642
1643   /* Come here when source_decl, source_offset, and source_size filled
1644      in appropriately.  */
1645
1646   if (source_decl == NULL_TREE)
1647     return FALSE;               /* No decl involved, so no overlap. */
1648
1649   if (source_decl != dest_decl)
1650     return FALSE;               /* Different decl, no overlap. */
1651
1652   if (TREE_CODE (dest_size) == ERROR_MARK)
1653     return TRUE;                /* Assignment into entire assumed-size
1654                                    array?  Shouldn't happen.... */
1655
1656   t = ffecom_2 (LE_EXPR, integer_type_node,
1657                 ffecom_2 (PLUS_EXPR, TREE_TYPE (dest_offset),
1658                           dest_offset,
1659                           convert (TREE_TYPE (dest_offset),
1660                                    dest_size)),
1661                 convert (TREE_TYPE (dest_offset),
1662                          source_offset));
1663
1664   if (integer_onep (t))
1665     return FALSE;               /* Destination precedes source. */
1666
1667   if (!scalar_arg
1668       || (source_size == NULL_TREE)
1669       || (TREE_CODE (source_size) == ERROR_MARK)
1670       || integer_zerop (source_size))
1671     return TRUE;                /* No way to tell if dest follows source. */
1672
1673   t = ffecom_2 (LE_EXPR, integer_type_node,
1674                 ffecom_2 (PLUS_EXPR, TREE_TYPE (source_offset),
1675                           source_offset,
1676                           convert (TREE_TYPE (source_offset),
1677                                    source_size)),
1678                 convert (TREE_TYPE (source_offset),
1679                          dest_offset));
1680
1681   if (integer_onep (t))
1682     return FALSE;               /* Destination follows source. */
1683
1684   return TRUE;          /* Destination and source overlap. */
1685 }
1686
1687 /* Check whether dest might overlap any of a list of arguments or is
1688    in a COMMON area the callee might know about (and thus modify).  */
1689
1690 static bool
1691 ffecom_args_overlapping_ (tree dest_tree, ffebld dest UNUSED,
1692                           tree args, tree callee_commons,
1693                           bool scalar_args)
1694 {
1695   tree arg;
1696   tree dest_decl;
1697   tree dest_offset;
1698   tree dest_size;
1699
1700   ffecom_tree_canonize_ref_ (&dest_decl, &dest_offset, &dest_size,
1701                              dest_tree);
1702
1703   if (dest_decl == NULL_TREE)
1704     return FALSE;               /* Seems unlikely! */
1705
1706   /* If the decl cannot be determined reliably, or if its in COMMON
1707      and the callee isn't known to not futz with COMMON via other
1708      means, overlap might happen.  */
1709
1710   if ((TREE_CODE (dest_decl) == ERROR_MARK)
1711       || ((callee_commons != NULL_TREE)
1712           && TREE_PUBLIC (dest_decl)))
1713     return TRUE;
1714
1715   for (; args != NULL_TREE; args = TREE_CHAIN (args))
1716     {
1717       if (((arg = TREE_VALUE (args)) != NULL_TREE)
1718           && ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1719                               arg, NULL, scalar_args))
1720         return TRUE;
1721     }
1722
1723   return FALSE;
1724 }
1725
1726 /* Build a string for a variable name as used by NAMELIST.  This means that
1727    if we're using the f2c library, we build an uppercase string, since
1728    f2c does this.  */
1729
1730 static tree
1731 ffecom_build_f2c_string_ (int i, const char *s)
1732 {
1733   if (!ffe_is_f2c_library ())
1734     return build_string (i, s);
1735
1736   {
1737     char *tmp;
1738     const char *p;
1739     char *q;
1740     char space[34];
1741     tree t;
1742
1743     if (((size_t) i) > ARRAY_SIZE (space))
1744       tmp = malloc_new_ks (malloc_pool_image (), "f2c_string", i);
1745     else
1746       tmp = &space[0];
1747
1748     for (p = s, q = tmp; *p != '\0'; ++p, ++q)
1749       *q = TOUPPER (*p);
1750     *q = '\0';
1751
1752     t = build_string (i, tmp);
1753
1754     if (((size_t) i) > ARRAY_SIZE (space))
1755       malloc_kill_ks (malloc_pool_image (), tmp, i);
1756
1757     return t;
1758   }
1759 }
1760
1761 /* Returns CALL_EXPR or equivalent with given type (pass NULL_TREE for
1762    type to just get whatever the function returns), handling the
1763    f2c value-returning convention, if required, by prepending
1764    to the arglist a pointer to a temporary to receive the return value.  */
1765
1766 static tree
1767 ffecom_call_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1768               tree type, tree args, tree dest_tree,
1769               ffebld dest, bool *dest_used, tree callee_commons,
1770               bool scalar_args, tree hook)
1771 {
1772   tree item;
1773   tree tempvar;
1774
1775   if (dest_used != NULL)
1776     *dest_used = FALSE;
1777
1778   if (is_f2c_complex)
1779     {
1780       if ((dest_used == NULL)
1781           || (dest == NULL)
1782           || (ffeinfo_basictype (ffebld_info (dest))
1783               != FFEINFO_basictypeCOMPLEX)
1784           || (ffeinfo_kindtype (ffebld_info (dest)) != kt)
1785           || ((type != NULL_TREE) && (TREE_TYPE (dest_tree) != type))
1786           || ffecom_args_overlapping_ (dest_tree, dest, args,
1787                                        callee_commons,
1788                                        scalar_args))
1789         {
1790 #ifdef HOHO
1791           tempvar = ffecom_make_tempvar (ffecom_tree_type
1792                                          [FFEINFO_basictypeCOMPLEX][kt],
1793                                          FFETARGET_charactersizeNONE,
1794                                          -1);
1795 #else
1796           tempvar = hook;
1797           assert (tempvar);
1798 #endif
1799         }
1800       else
1801         {
1802           *dest_used = TRUE;
1803           tempvar = dest_tree;
1804           type = NULL_TREE;
1805         }
1806
1807       item
1808         = build_tree_list (NULL_TREE,
1809                            ffecom_1 (ADDR_EXPR,
1810                                      build_pointer_type (TREE_TYPE (tempvar)),
1811                                      tempvar));
1812       TREE_CHAIN (item) = args;
1813
1814       item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1815                         item, NULL_TREE);
1816
1817       if (tempvar != dest_tree)
1818         item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item, tempvar);
1819     }
1820   else
1821     item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1822                       args, NULL_TREE);
1823
1824   if ((type != NULL_TREE) && (TREE_TYPE (item) != type))
1825     item = ffecom_convert_narrow_ (type, item);
1826
1827   return item;
1828 }
1829
1830 /* Given two arguments, transform them and make a call to the given
1831    function via ffecom_call_.  */
1832
1833 static tree
1834 ffecom_call_binop_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1835                     tree type, ffebld left, ffebld right,
1836                     tree dest_tree, ffebld dest, bool *dest_used,
1837                     tree callee_commons, bool scalar_args, bool ref, tree hook)
1838 {
1839   tree left_tree;
1840   tree right_tree;
1841   tree left_length;
1842   tree right_length;
1843
1844   if (ref)
1845     {
1846       /* Pass arguments by reference.  */
1847       left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
1848       right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
1849     }
1850   else
1851     {
1852       /* Pass arguments by value.  */
1853       left_tree = ffecom_arg_expr (left, &left_length);
1854       right_tree = ffecom_arg_expr (right, &right_length);
1855     }
1856
1857
1858   left_tree = build_tree_list (NULL_TREE, left_tree);
1859   right_tree = build_tree_list (NULL_TREE, right_tree);
1860   TREE_CHAIN (left_tree) = right_tree;
1861
1862   if (left_length != NULL_TREE)
1863     {
1864       left_length = build_tree_list (NULL_TREE, left_length);
1865       TREE_CHAIN (right_tree) = left_length;
1866     }
1867
1868   if (right_length != NULL_TREE)
1869     {
1870       right_length = build_tree_list (NULL_TREE, right_length);
1871       if (left_length != NULL_TREE)
1872         TREE_CHAIN (left_length) = right_length;
1873       else
1874         TREE_CHAIN (right_tree) = right_length;
1875     }
1876
1877   return ffecom_call_ (fn, kt, is_f2c_complex, type, left_tree,
1878                        dest_tree, dest, dest_used, callee_commons,
1879                        scalar_args, hook);
1880 }
1881
1882 /* Return ptr/length args for char subexpression
1883
1884    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
1885    subexpressions by constructing the appropriate trees for the ptr-to-
1886    character-text and length-of-character-text arguments in a calling
1887    sequence.
1888
1889    Note that if with_null is TRUE, and the expression is an opCONTER,
1890    a null byte is appended to the string.  */
1891
1892 static void
1893 ffecom_char_args_x_ (tree *xitem, tree *length, ffebld expr, bool with_null)
1894 {
1895   tree item;
1896   tree high;
1897   ffetargetCharacter1 val;
1898   ffetargetCharacterSize newlen;
1899
1900   switch (ffebld_op (expr))
1901     {
1902     case FFEBLD_opCONTER:
1903       val = ffebld_constant_character1 (ffebld_conter (expr));
1904       newlen = ffetarget_length_character1 (val);
1905       if (with_null)
1906         {
1907           /* Begin FFETARGET-NULL-KLUDGE.  */
1908           if (newlen != 0)
1909             ++newlen;
1910         }
1911       *length = build_int_2 (newlen, 0);
1912       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
1913       high = build_int_2 (newlen, 0);
1914       TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
1915       item = build_string (newlen,
1916                            ffetarget_text_character1 (val));
1917       /* End FFETARGET-NULL-KLUDGE.  */
1918       TREE_TYPE (item)
1919         = build_type_variant
1920           (build_array_type
1921            (char_type_node,
1922             build_range_type
1923             (ffecom_f2c_ftnlen_type_node,
1924              ffecom_f2c_ftnlen_one_node,
1925              high)),
1926            1, 0);
1927       TREE_CONSTANT (item) = 1;
1928       TREE_STATIC (item) = 1;
1929       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
1930                        item);
1931       break;
1932
1933     case FFEBLD_opSYMTER:
1934       {
1935         ffesymbol s = ffebld_symter (expr);
1936
1937         item = ffesymbol_hook (s).decl_tree;
1938         if (item == NULL_TREE)
1939           {
1940             s = ffecom_sym_transform_ (s);
1941             item = ffesymbol_hook (s).decl_tree;
1942           }
1943         if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
1944           {
1945             if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
1946               *length = ffesymbol_hook (s).length_tree;
1947             else
1948               {
1949                 *length = build_int_2 (ffesymbol_size (s), 0);
1950                 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
1951               }
1952           }
1953         else if (item == error_mark_node)
1954           *length = error_mark_node;
1955         else
1956           /* FFEINFO_kindFUNCTION.  */
1957           *length = NULL_TREE;
1958         if (!ffesymbol_hook (s).addr
1959             && (item != error_mark_node))
1960           item = ffecom_1 (ADDR_EXPR,
1961                            build_pointer_type (TREE_TYPE (item)),
1962                            item);
1963       }
1964       break;
1965
1966     case FFEBLD_opARRAYREF:
1967       {
1968         ffecom_char_args_ (&item, length, ffebld_left (expr));
1969
1970         if (item == error_mark_node || *length == error_mark_node)
1971           {
1972             item = *length = error_mark_node;
1973             break;
1974           }
1975
1976         item = ffecom_arrayref_ (item, expr, 1);
1977       }
1978       break;
1979
1980     case FFEBLD_opSUBSTR:
1981       {
1982         ffebld start;
1983         ffebld end;
1984         ffebld thing = ffebld_right (expr);
1985         tree start_tree;
1986         tree end_tree;
1987         const char *char_name;
1988         ffebld left_symter;
1989         tree array;
1990
1991         assert (ffebld_op (thing) == FFEBLD_opITEM);
1992         start = ffebld_head (thing);
1993         thing = ffebld_trail (thing);
1994         assert (ffebld_trail (thing) == NULL);
1995         end = ffebld_head (thing);
1996
1997         /* Determine name for pretty-printing range-check errors.  */
1998         for (left_symter = ffebld_left (expr);
1999              left_symter && ffebld_op (left_symter) == FFEBLD_opARRAYREF;
2000              left_symter = ffebld_left (left_symter))
2001           ;
2002         if (ffebld_op (left_symter) == FFEBLD_opSYMTER)
2003           char_name = ffesymbol_text (ffebld_symter (left_symter));
2004         else
2005           char_name = "[expr?]";
2006
2007         ffecom_char_args_ (&item, length, ffebld_left (expr));
2008
2009         if (item == error_mark_node || *length == error_mark_node)
2010           {
2011             item = *length = error_mark_node;
2012             break;
2013           }
2014
2015         array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
2016
2017         /* ~~~~Handle INTEGER*8 start/end, a la FFEBLD_opARRAYREF.  */
2018
2019         if (start == NULL)
2020           {
2021             if (end == NULL)
2022               ;
2023             else
2024               {
2025                 end_tree = ffecom_expr (end);
2026                 if (flag_bounds_check)
2027                   end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2028                                                       char_name);
2029                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2030                                     end_tree);
2031
2032                 if (end_tree == error_mark_node)
2033                   {
2034                     item = *length = error_mark_node;
2035                     break;
2036                   }
2037
2038                 *length = end_tree;
2039               }
2040           }
2041         else
2042           {
2043             start_tree = ffecom_expr (start);
2044             if (flag_bounds_check)
2045               start_tree = ffecom_subscript_check_ (array, start_tree, 0, 0,
2046                                                     char_name);
2047             start_tree = convert (ffecom_f2c_ftnlen_type_node,
2048                                   start_tree);
2049
2050             if (start_tree == error_mark_node)
2051               {
2052                 item = *length = error_mark_node;
2053                 break;
2054               }
2055
2056             start_tree = ffecom_save_tree (start_tree);
2057
2058             item = ffecom_2 (PLUS_EXPR, TREE_TYPE (item),
2059                              item,
2060                              ffecom_2 (MINUS_EXPR,
2061                                        TREE_TYPE (start_tree),
2062                                        start_tree,
2063                                        ffecom_f2c_ftnlen_one_node));
2064
2065             if (end == NULL)
2066               {
2067                 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2068                                     ffecom_f2c_ftnlen_one_node,
2069                                     ffecom_2 (MINUS_EXPR,
2070                                               ffecom_f2c_ftnlen_type_node,
2071                                               *length,
2072                                               start_tree));
2073               }
2074             else
2075               {
2076                 end_tree = ffecom_expr (end);
2077                 if (flag_bounds_check)
2078                   end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2079                                                       char_name);
2080                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2081                                     end_tree);
2082
2083                 if (end_tree == error_mark_node)
2084                   {
2085                     item = *length = error_mark_node;
2086                     break;
2087                   }
2088
2089                 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2090                                     ffecom_f2c_ftnlen_one_node,
2091                                     ffecom_2 (MINUS_EXPR,
2092                                               ffecom_f2c_ftnlen_type_node,
2093                                               end_tree, start_tree));
2094               }
2095           }
2096       }
2097       break;
2098
2099     case FFEBLD_opFUNCREF:
2100       {
2101         ffesymbol s = ffebld_symter (ffebld_left (expr));
2102         tree tempvar;
2103         tree args;
2104         ffetargetCharacterSize size = ffeinfo_size (ffebld_info (expr));
2105         ffecomGfrt ix;
2106
2107         if (size == FFETARGET_charactersizeNONE)
2108           /* ~~Kludge alert!  This should someday be fixed. */
2109           size = 24;
2110
2111         *length = build_int_2 (size, 0);
2112         TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2113
2114         if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
2115             == FFEINFO_whereINTRINSIC)
2116           {
2117             if (size == 1)
2118               {
2119                 /* Invocation of an intrinsic returning CHARACTER*1.  */
2120                 item = ffecom_expr_intrinsic_ (expr, NULL_TREE,
2121                                                NULL, NULL);
2122                 break;
2123               }
2124             ix = ffeintrin_gfrt_direct (ffebld_symter_implementation (ffebld_left (expr)));
2125             assert (ix != FFECOM_gfrt);
2126             item = ffecom_gfrt_tree_ (ix);
2127           }
2128         else
2129           {
2130             ix = FFECOM_gfrt;
2131             item = ffesymbol_hook (s).decl_tree;
2132             if (item == NULL_TREE)
2133               {
2134                 s = ffecom_sym_transform_ (s);
2135                 item = ffesymbol_hook (s).decl_tree;
2136               }
2137             if (item == error_mark_node)
2138               {
2139                 item = *length = error_mark_node;
2140                 break;
2141               }
2142
2143             if (!ffesymbol_hook (s).addr)
2144               item = ffecom_1_fn (item);
2145           }
2146
2147 #ifdef HOHO
2148         tempvar = ffecom_push_tempvar (char_type_node, size, -1, TRUE);
2149 #else
2150         tempvar = ffebld_nonter_hook (expr);
2151         assert (tempvar);
2152 #endif
2153         tempvar = ffecom_1 (ADDR_EXPR,
2154                             build_pointer_type (TREE_TYPE (tempvar)),
2155                             tempvar);
2156
2157         args = build_tree_list (NULL_TREE, tempvar);
2158
2159         if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)       /* Sfunc args by value. */
2160           TREE_CHAIN (args) = ffecom_list_expr (ffebld_right (expr));
2161         else
2162           {
2163             TREE_CHAIN (args) = build_tree_list (NULL_TREE, *length);
2164             if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
2165               {
2166                 TREE_CHAIN (TREE_CHAIN (args))
2167                   = ffecom_arglist_expr_ (ffecom_gfrt_args_ (ix),
2168                                           ffebld_right (expr));
2169               }
2170             else
2171               {
2172                 TREE_CHAIN (TREE_CHAIN (args))
2173                   = ffecom_list_ptr_to_expr (ffebld_right (expr));
2174               }
2175           }
2176
2177         item = ffecom_3s (CALL_EXPR,
2178                           TREE_TYPE (TREE_TYPE (TREE_TYPE (item))),
2179                           item, args, NULL_TREE);
2180         item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item,
2181                          tempvar);
2182       }
2183       break;
2184
2185     case FFEBLD_opCONVERT:
2186
2187       ffecom_char_args_ (&item, length, ffebld_left (expr));
2188
2189       if (item == error_mark_node || *length == error_mark_node)
2190         {
2191           item = *length = error_mark_node;
2192           break;
2193         }
2194
2195       if ((ffebld_size_known (ffebld_left (expr))
2196            == FFETARGET_charactersizeNONE)
2197           || (ffebld_size_known (ffebld_left (expr)) < (ffebld_size (expr))))
2198         {                       /* Possible blank-padding needed, copy into
2199                                    temporary. */
2200           tree tempvar;
2201           tree args;
2202           tree newlen;
2203
2204 #ifdef HOHO
2205           tempvar = ffecom_make_tempvar (char_type_node,
2206                                          ffebld_size (expr), -1);
2207 #else
2208           tempvar = ffebld_nonter_hook (expr);
2209           assert (tempvar);
2210 #endif
2211           tempvar = ffecom_1 (ADDR_EXPR,
2212                               build_pointer_type (TREE_TYPE (tempvar)),
2213                               tempvar);
2214
2215           newlen = build_int_2 (ffebld_size (expr), 0);
2216           TREE_TYPE (newlen) = ffecom_f2c_ftnlen_type_node;
2217
2218           args = build_tree_list (NULL_TREE, tempvar);
2219           TREE_CHAIN (args) = build_tree_list (NULL_TREE, item);
2220           TREE_CHAIN (TREE_CHAIN (args)) = build_tree_list (NULL_TREE, newlen);
2221           TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (args)))
2222             = build_tree_list (NULL_TREE, *length);
2223
2224           item = ffecom_call_gfrt (FFECOM_gfrtCOPY, args, NULL_TREE);
2225           TREE_SIDE_EFFECTS (item) = 1;
2226           item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), fold (item),
2227                            tempvar);
2228           *length = newlen;
2229         }
2230       else
2231         {                       /* Just truncate the length. */
2232           *length = build_int_2 (ffebld_size (expr), 0);
2233           TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2234         }
2235       break;
2236
2237     default:
2238       assert ("bad op for single char arg expr" == NULL);
2239       item = NULL_TREE;
2240       break;
2241     }
2242
2243   *xitem = item;
2244 }
2245
2246 /* Check the size of the type to be sure it doesn't overflow the
2247    "portable" capacities of the compiler back end.  `dummy' types
2248    can generally overflow the normal sizes as long as the computations
2249    themselves don't overflow.  A particular target of the back end
2250    must still enforce its size requirements, though, and the back
2251    end takes care of this in stor-layout.c.  */
2252
2253 static tree
2254 ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy)
2255 {
2256   if (TREE_CODE (type) == ERROR_MARK)
2257     return type;
2258
2259   if (TYPE_SIZE (type) == NULL_TREE)
2260     return type;
2261
2262   if (TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST)
2263     return type;
2264
2265   /* An array is too large if size is negative or the type_size overflows
2266      or its "upper half" is larger than 3 (which would make the signed
2267      byte size and offset computations overflow).  */
2268
2269   if ((tree_int_cst_sgn (TYPE_SIZE (type)) < 0)
2270       || (!dummy && (TREE_INT_CST_HIGH (TYPE_SIZE (type)) > 3
2271                      || TREE_OVERFLOW (TYPE_SIZE (type)))))
2272     {
2273       ffebad_start (FFEBAD_ARRAY_LARGE);
2274       ffebad_string (ffesymbol_text (s));
2275       ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s));
2276       ffebad_finish ();
2277
2278       return error_mark_node;
2279     }
2280
2281   return type;
2282 }
2283
2284 /* Builds a length argument (PARM_DECL).  Also wraps type in an array type
2285    where the dimension info is (1:size) where <size> is ffesymbol_size(s) if
2286    known, length_arg if not known (FFETARGET_charactersizeNONE).  */
2287
2288 static tree
2289 ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s)
2290 {
2291   ffetargetCharacterSize sz = ffesymbol_size (s);
2292   tree highval;
2293   tree tlen;
2294   tree type = *xtype;
2295
2296   if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
2297     tlen = NULL_TREE;           /* A statement function, no length passed. */
2298   else
2299     {
2300       if (ffesymbol_where (s) == FFEINFO_whereDUMMY)
2301         tlen = ffecom_get_invented_identifier ("__g77_length_%s",
2302                                                ffesymbol_text (s));
2303       else
2304         tlen = ffecom_get_invented_identifier ("__g77_%s", "length");
2305       tlen = build_decl (PARM_DECL, tlen, ffecom_f2c_ftnlen_type_node);
2306       DECL_ARTIFICIAL (tlen) = 1;
2307     }
2308
2309   if (sz == FFETARGET_charactersizeNONE)
2310     {
2311       assert (tlen != NULL_TREE);
2312       highval = variable_size (tlen);
2313     }
2314   else
2315     {
2316       highval = build_int_2 (sz, 0);
2317       TREE_TYPE (highval) = ffecom_f2c_ftnlen_type_node;
2318     }
2319
2320   type = build_array_type (type,
2321                            build_range_type (ffecom_f2c_ftnlen_type_node,
2322                                              ffecom_f2c_ftnlen_one_node,
2323                                              highval));
2324
2325   *xtype = type;
2326   return tlen;
2327 }
2328
2329 /* ffecom_concat_list_gather_ -- Gather list of concatenated string exprs
2330
2331    ffecomConcatList_ catlist;
2332    ffebld expr;  // expr of CHARACTER basictype.
2333    ffetargetCharacterSize max;  // max chars to gather or _...NONE if no max
2334    catlist = ffecom_concat_list_gather_(catlist,expr,max);
2335
2336    Scans expr for character subexpressions, updates and returns catlist
2337    accordingly.  */
2338
2339 static ffecomConcatList_
2340 ffecom_concat_list_gather_ (ffecomConcatList_ catlist, ffebld expr,
2341                             ffetargetCharacterSize max)
2342 {
2343   ffetargetCharacterSize sz;
2344
2345  recurse:
2346
2347   if (expr == NULL)
2348     return catlist;
2349
2350   if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen >= max))
2351     return catlist;             /* Don't append any more items. */
2352
2353   switch (ffebld_op (expr))
2354     {
2355     case FFEBLD_opCONTER:
2356     case FFEBLD_opSYMTER:
2357     case FFEBLD_opARRAYREF:
2358     case FFEBLD_opFUNCREF:
2359     case FFEBLD_opSUBSTR:
2360     case FFEBLD_opCONVERT:      /* Callers should strip this off beforehand
2361                                    if they don't need to preserve it. */
2362       if (catlist.count == catlist.max)
2363         {                       /* Make a (larger) list. */
2364           ffebld *newx;
2365           int newmax;
2366
2367           newmax = (catlist.max == 0) ? 8 : catlist.max * 2;
2368           newx = malloc_new_ks (malloc_pool_image (), "catlist",
2369                                 newmax * sizeof (newx[0]));
2370           if (catlist.max != 0)
2371             {
2372               memcpy (newx, catlist.exprs, catlist.max * sizeof (newx[0]));
2373               malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2374                               catlist.max * sizeof (newx[0]));
2375             }
2376           catlist.max = newmax;
2377           catlist.exprs = newx;
2378         }
2379       if ((sz = ffebld_size_known (expr)) != FFETARGET_charactersizeNONE)
2380         catlist.minlen += sz;
2381       else
2382         ++catlist.minlen;       /* Not true for F90; can be 0 length. */
2383       if ((sz = ffebld_size_max (expr)) == FFETARGET_charactersizeNONE)
2384         catlist.maxlen = sz;
2385       else
2386         catlist.maxlen += sz;
2387       if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen > max))
2388         {                       /* This item overlaps (or is beyond) the end
2389                                    of the destination. */
2390           switch (ffebld_op (expr))
2391             {
2392             case FFEBLD_opCONTER:
2393             case FFEBLD_opSYMTER:
2394             case FFEBLD_opARRAYREF:
2395             case FFEBLD_opFUNCREF:
2396             case FFEBLD_opSUBSTR:
2397               /* ~~Do useful truncations here. */
2398               break;
2399
2400             default:
2401               assert ("op changed or inconsistent switches!" == NULL);
2402               break;
2403             }
2404         }
2405       catlist.exprs[catlist.count++] = expr;
2406       return catlist;
2407
2408     case FFEBLD_opPAREN:
2409       expr = ffebld_left (expr);
2410       goto recurse;             /* :::::::::::::::::::: */
2411
2412     case FFEBLD_opCONCATENATE:
2413       catlist = ffecom_concat_list_gather_ (catlist, ffebld_left (expr), max);
2414       expr = ffebld_right (expr);
2415       goto recurse;             /* :::::::::::::::::::: */
2416
2417 #if 0                           /* Breaks passing small actual arg to larger
2418                                    dummy arg of sfunc */
2419     case FFEBLD_opCONVERT:
2420       expr = ffebld_left (expr);
2421       {
2422         ffetargetCharacterSize cmax;
2423
2424         cmax = catlist.len + ffebld_size_known (expr);
2425
2426         if ((max == FFETARGET_charactersizeNONE) || (max > cmax))
2427           max = cmax;
2428       }
2429       goto recurse;             /* :::::::::::::::::::: */
2430 #endif
2431
2432     case FFEBLD_opANY:
2433       return catlist;
2434
2435     default:
2436       assert ("bad op in _gather_" == NULL);
2437       return catlist;
2438     }
2439 }
2440
2441 /* ffecom_concat_list_kill_ -- Kill list of concatenated string exprs
2442
2443    ffecomConcatList_ catlist;
2444    ffecom_concat_list_kill_(catlist);
2445
2446    Anything allocated within the list info is deallocated.  */
2447
2448 static void
2449 ffecom_concat_list_kill_ (ffecomConcatList_ catlist)
2450 {
2451   if (catlist.max != 0)
2452     malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2453                     catlist.max * sizeof (catlist.exprs[0]));
2454 }
2455
2456 /* Make list of concatenated string exprs.
2457
2458    Returns a flattened list of concatenated subexpressions given a
2459    tree of such expressions.  */
2460
2461 static ffecomConcatList_
2462 ffecom_concat_list_new_ (ffebld expr, ffetargetCharacterSize max)
2463 {
2464   ffecomConcatList_ catlist;
2465
2466   catlist.maxlen = catlist.minlen = catlist.max = catlist.count = 0;
2467   return ffecom_concat_list_gather_ (catlist, expr, max);
2468 }
2469
2470 /* Provide some kind of useful info on member of aggregate area,
2471    since current g77/gcc technology does not provide debug info
2472    on these members.  */
2473
2474 static void
2475 ffecom_debug_kludge_ (tree aggr, const char *aggr_type, ffesymbol member,
2476                       tree member_type UNUSED, ffetargetOffset offset)
2477 {
2478   tree value;
2479   tree decl;
2480   int len;
2481   char *buff;
2482   char space[120];
2483 #if 0
2484   tree type_id;
2485
2486   for (type_id = member_type;
2487        TREE_CODE (type_id) != IDENTIFIER_NODE;
2488        )
2489     {
2490       switch (TREE_CODE (type_id))
2491         {
2492         case INTEGER_TYPE:
2493         case REAL_TYPE:
2494           type_id = TYPE_NAME (type_id);
2495           break;
2496
2497         case ARRAY_TYPE:
2498         case COMPLEX_TYPE:
2499           type_id = TREE_TYPE (type_id);
2500           break;
2501
2502         default:
2503           assert ("no IDENTIFIER_NODE for type!" == NULL);
2504           type_id = error_mark_node;
2505           break;
2506         }
2507     }
2508 #endif
2509
2510   if (ffecom_transform_only_dummies_
2511       || !ffe_is_debug_kludge ())
2512     return;     /* Can't do this yet, maybe later. */
2513
2514   len = 60
2515     + strlen (aggr_type)
2516     + IDENTIFIER_LENGTH (DECL_NAME (aggr));
2517 #if 0
2518     + IDENTIFIER_LENGTH (type_id);
2519 #endif
2520
2521   if (((size_t) len) >= ARRAY_SIZE (space))
2522     buff = malloc_new_ks (malloc_pool_image (), "debug_kludge", len + 1);
2523   else
2524     buff = &space[0];
2525
2526   sprintf (&buff[0], "At (%s) `%s' plus %ld bytes",
2527            aggr_type,
2528            IDENTIFIER_POINTER (DECL_NAME (aggr)),
2529            (long int) offset);
2530
2531   value = build_string (len, buff);
2532   TREE_TYPE (value)
2533     = build_type_variant (build_array_type (char_type_node,
2534                                             build_range_type
2535                                             (integer_type_node,
2536                                              integer_one_node,
2537                                              build_int_2 (strlen (buff), 0))),
2538                           1, 0);
2539   decl = build_decl (VAR_DECL,
2540                      ffecom_get_identifier_ (ffesymbol_text (member)),
2541                      TREE_TYPE (value));
2542   TREE_CONSTANT (decl) = 1;
2543   TREE_STATIC (decl) = 1;
2544   DECL_INITIAL (decl) = error_mark_node;
2545   DECL_IN_SYSTEM_HEADER (decl) = 1;     /* Don't let -Wunused complain. */
2546   decl = start_decl (decl, FALSE);
2547   finish_decl (decl, value, FALSE);
2548
2549   if (buff != &space[0])
2550     malloc_kill_ks (malloc_pool_image (), buff, len + 1);
2551 }
2552
2553 /* ffecom_do_entry_ -- Do compilation of a particular entrypoint
2554
2555    ffesymbol fn;  // the SUBROUTINE, FUNCTION, or ENTRY symbol itself
2556    int i;  // entry# for this entrypoint (used by master fn)
2557    ffecom_do_entrypoint_(s,i);
2558
2559    Makes a public entry point that calls our private master fn (already
2560    compiled).  */
2561
2562 static void
2563 ffecom_do_entry_ (ffesymbol fn, int entrynum)
2564 {
2565   ffebld item;
2566   tree type;                    /* Type of function. */
2567   tree multi_retval;            /* Var holding return value (union). */
2568   tree result;                  /* Var holding result. */
2569   ffeinfoBasictype bt;
2570   ffeinfoKindtype kt;
2571   ffeglobal g;
2572   ffeglobalType gt;
2573   bool charfunc;                /* All entry points return same type
2574                                    CHARACTER. */
2575   bool cmplxfunc;               /* Use f2c way of returning COMPLEX. */
2576   bool multi;                   /* Master fn has multiple return types. */
2577   bool altreturning = FALSE;    /* This entry point has alternate returns. */
2578   int old_lineno = lineno;
2579   const char *old_input_filename = input_filename;
2580
2581   input_filename = ffesymbol_where_filename (fn);
2582   lineno = ffesymbol_where_filelinenum (fn);
2583
2584   ffecom_doing_entry_ = TRUE;   /* Don't bother with array dimensions. */
2585
2586   switch (ffecom_primary_entry_kind_)
2587     {
2588     case FFEINFO_kindFUNCTION:
2589
2590       /* Determine actual return type for function. */
2591
2592       gt = FFEGLOBAL_typeFUNC;
2593       bt = ffesymbol_basictype (fn);
2594       kt = ffesymbol_kindtype (fn);
2595       if (bt == FFEINFO_basictypeNONE)
2596         {
2597           ffeimplic_establish_symbol (fn);
2598           if (ffesymbol_funcresult (fn) != NULL)
2599             ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
2600           bt = ffesymbol_basictype (fn);
2601           kt = ffesymbol_kindtype (fn);
2602         }
2603
2604       if (bt == FFEINFO_basictypeCHARACTER)
2605         charfunc = TRUE, cmplxfunc = FALSE;
2606       else if ((bt == FFEINFO_basictypeCOMPLEX)
2607                && ffesymbol_is_f2c (fn))
2608         charfunc = FALSE, cmplxfunc = TRUE;
2609       else
2610         charfunc = cmplxfunc = FALSE;
2611
2612       if (charfunc)
2613         type = ffecom_tree_fun_type_void;
2614       else if (ffesymbol_is_f2c (fn))
2615         type = ffecom_tree_fun_type[bt][kt];
2616       else
2617         type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
2618
2619       if ((type == NULL_TREE)
2620           || (TREE_TYPE (type) == NULL_TREE))
2621         type = ffecom_tree_fun_type_void;       /* _sym_exec_transition. */
2622
2623       multi = (ffecom_master_bt_ == FFEINFO_basictypeNONE);
2624       break;
2625
2626     case FFEINFO_kindSUBROUTINE:
2627       gt = FFEGLOBAL_typeSUBR;
2628       bt = FFEINFO_basictypeNONE;
2629       kt = FFEINFO_kindtypeNONE;
2630       if (ffecom_is_altreturning_)
2631         {                       /* Am _I_ altreturning? */
2632           for (item = ffesymbol_dummyargs (fn);
2633                item != NULL;
2634                item = ffebld_trail (item))
2635             {
2636               if (ffebld_op (ffebld_head (item)) == FFEBLD_opSTAR)
2637                 {
2638                   altreturning = TRUE;
2639                   break;
2640                 }
2641             }
2642           if (altreturning)
2643             type = ffecom_tree_subr_type;
2644           else
2645             type = ffecom_tree_fun_type_void;
2646         }
2647       else
2648         type = ffecom_tree_fun_type_void;
2649       charfunc = FALSE;
2650       cmplxfunc = FALSE;
2651       multi = FALSE;
2652       break;
2653
2654     default:
2655       assert ("say what??" == NULL);
2656       /* Fall through. */
2657     case FFEINFO_kindANY:
2658       gt = FFEGLOBAL_typeANY;
2659       bt = FFEINFO_basictypeNONE;
2660       kt = FFEINFO_kindtypeNONE;
2661       type = error_mark_node;
2662       charfunc = FALSE;
2663       cmplxfunc = FALSE;
2664       multi = FALSE;
2665       break;
2666     }
2667
2668   /* build_decl uses the current lineno and input_filename to set the decl
2669      source info.  So, I've putzed with ffestd and ffeste code to update that
2670      source info to point to the appropriate statement just before calling
2671      ffecom_do_entrypoint (which calls this fn).  */
2672
2673   start_function (ffecom_get_external_identifier_ (fn),
2674                   type,
2675                   0,            /* nested/inline */
2676                   1);           /* TREE_PUBLIC */
2677
2678   if (((g = ffesymbol_global (fn)) != NULL)
2679       && ((ffeglobal_type (g) == gt)
2680           || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
2681     {
2682       ffeglobal_set_hook (g, current_function_decl);
2683     }
2684
2685   /* Reset args in master arg list so they get retransitioned. */
2686
2687   for (item = ffecom_master_arglist_;
2688        item != NULL;
2689        item = ffebld_trail (item))
2690     {
2691       ffebld arg;
2692       ffesymbol s;
2693
2694       arg = ffebld_head (item);
2695       if (ffebld_op (arg) != FFEBLD_opSYMTER)
2696         continue;               /* Alternate return or some such thing. */
2697       s = ffebld_symter (arg);
2698       ffesymbol_hook (s).decl_tree = NULL_TREE;
2699       ffesymbol_hook (s).length_tree = NULL_TREE;
2700     }
2701
2702   /* Build dummy arg list for this entry point. */
2703
2704   if (charfunc || cmplxfunc)
2705     {                           /* Prepend arg for where result goes. */
2706       tree type;
2707       tree length;
2708
2709       if (charfunc)
2710         type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
2711       else
2712         type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
2713
2714       result = ffecom_get_invented_identifier ("__g77_%s", "result");
2715
2716       /* Make length arg _and_ enhance type info for CHAR arg itself.  */
2717
2718       if (charfunc)
2719         length = ffecom_char_enhance_arg_ (&type, fn);
2720       else
2721         length = NULL_TREE;     /* Not ref'd if !charfunc. */
2722
2723       type = build_pointer_type (type);
2724       result = build_decl (PARM_DECL, result, type);
2725
2726       push_parm_decl (result);
2727       ffecom_func_result_ = result;
2728
2729       if (charfunc)
2730         {
2731           push_parm_decl (length);
2732           ffecom_func_length_ = length;
2733         }
2734     }
2735   else
2736     result = DECL_RESULT (current_function_decl);
2737
2738   ffecom_push_dummy_decls_ (ffesymbol_dummyargs (fn), FALSE);
2739
2740   store_parm_decls (0);
2741
2742   ffecom_start_compstmt ();
2743   /* Disallow temp vars at this level.  */
2744   current_binding_level->prep_state = 2;
2745
2746   /* Make local var to hold return type for multi-type master fn. */
2747
2748   if (multi)
2749     {
2750       multi_retval = ffecom_get_invented_identifier ("__g77_%s",
2751                                                      "multi_retval");
2752       multi_retval = build_decl (VAR_DECL, multi_retval,
2753                                  ffecom_multi_type_node_);
2754       multi_retval = start_decl (multi_retval, FALSE);
2755       finish_decl (multi_retval, NULL_TREE, FALSE);
2756     }
2757   else
2758     multi_retval = NULL_TREE;   /* Not actually ref'd if !multi. */
2759
2760   /* Here we emit the actual code for the entry point. */
2761
2762   {
2763     ffebld list;
2764     ffebld arg;
2765     ffesymbol s;
2766     tree arglist = NULL_TREE;
2767     tree *plist = &arglist;
2768     tree prepend;
2769     tree call;
2770     tree actarg;
2771     tree master_fn;
2772
2773     /* Prepare actual arg list based on master arg list. */
2774
2775     for (list = ffecom_master_arglist_;
2776          list != NULL;
2777          list = ffebld_trail (list))
2778       {
2779         arg = ffebld_head (list);
2780         if (ffebld_op (arg) != FFEBLD_opSYMTER)
2781           continue;
2782         s = ffebld_symter (arg);
2783         if (ffesymbol_hook (s).decl_tree == NULL_TREE
2784             || ffesymbol_hook (s).decl_tree == error_mark_node)
2785           actarg = null_pointer_node;   /* We don't have this arg. */
2786         else
2787           actarg = ffesymbol_hook (s).decl_tree;
2788         *plist = build_tree_list (NULL_TREE, actarg);
2789         plist = &TREE_CHAIN (*plist);
2790       }
2791
2792     /* This code appends the length arguments for character
2793        variables/arrays.  */
2794
2795     for (list = ffecom_master_arglist_;
2796          list != NULL;
2797          list = ffebld_trail (list))
2798       {
2799         arg = ffebld_head (list);
2800         if (ffebld_op (arg) != FFEBLD_opSYMTER)
2801           continue;
2802         s = ffebld_symter (arg);
2803         if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
2804           continue;             /* Only looking for CHARACTER arguments. */
2805         if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
2806           continue;             /* Only looking for variables and arrays. */
2807         if (ffesymbol_hook (s).length_tree == NULL_TREE
2808             || ffesymbol_hook (s).length_tree == error_mark_node)
2809           actarg = ffecom_f2c_ftnlen_zero_node; /* We don't have this arg. */
2810         else
2811           actarg = ffesymbol_hook (s).length_tree;
2812         *plist = build_tree_list (NULL_TREE, actarg);
2813         plist = &TREE_CHAIN (*plist);
2814       }
2815
2816     /* Prepend character-value return info to actual arg list. */
2817
2818     if (charfunc)
2819       {
2820         prepend = build_tree_list (NULL_TREE, ffecom_func_result_);
2821         TREE_CHAIN (prepend)
2822           = build_tree_list (NULL_TREE, ffecom_func_length_);
2823         TREE_CHAIN (TREE_CHAIN (prepend)) = arglist;
2824         arglist = prepend;
2825       }
2826
2827     /* Prepend multi-type return value to actual arg list. */
2828
2829     if (multi)
2830       {
2831         prepend
2832           = build_tree_list (NULL_TREE,
2833                              ffecom_1 (ADDR_EXPR,
2834                               build_pointer_type (TREE_TYPE (multi_retval)),
2835                                        multi_retval));
2836         TREE_CHAIN (prepend) = arglist;
2837         arglist = prepend;
2838       }
2839
2840     /* Prepend my entry-point number to the actual arg list. */
2841
2842     prepend = build_tree_list (NULL_TREE, build_int_2 (entrynum, 0));
2843     TREE_CHAIN (prepend) = arglist;
2844     arglist = prepend;
2845
2846     /* Build the call to the master function. */
2847
2848     master_fn = ffecom_1_fn (ffecom_previous_function_decl_);
2849     call = ffecom_3s (CALL_EXPR,
2850                       TREE_TYPE (TREE_TYPE (TREE_TYPE (master_fn))),
2851                       master_fn, arglist, NULL_TREE);
2852
2853     /* Decide whether the master function is a function or subroutine, and
2854        handle the return value for my entry point. */
2855
2856     if (charfunc || ((ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
2857                      && !altreturning))
2858       {
2859         expand_expr_stmt (call);
2860         expand_null_return ();
2861       }
2862     else if (multi && cmplxfunc)
2863       {
2864         expand_expr_stmt (call);
2865         result
2866           = ffecom_1 (INDIRECT_REF,
2867                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
2868                       result);
2869         result = ffecom_modify (NULL_TREE, result,
2870                                 ffecom_2 (COMPONENT_REF, TREE_TYPE (result),
2871                                           multi_retval,
2872                                           ffecom_multi_fields_[bt][kt]));
2873         expand_expr_stmt (result);
2874         expand_null_return ();
2875       }
2876     else if (multi)
2877       {
2878         expand_expr_stmt (call);
2879         result
2880           = ffecom_modify (NULL_TREE, result,
2881                            convert (TREE_TYPE (result),
2882                                     ffecom_2 (COMPONENT_REF,
2883                                               ffecom_tree_type[bt][kt],
2884                                               multi_retval,
2885                                               ffecom_multi_fields_[bt][kt])));
2886         expand_return (result);
2887       }
2888     else if (cmplxfunc)
2889       {
2890         result
2891           = ffecom_1 (INDIRECT_REF,
2892                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
2893                       result);
2894         result = ffecom_modify (NULL_TREE, result, call);
2895         expand_expr_stmt (result);
2896         expand_null_return ();
2897       }
2898     else
2899       {
2900         result = ffecom_modify (NULL_TREE,
2901                                 result,
2902                                 convert (TREE_TYPE (result),
2903                                          call));
2904         expand_return (result);
2905       }
2906   }
2907
2908   ffecom_end_compstmt ();
2909
2910   finish_function (0);
2911
2912   lineno = old_lineno;
2913   input_filename = old_input_filename;
2914
2915   ffecom_doing_entry_ = FALSE;
2916 }
2917
2918 /* Transform expr into gcc tree with possible destination
2919
2920    Recursive descent on expr while making corresponding tree nodes and
2921    attaching type info and such.  If destination supplied and compatible
2922    with temporary that would be made in certain cases, temporary isn't
2923    made, destination used instead, and dest_used flag set TRUE.  */
2924
2925 static tree
2926 ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
2927               bool *dest_used, bool assignp, bool widenp)
2928 {
2929   tree item;
2930   tree list;
2931   tree args;
2932   ffeinfoBasictype bt;
2933   ffeinfoKindtype kt;
2934   tree t;
2935   tree dt;                      /* decl_tree for an ffesymbol. */
2936   tree tree_type, tree_type_x;
2937   tree left, right;
2938   ffesymbol s;
2939   enum tree_code code;
2940
2941   assert (expr != NULL);
2942
2943   if (dest_used != NULL)
2944     *dest_used = FALSE;
2945
2946   bt = ffeinfo_basictype (ffebld_info (expr));
2947   kt = ffeinfo_kindtype (ffebld_info (expr));
2948   tree_type = ffecom_tree_type[bt][kt];
2949
2950   /* Widen integral arithmetic as desired while preserving signedness.  */
2951   tree_type_x = NULL_TREE;
2952   if (widenp && tree_type
2953       && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
2954       && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
2955     tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
2956
2957   switch (ffebld_op (expr))
2958     {
2959     case FFEBLD_opACCTER:
2960       {
2961         ffebitCount i;
2962         ffebit bits = ffebld_accter_bits (expr);
2963         ffetargetOffset source_offset = 0;
2964         ffetargetOffset dest_offset = ffebld_accter_pad (expr);
2965         tree purpose;
2966
2967         assert (dest_offset == 0
2968                 || (bt == FFEINFO_basictypeCHARACTER
2969                     && kt == FFEINFO_kindtypeCHARACTER1));
2970
2971         list = item = NULL;
2972         for (;;)
2973           {
2974             ffebldConstantUnion cu;
2975             ffebitCount length;
2976             bool value;
2977             ffebldConstantArray ca = ffebld_accter (expr);
2978
2979             ffebit_test (bits, source_offset, &value, &length);
2980             if (length == 0)
2981               break;
2982
2983             if (value)
2984               {
2985                 for (i = 0; i < length; ++i)
2986                   {
2987                     cu = ffebld_constantarray_get (ca, bt, kt,
2988                                                    source_offset + i);
2989
2990                     t = ffecom_constantunion (&cu, bt, kt, tree_type);
2991
2992                     if (i == 0
2993                         && dest_offset != 0)
2994                       purpose = build_int_2 (dest_offset, 0);
2995                     else
2996                       purpose = NULL_TREE;
2997
2998                     if (list == NULL_TREE)
2999                       list = item = build_tree_list (purpose, t);
3000                     else
3001                       {
3002                         TREE_CHAIN (item) = build_tree_list (purpose, t);
3003                         item = TREE_CHAIN (item);
3004                       }
3005                   }
3006               }
3007             source_offset += length;
3008             dest_offset += length;
3009           }
3010       }
3011
3012       item = build_int_2 ((ffebld_accter_size (expr)
3013                            + ffebld_accter_pad (expr)) - 1, 0);
3014       ffebit_kill (ffebld_accter_bits (expr));
3015       TREE_TYPE (item) = ffecom_integer_type_node;
3016       item
3017         = build_array_type
3018           (tree_type,
3019            build_range_type (ffecom_integer_type_node,
3020                              ffecom_integer_zero_node,
3021                              item));
3022       list = build (CONSTRUCTOR, item, NULL_TREE, list);
3023       TREE_CONSTANT (list) = 1;
3024       TREE_STATIC (list) = 1;
3025       return list;
3026
3027     case FFEBLD_opARRTER:
3028       {
3029         ffetargetOffset i;
3030
3031         list = NULL_TREE;
3032         if (ffebld_arrter_pad (expr) == 0)
3033           item = NULL_TREE;
3034         else
3035           {
3036             assert (bt == FFEINFO_basictypeCHARACTER
3037                     && kt == FFEINFO_kindtypeCHARACTER1);
3038
3039             /* Becomes PURPOSE first time through loop.  */
3040             item = build_int_2 (ffebld_arrter_pad (expr), 0);
3041           }
3042
3043         for (i = 0; i < ffebld_arrter_size (expr); ++i)
3044           {
3045             ffebldConstantUnion cu
3046             = ffebld_constantarray_get (ffebld_arrter (expr), bt, kt, i);
3047
3048             t = ffecom_constantunion (&cu, bt, kt, tree_type);
3049
3050             if (list == NULL_TREE)
3051               /* Assume item is PURPOSE first time through loop.  */
3052               list = item = build_tree_list (item, t);
3053             else
3054               {
3055                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
3056                 item = TREE_CHAIN (item);
3057               }
3058           }
3059       }
3060
3061       item = build_int_2 ((ffebld_arrter_size (expr)
3062                           + ffebld_arrter_pad (expr)) - 1, 0);
3063       TREE_TYPE (item) = ffecom_integer_type_node;
3064       item
3065         = build_array_type
3066           (tree_type,
3067            build_range_type (ffecom_integer_type_node,
3068                              ffecom_integer_zero_node,
3069                              item));
3070       list = build (CONSTRUCTOR, item, NULL_TREE, list);
3071       TREE_CONSTANT (list) = 1;
3072       TREE_STATIC (list) = 1;
3073       return list;
3074
3075     case FFEBLD_opCONTER:
3076       assert (ffebld_conter_pad (expr) == 0);
3077       item
3078         = ffecom_constantunion (&ffebld_constant_union (ffebld_conter (expr)),
3079                                 bt, kt, tree_type);
3080       return item;
3081
3082     case FFEBLD_opSYMTER:
3083       if ((ffebld_symter_generic (expr) != FFEINTRIN_genNONE)
3084           || (ffebld_symter_specific (expr) != FFEINTRIN_specNONE))
3085         return ffecom_ptr_to_expr (expr);       /* Same as %REF(intrinsic). */
3086       s = ffebld_symter (expr);
3087       t = ffesymbol_hook (s).decl_tree;
3088
3089       if (assignp)
3090         {                       /* ASSIGN'ed-label expr. */
3091           if (ffe_is_ugly_assign ())
3092             {
3093               /* User explicitly wants ASSIGN'ed variables to be at the same
3094                  memory address as the variables when used in non-ASSIGN
3095                  contexts.  That can make old, arcane, non-standard code
3096                  work, but don't try to do it when a pointer wouldn't fit
3097                  in the normal variable (take other approach, and warn,
3098                  instead).  */
3099
3100               if (t == NULL_TREE)
3101                 {
3102                   s = ffecom_sym_transform_ (s);
3103                   t = ffesymbol_hook (s).decl_tree;
3104                   assert (t != NULL_TREE);
3105                 }
3106
3107               if (t == error_mark_node)
3108                 return t;
3109
3110               if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t)))
3111                   >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
3112                 {
3113                   if (ffesymbol_hook (s).addr)
3114                     t = ffecom_1 (INDIRECT_REF,
3115                                   TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3116                   return t;
3117                 }
3118
3119               if (ffesymbol_hook (s).assign_tree == NULL_TREE)
3120                 {
3121                   /* xgettext:no-c-format */
3122                   ffebad_start_msg ("ASSIGN'ed label cannot fit into `%A' at %0 -- using wider sibling",
3123                                     FFEBAD_severityWARNING);
3124                   ffebad_string (ffesymbol_text (s));
3125                   ffebad_here (0, ffesymbol_where_line (s),
3126                                ffesymbol_where_column (s));
3127                   ffebad_finish ();
3128                 }
3129             }
3130
3131           /* Don't use the normal variable's tree for ASSIGN, though mark
3132              it as in the system header (housekeeping).  Use an explicit,
3133              specially created sibling that is known to be wide enough
3134              to hold pointers to labels.  */
3135
3136           if (t != NULL_TREE
3137               && TREE_CODE (t) == VAR_DECL)
3138             DECL_IN_SYSTEM_HEADER (t) = 1;      /* Don't let -Wunused complain. */
3139
3140           t = ffesymbol_hook (s).assign_tree;
3141           if (t == NULL_TREE)
3142             {
3143               s = ffecom_sym_transform_assign_ (s);
3144               t = ffesymbol_hook (s).assign_tree;
3145               assert (t != NULL_TREE);
3146             }
3147         }
3148       else
3149         {
3150           if (t == NULL_TREE)
3151             {
3152               s = ffecom_sym_transform_ (s);
3153               t = ffesymbol_hook (s).decl_tree;
3154               assert (t != NULL_TREE);
3155             }
3156           if (ffesymbol_hook (s).addr)
3157             t = ffecom_1 (INDIRECT_REF,
3158                           TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3159         }
3160       return t;
3161
3162     case FFEBLD_opARRAYREF:
3163       return ffecom_arrayref_ (NULL_TREE, expr, 0);
3164
3165     case FFEBLD_opUPLUS:
3166       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3167       return ffecom_1 (NOP_EXPR, tree_type, left);
3168
3169     case FFEBLD_opPAREN:
3170       /* ~~~Make sure Fortran rules respected here */
3171       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3172       return ffecom_1 (NOP_EXPR, tree_type, left);
3173
3174     case FFEBLD_opUMINUS:
3175       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3176       if (tree_type_x)
3177         {
3178           tree_type = tree_type_x;
3179           left = convert (tree_type, left);
3180         }
3181       return ffecom_1 (NEGATE_EXPR, tree_type, left);
3182
3183     case FFEBLD_opADD:
3184       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3185       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3186       if (tree_type_x)
3187         {
3188           tree_type = tree_type_x;
3189           left = convert (tree_type, left);
3190           right = convert (tree_type, right);
3191         }
3192       return ffecom_2 (PLUS_EXPR, tree_type, left, right);
3193
3194     case FFEBLD_opSUBTRACT:
3195       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3196       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3197       if (tree_type_x)
3198         {
3199           tree_type = tree_type_x;
3200           left = convert (tree_type, left);
3201           right = convert (tree_type, right);
3202         }
3203       return ffecom_2 (MINUS_EXPR, tree_type, left, right);
3204
3205     case FFEBLD_opMULTIPLY:
3206       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3207       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3208       if (tree_type_x)
3209         {
3210           tree_type = tree_type_x;
3211           left = convert (tree_type, left);
3212           right = convert (tree_type, right);
3213         }
3214       return ffecom_2 (MULT_EXPR, tree_type, left, right);
3215
3216     case FFEBLD_opDIVIDE:
3217       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3218       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3219       if (tree_type_x)
3220         {
3221           tree_type = tree_type_x;
3222           left = convert (tree_type, left);
3223           right = convert (tree_type, right);
3224         }
3225       return ffecom_tree_divide_ (tree_type, left, right,
3226                                   dest_tree, dest, dest_used,
3227                                   ffebld_nonter_hook (expr));
3228
3229     case FFEBLD_opPOWER:
3230       {
3231         ffebld left = ffebld_left (expr);
3232         ffebld right = ffebld_right (expr);
3233         ffecomGfrt code;
3234         ffeinfoKindtype rtkt;
3235         ffeinfoKindtype ltkt;
3236         bool ref = TRUE;
3237
3238         switch (ffeinfo_basictype (ffebld_info (right)))
3239           {
3240
3241           case FFEINFO_basictypeINTEGER:
3242             if (1 || optimize)
3243               {
3244                 item = ffecom_expr_power_integer_ (expr);
3245                 if (item != NULL_TREE)
3246                   return item;
3247               }
3248
3249             rtkt = FFEINFO_kindtypeINTEGER1;
3250             switch (ffeinfo_basictype (ffebld_info (left)))
3251               {
3252               case FFEINFO_basictypeINTEGER:
3253                 if ((ffeinfo_kindtype (ffebld_info (left))
3254                     == FFEINFO_kindtypeINTEGER4)
3255                     || (ffeinfo_kindtype (ffebld_info (right))
3256                         == FFEINFO_kindtypeINTEGER4))
3257                   {
3258                     code = FFECOM_gfrtPOW_QQ;
3259                     ltkt = FFEINFO_kindtypeINTEGER4;
3260                     rtkt = FFEINFO_kindtypeINTEGER4;
3261                   }
3262                 else
3263                   {
3264                     code = FFECOM_gfrtPOW_II;
3265                     ltkt = FFEINFO_kindtypeINTEGER1;
3266                   }
3267                 break;
3268
3269               case FFEINFO_basictypeREAL:
3270                 if (ffeinfo_kindtype (ffebld_info (left))
3271                     == FFEINFO_kindtypeREAL1)
3272                   {
3273                     code = FFECOM_gfrtPOW_RI;
3274                     ltkt = FFEINFO_kindtypeREAL1;
3275                   }
3276                 else
3277                   {
3278                     code = FFECOM_gfrtPOW_DI;
3279                     ltkt = FFEINFO_kindtypeREAL2;
3280                   }
3281                 break;
3282
3283               case FFEINFO_basictypeCOMPLEX:
3284                 if (ffeinfo_kindtype (ffebld_info (left))
3285                     == FFEINFO_kindtypeREAL1)
3286                   {
3287                     code = FFECOM_gfrtPOW_CI;   /* Overlapping result okay. */
3288                     ltkt = FFEINFO_kindtypeREAL1;
3289                   }
3290                 else
3291                   {
3292                     code = FFECOM_gfrtPOW_ZI;   /* Overlapping result okay. */
3293                     ltkt = FFEINFO_kindtypeREAL2;
3294                   }
3295                 break;
3296
3297               default:
3298                 assert ("bad pow_*i" == NULL);
3299                 code = FFECOM_gfrtPOW_CI;       /* Overlapping result okay. */
3300                 ltkt = FFEINFO_kindtypeREAL1;
3301                 break;
3302               }
3303             if (ffeinfo_kindtype (ffebld_info (left)) != ltkt)
3304               left = ffeexpr_convert (left, NULL, NULL,
3305                                       ffeinfo_basictype (ffebld_info (left)),
3306                                       ltkt, 0,
3307                                       FFETARGET_charactersizeNONE,
3308                                       FFEEXPR_contextLET);
3309             if (ffeinfo_kindtype (ffebld_info (right)) != rtkt)
3310               right = ffeexpr_convert (right, NULL, NULL,
3311                                        FFEINFO_basictypeINTEGER,
3312                                        rtkt, 0,
3313                                        FFETARGET_charactersizeNONE,
3314                                        FFEEXPR_contextLET);
3315             break;
3316
3317           case FFEINFO_basictypeREAL:
3318             if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3319               left = ffeexpr_convert (left, NULL, NULL, FFEINFO_basictypeREAL,
3320                                       FFEINFO_kindtypeREALDOUBLE, 0,
3321                                       FFETARGET_charactersizeNONE,
3322                                       FFEEXPR_contextLET);
3323             if (ffeinfo_kindtype (ffebld_info (right))
3324                 == FFEINFO_kindtypeREAL1)
3325               right = ffeexpr_convert (right, NULL, NULL,
3326                                        FFEINFO_basictypeREAL,
3327                                        FFEINFO_kindtypeREALDOUBLE, 0,
3328                                        FFETARGET_charactersizeNONE,
3329                                        FFEEXPR_contextLET);
3330             /* We used to call FFECOM_gfrtPOW_DD here,
3331                which passes arguments by reference.  */
3332             code = FFECOM_gfrtL_POW;
3333             /* Pass arguments by value. */
3334             ref  = FALSE;
3335             break;
3336
3337           case FFEINFO_basictypeCOMPLEX:
3338             if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3339               left = ffeexpr_convert (left, NULL, NULL,
3340                                       FFEINFO_basictypeCOMPLEX,
3341                                       FFEINFO_kindtypeREALDOUBLE, 0,
3342                                       FFETARGET_charactersizeNONE,
3343                                       FFEEXPR_contextLET);
3344             if (ffeinfo_kindtype (ffebld_info (right))
3345                 == FFEINFO_kindtypeREAL1)
3346               right = ffeexpr_convert (right, NULL, NULL,
3347                                        FFEINFO_basictypeCOMPLEX,
3348                                        FFEINFO_kindtypeREALDOUBLE, 0,
3349                                        FFETARGET_charactersizeNONE,
3350                                        FFEEXPR_contextLET);
3351             code = FFECOM_gfrtPOW_ZZ;   /* Overlapping result okay. */
3352             ref = TRUE;                 /* Pass arguments by reference. */
3353             break;
3354
3355           default:
3356             assert ("bad pow_x*" == NULL);
3357             code = FFECOM_gfrtPOW_II;
3358             break;
3359           }
3360         return ffecom_call_binop_ (ffecom_gfrt_tree_ (code),
3361                                    ffecom_gfrt_kindtype (code),
3362                                    (ffe_is_f2c_library ()
3363                                     && ffecom_gfrt_complex_[code]),
3364                                    tree_type, left, right,
3365                                    dest_tree, dest, dest_used,
3366                                    NULL_TREE, FALSE, ref,
3367                                    ffebld_nonter_hook (expr));
3368       }
3369
3370     case FFEBLD_opNOT:
3371       switch (bt)
3372         {
3373         case FFEINFO_basictypeLOGICAL:
3374           item = ffecom_truth_value_invert (ffecom_expr (ffebld_left (expr)));
3375           return convert (tree_type, item);
3376
3377         case FFEINFO_basictypeINTEGER:
3378           return ffecom_1 (BIT_NOT_EXPR, tree_type,
3379                            ffecom_expr (ffebld_left (expr)));
3380
3381         default:
3382           assert ("NOT bad basictype" == NULL);
3383           /* Fall through. */
3384         case FFEINFO_basictypeANY:
3385           return error_mark_node;
3386         }
3387       break;
3388
3389     case FFEBLD_opFUNCREF:
3390       assert (ffeinfo_basictype (ffebld_info (expr))
3391               != FFEINFO_basictypeCHARACTER);
3392       /* Fall through.   */
3393     case FFEBLD_opSUBRREF:
3394       if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
3395           == FFEINFO_whereINTRINSIC)
3396         {                       /* Invocation of an intrinsic. */
3397           item = ffecom_expr_intrinsic_ (expr, dest_tree, dest,
3398                                          dest_used);
3399           return item;
3400         }
3401       s = ffebld_symter (ffebld_left (expr));
3402       dt = ffesymbol_hook (s).decl_tree;
3403       if (dt == NULL_TREE)
3404         {
3405           s = ffecom_sym_transform_ (s);
3406           dt = ffesymbol_hook (s).decl_tree;
3407         }
3408       if (dt == error_mark_node)
3409         return dt;
3410
3411       if (ffesymbol_hook (s).addr)
3412         item = dt;
3413       else
3414         item = ffecom_1_fn (dt);
3415
3416       if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
3417         args = ffecom_list_expr (ffebld_right (expr));
3418       else
3419         args = ffecom_list_ptr_to_expr (ffebld_right (expr));
3420
3421       if (args == error_mark_node)
3422         return error_mark_node;
3423
3424       item = ffecom_call_ (item, kt,
3425                            ffesymbol_is_f2c (s)
3426                            && (bt == FFEINFO_basictypeCOMPLEX)
3427                            && (ffesymbol_where (s)
3428                                != FFEINFO_whereCONSTANT),
3429                            tree_type,
3430                            args,
3431                            dest_tree, dest, dest_used,
3432                            error_mark_node, FALSE,
3433                            ffebld_nonter_hook (expr));
3434       TREE_SIDE_EFFECTS (item) = 1;
3435       return item;
3436
3437     case FFEBLD_opAND:
3438       switch (bt)
3439         {
3440         case FFEINFO_basictypeLOGICAL:
3441           item
3442             = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3443                        ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3444                      ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3445           return convert (tree_type, item);
3446
3447         case FFEINFO_basictypeINTEGER:
3448           return ffecom_2 (BIT_AND_EXPR, tree_type,
3449                            ffecom_expr (ffebld_left (expr)),
3450                            ffecom_expr (ffebld_right (expr)));
3451
3452         default:
3453           assert ("AND bad basictype" == NULL);
3454           /* Fall through. */
3455         case FFEINFO_basictypeANY:
3456           return error_mark_node;
3457         }
3458       break;
3459
3460     case FFEBLD_opOR:
3461       switch (bt)
3462         {
3463         case FFEINFO_basictypeLOGICAL:
3464           item
3465             = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
3466                        ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3467                      ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3468           return convert (tree_type, item);
3469
3470         case FFEINFO_basictypeINTEGER:
3471           return ffecom_2 (BIT_IOR_EXPR, tree_type,
3472                            ffecom_expr (ffebld_left (expr)),
3473                            ffecom_expr (ffebld_right (expr)));
3474
3475         default:
3476           assert ("OR bad basictype" == NULL);
3477           /* Fall through. */
3478         case FFEINFO_basictypeANY:
3479           return error_mark_node;
3480         }
3481       break;
3482
3483     case FFEBLD_opXOR:
3484     case FFEBLD_opNEQV:
3485       switch (bt)
3486         {
3487         case FFEINFO_basictypeLOGICAL:
3488           item
3489             = ffecom_2 (NE_EXPR, integer_type_node,
3490                         ffecom_expr (ffebld_left (expr)),
3491                         ffecom_expr (ffebld_right (expr)));
3492           return convert (tree_type, ffecom_truth_value (item));
3493
3494         case FFEINFO_basictypeINTEGER:
3495           return ffecom_2 (BIT_XOR_EXPR, tree_type,
3496                            ffecom_expr (ffebld_left (expr)),
3497                            ffecom_expr (ffebld_right (expr)));
3498
3499         default:
3500           assert ("XOR/NEQV bad basictype" == NULL);
3501           /* Fall through. */
3502         case FFEINFO_basictypeANY:
3503           return error_mark_node;
3504         }
3505       break;
3506
3507     case FFEBLD_opEQV:
3508       switch (bt)
3509         {
3510         case FFEINFO_basictypeLOGICAL:
3511           item
3512             = ffecom_2 (EQ_EXPR, integer_type_node,
3513                         ffecom_expr (ffebld_left (expr)),
3514                         ffecom_expr (ffebld_right (expr)));
3515           return convert (tree_type, ffecom_truth_value (item));
3516
3517         case FFEINFO_basictypeINTEGER:
3518           return
3519             ffecom_1 (BIT_NOT_EXPR, tree_type,
3520                       ffecom_2 (BIT_XOR_EXPR, tree_type,
3521                                 ffecom_expr (ffebld_left (expr)),
3522                                 ffecom_expr (ffebld_right (expr))));
3523
3524         default:
3525           assert ("EQV bad basictype" == NULL);
3526           /* Fall through. */
3527         case FFEINFO_basictypeANY:
3528           return error_mark_node;
3529         }
3530       break;
3531
3532     case FFEBLD_opCONVERT:
3533       if (ffebld_op (ffebld_left (expr)) == FFEBLD_opANY)
3534         return error_mark_node;
3535
3536       switch (bt)
3537         {
3538         case FFEINFO_basictypeLOGICAL:
3539         case FFEINFO_basictypeINTEGER:
3540         case FFEINFO_basictypeREAL:
3541           return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3542
3543         case FFEINFO_basictypeCOMPLEX:
3544           switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3545             {
3546             case FFEINFO_basictypeINTEGER:
3547             case FFEINFO_basictypeLOGICAL:
3548             case FFEINFO_basictypeREAL:
3549               item = ffecom_expr (ffebld_left (expr));
3550               if (item == error_mark_node)
3551                 return error_mark_node;
3552               /* convert() takes care of converting to the subtype first,
3553                  at least in gcc-2.7.2. */
3554               item = convert (tree_type, item);
3555               return item;
3556
3557             case FFEINFO_basictypeCOMPLEX:
3558               return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3559
3560             default:
3561               assert ("CONVERT COMPLEX bad basictype" == NULL);
3562               /* Fall through. */
3563             case FFEINFO_basictypeANY:
3564               return error_mark_node;
3565             }
3566           break;
3567
3568         default:
3569           assert ("CONVERT bad basictype" == NULL);
3570           /* Fall through. */
3571         case FFEINFO_basictypeANY:
3572           return error_mark_node;
3573         }
3574       break;
3575
3576     case FFEBLD_opLT:
3577       code = LT_EXPR;
3578       goto relational;          /* :::::::::::::::::::: */
3579
3580     case FFEBLD_opLE:
3581       code = LE_EXPR;
3582       goto relational;          /* :::::::::::::::::::: */
3583
3584     case FFEBLD_opEQ:
3585       code = EQ_EXPR;
3586       goto relational;          /* :::::::::::::::::::: */
3587
3588     case FFEBLD_opNE:
3589       code = NE_EXPR;
3590       goto relational;          /* :::::::::::::::::::: */
3591
3592     case FFEBLD_opGT:
3593       code = GT_EXPR;
3594       goto relational;          /* :::::::::::::::::::: */
3595
3596     case FFEBLD_opGE:
3597       code = GE_EXPR;
3598
3599     relational:         /* :::::::::::::::::::: */
3600       switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3601         {
3602         case FFEINFO_basictypeLOGICAL:
3603         case FFEINFO_basictypeINTEGER:
3604         case FFEINFO_basictypeREAL:
3605           item = ffecom_2 (code, integer_type_node,
3606                            ffecom_expr (ffebld_left (expr)),
3607                            ffecom_expr (ffebld_right (expr)));
3608           return convert (tree_type, item);
3609
3610         case FFEINFO_basictypeCOMPLEX:
3611           assert (code == EQ_EXPR || code == NE_EXPR);
3612           {
3613             tree real_type;
3614             tree arg1 = ffecom_expr (ffebld_left (expr));
3615             tree arg2 = ffecom_expr (ffebld_right (expr));
3616
3617             if (arg1 == error_mark_node || arg2 == error_mark_node)
3618               return error_mark_node;
3619
3620             arg1 = ffecom_save_tree (arg1);
3621             arg2 = ffecom_save_tree (arg2);
3622
3623             if (TREE_CODE (TREE_TYPE (arg1)) == COMPLEX_TYPE)
3624               {
3625                 real_type = TREE_TYPE (TREE_TYPE (arg1));
3626                 assert (real_type == TREE_TYPE (TREE_TYPE (arg2)));
3627               }
3628             else
3629               {
3630                 real_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg1)));
3631                 assert (real_type == TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg2))));
3632               }
3633
3634             item
3635               = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3636                           ffecom_2 (EQ_EXPR, integer_type_node,
3637                                   ffecom_1 (REALPART_EXPR, real_type, arg1),
3638                                  ffecom_1 (REALPART_EXPR, real_type, arg2)),
3639                           ffecom_2 (EQ_EXPR, integer_type_node,
3640                                   ffecom_1 (IMAGPART_EXPR, real_type, arg1),
3641                                     ffecom_1 (IMAGPART_EXPR, real_type,
3642                                               arg2)));
3643             if (code == EQ_EXPR)
3644               item = ffecom_truth_value (item);
3645             else
3646               item = ffecom_truth_value_invert (item);
3647             return convert (tree_type, item);
3648           }
3649
3650         case FFEINFO_basictypeCHARACTER:
3651           {
3652             ffebld left = ffebld_left (expr);
3653             ffebld right = ffebld_right (expr);
3654             tree left_tree;
3655             tree right_tree;
3656             tree left_length;
3657             tree right_length;
3658
3659             /* f2c run-time functions do the implicit blank-padding for us,
3660                so we don't usually have to implement blank-padding ourselves.
3661                (The exception is when we pass an argument to a separately
3662                compiled statement function -- if we know the arg is not the
3663                same length as the dummy, we must truncate or extend it.  If
3664                we "inline" statement functions, that necessity goes away as
3665                well.)
3666
3667                Strip off the CONVERT operators that blank-pad.  (Truncation by
3668                CONVERT shouldn't happen here, but it can happen in
3669                assignments.) */
3670
3671             while (ffebld_op (left) == FFEBLD_opCONVERT)
3672               left = ffebld_left (left);
3673             while (ffebld_op (right) == FFEBLD_opCONVERT)
3674               right = ffebld_left (right);
3675
3676             left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
3677             right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
3678
3679             if (left_tree == error_mark_node || left_length == error_mark_node
3680                 || right_tree == error_mark_node
3681                 || right_length == error_mark_node)
3682               return error_mark_node;
3683
3684             if ((ffebld_size_known (left) == 1)
3685                 && (ffebld_size_known (right) == 1))
3686               {
3687                 left_tree
3688                   = ffecom_1 (INDIRECT_REF,
3689                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3690                               left_tree);
3691                 right_tree
3692                   = ffecom_1 (INDIRECT_REF,
3693                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3694                               right_tree);
3695
3696                 item
3697                   = ffecom_2 (code, integer_type_node,
3698                               ffecom_2 (ARRAY_REF,
3699                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3700                                         left_tree,
3701                                         integer_one_node),
3702                               ffecom_2 (ARRAY_REF,
3703                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3704                                         right_tree,
3705                                         integer_one_node));
3706               }
3707             else
3708               {
3709                 item = build_tree_list (NULL_TREE, left_tree);
3710                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, right_tree);
3711                 TREE_CHAIN (TREE_CHAIN (item)) = build_tree_list (NULL_TREE,
3712                                                                left_length);
3713                 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
3714                   = build_tree_list (NULL_TREE, right_length);
3715                 item = ffecom_call_gfrt (FFECOM_gfrtCMP, item, NULL_TREE);
3716                 item = ffecom_2 (code, integer_type_node,
3717                                  item,
3718                                  convert (TREE_TYPE (item),
3719                                           integer_zero_node));
3720               }
3721             item = convert (tree_type, item);
3722           }
3723
3724           return item;
3725
3726         default:
3727           assert ("relational bad basictype" == NULL);
3728           /* Fall through. */
3729         case FFEINFO_basictypeANY:
3730           return error_mark_node;
3731         }
3732       break;
3733
3734     case FFEBLD_opPERCENT_LOC:
3735       item = ffecom_arg_ptr_to_expr (ffebld_left (expr), &list);
3736       return convert (tree_type, item);
3737
3738     case FFEBLD_opPERCENT_VAL:
3739       item = ffecom_arg_expr (ffebld_left (expr), &list);
3740       return convert (tree_type, item);
3741
3742     case FFEBLD_opITEM:
3743     case FFEBLD_opSTAR:
3744     case FFEBLD_opBOUNDS:
3745     case FFEBLD_opREPEAT:
3746     case FFEBLD_opLABTER:
3747     case FFEBLD_opLABTOK:
3748     case FFEBLD_opIMPDO:
3749     case FFEBLD_opCONCATENATE:
3750     case FFEBLD_opSUBSTR:
3751     default:
3752       assert ("bad op" == NULL);
3753       /* Fall through. */
3754     case FFEBLD_opANY:
3755       return error_mark_node;
3756     }
3757
3758 #if 1
3759   assert ("didn't think anything got here anymore!!" == NULL);
3760 #else
3761   switch (ffebld_arity (expr))
3762     {
3763     case 2:
3764       TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3765       TREE_OPERAND (item, 1) = ffecom_expr (ffebld_right (expr));
3766       if (TREE_OPERAND (item, 0) == error_mark_node
3767           || TREE_OPERAND (item, 1) == error_mark_node)
3768         return error_mark_node;
3769       break;
3770
3771     case 1:
3772       TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3773       if (TREE_OPERAND (item, 0) == error_mark_node)
3774         return error_mark_node;
3775       break;
3776
3777     default:
3778       break;
3779     }
3780
3781   return fold (item);
3782 #endif
3783 }
3784
3785 /* Returns the tree that does the intrinsic invocation.
3786
3787    Note: this function applies only to intrinsics returning
3788    CHARACTER*1 or non-CHARACTER results, and to intrinsic
3789    subroutines.  */
3790
3791 static tree
3792 ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
3793                         ffebld dest, bool *dest_used)
3794 {
3795   tree expr_tree;
3796   tree saved_expr1;             /* For those who need it. */
3797   tree saved_expr2;             /* For those who need it. */
3798   ffeinfoBasictype bt;
3799   ffeinfoKindtype kt;
3800   tree tree_type;
3801   tree arg1_type;
3802   tree real_type;               /* REAL type corresponding to COMPLEX. */
3803   tree tempvar;
3804   ffebld list = ffebld_right (expr);    /* List of (some) args. */
3805   ffebld arg1;                  /* For handy reference. */
3806   ffebld arg2;
3807   ffebld arg3;
3808   ffeintrinImp codegen_imp;
3809   ffecomGfrt gfrt;
3810
3811   assert (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER);
3812
3813   if (dest_used != NULL)
3814     *dest_used = FALSE;
3815
3816   bt = ffeinfo_basictype (ffebld_info (expr));
3817   kt = ffeinfo_kindtype (ffebld_info (expr));
3818   tree_type = ffecom_tree_type[bt][kt];
3819
3820   if (list != NULL)
3821     {
3822       arg1 = ffebld_head (list);
3823       if (arg1 != NULL && ffebld_op (arg1) == FFEBLD_opANY)
3824         return error_mark_node;
3825       if ((list = ffebld_trail (list)) != NULL)
3826         {
3827           arg2 = ffebld_head (list);
3828           if (arg2 != NULL && ffebld_op (arg2) == FFEBLD_opANY)
3829             return error_mark_node;
3830           if ((list = ffebld_trail (list)) != NULL)
3831             {
3832               arg3 = ffebld_head (list);
3833               if (arg3 != NULL && ffebld_op (arg3) == FFEBLD_opANY)
3834                 return error_mark_node;
3835             }
3836           else
3837             arg3 = NULL;
3838         }
3839       else
3840         arg2 = arg3 = NULL;
3841     }
3842   else
3843     arg1 = arg2 = arg3 = NULL;
3844
3845   /* <list> ends up at the opITEM of the 3rd arg, or NULL if there are < 3
3846      args.  This is used by the MAX/MIN expansions. */
3847
3848   if (arg1 != NULL)
3849     arg1_type = ffecom_tree_type
3850       [ffeinfo_basictype (ffebld_info (arg1))]
3851       [ffeinfo_kindtype (ffebld_info (arg1))];
3852   else
3853     arg1_type = NULL_TREE;      /* Really not needed, but might catch bugs
3854                                    here. */
3855
3856   /* There are several ways for each of the cases in the following switch
3857      statements to exit (from simplest to use to most complicated):
3858
3859      break;  (when expr_tree == NULL)
3860
3861      A standard call is made to the specific intrinsic just as if it had been
3862      passed in as a dummy procedure and called as any old procedure.  This
3863      method can produce slower code but in some cases it's the easiest way for
3864      now.  However, if a (presumably faster) direct call is available,
3865      that is used, so this is the easiest way in many more cases now.
3866
3867      gfrt = FFECOM_gfrtWHATEVER;
3868      break;
3869
3870      gfrt contains the gfrt index of a library function to call, passing the
3871      argument(s) by value rather than by reference.  Used when a more
3872      careful choice of library function is needed than that provided
3873      by the vanilla `break;'.
3874
3875      return expr_tree;
3876
3877      The expr_tree has been completely set up and is ready to be returned
3878      as is.  No further actions are taken.  Use this when the tree is not
3879      in the simple form for one of the arity_n labels.   */
3880
3881   /* For info on how the switch statement cases were written, see the files
3882      enclosed in comments below the switch statement. */
3883
3884   codegen_imp = ffebld_symter_implementation (ffebld_left (expr));
3885   gfrt = ffeintrin_gfrt_direct (codegen_imp);
3886   if (gfrt == FFECOM_gfrt)
3887     gfrt = ffeintrin_gfrt_indirect (codegen_imp);
3888
3889   switch (codegen_imp)
3890     {
3891     case FFEINTRIN_impABS:
3892     case FFEINTRIN_impCABS:
3893     case FFEINTRIN_impCDABS:
3894     case FFEINTRIN_impDABS:
3895     case FFEINTRIN_impIABS:
3896       if (ffeinfo_basictype (ffebld_info (arg1))
3897           == FFEINFO_basictypeCOMPLEX)
3898         {
3899           if (kt == FFEINFO_kindtypeREAL1)
3900             gfrt = FFECOM_gfrtCABS;
3901           else if (kt == FFEINFO_kindtypeREAL2)
3902             gfrt = FFECOM_gfrtCDABS;
3903           break;
3904         }
3905       return ffecom_1 (ABS_EXPR, tree_type,
3906                        convert (tree_type, ffecom_expr (arg1)));
3907
3908     case FFEINTRIN_impACOS:
3909     case FFEINTRIN_impDACOS:
3910       break;
3911
3912     case FFEINTRIN_impAIMAG:
3913     case FFEINTRIN_impDIMAG:
3914     case FFEINTRIN_impIMAGPART:
3915       if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
3916         arg1_type = TREE_TYPE (arg1_type);
3917       else
3918         arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
3919
3920       return
3921         convert (tree_type,
3922                  ffecom_1 (IMAGPART_EXPR, arg1_type,
3923                            ffecom_expr (arg1)));
3924
3925     case FFEINTRIN_impAINT:
3926     case FFEINTRIN_impDINT:
3927 #if 0
3928       /* ~~Someday implement FIX_TRUNC_EXPR yielding same type as arg.  */
3929       return ffecom_1 (FIX_TRUNC_EXPR, tree_type, ffecom_expr (arg1));
3930 #else /* in the meantime, must use floor to avoid range problems with ints */
3931       /* r__1 = r1 >= 0 ? floor(r1) : -floor(-r1); */
3932       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
3933       return
3934         convert (tree_type,
3935                  ffecom_3 (COND_EXPR, double_type_node,
3936                            ffecom_truth_value
3937                            (ffecom_2 (GE_EXPR, integer_type_node,
3938                                       saved_expr1,
3939                                       convert (arg1_type,
3940                                                ffecom_float_zero_))),
3941                            ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
3942                                              build_tree_list (NULL_TREE,
3943                                                   convert (double_type_node,
3944                                                            saved_expr1)),
3945                                              NULL_TREE),
3946                            ffecom_1 (NEGATE_EXPR, double_type_node,
3947                                      ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
3948                                                  build_tree_list (NULL_TREE,
3949                                                   convert (double_type_node,
3950                                                       ffecom_1 (NEGATE_EXPR,
3951                                                                 arg1_type,
3952                                                                saved_expr1))),
3953                                                        NULL_TREE)
3954                                      ))
3955                  );
3956 #endif
3957
3958     case FFEINTRIN_impANINT:
3959     case FFEINTRIN_impDNINT:
3960 #if 0                           /* This way of doing it won't handle real
3961                                    numbers of large magnitudes. */
3962       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
3963       expr_tree = convert (tree_type,
3964                            convert (integer_type_node,
3965                                     ffecom_3 (COND_EXPR, tree_type,
3966                                               ffecom_truth_value
3967                                               (ffecom_2 (GE_EXPR,
3968                                                          integer_type_node,
3969                                                          saved_expr1,
3970                                                        ffecom_float_zero_)),
3971                                               ffecom_2 (PLUS_EXPR,
3972                                                         tree_type,
3973                                                         saved_expr1,
3974                                                         ffecom_float_half_),
3975                                               ffecom_2 (MINUS_EXPR,
3976                                                         tree_type,
3977                                                         saved_expr1,
3978                                                      ffecom_float_half_))));
3979       return expr_tree;
3980 #else /* So we instead call floor. */
3981       /* r__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1) */
3982       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
3983       return
3984         convert (tree_type,
3985                  ffecom_3 (COND_EXPR, double_type_node,
3986                            ffecom_truth_value
3987                            (ffecom_2 (GE_EXPR, integer_type_node,
3988                                       saved_expr1,
3989                                       convert (arg1_type,
3990                                                ffecom_float_zero_))),
3991                            ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
3992                                              build_tree_list (NULL_TREE,
3993                                                   convert (double_type_node,
3994                                                            ffecom_2 (PLUS_EXPR,
3995                                                                      arg1_type,
3996                                                                      saved_expr1,
3997                                                                      convert (arg1_type,
3998                                                                               ffecom_float_half_)))),
3999                                              NULL_TREE),
4000                            ffecom_1 (NEGATE_EXPR, double_type_node,
4001                                      ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4002                                                        build_tree_list (NULL_TREE,
4003                                                                         convert (double_type_node,
4004                                                                                  ffecom_2 (MINUS_EXPR,
4005                                                                                            arg1_type,
4006                                                                                            convert (arg1_type,
4007                                                                                                     ffecom_float_half_),
4008                                                                                            saved_expr1))),
4009                                                        NULL_TREE))
4010                            )
4011                  );
4012 #endif
4013
4014     case FFEINTRIN_impASIN:
4015     case FFEINTRIN_impDASIN:
4016     case FFEINTRIN_impATAN:
4017     case FFEINTRIN_impDATAN:
4018     case FFEINTRIN_impATAN2:
4019     case FFEINTRIN_impDATAN2:
4020       break;
4021
4022     case FFEINTRIN_impCHAR:
4023     case FFEINTRIN_impACHAR:
4024 #ifdef HOHO
4025       tempvar = ffecom_make_tempvar (char_type_node, 1, -1);
4026 #else
4027       tempvar = ffebld_nonter_hook (expr);
4028       assert (tempvar);
4029 #endif
4030       {
4031         tree tmv = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (tempvar)));
4032
4033         expr_tree = ffecom_modify (tmv,
4034                                    ffecom_2 (ARRAY_REF, tmv, tempvar,
4035                                              integer_one_node),
4036                                    convert (tmv, ffecom_expr (arg1)));
4037       }
4038       expr_tree = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar),
4039                             expr_tree,
4040                             tempvar);
4041       expr_tree = ffecom_1 (ADDR_EXPR,
4042                             build_pointer_type (TREE_TYPE (expr_tree)),
4043                             expr_tree);
4044       return expr_tree;
4045
4046     case FFEINTRIN_impCMPLX:
4047     case FFEINTRIN_impDCMPLX:
4048       if (arg2 == NULL)
4049         return
4050           convert (tree_type, ffecom_expr (arg1));
4051
4052       real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4053       return
4054         ffecom_2 (COMPLEX_EXPR, tree_type,
4055                   convert (real_type, ffecom_expr (arg1)),
4056                   convert (real_type,
4057                            ffecom_expr (arg2)));
4058
4059     case FFEINTRIN_impCOMPLEX:
4060       return
4061         ffecom_2 (COMPLEX_EXPR, tree_type,
4062                   ffecom_expr (arg1),
4063                   ffecom_expr (arg2));
4064
4065     case FFEINTRIN_impCONJG:
4066     case FFEINTRIN_impDCONJG:
4067       {
4068         tree arg1_tree;
4069
4070         real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4071         arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4072         return
4073           ffecom_2 (COMPLEX_EXPR, tree_type,
4074                     ffecom_1 (REALPART_EXPR, real_type, arg1_tree),
4075                     ffecom_1 (NEGATE_EXPR, real_type,
4076                               ffecom_1 (IMAGPART_EXPR, real_type, arg1_tree)));
4077       }
4078
4079     case FFEINTRIN_impCOS:
4080     case FFEINTRIN_impCCOS:
4081     case FFEINTRIN_impCDCOS:
4082     case FFEINTRIN_impDCOS:
4083       if (bt == FFEINFO_basictypeCOMPLEX)
4084         {
4085           if (kt == FFEINFO_kindtypeREAL1)
4086             gfrt = FFECOM_gfrtCCOS;     /* Overlapping result okay. */
4087           else if (kt == FFEINFO_kindtypeREAL2)
4088             gfrt = FFECOM_gfrtCDCOS;    /* Overlapping result okay. */
4089         }
4090       break;
4091
4092     case FFEINTRIN_impCOSH:
4093     case FFEINTRIN_impDCOSH:
4094       break;
4095
4096     case FFEINTRIN_impDBLE:
4097     case FFEINTRIN_impDFLOAT:
4098     case FFEINTRIN_impDREAL:
4099     case FFEINTRIN_impFLOAT:
4100     case FFEINTRIN_impIDINT:
4101     case FFEINTRIN_impIFIX:
4102     case FFEINTRIN_impINT2:
4103     case FFEINTRIN_impINT8:
4104     case FFEINTRIN_impINT:
4105     case FFEINTRIN_impLONG:
4106     case FFEINTRIN_impREAL:
4107     case FFEINTRIN_impSHORT:
4108     case FFEINTRIN_impSNGL:
4109       return convert (tree_type, ffecom_expr (arg1));
4110
4111     case FFEINTRIN_impDIM:
4112     case FFEINTRIN_impDDIM:
4113     case FFEINTRIN_impIDIM:
4114       saved_expr1 = ffecom_save_tree (convert (tree_type,
4115                                                ffecom_expr (arg1)));
4116       saved_expr2 = ffecom_save_tree (convert (tree_type,
4117                                                ffecom_expr (arg2)));
4118       return
4119         ffecom_3 (COND_EXPR, tree_type,
4120                   ffecom_truth_value
4121                   (ffecom_2 (GT_EXPR, integer_type_node,
4122                              saved_expr1,
4123                              saved_expr2)),
4124                   ffecom_2 (MINUS_EXPR, tree_type,
4125                             saved_expr1,
4126                             saved_expr2),
4127                   convert (tree_type, ffecom_float_zero_));
4128
4129     case FFEINTRIN_impDPROD:
4130       return
4131         ffecom_2 (MULT_EXPR, tree_type,
4132                   convert (tree_type, ffecom_expr (arg1)),
4133                   convert (tree_type, ffecom_expr (arg2)));
4134
4135     case FFEINTRIN_impEXP:
4136     case FFEINTRIN_impCDEXP:
4137     case FFEINTRIN_impCEXP:
4138     case FFEINTRIN_impDEXP:
4139       if (bt == FFEINFO_basictypeCOMPLEX)
4140         {
4141           if (kt == FFEINFO_kindtypeREAL1)
4142             gfrt = FFECOM_gfrtCEXP;     /* Overlapping result okay. */
4143           else if (kt == FFEINFO_kindtypeREAL2)
4144             gfrt = FFECOM_gfrtCDEXP;    /* Overlapping result okay. */
4145         }
4146       break;
4147
4148     case FFEINTRIN_impICHAR:
4149     case FFEINTRIN_impIACHAR:
4150 #if 0                           /* The simple approach. */
4151       ffecom_char_args_ (&expr_tree, &saved_expr1 /* Ignored */ , arg1);
4152       expr_tree
4153         = ffecom_1 (INDIRECT_REF,
4154                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4155                     expr_tree);
4156       expr_tree
4157         = ffecom_2 (ARRAY_REF,
4158                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4159                     expr_tree,
4160                     integer_one_node);
4161       return convert (tree_type, expr_tree);
4162 #else /* The more interesting (and more optimal) approach. */
4163       expr_tree = ffecom_intrinsic_ichar_ (tree_type, arg1, &saved_expr1);
4164       expr_tree = ffecom_3 (COND_EXPR, tree_type,
4165                             saved_expr1,
4166                             expr_tree,
4167                             convert (tree_type, integer_zero_node));
4168       return expr_tree;
4169 #endif
4170
4171     case FFEINTRIN_impINDEX:
4172       break;
4173
4174     case FFEINTRIN_impLEN:
4175 #if 0
4176       break;                                    /* The simple approach. */
4177 #else
4178       return ffecom_intrinsic_len_ (arg1);      /* The more optimal approach. */
4179 #endif
4180
4181     case FFEINTRIN_impLGE:
4182     case FFEINTRIN_impLGT:
4183     case FFEINTRIN_impLLE:
4184     case FFEINTRIN_impLLT:
4185       break;
4186
4187     case FFEINTRIN_impLOG:
4188     case FFEINTRIN_impALOG:
4189     case FFEINTRIN_impCDLOG:
4190     case FFEINTRIN_impCLOG:
4191     case FFEINTRIN_impDLOG:
4192       if (bt == FFEINFO_basictypeCOMPLEX)
4193         {
4194           if (kt == FFEINFO_kindtypeREAL1)
4195             gfrt = FFECOM_gfrtCLOG;     /* Overlapping result okay. */
4196           else if (kt == FFEINFO_kindtypeREAL2)
4197             gfrt = FFECOM_gfrtCDLOG;    /* Overlapping result okay. */
4198         }
4199       break;
4200
4201     case FFEINTRIN_impLOG10:
4202     case FFEINTRIN_impALOG10:
4203     case FFEINTRIN_impDLOG10:
4204       if (gfrt != FFECOM_gfrt)
4205         break;  /* Already picked one, stick with it. */
4206
4207       if (kt == FFEINFO_kindtypeREAL1)
4208         /* We used to call FFECOM_gfrtALOG10 here.  */
4209         gfrt = FFECOM_gfrtL_LOG10;
4210       else if (kt == FFEINFO_kindtypeREAL2)
4211         /* We used to call FFECOM_gfrtDLOG10 here.  */
4212         gfrt = FFECOM_gfrtL_LOG10;
4213       break;
4214
4215     case FFEINTRIN_impMAX:
4216     case FFEINTRIN_impAMAX0:
4217     case FFEINTRIN_impAMAX1:
4218     case FFEINTRIN_impDMAX1:
4219     case FFEINTRIN_impMAX0:
4220     case FFEINTRIN_impMAX1:
4221       if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4222         arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4223       else
4224         arg1_type = tree_type;
4225       expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4226                             convert (arg1_type, ffecom_expr (arg1)),
4227                             convert (arg1_type, ffecom_expr (arg2)));
4228       for (; list != NULL; list = ffebld_trail (list))
4229         {
4230           if ((ffebld_head (list) == NULL)
4231               || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4232             continue;
4233           expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4234                                 expr_tree,
4235                                 convert (arg1_type,
4236                                          ffecom_expr (ffebld_head (list))));
4237         }
4238       return convert (tree_type, expr_tree);
4239
4240     case FFEINTRIN_impMIN:
4241     case FFEINTRIN_impAMIN0:
4242     case FFEINTRIN_impAMIN1:
4243     case FFEINTRIN_impDMIN1:
4244     case FFEINTRIN_impMIN0:
4245     case FFEINTRIN_impMIN1:
4246       if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4247         arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4248       else
4249         arg1_type = tree_type;
4250       expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4251                             convert (arg1_type, ffecom_expr (arg1)),
4252                             convert (arg1_type, ffecom_expr (arg2)));
4253       for (; list != NULL; list = ffebld_trail (list))
4254         {
4255           if ((ffebld_head (list) == NULL)
4256               || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4257             continue;
4258           expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4259                                 expr_tree,
4260                                 convert (arg1_type,
4261                                          ffecom_expr (ffebld_head (list))));
4262         }
4263       return convert (tree_type, expr_tree);
4264
4265     case FFEINTRIN_impMOD:
4266     case FFEINTRIN_impAMOD:
4267     case FFEINTRIN_impDMOD:
4268       if (bt != FFEINFO_basictypeREAL)
4269         return ffecom_2 (TRUNC_MOD_EXPR, tree_type,
4270                          convert (tree_type, ffecom_expr (arg1)),
4271                          convert (tree_type, ffecom_expr (arg2)));
4272
4273       if (kt == FFEINFO_kindtypeREAL1)
4274         /* We used to call FFECOM_gfrtAMOD here.  */
4275         gfrt = FFECOM_gfrtL_FMOD;
4276       else if (kt == FFEINFO_kindtypeREAL2)
4277         /* We used to call FFECOM_gfrtDMOD here.  */
4278         gfrt = FFECOM_gfrtL_FMOD;
4279       break;
4280
4281     case FFEINTRIN_impNINT:
4282     case FFEINTRIN_impIDNINT:
4283 #if 0
4284       /* ~~Ideally FIX_ROUND_EXPR would be implemented, but it ain't yet.  */
4285       return ffecom_1 (FIX_ROUND_EXPR, tree_type, ffecom_expr (arg1));
4286 #else
4287       /* i__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1); */
4288       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4289       return
4290         convert (ffecom_integer_type_node,
4291                  ffecom_3 (COND_EXPR, arg1_type,
4292                            ffecom_truth_value
4293                            (ffecom_2 (GE_EXPR, integer_type_node,
4294                                       saved_expr1,
4295                                       convert (arg1_type,
4296                                                ffecom_float_zero_))),
4297                            ffecom_2 (PLUS_EXPR, arg1_type,
4298                                      saved_expr1,
4299                                      convert (arg1_type,
4300                                               ffecom_float_half_)),
4301                            ffecom_2 (MINUS_EXPR, arg1_type,
4302                                      saved_expr1,
4303                                      convert (arg1_type,
4304                                               ffecom_float_half_))));
4305 #endif
4306
4307     case FFEINTRIN_impSIGN:
4308     case FFEINTRIN_impDSIGN:
4309     case FFEINTRIN_impISIGN:
4310       {
4311         tree arg2_tree = ffecom_expr (arg2);
4312
4313         saved_expr1
4314           = ffecom_save_tree
4315           (ffecom_1 (ABS_EXPR, tree_type,
4316                      convert (tree_type,
4317                               ffecom_expr (arg1))));
4318         expr_tree
4319           = ffecom_3 (COND_EXPR, tree_type,
4320                       ffecom_truth_value
4321                       (ffecom_2 (GE_EXPR, integer_type_node,
4322                                  arg2_tree,
4323                                  convert (TREE_TYPE (arg2_tree),
4324                                           integer_zero_node))),
4325                       saved_expr1,
4326                       ffecom_1 (NEGATE_EXPR, tree_type, saved_expr1));
4327         /* Make sure SAVE_EXPRs get referenced early enough. */
4328         expr_tree
4329           = ffecom_2 (COMPOUND_EXPR, tree_type,
4330                       convert (void_type_node, saved_expr1),
4331                       expr_tree);
4332       }
4333       return expr_tree;
4334
4335     case FFEINTRIN_impSIN:
4336     case FFEINTRIN_impCDSIN:
4337     case FFEINTRIN_impCSIN:
4338     case FFEINTRIN_impDSIN:
4339       if (bt == FFEINFO_basictypeCOMPLEX)
4340         {
4341           if (kt == FFEINFO_kindtypeREAL1)
4342             gfrt = FFECOM_gfrtCSIN;     /* Overlapping result okay. */
4343           else if (kt == FFEINFO_kindtypeREAL2)
4344             gfrt = FFECOM_gfrtCDSIN;    /* Overlapping result okay. */
4345         }
4346       break;
4347
4348     case FFEINTRIN_impSINH:
4349     case FFEINTRIN_impDSINH:
4350       break;
4351
4352     case FFEINTRIN_impSQRT:
4353     case FFEINTRIN_impCDSQRT:
4354     case FFEINTRIN_impCSQRT:
4355     case FFEINTRIN_impDSQRT:
4356       if (bt == FFEINFO_basictypeCOMPLEX)
4357         {
4358           if (kt == FFEINFO_kindtypeREAL1)
4359             gfrt = FFECOM_gfrtCSQRT;    /* Overlapping result okay. */
4360           else if (kt == FFEINFO_kindtypeREAL2)
4361             gfrt = FFECOM_gfrtCDSQRT;   /* Overlapping result okay. */
4362         }
4363       break;
4364
4365     case FFEINTRIN_impTAN:
4366     case FFEINTRIN_impDTAN:
4367     case FFEINTRIN_impTANH:
4368     case FFEINTRIN_impDTANH:
4369       break;
4370
4371     case FFEINTRIN_impREALPART:
4372       if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
4373         arg1_type = TREE_TYPE (arg1_type);
4374       else
4375         arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
4376
4377       return
4378         convert (tree_type,
4379                  ffecom_1 (REALPART_EXPR, arg1_type,
4380                            ffecom_expr (arg1)));
4381
4382     case FFEINTRIN_impIAND:
4383     case FFEINTRIN_impAND:
4384       return ffecom_2 (BIT_AND_EXPR, tree_type,
4385                        convert (tree_type,
4386                                 ffecom_expr (arg1)),
4387                        convert (tree_type,
4388                                 ffecom_expr (arg2)));
4389
4390     case FFEINTRIN_impIOR:
4391     case FFEINTRIN_impOR:
4392       return ffecom_2 (BIT_IOR_EXPR, tree_type,
4393                        convert (tree_type,
4394                                 ffecom_expr (arg1)),
4395                        convert (tree_type,
4396                                 ffecom_expr (arg2)));
4397
4398     case FFEINTRIN_impIEOR:
4399     case FFEINTRIN_impXOR:
4400       return ffecom_2 (BIT_XOR_EXPR, tree_type,
4401                        convert (tree_type,
4402                                 ffecom_expr (arg1)),
4403                        convert (tree_type,
4404                                 ffecom_expr (arg2)));
4405
4406     case FFEINTRIN_impLSHIFT:
4407       return ffecom_2 (LSHIFT_EXPR, tree_type,
4408                        ffecom_expr (arg1),
4409                        convert (integer_type_node,
4410                                 ffecom_expr (arg2)));
4411
4412     case FFEINTRIN_impRSHIFT:
4413       return ffecom_2 (RSHIFT_EXPR, tree_type,
4414                        ffecom_expr (arg1),
4415                        convert (integer_type_node,
4416                                 ffecom_expr (arg2)));
4417
4418     case FFEINTRIN_impNOT:
4419       return ffecom_1 (BIT_NOT_EXPR, tree_type, ffecom_expr (arg1));
4420
4421     case FFEINTRIN_impBIT_SIZE:
4422       return convert (tree_type, TYPE_SIZE (arg1_type));
4423
4424     case FFEINTRIN_impBTEST:
4425       {
4426         ffetargetLogical1 target_true;
4427         ffetargetLogical1 target_false;
4428         tree true_tree;
4429         tree false_tree;
4430
4431         ffetarget_logical1 (&target_true, TRUE);
4432         ffetarget_logical1 (&target_false, FALSE);
4433         if (target_true == 1)
4434           true_tree = convert (tree_type, integer_one_node);
4435         else
4436           true_tree = convert (tree_type, build_int_2 (target_true, 0));
4437         if (target_false == 0)
4438           false_tree = convert (tree_type, integer_zero_node);
4439         else
4440           false_tree = convert (tree_type, build_int_2 (target_false, 0));
4441
4442         return
4443           ffecom_3 (COND_EXPR, tree_type,
4444                     ffecom_truth_value
4445                     (ffecom_2 (EQ_EXPR, integer_type_node,
4446                                ffecom_2 (BIT_AND_EXPR, arg1_type,
4447                                          ffecom_expr (arg1),
4448                                          ffecom_2 (LSHIFT_EXPR, arg1_type,
4449                                                    convert (arg1_type,
4450                                                           integer_one_node),
4451                                                    convert (integer_type_node,
4452                                                             ffecom_expr (arg2)))),
4453                                convert (arg1_type,
4454                                         integer_zero_node))),
4455                     false_tree,
4456                     true_tree);
4457       }
4458
4459     case FFEINTRIN_impIBCLR:
4460       return
4461         ffecom_2 (BIT_AND_EXPR, tree_type,
4462                   ffecom_expr (arg1),
4463                   ffecom_1 (BIT_NOT_EXPR, tree_type,
4464                             ffecom_2 (LSHIFT_EXPR, tree_type,
4465                                       convert (tree_type,
4466                                                integer_one_node),
4467                                       convert (integer_type_node,
4468                                                ffecom_expr (arg2)))));
4469
4470     case FFEINTRIN_impIBITS:
4471       {
4472         tree arg3_tree = ffecom_save_tree (convert (integer_type_node,
4473                                                     ffecom_expr (arg3)));
4474         tree uns_type
4475         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4476
4477         expr_tree
4478           = ffecom_2 (BIT_AND_EXPR, tree_type,
4479                       ffecom_2 (RSHIFT_EXPR, tree_type,
4480                                 ffecom_expr (arg1),
4481                                 convert (integer_type_node,
4482                                          ffecom_expr (arg2))),
4483                       convert (tree_type,
4484                                ffecom_2 (RSHIFT_EXPR, uns_type,
4485                                          ffecom_1 (BIT_NOT_EXPR,
4486                                                    uns_type,
4487                                                    convert (uns_type,
4488                                                         integer_zero_node)),
4489                                          ffecom_2 (MINUS_EXPR,
4490                                                    integer_type_node,
4491                                                    TYPE_SIZE (uns_type),
4492                                                    arg3_tree))));
4493         /* Fix up, because the RSHIFT_EXPR above can't shift over TYPE_SIZE.  */
4494         expr_tree
4495           = ffecom_3 (COND_EXPR, tree_type,
4496                       ffecom_truth_value
4497                       (ffecom_2 (NE_EXPR, integer_type_node,
4498                                  arg3_tree,
4499                                  integer_zero_node)),
4500                       expr_tree,
4501                       convert (tree_type, integer_zero_node));
4502       }
4503       return expr_tree;
4504
4505     case FFEINTRIN_impIBSET:
4506       return
4507         ffecom_2 (BIT_IOR_EXPR, tree_type,
4508                   ffecom_expr (arg1),
4509                   ffecom_2 (LSHIFT_EXPR, tree_type,
4510                             convert (tree_type, integer_one_node),
4511                             convert (integer_type_node,
4512                                      ffecom_expr (arg2))));
4513
4514     case FFEINTRIN_impISHFT:
4515       {
4516         tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4517         tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4518                                                     ffecom_expr (arg2)));
4519         tree uns_type
4520         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4521
4522         expr_tree
4523           = ffecom_3 (COND_EXPR, tree_type,
4524                       ffecom_truth_value
4525                       (ffecom_2 (GE_EXPR, integer_type_node,
4526                                  arg2_tree,
4527                                  integer_zero_node)),
4528                       ffecom_2 (LSHIFT_EXPR, tree_type,
4529                                 arg1_tree,
4530                                 arg2_tree),
4531                       convert (tree_type,
4532                                ffecom_2 (RSHIFT_EXPR, uns_type,
4533                                          convert (uns_type, arg1_tree),
4534                                          ffecom_1 (NEGATE_EXPR,
4535                                                    integer_type_node,
4536                                                    arg2_tree))));
4537         /* Fix up, because {L|R}SHIFT_EXPR don't go over TYPE_SIZE bounds.  */
4538         expr_tree
4539           = ffecom_3 (COND_EXPR, tree_type,
4540                       ffecom_truth_value
4541                       (ffecom_2 (NE_EXPR, integer_type_node,
4542                                  ffecom_1 (ABS_EXPR,
4543                                            integer_type_node,
4544                                            arg2_tree),
4545                                  TYPE_SIZE (uns_type))),
4546                       expr_tree,
4547                       convert (tree_type, integer_zero_node));
4548         /* Make sure SAVE_EXPRs get referenced early enough. */
4549         expr_tree
4550           = ffecom_2 (COMPOUND_EXPR, tree_type,
4551                       convert (void_type_node, arg1_tree),
4552                       ffecom_2 (COMPOUND_EXPR, tree_type,
4553                                 convert (void_type_node, arg2_tree),
4554                                 expr_tree));
4555       }
4556       return expr_tree;
4557
4558     case FFEINTRIN_impISHFTC:
4559       {
4560         tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4561         tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4562                                                     ffecom_expr (arg2)));
4563         tree arg3_tree = (arg3 == NULL) ? TYPE_SIZE (tree_type)
4564         : ffecom_save_tree (convert (integer_type_node, ffecom_expr (arg3)));
4565         tree shift_neg;
4566         tree shift_pos;
4567         tree mask_arg1;
4568         tree masked_arg1;
4569         tree uns_type
4570         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4571
4572         mask_arg1
4573           = ffecom_2 (LSHIFT_EXPR, tree_type,
4574                       ffecom_1 (BIT_NOT_EXPR, tree_type,
4575                                 convert (tree_type, integer_zero_node)),
4576                       arg3_tree);
4577         /* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE.  */
4578         mask_arg1
4579           = ffecom_3 (COND_EXPR, tree_type,
4580                       ffecom_truth_value
4581                       (ffecom_2 (NE_EXPR, integer_type_node,
4582                                  arg3_tree,
4583                                  TYPE_SIZE (uns_type))),
4584                       mask_arg1,
4585                       convert (tree_type, integer_zero_node));
4586         mask_arg1 = ffecom_save_tree (mask_arg1);
4587         masked_arg1
4588           = ffecom_2 (BIT_AND_EXPR, tree_type,
4589                       arg1_tree,
4590                       ffecom_1 (BIT_NOT_EXPR, tree_type,
4591                                 mask_arg1));
4592         masked_arg1 = ffecom_save_tree (masked_arg1);
4593         shift_neg
4594           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4595                       convert (tree_type,
4596                                ffecom_2 (RSHIFT_EXPR, uns_type,
4597                                          convert (uns_type, masked_arg1),
4598                                          ffecom_1 (NEGATE_EXPR,
4599                                                    integer_type_node,
4600                                                    arg2_tree))),
4601                       ffecom_2 (LSHIFT_EXPR, tree_type,
4602                                 arg1_tree,
4603                                 ffecom_2 (PLUS_EXPR, integer_type_node,
4604                                           arg2_tree,
4605                                           arg3_tree)));
4606         shift_pos
4607           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4608                       ffecom_2 (LSHIFT_EXPR, tree_type,
4609                                 arg1_tree,
4610                                 arg2_tree),
4611                       convert (tree_type,
4612                                ffecom_2 (RSHIFT_EXPR, uns_type,
4613                                          convert (uns_type, masked_arg1),
4614                                          ffecom_2 (MINUS_EXPR,
4615                                                    integer_type_node,
4616                                                    arg3_tree,
4617                                                    arg2_tree))));
4618         expr_tree
4619           = ffecom_3 (COND_EXPR, tree_type,
4620                       ffecom_truth_value
4621                       (ffecom_2 (LT_EXPR, integer_type_node,
4622                                  arg2_tree,
4623                                  integer_zero_node)),
4624                       shift_neg,
4625                       shift_pos);
4626         expr_tree
4627           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4628                       ffecom_2 (BIT_AND_EXPR, tree_type,
4629                                 mask_arg1,
4630                                 arg1_tree),
4631                       ffecom_2 (BIT_AND_EXPR, tree_type,
4632                                 ffecom_1 (BIT_NOT_EXPR, tree_type,
4633                                           mask_arg1),
4634                                 expr_tree));
4635         expr_tree
4636           = ffecom_3 (COND_EXPR, tree_type,
4637                       ffecom_truth_value
4638                       (ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
4639                                  ffecom_2 (EQ_EXPR, integer_type_node,
4640                                            ffecom_1 (ABS_EXPR,
4641                                                      integer_type_node,
4642                                                      arg2_tree),
4643                                            arg3_tree),
4644                                  ffecom_2 (EQ_EXPR, integer_type_node,
4645                                            arg2_tree,
4646                                            integer_zero_node))),
4647                       arg1_tree,
4648                       expr_tree);
4649         /* Make sure SAVE_EXPRs get referenced early enough. */
4650         expr_tree
4651           = ffecom_2 (COMPOUND_EXPR, tree_type,
4652                       convert (void_type_node, arg1_tree),
4653                       ffecom_2 (COMPOUND_EXPR, tree_type,
4654                                 convert (void_type_node, arg2_tree),
4655                                 ffecom_2 (COMPOUND_EXPR, tree_type,
4656                                           convert (void_type_node,
4657                                                    mask_arg1),
4658                                           ffecom_2 (COMPOUND_EXPR, tree_type,
4659                                                     convert (void_type_node,
4660                                                              masked_arg1),
4661                                                     expr_tree))));
4662         expr_tree
4663           = ffecom_2 (COMPOUND_EXPR, tree_type,
4664                       convert (void_type_node,
4665                                arg3_tree),
4666                       expr_tree);
4667       }
4668       return expr_tree;
4669
4670     case FFEINTRIN_impLOC:
4671       {
4672         tree arg1_tree = ffecom_expr (arg1);
4673
4674         expr_tree
4675           = convert (tree_type,
4676                      ffecom_1 (ADDR_EXPR,
4677                                build_pointer_type (TREE_TYPE (arg1_tree)),
4678                                arg1_tree));
4679       }
4680       return expr_tree;
4681
4682     case FFEINTRIN_impMVBITS:
4683       {
4684         tree arg1_tree;
4685         tree arg2_tree;
4686         tree arg3_tree;
4687         ffebld arg4 = ffebld_head (ffebld_trail (list));
4688         tree arg4_tree;
4689         tree arg4_type;
4690         ffebld arg5 = ffebld_head (ffebld_trail (ffebld_trail (list)));
4691         tree arg5_tree;
4692         tree prep_arg1;
4693         tree prep_arg4;
4694         tree arg5_plus_arg3;
4695
4696         arg2_tree = convert (integer_type_node,
4697                              ffecom_expr (arg2));
4698         arg3_tree = ffecom_save_tree (convert (integer_type_node,
4699                                                ffecom_expr (arg3)));
4700         arg4_tree = ffecom_expr_rw (NULL_TREE, arg4);
4701         arg4_type = TREE_TYPE (arg4_tree);
4702
4703         arg1_tree = ffecom_save_tree (convert (arg4_type,
4704                                                ffecom_expr (arg1)));
4705
4706         arg5_tree = ffecom_save_tree (convert (integer_type_node,
4707                                                ffecom_expr (arg5)));
4708
4709         prep_arg1
4710           = ffecom_2 (LSHIFT_EXPR, arg4_type,
4711                       ffecom_2 (BIT_AND_EXPR, arg4_type,
4712                                 ffecom_2 (RSHIFT_EXPR, arg4_type,
4713                                           arg1_tree,
4714                                           arg2_tree),
4715                                 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4716                                           ffecom_2 (LSHIFT_EXPR, arg4_type,
4717                                                     ffecom_1 (BIT_NOT_EXPR,
4718                                                               arg4_type,
4719                                                               convert
4720                                                               (arg4_type,
4721                                                         integer_zero_node)),
4722                                                     arg3_tree))),
4723                       arg5_tree);
4724         arg5_plus_arg3
4725           = ffecom_save_tree (ffecom_2 (PLUS_EXPR, arg4_type,
4726                                         arg5_tree,
4727                                         arg3_tree));
4728         prep_arg4
4729           = ffecom_2 (LSHIFT_EXPR, arg4_type,
4730                       ffecom_1 (BIT_NOT_EXPR, arg4_type,
4731                                 convert (arg4_type,
4732                                          integer_zero_node)),
4733                       arg5_plus_arg3);
4734         /* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE.  */
4735         prep_arg4
4736           = ffecom_3 (COND_EXPR, arg4_type,
4737                       ffecom_truth_value
4738                       (ffecom_2 (NE_EXPR, integer_type_node,
4739                                  arg5_plus_arg3,
4740                                  convert (TREE_TYPE (arg5_plus_arg3),
4741                                           TYPE_SIZE (arg4_type)))),
4742                       prep_arg4,
4743                       convert (arg4_type, integer_zero_node));
4744         prep_arg4
4745           = ffecom_2 (BIT_AND_EXPR, arg4_type,
4746                       arg4_tree,
4747                       ffecom_2 (BIT_IOR_EXPR, arg4_type,
4748                                 prep_arg4,
4749                                 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4750                                           ffecom_2 (LSHIFT_EXPR, arg4_type,
4751                                                     ffecom_1 (BIT_NOT_EXPR,
4752                                                               arg4_type,
4753                                                               convert
4754                                                               (arg4_type,
4755                                                         integer_zero_node)),
4756                                                     arg5_tree))));
4757         prep_arg1
4758           = ffecom_2 (BIT_IOR_EXPR, arg4_type,
4759                       prep_arg1,
4760                       prep_arg4);
4761         /* Fix up (twice), because LSHIFT_EXPR above
4762            can't shift over TYPE_SIZE.  */
4763         prep_arg1
4764           = ffecom_3 (COND_EXPR, arg4_type,
4765                       ffecom_truth_value
4766                       (ffecom_2 (NE_EXPR, integer_type_node,
4767                                  arg3_tree,
4768                                  convert (TREE_TYPE (arg3_tree),
4769                                           integer_zero_node))),
4770                       prep_arg1,
4771                       arg4_tree);
4772         prep_arg1
4773           = ffecom_3 (COND_EXPR, arg4_type,
4774                       ffecom_truth_value
4775                       (ffecom_2 (NE_EXPR, integer_type_node,
4776                                  arg3_tree,
4777                                  convert (TREE_TYPE (arg3_tree),
4778                                           TYPE_SIZE (arg4_type)))),
4779                       prep_arg1,
4780                       arg1_tree);
4781         expr_tree
4782           = ffecom_2s (MODIFY_EXPR, void_type_node,
4783                        arg4_tree,
4784                        prep_arg1);
4785         /* Make sure SAVE_EXPRs get referenced early enough. */
4786         expr_tree
4787           = ffecom_2 (COMPOUND_EXPR, void_type_node,
4788                       arg1_tree,
4789                       ffecom_2 (COMPOUND_EXPR, void_type_node,
4790                                 arg3_tree,
4791                                 ffecom_2 (COMPOUND_EXPR, void_type_node,
4792                                           arg5_tree,
4793                                           ffecom_2 (COMPOUND_EXPR, void_type_node,
4794                                                     arg5_plus_arg3,
4795                                                     expr_tree))));
4796         expr_tree
4797           = ffecom_2 (COMPOUND_EXPR, void_type_node,
4798                       arg4_tree,
4799                       expr_tree);
4800
4801       }
4802       return expr_tree;
4803
4804     case FFEINTRIN_impDERF:
4805     case FFEINTRIN_impERF:
4806     case FFEINTRIN_impDERFC:
4807     case FFEINTRIN_impERFC:
4808       break;
4809
4810     case FFEINTRIN_impIARGC:
4811       /* extern int xargc; i__1 = xargc - 1; */
4812       expr_tree = ffecom_2 (MINUS_EXPR, TREE_TYPE (ffecom_tree_xargc_),
4813                             ffecom_tree_xargc_,
4814                             convert (TREE_TYPE (ffecom_tree_xargc_),
4815                                      integer_one_node));
4816       return expr_tree;
4817
4818     case FFEINTRIN_impSIGNAL_func:
4819     case FFEINTRIN_impSIGNAL_subr:
4820       {
4821         tree arg1_tree;
4822         tree arg2_tree;
4823         tree arg3_tree;
4824
4825         arg1_tree = convert (ffecom_f2c_integer_type_node,
4826                              ffecom_expr (arg1));
4827         arg1_tree = ffecom_1 (ADDR_EXPR,
4828                               build_pointer_type (TREE_TYPE (arg1_tree)),
4829                               arg1_tree);
4830
4831         /* Pass procedure as a pointer to it, anything else by value.  */
4832         if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
4833           arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
4834         else
4835           arg2_tree = ffecom_ptr_to_expr (arg2);
4836         arg2_tree = convert (TREE_TYPE (null_pointer_node),
4837                              arg2_tree);
4838
4839         if (arg3 != NULL)
4840           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
4841         else
4842           arg3_tree = NULL_TREE;
4843
4844         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4845         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4846         TREE_CHAIN (arg1_tree) = arg2_tree;
4847
4848         expr_tree
4849           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4850                           ffecom_gfrt_kindtype (gfrt),
4851                           FALSE,
4852                           ((codegen_imp == FFEINTRIN_impSIGNAL_subr) ?
4853                            NULL_TREE :
4854                            tree_type),
4855                           arg1_tree,
4856                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4857                           ffebld_nonter_hook (expr));
4858
4859         if (arg3_tree != NULL_TREE)
4860           expr_tree
4861             = ffecom_modify (NULL_TREE, arg3_tree,
4862                              convert (TREE_TYPE (arg3_tree),
4863                                       expr_tree));
4864       }
4865       return expr_tree;
4866
4867     case FFEINTRIN_impALARM:
4868       {
4869         tree arg1_tree;
4870         tree arg2_tree;
4871         tree arg3_tree;
4872
4873         arg1_tree = convert (ffecom_f2c_integer_type_node,
4874                              ffecom_expr (arg1));
4875         arg1_tree = ffecom_1 (ADDR_EXPR,
4876                               build_pointer_type (TREE_TYPE (arg1_tree)),
4877                               arg1_tree);
4878
4879         /* Pass procedure as a pointer to it, anything else by value.  */
4880         if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
4881           arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
4882         else
4883           arg2_tree = ffecom_ptr_to_expr (arg2);
4884         arg2_tree = convert (TREE_TYPE (null_pointer_node),
4885                              arg2_tree);
4886
4887         if (arg3 != NULL)
4888           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
4889         else
4890           arg3_tree = NULL_TREE;
4891
4892         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4893         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4894         TREE_CHAIN (arg1_tree) = arg2_tree;
4895
4896         expr_tree
4897           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4898                           ffecom_gfrt_kindtype (gfrt),
4899                           FALSE,
4900                           NULL_TREE,
4901                           arg1_tree,
4902                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4903                           ffebld_nonter_hook (expr));
4904
4905         if (arg3_tree != NULL_TREE)
4906           expr_tree
4907             = ffecom_modify (NULL_TREE, arg3_tree,
4908                              convert (TREE_TYPE (arg3_tree),
4909                                       expr_tree));
4910       }
4911       return expr_tree;
4912
4913     case FFEINTRIN_impCHDIR_subr:
4914     case FFEINTRIN_impFDATE_subr:
4915     case FFEINTRIN_impFGET_subr:
4916     case FFEINTRIN_impFPUT_subr:
4917     case FFEINTRIN_impGETCWD_subr:
4918     case FFEINTRIN_impHOSTNM_subr:
4919     case FFEINTRIN_impSYSTEM_subr:
4920     case FFEINTRIN_impUNLINK_subr:
4921       {
4922         tree arg1_len = integer_zero_node;
4923         tree arg1_tree;
4924         tree arg2_tree;
4925
4926         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
4927
4928         if (arg2 != NULL)
4929           arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
4930         else
4931           arg2_tree = NULL_TREE;
4932
4933         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4934         arg1_len = build_tree_list (NULL_TREE, arg1_len);
4935         TREE_CHAIN (arg1_tree) = arg1_len;
4936
4937         expr_tree
4938           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4939                           ffecom_gfrt_kindtype (gfrt),
4940                           FALSE,
4941                           NULL_TREE,
4942                           arg1_tree,
4943                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4944                           ffebld_nonter_hook (expr));
4945
4946         if (arg2_tree != NULL_TREE)
4947           expr_tree
4948             = ffecom_modify (NULL_TREE, arg2_tree,
4949                              convert (TREE_TYPE (arg2_tree),
4950                                       expr_tree));
4951       }
4952       return expr_tree;
4953
4954     case FFEINTRIN_impEXIT:
4955       if (arg1 != NULL)
4956         break;
4957
4958       expr_tree = build_tree_list (NULL_TREE,
4959                                    ffecom_1 (ADDR_EXPR,
4960                                              build_pointer_type
4961                                              (ffecom_integer_type_node),
4962                                              integer_zero_node));
4963
4964       return
4965         ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4966                       ffecom_gfrt_kindtype (gfrt),
4967                       FALSE,
4968                       void_type_node,
4969                       expr_tree,
4970                       NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4971                       ffebld_nonter_hook (expr));
4972
4973     case FFEINTRIN_impFLUSH:
4974       if (arg1 == NULL)
4975         gfrt = FFECOM_gfrtFLUSH;
4976       else
4977         gfrt = FFECOM_gfrtFLUSH1;
4978       break;
4979
4980     case FFEINTRIN_impCHMOD_subr:
4981     case FFEINTRIN_impLINK_subr:
4982     case FFEINTRIN_impRENAME_subr:
4983     case FFEINTRIN_impSYMLNK_subr:
4984       {
4985         tree arg1_len = integer_zero_node;
4986         tree arg1_tree;
4987         tree arg2_len = integer_zero_node;
4988         tree arg2_tree;
4989         tree arg3_tree;
4990
4991         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
4992         arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
4993         if (arg3 != NULL)
4994           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
4995         else
4996           arg3_tree = NULL_TREE;
4997
4998         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4999         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5000         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5001         arg2_len = build_tree_list (NULL_TREE, arg2_len);
5002         TREE_CHAIN (arg1_tree) = arg2_tree;
5003         TREE_CHAIN (arg2_tree) = arg1_len;
5004         TREE_CHAIN (arg1_len) = arg2_len;
5005         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5006                                   ffecom_gfrt_kindtype (gfrt),
5007                                   FALSE,
5008                                   NULL_TREE,
5009                                   arg1_tree,
5010                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5011                                   ffebld_nonter_hook (expr));
5012         if (arg3_tree != NULL_TREE)
5013           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5014                                      convert (TREE_TYPE (arg3_tree),
5015                                               expr_tree));
5016       }
5017       return expr_tree;
5018
5019     case FFEINTRIN_impLSTAT_subr:
5020     case FFEINTRIN_impSTAT_subr:
5021       {
5022         tree arg1_len = integer_zero_node;
5023         tree arg1_tree;
5024         tree arg2_tree;
5025         tree arg3_tree;
5026
5027         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5028
5029         arg2_tree = ffecom_ptr_to_expr (arg2);
5030
5031         if (arg3 != NULL)
5032           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5033         else
5034           arg3_tree = NULL_TREE;
5035
5036         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5037         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5038         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5039         TREE_CHAIN (arg1_tree) = arg2_tree;
5040         TREE_CHAIN (arg2_tree) = arg1_len;
5041         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5042                                   ffecom_gfrt_kindtype (gfrt),
5043                                   FALSE,
5044                                   NULL_TREE,
5045                                   arg1_tree,
5046                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5047                                   ffebld_nonter_hook (expr));
5048         if (arg3_tree != NULL_TREE)
5049           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5050                                      convert (TREE_TYPE (arg3_tree),
5051                                               expr_tree));
5052       }
5053       return expr_tree;
5054
5055     case FFEINTRIN_impFGETC_subr:
5056     case FFEINTRIN_impFPUTC_subr:
5057       {
5058         tree arg1_tree;
5059         tree arg2_tree;
5060         tree arg2_len = integer_zero_node;
5061         tree arg3_tree;
5062
5063         arg1_tree = convert (ffecom_f2c_integer_type_node,
5064                              ffecom_expr (arg1));
5065         arg1_tree = ffecom_1 (ADDR_EXPR,
5066                               build_pointer_type (TREE_TYPE (arg1_tree)),
5067                               arg1_tree);
5068
5069         arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
5070         if (arg3 != NULL)
5071           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5072         else
5073           arg3_tree = NULL_TREE;
5074
5075         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5076         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5077         arg2_len = build_tree_list (NULL_TREE, arg2_len);
5078         TREE_CHAIN (arg1_tree) = arg2_tree;
5079         TREE_CHAIN (arg2_tree) = arg2_len;
5080
5081         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5082                                   ffecom_gfrt_kindtype (gfrt),
5083                                   FALSE,
5084                                   NULL_TREE,
5085                                   arg1_tree,
5086                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5087                                   ffebld_nonter_hook (expr));
5088         if (arg3_tree != NULL_TREE)
5089           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5090                                      convert (TREE_TYPE (arg3_tree),
5091                                               expr_tree));
5092       }
5093       return expr_tree;
5094
5095     case FFEINTRIN_impFSTAT_subr:
5096       {
5097         tree arg1_tree;
5098         tree arg2_tree;
5099         tree arg3_tree;
5100
5101         arg1_tree = convert (ffecom_f2c_integer_type_node,
5102                              ffecom_expr (arg1));
5103         arg1_tree = ffecom_1 (ADDR_EXPR,
5104                               build_pointer_type (TREE_TYPE (arg1_tree)),
5105                               arg1_tree);
5106
5107         arg2_tree = convert (ffecom_f2c_ptr_to_integer_type_node,
5108                              ffecom_ptr_to_expr (arg2));
5109
5110         if (arg3 == NULL)
5111           arg3_tree = NULL_TREE;
5112         else
5113           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5114
5115         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5116         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5117         TREE_CHAIN (arg1_tree) = arg2_tree;
5118         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5119                                   ffecom_gfrt_kindtype (gfrt),
5120                                   FALSE,
5121                                   NULL_TREE,
5122                                   arg1_tree,
5123                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5124                                   ffebld_nonter_hook (expr));
5125         if (arg3_tree != NULL_TREE) {
5126           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5127                                      convert (TREE_TYPE (arg3_tree),
5128                                               expr_tree));
5129         }
5130       }
5131       return expr_tree;
5132
5133     case FFEINTRIN_impKILL_subr:
5134       {
5135         tree arg1_tree;
5136         tree arg2_tree;
5137         tree arg3_tree;
5138
5139         arg1_tree = convert (ffecom_f2c_integer_type_node,
5140                              ffecom_expr (arg1));
5141         arg1_tree = ffecom_1 (ADDR_EXPR,
5142                               build_pointer_type (TREE_TYPE (arg1_tree)),
5143                               arg1_tree);
5144
5145         arg2_tree = convert (ffecom_f2c_integer_type_node,
5146                              ffecom_expr (arg2));
5147         arg2_tree = ffecom_1 (ADDR_EXPR,
5148                               build_pointer_type (TREE_TYPE (arg2_tree)),
5149                               arg2_tree);
5150
5151         if (arg3 == NULL)
5152           arg3_tree = NULL_TREE;
5153         else
5154           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5155
5156         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5157         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5158         TREE_CHAIN (arg1_tree) = arg2_tree;
5159         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5160                                   ffecom_gfrt_kindtype (gfrt),
5161                                   FALSE,
5162                                   NULL_TREE,
5163                                   arg1_tree,
5164                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5165                                   ffebld_nonter_hook (expr));
5166         if (arg3_tree != NULL_TREE) {
5167           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5168                                      convert (TREE_TYPE (arg3_tree),
5169                                               expr_tree));
5170         }
5171       }
5172       return expr_tree;
5173
5174     case FFEINTRIN_impCTIME_subr:
5175     case FFEINTRIN_impTTYNAM_subr:
5176       {
5177         tree arg1_len = integer_zero_node;
5178         tree arg1_tree;
5179         tree arg2_tree;
5180
5181         arg1_tree = ffecom_arg_ptr_to_expr (arg2, &arg1_len);
5182
5183         arg2_tree = convert (((codegen_imp == FFEINTRIN_impCTIME_subr) ?
5184                               ffecom_f2c_longint_type_node :
5185                               ffecom_f2c_integer_type_node),
5186                              ffecom_expr (arg1));
5187         arg2_tree = ffecom_1 (ADDR_EXPR,
5188                               build_pointer_type (TREE_TYPE (arg2_tree)),
5189                               arg2_tree);
5190
5191         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5192         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5193         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5194         TREE_CHAIN (arg1_len) = arg2_tree;
5195         TREE_CHAIN (arg1_tree) = arg1_len;
5196
5197         expr_tree
5198           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5199                           ffecom_gfrt_kindtype (gfrt),
5200                           FALSE,
5201                           NULL_TREE,
5202                           arg1_tree,
5203                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5204                           ffebld_nonter_hook (expr));
5205         TREE_SIDE_EFFECTS (expr_tree) = 1;
5206       }
5207       return expr_tree;
5208
5209     case FFEINTRIN_impIRAND:
5210     case FFEINTRIN_impRAND:
5211       /* Arg defaults to 0 (normal random case) */
5212       {
5213         tree arg1_tree;
5214
5215         if (arg1 == NULL)
5216           arg1_tree = ffecom_integer_zero_node;
5217         else
5218           arg1_tree = ffecom_expr (arg1);
5219         arg1_tree = convert (ffecom_f2c_integer_type_node,
5220                              arg1_tree);
5221         arg1_tree = ffecom_1 (ADDR_EXPR,
5222                               build_pointer_type (TREE_TYPE (arg1_tree)),
5223                               arg1_tree);
5224         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5225
5226         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5227                                   ffecom_gfrt_kindtype (gfrt),
5228                                   FALSE,
5229                                   ((codegen_imp == FFEINTRIN_impIRAND) ?
5230                                    ffecom_f2c_integer_type_node :
5231                                    ffecom_f2c_real_type_node),
5232                                   arg1_tree,
5233                                   dest_tree, dest, dest_used,
5234                                   NULL_TREE, TRUE,
5235                                   ffebld_nonter_hook (expr));
5236       }
5237       return expr_tree;
5238
5239     case FFEINTRIN_impFTELL_subr:
5240     case FFEINTRIN_impUMASK_subr:
5241       {
5242         tree arg1_tree;
5243         tree arg2_tree;
5244
5245         arg1_tree = convert (ffecom_f2c_integer_type_node,
5246                              ffecom_expr (arg1));
5247         arg1_tree = ffecom_1 (ADDR_EXPR,
5248                               build_pointer_type (TREE_TYPE (arg1_tree)),
5249                               arg1_tree);
5250
5251         if (arg2 == NULL)
5252           arg2_tree = NULL_TREE;
5253         else
5254           arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
5255
5256         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5257                                   ffecom_gfrt_kindtype (gfrt),
5258                                   FALSE,
5259                                   NULL_TREE,
5260                                   build_tree_list (NULL_TREE, arg1_tree),
5261                                   NULL_TREE, NULL, NULL, NULL_TREE,
5262                                   TRUE,
5263                                   ffebld_nonter_hook (expr));
5264         if (arg2_tree != NULL_TREE) {
5265           expr_tree = ffecom_modify (NULL_TREE, arg2_tree,
5266                                      convert (TREE_TYPE (arg2_tree),
5267                                               expr_tree));
5268         }
5269       }
5270       return expr_tree;
5271
5272     case FFEINTRIN_impCPU_TIME:
5273     case FFEINTRIN_impSECOND_subr:
5274       {
5275         tree arg1_tree;
5276
5277         arg1_tree = ffecom_expr_w (NULL_TREE, arg1);
5278
5279         expr_tree
5280           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5281                           ffecom_gfrt_kindtype (gfrt),
5282                           FALSE,
5283                           NULL_TREE,
5284                           NULL_TREE,
5285                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5286                           ffebld_nonter_hook (expr));
5287
5288         expr_tree
5289           = ffecom_modify (NULL_TREE, arg1_tree,
5290                            convert (TREE_TYPE (arg1_tree),
5291                                     expr_tree));
5292       }
5293       return expr_tree;
5294
5295     case FFEINTRIN_impDTIME_subr:
5296     case FFEINTRIN_impETIME_subr:
5297       {
5298         tree arg1_tree;
5299         tree result_tree;
5300
5301         result_tree = ffecom_expr_w (NULL_TREE, arg2);
5302
5303         arg1_tree = ffecom_ptr_to_expr (arg1);
5304
5305         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5306                                   ffecom_gfrt_kindtype (gfrt),
5307                                   FALSE,
5308                                   NULL_TREE,
5309                                   build_tree_list (NULL_TREE, arg1_tree),
5310                                   NULL_TREE, NULL, NULL, NULL_TREE,
5311                                   TRUE,
5312                                   ffebld_nonter_hook (expr));
5313         expr_tree = ffecom_modify (NULL_TREE, result_tree,
5314                                    convert (TREE_TYPE (result_tree),
5315                                             expr_tree));
5316       }
5317       return expr_tree;
5318
5319       /* Straightforward calls of libf2c routines: */
5320     case FFEINTRIN_impABORT:
5321     case FFEINTRIN_impACCESS:
5322     case FFEINTRIN_impBESJ0:
5323     case FFEINTRIN_impBESJ1:
5324     case FFEINTRIN_impBESJN:
5325     case FFEINTRIN_impBESY0:
5326     case FFEINTRIN_impBESY1:
5327     case FFEINTRIN_impBESYN:
5328     case FFEINTRIN_impCHDIR_func:
5329     case FFEINTRIN_impCHMOD_func:
5330     case FFEINTRIN_impDATE:
5331     case FFEINTRIN_impDATE_AND_TIME:
5332     case FFEINTRIN_impDBESJ0:
5333     case FFEINTRIN_impDBESJ1:
5334     case FFEINTRIN_impDBESJN:
5335     case FFEINTRIN_impDBESY0:
5336     case FFEINTRIN_impDBESY1:
5337     case FFEINTRIN_impDBESYN:
5338     case FFEINTRIN_impDTIME_func:
5339     case FFEINTRIN_impETIME_func:
5340     case FFEINTRIN_impFGETC_func:
5341     case FFEINTRIN_impFGET_func:
5342     case FFEINTRIN_impFNUM:
5343     case FFEINTRIN_impFPUTC_func:
5344     case FFEINTRIN_impFPUT_func:
5345     case FFEINTRIN_impFSEEK:
5346     case FFEINTRIN_impFSTAT_func:
5347     case FFEINTRIN_impFTELL_func:
5348     case FFEINTRIN_impGERROR:
5349     case FFEINTRIN_impGETARG:
5350     case FFEINTRIN_impGETCWD_func:
5351     case FFEINTRIN_impGETENV:
5352     case FFEINTRIN_impGETGID:
5353     case FFEINTRIN_impGETLOG:
5354     case FFEINTRIN_impGETPID:
5355     case FFEINTRIN_impGETUID:
5356     case FFEINTRIN_impGMTIME:
5357     case FFEINTRIN_impHOSTNM_func:
5358     case FFEINTRIN_impIDATE_unix:
5359     case FFEINTRIN_impIDATE_vxt:
5360     case FFEINTRIN_impIERRNO:
5361     case FFEINTRIN_impISATTY:
5362     case FFEINTRIN_impITIME:
5363     case FFEINTRIN_impKILL_func:
5364     case FFEINTRIN_impLINK_func:
5365     case FFEINTRIN_impLNBLNK:
5366     case FFEINTRIN_impLSTAT_func:
5367     case FFEINTRIN_impLTIME:
5368     case FFEINTRIN_impMCLOCK8:
5369     case FFEINTRIN_impMCLOCK:
5370     case FFEINTRIN_impPERROR:
5371     case FFEINTRIN_impRENAME_func:
5372     case FFEINTRIN_impSECNDS:
5373     case FFEINTRIN_impSECOND_func:
5374     case FFEINTRIN_impSLEEP:
5375     case FFEINTRIN_impSRAND:
5376     case FFEINTRIN_impSTAT_func:
5377     case FFEINTRIN_impSYMLNK_func:
5378     case FFEINTRIN_impSYSTEM_CLOCK:
5379     case FFEINTRIN_impSYSTEM_func:
5380     case FFEINTRIN_impTIME8:
5381     case FFEINTRIN_impTIME_unix:
5382     case FFEINTRIN_impTIME_vxt:
5383     case FFEINTRIN_impUMASK_func:
5384     case FFEINTRIN_impUNLINK_func:
5385       break;
5386
5387     case FFEINTRIN_impCTIME_func:       /* CHARACTER functions not handled here. */
5388     case FFEINTRIN_impFDATE_func:       /* CHARACTER functions not handled here. */
5389     case FFEINTRIN_impTTYNAM_func:      /* CHARACTER functions not handled here. */
5390     case FFEINTRIN_impNONE:
5391     case FFEINTRIN_imp:         /* Hush up gcc warning. */
5392       fprintf (stderr, "No %s implementation.\n",
5393                ffeintrin_name_implementation (ffebld_symter_implementation (ffebld_left (expr))));
5394       assert ("unimplemented intrinsic" == NULL);
5395       return error_mark_node;
5396     }
5397
5398   assert (gfrt != FFECOM_gfrt); /* Must have an implementation! */
5399
5400   expr_tree = ffecom_arglist_expr_ (ffecom_gfrt_args_ (gfrt),
5401                                     ffebld_right (expr));
5402
5403   return ffecom_call_ (ffecom_gfrt_tree_ (gfrt), ffecom_gfrt_kindtype (gfrt),
5404                        (ffe_is_f2c_library () && ffecom_gfrt_complex_[gfrt]),
5405                        tree_type,
5406                        expr_tree, dest_tree, dest, dest_used,
5407                        NULL_TREE, TRUE,
5408                        ffebld_nonter_hook (expr));
5409
5410   /* See bottom of this file for f2c transforms used to determine
5411      many of the above implementations.  The info seems to confuse
5412      Emacs's C mode indentation, which is why it's been moved to
5413      the bottom of this source file.  */
5414 }
5415
5416 /* For power (exponentiation) where right-hand operand is type INTEGER,
5417    generate in-line code to do it the fast way (which, if the operand
5418    is a constant, might just mean a series of multiplies).  */
5419
5420 static tree
5421 ffecom_expr_power_integer_ (ffebld expr)
5422 {
5423   tree l = ffecom_expr (ffebld_left (expr));
5424   tree r = ffecom_expr (ffebld_right (expr));
5425   tree ltype = TREE_TYPE (l);
5426   tree rtype = TREE_TYPE (r);
5427   tree result = NULL_TREE;
5428
5429   if (l == error_mark_node
5430       || r == error_mark_node)
5431     return error_mark_node;
5432
5433   if (TREE_CODE (r) == INTEGER_CST)
5434     {
5435       int sgn = tree_int_cst_sgn (r);
5436
5437       if (sgn == 0)
5438         return convert (ltype, integer_one_node);
5439
5440       if ((TREE_CODE (ltype) == INTEGER_TYPE)
5441           && (sgn < 0))
5442         {
5443           /* Reciprocal of integer is either 0, -1, or 1, so after
5444              calculating that (which we leave to the back end to do
5445              or not do optimally), don't bother with any multiplying.  */
5446
5447           result = ffecom_tree_divide_ (ltype,
5448                                         convert (ltype, integer_one_node),
5449                                         l,
5450                                         NULL_TREE, NULL, NULL, NULL_TREE);
5451           r = ffecom_1 (NEGATE_EXPR,
5452                         rtype,
5453                         r);
5454           if ((TREE_INT_CST_LOW (r) & 1) == 0)
5455             result = ffecom_1 (ABS_EXPR, rtype,
5456                                result);
5457         }
5458
5459       /* Generate appropriate series of multiplies, preceded
5460          by divide if the exponent is negative.  */
5461
5462       l = save_expr (l);
5463
5464       if (sgn < 0)
5465         {
5466           l = ffecom_tree_divide_ (ltype,
5467                                    convert (ltype, integer_one_node),
5468                                    l,
5469                                    NULL_TREE, NULL, NULL,
5470                                    ffebld_nonter_hook (expr));
5471           r = ffecom_1 (NEGATE_EXPR, rtype, r);
5472           assert (TREE_CODE (r) == INTEGER_CST);
5473
5474           if (tree_int_cst_sgn (r) < 0)
5475             {                   /* The "most negative" number.  */
5476               r = ffecom_1 (NEGATE_EXPR, rtype,
5477                             ffecom_2 (RSHIFT_EXPR, rtype,
5478                                       r,
5479                                       integer_one_node));
5480               l = save_expr (l);
5481               l = ffecom_2 (MULT_EXPR, ltype,
5482                             l,
5483                             l);
5484             }
5485         }
5486
5487       for (;;)
5488         {
5489           if (TREE_INT_CST_LOW (r) & 1)
5490             {
5491               if (result == NULL_TREE)
5492                 result = l;
5493               else
5494                 result = ffecom_2 (MULT_EXPR, ltype,
5495                                    result,
5496                                    l);
5497             }
5498
5499           r = ffecom_2 (RSHIFT_EXPR, rtype,
5500                         r,
5501                         integer_one_node);
5502           if (integer_zerop (r))
5503             break;
5504           assert (TREE_CODE (r) == INTEGER_CST);
5505
5506           l = save_expr (l);
5507           l = ffecom_2 (MULT_EXPR, ltype,
5508                         l,
5509                         l);
5510         }
5511       return result;
5512     }
5513
5514   /* Though rhs isn't a constant, in-line code cannot be expanded
5515      while transforming dummies
5516      because the back end cannot be easily convinced to generate
5517      stores (MODIFY_EXPR), handle temporaries, and so on before
5518      all the appropriate rtx's have been generated for things like
5519      dummy args referenced in rhs -- which doesn't happen until
5520      store_parm_decls() is called (expand_function_start, I believe,
5521      does the actual rtx-stuffing of PARM_DECLs).
5522
5523      So, in this case, let the caller generate the call to the
5524      run-time-library function to evaluate the power for us.  */
5525
5526   if (ffecom_transform_only_dummies_)
5527     return NULL_TREE;
5528
5529   /* Right-hand operand not a constant, expand in-line code to figure
5530      out how to do the multiplies, &c.
5531
5532      The returned expression is expressed this way in GNU C, where l and
5533      r are the "inputs":
5534
5535      ({ typeof (r) rtmp = r;
5536         typeof (l) ltmp = l;
5537         typeof (l) result;
5538
5539         if (rtmp == 0)
5540           result = 1;
5541         else
5542           {
5543             if ((basetypeof (l) == basetypeof (int))
5544                 && (rtmp < 0))
5545               {
5546                 result = ((typeof (l)) 1) / ltmp;
5547                 if ((ltmp < 0) && (((-rtmp) & 1) == 0))
5548                   result = -result;
5549               }
5550             else
5551               {
5552                 result = 1;
5553                 if ((basetypeof (l) != basetypeof (int))
5554                     && (rtmp < 0))
5555                   {
5556                     ltmp = ((typeof (l)) 1) / ltmp;
5557                     rtmp = -rtmp;
5558                     if (rtmp < 0)
5559                       {
5560                         rtmp = -(rtmp >> 1);
5561                         ltmp *= ltmp;
5562                       }
5563                   }
5564                 for (;;)
5565                   {
5566                     if (rtmp & 1)
5567                       result *= ltmp;
5568                     if ((rtmp >>= 1) == 0)
5569                       break;
5570                     ltmp *= ltmp;
5571                   }
5572               }
5573           }
5574         result;
5575      })
5576
5577      Note that some of the above is compile-time collapsable, such as
5578      the first part of the if statements that checks the base type of
5579      l against int.  The if statements are phrased that way to suggest
5580      an easy way to generate the if/else constructs here, knowing that
5581      the back end should (and probably does) eliminate the resulting
5582      dead code (either the int case or the non-int case), something
5583      it couldn't do without the redundant phrasing, requiring explicit
5584      dead-code elimination here, which would be kind of difficult to
5585      read.  */
5586
5587   {
5588     tree rtmp;
5589     tree ltmp;
5590     tree divide;
5591     tree basetypeof_l_is_int;
5592     tree se;
5593     tree t;
5594
5595     basetypeof_l_is_int
5596       = build_int_2 ((TREE_CODE (ltype) == INTEGER_TYPE), 0);
5597
5598     se = expand_start_stmt_expr ();
5599
5600     ffecom_start_compstmt ();
5601
5602 #ifndef HAHA
5603     rtmp = ffecom_make_tempvar ("power_r", rtype,
5604                                 FFETARGET_charactersizeNONE, -1);
5605     ltmp = ffecom_make_tempvar ("power_l", ltype,
5606                                 FFETARGET_charactersizeNONE, -1);
5607     result = ffecom_make_tempvar ("power_res", ltype,
5608                                   FFETARGET_charactersizeNONE, -1);
5609     if (TREE_CODE (ltype) == COMPLEX_TYPE
5610         || TREE_CODE (ltype) == RECORD_TYPE)
5611       divide = ffecom_make_tempvar ("power_div", ltype,
5612                                     FFETARGET_charactersizeNONE, -1);
5613     else
5614       divide = NULL_TREE;
5615 #else  /* HAHA */
5616     {
5617       tree hook;
5618
5619       hook = ffebld_nonter_hook (expr);
5620       assert (hook);
5621       assert (TREE_CODE (hook) == TREE_VEC);
5622       assert (TREE_VEC_LENGTH (hook) == 4);
5623       rtmp = TREE_VEC_ELT (hook, 0);
5624       ltmp = TREE_VEC_ELT (hook, 1);
5625       result = TREE_VEC_ELT (hook, 2);
5626       divide = TREE_VEC_ELT (hook, 3);
5627       if (TREE_CODE (ltype) == COMPLEX_TYPE
5628           || TREE_CODE (ltype) == RECORD_TYPE)
5629         assert (divide);
5630       else
5631         assert (! divide);
5632     }
5633 #endif  /* HAHA */
5634
5635     expand_expr_stmt (ffecom_modify (void_type_node,
5636                                      rtmp,
5637                                      r));
5638     expand_expr_stmt (ffecom_modify (void_type_node,
5639                                      ltmp,
5640                                      l));
5641     expand_start_cond (ffecom_truth_value
5642                        (ffecom_2 (EQ_EXPR, integer_type_node,
5643                                   rtmp,
5644                                   convert (rtype, integer_zero_node))),
5645                        0);
5646     expand_expr_stmt (ffecom_modify (void_type_node,
5647                                      result,
5648                                      convert (ltype, integer_one_node)));
5649     expand_start_else ();
5650     if (! integer_zerop (basetypeof_l_is_int))
5651       {
5652         expand_start_cond (ffecom_2 (LT_EXPR, integer_type_node,
5653                                      rtmp,
5654                                      convert (rtype,
5655                                               integer_zero_node)),
5656                            0);
5657         expand_expr_stmt (ffecom_modify (void_type_node,
5658                                          result,
5659                                          ffecom_tree_divide_
5660                                          (ltype,
5661                                           convert (ltype, integer_one_node),
5662                                           ltmp,
5663                                           NULL_TREE, NULL, NULL,
5664                                           divide)));
5665         expand_start_cond (ffecom_truth_value
5666                            (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5667                                       ffecom_2 (LT_EXPR, integer_type_node,
5668                                                 ltmp,
5669                                                 convert (ltype,
5670                                                          integer_zero_node)),
5671                                       ffecom_2 (EQ_EXPR, integer_type_node,
5672                                                 ffecom_2 (BIT_AND_EXPR,
5673                                                           rtype,
5674                                                           ffecom_1 (NEGATE_EXPR,
5675                                                                     rtype,
5676                                                                     rtmp),
5677                                                           convert (rtype,
5678                                                                    integer_one_node)),
5679                                                 convert (rtype,
5680                                                          integer_zero_node)))),
5681                            0);
5682         expand_expr_stmt (ffecom_modify (void_type_node,
5683                                          result,
5684                                          ffecom_1 (NEGATE_EXPR,
5685                                                    ltype,
5686                                                    result)));
5687         expand_end_cond ();
5688         expand_start_else ();
5689       }
5690     expand_expr_stmt (ffecom_modify (void_type_node,
5691                                      result,
5692                                      convert (ltype, integer_one_node)));
5693     expand_start_cond (ffecom_truth_value
5694                        (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5695                                   ffecom_truth_value_invert
5696                                   (basetypeof_l_is_int),
5697                                   ffecom_2 (LT_EXPR, integer_type_node,
5698                                             rtmp,
5699                                             convert (rtype,
5700                                                      integer_zero_node)))),
5701                        0);
5702     expand_expr_stmt (ffecom_modify (void_type_node,
5703                                      ltmp,
5704                                      ffecom_tree_divide_
5705                                      (ltype,
5706                                       convert (ltype, integer_one_node),
5707                                       ltmp,
5708                                       NULL_TREE, NULL, NULL,
5709                                       divide)));
5710     expand_expr_stmt (ffecom_modify (void_type_node,
5711                                      rtmp,
5712                                      ffecom_1 (NEGATE_EXPR, rtype,
5713                                                rtmp)));
5714     expand_start_cond (ffecom_truth_value
5715                        (ffecom_2 (LT_EXPR, integer_type_node,
5716                                   rtmp,
5717                                   convert (rtype, integer_zero_node))),
5718                        0);
5719     expand_expr_stmt (ffecom_modify (void_type_node,
5720                                      rtmp,
5721                                      ffecom_1 (NEGATE_EXPR, rtype,
5722                                                ffecom_2 (RSHIFT_EXPR,
5723                                                          rtype,
5724                                                          rtmp,
5725                                                          integer_one_node))));
5726     expand_expr_stmt (ffecom_modify (void_type_node,
5727                                      ltmp,
5728                                      ffecom_2 (MULT_EXPR, ltype,
5729                                                ltmp,
5730                                                ltmp)));
5731     expand_end_cond ();
5732     expand_end_cond ();
5733     expand_start_loop (1);
5734     expand_start_cond (ffecom_truth_value
5735                        (ffecom_2 (BIT_AND_EXPR, rtype,
5736                                   rtmp,
5737                                   convert (rtype, integer_one_node))),
5738                        0);
5739     expand_expr_stmt (ffecom_modify (void_type_node,
5740                                      result,
5741                                      ffecom_2 (MULT_EXPR, ltype,
5742                                                result,
5743                                                ltmp)));
5744     expand_end_cond ();
5745     expand_exit_loop_if_false (NULL,
5746                                ffecom_truth_value
5747                                (ffecom_modify (rtype,
5748                                                rtmp,
5749                                                ffecom_2 (RSHIFT_EXPR,
5750                                                          rtype,
5751                                                          rtmp,
5752                                                          integer_one_node))));
5753     expand_expr_stmt (ffecom_modify (void_type_node,
5754                                      ltmp,
5755                                      ffecom_2 (MULT_EXPR, ltype,
5756                                                ltmp,
5757                                                ltmp)));
5758     expand_end_loop ();
5759     expand_end_cond ();
5760     if (!integer_zerop (basetypeof_l_is_int))
5761       expand_end_cond ();
5762     expand_expr_stmt (result);
5763
5764     t = ffecom_end_compstmt ();
5765
5766     result = expand_end_stmt_expr (se);
5767
5768     /* This code comes from c-parse.in, after its expand_end_stmt_expr.  */
5769
5770     if (TREE_CODE (t) == BLOCK)
5771       {
5772         /* Make a BIND_EXPR for the BLOCK already made.  */
5773         result = build (BIND_EXPR, TREE_TYPE (result),
5774                         NULL_TREE, result, t);
5775         /* Remove the block from the tree at this point.
5776            It gets put back at the proper place
5777            when the BIND_EXPR is expanded.  */
5778         delete_block (t);
5779       }
5780     else
5781       result = t;
5782   }
5783
5784   return result;
5785 }
5786
5787 /* ffecom_expr_transform_ -- Transform symbols in expr
5788
5789    ffebld expr;  // FFE expression.
5790    ffecom_expr_transform_ (expr);
5791
5792    Recursive descent on expr while transforming any untransformed SYMTERs.  */
5793
5794 static void
5795 ffecom_expr_transform_ (ffebld expr)
5796 {
5797   tree t;
5798   ffesymbol s;
5799
5800  tail_recurse:
5801
5802   if (expr == NULL)
5803     return;
5804
5805   switch (ffebld_op (expr))
5806     {
5807     case FFEBLD_opSYMTER:
5808       s = ffebld_symter (expr);
5809       t = ffesymbol_hook (s).decl_tree;
5810       if ((t == NULL_TREE)
5811           && ((ffesymbol_kind (s) != FFEINFO_kindNONE)
5812               || ((ffesymbol_where (s) != FFEINFO_whereNONE)
5813                   && (ffesymbol_where (s) != FFEINFO_whereINTRINSIC))))
5814         {
5815           s = ffecom_sym_transform_ (s);
5816           t = ffesymbol_hook (s).decl_tree;     /* Sfunc expr non-dummy,
5817                                                    DIMENSION expr? */
5818         }
5819       break;                    /* Ok if (t == NULL) here. */
5820
5821     case FFEBLD_opITEM:
5822       ffecom_expr_transform_ (ffebld_head (expr));
5823       expr = ffebld_trail (expr);
5824       goto tail_recurse;        /* :::::::::::::::::::: */
5825
5826     default:
5827       break;
5828     }
5829
5830   switch (ffebld_arity (expr))
5831     {
5832     case 2:
5833       ffecom_expr_transform_ (ffebld_left (expr));
5834       expr = ffebld_right (expr);
5835       goto tail_recurse;        /* :::::::::::::::::::: */
5836
5837     case 1:
5838       expr = ffebld_left (expr);
5839       goto tail_recurse;        /* :::::::::::::::::::: */
5840
5841     default:
5842       break;
5843     }
5844
5845   return;
5846 }
5847
5848 /* Make a type based on info in live f2c.h file.  */
5849
5850 static void
5851 ffecom_f2c_make_type_ (tree *type, int tcode, const char *name)
5852 {
5853   switch (tcode)
5854     {
5855     case FFECOM_f2ccodeCHAR:
5856       *type = make_signed_type (CHAR_TYPE_SIZE);
5857       break;
5858
5859     case FFECOM_f2ccodeSHORT:
5860       *type = make_signed_type (SHORT_TYPE_SIZE);
5861       break;
5862
5863     case FFECOM_f2ccodeINT:
5864       *type = make_signed_type (INT_TYPE_SIZE);
5865       break;
5866
5867     case FFECOM_f2ccodeLONG:
5868       *type = make_signed_type (LONG_TYPE_SIZE);
5869       break;
5870
5871     case FFECOM_f2ccodeLONGLONG:
5872       *type = make_signed_type (LONG_LONG_TYPE_SIZE);
5873       break;
5874
5875     case FFECOM_f2ccodeCHARPTR:
5876       *type = build_pointer_type (DEFAULT_SIGNED_CHAR
5877                                   ? signed_char_type_node
5878                                   : unsigned_char_type_node);
5879       break;
5880
5881     case FFECOM_f2ccodeFLOAT:
5882       *type = make_node (REAL_TYPE);
5883       TYPE_PRECISION (*type) = FLOAT_TYPE_SIZE;
5884       layout_type (*type);
5885       break;
5886
5887     case FFECOM_f2ccodeDOUBLE:
5888       *type = make_node (REAL_TYPE);
5889       TYPE_PRECISION (*type) = DOUBLE_TYPE_SIZE;
5890       layout_type (*type);
5891       break;
5892
5893     case FFECOM_f2ccodeLONGDOUBLE:
5894       *type = make_node (REAL_TYPE);
5895       TYPE_PRECISION (*type) = LONG_DOUBLE_TYPE_SIZE;
5896       layout_type (*type);
5897       break;
5898
5899     case FFECOM_f2ccodeTWOREALS:
5900       *type = ffecom_make_complex_type_ (ffecom_f2c_real_type_node);
5901       break;
5902
5903     case FFECOM_f2ccodeTWODOUBLEREALS:
5904       *type = ffecom_make_complex_type_ (ffecom_f2c_doublereal_type_node);
5905       break;
5906
5907     default:
5908       assert ("unexpected FFECOM_f2ccodeXYZZY!" == NULL);
5909       *type = error_mark_node;
5910       return;
5911     }
5912
5913   pushdecl (build_decl (TYPE_DECL,
5914                         ffecom_get_invented_identifier ("__g77_f2c_%s", name),
5915                         *type));
5916 }
5917
5918 /* Set the f2c list-directed-I/O code for whatever (integral) type has the
5919    given size.  */
5920
5921 static void
5922 ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
5923                           int code)
5924 {
5925   int j;
5926   tree t;
5927
5928   for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
5929     if ((t = ffecom_tree_type[bt][j]) != NULL_TREE
5930         && compare_tree_int (TYPE_SIZE (t), size) == 0)
5931       {
5932         assert (code != -1);
5933         ffecom_f2c_typecode_[bt][j] = code;
5934         code = -1;
5935       }
5936 }
5937
5938 /* Finish up globals after doing all program units in file
5939
5940    Need to handle only uninitialized COMMON areas.  */
5941
5942 static ffeglobal
5943 ffecom_finish_global_ (ffeglobal global)
5944 {
5945   tree cbtype;
5946   tree cbt;
5947   tree size;
5948
5949   if (ffeglobal_type (global) != FFEGLOBAL_typeCOMMON)
5950       return global;
5951
5952   if (ffeglobal_common_init (global))
5953       return global;
5954
5955   cbt = ffeglobal_hook (global);
5956   if ((cbt == NULL_TREE)
5957       || !ffeglobal_common_have_size (global))
5958     return global;              /* No need to make common, never ref'd. */
5959
5960   DECL_EXTERNAL (cbt) = 0;
5961
5962   /* Give the array a size now.  */
5963
5964   size = build_int_2 ((ffeglobal_common_size (global)
5965                       + ffeglobal_common_pad (global)) - 1,
5966                       0);
5967
5968   cbtype = TREE_TYPE (cbt);
5969   TYPE_DOMAIN (cbtype) = build_range_type (integer_type_node,
5970                                            integer_zero_node,
5971                                            size);
5972   if (!TREE_TYPE (size))
5973     TREE_TYPE (size) = TYPE_DOMAIN (cbtype);
5974   layout_type (cbtype);
5975
5976   cbt = start_decl (cbt, FALSE);
5977   assert (cbt == ffeglobal_hook (global));
5978
5979   finish_decl (cbt, NULL_TREE, FALSE);
5980
5981   return global;
5982 }
5983
5984 /* Finish up any untransformed symbols.  */
5985
5986 static ffesymbol
5987 ffecom_finish_symbol_transform_ (ffesymbol s)
5988 {
5989   if ((s == NULL) || (TREE_CODE (current_function_decl) == ERROR_MARK))
5990     return s;
5991
5992   /* It's easy to know to transform an untransformed symbol, to make sure
5993      we put out debugging info for it.  But COMMON variables, unlike
5994      EQUIVALENCE ones, aren't given declarations in addition to the
5995      tree expressions that specify offsets, because COMMON variables
5996      can be referenced in the outer scope where only dummy arguments
5997      (PARM_DECLs) should really be seen.  To be safe, just don't do any
5998      VAR_DECLs for COMMON variables when we transform them for real
5999      use, and therefore we do all the VAR_DECL creating here.  */
6000
6001   if (ffesymbol_hook (s).decl_tree == NULL_TREE)
6002     {
6003       if (ffesymbol_kind (s) != FFEINFO_kindNONE
6004           || (ffesymbol_where (s) != FFEINFO_whereNONE
6005               && ffesymbol_where (s) != FFEINFO_whereINTRINSIC
6006               && ffesymbol_where (s) != FFEINFO_whereDUMMY))
6007         /* Not transformed, and not CHARACTER*(*), and not a dummy
6008            argument, which can happen only if the entry point names
6009            it "rides in on" are all invalidated for other reasons.  */
6010         s = ffecom_sym_transform_ (s);
6011     }
6012
6013   if ((ffesymbol_where (s) == FFEINFO_whereCOMMON)
6014       && (ffesymbol_hook (s).decl_tree != error_mark_node))
6015     {
6016       /* This isn't working, at least for dbxout.  The .s file looks
6017          okay to me (burley), but in gdb 4.9 at least, the variables
6018          appear to reside somewhere outside of the common area, so
6019          it doesn't make sense to mislead anyone by generating the info
6020          on those variables until this is fixed.  NOTE: Same problem
6021          with EQUIVALENCE, sadly...see similar #if later.  */
6022       ffecom_member_phase2_ (ffesymbol_storage (ffesymbol_common (s)),
6023                              ffesymbol_storage (s));
6024     }
6025
6026   return s;
6027 }
6028
6029 /* Append underscore(s) to name before calling get_identifier.  "us"
6030    is nonzero if the name already contains an underscore and thus
6031    needs two underscores appended.  */
6032
6033 static tree
6034 ffecom_get_appended_identifier_ (char us, const char *name)
6035 {
6036   int i;
6037   char *newname;
6038   tree id;
6039
6040   newname = xmalloc ((i = strlen (name)) + 1
6041                      + ffe_is_underscoring ()
6042                      + us);
6043   memcpy (newname, name, i);
6044   newname[i] = '_';
6045   newname[i + us] = '_';
6046   newname[i + 1 + us] = '\0';
6047   id = get_identifier (newname);
6048
6049   free (newname);
6050
6051   return id;
6052 }
6053
6054 /* Decide whether to append underscore to name before calling
6055    get_identifier.  */
6056
6057 static tree
6058 ffecom_get_external_identifier_ (ffesymbol s)
6059 {
6060   char us;
6061   const char *name = ffesymbol_text (s);
6062
6063   /* If name is a built-in name, just return it as is.  */
6064
6065   if (!ffe_is_underscoring ()
6066       || (strcmp (name, FFETARGET_nameBLANK_COMMON) == 0)
6067 #if FFETARGET_isENFORCED_MAIN_NAME
6068       || (strcmp (name, FFETARGET_nameENFORCED_NAME) == 0)
6069 #else
6070       || (strcmp (name, FFETARGET_nameUNNAMED_MAIN) == 0)
6071 #endif
6072       || (strcmp (name, FFETARGET_nameUNNAMED_BLOCK_DATA) == 0))
6073     return get_identifier (name);
6074
6075   us = ffe_is_second_underscore ()
6076     ? (strchr (name, '_') != NULL)
6077       : 0;
6078
6079   return ffecom_get_appended_identifier_ (us, name);
6080 }
6081
6082 /* Decide whether to append underscore to internal name before calling
6083    get_identifier.
6084
6085    This is for non-external, top-function-context names only.  Transform
6086    identifier so it doesn't conflict with the transformed result
6087    of using a _different_ external name.  E.g. if "CALL FOO" is
6088    transformed into "FOO_();", then the variable in "FOO_ = 3"
6089    must be transformed into something that does not conflict, since
6090    these two things should be independent.
6091
6092    The transformation is as follows.  If the name does not contain
6093    an underscore, there is no possible conflict, so just return.
6094    If the name does contain an underscore, then transform it just
6095    like we transform an external identifier.  */
6096
6097 static tree
6098 ffecom_get_identifier_ (const char *name)
6099 {
6100   /* If name does not contain an underscore, just return it as is.  */
6101
6102   if (!ffe_is_underscoring ()
6103       || (strchr (name, '_') == NULL))
6104     return get_identifier (name);
6105
6106   return ffecom_get_appended_identifier_ (ffe_is_second_underscore (),
6107                                           name);
6108 }
6109
6110 /* ffecom_gen_sfuncdef_ -- Generate definition of statement function
6111
6112    tree t;
6113    ffesymbol s;  // kindFUNCTION, whereIMMEDIATE.
6114    t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s),
6115          ffesymbol_kindtype(s));
6116
6117    Call after setting up containing function and getting trees for all
6118    other symbols.  */
6119
6120 static tree
6121 ffecom_gen_sfuncdef_ (ffesymbol s, ffeinfoBasictype bt, ffeinfoKindtype kt)
6122 {
6123   ffebld expr = ffesymbol_sfexpr (s);
6124   tree type;
6125   tree func;
6126   tree result;
6127   bool charfunc = (bt == FFEINFO_basictypeCHARACTER);
6128   static bool recurse = FALSE;
6129   int old_lineno = lineno;
6130   const char *old_input_filename = input_filename;
6131
6132   ffecom_nested_entry_ = s;
6133
6134   /* For now, we don't have a handy pointer to where the sfunc is actually
6135      defined, though that should be easy to add to an ffesymbol. (The
6136      token/where info available might well point to the place where the type
6137      of the sfunc is declared, especially if that precedes the place where
6138      the sfunc itself is defined, which is typically the case.)  We should
6139      put out a null pointer rather than point somewhere wrong, but I want to
6140      see how it works at this point.  */
6141
6142   input_filename = ffesymbol_where_filename (s);
6143   lineno = ffesymbol_where_filelinenum (s);
6144
6145   /* Pretransform the expression so any newly discovered things belong to the
6146      outer program unit, not to the statement function. */
6147
6148   ffecom_expr_transform_ (expr);
6149
6150   /* Make sure no recursive invocation of this fn (a specific case of failing
6151      to pretransform an sfunc's expression, i.e. where its expression
6152      references another untransformed sfunc) happens. */
6153
6154   assert (!recurse);
6155   recurse = TRUE;
6156
6157   push_f_function_context ();
6158
6159   if (charfunc)
6160     type = void_type_node;
6161   else
6162     {
6163       type = ffecom_tree_type[bt][kt];
6164       if (type == NULL_TREE)
6165         type = integer_type_node;       /* _sym_exec_transition reports
6166                                            error. */
6167     }
6168
6169   start_function (ffecom_get_identifier_ (ffesymbol_text (s)),
6170                   build_function_type (type, NULL_TREE),
6171                   1,            /* nested/inline */
6172                   0);           /* TREE_PUBLIC */
6173
6174   /* We don't worry about COMPLEX return values here, because this is
6175      entirely internal to our code, and gcc has the ability to return COMPLEX
6176      directly as a value.  */
6177
6178   if (charfunc)
6179     {                           /* Prepend arg for where result goes. */
6180       tree type;
6181
6182       type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
6183
6184       result = ffecom_get_invented_identifier ("__g77_%s", "result");
6185
6186       ffecom_char_enhance_arg_ (&type, s);      /* Ignore returned length. */
6187
6188       type = build_pointer_type (type);
6189       result = build_decl (PARM_DECL, result, type);
6190
6191       push_parm_decl (result);
6192     }
6193   else
6194     result = NULL_TREE;         /* Not ref'd if !charfunc. */
6195
6196   ffecom_push_dummy_decls_ (ffesymbol_dummyargs (s), TRUE);
6197
6198   store_parm_decls (0);
6199
6200   ffecom_start_compstmt ();
6201
6202   if (expr != NULL)
6203     {
6204       if (charfunc)
6205         {
6206           ffetargetCharacterSize sz = ffesymbol_size (s);
6207           tree result_length;
6208
6209           result_length = build_int_2 (sz, 0);
6210           TREE_TYPE (result_length) = ffecom_f2c_ftnlen_type_node;
6211
6212           ffecom_prepare_let_char_ (sz, expr);
6213
6214           ffecom_prepare_end ();
6215
6216           ffecom_let_char_ (result, result_length, sz, expr);
6217           expand_null_return ();
6218         }
6219       else
6220         {
6221           ffecom_prepare_expr (expr);
6222
6223           ffecom_prepare_end ();
6224
6225           expand_return (ffecom_modify (NULL_TREE,
6226                                         DECL_RESULT (current_function_decl),
6227                                         ffecom_expr (expr)));
6228         }
6229     }
6230
6231   ffecom_end_compstmt ();
6232
6233   func = current_function_decl;
6234   finish_function (1);
6235
6236   pop_f_function_context ();
6237
6238   recurse = FALSE;
6239
6240   lineno = old_lineno;
6241   input_filename = old_input_filename;
6242
6243   ffecom_nested_entry_ = NULL;
6244
6245   return func;
6246 }
6247
6248 static const char *
6249 ffecom_gfrt_args_ (ffecomGfrt ix)
6250 {
6251   return ffecom_gfrt_argstring_[ix];
6252 }
6253
6254 static tree
6255 ffecom_gfrt_tree_ (ffecomGfrt ix)
6256 {
6257   if (ffecom_gfrt_[ix] == NULL_TREE)
6258     ffecom_make_gfrt_ (ix);
6259
6260   return ffecom_1 (ADDR_EXPR,
6261                    build_pointer_type (TREE_TYPE (ffecom_gfrt_[ix])),
6262                    ffecom_gfrt_[ix]);
6263 }
6264
6265 /* Return initialize-to-zero expression for this VAR_DECL.  */
6266
6267 /* A somewhat evil way to prevent the garbage collector
6268    from collecting 'tree' structures.  */
6269 #define NUM_TRACKED_CHUNK 63
6270 static struct tree_ggc_tracker
6271 {
6272   struct tree_ggc_tracker *next;
6273   tree trees[NUM_TRACKED_CHUNK];
6274 } *tracker_head = NULL;
6275
6276 static void
6277 mark_tracker_head (void *arg)
6278 {
6279   struct tree_ggc_tracker *head;
6280   int i;
6281
6282   for (head = * (struct tree_ggc_tracker **) arg;
6283        head != NULL;
6284        head = head->next)
6285   {
6286     ggc_mark (head);
6287     for (i = 0; i < NUM_TRACKED_CHUNK; i++)
6288       ggc_mark_tree (head->trees[i]);
6289   }
6290 }
6291
6292 void
6293 ffecom_save_tree_forever (tree t)
6294 {
6295   int i;
6296   if (tracker_head != NULL)
6297     for (i = 0; i < NUM_TRACKED_CHUNK; i++)
6298       if (tracker_head->trees[i] == NULL)
6299         {
6300           tracker_head->trees[i] = t;
6301           return;
6302         }
6303
6304   {
6305     /* Need to allocate a new block.  */
6306     struct tree_ggc_tracker *old_head = tracker_head;
6307
6308     tracker_head = ggc_alloc (sizeof (*tracker_head));
6309     tracker_head->next = old_head;
6310     tracker_head->trees[0] = t;
6311     for (i = 1; i < NUM_TRACKED_CHUNK; i++)
6312       tracker_head->trees[i] = NULL;
6313   }
6314 }
6315
6316 static tree
6317 ffecom_init_zero_ (tree decl)
6318 {
6319   tree init;
6320   int incremental = TREE_STATIC (decl);
6321   tree type = TREE_TYPE (decl);
6322
6323   if (incremental)
6324     {
6325       make_decl_rtl (decl, NULL);
6326       assemble_variable (decl, TREE_PUBLIC (decl) ? 1 : 0, 0, 1);
6327     }
6328
6329   if ((TREE_CODE (type) != ARRAY_TYPE)
6330       && (TREE_CODE (type) != RECORD_TYPE)
6331       && (TREE_CODE (type) != UNION_TYPE)
6332       && !incremental)
6333     init = convert (type, integer_zero_node);
6334   else if (!incremental)
6335     {
6336       init = build (CONSTRUCTOR, type, NULL_TREE, NULL_TREE);
6337       TREE_CONSTANT (init) = 1;
6338       TREE_STATIC (init) = 1;
6339     }
6340   else
6341     {
6342       assemble_zeros (int_size_in_bytes (type));
6343       init = error_mark_node;
6344     }
6345
6346   return init;
6347 }
6348
6349 static tree
6350 ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
6351                          tree *maybe_tree)
6352 {
6353   tree expr_tree;
6354   tree length_tree;
6355
6356   switch (ffebld_op (arg))
6357     {
6358     case FFEBLD_opCONTER:       /* For F90, check 0-length. */
6359       if (ffetarget_length_character1
6360           (ffebld_constant_character1
6361            (ffebld_conter (arg))) == 0)
6362         {
6363           *maybe_tree = integer_zero_node;
6364           return convert (tree_type, integer_zero_node);
6365         }
6366
6367       *maybe_tree = integer_one_node;
6368       expr_tree = build_int_2 (*ffetarget_text_character1
6369                                (ffebld_constant_character1
6370                                 (ffebld_conter (arg))),
6371                                0);
6372       TREE_TYPE (expr_tree) = tree_type;
6373       return expr_tree;
6374
6375     case FFEBLD_opSYMTER:
6376     case FFEBLD_opARRAYREF:
6377     case FFEBLD_opFUNCREF:
6378     case FFEBLD_opSUBSTR:
6379       ffecom_char_args_ (&expr_tree, &length_tree, arg);
6380
6381       if ((expr_tree == error_mark_node)
6382           || (length_tree == error_mark_node))
6383         {
6384           *maybe_tree = error_mark_node;
6385           return error_mark_node;
6386         }
6387
6388       if (integer_zerop (length_tree))
6389         {
6390           *maybe_tree = integer_zero_node;
6391           return convert (tree_type, integer_zero_node);
6392         }
6393
6394       expr_tree
6395         = ffecom_1 (INDIRECT_REF,
6396                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6397                     expr_tree);
6398       expr_tree
6399         = ffecom_2 (ARRAY_REF,
6400                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6401                     expr_tree,
6402                     integer_one_node);
6403       expr_tree = convert (tree_type, expr_tree);
6404
6405       if (TREE_CODE (length_tree) == INTEGER_CST)
6406         *maybe_tree = integer_one_node;
6407       else                      /* Must check length at run time.  */
6408         *maybe_tree
6409           = ffecom_truth_value
6410             (ffecom_2 (GT_EXPR, integer_type_node,
6411                        length_tree,
6412                        ffecom_f2c_ftnlen_zero_node));
6413       return expr_tree;
6414
6415     case FFEBLD_opPAREN:
6416     case FFEBLD_opCONVERT:
6417       if (ffeinfo_size (ffebld_info (arg)) == 0)
6418         {
6419           *maybe_tree = integer_zero_node;
6420           return convert (tree_type, integer_zero_node);
6421         }
6422       return ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6423                                       maybe_tree);
6424
6425     case FFEBLD_opCONCATENATE:
6426       {
6427         tree maybe_left;
6428         tree maybe_right;
6429         tree expr_left;
6430         tree expr_right;
6431
6432         expr_left = ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6433                                              &maybe_left);
6434         expr_right = ffecom_intrinsic_ichar_ (tree_type, ffebld_right (arg),
6435                                               &maybe_right);
6436         *maybe_tree = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
6437                                 maybe_left,
6438                                 maybe_right);
6439         expr_tree = ffecom_3 (COND_EXPR, tree_type,
6440                               maybe_left,
6441                               expr_left,
6442                               expr_right);
6443         return expr_tree;
6444       }
6445
6446     default:
6447       assert ("bad op in ICHAR" == NULL);
6448       return error_mark_node;
6449     }
6450 }
6451
6452 /* ffecom_intrinsic_len_ -- Return length info for char arg (LEN())
6453
6454    tree length_arg;
6455    ffebld expr;
6456    length_arg = ffecom_intrinsic_len_ (expr);
6457
6458    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
6459    subexpressions by constructing the appropriate tree for the
6460    length-of-character-text argument in a calling sequence.  */
6461
6462 static tree
6463 ffecom_intrinsic_len_ (ffebld expr)
6464 {
6465   ffetargetCharacter1 val;
6466   tree length;
6467
6468   switch (ffebld_op (expr))
6469     {
6470     case FFEBLD_opCONTER:
6471       val = ffebld_constant_character1 (ffebld_conter (expr));
6472       length = build_int_2 (ffetarget_length_character1 (val), 0);
6473       TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6474       break;
6475
6476     case FFEBLD_opSYMTER:
6477       {
6478         ffesymbol s = ffebld_symter (expr);
6479         tree item;
6480
6481         item = ffesymbol_hook (s).decl_tree;
6482         if (item == NULL_TREE)
6483           {
6484             s = ffecom_sym_transform_ (s);
6485             item = ffesymbol_hook (s).decl_tree;
6486           }
6487         if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
6488           {
6489             if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
6490               length = ffesymbol_hook (s).length_tree;
6491             else
6492               {
6493                 length = build_int_2 (ffesymbol_size (s), 0);
6494                 TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6495               }
6496           }
6497         else if (item == error_mark_node)
6498           length = error_mark_node;
6499         else                    /* FFEINFO_kindFUNCTION: */
6500           length = NULL_TREE;
6501       }
6502       break;
6503
6504     case FFEBLD_opARRAYREF:
6505       length = ffecom_intrinsic_len_ (ffebld_left (expr));
6506       break;
6507
6508     case FFEBLD_opSUBSTR:
6509       {
6510         ffebld start;
6511         ffebld end;
6512         ffebld thing = ffebld_right (expr);
6513         tree start_tree;
6514         tree end_tree;
6515
6516         assert (ffebld_op (thing) == FFEBLD_opITEM);
6517         start = ffebld_head (thing);
6518         thing = ffebld_trail (thing);
6519         assert (ffebld_trail (thing) == NULL);
6520         end = ffebld_head (thing);
6521
6522         length = ffecom_intrinsic_len_ (ffebld_left (expr));
6523
6524         if (length == error_mark_node)
6525           break;
6526
6527         if (start == NULL)
6528           {
6529             if (end == NULL)
6530               ;
6531             else
6532               {
6533                 length = convert (ffecom_f2c_ftnlen_type_node,
6534                                   ffecom_expr (end));
6535               }
6536           }
6537         else
6538           {
6539             start_tree = convert (ffecom_f2c_ftnlen_type_node,
6540                                   ffecom_expr (start));
6541
6542             if (start_tree == error_mark_node)
6543               {
6544                 length = error_mark_node;
6545                 break;
6546               }
6547
6548             if (end == NULL)
6549               {
6550                 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6551                                    ffecom_f2c_ftnlen_one_node,
6552                                    ffecom_2 (MINUS_EXPR,
6553                                              ffecom_f2c_ftnlen_type_node,
6554                                              length,
6555                                              start_tree));
6556               }
6557             else
6558               {
6559                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
6560                                     ffecom_expr (end));
6561
6562                 if (end_tree == error_mark_node)
6563                   {
6564                     length = error_mark_node;
6565                     break;
6566                   }
6567
6568                 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6569                                    ffecom_f2c_ftnlen_one_node,
6570                                    ffecom_2 (MINUS_EXPR,
6571                                              ffecom_f2c_ftnlen_type_node,
6572                                              end_tree, start_tree));
6573               }
6574           }
6575       }
6576       break;
6577
6578     case FFEBLD_opCONCATENATE:
6579       length
6580         = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6581                     ffecom_intrinsic_len_ (ffebld_left (expr)),
6582                     ffecom_intrinsic_len_ (ffebld_right (expr)));
6583       break;
6584
6585     case FFEBLD_opFUNCREF:
6586     case FFEBLD_opCONVERT:
6587       length = build_int_2 (ffebld_size (expr), 0);
6588       TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6589       break;
6590
6591     default:
6592       assert ("bad op for single char arg expr" == NULL);
6593       length = ffecom_f2c_ftnlen_zero_node;
6594       break;
6595     }
6596
6597   assert (length != NULL_TREE);
6598
6599   return length;
6600 }
6601
6602 /* Handle CHARACTER assignments.
6603
6604    Generates code to do the assignment.  Used by ordinary assignment
6605    statement handler ffecom_let_stmt and by statement-function
6606    handler to generate code for a statement function.  */
6607
6608 static void
6609 ffecom_let_char_ (tree dest_tree, tree dest_length,
6610                   ffetargetCharacterSize dest_size, ffebld source)
6611 {
6612   ffecomConcatList_ catlist;
6613   tree source_length;
6614   tree source_tree;
6615   tree expr_tree;
6616
6617   if ((dest_tree == error_mark_node)
6618       || (dest_length == error_mark_node))
6619     return;
6620
6621   assert (dest_tree != NULL_TREE);
6622   assert (dest_length != NULL_TREE);
6623
6624   /* Source might be an opCONVERT, which just means it is a different size
6625      than the destination.  Since the underlying implementation here handles
6626      that (directly or via the s_copy or s_cat run-time-library functions),
6627      we don't need the "convenience" of an opCONVERT that tells us to
6628      truncate or blank-pad, particularly since the resulting implementation
6629      would probably be slower than otherwise. */
6630
6631   while (ffebld_op (source) == FFEBLD_opCONVERT)
6632     source = ffebld_left (source);
6633
6634   catlist = ffecom_concat_list_new_ (source, dest_size);
6635   switch (ffecom_concat_list_count_ (catlist))
6636     {
6637     case 0:                     /* Shouldn't happen, but in case it does... */
6638       ffecom_concat_list_kill_ (catlist);
6639       source_tree = null_pointer_node;
6640       source_length = ffecom_f2c_ftnlen_zero_node;
6641       expr_tree = build_tree_list (NULL_TREE, dest_tree);
6642       TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6643       TREE_CHAIN (TREE_CHAIN (expr_tree))
6644         = build_tree_list (NULL_TREE, dest_length);
6645       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6646         = build_tree_list (NULL_TREE, source_length);
6647
6648       expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6649       TREE_SIDE_EFFECTS (expr_tree) = 1;
6650
6651       expand_expr_stmt (expr_tree);
6652
6653       return;
6654
6655     case 1:                     /* The (fairly) easy case. */
6656       ffecom_char_args_ (&source_tree, &source_length,
6657                          ffecom_concat_list_expr_ (catlist, 0));
6658       ffecom_concat_list_kill_ (catlist);
6659       assert (source_tree != NULL_TREE);
6660       assert (source_length != NULL_TREE);
6661
6662       if ((source_tree == error_mark_node)
6663           || (source_length == error_mark_node))
6664         return;
6665
6666       if (dest_size == 1)
6667         {
6668           dest_tree
6669             = ffecom_1 (INDIRECT_REF,
6670                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6671                                                       (dest_tree))),
6672                         dest_tree);
6673           dest_tree
6674             = ffecom_2 (ARRAY_REF,
6675                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6676                                                       (dest_tree))),
6677                         dest_tree,
6678                         integer_one_node);
6679           source_tree
6680             = ffecom_1 (INDIRECT_REF,
6681                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6682                                                       (source_tree))),
6683                         source_tree);
6684           source_tree
6685             = ffecom_2 (ARRAY_REF,
6686                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6687                                                       (source_tree))),
6688                         source_tree,
6689                         integer_one_node);
6690
6691           expr_tree = ffecom_modify (void_type_node, dest_tree, source_tree);
6692
6693           expand_expr_stmt (expr_tree);
6694
6695           return;
6696         }
6697
6698       expr_tree = build_tree_list (NULL_TREE, dest_tree);
6699       TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6700       TREE_CHAIN (TREE_CHAIN (expr_tree))
6701         = build_tree_list (NULL_TREE, dest_length);
6702       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6703         = build_tree_list (NULL_TREE, source_length);
6704
6705       expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6706       TREE_SIDE_EFFECTS (expr_tree) = 1;
6707
6708       expand_expr_stmt (expr_tree);
6709
6710       return;
6711
6712     default:                    /* Must actually concatenate things. */
6713       break;
6714     }
6715
6716   /* Heavy-duty concatenation. */
6717
6718   {
6719     int count = ffecom_concat_list_count_ (catlist);
6720     int i;
6721     tree lengths;
6722     tree items;
6723     tree length_array;
6724     tree item_array;
6725     tree citem;
6726     tree clength;
6727
6728 #ifdef HOHO
6729     length_array
6730       = lengths
6731       = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
6732                              FFETARGET_charactersizeNONE, count, TRUE);
6733     item_array = items = ffecom_push_tempvar (ffecom_f2c_address_type_node,
6734                                               FFETARGET_charactersizeNONE,
6735                                               count, TRUE);
6736 #else
6737     {
6738       tree hook;
6739
6740       hook = ffebld_nonter_hook (source);
6741       assert (hook);
6742       assert (TREE_CODE (hook) == TREE_VEC);
6743       assert (TREE_VEC_LENGTH (hook) == 2);
6744       length_array = lengths = TREE_VEC_ELT (hook, 0);
6745       item_array = items = TREE_VEC_ELT (hook, 1);
6746     }
6747 #endif
6748
6749     for (i = 0; i < count; ++i)
6750       {
6751         ffecom_char_args_ (&citem, &clength,
6752                            ffecom_concat_list_expr_ (catlist, i));
6753         if ((citem == error_mark_node)
6754             || (clength == error_mark_node))
6755           {
6756             ffecom_concat_list_kill_ (catlist);
6757             return;
6758           }
6759
6760         items
6761           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
6762                       ffecom_modify (void_type_node,
6763                                      ffecom_2 (ARRAY_REF,
6764                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
6765                                                item_array,
6766                                                build_int_2 (i, 0)),
6767                                      citem),
6768                       items);
6769         lengths
6770           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
6771                       ffecom_modify (void_type_node,
6772                                      ffecom_2 (ARRAY_REF,
6773                    TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
6774                                                length_array,
6775                                                build_int_2 (i, 0)),
6776                                      clength),
6777                       lengths);
6778       }
6779
6780     expr_tree = build_tree_list (NULL_TREE, dest_tree);
6781     TREE_CHAIN (expr_tree)
6782       = build_tree_list (NULL_TREE,
6783                          ffecom_1 (ADDR_EXPR,
6784                                    build_pointer_type (TREE_TYPE (items)),
6785                                    items));
6786     TREE_CHAIN (TREE_CHAIN (expr_tree))
6787       = build_tree_list (NULL_TREE,
6788                          ffecom_1 (ADDR_EXPR,
6789                                    build_pointer_type (TREE_TYPE (lengths)),
6790                                    lengths));
6791     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6792       = build_tree_list
6793         (NULL_TREE,
6794          ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
6795                    convert (ffecom_f2c_ftnlen_type_node,
6796                             build_int_2 (count, 0))));
6797     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree))))
6798       = build_tree_list (NULL_TREE, dest_length);
6799
6800     expr_tree = ffecom_call_gfrt (FFECOM_gfrtCAT, expr_tree, NULL_TREE);
6801     TREE_SIDE_EFFECTS (expr_tree) = 1;
6802
6803     expand_expr_stmt (expr_tree);
6804   }
6805
6806   ffecom_concat_list_kill_ (catlist);
6807 }
6808
6809 /* ffecom_make_gfrt_ -- Make initial info for run-time routine
6810
6811    ffecomGfrt ix;
6812    ffecom_make_gfrt_(ix);
6813
6814    Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL
6815    for the indicated run-time routine (ix).  */
6816
6817 static void
6818 ffecom_make_gfrt_ (ffecomGfrt ix)
6819 {
6820   tree t;
6821   tree ttype;
6822
6823   switch (ffecom_gfrt_type_[ix])
6824     {
6825     case FFECOM_rttypeVOID_:
6826       ttype = void_type_node;
6827       break;
6828
6829     case FFECOM_rttypeVOIDSTAR_:
6830       ttype = TREE_TYPE (null_pointer_node);    /* `void *'. */
6831       break;
6832
6833     case FFECOM_rttypeFTNINT_:
6834       ttype = ffecom_f2c_ftnint_type_node;
6835       break;
6836
6837     case FFECOM_rttypeINTEGER_:
6838       ttype = ffecom_f2c_integer_type_node;
6839       break;
6840
6841     case FFECOM_rttypeLONGINT_:
6842       ttype = ffecom_f2c_longint_type_node;
6843       break;
6844
6845     case FFECOM_rttypeLOGICAL_:
6846       ttype = ffecom_f2c_logical_type_node;
6847       break;
6848
6849     case FFECOM_rttypeREAL_F2C_:
6850       ttype = double_type_node;
6851       break;
6852
6853     case FFECOM_rttypeREAL_GNU_:
6854       ttype = float_type_node;
6855       break;
6856
6857     case FFECOM_rttypeCOMPLEX_F2C_:
6858       ttype = void_type_node;
6859       break;
6860
6861     case FFECOM_rttypeCOMPLEX_GNU_:
6862       ttype = ffecom_f2c_complex_type_node;
6863       break;
6864
6865     case FFECOM_rttypeDOUBLE_:
6866       ttype = double_type_node;
6867       break;
6868
6869     case FFECOM_rttypeDOUBLEREAL_:
6870       ttype = ffecom_f2c_doublereal_type_node;
6871       break;
6872
6873     case FFECOM_rttypeDBLCMPLX_F2C_:
6874       ttype = void_type_node;
6875       break;
6876
6877     case FFECOM_rttypeDBLCMPLX_GNU_:
6878       ttype = ffecom_f2c_doublecomplex_type_node;
6879       break;
6880
6881     case FFECOM_rttypeCHARACTER_:
6882       ttype = void_type_node;
6883       break;
6884
6885     default:
6886       ttype = NULL;
6887       assert ("bad rttype" == NULL);
6888       break;
6889     }
6890
6891   ttype = build_function_type (ttype, NULL_TREE);
6892   t = build_decl (FUNCTION_DECL,
6893                   get_identifier (ffecom_gfrt_name_[ix]),
6894                   ttype);
6895   DECL_EXTERNAL (t) = 1;
6896   TREE_READONLY (t) = ffecom_gfrt_const_[ix] ? 1 : 0;
6897   TREE_PUBLIC (t) = 1;
6898   TREE_THIS_VOLATILE (t) = ffecom_gfrt_volatile_[ix] ? 1 : 0;
6899
6900   /* Sanity check:  A function that's const cannot be volatile.  */
6901
6902   assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_volatile_[ix] : 1);
6903
6904   /* Sanity check: A function that's const cannot return complex.  */
6905
6906   assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_complex_[ix] : 1);
6907
6908   t = start_decl (t, TRUE);
6909
6910   finish_decl (t, NULL_TREE, TRUE);
6911
6912   ffecom_gfrt_[ix] = t;
6913 }
6914
6915 /* Phase 1 pass over each member of a COMMON/EQUIVALENCE group.  */
6916
6917 static void
6918 ffecom_member_phase1_ (ffestorag mst UNUSED, ffestorag st)
6919 {
6920   ffesymbol s = ffestorag_symbol (st);
6921
6922   if (ffesymbol_namelisted (s))
6923     ffecom_member_namelisted_ = TRUE;
6924 }
6925
6926 /* Phase 2 pass over each member of a COMMON/EQUIVALENCE group.  Declare
6927    the member so debugger will see it.  Otherwise nobody should be
6928    referencing the member.  */
6929
6930 static void
6931 ffecom_member_phase2_ (ffestorag mst, ffestorag st)
6932 {
6933   ffesymbol s;
6934   tree t;
6935   tree mt;
6936   tree type;
6937
6938   if ((mst == NULL)
6939       || ((mt = ffestorag_hook (mst)) == NULL)
6940       || (mt == error_mark_node))
6941     return;
6942
6943   if ((st == NULL)
6944       || ((s = ffestorag_symbol (st)) == NULL))
6945     return;
6946
6947   type = ffecom_type_localvar_ (s,
6948                                 ffesymbol_basictype (s),
6949                                 ffesymbol_kindtype (s));
6950   if (type == error_mark_node)
6951     return;
6952
6953   t = build_decl (VAR_DECL,
6954                   ffecom_get_identifier_ (ffesymbol_text (s)),
6955                   type);
6956
6957   TREE_STATIC (t) = TREE_STATIC (mt);
6958   DECL_INITIAL (t) = NULL_TREE;
6959   TREE_ASM_WRITTEN (t) = 1;
6960   TREE_USED (t) = 1;
6961
6962   SET_DECL_RTL (t,
6963                 gen_rtx (MEM, TYPE_MODE (type),
6964                          plus_constant (XEXP (DECL_RTL (mt), 0),
6965                                         ffestorag_modulo (mst)
6966                                         + ffestorag_offset (st)
6967                                         - ffestorag_offset (mst))));
6968
6969   t = start_decl (t, FALSE);
6970
6971   finish_decl (t, NULL_TREE, FALSE);
6972 }
6973
6974 /* Prepare source expression for assignment into a destination perhaps known
6975    to be of a specific size.  */
6976
6977 static void
6978 ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size, ffebld source)
6979 {
6980   ffecomConcatList_ catlist;
6981   int count;
6982   int i;
6983   tree ltmp;
6984   tree itmp;
6985   tree tempvar = NULL_TREE;
6986
6987   while (ffebld_op (source) == FFEBLD_opCONVERT)
6988     source = ffebld_left (source);
6989
6990   catlist = ffecom_concat_list_new_ (source, dest_size);
6991   count = ffecom_concat_list_count_ (catlist);
6992
6993   if (count >= 2)
6994     {
6995       ltmp
6996         = ffecom_make_tempvar ("let_char_len", ffecom_f2c_ftnlen_type_node,
6997                                FFETARGET_charactersizeNONE, count);
6998       itmp
6999         = ffecom_make_tempvar ("let_char_item", ffecom_f2c_address_type_node,
7000                                FFETARGET_charactersizeNONE, count);
7001
7002       tempvar = make_tree_vec (2);
7003       TREE_VEC_ELT (tempvar, 0) = ltmp;
7004       TREE_VEC_ELT (tempvar, 1) = itmp;
7005     }
7006
7007   for (i = 0; i < count; ++i)
7008     ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist, i));
7009
7010   ffecom_concat_list_kill_ (catlist);
7011
7012   if (tempvar)
7013     {
7014       ffebld_nonter_set_hook (source, tempvar);
7015       current_binding_level->prep_state = 1;
7016     }
7017 }
7018
7019 /* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order
7020
7021    Ignores STAR (alternate-return) dummies.  All other get exec-transitioned
7022    (which generates their trees) and then their trees get push_parm_decl'd.
7023
7024    The second arg is TRUE if the dummies are for a statement function, in
7025    which case lengths are not pushed for character arguments (since they are
7026    always known by both the caller and the callee, though the code allows
7027    for someday permitting CHAR*(*) stmtfunc dummies).  */
7028
7029 static void
7030 ffecom_push_dummy_decls_ (ffebld dummy_list, bool stmtfunc)
7031 {
7032   ffebld dummy;
7033   ffebld dumlist;
7034   ffesymbol s;
7035   tree parm;
7036
7037   ffecom_transform_only_dummies_ = TRUE;
7038
7039   /* First push the parms corresponding to actual dummy "contents".  */
7040
7041   for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7042     {
7043       dummy = ffebld_head (dumlist);
7044       switch (ffebld_op (dummy))
7045         {
7046         case FFEBLD_opSTAR:
7047         case FFEBLD_opANY:
7048           continue;             /* Forget alternate returns. */
7049
7050         default:
7051           break;
7052         }
7053       assert (ffebld_op (dummy) == FFEBLD_opSYMTER);
7054       s = ffebld_symter (dummy);
7055       parm = ffesymbol_hook (s).decl_tree;
7056       if (parm == NULL_TREE)
7057         {
7058           s = ffecom_sym_transform_ (s);
7059           parm = ffesymbol_hook (s).decl_tree;
7060           assert (parm != NULL_TREE);
7061         }
7062       if (parm != error_mark_node)
7063         push_parm_decl (parm);
7064     }
7065
7066   /* Then, for CHARACTER dummies, push the parms giving their lengths.  */
7067
7068   for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7069     {
7070       dummy = ffebld_head (dumlist);
7071       switch (ffebld_op (dummy))
7072         {
7073         case FFEBLD_opSTAR:
7074         case FFEBLD_opANY:
7075           continue;             /* Forget alternate returns, they mean
7076                                    NOTHING! */
7077
7078         default:
7079           break;
7080         }
7081       s = ffebld_symter (dummy);
7082       if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
7083         continue;               /* Only looking for CHARACTER arguments. */
7084       if (stmtfunc && (ffesymbol_size (s) != FFETARGET_charactersizeNONE))
7085         continue;               /* Stmtfunc arg with known size needs no
7086                                    length param. */
7087       if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
7088         continue;               /* Only looking for variables and arrays. */
7089       parm = ffesymbol_hook (s).length_tree;
7090       assert (parm != NULL_TREE);
7091       if (parm != error_mark_node)
7092         push_parm_decl (parm);
7093     }
7094
7095   ffecom_transform_only_dummies_ = FALSE;
7096 }
7097
7098 /* ffecom_start_progunit_ -- Beginning of program unit
7099
7100    Does GNU back end stuff necessary to teach it about the start of its
7101    equivalent of a Fortran program unit.  */
7102
7103 static void
7104 ffecom_start_progunit_ ()
7105 {
7106   ffesymbol fn = ffecom_primary_entry_;
7107   ffebld arglist;
7108   tree id;                      /* Identifier (name) of function. */
7109   tree type;                    /* Type of function. */
7110   tree result;                  /* Result of function. */
7111   ffeinfoBasictype bt;
7112   ffeinfoKindtype kt;
7113   ffeglobal g;
7114   ffeglobalType gt;
7115   ffeglobalType egt = FFEGLOBAL_type;
7116   bool charfunc;
7117   bool cmplxfunc;
7118   bool altentries = (ffecom_num_entrypoints_ != 0);
7119   bool multi
7120   = altentries
7121   && (ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
7122   && (ffecom_master_bt_ == FFEINFO_basictypeNONE);
7123   bool main_program = FALSE;
7124   int old_lineno = lineno;
7125   const char *old_input_filename = input_filename;
7126
7127   assert (fn != NULL);
7128   assert (ffesymbol_hook (fn).decl_tree == NULL_TREE);
7129
7130   input_filename = ffesymbol_where_filename (fn);
7131   lineno = ffesymbol_where_filelinenum (fn);
7132
7133   switch (ffecom_primary_entry_kind_)
7134     {
7135     case FFEINFO_kindPROGRAM:
7136       main_program = TRUE;
7137       gt = FFEGLOBAL_typeMAIN;
7138       bt = FFEINFO_basictypeNONE;
7139       kt = FFEINFO_kindtypeNONE;
7140       type = ffecom_tree_fun_type_void;
7141       charfunc = FALSE;
7142       cmplxfunc = FALSE;
7143       break;
7144
7145     case FFEINFO_kindBLOCKDATA:
7146       gt = FFEGLOBAL_typeBDATA;
7147       bt = FFEINFO_basictypeNONE;
7148       kt = FFEINFO_kindtypeNONE;
7149       type = ffecom_tree_fun_type_void;
7150       charfunc = FALSE;
7151       cmplxfunc = FALSE;
7152       break;
7153
7154     case FFEINFO_kindFUNCTION:
7155       gt = FFEGLOBAL_typeFUNC;
7156       egt = FFEGLOBAL_typeEXT;
7157       bt = ffesymbol_basictype (fn);
7158       kt = ffesymbol_kindtype (fn);
7159       if (bt == FFEINFO_basictypeNONE)
7160         {
7161           ffeimplic_establish_symbol (fn);
7162           if (ffesymbol_funcresult (fn) != NULL)
7163             ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
7164           bt = ffesymbol_basictype (fn);
7165           kt = ffesymbol_kindtype (fn);
7166         }
7167
7168       if (multi)
7169         charfunc = cmplxfunc = FALSE;
7170       else if (bt == FFEINFO_basictypeCHARACTER)
7171         charfunc = TRUE, cmplxfunc = FALSE;
7172       else if ((bt == FFEINFO_basictypeCOMPLEX)
7173                && ffesymbol_is_f2c (fn)
7174                && !altentries)
7175         charfunc = FALSE, cmplxfunc = TRUE;
7176       else
7177         charfunc = cmplxfunc = FALSE;
7178
7179       if (multi || charfunc)
7180         type = ffecom_tree_fun_type_void;
7181       else if (ffesymbol_is_f2c (fn) && !altentries)
7182         type = ffecom_tree_fun_type[bt][kt];
7183       else
7184         type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
7185
7186       if ((type == NULL_TREE)
7187           || (TREE_TYPE (type) == NULL_TREE))
7188         type = ffecom_tree_fun_type_void;       /* _sym_exec_transition. */
7189       break;
7190
7191     case FFEINFO_kindSUBROUTINE:
7192       gt = FFEGLOBAL_typeSUBR;
7193       egt = FFEGLOBAL_typeEXT;
7194       bt = FFEINFO_basictypeNONE;
7195       kt = FFEINFO_kindtypeNONE;
7196       if (ffecom_is_altreturning_)
7197         type = ffecom_tree_subr_type;
7198       else
7199         type = ffecom_tree_fun_type_void;
7200       charfunc = FALSE;
7201       cmplxfunc = FALSE;
7202       break;
7203
7204     default:
7205       assert ("say what??" == NULL);
7206       /* Fall through. */
7207     case FFEINFO_kindANY:
7208       gt = FFEGLOBAL_typeANY;
7209       bt = FFEINFO_basictypeNONE;
7210       kt = FFEINFO_kindtypeNONE;
7211       type = error_mark_node;
7212       charfunc = FALSE;
7213       cmplxfunc = FALSE;
7214       break;
7215     }
7216
7217   if (altentries)
7218     {
7219       id = ffecom_get_invented_identifier ("__g77_masterfun_%s",
7220                                            ffesymbol_text (fn));
7221     }
7222 #if FFETARGET_isENFORCED_MAIN
7223   else if (main_program)
7224     id = get_identifier (FFETARGET_nameENFORCED_MAIN_NAME);
7225 #endif
7226   else
7227     id = ffecom_get_external_identifier_ (fn);
7228
7229   start_function (id,
7230                   type,
7231                   0,            /* nested/inline */
7232                   !altentries); /* TREE_PUBLIC */
7233
7234   TREE_USED (current_function_decl) = 1;        /* Avoid spurious warning if altentries. */
7235
7236   if (!altentries
7237       && ((g = ffesymbol_global (fn)) != NULL)
7238       && ((ffeglobal_type (g) == gt)
7239           || (ffeglobal_type (g) == egt)))
7240     {
7241       ffeglobal_set_hook (g, current_function_decl);
7242     }
7243
7244   /* Arg handling needs exec-transitioned ffesymbols to work with.  But
7245      exec-transitioning needs current_function_decl to be filled in.  So we
7246      do these things in two phases. */
7247
7248   if (altentries)
7249     {                           /* 1st arg identifies which entrypoint. */
7250       ffecom_which_entrypoint_decl_
7251         = build_decl (PARM_DECL,
7252                       ffecom_get_invented_identifier ("__g77_%s",
7253                                                       "which_entrypoint"),
7254                       integer_type_node);
7255       push_parm_decl (ffecom_which_entrypoint_decl_);
7256     }
7257
7258   if (charfunc
7259       || cmplxfunc
7260       || multi)
7261     {                           /* Arg for result (return value). */
7262       tree type;
7263       tree length;
7264
7265       if (charfunc)
7266         type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
7267       else if (cmplxfunc)
7268         type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
7269       else
7270         type = ffecom_multi_type_node_;
7271
7272       result = ffecom_get_invented_identifier ("__g77_%s", "result");
7273
7274       /* Make length arg _and_ enhance type info for CHAR arg itself.  */
7275
7276       if (charfunc)
7277         length = ffecom_char_enhance_arg_ (&type, fn);
7278       else
7279         length = NULL_TREE;     /* Not ref'd if !charfunc. */
7280
7281       type = build_pointer_type (type);
7282       result = build_decl (PARM_DECL, result, type);
7283
7284       push_parm_decl (result);
7285       if (multi)
7286         ffecom_multi_retval_ = result;
7287       else
7288         ffecom_func_result_ = result;
7289
7290       if (charfunc)
7291         {
7292           push_parm_decl (length);
7293           ffecom_func_length_ = length;
7294         }
7295     }
7296
7297   if (ffecom_primary_entry_is_proc_)
7298     {
7299       if (altentries)
7300         arglist = ffecom_master_arglist_;
7301       else
7302         arglist = ffesymbol_dummyargs (fn);
7303       ffecom_push_dummy_decls_ (arglist, FALSE);
7304     }
7305
7306   if (TREE_CODE (current_function_decl) != ERROR_MARK)
7307     store_parm_decls (main_program ? 1 : 0);
7308
7309   ffecom_start_compstmt ();
7310   /* Disallow temp vars at this level.  */
7311   current_binding_level->prep_state = 2;
7312
7313   lineno = old_lineno;
7314   input_filename = old_input_filename;
7315
7316   /* This handles any symbols still untransformed, in case -g specified.
7317      This used to be done in ffecom_finish_progunit, but it turns out to
7318      be necessary to do it here so that statement functions are
7319      expanded before code.  But don't bother for BLOCK DATA.  */
7320
7321   if (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
7322     ffesymbol_drive (ffecom_finish_symbol_transform_);
7323 }
7324
7325 /* ffecom_sym_transform_ -- Transform FFE sym into backend sym
7326
7327    ffesymbol s;
7328    ffecom_sym_transform_(s);
7329
7330    The ffesymbol_hook info for s is updated with appropriate backend info
7331    on the symbol.  */
7332
7333 static ffesymbol
7334 ffecom_sym_transform_ (ffesymbol s)
7335 {
7336   tree t;                       /* Transformed thingy. */
7337   tree tlen;                    /* Length if CHAR*(*). */
7338   bool addr;                    /* Is t the address of the thingy? */
7339   ffeinfoBasictype bt;
7340   ffeinfoKindtype kt;
7341   ffeglobal g;
7342   int old_lineno = lineno;
7343   const char *old_input_filename = input_filename;
7344
7345   /* Must ensure special ASSIGN variables are declared at top of outermost
7346      block, else they'll end up in the innermost block when their first
7347      ASSIGN is seen, which leaves them out of scope when they're the
7348      subject of a GOTO or I/O statement.
7349
7350      We make this variable even if -fugly-assign.  Just let it go unused,
7351      in case it turns out there are cases where we really want to use this
7352      variable anyway (e.g. ASSIGN to INTEGER*2 variable).  */
7353
7354   if (! ffecom_transform_only_dummies_
7355       && ffesymbol_assigned (s)
7356       && ! ffesymbol_hook (s).assign_tree)
7357     s = ffecom_sym_transform_assign_ (s);
7358
7359   if (ffesymbol_sfdummyparent (s) == NULL)
7360     {
7361       input_filename = ffesymbol_where_filename (s);
7362       lineno = ffesymbol_where_filelinenum (s);
7363     }
7364   else
7365     {
7366       ffesymbol sf = ffesymbol_sfdummyparent (s);
7367
7368       input_filename = ffesymbol_where_filename (sf);
7369       lineno = ffesymbol_where_filelinenum (sf);
7370     }
7371
7372   bt = ffeinfo_basictype (ffebld_info (s));
7373   kt = ffeinfo_kindtype (ffebld_info (s));
7374
7375   t = NULL_TREE;
7376   tlen = NULL_TREE;
7377   addr = FALSE;
7378
7379   switch (ffesymbol_kind (s))
7380     {
7381     case FFEINFO_kindNONE:
7382       switch (ffesymbol_where (s))
7383         {
7384         case FFEINFO_whereDUMMY:        /* Subroutine or function. */
7385           assert (ffecom_transform_only_dummies_);
7386
7387           /* Before 0.4, this could be ENTITY/DUMMY, but see
7388              ffestu_sym_end_transition -- no longer true (in particular, if
7389              it could be an ENTITY, it _will_ be made one, so that
7390              possibility won't come through here).  So we never make length
7391              arg for CHARACTER type.  */
7392
7393           t = build_decl (PARM_DECL,
7394                           ffecom_get_identifier_ (ffesymbol_text (s)),
7395                           ffecom_tree_ptr_to_subr_type);
7396           DECL_ARTIFICIAL (t) = 1;
7397           addr = TRUE;
7398           break;
7399
7400         case FFEINFO_whereGLOBAL:       /* Subroutine or function. */
7401           assert (!ffecom_transform_only_dummies_);
7402
7403           if (((g = ffesymbol_global (s)) != NULL)
7404               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7405                   || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7406                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
7407               && (ffeglobal_hook (g) != NULL_TREE)
7408               && ffe_is_globals ())
7409             {
7410               t = ffeglobal_hook (g);
7411               break;
7412             }
7413
7414           t = build_decl (FUNCTION_DECL,
7415                           ffecom_get_external_identifier_ (s),
7416                           ffecom_tree_subr_type);       /* Assume subr. */
7417           DECL_EXTERNAL (t) = 1;
7418           TREE_PUBLIC (t) = 1;
7419
7420           t = start_decl (t, FALSE);
7421           finish_decl (t, NULL_TREE, FALSE);
7422
7423           if ((g != NULL)
7424               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7425                   || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7426                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
7427             ffeglobal_set_hook (g, t);
7428
7429           ffecom_save_tree_forever (t);
7430
7431           break;
7432
7433         default:
7434           assert ("NONE where unexpected" == NULL);
7435           /* Fall through. */
7436         case FFEINFO_whereANY:
7437           break;
7438         }
7439       break;
7440
7441     case FFEINFO_kindENTITY:
7442       switch (ffeinfo_where (ffesymbol_info (s)))
7443         {
7444
7445         case FFEINFO_whereCONSTANT:
7446           /* ~~Debugging info needed? */
7447           assert (!ffecom_transform_only_dummies_);
7448           t = error_mark_node;  /* Shouldn't ever see this in expr. */
7449           break;
7450
7451         case FFEINFO_whereLOCAL:
7452           assert (!ffecom_transform_only_dummies_);
7453
7454           {
7455             ffestorag st = ffesymbol_storage (s);
7456             tree type;
7457
7458             if ((st != NULL)
7459                 && (ffestorag_size (st) == 0))
7460               {
7461                 t = error_mark_node;
7462                 break;
7463               }
7464
7465             type = ffecom_type_localvar_ (s, bt, kt);
7466
7467             if (type == error_mark_node)
7468               {
7469                 t = error_mark_node;
7470                 break;
7471               }
7472
7473             if ((st != NULL)
7474                 && (ffestorag_parent (st) != NULL))
7475               {                 /* Child of EQUIVALENCE parent. */
7476                 ffestorag est;
7477                 tree et;
7478                 ffetargetOffset offset;
7479
7480                 est = ffestorag_parent (st);
7481                 ffecom_transform_equiv_ (est);
7482
7483                 et = ffestorag_hook (est);
7484                 assert (et != NULL_TREE);
7485
7486                 if (! TREE_STATIC (et))
7487                   put_var_into_stack (et);
7488
7489                 offset = ffestorag_modulo (est)
7490                   + ffestorag_offset (ffesymbol_storage (s))
7491                   - ffestorag_offset (est);
7492
7493                 ffecom_debug_kludge_ (et, "EQUIVALENCE", s, type, offset);
7494
7495                 /* (t_type *) (((char *) &et) + offset) */
7496
7497                 t = convert (string_type_node,  /* (char *) */
7498                              ffecom_1 (ADDR_EXPR,
7499                                        build_pointer_type (TREE_TYPE (et)),
7500                                        et));
7501                 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
7502                               t,
7503                               build_int_2 (offset, 0));
7504                 t = convert (build_pointer_type (type),
7505                              t);
7506                 TREE_CONSTANT (t) = staticp (et);
7507
7508                 addr = TRUE;
7509               }
7510             else
7511               {
7512                 tree initexpr;
7513                 bool init = ffesymbol_is_init (s);
7514
7515                 t = build_decl (VAR_DECL,
7516                                 ffecom_get_identifier_ (ffesymbol_text (s)),
7517                                 type);
7518
7519                 if (init
7520                     || ffesymbol_namelisted (s)
7521 #ifdef FFECOM_sizeMAXSTACKITEM
7522                     || ((st != NULL)
7523                         && (ffestorag_size (st) > FFECOM_sizeMAXSTACKITEM))
7524 #endif
7525                     || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
7526                         && (ffecom_primary_entry_kind_
7527                             != FFEINFO_kindBLOCKDATA)
7528                         && (ffesymbol_is_save (s) || ffe_is_saveall ())))
7529                   TREE_STATIC (t) = !ffesymbol_attr (s, FFESYMBOL_attrADJUSTABLE);
7530                 else
7531                   TREE_STATIC (t) = 0;  /* No need to make static. */
7532
7533                 if (init || ffe_is_init_local_zero ())
7534                   DECL_INITIAL (t) = error_mark_node;
7535
7536                 /* Keep -Wunused from complaining about var if it
7537                    is used as sfunc arg or DATA implied-DO.  */
7538                 if (ffesymbol_attrs (s) & FFESYMBOL_attrsSFARG)
7539                   DECL_IN_SYSTEM_HEADER (t) = 1;
7540
7541                 t = start_decl (t, FALSE);
7542
7543                 if (init)
7544                   {
7545                     if (ffesymbol_init (s) != NULL)
7546                       initexpr = ffecom_expr (ffesymbol_init (s));
7547                     else
7548                       initexpr = ffecom_init_zero_ (t);
7549                   }
7550                 else if (ffe_is_init_local_zero ())
7551                   initexpr = ffecom_init_zero_ (t);
7552                 else
7553                   initexpr = NULL_TREE; /* Not ref'd if !init. */
7554
7555                 finish_decl (t, initexpr, FALSE);
7556
7557                 if (st != NULL && DECL_SIZE (t) != error_mark_node)
7558                   {
7559                     assert (TREE_CODE (DECL_SIZE_UNIT (t)) == INTEGER_CST);
7560                     assert (0 == compare_tree_int (DECL_SIZE_UNIT (t),
7561                                                    ffestorag_size (st)));
7562                   }
7563               }
7564           }
7565           break;
7566
7567         case FFEINFO_whereRESULT:
7568           assert (!ffecom_transform_only_dummies_);
7569
7570           if (bt == FFEINFO_basictypeCHARACTER)
7571             {                   /* Result is already in list of dummies, use
7572                                    it (& length). */
7573               t = ffecom_func_result_;
7574               tlen = ffecom_func_length_;
7575               addr = TRUE;
7576               break;
7577             }
7578           if ((ffecom_num_entrypoints_ == 0)
7579               && (bt == FFEINFO_basictypeCOMPLEX)
7580               && (ffesymbol_is_f2c (ffecom_primary_entry_)))
7581             {                   /* Result is already in list of dummies, use
7582                                    it. */
7583               t = ffecom_func_result_;
7584               addr = TRUE;
7585               break;
7586             }
7587           if (ffecom_func_result_ != NULL_TREE)
7588             {
7589               t = ffecom_func_result_;
7590               break;
7591             }
7592           if ((ffecom_num_entrypoints_ != 0)
7593               && (ffecom_master_bt_ == FFEINFO_basictypeNONE))
7594             {
7595               assert (ffecom_multi_retval_ != NULL_TREE);
7596               t = ffecom_1 (INDIRECT_REF, ffecom_multi_type_node_,
7597                             ffecom_multi_retval_);
7598               t = ffecom_2 (COMPONENT_REF, ffecom_tree_type[bt][kt],
7599                             t, ffecom_multi_fields_[bt][kt]);
7600
7601               break;
7602             }
7603
7604           t = build_decl (VAR_DECL,
7605                           ffecom_get_identifier_ (ffesymbol_text (s)),
7606                           ffecom_tree_type[bt][kt]);
7607           TREE_STATIC (t) = 0;  /* Put result on stack. */
7608           t = start_decl (t, FALSE);
7609           finish_decl (t, NULL_TREE, FALSE);
7610
7611           ffecom_func_result_ = t;
7612
7613           break;
7614
7615         case FFEINFO_whereDUMMY:
7616           {
7617             tree type;
7618             ffebld dl;
7619             ffebld dim;
7620             tree low;
7621             tree high;
7622             tree old_sizes;
7623             bool adjustable = FALSE;    /* Conditionally adjustable? */
7624
7625             type = ffecom_tree_type[bt][kt];
7626             if (ffesymbol_sfdummyparent (s) != NULL)
7627               {
7628                 if (current_function_decl == ffecom_outer_function_decl_)
7629                   {                     /* Exec transition before sfunc
7630                                            context; get it later. */
7631                     break;
7632                   }
7633                 t = ffecom_get_identifier_ (ffesymbol_text
7634                                             (ffesymbol_sfdummyparent (s)));
7635               }
7636             else
7637               t = ffecom_get_identifier_ (ffesymbol_text (s));
7638
7639             assert (ffecom_transform_only_dummies_);
7640
7641             old_sizes = get_pending_sizes ();
7642             put_pending_sizes (old_sizes);
7643
7644             if (bt == FFEINFO_basictypeCHARACTER)
7645               tlen = ffecom_char_enhance_arg_ (&type, s);
7646             type = ffecom_check_size_overflow_ (s, type, TRUE);
7647
7648             for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
7649               {
7650                 if (type == error_mark_node)
7651                   break;
7652
7653                 dim = ffebld_head (dl);
7654                 assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
7655                 if ((ffebld_left (dim) == NULL) || ffecom_doing_entry_)
7656                   low = ffecom_integer_one_node;
7657                 else
7658                   low = ffecom_expr (ffebld_left (dim));
7659                 assert (ffebld_right (dim) != NULL);
7660                 if ((ffebld_op (ffebld_right (dim)) == FFEBLD_opSTAR)
7661                     || ffecom_doing_entry_)
7662                   {
7663                     /* Used to just do high=low.  But for ffecom_tree_
7664                        canonize_ref_, it probably is important to correctly
7665                        assess the size.  E.g. given COMPLEX C(*),CFUNC and
7666                        C(2)=CFUNC(C), overlap can happen, while it can't
7667                        for, say, C(1)=CFUNC(C(2)).  */
7668                     /* Even more recently used to set to INT_MAX, but that
7669                        broke when some overflow checking went into the back
7670                        end.  Now we just leave the upper bound unspecified.  */
7671                     high = NULL;
7672                   }
7673                 else
7674                   high = ffecom_expr (ffebld_right (dim));
7675
7676                 /* Determine whether array is conditionally adjustable,
7677                    to decide whether back-end magic is needed.
7678
7679                    Normally the front end uses the back-end function
7680                    variable_size to wrap SAVE_EXPR's around expressions
7681                    affecting the size/shape of an array so that the
7682                    size/shape info doesn't change during execution
7683                    of the compiled code even though variables and
7684                    functions referenced in those expressions might.
7685
7686                    variable_size also makes sure those saved expressions
7687                    get evaluated immediately upon entry to the
7688                    compiled procedure -- the front end normally doesn't
7689                    have to worry about that.
7690
7691                    However, there is a problem with this that affects
7692                    g77's implementation of entry points, and that is
7693                    that it is _not_ true that each invocation of the
7694                    compiled procedure is permitted to evaluate
7695                    array size/shape info -- because it is possible
7696                    that, for some invocations, that info is invalid (in
7697                    which case it is "promised" -- i.e. a violation of
7698                    the Fortran standard -- that the compiled code
7699                    won't reference the array or its size/shape
7700                    during that particular invocation).
7701
7702                    To phrase this in C terms, consider this gcc function:
7703
7704                      void foo (int *n, float (*a)[*n])
7705                      {
7706                        // a is "pointer to array ...", fyi.
7707                      }
7708
7709                    Suppose that, for some invocations, it is permitted
7710                    for a caller of foo to do this:
7711
7712                        foo (NULL, NULL);
7713
7714                    Now the _written_ code for foo can take such a call
7715                    into account by either testing explicitly for whether
7716                    (a == NULL) || (n == NULL) -- presumably it is
7717                    not permitted to reference *a in various fashions
7718                    if (n == NULL) I suppose -- or it can avoid it by
7719                    looking at other info (other arguments, static/global
7720                    data, etc.).
7721
7722                    However, this won't work in gcc 2.5.8 because it'll
7723                    automatically emit the code to save the "*n"
7724                    expression, which'll yield a NULL dereference for
7725                    the "foo (NULL, NULL)" call, something the code
7726                    for foo cannot prevent.
7727
7728                    g77 definitely needs to avoid executing such
7729                    code anytime the pointer to the adjustable array
7730                    is NULL, because even if its bounds expressions
7731                    don't have any references to possible "absent"
7732                    variables like "*n" -- say all variable references
7733                    are to COMMON variables, i.e. global (though in C,
7734                    local static could actually make sense) -- the
7735                    expressions could yield other run-time problems
7736                    for allowably "dead" values in those variables.
7737
7738                    For example, let's consider a more complicated
7739                    version of foo:
7740
7741                      extern int i;
7742                      extern int j;
7743
7744                      void foo (float (*a)[i/j])
7745                      {
7746                        ...
7747                      }
7748
7749                    The above is (essentially) quite valid for Fortran
7750                    but, again, for a call like "foo (NULL);", it is
7751                    permitted for i and j to be undefined when the
7752                    call is made.  If j happened to be zero, for
7753                    example, emitting the code to evaluate "i/j"
7754                    could result in a run-time error.
7755
7756                    Offhand, though I don't have my F77 or F90
7757                    standards handy, it might even be valid for a
7758                    bounds expression to contain a function reference,
7759                    in which case I doubt it is permitted for an
7760                    implementation to invoke that function in the
7761                    Fortran case involved here (invocation of an
7762                    alternate ENTRY point that doesn't have the adjustable
7763                    array as one of its arguments).
7764
7765                    So, the code that the compiler would normally emit
7766                    to preevaluate the size/shape info for an
7767                    adjustable array _must not_ be executed at run time
7768                    in certain cases.  Specifically, for Fortran,
7769                    the case is when the pointer to the adjustable
7770                    array == NULL.  (For gnu-ish C, it might be nice
7771                    for the source code itself to specify an expression
7772                    that, if TRUE, inhibits execution of the code.  Or
7773                    reverse the sense for elegance.)
7774
7775                    (Note that g77 could use a different test than NULL,
7776                    actually, since it happens to always pass an
7777                    integer to the called function that specifies which
7778                    entry point is being invoked.  Hmm, this might
7779                    solve the next problem.)
7780
7781                    One way a user could, I suppose, write "foo" so
7782                    it works is to insert COND_EXPR's for the
7783                    size/shape info so the dangerous stuff isn't
7784                    actually done, as in:
7785
7786                      void foo (int *n, float (*a)[(a == NULL) ? 0 : *n])
7787                      {
7788                        ...
7789                      }
7790
7791                    The next problem is that the front end needs to
7792                    be able to tell the back end about the array's
7793                    decl _before_ it tells it about the conditional
7794                    expression to inhibit evaluation of size/shape info,
7795                    as shown above.
7796
7797                    To solve this, the front end needs to be able
7798                    to give the back end the expression to inhibit
7799                    generation of the preevaluation code _after_
7800                    it makes the decl for the adjustable array.
7801
7802                    Until then, the above example using the COND_EXPR
7803                    doesn't pass muster with gcc because the "(a == NULL)"
7804                    part has a reference to "a", which is still
7805                    undefined at that point.
7806
7807                    g77 will therefore use a different mechanism in the
7808                    meantime.  */
7809
7810                 if (!adjustable
7811                     && ((TREE_CODE (low) != INTEGER_CST)
7812                         || (high && TREE_CODE (high) != INTEGER_CST)))
7813                   adjustable = TRUE;
7814
7815 #if 0                           /* Old approach -- see below. */
7816                 if (TREE_CODE (low) != INTEGER_CST)
7817                   low = ffecom_3 (COND_EXPR, integer_type_node,
7818                                   ffecom_adjarray_passed_ (s),
7819                                   low,
7820                                   ffecom_integer_zero_node);
7821
7822                 if (high && TREE_CODE (high) != INTEGER_CST)
7823                   high = ffecom_3 (COND_EXPR, integer_type_node,
7824                                    ffecom_adjarray_passed_ (s),
7825                                    high,
7826                                    ffecom_integer_zero_node);
7827 #endif
7828
7829                 /* ~~~gcc/stor-layout.c (layout_type) should do this,
7830                    probably.  Fixes 950302-1.f.  */
7831
7832                 if (TREE_CODE (low) != INTEGER_CST)
7833                   low = variable_size (low);
7834
7835                 /* ~~~Similarly, this fixes dumb0.f.  The C front end
7836                    does this, which is why dumb0.c would work.  */
7837
7838                 if (high && TREE_CODE (high) != INTEGER_CST)
7839                   high = variable_size (high);
7840
7841                 type
7842                   = build_array_type
7843                     (type,
7844                      build_range_type (ffecom_integer_type_node,
7845                                        low, high));
7846                 type = ffecom_check_size_overflow_ (s, type, TRUE);
7847               }
7848
7849             if (type == error_mark_node)
7850               {
7851                 t = error_mark_node;
7852                 break;
7853               }
7854
7855             if ((ffesymbol_sfdummyparent (s) == NULL)
7856                  || (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER))
7857               {
7858                 type = build_pointer_type (type);
7859                 addr = TRUE;
7860               }
7861
7862             t = build_decl (PARM_DECL, t, type);
7863             DECL_ARTIFICIAL (t) = 1;
7864
7865             /* If this arg is present in every entry point's list of
7866                dummy args, then we're done.  */
7867
7868             if (ffesymbol_numentries (s)
7869                 == (ffecom_num_entrypoints_ + 1))
7870               break;
7871
7872 #if 1
7873
7874             /* If variable_size in stor-layout has been called during
7875                the above, then get_pending_sizes should have the
7876                yet-to-be-evaluated saved expressions pending.
7877                Make the whole lot of them get emitted, conditionally
7878                on whether the array decl ("t" above) is not NULL.  */
7879
7880             {
7881               tree sizes = get_pending_sizes ();
7882               tree tem;
7883
7884               for (tem = sizes;
7885                    tem != old_sizes;
7886                    tem = TREE_CHAIN (tem))
7887                 {
7888                   tree temv = TREE_VALUE (tem);
7889
7890                   if (sizes == tem)
7891                     sizes = temv;
7892                   else
7893                     sizes
7894                       = ffecom_2 (COMPOUND_EXPR,
7895                                   TREE_TYPE (sizes),
7896                                   temv,
7897                                   sizes);
7898                 }
7899
7900               if (sizes != tem)
7901                 {
7902                   sizes
7903                     = ffecom_3 (COND_EXPR,
7904                                 TREE_TYPE (sizes),
7905                                 ffecom_2 (NE_EXPR,
7906                                           integer_type_node,
7907                                           t,
7908                                           null_pointer_node),
7909                                 sizes,
7910                                 convert (TREE_TYPE (sizes),
7911                                          integer_zero_node));
7912                   sizes = ffecom_save_tree (sizes);
7913
7914                   sizes
7915                     = tree_cons (NULL_TREE, sizes, tem);
7916                 }
7917
7918               if (sizes)
7919                 put_pending_sizes (sizes);
7920             }
7921
7922 #else
7923 #if 0
7924             if (adjustable
7925                 && (ffesymbol_numentries (s)
7926                     != ffecom_num_entrypoints_ + 1))
7927               DECL_SOMETHING (t)
7928                 = ffecom_2 (NE_EXPR, integer_type_node,
7929                             t,
7930                             null_pointer_node);
7931 #else
7932 #if 0
7933             if (adjustable
7934                 && (ffesymbol_numentries (s)
7935                     != ffecom_num_entrypoints_ + 1))
7936               {
7937                 ffebad_start (FFEBAD_MISSING_ADJARRAY_UNSUPPORTED);
7938                 ffebad_here (0, ffesymbol_where_line (s),
7939                              ffesymbol_where_column (s));
7940                 ffebad_string (ffesymbol_text (s));
7941                 ffebad_finish ();
7942               }
7943 #endif
7944 #endif
7945 #endif
7946           }
7947           break;
7948
7949         case FFEINFO_whereCOMMON:
7950           {
7951             ffesymbol cs;
7952             ffeglobal cg;
7953             tree ct;
7954             ffestorag st = ffesymbol_storage (s);
7955             tree type;
7956
7957             cs = ffesymbol_common (s);  /* The COMMON area itself.  */
7958             if (st != NULL)     /* Else not laid out. */
7959               {
7960                 ffecom_transform_common_ (cs);
7961                 st = ffesymbol_storage (s);
7962               }
7963
7964             type = ffecom_type_localvar_ (s, bt, kt);
7965
7966             cg = ffesymbol_global (cs); /* The global COMMON info.  */
7967             if ((cg == NULL)
7968                 || (ffeglobal_type (cg) != FFEGLOBAL_typeCOMMON))
7969               ct = NULL_TREE;
7970             else
7971               ct = ffeglobal_hook (cg); /* The common area's tree.  */
7972
7973             if ((ct == NULL_TREE)
7974                 || (st == NULL)
7975                 || (type == error_mark_node))
7976               t = error_mark_node;
7977             else
7978               {
7979                 ffetargetOffset offset;
7980                 ffestorag cst;
7981
7982                 cst = ffestorag_parent (st);
7983                 assert (cst == ffesymbol_storage (cs));
7984
7985                 offset = ffestorag_modulo (cst)
7986                   + ffestorag_offset (st)
7987                   - ffestorag_offset (cst);
7988
7989                 ffecom_debug_kludge_ (ct, "COMMON", s, type, offset);
7990
7991                 /* (t_type *) (((char *) &ct) + offset) */
7992
7993                 t = convert (string_type_node,  /* (char *) */
7994                              ffecom_1 (ADDR_EXPR,
7995                                        build_pointer_type (TREE_TYPE (ct)),
7996                                        ct));
7997                 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
7998                               t,
7999                               build_int_2 (offset, 0));
8000                 t = convert (build_pointer_type (type),
8001                              t);
8002                 TREE_CONSTANT (t) = 1;
8003
8004                 addr = TRUE;
8005               }
8006           }
8007           break;
8008
8009         case FFEINFO_whereIMMEDIATE:
8010         case FFEINFO_whereGLOBAL:
8011         case FFEINFO_whereFLEETING:
8012         case FFEINFO_whereFLEETING_CADDR:
8013         case FFEINFO_whereFLEETING_IADDR:
8014         case FFEINFO_whereINTRINSIC:
8015         case FFEINFO_whereCONSTANT_SUBOBJECT:
8016         default:
8017           assert ("ENTITY where unheard of" == NULL);
8018           /* Fall through. */
8019         case FFEINFO_whereANY:
8020           t = error_mark_node;
8021           break;
8022         }
8023       break;
8024
8025     case FFEINFO_kindFUNCTION:
8026       switch (ffeinfo_where (ffesymbol_info (s)))
8027         {
8028         case FFEINFO_whereLOCAL:        /* Me. */
8029           assert (!ffecom_transform_only_dummies_);
8030           t = current_function_decl;
8031           break;
8032
8033         case FFEINFO_whereGLOBAL:
8034           assert (!ffecom_transform_only_dummies_);
8035
8036           if (((g = ffesymbol_global (s)) != NULL)
8037               && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8038                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8039               && (ffeglobal_hook (g) != NULL_TREE)
8040               && ffe_is_globals ())
8041             {
8042               t = ffeglobal_hook (g);
8043               break;
8044             }
8045
8046           if (ffesymbol_is_f2c (s)
8047               && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8048             t = ffecom_tree_fun_type[bt][kt];
8049           else
8050             t = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
8051
8052           t = build_decl (FUNCTION_DECL,
8053                           ffecom_get_external_identifier_ (s),
8054                           t);
8055           DECL_EXTERNAL (t) = 1;
8056           TREE_PUBLIC (t) = 1;
8057
8058           t = start_decl (t, FALSE);
8059           finish_decl (t, NULL_TREE, FALSE);
8060
8061           if ((g != NULL)
8062               && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8063                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8064             ffeglobal_set_hook (g, t);
8065
8066           ffecom_save_tree_forever (t);
8067
8068           break;
8069
8070         case FFEINFO_whereDUMMY:
8071           assert (ffecom_transform_only_dummies_);
8072
8073           if (ffesymbol_is_f2c (s)
8074               && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8075             t = ffecom_tree_ptr_to_fun_type[bt][kt];
8076           else
8077             t = build_pointer_type
8078               (build_function_type (ffecom_tree_type[bt][kt], NULL_TREE));
8079
8080           t = build_decl (PARM_DECL,
8081                           ffecom_get_identifier_ (ffesymbol_text (s)),
8082                           t);
8083           DECL_ARTIFICIAL (t) = 1;
8084           addr = TRUE;
8085           break;
8086
8087         case FFEINFO_whereCONSTANT:     /* Statement function. */
8088           assert (!ffecom_transform_only_dummies_);
8089           t = ffecom_gen_sfuncdef_ (s, bt, kt);
8090           break;
8091
8092         case FFEINFO_whereINTRINSIC:
8093           assert (!ffecom_transform_only_dummies_);
8094           break;                /* Let actual references generate their
8095                                    decls. */
8096
8097         default:
8098           assert ("FUNCTION where unheard of" == NULL);
8099           /* Fall through. */
8100         case FFEINFO_whereANY:
8101           t = error_mark_node;
8102           break;
8103         }
8104       break;
8105
8106     case FFEINFO_kindSUBROUTINE:
8107       switch (ffeinfo_where (ffesymbol_info (s)))
8108         {
8109         case FFEINFO_whereLOCAL:        /* Me. */
8110           assert (!ffecom_transform_only_dummies_);
8111           t = current_function_decl;
8112           break;
8113
8114         case FFEINFO_whereGLOBAL:
8115           assert (!ffecom_transform_only_dummies_);
8116
8117           if (((g = ffesymbol_global (s)) != NULL)
8118               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8119                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8120               && (ffeglobal_hook (g) != NULL_TREE)
8121               && ffe_is_globals ())
8122             {
8123               t = ffeglobal_hook (g);
8124               break;
8125             }
8126
8127           t = build_decl (FUNCTION_DECL,
8128                           ffecom_get_external_identifier_ (s),
8129                           ffecom_tree_subr_type);
8130           DECL_EXTERNAL (t) = 1;
8131           TREE_PUBLIC (t) = 1;
8132
8133           t = start_decl (t, FALSE);
8134           finish_decl (t, NULL_TREE, FALSE);
8135
8136           if ((g != NULL)
8137               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8138                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8139             ffeglobal_set_hook (g, t);
8140
8141           ffecom_save_tree_forever (t);
8142
8143           break;
8144
8145         case FFEINFO_whereDUMMY:
8146           assert (ffecom_transform_only_dummies_);
8147
8148           t = build_decl (PARM_DECL,
8149                           ffecom_get_identifier_ (ffesymbol_text (s)),
8150                           ffecom_tree_ptr_to_subr_type);
8151           DECL_ARTIFICIAL (t) = 1;
8152           addr = TRUE;
8153           break;
8154
8155         case FFEINFO_whereINTRINSIC:
8156           assert (!ffecom_transform_only_dummies_);
8157           break;                /* Let actual references generate their
8158                                    decls. */
8159
8160         default:
8161           assert ("SUBROUTINE where unheard of" == NULL);
8162           /* Fall through. */
8163         case FFEINFO_whereANY:
8164           t = error_mark_node;
8165           break;
8166         }
8167       break;
8168
8169     case FFEINFO_kindPROGRAM:
8170       switch (ffeinfo_where (ffesymbol_info (s)))
8171         {
8172         case FFEINFO_whereLOCAL:        /* Me. */
8173           assert (!ffecom_transform_only_dummies_);
8174           t = current_function_decl;
8175           break;
8176
8177         case FFEINFO_whereCOMMON:
8178         case FFEINFO_whereDUMMY:
8179         case FFEINFO_whereGLOBAL:
8180         case FFEINFO_whereRESULT:
8181         case FFEINFO_whereFLEETING:
8182         case FFEINFO_whereFLEETING_CADDR:
8183         case FFEINFO_whereFLEETING_IADDR:
8184         case FFEINFO_whereIMMEDIATE:
8185         case FFEINFO_whereINTRINSIC:
8186         case FFEINFO_whereCONSTANT:
8187         case FFEINFO_whereCONSTANT_SUBOBJECT:
8188         default:
8189           assert ("PROGRAM where unheard of" == NULL);
8190           /* Fall through. */
8191         case FFEINFO_whereANY:
8192           t = error_mark_node;
8193           break;
8194         }
8195       break;
8196
8197     case FFEINFO_kindBLOCKDATA:
8198       switch (ffeinfo_where (ffesymbol_info (s)))
8199         {
8200         case FFEINFO_whereLOCAL:        /* Me. */
8201           assert (!ffecom_transform_only_dummies_);
8202           t = current_function_decl;
8203           break;
8204
8205         case FFEINFO_whereGLOBAL:
8206           assert (!ffecom_transform_only_dummies_);
8207
8208           t = build_decl (FUNCTION_DECL,
8209                           ffecom_get_external_identifier_ (s),
8210                           ffecom_tree_blockdata_type);
8211           DECL_EXTERNAL (t) = 1;
8212           TREE_PUBLIC (t) = 1;
8213
8214           t = start_decl (t, FALSE);
8215           finish_decl (t, NULL_TREE, FALSE);
8216
8217           ffecom_save_tree_forever (t);
8218
8219           break;
8220
8221         case FFEINFO_whereCOMMON:
8222         case FFEINFO_whereDUMMY:
8223         case FFEINFO_whereRESULT:
8224         case FFEINFO_whereFLEETING:
8225         case FFEINFO_whereFLEETING_CADDR:
8226         case FFEINFO_whereFLEETING_IADDR:
8227         case FFEINFO_whereIMMEDIATE:
8228         case FFEINFO_whereINTRINSIC:
8229         case FFEINFO_whereCONSTANT:
8230         case FFEINFO_whereCONSTANT_SUBOBJECT:
8231         default:
8232           assert ("BLOCKDATA where unheard of" == NULL);
8233           /* Fall through. */
8234         case FFEINFO_whereANY:
8235           t = error_mark_node;
8236           break;
8237         }
8238       break;
8239
8240     case FFEINFO_kindCOMMON:
8241       switch (ffeinfo_where (ffesymbol_info (s)))
8242         {
8243         case FFEINFO_whereLOCAL:
8244           assert (!ffecom_transform_only_dummies_);
8245           ffecom_transform_common_ (s);
8246           break;
8247
8248         case FFEINFO_whereNONE:
8249         case FFEINFO_whereCOMMON:
8250         case FFEINFO_whereDUMMY:
8251         case FFEINFO_whereGLOBAL:
8252         case FFEINFO_whereRESULT:
8253         case FFEINFO_whereFLEETING:
8254         case FFEINFO_whereFLEETING_CADDR:
8255         case FFEINFO_whereFLEETING_IADDR:
8256         case FFEINFO_whereIMMEDIATE:
8257         case FFEINFO_whereINTRINSIC:
8258         case FFEINFO_whereCONSTANT:
8259         case FFEINFO_whereCONSTANT_SUBOBJECT:
8260         default:
8261           assert ("COMMON where unheard of" == NULL);
8262           /* Fall through. */
8263         case FFEINFO_whereANY:
8264           t = error_mark_node;
8265           break;
8266         }
8267       break;
8268
8269     case FFEINFO_kindCONSTRUCT:
8270       switch (ffeinfo_where (ffesymbol_info (s)))
8271         {
8272         case FFEINFO_whereLOCAL:
8273           assert (!ffecom_transform_only_dummies_);
8274           break;
8275
8276         case FFEINFO_whereNONE:
8277         case FFEINFO_whereCOMMON:
8278         case FFEINFO_whereDUMMY:
8279         case FFEINFO_whereGLOBAL:
8280         case FFEINFO_whereRESULT:
8281         case FFEINFO_whereFLEETING:
8282         case FFEINFO_whereFLEETING_CADDR:
8283         case FFEINFO_whereFLEETING_IADDR:
8284         case FFEINFO_whereIMMEDIATE:
8285         case FFEINFO_whereINTRINSIC:
8286         case FFEINFO_whereCONSTANT:
8287         case FFEINFO_whereCONSTANT_SUBOBJECT:
8288         default:
8289           assert ("CONSTRUCT where unheard of" == NULL);
8290           /* Fall through. */
8291         case FFEINFO_whereANY:
8292           t = error_mark_node;
8293           break;
8294         }
8295       break;
8296
8297     case FFEINFO_kindNAMELIST:
8298       switch (ffeinfo_where (ffesymbol_info (s)))
8299         {
8300         case FFEINFO_whereLOCAL:
8301           assert (!ffecom_transform_only_dummies_);
8302           t = ffecom_transform_namelist_ (s);
8303           break;
8304
8305         case FFEINFO_whereNONE:
8306         case FFEINFO_whereCOMMON:
8307         case FFEINFO_whereDUMMY:
8308         case FFEINFO_whereGLOBAL:
8309         case FFEINFO_whereRESULT:
8310         case FFEINFO_whereFLEETING:
8311         case FFEINFO_whereFLEETING_CADDR:
8312         case FFEINFO_whereFLEETING_IADDR:
8313         case FFEINFO_whereIMMEDIATE:
8314         case FFEINFO_whereINTRINSIC:
8315         case FFEINFO_whereCONSTANT:
8316         case FFEINFO_whereCONSTANT_SUBOBJECT:
8317         default:
8318           assert ("NAMELIST where unheard of" == NULL);
8319           /* Fall through. */
8320         case FFEINFO_whereANY:
8321           t = error_mark_node;
8322           break;
8323         }
8324       break;
8325
8326     default:
8327       assert ("kind unheard of" == NULL);
8328       /* Fall through. */
8329     case FFEINFO_kindANY:
8330       t = error_mark_node;
8331       break;
8332     }
8333
8334   ffesymbol_hook (s).decl_tree = t;
8335   ffesymbol_hook (s).length_tree = tlen;
8336   ffesymbol_hook (s).addr = addr;
8337
8338   lineno = old_lineno;
8339   input_filename = old_input_filename;
8340
8341   return s;
8342 }
8343
8344 /* Transform into ASSIGNable symbol.
8345
8346    Symbol has already been transformed, but for whatever reason, the
8347    resulting decl_tree has been deemed not usable for an ASSIGN target.
8348    (E.g. it isn't wide enough to hold a pointer.)  So, here we invent
8349    another local symbol of type void * and stuff that in the assign_tree
8350    argument.  The F77/F90 standards allow this implementation.  */
8351
8352 static ffesymbol
8353 ffecom_sym_transform_assign_ (ffesymbol s)
8354 {
8355   tree t;                       /* Transformed thingy. */
8356   int old_lineno = lineno;
8357   const char *old_input_filename = input_filename;
8358
8359   if (ffesymbol_sfdummyparent (s) == NULL)
8360     {
8361       input_filename = ffesymbol_where_filename (s);
8362       lineno = ffesymbol_where_filelinenum (s);
8363     }
8364   else
8365     {
8366       ffesymbol sf = ffesymbol_sfdummyparent (s);
8367
8368       input_filename = ffesymbol_where_filename (sf);
8369       lineno = ffesymbol_where_filelinenum (sf);
8370     }
8371
8372   assert (!ffecom_transform_only_dummies_);
8373
8374   t = build_decl (VAR_DECL,
8375                   ffecom_get_invented_identifier ("__g77_ASSIGN_%s",
8376                                                    ffesymbol_text (s)),
8377                   TREE_TYPE (null_pointer_node));
8378
8379   switch (ffesymbol_where (s))
8380     {
8381     case FFEINFO_whereLOCAL:
8382       /* Unlike for regular vars, SAVE status is easy to determine for
8383          ASSIGNed vars, since there's no initialization, there's no
8384          effective storage association (so "SAVE J" does not apply to
8385          K even given "EQUIVALENCE (J,K)"), there's no size issue
8386          to worry about, etc.  */
8387       if ((ffesymbol_is_save (s) || ffe_is_saveall ())
8388           && (ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8389           && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA))
8390         TREE_STATIC (t) = 1;    /* SAVEd in proc, make static. */
8391       else
8392         TREE_STATIC (t) = 0;    /* No need to make static. */
8393       break;
8394
8395     case FFEINFO_whereCOMMON:
8396       TREE_STATIC (t) = 1;      /* Assume COMMONs always SAVEd. */
8397       break;
8398
8399     case FFEINFO_whereDUMMY:
8400       /* Note that twinning a DUMMY means the caller won't see
8401          the ASSIGNed value.  But both F77 and F90 allow implementations
8402          to do this, i.e. disallow Fortran code that would try and
8403          take advantage of actually putting a label into a variable
8404          via a dummy argument (or any other storage association, for
8405          that matter).  */
8406       TREE_STATIC (t) = 0;
8407       break;
8408
8409     default:
8410       TREE_STATIC (t) = 0;
8411       break;
8412     }
8413
8414   t = start_decl (t, FALSE);
8415   finish_decl (t, NULL_TREE, FALSE);
8416
8417   ffesymbol_hook (s).assign_tree = t;
8418
8419   lineno = old_lineno;
8420   input_filename = old_input_filename;
8421
8422   return s;
8423 }
8424
8425 /* Implement COMMON area in back end.
8426
8427    Because COMMON-based variables can be referenced in the dimension
8428    expressions of dummy (adjustable) arrays, and because dummies
8429    (in the gcc back end) need to be put in the outer binding level
8430    of a function (which has two binding levels, the outer holding
8431    the dummies and the inner holding the other vars), special care
8432    must be taken to handle COMMON areas.
8433
8434    The current strategy is basically to always tell the back end about
8435    the COMMON area as a top-level external reference to just a block
8436    of storage of the master type of that area (e.g. integer, real,
8437    character, whatever -- not a structure).  As a distinct action,
8438    if initial values are provided, tell the back end about the area
8439    as a top-level non-external (initialized) area and remember not to
8440    allow further initialization or expansion of the area.  Meanwhile,
8441    if no initialization happens at all, tell the back end about
8442    the largest size we've seen declared so the space does get reserved.
8443    (This function doesn't handle all that stuff, but it does some
8444    of the important things.)
8445
8446    Meanwhile, for COMMON variables themselves, just keep creating
8447    references like *((float *) (&common_area + offset)) each time
8448    we reference the variable.  In other words, don't make a VAR_DECL
8449    or any kind of component reference (like we used to do before 0.4),
8450    though we might do that as well just for debugging purposes (and
8451    stuff the rtl with the appropriate offset expression).  */
8452
8453 static void
8454 ffecom_transform_common_ (ffesymbol s)
8455 {
8456   ffestorag st = ffesymbol_storage (s);
8457   ffeglobal g = ffesymbol_global (s);
8458   tree cbt;
8459   tree cbtype;
8460   tree init;
8461   tree high;
8462   bool is_init = ffestorag_is_init (st);
8463
8464   assert (st != NULL);
8465
8466   if ((g == NULL)
8467       || (ffeglobal_type (g) != FFEGLOBAL_typeCOMMON))
8468     return;
8469
8470   /* First update the size of the area in global terms.  */
8471
8472   ffeglobal_size_common (s, ffestorag_size (st));
8473
8474   if (!ffeglobal_common_init (g))
8475     is_init = FALSE;    /* No explicit init, don't let erroneous joins init. */
8476
8477   cbt = ffeglobal_hook (g);
8478
8479   /* If we already have declared this common block for a previous program
8480      unit, and either we already initialized it or we don't have new
8481      initialization for it, just return what we have without changing it.  */
8482
8483   if ((cbt != NULL_TREE)
8484       && (!is_init
8485           || !DECL_EXTERNAL (cbt)))
8486     {
8487       if (st->hook == NULL) ffestorag_set_hook (st, cbt);
8488       return;
8489     }
8490
8491   /* Process inits.  */
8492
8493   if (is_init)
8494     {
8495       if (ffestorag_init (st) != NULL)
8496         {
8497           ffebld sexp;
8498
8499           /* Set the padding for the expression, so ffecom_expr
8500              knows to insert that many zeros.  */
8501           switch (ffebld_op (sexp = ffestorag_init (st)))
8502             {
8503             case FFEBLD_opCONTER:
8504               ffebld_conter_set_pad (sexp, ffestorag_modulo (st));
8505               break;
8506
8507             case FFEBLD_opARRTER:
8508               ffebld_arrter_set_pad (sexp, ffestorag_modulo (st));
8509               break;
8510
8511             case FFEBLD_opACCTER:
8512               ffebld_accter_set_pad (sexp, ffestorag_modulo (st));
8513               break;
8514
8515             default:
8516               assert ("bad op for cmn init (pad)" == NULL);
8517               break;
8518             }
8519
8520           init = ffecom_expr (sexp);
8521           if (init == error_mark_node)
8522             {                   /* Hopefully the back end complained! */
8523               init = NULL_TREE;
8524               if (cbt != NULL_TREE)
8525                 return;
8526             }
8527         }
8528       else
8529         init = error_mark_node;
8530     }
8531   else
8532     init = NULL_TREE;
8533
8534   /* cbtype must be permanently allocated!  */
8535
8536   /* Allocate the MAX of the areas so far, seen filewide.  */
8537   high = build_int_2 ((ffeglobal_common_size (g)
8538                        + ffeglobal_common_pad (g)) - 1, 0);
8539   TREE_TYPE (high) = ffecom_integer_type_node;
8540
8541   if (init)
8542     cbtype = build_array_type (char_type_node,
8543                                build_range_type (integer_type_node,
8544                                                  integer_zero_node,
8545                                                  high));
8546   else
8547     cbtype = build_array_type (char_type_node, NULL_TREE);
8548
8549   if (cbt == NULL_TREE)
8550     {
8551       cbt
8552         = build_decl (VAR_DECL,
8553                       ffecom_get_external_identifier_ (s),
8554                       cbtype);
8555       TREE_STATIC (cbt) = 1;
8556       TREE_PUBLIC (cbt) = 1;
8557     }
8558   else
8559     {
8560       assert (is_init);
8561       TREE_TYPE (cbt) = cbtype;
8562     }
8563   DECL_EXTERNAL (cbt) = init ? 0 : 1;
8564   DECL_INITIAL (cbt) = init ? error_mark_node : NULL_TREE;
8565
8566   cbt = start_decl (cbt, TRUE);
8567   if (ffeglobal_hook (g) != NULL)
8568     assert (cbt == ffeglobal_hook (g));
8569
8570   assert (!init || !DECL_EXTERNAL (cbt));
8571
8572   /* Make sure that any type can live in COMMON and be referenced
8573      without getting a bus error.  We could pick the most restrictive
8574      alignment of all entities actually placed in the COMMON, but
8575      this seems easy enough.  */
8576
8577   DECL_ALIGN (cbt) = BIGGEST_ALIGNMENT;
8578   DECL_USER_ALIGN (cbt) = 0;
8579
8580   if (is_init && (ffestorag_init (st) == NULL))
8581     init = ffecom_init_zero_ (cbt);
8582
8583   finish_decl (cbt, init, TRUE);
8584
8585   if (is_init)
8586     ffestorag_set_init (st, ffebld_new_any ());
8587
8588   if (init)
8589     {
8590       assert (DECL_SIZE_UNIT (cbt) != NULL_TREE);
8591       assert (TREE_CODE (DECL_SIZE_UNIT (cbt)) == INTEGER_CST);
8592       assert (0 == compare_tree_int (DECL_SIZE_UNIT (cbt),
8593                                      (ffeglobal_common_size (g)
8594                                       + ffeglobal_common_pad (g))));
8595     }
8596
8597   ffeglobal_set_hook (g, cbt);
8598
8599   ffestorag_set_hook (st, cbt);
8600
8601   ffecom_save_tree_forever (cbt);
8602 }
8603
8604 /* Make master area for local EQUIVALENCE.  */
8605
8606 static void
8607 ffecom_transform_equiv_ (ffestorag eqst)
8608 {
8609   tree eqt;
8610   tree eqtype;
8611   tree init;
8612   tree high;
8613   bool is_init = ffestorag_is_init (eqst);
8614
8615   assert (eqst != NULL);
8616
8617   eqt = ffestorag_hook (eqst);
8618
8619   if (eqt != NULL_TREE)
8620     return;
8621
8622   /* Process inits.  */
8623
8624   if (is_init)
8625     {
8626       if (ffestorag_init (eqst) != NULL)
8627         {
8628           ffebld sexp;
8629
8630           /* Set the padding for the expression, so ffecom_expr
8631              knows to insert that many zeros.  */
8632           switch (ffebld_op (sexp = ffestorag_init (eqst)))
8633             {
8634             case FFEBLD_opCONTER:
8635               ffebld_conter_set_pad (sexp, ffestorag_modulo (eqst));
8636               break;
8637
8638             case FFEBLD_opARRTER:
8639               ffebld_arrter_set_pad (sexp, ffestorag_modulo (eqst));
8640               break;
8641
8642             case FFEBLD_opACCTER:
8643               ffebld_accter_set_pad (sexp, ffestorag_modulo (eqst));
8644               break;
8645
8646             default:
8647               assert ("bad op for eqv init (pad)" == NULL);
8648               break;
8649             }
8650
8651           init = ffecom_expr (sexp);
8652           if (init == error_mark_node)
8653             init = NULL_TREE;   /* Hopefully the back end complained! */
8654         }
8655       else
8656         init = error_mark_node;
8657     }
8658   else if (ffe_is_init_local_zero ())
8659     init = error_mark_node;
8660   else
8661     init = NULL_TREE;
8662
8663   ffecom_member_namelisted_ = FALSE;
8664   ffestorag_drive (ffestorag_list_equivs (eqst),
8665                    &ffecom_member_phase1_,
8666                    eqst);
8667
8668   high = build_int_2 ((ffestorag_size (eqst)
8669                        + ffestorag_modulo (eqst)) - 1, 0);
8670   TREE_TYPE (high) = ffecom_integer_type_node;
8671
8672   eqtype = build_array_type (char_type_node,
8673                              build_range_type (ffecom_integer_type_node,
8674                                                ffecom_integer_zero_node,
8675                                                high));
8676
8677   eqt = build_decl (VAR_DECL,
8678                     ffecom_get_invented_identifier ("__g77_equiv_%s",
8679                                                     ffesymbol_text
8680                                                     (ffestorag_symbol (eqst))),
8681                     eqtype);
8682   DECL_EXTERNAL (eqt) = 0;
8683   if (is_init
8684       || ffecom_member_namelisted_
8685 #ifdef FFECOM_sizeMAXSTACKITEM
8686       || (ffestorag_size (eqst) > FFECOM_sizeMAXSTACKITEM)
8687 #endif
8688       || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8689           && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
8690           && (ffestorag_is_save (eqst) || ffe_is_saveall ())))
8691     TREE_STATIC (eqt) = 1;
8692   else
8693     TREE_STATIC (eqt) = 0;
8694   TREE_PUBLIC (eqt) = 0;
8695   TREE_ADDRESSABLE (eqt) = 1;  /* Ensure non-register allocation */
8696   DECL_CONTEXT (eqt) = current_function_decl;
8697   if (init)
8698     DECL_INITIAL (eqt) = error_mark_node;
8699   else
8700     DECL_INITIAL (eqt) = NULL_TREE;
8701
8702   eqt = start_decl (eqt, FALSE);
8703
8704   /* Make sure that any type can live in EQUIVALENCE and be referenced
8705      without getting a bus error.  We could pick the most restrictive
8706      alignment of all entities actually placed in the EQUIVALENCE, but
8707      this seems easy enough.  */
8708
8709   DECL_ALIGN (eqt) = BIGGEST_ALIGNMENT;
8710   DECL_USER_ALIGN (eqt) = 0;
8711
8712   if ((!is_init && ffe_is_init_local_zero ())
8713       || (is_init && (ffestorag_init (eqst) == NULL)))
8714     init = ffecom_init_zero_ (eqt);
8715
8716   finish_decl (eqt, init, FALSE);
8717
8718   if (is_init)
8719     ffestorag_set_init (eqst, ffebld_new_any ());
8720
8721   {
8722     assert (TREE_CODE (DECL_SIZE_UNIT (eqt)) == INTEGER_CST);
8723     assert (0 == compare_tree_int (DECL_SIZE_UNIT (eqt),
8724                                    (ffestorag_size (eqst)
8725                                     + ffestorag_modulo (eqst))));
8726   }
8727
8728   ffestorag_set_hook (eqst, eqt);
8729
8730   ffestorag_drive (ffestorag_list_equivs (eqst),
8731                    &ffecom_member_phase2_,
8732                    eqst);
8733 }
8734
8735 /* Implement NAMELIST in back end.  See f2c/format.c for more info.  */
8736
8737 static tree
8738 ffecom_transform_namelist_ (ffesymbol s)
8739 {
8740   tree nmlt;
8741   tree nmltype = ffecom_type_namelist_ ();
8742   tree nmlinits;
8743   tree nameinit;
8744   tree varsinit;
8745   tree nvarsinit;
8746   tree field;
8747   tree high;
8748   int i;
8749   static int mynumber = 0;
8750
8751   nmlt = build_decl (VAR_DECL,
8752                      ffecom_get_invented_identifier ("__g77_namelist_%d",
8753                                                      mynumber++),
8754                      nmltype);
8755   TREE_STATIC (nmlt) = 1;
8756   DECL_INITIAL (nmlt) = error_mark_node;
8757
8758   nmlt = start_decl (nmlt, FALSE);
8759
8760   /* Process inits.  */
8761
8762   i = strlen (ffesymbol_text (s));
8763
8764   high = build_int_2 (i, 0);
8765   TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
8766
8767   nameinit = ffecom_build_f2c_string_ (i + 1,
8768                                        ffesymbol_text (s));
8769   TREE_TYPE (nameinit)
8770     = build_type_variant
8771     (build_array_type
8772      (char_type_node,
8773       build_range_type (ffecom_f2c_ftnlen_type_node,
8774                         ffecom_f2c_ftnlen_one_node,
8775                         high)),
8776      1, 0);
8777   TREE_CONSTANT (nameinit) = 1;
8778   TREE_STATIC (nameinit) = 1;
8779   nameinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (nameinit)),
8780                        nameinit);
8781
8782   varsinit = ffecom_vardesc_array_ (s);
8783   varsinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (varsinit)),
8784                        varsinit);
8785   TREE_CONSTANT (varsinit) = 1;
8786   TREE_STATIC (varsinit) = 1;
8787
8788   {
8789     ffebld b;
8790
8791     for (i = 0, b = ffesymbol_namelist (s); b != NULL; b = ffebld_trail (b))
8792       ++i;
8793   }
8794   nvarsinit = build_int_2 (i, 0);
8795   TREE_TYPE (nvarsinit) = integer_type_node;
8796   TREE_CONSTANT (nvarsinit) = 1;
8797   TREE_STATIC (nvarsinit) = 1;
8798
8799   nmlinits = build_tree_list ((field = TYPE_FIELDS (nmltype)), nameinit);
8800   TREE_CHAIN (nmlinits) = build_tree_list ((field = TREE_CHAIN (field)),
8801                                            varsinit);
8802   TREE_CHAIN (TREE_CHAIN (nmlinits))
8803     = build_tree_list ((field = TREE_CHAIN (field)), nvarsinit);
8804
8805   nmlinits = build (CONSTRUCTOR, nmltype, NULL_TREE, nmlinits);
8806   TREE_CONSTANT (nmlinits) = 1;
8807   TREE_STATIC (nmlinits) = 1;
8808
8809   finish_decl (nmlt, nmlinits, FALSE);
8810
8811   nmlt = ffecom_1 (ADDR_EXPR, build_pointer_type (nmltype), nmlt);
8812
8813   return nmlt;
8814 }
8815
8816 /* A subroutine of ffecom_tree_canonize_ref_.  The incoming tree is
8817    analyzed on the assumption it is calculating a pointer to be
8818    indirected through.  It must return the proper decl and offset,
8819    taking into account different units of measurements for offsets.  */
8820
8821 static void
8822 ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
8823                            tree t)
8824 {
8825   switch (TREE_CODE (t))
8826     {
8827     case NOP_EXPR:
8828     case CONVERT_EXPR:
8829     case NON_LVALUE_EXPR:
8830       ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
8831       break;
8832
8833     case PLUS_EXPR:
8834       ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
8835       if ((*decl == NULL_TREE)
8836           || (*decl == error_mark_node))
8837         break;
8838
8839       if (TREE_CODE (TREE_OPERAND (t, 1)) == INTEGER_CST)
8840         {
8841           /* An offset into COMMON.  */
8842           *offset = fold (build (PLUS_EXPR, TREE_TYPE (*offset),
8843                                  *offset, TREE_OPERAND (t, 1)));
8844           /* Convert offset (presumably in bytes) into canonical units
8845              (presumably bits).  */
8846           *offset = size_binop (MULT_EXPR,
8847                                 convert (bitsizetype, *offset),
8848                                 TYPE_SIZE (TREE_TYPE (TREE_TYPE (t))));
8849           break;
8850         }
8851       /* Not a COMMON reference, so an unrecognized pattern.  */
8852       *decl = error_mark_node;
8853       break;
8854
8855     case PARM_DECL:
8856       *decl = t;
8857       *offset = bitsize_zero_node;
8858       break;
8859
8860     case ADDR_EXPR:
8861       if (TREE_CODE (TREE_OPERAND (t, 0)) == VAR_DECL)
8862         {
8863           /* A reference to COMMON.  */
8864           *decl = TREE_OPERAND (t, 0);
8865           *offset = bitsize_zero_node;
8866           break;
8867         }
8868       /* Fall through.  */
8869     default:
8870       /* Not a COMMON reference, so an unrecognized pattern.  */
8871       *decl = error_mark_node;
8872       break;
8873     }
8874 }
8875
8876 /* Given a tree that is possibly intended for use as an lvalue, return
8877    information representing a canonical view of that tree as a decl, an
8878    offset into that decl, and a size for the lvalue.
8879
8880    If there's no applicable decl, NULL_TREE is returned for the decl,
8881    and the other fields are left undefined.
8882
8883    If the tree doesn't fit the recognizable forms, an ERROR_MARK node
8884    is returned for the decl, and the other fields are left undefined.
8885
8886    Otherwise, the decl returned currently is either a VAR_DECL or a
8887    PARM_DECL.
8888
8889    The offset returned is always valid, but of course not necessarily
8890    a constant, and not necessarily converted into the appropriate
8891    type, leaving that up to the caller (so as to avoid that overhead
8892    if the decls being looked at are different anyway).
8893
8894    If the size cannot be determined (e.g. an adjustable array),
8895    an ERROR_MARK node is returned for the size.  Otherwise, the
8896    size returned is valid, not necessarily a constant, and not
8897    necessarily converted into the appropriate type as with the
8898    offset.
8899
8900    Note that the offset and size expressions are expressed in the
8901    base storage units (usually bits) rather than in the units of
8902    the type of the decl, because two decls with different types
8903    might overlap but with apparently non-overlapping array offsets,
8904    whereas converting the array offsets to consistant offsets will
8905    reveal the overlap.  */
8906
8907 static void
8908 ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
8909                            tree *size, tree t)
8910 {
8911   /* The default path is to report a nonexistant decl.  */
8912   *decl = NULL_TREE;
8913
8914   if (t == NULL_TREE)
8915     return;
8916
8917   switch (TREE_CODE (t))
8918     {
8919     case ERROR_MARK:
8920     case IDENTIFIER_NODE:
8921     case INTEGER_CST:
8922     case REAL_CST:
8923     case COMPLEX_CST:
8924     case STRING_CST:
8925     case CONST_DECL:
8926     case PLUS_EXPR:
8927     case MINUS_EXPR:
8928     case MULT_EXPR:
8929     case TRUNC_DIV_EXPR:
8930     case CEIL_DIV_EXPR:
8931     case FLOOR_DIV_EXPR:
8932     case ROUND_DIV_EXPR:
8933     case TRUNC_MOD_EXPR:
8934     case CEIL_MOD_EXPR:
8935     case FLOOR_MOD_EXPR:
8936     case ROUND_MOD_EXPR:
8937     case RDIV_EXPR:
8938     case EXACT_DIV_EXPR:
8939     case FIX_TRUNC_EXPR:
8940     case FIX_CEIL_EXPR:
8941     case FIX_FLOOR_EXPR:
8942     case FIX_ROUND_EXPR:
8943     case FLOAT_EXPR:
8944     case NEGATE_EXPR:
8945     case MIN_EXPR:
8946     case MAX_EXPR:
8947     case ABS_EXPR:
8948     case FFS_EXPR:
8949     case LSHIFT_EXPR:
8950     case RSHIFT_EXPR:
8951     case LROTATE_EXPR:
8952     case RROTATE_EXPR:
8953     case BIT_IOR_EXPR:
8954     case BIT_XOR_EXPR:
8955     case BIT_AND_EXPR:
8956     case BIT_ANDTC_EXPR:
8957     case BIT_NOT_EXPR:
8958     case TRUTH_ANDIF_EXPR:
8959     case TRUTH_ORIF_EXPR:
8960     case TRUTH_AND_EXPR:
8961     case TRUTH_OR_EXPR:
8962     case TRUTH_XOR_EXPR:
8963     case TRUTH_NOT_EXPR:
8964     case LT_EXPR:
8965     case LE_EXPR:
8966     case GT_EXPR:
8967     case GE_EXPR:
8968     case EQ_EXPR:
8969     case NE_EXPR:
8970     case COMPLEX_EXPR:
8971     case CONJ_EXPR:
8972     case REALPART_EXPR:
8973     case IMAGPART_EXPR:
8974     case LABEL_EXPR:
8975     case COMPONENT_REF:
8976     case COMPOUND_EXPR:
8977     case ADDR_EXPR:
8978       return;
8979
8980     case VAR_DECL:
8981     case PARM_DECL:
8982       *decl = t;
8983       *offset = bitsize_zero_node;
8984       *size = TYPE_SIZE (TREE_TYPE (t));
8985       return;
8986
8987     case ARRAY_REF:
8988       {
8989         tree array = TREE_OPERAND (t, 0);
8990         tree element = TREE_OPERAND (t, 1);
8991         tree init_offset;
8992
8993         if ((array == NULL_TREE)
8994             || (element == NULL_TREE))
8995           {
8996             *decl = error_mark_node;
8997             return;
8998           }
8999
9000         ffecom_tree_canonize_ref_ (decl, &init_offset, size,
9001                                    array);
9002         if ((*decl == NULL_TREE)
9003             || (*decl == error_mark_node))
9004           return;
9005
9006         /* Calculate ((element - base) * NBBY) + init_offset.  */
9007         *offset = fold (build (MINUS_EXPR, TREE_TYPE (element),
9008                                element,
9009                                TYPE_MIN_VALUE (TYPE_DOMAIN
9010                                                (TREE_TYPE (array)))));
9011
9012         *offset = size_binop (MULT_EXPR,
9013                               convert (bitsizetype, *offset),
9014                               TYPE_SIZE (TREE_TYPE (TREE_TYPE (array))));
9015
9016         *offset = size_binop (PLUS_EXPR, init_offset, *offset);
9017
9018         *size = TYPE_SIZE (TREE_TYPE (t));
9019         return;
9020       }
9021
9022     case INDIRECT_REF:
9023
9024       /* Most of this code is to handle references to COMMON.  And so
9025          far that is useful only for calling library functions, since
9026          external (user) functions might reference common areas.  But
9027          even calling an external function, it's worthwhile to decode
9028          COMMON references because if not storing into COMMON, we don't
9029          want COMMON-based arguments to gratuitously force use of a
9030          temporary.  */
9031
9032       *size = TYPE_SIZE (TREE_TYPE (t));
9033
9034       ffecom_tree_canonize_ptr_ (decl, offset,
9035                                  TREE_OPERAND (t, 0));
9036
9037       return;
9038
9039     case CONVERT_EXPR:
9040     case NOP_EXPR:
9041     case MODIFY_EXPR:
9042     case NON_LVALUE_EXPR:
9043     case RESULT_DECL:
9044     case FIELD_DECL:
9045     case COND_EXPR:             /* More cases than we can handle. */
9046     case SAVE_EXPR:
9047     case REFERENCE_EXPR:
9048     case PREDECREMENT_EXPR:
9049     case PREINCREMENT_EXPR:
9050     case POSTDECREMENT_EXPR:
9051     case POSTINCREMENT_EXPR:
9052     case CALL_EXPR:
9053     default:
9054       *decl = error_mark_node;
9055       return;
9056     }
9057 }
9058
9059 /* Do divide operation appropriate to type of operands.  */
9060
9061 static tree
9062 ffecom_tree_divide_ (tree tree_type, tree left, tree right,
9063                      tree dest_tree, ffebld dest, bool *dest_used,
9064                      tree hook)
9065 {
9066   if ((left == error_mark_node)
9067       || (right == error_mark_node))
9068     return error_mark_node;
9069
9070   switch (TREE_CODE (tree_type))
9071     {
9072     case INTEGER_TYPE:
9073       return ffecom_2 (TRUNC_DIV_EXPR, tree_type,
9074                        left,
9075                        right);
9076
9077     case COMPLEX_TYPE:
9078       if (! optimize_size)
9079         return ffecom_2 (RDIV_EXPR, tree_type,
9080                          left,
9081                          right);
9082       {
9083         ffecomGfrt ix;
9084
9085         if (TREE_TYPE (tree_type)
9086             == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9087           ix = FFECOM_gfrtDIV_CC;       /* Overlapping result okay. */
9088         else
9089           ix = FFECOM_gfrtDIV_ZZ;       /* Overlapping result okay. */
9090
9091         left = ffecom_1 (ADDR_EXPR,
9092                          build_pointer_type (TREE_TYPE (left)),
9093                          left);
9094         left = build_tree_list (NULL_TREE, left);
9095         right = ffecom_1 (ADDR_EXPR,
9096                           build_pointer_type (TREE_TYPE (right)),
9097                           right);
9098         right = build_tree_list (NULL_TREE, right);
9099         TREE_CHAIN (left) = right;
9100
9101         return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9102                              ffecom_gfrt_kindtype (ix),
9103                              ffe_is_f2c_library (),
9104                              tree_type,
9105                              left,
9106                              dest_tree, dest, dest_used,
9107                              NULL_TREE, TRUE, hook);
9108       }
9109       break;
9110
9111     case RECORD_TYPE:
9112       {
9113         ffecomGfrt ix;
9114
9115         if (TREE_TYPE (TYPE_FIELDS (tree_type))
9116             == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9117           ix = FFECOM_gfrtDIV_CC;       /* Overlapping result okay. */
9118         else
9119           ix = FFECOM_gfrtDIV_ZZ;       /* Overlapping result okay. */
9120
9121         left = ffecom_1 (ADDR_EXPR,
9122                          build_pointer_type (TREE_TYPE (left)),
9123                          left);
9124         left = build_tree_list (NULL_TREE, left);
9125         right = ffecom_1 (ADDR_EXPR,
9126                           build_pointer_type (TREE_TYPE (right)),
9127                           right);
9128         right = build_tree_list (NULL_TREE, right);
9129         TREE_CHAIN (left) = right;
9130
9131         return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9132                              ffecom_gfrt_kindtype (ix),
9133                              ffe_is_f2c_library (),
9134                              tree_type,
9135                              left,
9136                              dest_tree, dest, dest_used,
9137                              NULL_TREE, TRUE, hook);
9138       }
9139       break;
9140
9141     default:
9142       return ffecom_2 (RDIV_EXPR, tree_type,
9143                        left,
9144                        right);
9145     }
9146 }
9147
9148 /* Build type info for non-dummy variable.  */
9149
9150 static tree
9151 ffecom_type_localvar_ (ffesymbol s, ffeinfoBasictype bt,
9152                        ffeinfoKindtype kt)
9153 {
9154   tree type;
9155   ffebld dl;
9156   ffebld dim;
9157   tree lowt;
9158   tree hight;
9159
9160   type = ffecom_tree_type[bt][kt];
9161   if (bt == FFEINFO_basictypeCHARACTER)
9162     {
9163       hight = build_int_2 (ffesymbol_size (s), 0);
9164       TREE_TYPE (hight) = ffecom_f2c_ftnlen_type_node;
9165
9166       type
9167         = build_array_type
9168           (type,
9169            build_range_type (ffecom_f2c_ftnlen_type_node,
9170                              ffecom_f2c_ftnlen_one_node,
9171                              hight));
9172       type = ffecom_check_size_overflow_ (s, type, FALSE);
9173     }
9174
9175   for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
9176     {
9177       if (type == error_mark_node)
9178         break;
9179
9180       dim = ffebld_head (dl);
9181       assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
9182
9183       if (ffebld_left (dim) == NULL)
9184         lowt = integer_one_node;
9185       else
9186         lowt = ffecom_expr (ffebld_left (dim));
9187
9188       if (TREE_CODE (lowt) != INTEGER_CST)
9189         lowt = variable_size (lowt);
9190
9191       assert (ffebld_right (dim) != NULL);
9192       hight = ffecom_expr (ffebld_right (dim));
9193
9194       if (TREE_CODE (hight) != INTEGER_CST)
9195         hight = variable_size (hight);
9196
9197       type = build_array_type (type,
9198                                build_range_type (ffecom_integer_type_node,
9199                                                  lowt, hight));
9200       type = ffecom_check_size_overflow_ (s, type, FALSE);
9201     }
9202
9203   return type;
9204 }
9205
9206 /* Build Namelist type.  */
9207
9208 static tree
9209 ffecom_type_namelist_ ()
9210 {
9211   static tree type = NULL_TREE;
9212
9213   if (type == NULL_TREE)
9214     {
9215       static tree namefield, varsfield, nvarsfield;
9216       tree vardesctype;
9217
9218       vardesctype = ffecom_type_vardesc_ ();
9219
9220       type = make_node (RECORD_TYPE);
9221
9222       vardesctype = build_pointer_type (build_pointer_type (vardesctype));
9223
9224       namefield = ffecom_decl_field (type, NULL_TREE, "name",
9225                                      string_type_node);
9226       varsfield = ffecom_decl_field (type, namefield, "vars", vardesctype);
9227       nvarsfield = ffecom_decl_field (type, varsfield, "nvars",
9228                                       integer_type_node);
9229
9230       TYPE_FIELDS (type) = namefield;
9231       layout_type (type);
9232
9233       ggc_add_tree_root (&type, 1);
9234     }
9235
9236   return type;
9237 }
9238
9239 /* Build Vardesc type.  */
9240
9241 static tree
9242 ffecom_type_vardesc_ ()
9243 {
9244   static tree type = NULL_TREE;
9245   static tree namefield, addrfield, dimsfield, typefield;
9246
9247   if (type == NULL_TREE)
9248     {
9249       type = make_node (RECORD_TYPE);
9250
9251       namefield = ffecom_decl_field (type, NULL_TREE, "name",
9252                                      string_type_node);
9253       addrfield = ffecom_decl_field (type, namefield, "addr",
9254                                      string_type_node);
9255       dimsfield = ffecom_decl_field (type, addrfield, "dims",
9256                                      ffecom_f2c_ptr_to_ftnlen_type_node);
9257       typefield = ffecom_decl_field (type, dimsfield, "type",
9258                                      integer_type_node);
9259
9260       TYPE_FIELDS (type) = namefield;
9261       layout_type (type);
9262
9263       ggc_add_tree_root (&type, 1);
9264     }
9265
9266   return type;
9267 }
9268
9269 static tree
9270 ffecom_vardesc_ (ffebld expr)
9271 {
9272   ffesymbol s;
9273
9274   assert (ffebld_op (expr) == FFEBLD_opSYMTER);
9275   s = ffebld_symter (expr);
9276
9277   if (ffesymbol_hook (s).vardesc_tree == NULL_TREE)
9278     {
9279       int i;
9280       tree vardesctype = ffecom_type_vardesc_ ();
9281       tree var;
9282       tree nameinit;
9283       tree dimsinit;
9284       tree addrinit;
9285       tree typeinit;
9286       tree field;
9287       tree varinits;
9288       static int mynumber = 0;
9289
9290       var = build_decl (VAR_DECL,
9291                         ffecom_get_invented_identifier ("__g77_vardesc_%d",
9292                                                         mynumber++),
9293                         vardesctype);
9294       TREE_STATIC (var) = 1;
9295       DECL_INITIAL (var) = error_mark_node;
9296
9297       var = start_decl (var, FALSE);
9298
9299       /* Process inits.  */
9300
9301       nameinit = ffecom_build_f2c_string_ ((i = strlen (ffesymbol_text (s)))
9302                                            + 1,
9303                                            ffesymbol_text (s));
9304       TREE_TYPE (nameinit)
9305         = build_type_variant
9306         (build_array_type
9307          (char_type_node,
9308           build_range_type (integer_type_node,
9309                             integer_one_node,
9310                             build_int_2 (i, 0))),
9311          1, 0);
9312       TREE_CONSTANT (nameinit) = 1;
9313       TREE_STATIC (nameinit) = 1;
9314       nameinit = ffecom_1 (ADDR_EXPR,
9315                            build_pointer_type (TREE_TYPE (nameinit)),
9316                            nameinit);
9317
9318       addrinit = ffecom_arg_ptr_to_expr (expr, &typeinit);
9319
9320       dimsinit = ffecom_vardesc_dims_ (s);
9321
9322       if (typeinit == NULL_TREE)
9323         {
9324           ffeinfoBasictype bt = ffesymbol_basictype (s);
9325           ffeinfoKindtype kt = ffesymbol_kindtype (s);
9326           int tc = ffecom_f2c_typecode (bt, kt);
9327
9328           assert (tc != -1);
9329           typeinit = build_int_2 (tc, (tc < 0) ? -1 : 0);
9330         }
9331       else
9332         typeinit = ffecom_1 (NEGATE_EXPR, TREE_TYPE (typeinit), typeinit);
9333
9334       varinits = build_tree_list ((field = TYPE_FIELDS (vardesctype)),
9335                                   nameinit);
9336       TREE_CHAIN (varinits) = build_tree_list ((field = TREE_CHAIN (field)),
9337                                                addrinit);
9338       TREE_CHAIN (TREE_CHAIN (varinits))
9339         = build_tree_list ((field = TREE_CHAIN (field)), dimsinit);
9340       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (varinits)))
9341         = build_tree_list ((field = TREE_CHAIN (field)), typeinit);
9342
9343       varinits = build (CONSTRUCTOR, vardesctype, NULL_TREE, varinits);
9344       TREE_CONSTANT (varinits) = 1;
9345       TREE_STATIC (varinits) = 1;
9346
9347       finish_decl (var, varinits, FALSE);
9348
9349       var = ffecom_1 (ADDR_EXPR, build_pointer_type (vardesctype), var);
9350
9351       ffesymbol_hook (s).vardesc_tree = var;
9352     }
9353
9354   return ffesymbol_hook (s).vardesc_tree;
9355 }
9356
9357 static tree
9358 ffecom_vardesc_array_ (ffesymbol s)
9359 {
9360   ffebld b;
9361   tree list;
9362   tree item = NULL_TREE;
9363   tree var;
9364   int i;
9365   static int mynumber = 0;
9366
9367   for (i = 0, list = NULL_TREE, b = ffesymbol_namelist (s);
9368        b != NULL;
9369        b = ffebld_trail (b), ++i)
9370     {
9371       tree t;
9372
9373       t = ffecom_vardesc_ (ffebld_head (b));
9374
9375       if (list == NULL_TREE)
9376         list = item = build_tree_list (NULL_TREE, t);
9377       else
9378         {
9379           TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9380           item = TREE_CHAIN (item);
9381         }
9382     }
9383
9384   item = build_array_type (build_pointer_type (ffecom_type_vardesc_ ()),
9385                            build_range_type (integer_type_node,
9386                                              integer_one_node,
9387                                              build_int_2 (i, 0)));
9388   list = build (CONSTRUCTOR, item, NULL_TREE, list);
9389   TREE_CONSTANT (list) = 1;
9390   TREE_STATIC (list) = 1;
9391
9392   var = ffecom_get_invented_identifier ("__g77_vardesc_array_%d", mynumber++);
9393   var = build_decl (VAR_DECL, var, item);
9394   TREE_STATIC (var) = 1;
9395   DECL_INITIAL (var) = error_mark_node;
9396   var = start_decl (var, FALSE);
9397   finish_decl (var, list, FALSE);
9398
9399   return var;
9400 }
9401
9402 static tree
9403 ffecom_vardesc_dims_ (ffesymbol s)
9404 {
9405   if (ffesymbol_dims (s) == NULL)
9406     return convert (ffecom_f2c_ptr_to_ftnlen_type_node,
9407                     integer_zero_node);
9408
9409   {
9410     ffebld b;
9411     ffebld e;
9412     tree list;
9413     tree backlist;
9414     tree item = NULL_TREE;
9415     tree var;
9416     tree numdim;
9417     tree numelem;
9418     tree baseoff = NULL_TREE;
9419     static int mynumber = 0;
9420
9421     numdim = build_int_2 ((int) ffesymbol_rank (s), 0);
9422     TREE_TYPE (numdim) = ffecom_f2c_ftnlen_type_node;
9423
9424     numelem = ffecom_expr (ffesymbol_arraysize (s));
9425     TREE_TYPE (numelem) = ffecom_f2c_ftnlen_type_node;
9426
9427     list = NULL_TREE;
9428     backlist = NULL_TREE;
9429     for (b = ffesymbol_dims (s), e = ffesymbol_extents (s);
9430          b != NULL;
9431          b = ffebld_trail (b), e = ffebld_trail (e))
9432       {
9433         tree t;
9434         tree low;
9435         tree back;
9436
9437         if (ffebld_trail (b) == NULL)
9438           t = NULL_TREE;
9439         else
9440           {
9441             t = convert (ffecom_f2c_ftnlen_type_node,
9442                          ffecom_expr (ffebld_head (e)));
9443
9444             if (list == NULL_TREE)
9445               list = item = build_tree_list (NULL_TREE, t);
9446             else
9447               {
9448                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9449                 item = TREE_CHAIN (item);
9450               }
9451           }
9452
9453         if (ffebld_left (ffebld_head (b)) == NULL)
9454           low = ffecom_integer_one_node;
9455         else
9456           low = ffecom_expr (ffebld_left (ffebld_head (b)));
9457         low = convert (ffecom_f2c_ftnlen_type_node, low);
9458
9459         back = build_tree_list (low, t);
9460         TREE_CHAIN (back) = backlist;
9461         backlist = back;
9462       }
9463
9464     for (item = backlist; item != NULL_TREE; item = TREE_CHAIN (item))
9465       {
9466         if (TREE_VALUE (item) == NULL_TREE)
9467           baseoff = TREE_PURPOSE (item);
9468         else
9469           baseoff = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
9470                               TREE_PURPOSE (item),
9471                               ffecom_2 (MULT_EXPR,
9472                                         ffecom_f2c_ftnlen_type_node,
9473                                         TREE_VALUE (item),
9474                                         baseoff));
9475       }
9476
9477     /* backlist now dead, along with all TREE_PURPOSEs on it.  */
9478
9479     baseoff = build_tree_list (NULL_TREE, baseoff);
9480     TREE_CHAIN (baseoff) = list;
9481
9482     numelem = build_tree_list (NULL_TREE, numelem);
9483     TREE_CHAIN (numelem) = baseoff;
9484
9485     numdim = build_tree_list (NULL_TREE, numdim);
9486     TREE_CHAIN (numdim) = numelem;
9487
9488     item = build_array_type (ffecom_f2c_ftnlen_type_node,
9489                              build_range_type (integer_type_node,
9490                                                integer_zero_node,
9491                                                build_int_2
9492                                                ((int) ffesymbol_rank (s)
9493                                                 + 2, 0)));
9494     list = build (CONSTRUCTOR, item, NULL_TREE, numdim);
9495     TREE_CONSTANT (list) = 1;
9496     TREE_STATIC (list) = 1;
9497
9498     var = ffecom_get_invented_identifier ("__g77_dims_%d", mynumber++);
9499     var = build_decl (VAR_DECL, var, item);
9500     TREE_STATIC (var) = 1;
9501     DECL_INITIAL (var) = error_mark_node;
9502     var = start_decl (var, FALSE);
9503     finish_decl (var, list, FALSE);
9504
9505     var = ffecom_1 (ADDR_EXPR, build_pointer_type (item), var);
9506
9507     return var;
9508   }
9509 }
9510
9511 /* Essentially does a "fold (build1 (code, type, node))" while checking
9512    for certain housekeeping things.
9513
9514    NOTE: for building an ADDR_EXPR around a FUNCTION_DECL, use
9515    ffecom_1_fn instead.  */
9516
9517 tree
9518 ffecom_1 (enum tree_code code, tree type, tree node)
9519 {
9520   tree item;
9521
9522   if ((node == error_mark_node)
9523       || (type == error_mark_node))
9524     return error_mark_node;
9525
9526   if (code == ADDR_EXPR)
9527     {
9528       if (!mark_addressable (node))
9529         assert ("can't mark_addressable this node!" == NULL);
9530     }
9531
9532   switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9533     {
9534       tree realtype;
9535
9536     case REALPART_EXPR:
9537       item = build (COMPONENT_REF, type, node, TYPE_FIELDS (TREE_TYPE (node)));
9538       break;
9539
9540     case IMAGPART_EXPR:
9541       item = build (COMPONENT_REF, type, node, TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (node))));
9542       break;
9543
9544
9545     case NEGATE_EXPR:
9546       if (TREE_CODE (type) != RECORD_TYPE)
9547         {
9548           item = build1 (code, type, node);
9549           break;
9550         }
9551       node = ffecom_stabilize_aggregate_ (node);
9552       realtype = TREE_TYPE (TYPE_FIELDS (type));
9553       item =
9554         ffecom_2 (COMPLEX_EXPR, type,
9555                   ffecom_1 (NEGATE_EXPR, realtype,
9556                             ffecom_1 (REALPART_EXPR, realtype,
9557                                       node)),
9558                   ffecom_1 (NEGATE_EXPR, realtype,
9559                             ffecom_1 (IMAGPART_EXPR, realtype,
9560                                       node)));
9561       break;
9562
9563     default:
9564       item = build1 (code, type, node);
9565       break;
9566     }
9567
9568   if (TREE_SIDE_EFFECTS (node))
9569     TREE_SIDE_EFFECTS (item) = 1;
9570   if (code == ADDR_EXPR && staticp (node))
9571     TREE_CONSTANT (item) = 1;
9572   else if (code == INDIRECT_REF)
9573     TREE_READONLY (item) = TYPE_READONLY (type);
9574   return fold (item);
9575 }
9576
9577 /* Like ffecom_1 (ADDR_EXPR, TREE_TYPE (node), node), except
9578    handles TREE_CODE (node) == FUNCTION_DECL.  In particular,
9579    does not set TREE_ADDRESSABLE (because calling an inline
9580    function does not mean the function needs to be separately
9581    compiled).  */
9582
9583 tree
9584 ffecom_1_fn (tree node)
9585 {
9586   tree item;
9587   tree type;
9588
9589   if (node == error_mark_node)
9590     return error_mark_node;
9591
9592   type = build_type_variant (TREE_TYPE (node),
9593                              TREE_READONLY (node),
9594                              TREE_THIS_VOLATILE (node));
9595   item = build1 (ADDR_EXPR,
9596                  build_pointer_type (type), node);
9597   if (TREE_SIDE_EFFECTS (node))
9598     TREE_SIDE_EFFECTS (item) = 1;
9599   if (staticp (node))
9600     TREE_CONSTANT (item) = 1;
9601   return fold (item);
9602 }
9603
9604 /* Essentially does a "fold (build (code, type, node1, node2))" while
9605    checking for certain housekeeping things.  */
9606
9607 tree
9608 ffecom_2 (enum tree_code code, tree type, tree node1,
9609           tree node2)
9610 {
9611   tree item;
9612
9613   if ((node1 == error_mark_node)
9614       || (node2 == error_mark_node)
9615       || (type == error_mark_node))
9616     return error_mark_node;
9617
9618   switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9619     {
9620       tree a, b, c, d, realtype;
9621
9622     case CONJ_EXPR:
9623       assert ("no CONJ_EXPR support yet" == NULL);
9624       return error_mark_node;
9625
9626     case COMPLEX_EXPR:
9627       item = build_tree_list (TYPE_FIELDS (type), node1);
9628       TREE_CHAIN (item) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), node2);
9629       item = build (CONSTRUCTOR, type, NULL_TREE, item);
9630       break;
9631
9632     case PLUS_EXPR:
9633       if (TREE_CODE (type) != RECORD_TYPE)
9634         {
9635           item = build (code, type, node1, node2);
9636           break;
9637         }
9638       node1 = ffecom_stabilize_aggregate_ (node1);
9639       node2 = ffecom_stabilize_aggregate_ (node2);
9640       realtype = TREE_TYPE (TYPE_FIELDS (type));
9641       item =
9642         ffecom_2 (COMPLEX_EXPR, type,
9643                   ffecom_2 (PLUS_EXPR, realtype,
9644                             ffecom_1 (REALPART_EXPR, realtype,
9645                                       node1),
9646                             ffecom_1 (REALPART_EXPR, realtype,
9647                                       node2)),
9648                   ffecom_2 (PLUS_EXPR, realtype,
9649                             ffecom_1 (IMAGPART_EXPR, realtype,
9650                                       node1),
9651                             ffecom_1 (IMAGPART_EXPR, realtype,
9652                                       node2)));
9653       break;
9654
9655     case MINUS_EXPR:
9656       if (TREE_CODE (type) != RECORD_TYPE)
9657         {
9658           item = build (code, type, node1, node2);
9659           break;
9660         }
9661       node1 = ffecom_stabilize_aggregate_ (node1);
9662       node2 = ffecom_stabilize_aggregate_ (node2);
9663       realtype = TREE_TYPE (TYPE_FIELDS (type));
9664       item =
9665         ffecom_2 (COMPLEX_EXPR, type,
9666                   ffecom_2 (MINUS_EXPR, realtype,
9667                             ffecom_1 (REALPART_EXPR, realtype,
9668                                       node1),
9669                             ffecom_1 (REALPART_EXPR, realtype,
9670                                       node2)),
9671                   ffecom_2 (MINUS_EXPR, realtype,
9672                             ffecom_1 (IMAGPART_EXPR, realtype,
9673                                       node1),
9674                             ffecom_1 (IMAGPART_EXPR, realtype,
9675                                       node2)));
9676       break;
9677
9678     case MULT_EXPR:
9679       if (TREE_CODE (type) != RECORD_TYPE)
9680         {
9681           item = build (code, type, node1, node2);
9682           break;
9683         }
9684       node1 = ffecom_stabilize_aggregate_ (node1);
9685       node2 = ffecom_stabilize_aggregate_ (node2);
9686       realtype = TREE_TYPE (TYPE_FIELDS (type));
9687       a = save_expr (ffecom_1 (REALPART_EXPR, realtype,
9688                                node1));
9689       b = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
9690                                node1));
9691       c = save_expr (ffecom_1 (REALPART_EXPR, realtype,
9692                                node2));
9693       d = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
9694                                node2));
9695       item =
9696         ffecom_2 (COMPLEX_EXPR, type,
9697                   ffecom_2 (MINUS_EXPR, realtype,
9698                             ffecom_2 (MULT_EXPR, realtype,
9699                                       a,
9700                                       c),
9701                             ffecom_2 (MULT_EXPR, realtype,
9702                                       b,
9703                                       d)),
9704                   ffecom_2 (PLUS_EXPR, realtype,
9705                             ffecom_2 (MULT_EXPR, realtype,
9706                                       a,
9707                                       d),
9708                             ffecom_2 (MULT_EXPR, realtype,
9709                                       c,
9710                                       b)));
9711       break;
9712
9713     case EQ_EXPR:
9714       if ((TREE_CODE (node1) != RECORD_TYPE)
9715           && (TREE_CODE (node2) != RECORD_TYPE))
9716         {
9717           item = build (code, type, node1, node2);
9718           break;
9719         }
9720       assert (TREE_CODE (node1) == RECORD_TYPE);
9721       assert (TREE_CODE (node2) == RECORD_TYPE);
9722       node1 = ffecom_stabilize_aggregate_ (node1);
9723       node2 = ffecom_stabilize_aggregate_ (node2);
9724       realtype = TREE_TYPE (TYPE_FIELDS (type));
9725       item =
9726         ffecom_2 (TRUTH_ANDIF_EXPR, type,
9727                   ffecom_2 (code, type,
9728                             ffecom_1 (REALPART_EXPR, realtype,
9729                                       node1),
9730                             ffecom_1 (REALPART_EXPR, realtype,
9731                                       node2)),
9732                   ffecom_2 (code, type,
9733                             ffecom_1 (IMAGPART_EXPR, realtype,
9734                                       node1),
9735                             ffecom_1 (IMAGPART_EXPR, realtype,
9736                                       node2)));
9737       break;
9738
9739     case NE_EXPR:
9740       if ((TREE_CODE (node1) != RECORD_TYPE)
9741           && (TREE_CODE (node2) != RECORD_TYPE))
9742         {
9743           item = build (code, type, node1, node2);
9744           break;
9745         }
9746       assert (TREE_CODE (node1) == RECORD_TYPE);
9747       assert (TREE_CODE (node2) == RECORD_TYPE);
9748       node1 = ffecom_stabilize_aggregate_ (node1);
9749       node2 = ffecom_stabilize_aggregate_ (node2);
9750       realtype = TREE_TYPE (TYPE_FIELDS (type));
9751       item =
9752         ffecom_2 (TRUTH_ORIF_EXPR, type,
9753                   ffecom_2 (code, type,
9754                             ffecom_1 (REALPART_EXPR, realtype,
9755                                       node1),
9756                             ffecom_1 (REALPART_EXPR, realtype,
9757                                       node2)),
9758                   ffecom_2 (code, type,
9759                             ffecom_1 (IMAGPART_EXPR, realtype,
9760                                       node1),
9761                             ffecom_1 (IMAGPART_EXPR, realtype,
9762                                       node2)));
9763       break;
9764
9765     default:
9766       item = build (code, type, node1, node2);
9767       break;
9768     }
9769
9770   if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2))
9771     TREE_SIDE_EFFECTS (item) = 1;
9772   return fold (item);
9773 }
9774
9775 /* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint
9776
9777    ffesymbol s;  // the ENTRY point itself
9778    if (ffecom_2pass_advise_entrypoint(s))
9779        // the ENTRY point has been accepted
9780
9781    Does whatever compiler needs to do when it learns about the entrypoint,
9782    like determine the return type of the master function, count the
9783    number of entrypoints, etc.  Returns FALSE if the return type is
9784    not compatible with the return type(s) of other entrypoint(s).
9785
9786    NOTE: for every call to this fn that returns TRUE, _do_entrypoint must
9787    later (after _finish_progunit) be called with the same entrypoint(s)
9788    as passed to this fn for which TRUE was returned.
9789
9790    03-Jan-92  JCB  2.0
9791       Return FALSE if the return type conflicts with previous entrypoints.  */
9792
9793 bool
9794 ffecom_2pass_advise_entrypoint (ffesymbol entry)
9795 {
9796   ffebld list;                  /* opITEM. */
9797   ffebld mlist;                 /* opITEM. */
9798   ffebld plist;                 /* opITEM. */
9799   ffebld arg;                   /* ffebld_head(opITEM). */
9800   ffebld item;                  /* opITEM. */
9801   ffesymbol s;                  /* ffebld_symter(arg). */
9802   ffeinfoBasictype bt = ffesymbol_basictype (entry);
9803   ffeinfoKindtype kt = ffesymbol_kindtype (entry);
9804   ffetargetCharacterSize size = ffesymbol_size (entry);
9805   bool ok;
9806
9807   if (ffecom_num_entrypoints_ == 0)
9808     {                           /* First entrypoint, make list of main
9809                                    arglist's dummies. */
9810       assert (ffecom_primary_entry_ != NULL);
9811
9812       ffecom_master_bt_ = ffesymbol_basictype (ffecom_primary_entry_);
9813       ffecom_master_kt_ = ffesymbol_kindtype (ffecom_primary_entry_);
9814       ffecom_master_size_ = ffesymbol_size (ffecom_primary_entry_);
9815
9816       for (plist = NULL, list = ffesymbol_dummyargs (ffecom_primary_entry_);
9817            list != NULL;
9818            list = ffebld_trail (list))
9819         {
9820           arg = ffebld_head (list);
9821           if (ffebld_op (arg) != FFEBLD_opSYMTER)
9822             continue;           /* Alternate return or some such thing. */
9823           item = ffebld_new_item (arg, NULL);
9824           if (plist == NULL)
9825             ffecom_master_arglist_ = item;
9826           else
9827             ffebld_set_trail (plist, item);
9828           plist = item;
9829         }
9830     }
9831
9832   /* If necessary, scan entry arglist for alternate returns.  Do this scan
9833      apparently redundantly (it's done below to UNIONize the arglists) so
9834      that we don't complain about RETURN 1 if an offending ENTRY is the only
9835      one with an alternate return.  */
9836
9837   if (!ffecom_is_altreturning_)
9838     {
9839       for (list = ffesymbol_dummyargs (entry);
9840            list != NULL;
9841            list = ffebld_trail (list))
9842         {
9843           arg = ffebld_head (list);
9844           if (ffebld_op (arg) == FFEBLD_opSTAR)
9845             {
9846               ffecom_is_altreturning_ = TRUE;
9847               break;
9848             }
9849         }
9850     }
9851
9852   /* Now check type compatibility. */
9853
9854   switch (ffecom_master_bt_)
9855     {
9856     case FFEINFO_basictypeNONE:
9857       ok = (bt != FFEINFO_basictypeCHARACTER);
9858       break;
9859
9860     case FFEINFO_basictypeCHARACTER:
9861       ok
9862         = (bt == FFEINFO_basictypeCHARACTER)
9863         && (kt == ffecom_master_kt_)
9864         && (size == ffecom_master_size_);
9865       break;
9866
9867     case FFEINFO_basictypeANY:
9868       return FALSE;             /* Just don't bother. */
9869
9870     default:
9871       if (bt == FFEINFO_basictypeCHARACTER)
9872         {
9873           ok = FALSE;
9874           break;
9875         }
9876       ok = TRUE;
9877       if ((bt != ffecom_master_bt_) || (kt != ffecom_master_kt_))
9878         {
9879           ffecom_master_bt_ = FFEINFO_basictypeNONE;
9880           ffecom_master_kt_ = FFEINFO_kindtypeNONE;
9881         }
9882       break;
9883     }
9884
9885   if (!ok)
9886     {
9887       ffebad_start (FFEBAD_ENTRY_CONFLICTS);
9888       ffest_ffebad_here_current_stmt (0);
9889       ffebad_finish ();
9890       return FALSE;             /* Can't handle entrypoint. */
9891     }
9892
9893   /* Entrypoint type compatible with previous types. */
9894
9895   ++ffecom_num_entrypoints_;
9896
9897   /* Master-arg-list = UNION(Master-arg-list,entry-arg-list). */
9898
9899   for (list = ffesymbol_dummyargs (entry);
9900        list != NULL;
9901        list = ffebld_trail (list))
9902     {
9903       arg = ffebld_head (list);
9904       if (ffebld_op (arg) != FFEBLD_opSYMTER)
9905         continue;               /* Alternate return or some such thing. */
9906       s = ffebld_symter (arg);
9907       for (plist = NULL, mlist = ffecom_master_arglist_;
9908            mlist != NULL;
9909            plist = mlist, mlist = ffebld_trail (mlist))
9910         {                       /* plist points to previous item for easy
9911                                    appending of arg. */
9912           if (ffebld_symter (ffebld_head (mlist)) == s)
9913             break;              /* Already have this arg in the master list. */
9914         }
9915       if (mlist != NULL)
9916         continue;               /* Already have this arg in the master list. */
9917
9918       /* Append this arg to the master list. */
9919
9920       item = ffebld_new_item (arg, NULL);
9921       if (plist == NULL)
9922         ffecom_master_arglist_ = item;
9923       else
9924         ffebld_set_trail (plist, item);
9925     }
9926
9927   return TRUE;
9928 }
9929
9930 /* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint
9931
9932    ffesymbol s;  // the ENTRY point itself
9933    ffecom_2pass_do_entrypoint(s);
9934
9935    Does whatever compiler needs to do to make the entrypoint actually
9936    happen.  Must be called for each entrypoint after
9937    ffecom_finish_progunit is called.  */
9938
9939 void
9940 ffecom_2pass_do_entrypoint (ffesymbol entry)
9941 {
9942   static int mfn_num = 0;
9943   static int ent_num;
9944
9945   if (mfn_num != ffecom_num_fns_)
9946     {                           /* First entrypoint for this program unit. */
9947       ent_num = 1;
9948       mfn_num = ffecom_num_fns_;
9949       ffecom_do_entry_ (ffecom_primary_entry_, 0);
9950     }
9951   else
9952     ++ent_num;
9953
9954   --ffecom_num_entrypoints_;
9955
9956   ffecom_do_entry_ (entry, ent_num);
9957 }
9958
9959 /* Essentially does a "fold (build (code, type, node1, node2))" while
9960    checking for certain housekeeping things.  Always sets
9961    TREE_SIDE_EFFECTS.  */
9962
9963 tree
9964 ffecom_2s (enum tree_code code, tree type, tree node1,
9965            tree node2)
9966 {
9967   tree item;
9968
9969   if ((node1 == error_mark_node)
9970       || (node2 == error_mark_node)
9971       || (type == error_mark_node))
9972     return error_mark_node;
9973
9974   item = build (code, type, node1, node2);
9975   TREE_SIDE_EFFECTS (item) = 1;
9976   return fold (item);
9977 }
9978
9979 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
9980    checking for certain housekeeping things.  */
9981
9982 tree
9983 ffecom_3 (enum tree_code code, tree type, tree node1,
9984           tree node2, tree node3)
9985 {
9986   tree item;
9987
9988   if ((node1 == error_mark_node)
9989       || (node2 == error_mark_node)
9990       || (node3 == error_mark_node)
9991       || (type == error_mark_node))
9992     return error_mark_node;
9993
9994   item = build (code, type, node1, node2, node3);
9995   if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2)
9996       || (node3 != NULL_TREE && TREE_SIDE_EFFECTS (node3)))
9997     TREE_SIDE_EFFECTS (item) = 1;
9998   return fold (item);
9999 }
10000
10001 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10002    checking for certain housekeeping things.  Always sets
10003    TREE_SIDE_EFFECTS.  */
10004
10005 tree
10006 ffecom_3s (enum tree_code code, tree type, tree node1,
10007            tree node2, tree node3)
10008 {
10009   tree item;
10010
10011   if ((node1 == error_mark_node)
10012       || (node2 == error_mark_node)
10013       || (node3 == error_mark_node)
10014       || (type == error_mark_node))
10015     return error_mark_node;
10016
10017   item = build (code, type, node1, node2, node3);
10018   TREE_SIDE_EFFECTS (item) = 1;
10019   return fold (item);
10020 }
10021
10022 /* ffecom_arg_expr -- Transform argument expr into gcc tree
10023
10024    See use by ffecom_list_expr.
10025
10026    If expression is NULL, returns an integer zero tree.  If it is not
10027    a CHARACTER expression, returns whatever ffecom_expr
10028    returns and sets the length return value to NULL_TREE.  Otherwise
10029    generates code to evaluate the character expression, returns the proper
10030    pointer to the result, but does NOT set the length return value to a tree
10031    that specifies the length of the result.  (In other words, the length
10032    variable is always set to NULL_TREE, because a length is never passed.)
10033
10034    21-Dec-91  JCB  1.1
10035       Don't set returned length, since nobody needs it (yet; someday if
10036       we allow CHARACTER*(*) dummies to statement functions, we'll need
10037       it).  */
10038
10039 tree
10040 ffecom_arg_expr (ffebld expr, tree *length)
10041 {
10042   tree ign;
10043
10044   *length = NULL_TREE;
10045
10046   if (expr == NULL)
10047     return integer_zero_node;
10048
10049   if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10050     return ffecom_expr (expr);
10051
10052   return ffecom_arg_ptr_to_expr (expr, &ign);
10053 }
10054
10055 /* Transform expression into constant argument-pointer-to-expression tree.
10056
10057    If the expression can be transformed into a argument-pointer-to-expression
10058    tree that is constant, that is done, and the tree returned.  Else
10059    NULL_TREE is returned.
10060
10061    That way, a caller can attempt to provide compile-time initialization
10062    of a variable and, if that fails, *then* choose to start a new block
10063    and resort to using temporaries, as appropriate.  */
10064
10065 tree
10066 ffecom_arg_ptr_to_const_expr (ffebld expr, tree *length)
10067 {
10068   if (! expr)
10069     return integer_zero_node;
10070
10071   if (ffebld_op (expr) == FFEBLD_opANY)
10072     {
10073       if (length)
10074         *length = error_mark_node;
10075       return error_mark_node;
10076     }
10077
10078   if (ffebld_arity (expr) == 0
10079       && (ffebld_op (expr) != FFEBLD_opSYMTER
10080           || ffebld_where (expr) == FFEINFO_whereCOMMON
10081           || ffebld_where (expr) == FFEINFO_whereGLOBAL
10082           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10083     {
10084       tree t;
10085
10086       t = ffecom_arg_ptr_to_expr (expr, length);
10087       assert (TREE_CONSTANT (t));
10088       assert (! length || TREE_CONSTANT (*length));
10089       return t;
10090     }
10091
10092   if (length
10093       && ffebld_size (expr) != FFETARGET_charactersizeNONE)
10094     *length = build_int_2 (ffebld_size (expr), 0);
10095   else if (length)
10096     *length = NULL_TREE;
10097   return NULL_TREE;
10098 }
10099
10100 /* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree
10101
10102    See use by ffecom_list_ptr_to_expr.
10103
10104    If expression is NULL, returns an integer zero tree.  If it is not
10105    a CHARACTER expression, returns whatever ffecom_ptr_to_expr
10106    returns and sets the length return value to NULL_TREE.  Otherwise
10107    generates code to evaluate the character expression, returns the proper
10108    pointer to the result, AND sets the length return value to a tree that
10109    specifies the length of the result.
10110
10111    If the length argument is NULL, this is a slightly special
10112    case of building a FORMAT expression, that is, an expression that
10113    will be used at run time without regard to length.  For the current
10114    implementation, which uses the libf2c library, this means it is nice
10115    to append a null byte to the end of the expression, where feasible,
10116    to make sure any diagnostic about the FORMAT string terminates at
10117    some useful point.
10118
10119    For now, treat %REF(char-expr) as the same as char-expr with a NULL
10120    length argument.  This might even be seen as a feature, if a null
10121    byte can always be appended.  */
10122
10123 tree
10124 ffecom_arg_ptr_to_expr (ffebld expr, tree *length)
10125 {
10126   tree item;
10127   tree ign_length;
10128   ffecomConcatList_ catlist;
10129
10130   if (length != NULL)
10131     *length = NULL_TREE;
10132
10133   if (expr == NULL)
10134     return integer_zero_node;
10135
10136   switch (ffebld_op (expr))
10137     {
10138     case FFEBLD_opPERCENT_VAL:
10139       if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10140         return ffecom_expr (ffebld_left (expr));
10141       {
10142         tree temp_exp;
10143         tree temp_length;
10144
10145         temp_exp = ffecom_arg_ptr_to_expr (ffebld_left (expr), &temp_length);
10146         if (temp_exp == error_mark_node)
10147           return error_mark_node;
10148
10149         return ffecom_1 (INDIRECT_REF, TREE_TYPE (TREE_TYPE (temp_exp)),
10150                          temp_exp);
10151       }
10152
10153     case FFEBLD_opPERCENT_REF:
10154       if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10155         return ffecom_ptr_to_expr (ffebld_left (expr));
10156       if (length != NULL)
10157         {
10158           ign_length = NULL_TREE;
10159           length = &ign_length;
10160         }
10161       expr = ffebld_left (expr);
10162       break;
10163
10164     case FFEBLD_opPERCENT_DESCR:
10165       switch (ffeinfo_basictype (ffebld_info (expr)))
10166         {
10167 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10168         case FFEINFO_basictypeHOLLERITH:
10169 #endif
10170         case FFEINFO_basictypeCHARACTER:
10171           break;                /* Passed by descriptor anyway. */
10172
10173         default:
10174           item = ffecom_ptr_to_expr (expr);
10175           if (item != error_mark_node)
10176             *length = TYPE_SIZE (TREE_TYPE (TREE_TYPE (item)));
10177           break;
10178         }
10179       break;
10180
10181     default:
10182       break;
10183     }
10184
10185 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10186   if ((ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeHOLLERITH)
10187       && (length != NULL))
10188     {                           /* Pass Hollerith by descriptor. */
10189       ffetargetHollerith h;
10190
10191       assert (ffebld_op (expr) == FFEBLD_opCONTER);
10192       h = ffebld_cu_val_hollerith (ffebld_constant_union
10193                                    (ffebld_conter (expr)));
10194       *length
10195         = build_int_2 (h.length, 0);
10196       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10197     }
10198 #endif
10199
10200   if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10201     return ffecom_ptr_to_expr (expr);
10202
10203   assert (ffeinfo_kindtype (ffebld_info (expr))
10204           == FFEINFO_kindtypeCHARACTER1);
10205
10206   while (ffebld_op (expr) == FFEBLD_opPAREN)
10207     expr = ffebld_left (expr);
10208
10209   catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
10210   switch (ffecom_concat_list_count_ (catlist))
10211     {
10212     case 0:                     /* Shouldn't happen, but in case it does... */
10213       if (length != NULL)
10214         {
10215           *length = ffecom_f2c_ftnlen_zero_node;
10216           TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10217         }
10218       ffecom_concat_list_kill_ (catlist);
10219       return null_pointer_node;
10220
10221     case 1:                     /* The (fairly) easy case. */
10222       if (length == NULL)
10223         ffecom_char_args_with_null_ (&item, &ign_length,
10224                                      ffecom_concat_list_expr_ (catlist, 0));
10225       else
10226         ffecom_char_args_ (&item, length,
10227                            ffecom_concat_list_expr_ (catlist, 0));
10228       ffecom_concat_list_kill_ (catlist);
10229       assert (item != NULL_TREE);
10230       return item;
10231
10232     default:                    /* Must actually concatenate things. */
10233       break;
10234     }
10235
10236   {
10237     int count = ffecom_concat_list_count_ (catlist);
10238     int i;
10239     tree lengths;
10240     tree items;
10241     tree length_array;
10242     tree item_array;
10243     tree citem;
10244     tree clength;
10245     tree temporary;
10246     tree num;
10247     tree known_length;
10248     ffetargetCharacterSize sz;
10249
10250     sz = ffecom_concat_list_maxlen_ (catlist);
10251     /* ~~Kludge! */
10252     assert (sz != FFETARGET_charactersizeNONE);
10253
10254 #ifdef HOHO
10255     length_array
10256       = lengths
10257       = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
10258                              FFETARGET_charactersizeNONE, count, TRUE);
10259     item_array
10260       = items
10261       = ffecom_push_tempvar (ffecom_f2c_address_type_node,
10262                              FFETARGET_charactersizeNONE, count, TRUE);
10263     temporary = ffecom_push_tempvar (char_type_node,
10264                                      sz, -1, TRUE);
10265 #else
10266     {
10267       tree hook;
10268
10269       hook = ffebld_nonter_hook (expr);
10270       assert (hook);
10271       assert (TREE_CODE (hook) == TREE_VEC);
10272       assert (TREE_VEC_LENGTH (hook) == 3);
10273       length_array = lengths = TREE_VEC_ELT (hook, 0);
10274       item_array = items = TREE_VEC_ELT (hook, 1);
10275       temporary = TREE_VEC_ELT (hook, 2);
10276     }
10277 #endif
10278
10279     known_length = ffecom_f2c_ftnlen_zero_node;
10280
10281     for (i = 0; i < count; ++i)
10282       {
10283         if ((i == count)
10284             && (length == NULL))
10285           ffecom_char_args_with_null_ (&citem, &clength,
10286                                        ffecom_concat_list_expr_ (catlist, i));
10287         else
10288           ffecom_char_args_ (&citem, &clength,
10289                              ffecom_concat_list_expr_ (catlist, i));
10290         if ((citem == error_mark_node)
10291             || (clength == error_mark_node))
10292           {
10293             ffecom_concat_list_kill_ (catlist);
10294             *length = error_mark_node;
10295             return error_mark_node;
10296           }
10297
10298         items
10299           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
10300                       ffecom_modify (void_type_node,
10301                                      ffecom_2 (ARRAY_REF,
10302                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
10303                                                item_array,
10304                                                build_int_2 (i, 0)),
10305                                      citem),
10306                       items);
10307         clength = ffecom_save_tree (clength);
10308         if (length != NULL)
10309           known_length
10310             = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
10311                         known_length,
10312                         clength);
10313         lengths
10314           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
10315                       ffecom_modify (void_type_node,
10316                                      ffecom_2 (ARRAY_REF,
10317                    TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
10318                                                length_array,
10319                                                build_int_2 (i, 0)),
10320                                      clength),
10321                       lengths);
10322       }
10323
10324     temporary = ffecom_1 (ADDR_EXPR,
10325                           build_pointer_type (TREE_TYPE (temporary)),
10326                           temporary);
10327
10328     item = build_tree_list (NULL_TREE, temporary);
10329     TREE_CHAIN (item)
10330       = build_tree_list (NULL_TREE,
10331                          ffecom_1 (ADDR_EXPR,
10332                                    build_pointer_type (TREE_TYPE (items)),
10333                                    items));
10334     TREE_CHAIN (TREE_CHAIN (item))
10335       = build_tree_list (NULL_TREE,
10336                          ffecom_1 (ADDR_EXPR,
10337                                    build_pointer_type (TREE_TYPE (lengths)),
10338                                    lengths));
10339     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
10340       = build_tree_list
10341         (NULL_TREE,
10342          ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
10343                    convert (ffecom_f2c_ftnlen_type_node,
10344                             build_int_2 (count, 0))));
10345     num = build_int_2 (sz, 0);
10346     TREE_TYPE (num) = ffecom_f2c_ftnlen_type_node;
10347     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item))))
10348       = build_tree_list (NULL_TREE, num);
10349
10350     item = ffecom_call_gfrt (FFECOM_gfrtCAT, item, NULL_TREE);
10351     TREE_SIDE_EFFECTS (item) = 1;
10352     item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (temporary),
10353                      item,
10354                      temporary);
10355
10356     if (length != NULL)
10357       *length = known_length;
10358   }
10359
10360   ffecom_concat_list_kill_ (catlist);
10361   assert (item != NULL_TREE);
10362   return item;
10363 }
10364
10365 /* Generate call to run-time function.
10366
10367    The first arg is the GNU Fortran Run-Time function index, the second
10368    arg is the list of arguments to pass to it.  Returned is the expression
10369    (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the
10370    result (which may be void).  */
10371
10372 tree
10373 ffecom_call_gfrt (ffecomGfrt ix, tree args, tree hook)
10374 {
10375   return ffecom_call_ (ffecom_gfrt_tree_ (ix),
10376                        ffecom_gfrt_kindtype (ix),
10377                        ffe_is_f2c_library () && ffecom_gfrt_complex_[ix],
10378                        NULL_TREE, args, NULL_TREE, NULL,
10379                        NULL, NULL_TREE, TRUE, hook);
10380 }
10381
10382 /* Transform constant-union to tree.  */
10383
10384 tree
10385 ffecom_constantunion (ffebldConstantUnion *cu, ffeinfoBasictype bt,
10386                       ffeinfoKindtype kt, tree tree_type)
10387 {
10388   tree item;
10389
10390   switch (bt)
10391     {
10392     case FFEINFO_basictypeINTEGER:
10393       {
10394         int val;
10395
10396         switch (kt)
10397           {
10398 #if FFETARGET_okINTEGER1
10399           case FFEINFO_kindtypeINTEGER1:
10400             val = ffebld_cu_val_integer1 (*cu);
10401             break;
10402 #endif
10403
10404 #if FFETARGET_okINTEGER2
10405           case FFEINFO_kindtypeINTEGER2:
10406             val = ffebld_cu_val_integer2 (*cu);
10407             break;
10408 #endif
10409
10410 #if FFETARGET_okINTEGER3
10411           case FFEINFO_kindtypeINTEGER3:
10412             val = ffebld_cu_val_integer3 (*cu);
10413             break;
10414 #endif
10415
10416 #if FFETARGET_okINTEGER4
10417           case FFEINFO_kindtypeINTEGER4:
10418             val = ffebld_cu_val_integer4 (*cu);
10419             break;
10420 #endif
10421
10422           default:
10423             assert ("bad INTEGER constant kind type" == NULL);
10424             /* Fall through. */
10425           case FFEINFO_kindtypeANY:
10426             return error_mark_node;
10427           }
10428         item = build_int_2 (val, (val < 0) ? -1 : 0);
10429         TREE_TYPE (item) = tree_type;
10430       }
10431       break;
10432
10433     case FFEINFO_basictypeLOGICAL:
10434       {
10435         int val;
10436
10437         switch (kt)
10438           {
10439 #if FFETARGET_okLOGICAL1
10440           case FFEINFO_kindtypeLOGICAL1:
10441             val = ffebld_cu_val_logical1 (*cu);
10442             break;
10443 #endif
10444
10445 #if FFETARGET_okLOGICAL2
10446           case FFEINFO_kindtypeLOGICAL2:
10447             val = ffebld_cu_val_logical2 (*cu);
10448             break;
10449 #endif
10450
10451 #if FFETARGET_okLOGICAL3
10452           case FFEINFO_kindtypeLOGICAL3:
10453             val = ffebld_cu_val_logical3 (*cu);
10454             break;
10455 #endif
10456
10457 #if FFETARGET_okLOGICAL4
10458           case FFEINFO_kindtypeLOGICAL4:
10459             val = ffebld_cu_val_logical4 (*cu);
10460             break;
10461 #endif
10462
10463           default:
10464             assert ("bad LOGICAL constant kind type" == NULL);
10465             /* Fall through. */
10466           case FFEINFO_kindtypeANY:
10467             return error_mark_node;
10468           }
10469         item = build_int_2 (val, (val < 0) ? -1 : 0);
10470         TREE_TYPE (item) = tree_type;
10471       }
10472       break;
10473
10474     case FFEINFO_basictypeREAL:
10475       {
10476         REAL_VALUE_TYPE val;
10477
10478         switch (kt)
10479           {
10480 #if FFETARGET_okREAL1
10481           case FFEINFO_kindtypeREAL1:
10482             val = ffetarget_value_real1 (ffebld_cu_val_real1 (*cu));
10483             break;
10484 #endif
10485
10486 #if FFETARGET_okREAL2
10487           case FFEINFO_kindtypeREAL2:
10488             val = ffetarget_value_real2 (ffebld_cu_val_real2 (*cu));
10489             break;
10490 #endif
10491
10492 #if FFETARGET_okREAL3
10493           case FFEINFO_kindtypeREAL3:
10494             val = ffetarget_value_real3 (ffebld_cu_val_real3 (*cu));
10495             break;
10496 #endif
10497
10498 #if FFETARGET_okREAL4
10499           case FFEINFO_kindtypeREAL4:
10500             val = ffetarget_value_real4 (ffebld_cu_val_real4 (*cu));
10501             break;
10502 #endif
10503
10504           default:
10505             assert ("bad REAL constant kind type" == NULL);
10506             /* Fall through. */
10507           case FFEINFO_kindtypeANY:
10508             return error_mark_node;
10509           }
10510         item = build_real (tree_type, val);
10511       }
10512       break;
10513
10514     case FFEINFO_basictypeCOMPLEX:
10515       {
10516         REAL_VALUE_TYPE real;
10517         REAL_VALUE_TYPE imag;
10518         tree el_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
10519
10520         switch (kt)
10521           {
10522 #if FFETARGET_okCOMPLEX1
10523           case FFEINFO_kindtypeREAL1:
10524             real = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).real);
10525             imag = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).imaginary);
10526             break;
10527 #endif
10528
10529 #if FFETARGET_okCOMPLEX2
10530           case FFEINFO_kindtypeREAL2:
10531             real = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).real);
10532             imag = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).imaginary);
10533             break;
10534 #endif
10535
10536 #if FFETARGET_okCOMPLEX3
10537           case FFEINFO_kindtypeREAL3:
10538             real = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).real);
10539             imag = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).imaginary);
10540             break;
10541 #endif
10542
10543 #if FFETARGET_okCOMPLEX4
10544           case FFEINFO_kindtypeREAL4:
10545             real = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).real);
10546             imag = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).imaginary);
10547             break;
10548 #endif
10549
10550           default:
10551             assert ("bad REAL constant kind type" == NULL);
10552             /* Fall through. */
10553           case FFEINFO_kindtypeANY:
10554             return error_mark_node;
10555           }
10556         item = ffecom_build_complex_constant_ (tree_type,
10557                                                build_real (el_type, real),
10558                                                build_real (el_type, imag));
10559       }
10560       break;
10561
10562     case FFEINFO_basictypeCHARACTER:
10563       {                         /* Happens only in DATA and similar contexts. */
10564         ffetargetCharacter1 val;
10565
10566         switch (kt)
10567           {
10568 #if FFETARGET_okCHARACTER1
10569           case FFEINFO_kindtypeLOGICAL1:
10570             val = ffebld_cu_val_character1 (*cu);
10571             break;
10572 #endif
10573
10574           default:
10575             assert ("bad CHARACTER constant kind type" == NULL);
10576             /* Fall through. */
10577           case FFEINFO_kindtypeANY:
10578             return error_mark_node;
10579           }
10580         item = build_string (ffetarget_length_character1 (val),
10581                              ffetarget_text_character1 (val));
10582         TREE_TYPE (item)
10583           = build_type_variant (build_array_type (char_type_node,
10584                                                   build_range_type
10585                                                   (integer_type_node,
10586                                                    integer_one_node,
10587                                                    build_int_2
10588                                                 (ffetarget_length_character1
10589                                                  (val), 0))),
10590                                 1, 0);
10591       }
10592       break;
10593
10594     case FFEINFO_basictypeHOLLERITH:
10595       {
10596         ffetargetHollerith h;
10597
10598         h = ffebld_cu_val_hollerith (*cu);
10599
10600         /* If not at least as wide as default INTEGER, widen it.  */
10601         if (h.length >= FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE)
10602           item = build_string (h.length, h.text);
10603         else
10604           {
10605             char str[FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE];
10606
10607             memcpy (str, h.text, h.length);
10608             memset (&str[h.length], ' ',
10609                     FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE
10610                     - h.length);
10611             item = build_string (FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE,
10612                                  str);
10613           }
10614         TREE_TYPE (item)
10615           = build_type_variant (build_array_type (char_type_node,
10616                                                   build_range_type
10617                                                   (integer_type_node,
10618                                                    integer_one_node,
10619                                                    build_int_2
10620                                                    (h.length, 0))),
10621                                 1, 0);
10622       }
10623       break;
10624
10625     case FFEINFO_basictypeTYPELESS:
10626       {
10627         ffetargetInteger1 ival;
10628         ffetargetTypeless tless;
10629         ffebad error;
10630
10631         tless = ffebld_cu_val_typeless (*cu);
10632         error = ffetarget_convert_integer1_typeless (&ival, tless);
10633         assert (error == FFEBAD);
10634
10635         item = build_int_2 ((int) ival, 0);
10636       }
10637       break;
10638
10639     default:
10640       assert ("not yet on constant type" == NULL);
10641       /* Fall through. */
10642     case FFEINFO_basictypeANY:
10643       return error_mark_node;
10644     }
10645
10646   TREE_CONSTANT (item) = 1;
10647
10648   return item;
10649 }
10650
10651 /* Transform expression into constant tree.
10652
10653    If the expression can be transformed into a tree that is constant,
10654    that is done, and the tree returned.  Else NULL_TREE is returned.
10655
10656    That way, a caller can attempt to provide compile-time initialization
10657    of a variable and, if that fails, *then* choose to start a new block
10658    and resort to using temporaries, as appropriate.  */
10659
10660 tree
10661 ffecom_const_expr (ffebld expr)
10662 {
10663   if (! expr)
10664     return integer_zero_node;
10665
10666   if (ffebld_op (expr) == FFEBLD_opANY)
10667     return error_mark_node;
10668
10669   if (ffebld_arity (expr) == 0
10670       && (ffebld_op (expr) != FFEBLD_opSYMTER
10671 #if NEWCOMMON
10672           /* ~~Enable once common/equivalence is handled properly?  */
10673           || ffebld_where (expr) == FFEINFO_whereCOMMON
10674 #endif
10675           || ffebld_where (expr) == FFEINFO_whereGLOBAL
10676           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10677     {
10678       tree t;
10679
10680       t = ffecom_expr (expr);
10681       assert (TREE_CONSTANT (t));
10682       return t;
10683     }
10684
10685   return NULL_TREE;
10686 }
10687
10688 /* Handy way to make a field in a struct/union.  */
10689
10690 tree
10691 ffecom_decl_field (tree context, tree prevfield,
10692                    const char *name, tree type)
10693 {
10694   tree field;
10695
10696   field = build_decl (FIELD_DECL, get_identifier (name), type);
10697   DECL_CONTEXT (field) = context;
10698   DECL_ALIGN (field) = 0;
10699   DECL_USER_ALIGN (field) = 0;
10700   if (prevfield != NULL_TREE)
10701     TREE_CHAIN (prevfield) = field;
10702
10703   return field;
10704 }
10705
10706 void
10707 ffecom_close_include (FILE *f)
10708 {
10709   ffecom_close_include_ (f);
10710 }
10711
10712 int
10713 ffecom_decode_include_option (char *spec)
10714 {
10715   return ffecom_decode_include_option_ (spec);
10716 }
10717
10718 /* End a compound statement (block).  */
10719
10720 tree
10721 ffecom_end_compstmt (void)
10722 {
10723   return bison_rule_compstmt_ ();
10724 }
10725
10726 /* ffecom_end_transition -- Perform end transition on all symbols
10727
10728    ffecom_end_transition();
10729
10730    Calls ffecom_sym_end_transition for each global and local symbol.  */
10731
10732 void
10733 ffecom_end_transition ()
10734 {
10735   ffebld item;
10736
10737   if (ffe_is_ffedebug ())
10738     fprintf (dmpout, "; end_stmt_transition\n");
10739
10740   ffecom_list_blockdata_ = NULL;
10741   ffecom_list_common_ = NULL;
10742
10743   ffesymbol_drive (ffecom_sym_end_transition);
10744   if (ffe_is_ffedebug ())
10745     {
10746       ffestorag_report ();
10747     }
10748
10749   ffecom_start_progunit_ ();
10750
10751   for (item = ffecom_list_blockdata_;
10752        item != NULL;
10753        item = ffebld_trail (item))
10754     {
10755       ffebld callee;
10756       ffesymbol s;
10757       tree dt;
10758       tree t;
10759       tree var;
10760       static int number = 0;
10761
10762       callee = ffebld_head (item);
10763       s = ffebld_symter (callee);
10764       t = ffesymbol_hook (s).decl_tree;
10765       if (t == NULL_TREE)
10766         {
10767           s = ffecom_sym_transform_ (s);
10768           t = ffesymbol_hook (s).decl_tree;
10769         }
10770
10771       dt = build_pointer_type (TREE_TYPE (t));
10772
10773       var = build_decl (VAR_DECL,
10774                         ffecom_get_invented_identifier ("__g77_forceload_%d",
10775                                                         number++),
10776                         dt);
10777       DECL_EXTERNAL (var) = 0;
10778       TREE_STATIC (var) = 1;
10779       TREE_PUBLIC (var) = 0;
10780       DECL_INITIAL (var) = error_mark_node;
10781       TREE_USED (var) = 1;
10782
10783       var = start_decl (var, FALSE);
10784
10785       t = ffecom_1 (ADDR_EXPR, dt, t);
10786
10787       finish_decl (var, t, FALSE);
10788     }
10789
10790   /* This handles any COMMON areas that weren't referenced but have, for
10791      example, important initial data.  */
10792
10793   for (item = ffecom_list_common_;
10794        item != NULL;
10795        item = ffebld_trail (item))
10796     ffecom_transform_common_ (ffebld_symter (ffebld_head (item)));
10797
10798   ffecom_list_common_ = NULL;
10799 }
10800
10801 /* ffecom_exec_transition -- Perform exec transition on all symbols
10802
10803    ffecom_exec_transition();
10804
10805    Calls ffecom_sym_exec_transition for each global and local symbol.
10806    Make sure error updating not inhibited.  */
10807
10808 void
10809 ffecom_exec_transition ()
10810 {
10811   bool inhibited;
10812
10813   if (ffe_is_ffedebug ())
10814     fprintf (dmpout, "; exec_stmt_transition\n");
10815
10816   inhibited = ffebad_inhibit ();
10817   ffebad_set_inhibit (FALSE);
10818
10819   ffesymbol_drive (ffecom_sym_exec_transition); /* Don't retract! */
10820   ffeequiv_exec_transition ();  /* Handle all pending EQUIVALENCEs. */
10821   if (ffe_is_ffedebug ())
10822     {
10823       ffestorag_report ();
10824     }
10825
10826   if (inhibited)
10827     ffebad_set_inhibit (TRUE);
10828 }
10829
10830 /* Handle assignment statement.
10831
10832    Convert dest and source using ffecom_expr, then join them
10833    with an ASSIGN op and pass the whole thing to expand_expr_stmt.  */
10834
10835 void
10836 ffecom_expand_let_stmt (ffebld dest, ffebld source)
10837 {
10838   tree dest_tree;
10839   tree dest_length;
10840   tree source_tree;
10841   tree expr_tree;
10842
10843   if (ffeinfo_basictype (ffebld_info (dest)) != FFEINFO_basictypeCHARACTER)
10844     {
10845       bool dest_used;
10846       tree assign_temp;
10847
10848       /* This attempts to replicate the test below, but must not be
10849          true when the test below is false.  (Always err on the side
10850          of creating unused temporaries, to avoid ICEs.)  */
10851       if (ffebld_op (dest) != FFEBLD_opSYMTER
10852           || ((dest_tree = ffesymbol_hook (ffebld_symter (dest)).decl_tree)
10853               && (TREE_CODE (dest_tree) != VAR_DECL
10854                   || TREE_ADDRESSABLE (dest_tree))))
10855         {
10856           ffecom_prepare_expr_ (source, dest);
10857           dest_used = TRUE;
10858         }
10859       else
10860         {
10861           ffecom_prepare_expr_ (source, NULL);
10862           dest_used = FALSE;
10863         }
10864
10865       ffecom_prepare_expr_w (NULL_TREE, dest);
10866
10867       /* For COMPLEX assignment like C1=C2, if partial overlap is possible,
10868          create a temporary through which the assignment is to take place,
10869          since MODIFY_EXPR doesn't handle partial overlap properly.  */
10870       if (ffebld_basictype (dest) == FFEINFO_basictypeCOMPLEX
10871           && ffecom_possible_partial_overlap_ (dest, source))
10872         {
10873           assign_temp = ffecom_make_tempvar ("complex_let",
10874                                              ffecom_tree_type
10875                                              [ffebld_basictype (dest)]
10876                                              [ffebld_kindtype (dest)],
10877                                              FFETARGET_charactersizeNONE,
10878                                              -1);
10879         }
10880       else
10881         assign_temp = NULL_TREE;
10882
10883       ffecom_prepare_end ();
10884
10885       dest_tree = ffecom_expr_w (NULL_TREE, dest);
10886       if (dest_tree == error_mark_node)
10887         return;
10888
10889       if ((TREE_CODE (dest_tree) != VAR_DECL)
10890           || TREE_ADDRESSABLE (dest_tree))
10891         source_tree = ffecom_expr_ (source, dest_tree, dest, &dest_used,
10892                                     FALSE, FALSE);
10893       else
10894         {
10895           assert (! dest_used);
10896           dest_used = FALSE;
10897           source_tree = ffecom_expr (source);
10898         }
10899       if (source_tree == error_mark_node)
10900         return;
10901
10902       if (dest_used)
10903         expr_tree = source_tree;
10904       else if (assign_temp)
10905         {
10906 #ifdef MOVE_EXPR
10907           /* The back end understands a conceptual move (evaluate source;
10908              store into dest), so use that, in case it can determine
10909              that it is going to use, say, two registers as temporaries
10910              anyway.  So don't use the temp (and someday avoid generating
10911              it, once this code starts triggering regularly).  */
10912           expr_tree = ffecom_2s (MOVE_EXPR, void_type_node,
10913                                  dest_tree,
10914                                  source_tree);
10915 #else
10916           expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
10917                                  assign_temp,
10918                                  source_tree);
10919           expand_expr_stmt (expr_tree);
10920           expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
10921                                  dest_tree,
10922                                  assign_temp);
10923 #endif
10924         }
10925       else
10926         expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
10927                                dest_tree,
10928                                source_tree);
10929
10930       expand_expr_stmt (expr_tree);
10931       return;
10932     }
10933
10934   ffecom_prepare_let_char_ (ffebld_size_known (dest), source);
10935   ffecom_prepare_expr_w (NULL_TREE, dest);
10936
10937   ffecom_prepare_end ();
10938
10939   ffecom_char_args_ (&dest_tree, &dest_length, dest);
10940   ffecom_let_char_ (dest_tree, dest_length, ffebld_size_known (dest),
10941                     source);
10942 }
10943
10944 /* ffecom_expr -- Transform expr into gcc tree
10945
10946    tree t;
10947    ffebld expr;  // FFE expression.
10948    tree = ffecom_expr(expr);
10949
10950    Recursive descent on expr while making corresponding tree nodes and
10951    attaching type info and such.  */
10952
10953 tree
10954 ffecom_expr (ffebld expr)
10955 {
10956   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, FALSE, FALSE);
10957 }
10958
10959 /* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT.  */
10960
10961 tree
10962 ffecom_expr_assign (ffebld expr)
10963 {
10964   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
10965 }
10966
10967 /* Like ffecom_expr_rw, but return tree usable for ASSIGN.  */
10968
10969 tree
10970 ffecom_expr_assign_w (ffebld expr)
10971 {
10972   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
10973 }
10974
10975 /* Transform expr for use as into read/write tree and stabilize the
10976    reference.  Not for use on CHARACTER expressions.
10977
10978    Recursive descent on expr while making corresponding tree nodes and
10979    attaching type info and such.  */
10980
10981 tree
10982 ffecom_expr_rw (tree type, ffebld expr)
10983 {
10984   assert (expr != NULL);
10985   /* Different target types not yet supported.  */
10986   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
10987
10988   return stabilize_reference (ffecom_expr (expr));
10989 }
10990
10991 /* Transform expr for use as into write tree and stabilize the
10992    reference.  Not for use on CHARACTER expressions.
10993
10994    Recursive descent on expr while making corresponding tree nodes and
10995    attaching type info and such.  */
10996
10997 tree
10998 ffecom_expr_w (tree type, ffebld expr)
10999 {
11000   assert (expr != NULL);
11001   /* Different target types not yet supported.  */
11002   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
11003
11004   return stabilize_reference (ffecom_expr (expr));
11005 }
11006
11007 /* Do global stuff.  */
11008
11009 void
11010 ffecom_finish_compile ()
11011 {
11012   assert (ffecom_outer_function_decl_ == NULL_TREE);
11013   assert (current_function_decl == NULL_TREE);
11014
11015   ffeglobal_drive (ffecom_finish_global_);
11016 }
11017
11018 /* Public entry point for front end to access finish_decl.  */
11019
11020 void
11021 ffecom_finish_decl (tree decl, tree init, bool is_top_level)
11022 {
11023   assert (!is_top_level);
11024   finish_decl (decl, init, FALSE);
11025 }
11026
11027 /* Finish a program unit.  */
11028
11029 void
11030 ffecom_finish_progunit ()
11031 {
11032   ffecom_end_compstmt ();
11033
11034   ffecom_previous_function_decl_ = current_function_decl;
11035   ffecom_which_entrypoint_decl_ = NULL_TREE;
11036
11037   finish_function (0);
11038 }
11039
11040 /* Wrapper for get_identifier.  pattern is sprintf-like.  */
11041
11042 tree
11043 ffecom_get_invented_identifier (const char *pattern, ...)
11044 {
11045   tree decl;
11046   char *nam;
11047   va_list ap;
11048
11049   va_start (ap, pattern);
11050   if (vasprintf (&nam, pattern, ap) == 0)
11051     abort ();
11052   va_end (ap);
11053   decl = get_identifier (nam);
11054   free (nam);
11055   IDENTIFIER_INVENTED (decl) = 1;
11056   return decl;
11057 }
11058
11059 ffeinfoBasictype
11060 ffecom_gfrt_basictype (ffecomGfrt gfrt)
11061 {
11062   assert (gfrt < FFECOM_gfrt);
11063
11064   switch (ffecom_gfrt_type_[gfrt])
11065     {
11066     case FFECOM_rttypeVOID_:
11067     case FFECOM_rttypeVOIDSTAR_:
11068       return FFEINFO_basictypeNONE;
11069
11070     case FFECOM_rttypeFTNINT_:
11071       return FFEINFO_basictypeINTEGER;
11072
11073     case FFECOM_rttypeINTEGER_:
11074       return FFEINFO_basictypeINTEGER;
11075
11076     case FFECOM_rttypeLONGINT_:
11077       return FFEINFO_basictypeINTEGER;
11078
11079     case FFECOM_rttypeLOGICAL_:
11080       return FFEINFO_basictypeLOGICAL;
11081
11082     case FFECOM_rttypeREAL_F2C_:
11083     case FFECOM_rttypeREAL_GNU_:
11084       return FFEINFO_basictypeREAL;
11085
11086     case FFECOM_rttypeCOMPLEX_F2C_:
11087     case FFECOM_rttypeCOMPLEX_GNU_:
11088       return FFEINFO_basictypeCOMPLEX;
11089
11090     case FFECOM_rttypeDOUBLE_:
11091     case FFECOM_rttypeDOUBLEREAL_:
11092       return FFEINFO_basictypeREAL;
11093
11094     case FFECOM_rttypeDBLCMPLX_F2C_:
11095     case FFECOM_rttypeDBLCMPLX_GNU_:
11096       return FFEINFO_basictypeCOMPLEX;
11097
11098     case FFECOM_rttypeCHARACTER_:
11099       return FFEINFO_basictypeCHARACTER;
11100
11101     default:
11102       return FFEINFO_basictypeANY;
11103     }
11104 }
11105
11106 ffeinfoKindtype
11107 ffecom_gfrt_kindtype (ffecomGfrt gfrt)
11108 {
11109   assert (gfrt < FFECOM_gfrt);
11110
11111   switch (ffecom_gfrt_type_[gfrt])
11112     {
11113     case FFECOM_rttypeVOID_:
11114     case FFECOM_rttypeVOIDSTAR_:
11115       return FFEINFO_kindtypeNONE;
11116
11117     case FFECOM_rttypeFTNINT_:
11118       return FFEINFO_kindtypeINTEGER1;
11119
11120     case FFECOM_rttypeINTEGER_:
11121       return FFEINFO_kindtypeINTEGER1;
11122
11123     case FFECOM_rttypeLONGINT_:
11124       return FFEINFO_kindtypeINTEGER4;
11125
11126     case FFECOM_rttypeLOGICAL_:
11127       return FFEINFO_kindtypeLOGICAL1;
11128
11129     case FFECOM_rttypeREAL_F2C_:
11130     case FFECOM_rttypeREAL_GNU_:
11131       return FFEINFO_kindtypeREAL1;
11132
11133     case FFECOM_rttypeCOMPLEX_F2C_:
11134     case FFECOM_rttypeCOMPLEX_GNU_:
11135       return FFEINFO_kindtypeREAL1;
11136
11137     case FFECOM_rttypeDOUBLE_:
11138     case FFECOM_rttypeDOUBLEREAL_:
11139       return FFEINFO_kindtypeREAL2;
11140
11141     case FFECOM_rttypeDBLCMPLX_F2C_:
11142     case FFECOM_rttypeDBLCMPLX_GNU_:
11143       return FFEINFO_kindtypeREAL2;
11144
11145     case FFECOM_rttypeCHARACTER_:
11146       return FFEINFO_kindtypeCHARACTER1;
11147
11148     default:
11149       return FFEINFO_kindtypeANY;
11150     }
11151 }
11152
11153 void
11154 ffecom_init_0 ()
11155 {
11156   tree endlink;
11157   int i;
11158   int j;
11159   tree t;
11160   tree field;
11161   ffetype type;
11162   ffetype base_type;
11163   tree double_ftype_double;
11164   tree float_ftype_float;
11165   tree ldouble_ftype_ldouble;
11166   tree ffecom_tree_ptr_to_fun_type_void;
11167
11168   /* This block of code comes from the now-obsolete cktyps.c.  It checks
11169      whether the compiler environment is buggy in known ways, some of which
11170      would, if not explicitly checked here, result in subtle bugs in g77.  */
11171
11172   if (ffe_is_do_internal_checks ())
11173     {
11174       static const char names[][12]
11175         =
11176       {"bar", "bletch", "foo", "foobar"};
11177       const char *name;
11178       unsigned long ul;
11179       double fl;
11180
11181       name = bsearch ("foo", &names[0], ARRAY_SIZE (names), sizeof (names[0]),
11182                       (int (*)(const void *, const void *)) strcmp);
11183       if (name != &names[0][2])
11184         {
11185           assert ("bsearch doesn't work, #define FFEPROJ_BSEARCH 0 in proj.h"
11186                   == NULL);
11187           abort ();
11188         }
11189
11190       ul = strtoul ("123456789", NULL, 10);
11191       if (ul != 123456789L)
11192         {
11193           assert ("strtoul doesn't have enough range, #define FFEPROJ_STRTOUL 0\
11194  in proj.h" == NULL);
11195           abort ();
11196         }
11197
11198       fl = atof ("56.789");
11199       if ((fl < 56.788) || (fl > 56.79))
11200         {
11201           assert ("atof not type double, fix your #include <stdio.h>"
11202                   == NULL);
11203           abort ();
11204         }
11205     }
11206
11207   ffecom_outer_function_decl_ = NULL_TREE;
11208   current_function_decl = NULL_TREE;
11209   named_labels = NULL_TREE;
11210   current_binding_level = NULL_BINDING_LEVEL;
11211   free_binding_level = NULL_BINDING_LEVEL;
11212   /* Make the binding_level structure for global names.  */
11213   pushlevel (0);
11214   global_binding_level = current_binding_level;
11215   current_binding_level->prep_state = 2;
11216
11217   build_common_tree_nodes (1);
11218
11219   /* Define `int' and `char' first so that dbx will output them first.  */
11220   pushdecl (build_decl (TYPE_DECL, get_identifier ("int"),
11221                         integer_type_node));
11222   /* CHARACTER*1 is unsigned in ICHAR contexts.  */
11223   char_type_node = make_unsigned_type (CHAR_TYPE_SIZE);
11224   pushdecl (build_decl (TYPE_DECL, get_identifier ("char"),
11225                         char_type_node));
11226   pushdecl (build_decl (TYPE_DECL, get_identifier ("long int"),
11227                         long_integer_type_node));
11228   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned int"),
11229                         unsigned_type_node));
11230   pushdecl (build_decl (TYPE_DECL, get_identifier ("long unsigned int"),
11231                         long_unsigned_type_node));
11232   pushdecl (build_decl (TYPE_DECL, get_identifier ("long long int"),
11233                         long_long_integer_type_node));
11234   pushdecl (build_decl (TYPE_DECL, get_identifier ("long long unsigned int"),
11235                         long_long_unsigned_type_node));
11236   pushdecl (build_decl (TYPE_DECL, get_identifier ("short int"),
11237                         short_integer_type_node));
11238   pushdecl (build_decl (TYPE_DECL, get_identifier ("short unsigned int"),
11239                         short_unsigned_type_node));
11240
11241   /* Set the sizetype before we make other types.  This *should* be the
11242      first type we create.  */
11243
11244   set_sizetype
11245     (TREE_TYPE (IDENTIFIER_GLOBAL_VALUE (get_identifier (SIZE_TYPE))));
11246   ffecom_typesize_pointer_
11247     = TREE_INT_CST_LOW (TYPE_SIZE (sizetype)) / BITS_PER_UNIT;
11248
11249   build_common_tree_nodes_2 (0);
11250
11251   /* Define both `signed char' and `unsigned char'.  */
11252   pushdecl (build_decl (TYPE_DECL, get_identifier ("signed char"),
11253                         signed_char_type_node));
11254
11255   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned char"),
11256                         unsigned_char_type_node));
11257
11258   pushdecl (build_decl (TYPE_DECL, get_identifier ("float"),
11259                         float_type_node));
11260   pushdecl (build_decl (TYPE_DECL, get_identifier ("double"),
11261                         double_type_node));
11262   pushdecl (build_decl (TYPE_DECL, get_identifier ("long double"),
11263                         long_double_type_node));
11264
11265   /* For now, override what build_common_tree_nodes has done.  */
11266   complex_integer_type_node = ffecom_make_complex_type_ (integer_type_node);
11267   complex_float_type_node = ffecom_make_complex_type_ (float_type_node);
11268   complex_double_type_node = ffecom_make_complex_type_ (double_type_node);
11269   complex_long_double_type_node
11270     = ffecom_make_complex_type_ (long_double_type_node);
11271
11272   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex int"),
11273                         complex_integer_type_node));
11274   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex float"),
11275                         complex_float_type_node));
11276   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex double"),
11277                         complex_double_type_node));
11278   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex long double"),
11279                         complex_long_double_type_node));
11280
11281   pushdecl (build_decl (TYPE_DECL, get_identifier ("void"),
11282                         void_type_node));
11283   /* We are not going to have real types in C with less than byte alignment,
11284      so we might as well not have any types that claim to have it.  */
11285   TYPE_ALIGN (void_type_node) = BITS_PER_UNIT;
11286   TYPE_USER_ALIGN (void_type_node) = 0;
11287
11288   string_type_node = build_pointer_type (char_type_node);
11289
11290   ffecom_tree_fun_type_void
11291     = build_function_type (void_type_node, NULL_TREE);
11292
11293   ffecom_tree_ptr_to_fun_type_void
11294     = build_pointer_type (ffecom_tree_fun_type_void);
11295
11296   endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE);
11297
11298   float_ftype_float
11299     = build_function_type (float_type_node,
11300                            tree_cons (NULL_TREE, float_type_node, endlink));
11301
11302   double_ftype_double
11303     = build_function_type (double_type_node,
11304                            tree_cons (NULL_TREE, double_type_node, endlink));
11305
11306   ldouble_ftype_ldouble
11307     = build_function_type (long_double_type_node,
11308                            tree_cons (NULL_TREE, long_double_type_node,
11309                                       endlink));
11310
11311   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11312     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11313       {
11314         ffecom_tree_type[i][j] = NULL_TREE;
11315         ffecom_tree_fun_type[i][j] = NULL_TREE;
11316         ffecom_tree_ptr_to_fun_type[i][j] = NULL_TREE;
11317         ffecom_f2c_typecode_[i][j] = -1;
11318       }
11319
11320   /* Set up standard g77 types.  Note that INTEGER and LOGICAL are set
11321      to size FLOAT_TYPE_SIZE because they have to be the same size as
11322      REAL, which also is FLOAT_TYPE_SIZE, according to the standard.
11323      Compiler options and other such stuff that change the ways these
11324      types are set should not affect this particular setup.  */
11325
11326   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1]
11327     = t = make_signed_type (FLOAT_TYPE_SIZE);
11328   pushdecl (build_decl (TYPE_DECL, get_identifier ("integer"),
11329                         t));
11330   type = ffetype_new ();
11331   base_type = type;
11332   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER1,
11333                     type);
11334   ffetype_set_ams (type,
11335                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11336                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11337   ffetype_set_star (base_type,
11338                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11339                     type);
11340   ffetype_set_kind (base_type, 1, type);
11341   ffecom_typesize_integer1_ = ffetype_size (type);
11342   assert (ffetype_size (type) == sizeof (ffetargetInteger1));
11343
11344   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER1]
11345     = t = make_unsigned_type (FLOAT_TYPE_SIZE); /* HOLLERITH means unsigned. */
11346   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned"),
11347                         t));
11348
11349   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER2]
11350     = t = make_signed_type (CHAR_TYPE_SIZE);
11351   pushdecl (build_decl (TYPE_DECL, get_identifier ("byte"),
11352                         t));
11353   type = ffetype_new ();
11354   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER2,
11355                     type);
11356   ffetype_set_ams (type,
11357                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11358                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11359   ffetype_set_star (base_type,
11360                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11361                     type);
11362   ffetype_set_kind (base_type, 3, type);
11363   assert (ffetype_size (type) == sizeof (ffetargetInteger2));
11364
11365   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER2]
11366     = t = make_unsigned_type (CHAR_TYPE_SIZE);
11367   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned byte"),
11368                         t));
11369
11370   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER3]
11371     = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11372   pushdecl (build_decl (TYPE_DECL, get_identifier ("word"),
11373                         t));
11374   type = ffetype_new ();
11375   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER3,
11376                     type);
11377   ffetype_set_ams (type,
11378                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11379                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11380   ffetype_set_star (base_type,
11381                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11382                     type);
11383   ffetype_set_kind (base_type, 6, type);
11384   assert (ffetype_size (type) == sizeof (ffetargetInteger3));
11385
11386   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER3]
11387     = t = make_unsigned_type (CHAR_TYPE_SIZE * 2);
11388   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned word"),
11389                         t));
11390
11391   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER4]
11392     = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11393   pushdecl (build_decl (TYPE_DECL, get_identifier ("integer4"),
11394                         t));
11395   type = ffetype_new ();
11396   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER4,
11397                     type);
11398   ffetype_set_ams (type,
11399                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11400                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11401   ffetype_set_star (base_type,
11402                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11403                     type);
11404   ffetype_set_kind (base_type, 2, type);
11405   assert (ffetype_size (type) == sizeof (ffetargetInteger4));
11406
11407   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER4]
11408     = t = make_unsigned_type (FLOAT_TYPE_SIZE * 2);
11409   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned4"),
11410                         t));
11411
11412 #if 0
11413   if (ffe_is_do_internal_checks ()
11414       && LONG_TYPE_SIZE != FLOAT_TYPE_SIZE
11415       && LONG_TYPE_SIZE != CHAR_TYPE_SIZE
11416       && LONG_TYPE_SIZE != SHORT_TYPE_SIZE
11417       && LONG_TYPE_SIZE != LONG_LONG_TYPE_SIZE)
11418     {
11419       fprintf (stderr, "Sorry, no g77 support for LONG_TYPE_SIZE (%d bits) yet.\n",
11420                LONG_TYPE_SIZE);
11421     }
11422 #endif
11423
11424   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL1]
11425     = t = make_signed_type (FLOAT_TYPE_SIZE);
11426   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical"),
11427                         t));
11428   type = ffetype_new ();
11429   base_type = type;
11430   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL1,
11431                     type);
11432   ffetype_set_ams (type,
11433                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11434                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11435   ffetype_set_star (base_type,
11436                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11437                     type);
11438   ffetype_set_kind (base_type, 1, type);
11439   assert (ffetype_size (type) == sizeof (ffetargetLogical1));
11440
11441   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL2]
11442     = t = make_signed_type (CHAR_TYPE_SIZE);
11443   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical2"),
11444                         t));
11445   type = ffetype_new ();
11446   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL2,
11447                     type);
11448   ffetype_set_ams (type,
11449                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11450                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11451   ffetype_set_star (base_type,
11452                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11453                     type);
11454   ffetype_set_kind (base_type, 3, type);
11455   assert (ffetype_size (type) == sizeof (ffetargetLogical2));
11456
11457   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL3]
11458     = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11459   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical3"),
11460                         t));
11461   type = ffetype_new ();
11462   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL3,
11463                     type);
11464   ffetype_set_ams (type,
11465                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11466                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11467   ffetype_set_star (base_type,
11468                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11469                     type);
11470   ffetype_set_kind (base_type, 6, type);
11471   assert (ffetype_size (type) == sizeof (ffetargetLogical3));
11472
11473   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL4]
11474     = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11475   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical4"),
11476                         t));
11477   type = ffetype_new ();
11478   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL4,
11479                     type);
11480   ffetype_set_ams (type,
11481                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11482                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11483   ffetype_set_star (base_type,
11484                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11485                     type);
11486   ffetype_set_kind (base_type, 2, type);
11487   assert (ffetype_size (type) == sizeof (ffetargetLogical4));
11488
11489   ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11490     = t = make_node (REAL_TYPE);
11491   TYPE_PRECISION (t) = FLOAT_TYPE_SIZE;
11492   pushdecl (build_decl (TYPE_DECL, get_identifier ("real"),
11493                         t));
11494   layout_type (t);
11495   type = ffetype_new ();
11496   base_type = type;
11497   ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL1,
11498                     type);
11499   ffetype_set_ams (type,
11500                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11501                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11502   ffetype_set_star (base_type,
11503                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11504                     type);
11505   ffetype_set_kind (base_type, 1, type);
11506   ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11507     = FFETARGET_f2cTYREAL;
11508   assert (ffetype_size (type) == sizeof (ffetargetReal1));
11509
11510   ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREALDOUBLE]
11511     = t = make_node (REAL_TYPE);
11512   TYPE_PRECISION (t) = FLOAT_TYPE_SIZE * 2;     /* Always twice REAL. */
11513   pushdecl (build_decl (TYPE_DECL, get_identifier ("double precision"),
11514                         t));
11515   layout_type (t);
11516   type = ffetype_new ();
11517   ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE,
11518                     type);
11519   ffetype_set_ams (type,
11520                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11521                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11522   ffetype_set_star (base_type,
11523                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11524                     type);
11525   ffetype_set_kind (base_type, 2, type);
11526   ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]
11527     = FFETARGET_f2cTYDREAL;
11528   assert (ffetype_size (type) == sizeof (ffetargetReal2));
11529
11530   ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11531     = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]);
11532   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex"),
11533                         t));
11534   type = ffetype_new ();
11535   base_type = type;
11536   ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL1,
11537                     type);
11538   ffetype_set_ams (type,
11539                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11540                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11541   ffetype_set_star (base_type,
11542                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11543                     type);
11544   ffetype_set_kind (base_type, 1, type);
11545   ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11546     = FFETARGET_f2cTYCOMPLEX;
11547   assert (ffetype_size (type) == sizeof (ffetargetComplex1));
11548
11549   ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREALDOUBLE]
11550     = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]);
11551   pushdecl (build_decl (TYPE_DECL, get_identifier ("double complex"),
11552                         t));
11553   type = ffetype_new ();
11554   ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREALDOUBLE,
11555                     type);
11556   ffetype_set_ams (type,
11557                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11558                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11559   ffetype_set_star (base_type,
11560                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11561                     type);
11562   ffetype_set_kind (base_type, 2,
11563                     type);
11564   ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL2]
11565     = FFETARGET_f2cTYDCOMPLEX;
11566   assert (ffetype_size (type) == sizeof (ffetargetComplex2));
11567
11568   /* Make function and ptr-to-function types for non-CHARACTER types. */
11569
11570   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11571     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11572       {
11573         if ((t = ffecom_tree_type[i][j]) != NULL_TREE)
11574           {
11575             if (i == FFEINFO_basictypeINTEGER)
11576               {
11577                 /* Figure out the smallest INTEGER type that can hold
11578                    a pointer on this machine. */
11579                 if (GET_MODE_SIZE (TYPE_MODE (t))
11580                     >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
11581                   {
11582                     if ((ffecom_pointer_kind_ == FFEINFO_kindtypeNONE)
11583                         || (GET_MODE_SIZE (TYPE_MODE (ffecom_tree_type[i][ffecom_pointer_kind_]))
11584                             > GET_MODE_SIZE (TYPE_MODE (t))))
11585                       ffecom_pointer_kind_ = j;
11586                   }
11587               }
11588             else if (i == FFEINFO_basictypeCOMPLEX)
11589               t = void_type_node;
11590             /* For f2c compatibility, REAL functions are really
11591                implemented as DOUBLE PRECISION.  */
11592             else if ((i == FFEINFO_basictypeREAL)
11593                      && (j == FFEINFO_kindtypeREAL1))
11594               t = ffecom_tree_type
11595                 [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2];
11596
11597             t = ffecom_tree_fun_type[i][j] = build_function_type (t,
11598                                                                   NULL_TREE);
11599             ffecom_tree_ptr_to_fun_type[i][j] = build_pointer_type (t);
11600           }
11601       }
11602
11603   /* Set up pointer types.  */
11604
11605   if (ffecom_pointer_kind_ == FFEINFO_basictypeNONE)
11606     fatal_error ("no INTEGER type can hold a pointer on this configuration");
11607   else if (0 && ffe_is_do_internal_checks ())
11608     fprintf (stderr, "Pointer type kt=%d\n", ffecom_pointer_kind_);
11609   ffetype_set_kind (ffeinfo_type (FFEINFO_basictypeINTEGER,
11610                                   FFEINFO_kindtypeINTEGERDEFAULT),
11611                     7,
11612                     ffeinfo_type (FFEINFO_basictypeINTEGER,
11613                                   ffecom_pointer_kind_));
11614
11615   if (ffe_is_ugly_assign ())
11616     ffecom_label_kind_ = ffecom_pointer_kind_;  /* Require ASSIGN etc to this. */
11617   else
11618     ffecom_label_kind_ = FFEINFO_kindtypeINTEGERDEFAULT;
11619   if (0 && ffe_is_do_internal_checks ())
11620     fprintf (stderr, "Label type kt=%d\n", ffecom_label_kind_);
11621
11622   ffecom_integer_type_node
11623     = ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1];
11624   ffecom_integer_zero_node = convert (ffecom_integer_type_node,
11625                                       integer_zero_node);
11626   ffecom_integer_one_node = convert (ffecom_integer_type_node,
11627                                      integer_one_node);
11628
11629   /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional.
11630      Turns out that by TYLONG, runtime/libI77/lio.h really means
11631      "whatever size an ftnint is".  For consistency and sanity,
11632      com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen
11633      all are INTEGER, which we also make out of whatever back-end
11634      integer type is FLOAT_TYPE_SIZE bits wide.  This change, from
11635      LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to
11636      accommodate machines like the Alpha.  Note that this suggests
11637      f2c and libf2c are missing a distinction perhaps needed on
11638      some machines between "int" and "long int".  -- burley 0.5.5 950215 */
11639
11640   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, FLOAT_TYPE_SIZE,
11641                             FFETARGET_f2cTYLONG);
11642   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, SHORT_TYPE_SIZE,
11643                             FFETARGET_f2cTYSHORT);
11644   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, CHAR_TYPE_SIZE,
11645                             FFETARGET_f2cTYINT1);
11646   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, LONG_LONG_TYPE_SIZE,
11647                             FFETARGET_f2cTYQUAD);
11648   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, FLOAT_TYPE_SIZE,
11649                             FFETARGET_f2cTYLOGICAL);
11650   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, SHORT_TYPE_SIZE,
11651                             FFETARGET_f2cTYLOGICAL2);
11652   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, CHAR_TYPE_SIZE,
11653                             FFETARGET_f2cTYLOGICAL1);
11654   /* ~~~Not really such a type in libf2c, e.g. I/O support?  */
11655   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, LONG_LONG_TYPE_SIZE,
11656                             FFETARGET_f2cTYQUAD);
11657
11658   /* CHARACTER stuff is all special-cased, so it is not handled in the above
11659      loop.  CHARACTER items are built as arrays of unsigned char.  */
11660
11661   ffecom_tree_type[FFEINFO_basictypeCHARACTER]
11662     [FFEINFO_kindtypeCHARACTER1] = t = char_type_node;
11663   type = ffetype_new ();
11664   base_type = type;
11665   ffeinfo_set_type (FFEINFO_basictypeCHARACTER,
11666                     FFEINFO_kindtypeCHARACTER1,
11667                     type);
11668   ffetype_set_ams (type,
11669                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11670                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11671   ffetype_set_kind (base_type, 1, type);
11672   assert (ffetype_size (type)
11673           == sizeof (((ffetargetCharacter1) { 0, NULL }).text[0]));
11674
11675   ffecom_tree_fun_type[FFEINFO_basictypeCHARACTER]
11676     [FFEINFO_kindtypeCHARACTER1] = ffecom_tree_fun_type_void;
11677   ffecom_tree_ptr_to_fun_type[FFEINFO_basictypeCHARACTER]
11678     [FFEINFO_kindtypeCHARACTER1]
11679     = ffecom_tree_ptr_to_fun_type_void;
11680   ffecom_f2c_typecode_[FFEINFO_basictypeCHARACTER][FFEINFO_kindtypeCHARACTER1]
11681     = FFETARGET_f2cTYCHAR;
11682
11683   ffecom_f2c_typecode_[FFEINFO_basictypeANY][FFEINFO_kindtypeANY]
11684     = 0;
11685
11686   /* Make multi-return-value type and fields. */
11687
11688   ffecom_multi_type_node_ = make_node (UNION_TYPE);
11689
11690   field = NULL_TREE;
11691
11692   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11693     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11694       {
11695         char name[30];
11696
11697         if (ffecom_tree_type[i][j] == NULL_TREE)
11698           continue;             /* Not supported. */
11699         sprintf (&name[0], "bt_%s_kt_%s",
11700                  ffeinfo_basictype_string ((ffeinfoBasictype) i),
11701                  ffeinfo_kindtype_string ((ffeinfoKindtype) j));
11702         ffecom_multi_fields_[i][j] = build_decl (FIELD_DECL,
11703                                                  get_identifier (name),
11704                                                  ffecom_tree_type[i][j]);
11705         DECL_CONTEXT (ffecom_multi_fields_[i][j])
11706           = ffecom_multi_type_node_;
11707         DECL_ALIGN (ffecom_multi_fields_[i][j]) = 0;
11708         DECL_USER_ALIGN (ffecom_multi_fields_[i][j]) = 0;
11709         TREE_CHAIN (ffecom_multi_fields_[i][j]) = field;
11710         field = ffecom_multi_fields_[i][j];
11711       }
11712
11713   TYPE_FIELDS (ffecom_multi_type_node_) = field;
11714   layout_type (ffecom_multi_type_node_);
11715
11716   /* Subroutines usually return integer because they might have alternate
11717      returns. */
11718
11719   ffecom_tree_subr_type
11720     = build_function_type (integer_type_node, NULL_TREE);
11721   ffecom_tree_ptr_to_subr_type
11722     = build_pointer_type (ffecom_tree_subr_type);
11723   ffecom_tree_blockdata_type
11724     = build_function_type (void_type_node, NULL_TREE);
11725
11726   builtin_function ("__builtin_sqrtf", float_ftype_float,
11727                     BUILT_IN_SQRTF, BUILT_IN_NORMAL, "sqrtf");
11728   builtin_function ("__builtin_sqrt", double_ftype_double,
11729                     BUILT_IN_SQRT, BUILT_IN_NORMAL, "sqrt");
11730   builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble,
11731                     BUILT_IN_SQRTL, BUILT_IN_NORMAL, "sqrtl");
11732   builtin_function ("__builtin_sinf", float_ftype_float,
11733                     BUILT_IN_SINF, BUILT_IN_NORMAL, "sinf");
11734   builtin_function ("__builtin_sin", double_ftype_double,
11735                     BUILT_IN_SIN, BUILT_IN_NORMAL, "sin");
11736   builtin_function ("__builtin_sinl", ldouble_ftype_ldouble,
11737                     BUILT_IN_SINL, BUILT_IN_NORMAL, "sinl");
11738   builtin_function ("__builtin_cosf", float_ftype_float,
11739                     BUILT_IN_COSF, BUILT_IN_NORMAL, "cosf");
11740   builtin_function ("__builtin_cos", double_ftype_double,
11741                     BUILT_IN_COS, BUILT_IN_NORMAL, "cos");
11742   builtin_function ("__builtin_cosl", ldouble_ftype_ldouble,
11743                     BUILT_IN_COSL, BUILT_IN_NORMAL, "cosl");
11744
11745   pedantic_lvalues = FALSE;
11746
11747   ffecom_f2c_make_type_ (&ffecom_f2c_integer_type_node,
11748                          FFECOM_f2cINTEGER,
11749                          "integer");
11750   ffecom_f2c_make_type_ (&ffecom_f2c_address_type_node,
11751                          FFECOM_f2cADDRESS,
11752                          "address");
11753   ffecom_f2c_make_type_ (&ffecom_f2c_real_type_node,
11754                          FFECOM_f2cREAL,
11755                          "real");
11756   ffecom_f2c_make_type_ (&ffecom_f2c_doublereal_type_node,
11757                          FFECOM_f2cDOUBLEREAL,
11758                          "doublereal");
11759   ffecom_f2c_make_type_ (&ffecom_f2c_complex_type_node,
11760                          FFECOM_f2cCOMPLEX,
11761                          "complex");
11762   ffecom_f2c_make_type_ (&ffecom_f2c_doublecomplex_type_node,
11763                          FFECOM_f2cDOUBLECOMPLEX,
11764                          "doublecomplex");
11765   ffecom_f2c_make_type_ (&ffecom_f2c_longint_type_node,
11766                          FFECOM_f2cLONGINT,
11767                          "longint");
11768   ffecom_f2c_make_type_ (&ffecom_f2c_logical_type_node,
11769                          FFECOM_f2cLOGICAL,
11770                          "logical");
11771   ffecom_f2c_make_type_ (&ffecom_f2c_flag_type_node,
11772                          FFECOM_f2cFLAG,
11773                          "flag");
11774   ffecom_f2c_make_type_ (&ffecom_f2c_ftnlen_type_node,
11775                          FFECOM_f2cFTNLEN,
11776                          "ftnlen");
11777   ffecom_f2c_make_type_ (&ffecom_f2c_ftnint_type_node,
11778                          FFECOM_f2cFTNINT,
11779                          "ftnint");
11780
11781   ffecom_f2c_ftnlen_zero_node
11782     = convert (ffecom_f2c_ftnlen_type_node, integer_zero_node);
11783
11784   ffecom_f2c_ftnlen_one_node
11785     = convert (ffecom_f2c_ftnlen_type_node, integer_one_node);
11786
11787   ffecom_f2c_ftnlen_two_node = build_int_2 (2, 0);
11788   TREE_TYPE (ffecom_f2c_ftnlen_two_node) = ffecom_integer_type_node;
11789
11790   ffecom_f2c_ptr_to_ftnlen_type_node
11791     = build_pointer_type (ffecom_f2c_ftnlen_type_node);
11792
11793   ffecom_f2c_ptr_to_ftnint_type_node
11794     = build_pointer_type (ffecom_f2c_ftnint_type_node);
11795
11796   ffecom_f2c_ptr_to_integer_type_node
11797     = build_pointer_type (ffecom_f2c_integer_type_node);
11798
11799   ffecom_f2c_ptr_to_real_type_node
11800     = build_pointer_type (ffecom_f2c_real_type_node);
11801
11802   ffecom_float_zero_ = build_real (float_type_node, dconst0);
11803   ffecom_double_zero_ = build_real (double_type_node, dconst0);
11804   {
11805     REAL_VALUE_TYPE point_5;
11806
11807     REAL_ARITHMETIC (point_5, RDIV_EXPR, dconst1, dconst2);
11808     ffecom_float_half_ = build_real (float_type_node, point_5);
11809     ffecom_double_half_ = build_real (double_type_node, point_5);
11810   }
11811
11812   /* Do "extern int xargc;".  */
11813
11814   ffecom_tree_xargc_ = build_decl (VAR_DECL,
11815                                    get_identifier ("f__xargc"),
11816                                    integer_type_node);
11817   DECL_EXTERNAL (ffecom_tree_xargc_) = 1;
11818   TREE_STATIC (ffecom_tree_xargc_) = 1;
11819   TREE_PUBLIC (ffecom_tree_xargc_) = 1;
11820   ffecom_tree_xargc_ = start_decl (ffecom_tree_xargc_, FALSE);
11821   finish_decl (ffecom_tree_xargc_, NULL_TREE, FALSE);
11822
11823 #if 0   /* This is being fixed, and seems to be working now. */
11824   if ((FLOAT_TYPE_SIZE != 32)
11825       || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))) != 32))
11826     {
11827       warning ("configuration: REAL, INTEGER, and LOGICAL are %d bits wide,",
11828                (int) FLOAT_TYPE_SIZE);
11829       warning ("and pointers are %d bits wide, but g77 doesn't yet work",
11830           (int) TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))));
11831       warning ("properly unless they all are 32 bits wide");
11832       warning ("Please keep this in mind before you report bugs.");
11833     }
11834 #endif
11835
11836 #if 0   /* Code in ste.c that would crash has been commented out. */
11837   if (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)
11838       < TYPE_PRECISION (string_type_node))
11839     /* I/O will probably crash.  */
11840     warning ("configuration: char * holds %d bits, but ftnlen only %d",
11841              TYPE_PRECISION (string_type_node),
11842              TYPE_PRECISION (ffecom_f2c_ftnlen_type_node));
11843 #endif
11844
11845 #if 0   /* ASSIGN-related stuff has been changed to accommodate this. */
11846   if (TYPE_PRECISION (ffecom_integer_type_node)
11847       < TYPE_PRECISION (string_type_node))
11848     /* ASSIGN 10 TO I will crash.  */
11849     warning ("configuration: char * holds %d bits, but INTEGER only %d --\n\
11850  ASSIGN statement might fail",
11851              TYPE_PRECISION (string_type_node),
11852              TYPE_PRECISION (ffecom_integer_type_node));
11853 #endif
11854 }
11855
11856 /* ffecom_init_2 -- Initialize
11857
11858    ffecom_init_2();  */
11859
11860 void
11861 ffecom_init_2 ()
11862 {
11863   assert (ffecom_outer_function_decl_ == NULL_TREE);
11864   assert (current_function_decl == NULL_TREE);
11865   assert (ffecom_which_entrypoint_decl_ == NULL_TREE);
11866
11867   ffecom_master_arglist_ = NULL;
11868   ++ffecom_num_fns_;
11869   ffecom_primary_entry_ = NULL;
11870   ffecom_is_altreturning_ = FALSE;
11871   ffecom_func_result_ = NULL_TREE;
11872   ffecom_multi_retval_ = NULL_TREE;
11873 }
11874
11875 /* ffecom_list_expr -- Transform list of exprs into gcc tree
11876
11877    tree t;
11878    ffebld expr;  // FFE opITEM list.
11879    tree = ffecom_list_expr(expr);
11880
11881    List of actual args is transformed into corresponding gcc backend list.  */
11882
11883 tree
11884 ffecom_list_expr (ffebld expr)
11885 {
11886   tree list;
11887   tree *plist = &list;
11888   tree trail = NULL_TREE;       /* Append char length args here. */
11889   tree *ptrail = &trail;
11890   tree length;
11891
11892   while (expr != NULL)
11893     {
11894       tree texpr = ffecom_arg_expr (ffebld_head (expr), &length);
11895
11896       if (texpr == error_mark_node)
11897         return error_mark_node;
11898
11899       *plist = build_tree_list (NULL_TREE, texpr);
11900       plist = &TREE_CHAIN (*plist);
11901       expr = ffebld_trail (expr);
11902       if (length != NULL_TREE)
11903         {
11904           *ptrail = build_tree_list (NULL_TREE, length);
11905           ptrail = &TREE_CHAIN (*ptrail);
11906         }
11907     }
11908
11909   *plist = trail;
11910
11911   return list;
11912 }
11913
11914 /* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree
11915
11916    tree t;
11917    ffebld expr;  // FFE opITEM list.
11918    tree = ffecom_list_ptr_to_expr(expr);
11919
11920    List of actual args is transformed into corresponding gcc backend list for
11921    use in calling an external procedure (vs. a statement function).  */
11922
11923 tree
11924 ffecom_list_ptr_to_expr (ffebld expr)
11925 {
11926   tree list;
11927   tree *plist = &list;
11928   tree trail = NULL_TREE;       /* Append char length args here. */
11929   tree *ptrail = &trail;
11930   tree length;
11931
11932   while (expr != NULL)
11933     {
11934       tree texpr = ffecom_arg_ptr_to_expr (ffebld_head (expr), &length);
11935
11936       if (texpr == error_mark_node)
11937         return error_mark_node;
11938
11939       *plist = build_tree_list (NULL_TREE, texpr);
11940       plist = &TREE_CHAIN (*plist);
11941       expr = ffebld_trail (expr);
11942       if (length != NULL_TREE)
11943         {
11944           *ptrail = build_tree_list (NULL_TREE, length);
11945           ptrail = &TREE_CHAIN (*ptrail);
11946         }
11947     }
11948
11949   *plist = trail;
11950
11951   return list;
11952 }
11953
11954 /* Obtain gcc's LABEL_DECL tree for label.  */
11955
11956 tree
11957 ffecom_lookup_label (ffelab label)
11958 {
11959   tree glabel;
11960
11961   if (ffelab_hook (label) == NULL_TREE)
11962     {
11963       char labelname[16];
11964
11965       switch (ffelab_type (label))
11966         {
11967         case FFELAB_typeLOOPEND:
11968         case FFELAB_typeNOTLOOP:
11969         case FFELAB_typeENDIF:
11970           sprintf (labelname, "%" ffelabValue_f "u", ffelab_value (label));
11971           glabel = build_decl (LABEL_DECL, get_identifier (labelname),
11972                                void_type_node);
11973           DECL_CONTEXT (glabel) = current_function_decl;
11974           DECL_MODE (glabel) = VOIDmode;
11975           break;
11976
11977         case FFELAB_typeFORMAT:
11978           glabel = build_decl (VAR_DECL,
11979                                ffecom_get_invented_identifier
11980                                ("__g77_format_%d", (int) ffelab_value (label)),
11981                                build_type_variant (build_array_type
11982                                                    (char_type_node,
11983                                                     NULL_TREE),
11984                                                    1, 0));
11985           TREE_CONSTANT (glabel) = 1;
11986           TREE_STATIC (glabel) = 1;
11987           DECL_CONTEXT (glabel) = current_function_decl;
11988           DECL_INITIAL (glabel) = NULL;
11989           make_decl_rtl (glabel, NULL);
11990           expand_decl (glabel);
11991
11992           ffecom_save_tree_forever (glabel);
11993
11994           break;
11995
11996         case FFELAB_typeANY:
11997           glabel = error_mark_node;
11998           break;
11999
12000         default:
12001           assert ("bad label type" == NULL);
12002           glabel = NULL;
12003           break;
12004         }
12005       ffelab_set_hook (label, glabel);
12006     }
12007   else
12008     {
12009       glabel = ffelab_hook (label);
12010     }
12011
12012   return glabel;
12013 }
12014
12015 /* Stabilizes the arguments.  Don't use this if the lhs and rhs come from
12016    a single source specification (as in the fourth argument of MVBITS).
12017    If the type is NULL_TREE, the type of lhs is used to make the type of
12018    the MODIFY_EXPR.  */
12019
12020 tree
12021 ffecom_modify (tree newtype, tree lhs,
12022                tree rhs)
12023 {
12024   if (lhs == error_mark_node || rhs == error_mark_node)
12025     return error_mark_node;
12026
12027   if (newtype == NULL_TREE)
12028     newtype = TREE_TYPE (lhs);
12029
12030   if (TREE_SIDE_EFFECTS (lhs))
12031     lhs = stabilize_reference (lhs);
12032
12033   return ffecom_2s (MODIFY_EXPR, newtype, lhs, rhs);
12034 }
12035
12036 /* Register source file name.  */
12037
12038 void
12039 ffecom_file (const char *name)
12040 {
12041   ffecom_file_ (name);
12042 }
12043
12044 /* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed
12045
12046    ffestorag st;
12047    ffecom_notify_init_storage(st);
12048
12049    Gets called when all possible units in an aggregate storage area (a LOCAL
12050    with equivalences or a COMMON) have been initialized.  The initialization
12051    info either is in ffestorag_init or, if that is NULL,
12052    ffestorag_accretion:
12053
12054    ffestorag_init may contain an opCONTER or opARRTER.  opCONTER may occur
12055    even for an array if the array is one element in length!
12056
12057    ffestorag_accretion will contain an opACCTER.  It is much like an
12058    opARRTER except it has an ffebit object in it instead of just a size.
12059    The back end can use the info in the ffebit object, if it wants, to
12060    reduce the amount of actual initialization, but in any case it should
12061    kill the ffebit object when done.  Also, set accretion to NULL but
12062    init to a non-NULL value.
12063
12064    After performing initialization, DO NOT set init to NULL, because that'll
12065    tell the front end it is ok for more initialization to happen.  Instead,
12066    set init to an opANY expression or some such thing that you can use to
12067    tell that you've already initialized the object.
12068
12069    27-Oct-91  JCB  1.1
12070       Support two-pass FFE.  */
12071
12072 void
12073 ffecom_notify_init_storage (ffestorag st)
12074 {
12075   ffebld init;                  /* The initialization expression. */
12076
12077   if (ffestorag_init (st) == NULL)
12078     {
12079       init = ffestorag_accretion (st);
12080       assert (init != NULL);
12081       ffestorag_set_accretion (st, NULL);
12082       ffestorag_set_accretes (st, 0);
12083       ffestorag_set_init (st, init);
12084     }
12085 }
12086
12087 /* ffecom_notify_init_symbol -- A symbol is now fully init'ed
12088
12089    ffesymbol s;
12090    ffecom_notify_init_symbol(s);
12091
12092    Gets called when all possible units in a symbol (not placed in COMMON
12093    or involved in EQUIVALENCE, unless it as yet has no ffestorag object)
12094    have been initialized.  The initialization info either is in
12095    ffesymbol_init or, if that is NULL, ffesymbol_accretion:
12096
12097    ffesymbol_init may contain an opCONTER or opARRTER.  opCONTER may occur
12098    even for an array if the array is one element in length!
12099
12100    ffesymbol_accretion will contain an opACCTER.  It is much like an
12101    opARRTER except it has an ffebit object in it instead of just a size.
12102    The back end can use the info in the ffebit object, if it wants, to
12103    reduce the amount of actual initialization, but in any case it should
12104    kill the ffebit object when done.  Also, set accretion to NULL but
12105    init to a non-NULL value.
12106
12107    After performing initialization, DO NOT set init to NULL, because that'll
12108    tell the front end it is ok for more initialization to happen.  Instead,
12109    set init to an opANY expression or some such thing that you can use to
12110    tell that you've already initialized the object.
12111
12112    27-Oct-91  JCB  1.1
12113       Support two-pass FFE.  */
12114
12115 void
12116 ffecom_notify_init_symbol (ffesymbol s)
12117 {
12118   ffebld init;                  /* The initialization expression. */
12119
12120   if (ffesymbol_storage (s) == NULL)
12121     return;                     /* Do nothing until COMMON/EQUIVALENCE
12122                                    possibilities checked. */
12123
12124   if ((ffesymbol_init (s) == NULL)
12125       && ((init = ffesymbol_accretion (s)) != NULL))
12126     {
12127       ffesymbol_set_accretion (s, NULL);
12128       ffesymbol_set_accretes (s, 0);
12129       ffesymbol_set_init (s, init);
12130     }
12131 }
12132
12133 /* ffecom_notify_primary_entry -- Learn which is the primary entry point
12134
12135    ffesymbol s;
12136    ffecom_notify_primary_entry(s);
12137
12138    Gets called when implicit or explicit PROGRAM statement seen or when
12139    FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary
12140    global symbol that serves as the entry point.  */
12141
12142 void
12143 ffecom_notify_primary_entry (ffesymbol s)
12144 {
12145   ffecom_primary_entry_ = s;
12146   ffecom_primary_entry_kind_ = ffesymbol_kind (s);
12147
12148   if ((ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
12149       || (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE))
12150     ffecom_primary_entry_is_proc_ = TRUE;
12151   else
12152     ffecom_primary_entry_is_proc_ = FALSE;
12153
12154   if (!ffe_is_silent ())
12155     {
12156       if (ffecom_primary_entry_kind_ == FFEINFO_kindPROGRAM)
12157         fprintf (stderr, "%s:\n", ffesymbol_text (s));
12158       else
12159         fprintf (stderr, "  %s:\n", ffesymbol_text (s));
12160     }
12161
12162   if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
12163     {
12164       ffebld list;
12165       ffebld arg;
12166
12167       for (list = ffesymbol_dummyargs (s);
12168            list != NULL;
12169            list = ffebld_trail (list))
12170         {
12171           arg = ffebld_head (list);
12172           if (ffebld_op (arg) == FFEBLD_opSTAR)
12173             {
12174               ffecom_is_altreturning_ = TRUE;
12175               break;
12176             }
12177         }
12178     }
12179 }
12180
12181 FILE *
12182 ffecom_open_include (char *name, ffewhereLine l, ffewhereColumn c)
12183 {
12184   return ffecom_open_include_ (name, l, c);
12185 }
12186
12187 /* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front
12188
12189    tree t;
12190    ffebld expr;  // FFE expression.
12191    tree = ffecom_ptr_to_expr(expr);
12192
12193    Like ffecom_expr, but sticks address-of in front of most things.  */
12194
12195 tree
12196 ffecom_ptr_to_expr (ffebld expr)
12197 {
12198   tree item;
12199   ffeinfoBasictype bt;
12200   ffeinfoKindtype kt;
12201   ffesymbol s;
12202
12203   assert (expr != NULL);
12204
12205   switch (ffebld_op (expr))
12206     {
12207     case FFEBLD_opSYMTER:
12208       s = ffebld_symter (expr);
12209       if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
12210         {
12211           ffecomGfrt ix;
12212
12213           ix = ffeintrin_gfrt_indirect (ffebld_symter_implementation (expr));
12214           assert (ix != FFECOM_gfrt);
12215           if ((item = ffecom_gfrt_[ix]) == NULL_TREE)
12216             {
12217               ffecom_make_gfrt_ (ix);
12218               item = ffecom_gfrt_[ix];
12219             }
12220         }
12221       else
12222         {
12223           item = ffesymbol_hook (s).decl_tree;
12224           if (item == NULL_TREE)
12225             {
12226               s = ffecom_sym_transform_ (s);
12227               item = ffesymbol_hook (s).decl_tree;
12228             }
12229         }
12230       assert (item != NULL);
12231       if (item == error_mark_node)
12232         return item;
12233       if (!ffesymbol_hook (s).addr)
12234         item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12235                          item);
12236       return item;
12237
12238     case FFEBLD_opARRAYREF:
12239       return ffecom_arrayref_ (NULL_TREE, expr, 1);
12240
12241     case FFEBLD_opCONTER:
12242
12243       bt = ffeinfo_basictype (ffebld_info (expr));
12244       kt = ffeinfo_kindtype (ffebld_info (expr));
12245
12246       item = ffecom_constantunion (&ffebld_constant_union
12247                                    (ffebld_conter (expr)), bt, kt,
12248                                    ffecom_tree_type[bt][kt]);
12249       if (item == error_mark_node)
12250         return error_mark_node;
12251       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12252                        item);
12253       return item;
12254
12255     case FFEBLD_opANY:
12256       return error_mark_node;
12257
12258     default:
12259       bt = ffeinfo_basictype (ffebld_info (expr));
12260       kt = ffeinfo_kindtype (ffebld_info (expr));
12261
12262       item = ffecom_expr (expr);
12263       if (item == error_mark_node)
12264         return error_mark_node;
12265
12266       /* The back end currently optimizes a bit too zealously for us, in that
12267          we fail JCB001 if the following block of code is omitted.  It checks
12268          to see if the transformed expression is a symbol or array reference,
12269          and encloses it in a SAVE_EXPR if that is the case.  */
12270
12271       STRIP_NOPS (item);
12272       if ((TREE_CODE (item) == VAR_DECL)
12273           || (TREE_CODE (item) == PARM_DECL)
12274           || (TREE_CODE (item) == RESULT_DECL)
12275           || (TREE_CODE (item) == INDIRECT_REF)
12276           || (TREE_CODE (item) == ARRAY_REF)
12277           || (TREE_CODE (item) == COMPONENT_REF)
12278 #ifdef OFFSET_REF
12279           || (TREE_CODE (item) == OFFSET_REF)
12280 #endif
12281           || (TREE_CODE (item) == BUFFER_REF)
12282           || (TREE_CODE (item) == REALPART_EXPR)
12283           || (TREE_CODE (item) == IMAGPART_EXPR))
12284         {
12285           item = ffecom_save_tree (item);
12286         }
12287
12288       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12289                        item);
12290       return item;
12291     }
12292
12293   assert ("fall-through error" == NULL);
12294   return error_mark_node;
12295 }
12296
12297 /* Obtain a temp var with given data type.
12298
12299    size is FFETARGET_charactersizeNONE for a non-CHARACTER type
12300    or >= 0 for a CHARACTER type.
12301
12302    elements is -1 for a scalar or > 0 for an array of type.  */
12303
12304 tree
12305 ffecom_make_tempvar (const char *commentary, tree type,
12306                      ffetargetCharacterSize size, int elements)
12307 {
12308   tree t;
12309   static int mynumber;
12310
12311   assert (current_binding_level->prep_state < 2);
12312
12313   if (type == error_mark_node)
12314     return error_mark_node;
12315
12316   if (size != FFETARGET_charactersizeNONE)
12317     type = build_array_type (type,
12318                              build_range_type (ffecom_f2c_ftnlen_type_node,
12319                                                ffecom_f2c_ftnlen_one_node,
12320                                                build_int_2 (size, 0)));
12321   if (elements != -1)
12322     type = build_array_type (type,
12323                              build_range_type (integer_type_node,
12324                                                integer_zero_node,
12325                                                build_int_2 (elements - 1,
12326                                                             0)));
12327   t = build_decl (VAR_DECL,
12328                   ffecom_get_invented_identifier ("__g77_%s_%d",
12329                                                   commentary,
12330                                                   mynumber++),
12331                   type);
12332
12333   t = start_decl (t, FALSE);
12334   finish_decl (t, NULL_TREE, FALSE);
12335
12336   return t;
12337 }
12338
12339 /* Prepare argument pointer to expression.
12340
12341    Like ffecom_prepare_expr, except for expressions to be evaluated
12342    via ffecom_arg_ptr_to_expr.  */
12343
12344 void
12345 ffecom_prepare_arg_ptr_to_expr (ffebld expr)
12346 {
12347   /* ~~For now, it seems to be the same thing.  */
12348   ffecom_prepare_expr (expr);
12349   return;
12350 }
12351
12352 /* End of preparations.  */
12353
12354 bool
12355 ffecom_prepare_end (void)
12356 {
12357   int prep_state = current_binding_level->prep_state;
12358
12359   assert (prep_state < 2);
12360   current_binding_level->prep_state = 2;
12361
12362   return (prep_state == 1) ? TRUE : FALSE;
12363 }
12364
12365 /* Prepare expression.
12366
12367    This is called before any code is generated for the current block.
12368    It scans the expression, declares any temporaries that might be needed
12369    during evaluation of the expression, and stores those temporaries in
12370    the appropriate "hook" fields of the expression.  `dest', if not NULL,
12371    specifies the destination that ffecom_expr_ will see, in case that
12372    helps avoid generating unused temporaries.
12373
12374    ~~Improve to avoid allocating unused temporaries by taking `dest'
12375    into account vis-a-vis aliasing requirements of complex/character
12376    functions.  */
12377
12378 void
12379 ffecom_prepare_expr_ (ffebld expr, ffebld dest UNUSED)
12380 {
12381   ffeinfoBasictype bt;
12382   ffeinfoKindtype kt;
12383   ffetargetCharacterSize sz;
12384   tree tempvar = NULL_TREE;
12385
12386   assert (current_binding_level->prep_state < 2);
12387
12388   if (! expr)
12389     return;
12390
12391   bt = ffeinfo_basictype (ffebld_info (expr));
12392   kt = ffeinfo_kindtype (ffebld_info (expr));
12393   sz = ffeinfo_size (ffebld_info (expr));
12394
12395   /* Generate whatever temporaries are needed to represent the result
12396      of the expression.  */
12397
12398   if (bt == FFEINFO_basictypeCHARACTER)
12399     {
12400       while (ffebld_op (expr) == FFEBLD_opPAREN)
12401         expr = ffebld_left (expr);
12402     }
12403
12404   switch (ffebld_op (expr))
12405     {
12406     default:
12407       /* Don't make temps for SYMTER, CONTER, etc.  */
12408       if (ffebld_arity (expr) == 0)
12409         break;
12410
12411       switch (bt)
12412         {
12413         case FFEINFO_basictypeCOMPLEX:
12414           if (ffebld_op (expr) == FFEBLD_opFUNCREF)
12415             {
12416               ffesymbol s;
12417
12418               if (ffebld_op (ffebld_left (expr)) != FFEBLD_opSYMTER)
12419                 break;
12420
12421               s = ffebld_symter (ffebld_left (expr));
12422               if (ffesymbol_where (s) == FFEINFO_whereCONSTANT
12423                   || (ffesymbol_where (s) != FFEINFO_whereINTRINSIC
12424                       && ! ffesymbol_is_f2c (s))
12425                   || (ffesymbol_where (s) == FFEINFO_whereINTRINSIC
12426                       && ! ffe_is_f2c_library ()))
12427                 break;
12428             }
12429           else if (ffebld_op (expr) == FFEBLD_opPOWER)
12430             {
12431               /* Requires special treatment.  There's no POW_CC function
12432                  in libg2c, so POW_ZZ is used, which means we always
12433                  need a double-complex temp, not a single-complex.  */
12434               kt = FFEINFO_kindtypeREAL2;
12435             }
12436           else if (ffebld_op (expr) != FFEBLD_opDIVIDE)
12437             /* The other ops don't need temps for complex operands.  */
12438             break;
12439
12440           /* ~~~Avoid making temps for some intrinsics, such as AIMAG(C),
12441              REAL(C).  See 19990325-0.f, routine `check', for cases.  */
12442           tempvar = ffecom_make_tempvar ("complex",
12443                                          ffecom_tree_type
12444                                          [FFEINFO_basictypeCOMPLEX][kt],
12445                                          FFETARGET_charactersizeNONE,
12446                                          -1);
12447           break;
12448
12449         case FFEINFO_basictypeCHARACTER:
12450           if (ffebld_op (expr) != FFEBLD_opFUNCREF)
12451             break;
12452
12453           if (sz == FFETARGET_charactersizeNONE)
12454             /* ~~Kludge alert!  This should someday be fixed. */
12455             sz = 24;
12456
12457           tempvar = ffecom_make_tempvar ("char", char_type_node, sz, -1);
12458           break;
12459
12460         default:
12461           break;
12462         }
12463       break;
12464
12465 #ifdef HAHA
12466     case FFEBLD_opPOWER:
12467       {
12468         tree rtype, ltype;
12469         tree rtmp, ltmp, result;
12470
12471         ltype = ffecom_type_expr (ffebld_left (expr));
12472         rtype = ffecom_type_expr (ffebld_right (expr));
12473
12474         rtmp = ffecom_make_tempvar (rtype, FFETARGET_charactersizeNONE, -1);
12475         ltmp = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
12476         result = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
12477
12478         tempvar = make_tree_vec (3);
12479         TREE_VEC_ELT (tempvar, 0) = rtmp;
12480         TREE_VEC_ELT (tempvar, 1) = ltmp;
12481         TREE_VEC_ELT (tempvar, 2) = result;
12482       }
12483       break;
12484 #endif  /* HAHA */
12485
12486     case FFEBLD_opCONCATENATE:
12487       {
12488         /* This gets special handling, because only one set of temps
12489            is needed for a tree of these -- the tree is treated as
12490            a flattened list of concatenations when generating code.  */
12491
12492         ffecomConcatList_ catlist;
12493         tree ltmp, itmp, result;
12494         int count;
12495         int i;
12496
12497         catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
12498         count = ffecom_concat_list_count_ (catlist);
12499
12500         if (count >= 2)
12501           {
12502             ltmp
12503               = ffecom_make_tempvar ("concat_len",
12504                                      ffecom_f2c_ftnlen_type_node,
12505                                      FFETARGET_charactersizeNONE, count);
12506             itmp
12507               = ffecom_make_tempvar ("concat_item",
12508                                      ffecom_f2c_address_type_node,
12509                                      FFETARGET_charactersizeNONE, count);
12510             result
12511               = ffecom_make_tempvar ("concat_res",
12512                                      char_type_node,
12513                                      ffecom_concat_list_maxlen_ (catlist),
12514                                      -1);
12515
12516             tempvar = make_tree_vec (3);
12517             TREE_VEC_ELT (tempvar, 0) = ltmp;
12518             TREE_VEC_ELT (tempvar, 1) = itmp;
12519             TREE_VEC_ELT (tempvar, 2) = result;
12520           }
12521
12522         for (i = 0; i < count; ++i)
12523           ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist,
12524                                                                     i));
12525
12526         ffecom_concat_list_kill_ (catlist);
12527
12528         if (tempvar)
12529           {
12530             ffebld_nonter_set_hook (expr, tempvar);
12531             current_binding_level->prep_state = 1;
12532           }
12533       }
12534       return;
12535
12536     case FFEBLD_opCONVERT:
12537       if (bt == FFEINFO_basictypeCHARACTER
12538           && ((ffebld_size_known (ffebld_left (expr))
12539                == FFETARGET_charactersizeNONE)
12540               || (ffebld_size_known (ffebld_left (expr)) >= sz)))
12541         tempvar = ffecom_make_tempvar ("convert", char_type_node, sz, -1);
12542       break;
12543     }
12544
12545   if (tempvar)
12546     {
12547       ffebld_nonter_set_hook (expr, tempvar);
12548       current_binding_level->prep_state = 1;
12549     }
12550
12551   /* Prepare subexpressions for this expr.  */
12552
12553   switch (ffebld_op (expr))
12554     {
12555     case FFEBLD_opPERCENT_LOC:
12556       ffecom_prepare_ptr_to_expr (ffebld_left (expr));
12557       break;
12558
12559     case FFEBLD_opPERCENT_VAL:
12560     case FFEBLD_opPERCENT_REF:
12561       ffecom_prepare_expr (ffebld_left (expr));
12562       break;
12563
12564     case FFEBLD_opPERCENT_DESCR:
12565       ffecom_prepare_arg_ptr_to_expr (ffebld_left (expr));
12566       break;
12567
12568     case FFEBLD_opITEM:
12569       {
12570         ffebld item;
12571
12572         for (item = expr;
12573              item != NULL;
12574              item = ffebld_trail (item))
12575           if (ffebld_head (item) != NULL)
12576             ffecom_prepare_expr (ffebld_head (item));
12577       }
12578       break;
12579
12580     default:
12581       /* Need to handle character conversion specially.  */
12582       switch (ffebld_arity (expr))
12583         {
12584         case 2:
12585           ffecom_prepare_expr (ffebld_left (expr));
12586           ffecom_prepare_expr (ffebld_right (expr));
12587           break;
12588
12589         case 1:
12590           ffecom_prepare_expr (ffebld_left (expr));
12591           break;
12592
12593         default:
12594           break;
12595         }
12596     }
12597
12598   return;
12599 }
12600
12601 /* Prepare expression for reading and writing.
12602
12603    Like ffecom_prepare_expr, except for expressions to be evaluated
12604    via ffecom_expr_rw.  */
12605
12606 void
12607 ffecom_prepare_expr_rw (tree type, ffebld expr)
12608 {
12609   /* This is all we support for now.  */
12610   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
12611
12612   /* ~~For now, it seems to be the same thing.  */
12613   ffecom_prepare_expr (expr);
12614   return;
12615 }
12616
12617 /* Prepare expression for writing.
12618
12619    Like ffecom_prepare_expr, except for expressions to be evaluated
12620    via ffecom_expr_w.  */
12621
12622 void
12623 ffecom_prepare_expr_w (tree type, ffebld expr)
12624 {
12625   /* This is all we support for now.  */
12626   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
12627
12628   /* ~~For now, it seems to be the same thing.  */
12629   ffecom_prepare_expr (expr);
12630   return;
12631 }
12632
12633 /* Prepare expression for returning.
12634
12635    Like ffecom_prepare_expr, except for expressions to be evaluated
12636    via ffecom_return_expr.  */
12637
12638 void
12639 ffecom_prepare_return_expr (ffebld expr)
12640 {
12641   assert (current_binding_level->prep_state < 2);
12642
12643   if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE
12644       && ffecom_is_altreturning_
12645       && expr != NULL)
12646     ffecom_prepare_expr (expr);
12647 }
12648
12649 /* Prepare pointer to expression.
12650
12651    Like ffecom_prepare_expr, except for expressions to be evaluated
12652    via ffecom_ptr_to_expr.  */
12653
12654 void
12655 ffecom_prepare_ptr_to_expr (ffebld expr)
12656 {
12657   /* ~~For now, it seems to be the same thing.  */
12658   ffecom_prepare_expr (expr);
12659   return;
12660 }
12661
12662 /* Transform expression into constant pointer-to-expression tree.
12663
12664    If the expression can be transformed into a pointer-to-expression tree
12665    that is constant, that is done, and the tree returned.  Else NULL_TREE
12666    is returned.
12667
12668    That way, a caller can attempt to provide compile-time initialization
12669    of a variable and, if that fails, *then* choose to start a new block
12670    and resort to using temporaries, as appropriate.  */
12671
12672 tree
12673 ffecom_ptr_to_const_expr (ffebld expr)
12674 {
12675   if (! expr)
12676     return integer_zero_node;
12677
12678   if (ffebld_op (expr) == FFEBLD_opANY)
12679     return error_mark_node;
12680
12681   if (ffebld_arity (expr) == 0
12682       && (ffebld_op (expr) != FFEBLD_opSYMTER
12683           || ffebld_where (expr) == FFEINFO_whereCOMMON
12684           || ffebld_where (expr) == FFEINFO_whereGLOBAL
12685           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
12686     {
12687       tree t;
12688
12689       t = ffecom_ptr_to_expr (expr);
12690       assert (TREE_CONSTANT (t));
12691       return t;
12692     }
12693
12694   return NULL_TREE;
12695 }
12696
12697 /* ffecom_return_expr -- Returns return-value expr given alt return expr
12698
12699    tree rtn;  // NULL_TREE means use expand_null_return()
12700    ffebld expr;  // NULL if no alt return expr to RETURN stmt
12701    rtn = ffecom_return_expr(expr);
12702
12703    Based on the program unit type and other info (like return function
12704    type, return master function type when alternate ENTRY points,
12705    whether subroutine has any alternate RETURN points, etc), returns the
12706    appropriate expression to be returned to the caller, or NULL_TREE
12707    meaning no return value or the caller expects it to be returned somewhere
12708    else (which is handled by other parts of this module).  */
12709
12710 tree
12711 ffecom_return_expr (ffebld expr)
12712 {
12713   tree rtn;
12714
12715   switch (ffecom_primary_entry_kind_)
12716     {
12717     case FFEINFO_kindPROGRAM:
12718     case FFEINFO_kindBLOCKDATA:
12719       rtn = NULL_TREE;
12720       break;
12721
12722     case FFEINFO_kindSUBROUTINE:
12723       if (!ffecom_is_altreturning_)
12724         rtn = NULL_TREE;        /* No alt returns, never an expr. */
12725       else if (expr == NULL)
12726         rtn = integer_zero_node;
12727       else
12728         rtn = ffecom_expr (expr);
12729       break;
12730
12731     case FFEINFO_kindFUNCTION:
12732       if ((ffecom_multi_retval_ != NULL_TREE)
12733           || (ffesymbol_basictype (ffecom_primary_entry_)
12734               == FFEINFO_basictypeCHARACTER)
12735           || ((ffesymbol_basictype (ffecom_primary_entry_)
12736                == FFEINFO_basictypeCOMPLEX)
12737               && (ffecom_num_entrypoints_ == 0)
12738               && ffesymbol_is_f2c (ffecom_primary_entry_)))
12739         {                       /* Value is returned by direct assignment
12740                                    into (implicit) dummy. */
12741           rtn = NULL_TREE;
12742           break;
12743         }
12744       rtn = ffecom_func_result_;
12745 #if 0
12746       /* Spurious error if RETURN happens before first reference!  So elide
12747          this code.  In particular, for debugging registry, rtn should always
12748          be non-null after all, but TREE_USED won't be set until we encounter
12749          a reference in the code.  Perfectly okay (but weird) code that,
12750          e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in
12751          this diagnostic for no reason.  Have people use -O -Wuninitialized
12752          and leave it to the back end to find obviously weird cases.  */
12753
12754       /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid
12755          situation; if the return value has never been referenced, it won't
12756          have a tree under 2pass mode. */
12757       if ((rtn == NULL_TREE)
12758           || !TREE_USED (rtn))
12759         {
12760           ffebad_start (FFEBAD_RETURN_VALUE_UNSET);
12761           ffebad_here (0, ffesymbol_where_line (ffecom_primary_entry_),
12762                        ffesymbol_where_column (ffecom_primary_entry_));
12763           ffebad_string (ffesymbol_text (ffesymbol_funcresult
12764                                          (ffecom_primary_entry_)));
12765           ffebad_finish ();
12766         }
12767 #endif
12768       break;
12769
12770     default:
12771       assert ("bad unit kind" == NULL);
12772     case FFEINFO_kindANY:
12773       rtn = error_mark_node;
12774       break;
12775     }
12776
12777   return rtn;
12778 }
12779
12780 /* Do save_expr only if tree is not error_mark_node.  */
12781
12782 tree
12783 ffecom_save_tree (tree t)
12784 {
12785   return save_expr (t);
12786 }
12787
12788 /* Start a compound statement (block).  */
12789
12790 void
12791 ffecom_start_compstmt (void)
12792 {
12793   bison_rule_pushlevel_ ();
12794 }
12795
12796 /* Public entry point for front end to access start_decl.  */
12797
12798 tree
12799 ffecom_start_decl (tree decl, bool is_initialized)
12800 {
12801   DECL_INITIAL (decl) = is_initialized ? error_mark_node : NULL_TREE;
12802   return start_decl (decl, FALSE);
12803 }
12804
12805 /* ffecom_sym_commit -- Symbol's state being committed to reality
12806
12807    ffesymbol s;
12808    ffecom_sym_commit(s);
12809
12810    Does whatever the backend needs when a symbol is committed after having
12811    been backtrackable for a period of time.  */
12812
12813 void
12814 ffecom_sym_commit (ffesymbol s UNUSED)
12815 {
12816   assert (!ffesymbol_retractable ());
12817 }
12818
12819 /* ffecom_sym_end_transition -- Perform end transition on all symbols
12820
12821    ffecom_sym_end_transition();
12822
12823    Does backend-specific stuff and also calls ffest_sym_end_transition
12824    to do the necessary FFE stuff.
12825
12826    Backtracking is never enabled when this fn is called, so don't worry
12827    about it.  */
12828
12829 ffesymbol
12830 ffecom_sym_end_transition (ffesymbol s)
12831 {
12832   ffestorag st;
12833
12834   assert (!ffesymbol_retractable ());
12835
12836   s = ffest_sym_end_transition (s);
12837
12838   if ((ffesymbol_kind (s) == FFEINFO_kindBLOCKDATA)
12839       && (ffesymbol_where (s) == FFEINFO_whereGLOBAL))
12840     {
12841       ffecom_list_blockdata_
12842         = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
12843                                               FFEINTRIN_specNONE,
12844                                               FFEINTRIN_impNONE),
12845                            ffecom_list_blockdata_);
12846     }
12847
12848   /* This is where we finally notice that a symbol has partial initialization
12849      and finalize it. */
12850
12851   if (ffesymbol_accretion (s) != NULL)
12852     {
12853       assert (ffesymbol_init (s) == NULL);
12854       ffecom_notify_init_symbol (s);
12855     }
12856   else if (((st = ffesymbol_storage (s)) != NULL)
12857            && ((st = ffestorag_parent (st)) != NULL)
12858            && (ffestorag_accretion (st) != NULL))
12859     {
12860       assert (ffestorag_init (st) == NULL);
12861       ffecom_notify_init_storage (st);
12862     }
12863
12864   if ((ffesymbol_kind (s) == FFEINFO_kindCOMMON)
12865       && (ffesymbol_where (s) == FFEINFO_whereLOCAL)
12866       && (ffesymbol_storage (s) != NULL))
12867     {
12868       ffecom_list_common_
12869         = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
12870                                               FFEINTRIN_specNONE,
12871                                               FFEINTRIN_impNONE),
12872                            ffecom_list_common_);
12873     }
12874
12875   return s;
12876 }
12877
12878 /* ffecom_sym_exec_transition -- Perform exec transition on all symbols
12879
12880    ffecom_sym_exec_transition();
12881
12882    Does backend-specific stuff and also calls ffest_sym_exec_transition
12883    to do the necessary FFE stuff.
12884
12885    See the long-winded description in ffecom_sym_learned for info
12886    on handling the situation where backtracking is inhibited.  */
12887
12888 ffesymbol
12889 ffecom_sym_exec_transition (ffesymbol s)
12890 {
12891   s = ffest_sym_exec_transition (s);
12892
12893   return s;
12894 }
12895
12896 /* ffecom_sym_learned -- Initial or more info gained on symbol after exec
12897
12898    ffesymbol s;
12899    s = ffecom_sym_learned(s);
12900
12901    Called when a new symbol is seen after the exec transition or when more
12902    info (perhaps) is gained for an UNCERTAIN symbol.  The symbol state when
12903    it arrives here is that all its latest info is updated already, so its
12904    state may be UNCERTAIN or UNDERSTOOD, it might already have the hook
12905    field filled in if its gone through here or exec_transition first, and
12906    so on.
12907
12908    The backend probably wants to check ffesymbol_retractable() to see if
12909    backtracking is in effect.  If so, the FFE's changes to the symbol may
12910    be retracted (undone) or committed (ratified), at which time the
12911    appropriate ffecom_sym_retract or _commit function will be called
12912    for that function.
12913
12914    If the backend has its own backtracking mechanism, great, use it so that
12915    committal is a simple operation.  Though it doesn't make much difference,
12916    I suppose: the reason for tentative symbol evolution in the FFE is to
12917    enable error detection in weird incorrect statements early and to disable
12918    incorrect error detection on a correct statement.  The backend is not
12919    likely to introduce any information that'll get involved in these
12920    considerations, so it is probably just fine that the implementation
12921    model for this fn and for _exec_transition is to not do anything
12922    (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE
12923    and instead wait until ffecom_sym_commit is called (which it never
12924    will be as long as we're using ambiguity-detecting statement analysis in
12925    the FFE, which we are initially to shake out the code, but don't depend
12926    on this), otherwise go ahead and do whatever is needed.
12927
12928    In essence, then, when this fn and _exec_transition get called while
12929    backtracking is enabled, a general mechanism would be to flag which (or
12930    both) of these were called (and in what order? neat question as to what
12931    might happen that I'm too lame to think through right now) and then when
12932    _commit is called reproduce the original calling sequence, if any, for
12933    the two fns (at which point backtracking will, of course, be disabled).  */
12934
12935 ffesymbol
12936 ffecom_sym_learned (ffesymbol s)
12937 {
12938   ffestorag_exec_layout (s);
12939
12940   return s;
12941 }
12942
12943 /* ffecom_sym_retract -- Symbol's state being retracted from reality
12944
12945    ffesymbol s;
12946    ffecom_sym_retract(s);
12947
12948    Does whatever the backend needs when a symbol is retracted after having
12949    been backtrackable for a period of time.  */
12950
12951 void
12952 ffecom_sym_retract (ffesymbol s UNUSED)
12953 {
12954   assert (!ffesymbol_retractable ());
12955
12956 #if 0                           /* GCC doesn't commit any backtrackable sins,
12957                                    so nothing needed here. */
12958   switch (ffesymbol_hook (s).state)
12959     {
12960     case 0:                     /* nothing happened yet. */
12961       break;
12962
12963     case 1:                     /* exec transition happened. */
12964       break;
12965
12966     case 2:                     /* learned happened. */
12967       break;
12968
12969     case 3:                     /* learned then exec. */
12970       break;
12971
12972     case 4:                     /* exec then learned. */
12973       break;
12974
12975     default:
12976       assert ("bad hook state" == NULL);
12977       break;
12978     }
12979 #endif
12980 }
12981
12982 /* Create temporary gcc label.  */
12983
12984 tree
12985 ffecom_temp_label ()
12986 {
12987   tree glabel;
12988   static int mynumber = 0;
12989
12990   glabel = build_decl (LABEL_DECL,
12991                        ffecom_get_invented_identifier ("__g77_label_%d",
12992                                                        mynumber++),
12993                        void_type_node);
12994   DECL_CONTEXT (glabel) = current_function_decl;
12995   DECL_MODE (glabel) = VOIDmode;
12996
12997   return glabel;
12998 }
12999
13000 /* Return an expression that is usable as an arg in a conditional context
13001    (IF, DO WHILE, .NOT., and so on).
13002
13003    Use the one provided for the back end as of >2.6.0.  */
13004
13005 tree
13006 ffecom_truth_value (tree expr)
13007 {
13008   return truthvalue_conversion (expr);
13009 }
13010
13011 /* Return the inversion of a truth value (the inversion of what
13012    ffecom_truth_value builds).
13013
13014    Apparently invert_truthvalue, which is properly in the back end, is
13015    enough for now, so just use it.  */
13016
13017 tree
13018 ffecom_truth_value_invert (tree expr)
13019 {
13020   return invert_truthvalue (ffecom_truth_value (expr));
13021 }
13022
13023 /* Return the tree that is the type of the expression, as would be
13024    returned in TREE_TYPE(ffecom_expr(expr)), without otherwise
13025    transforming the expression, generating temporaries, etc.  */
13026
13027 tree
13028 ffecom_type_expr (ffebld expr)
13029 {
13030   ffeinfoBasictype bt;
13031   ffeinfoKindtype kt;
13032   tree tree_type;
13033
13034   assert (expr != NULL);
13035
13036   bt = ffeinfo_basictype (ffebld_info (expr));
13037   kt = ffeinfo_kindtype (ffebld_info (expr));
13038   tree_type = ffecom_tree_type[bt][kt];
13039
13040   switch (ffebld_op (expr))
13041     {
13042     case FFEBLD_opCONTER:
13043     case FFEBLD_opSYMTER:
13044     case FFEBLD_opARRAYREF:
13045     case FFEBLD_opUPLUS:
13046     case FFEBLD_opPAREN:
13047     case FFEBLD_opUMINUS:
13048     case FFEBLD_opADD:
13049     case FFEBLD_opSUBTRACT:
13050     case FFEBLD_opMULTIPLY:
13051     case FFEBLD_opDIVIDE:
13052     case FFEBLD_opPOWER:
13053     case FFEBLD_opNOT:
13054     case FFEBLD_opFUNCREF:
13055     case FFEBLD_opSUBRREF:
13056     case FFEBLD_opAND:
13057     case FFEBLD_opOR:
13058     case FFEBLD_opXOR:
13059     case FFEBLD_opNEQV:
13060     case FFEBLD_opEQV:
13061     case FFEBLD_opCONVERT:
13062     case FFEBLD_opLT:
13063     case FFEBLD_opLE:
13064     case FFEBLD_opEQ:
13065     case FFEBLD_opNE:
13066     case FFEBLD_opGT:
13067     case FFEBLD_opGE:
13068     case FFEBLD_opPERCENT_LOC:
13069       return tree_type;
13070
13071     case FFEBLD_opACCTER:
13072     case FFEBLD_opARRTER:
13073     case FFEBLD_opITEM:
13074     case FFEBLD_opSTAR:
13075     case FFEBLD_opBOUNDS:
13076     case FFEBLD_opREPEAT:
13077     case FFEBLD_opLABTER:
13078     case FFEBLD_opLABTOK:
13079     case FFEBLD_opIMPDO:
13080     case FFEBLD_opCONCATENATE:
13081     case FFEBLD_opSUBSTR:
13082     default:
13083       assert ("bad op for ffecom_type_expr" == NULL);
13084       /* Fall through. */
13085     case FFEBLD_opANY:
13086       return error_mark_node;
13087     }
13088 }
13089
13090 /* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points
13091
13092    If the PARM_DECL already exists, return it, else create it.  It's an
13093    integer_type_node argument for the master function that implements a
13094    subroutine or function with more than one entrypoint and is bound at
13095    run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for
13096    first ENTRY statement, and so on).  */
13097
13098 tree
13099 ffecom_which_entrypoint_decl ()
13100 {
13101   assert (ffecom_which_entrypoint_decl_ != NULL_TREE);
13102
13103   return ffecom_which_entrypoint_decl_;
13104 }
13105 \f
13106 /* The following sections consists of private and public functions
13107    that have the same names and perform roughly the same functions
13108    as counterparts in the C front end.  Changes in the C front end
13109    might affect how things should be done here.  Only functions
13110    needed by the back end should be public here; the rest should
13111    be private (static in the C sense).  Functions needed by other
13112    g77 front-end modules should be accessed by them via public
13113    ffecom_* names, which should themselves call private versions
13114    in this section so the private versions are easy to recognize
13115    when upgrading to a new gcc and finding interesting changes
13116    in the front end.
13117
13118    Functions named after rule "foo:" in c-parse.y are named
13119    "bison_rule_foo_" so they are easy to find.  */
13120
13121 static void
13122 bison_rule_pushlevel_ ()
13123 {
13124   emit_line_note (input_filename, lineno);
13125   pushlevel (0);
13126   clear_last_expr ();
13127   expand_start_bindings (0);
13128 }
13129
13130 static tree
13131 bison_rule_compstmt_ ()
13132 {
13133   tree t;
13134   int keep = kept_level_p ();
13135
13136   /* Make the temps go away.  */
13137   if (! keep)
13138     current_binding_level->names = NULL_TREE;
13139
13140   emit_line_note (input_filename, lineno);
13141   expand_end_bindings (getdecls (), keep, 0);
13142   t = poplevel (keep, 1, 0);
13143
13144   return t;
13145 }
13146
13147 /* Return a definition for a builtin function named NAME and whose data type
13148    is TYPE.  TYPE should be a function type with argument types.
13149    FUNCTION_CODE tells later passes how to compile calls to this function.
13150    See tree.h for its possible values.
13151
13152    If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
13153    the name to be called if we can't opencode the function.  */
13154
13155 tree
13156 builtin_function (const char *name, tree type, int function_code,
13157                   enum built_in_class class,
13158                   const char *library_name)
13159 {
13160   tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type);
13161   DECL_EXTERNAL (decl) = 1;
13162   TREE_PUBLIC (decl) = 1;
13163   if (library_name)
13164     SET_DECL_ASSEMBLER_NAME (decl, get_identifier (library_name));
13165   make_decl_rtl (decl, NULL);
13166   pushdecl (decl);
13167   DECL_BUILT_IN_CLASS (decl) = class;
13168   DECL_FUNCTION_CODE (decl) = function_code;
13169
13170   return decl;
13171 }
13172
13173 /* Handle when a new declaration NEWDECL
13174    has the same name as an old one OLDDECL
13175    in the same binding contour.
13176    Prints an error message if appropriate.
13177
13178    If safely possible, alter OLDDECL to look like NEWDECL, and return 1.
13179    Otherwise, return 0.  */
13180
13181 static int
13182 duplicate_decls (tree newdecl, tree olddecl)
13183 {
13184   int types_match = 1;
13185   int new_is_definition = (TREE_CODE (newdecl) == FUNCTION_DECL
13186                            && DECL_INITIAL (newdecl) != 0);
13187   tree oldtype = TREE_TYPE (olddecl);
13188   tree newtype = TREE_TYPE (newdecl);
13189
13190   if (olddecl == newdecl)
13191     return 1;
13192
13193   if (TREE_CODE (newtype) == ERROR_MARK
13194       || TREE_CODE (oldtype) == ERROR_MARK)
13195     types_match = 0;
13196
13197   /* New decl is completely inconsistent with the old one =>
13198      tell caller to replace the old one.
13199      This is always an error except in the case of shadowing a builtin.  */
13200   if (TREE_CODE (olddecl) != TREE_CODE (newdecl))
13201     return 0;
13202
13203   /* For real parm decl following a forward decl,
13204      return 1 so old decl will be reused.  */
13205   if (types_match && TREE_CODE (newdecl) == PARM_DECL
13206       && TREE_ASM_WRITTEN (olddecl) && ! TREE_ASM_WRITTEN (newdecl))
13207     return 1;
13208
13209   /* The new declaration is the same kind of object as the old one.
13210      The declarations may partially match.  Print warnings if they don't
13211      match enough.  Ultimately, copy most of the information from the new
13212      decl to the old one, and keep using the old one.  */
13213
13214   if (TREE_CODE (olddecl) == FUNCTION_DECL
13215       && DECL_BUILT_IN (olddecl))
13216     {
13217       /* A function declaration for a built-in function.  */
13218       if (!TREE_PUBLIC (newdecl))
13219         return 0;
13220       else if (!types_match)
13221         {
13222           /* Accept the return type of the new declaration if same modes.  */
13223           tree oldreturntype = TREE_TYPE (TREE_TYPE (olddecl));
13224           tree newreturntype = TREE_TYPE (TREE_TYPE (newdecl));
13225
13226           if (TYPE_MODE (oldreturntype) == TYPE_MODE (newreturntype))
13227             {
13228               /* Function types may be shared, so we can't just modify
13229                  the return type of olddecl's function type.  */
13230               tree newtype
13231                 = build_function_type (newreturntype,
13232                                        TYPE_ARG_TYPES (TREE_TYPE (olddecl)));
13233
13234               types_match = 1;
13235               if (types_match)
13236                 TREE_TYPE (olddecl) = newtype;
13237             }
13238         }
13239       if (!types_match)
13240         return 0;
13241     }
13242   else if (TREE_CODE (olddecl) == FUNCTION_DECL
13243            && DECL_SOURCE_LINE (olddecl) == 0)
13244     {
13245       /* A function declaration for a predeclared function
13246          that isn't actually built in.  */
13247       if (!TREE_PUBLIC (newdecl))
13248         return 0;
13249       else if (!types_match)
13250         {
13251           /* If the types don't match, preserve volatility indication.
13252              Later on, we will discard everything else about the
13253              default declaration.  */
13254           TREE_THIS_VOLATILE (newdecl) |= TREE_THIS_VOLATILE (olddecl);
13255         }
13256     }
13257
13258   /* Copy all the DECL_... slots specified in the new decl
13259      except for any that we copy here from the old type.
13260
13261      Past this point, we don't change OLDTYPE and NEWTYPE
13262      even if we change the types of NEWDECL and OLDDECL.  */
13263
13264   if (types_match)
13265     {
13266       /* Merge the data types specified in the two decls.  */
13267       if (TREE_CODE (newdecl) != FUNCTION_DECL || !DECL_BUILT_IN (olddecl))
13268         TREE_TYPE (newdecl)
13269           = TREE_TYPE (olddecl)
13270             = TREE_TYPE (newdecl);
13271
13272       /* Lay the type out, unless already done.  */
13273       if (oldtype != TREE_TYPE (newdecl))
13274         {
13275           if (TREE_TYPE (newdecl) != error_mark_node)
13276             layout_type (TREE_TYPE (newdecl));
13277           if (TREE_CODE (newdecl) != FUNCTION_DECL
13278               && TREE_CODE (newdecl) != TYPE_DECL
13279               && TREE_CODE (newdecl) != CONST_DECL)
13280             layout_decl (newdecl, 0);
13281         }
13282       else
13283         {
13284           /* Since the type is OLDDECL's, make OLDDECL's size go with.  */
13285           DECL_SIZE (newdecl) = DECL_SIZE (olddecl);
13286           DECL_SIZE_UNIT (newdecl) = DECL_SIZE_UNIT (olddecl);
13287           if (TREE_CODE (olddecl) != FUNCTION_DECL)
13288             if (DECL_ALIGN (olddecl) > DECL_ALIGN (newdecl))
13289               {
13290                 DECL_ALIGN (newdecl) = DECL_ALIGN (olddecl);
13291                 DECL_USER_ALIGN (newdecl) |= DECL_USER_ALIGN (olddecl);
13292               }
13293         }
13294
13295       /* Keep the old rtl since we can safely use it.  */
13296       COPY_DECL_RTL (olddecl, newdecl);
13297
13298       /* Merge the type qualifiers.  */
13299       if (DECL_BUILT_IN_NONANSI (olddecl) && TREE_THIS_VOLATILE (olddecl)
13300           && !TREE_THIS_VOLATILE (newdecl))
13301         TREE_THIS_VOLATILE (olddecl) = 0;
13302       if (TREE_READONLY (newdecl))
13303         TREE_READONLY (olddecl) = 1;
13304       if (TREE_THIS_VOLATILE (newdecl))
13305         {
13306           TREE_THIS_VOLATILE (olddecl) = 1;
13307           if (TREE_CODE (newdecl) == VAR_DECL)
13308             make_var_volatile (newdecl);
13309         }
13310
13311       /* Keep source location of definition rather than declaration.
13312          Likewise, keep decl at outer scope.  */
13313       if ((DECL_INITIAL (newdecl) == 0 && DECL_INITIAL (olddecl) != 0)
13314           || (DECL_CONTEXT (newdecl) != 0 && DECL_CONTEXT (olddecl) == 0))
13315         {
13316           DECL_SOURCE_LINE (newdecl) = DECL_SOURCE_LINE (olddecl);
13317           DECL_SOURCE_FILE (newdecl) = DECL_SOURCE_FILE (olddecl);
13318
13319           if (DECL_CONTEXT (olddecl) == 0
13320               && TREE_CODE (newdecl) != FUNCTION_DECL)
13321             DECL_CONTEXT (newdecl) = 0;
13322         }
13323
13324       /* Merge the unused-warning information.  */
13325       if (DECL_IN_SYSTEM_HEADER (olddecl))
13326         DECL_IN_SYSTEM_HEADER (newdecl) = 1;
13327       else if (DECL_IN_SYSTEM_HEADER (newdecl))
13328         DECL_IN_SYSTEM_HEADER (olddecl) = 1;
13329
13330       /* Merge the initialization information.  */
13331       if (DECL_INITIAL (newdecl) == 0)
13332         DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13333
13334       /* Merge the section attribute.
13335          We want to issue an error if the sections conflict but that must be
13336          done later in decl_attributes since we are called before attributes
13337          are assigned.  */
13338       if (DECL_SECTION_NAME (newdecl) == NULL_TREE)
13339         DECL_SECTION_NAME (newdecl) = DECL_SECTION_NAME (olddecl);
13340
13341       if (TREE_CODE (newdecl) == FUNCTION_DECL)
13342         {
13343           DECL_STATIC_CONSTRUCTOR(newdecl) |= DECL_STATIC_CONSTRUCTOR(olddecl);
13344           DECL_STATIC_DESTRUCTOR (newdecl) |= DECL_STATIC_DESTRUCTOR (olddecl);
13345         }
13346     }
13347   /* If cannot merge, then use the new type and qualifiers,
13348      and don't preserve the old rtl.  */
13349   else
13350     {
13351       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13352       TREE_READONLY (olddecl) = TREE_READONLY (newdecl);
13353       TREE_THIS_VOLATILE (olddecl) = TREE_THIS_VOLATILE (newdecl);
13354       TREE_SIDE_EFFECTS (olddecl) = TREE_SIDE_EFFECTS (newdecl);
13355     }
13356
13357   /* Merge the storage class information.  */
13358   /* For functions, static overrides non-static.  */
13359   if (TREE_CODE (newdecl) == FUNCTION_DECL)
13360     {
13361       TREE_PUBLIC (newdecl) &= TREE_PUBLIC (olddecl);
13362       /* This is since we don't automatically
13363          copy the attributes of NEWDECL into OLDDECL.  */
13364       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13365       /* If this clears `static', clear it in the identifier too.  */
13366       if (! TREE_PUBLIC (olddecl))
13367         TREE_PUBLIC (DECL_NAME (olddecl)) = 0;
13368     }
13369   if (DECL_EXTERNAL (newdecl))
13370     {
13371       TREE_STATIC (newdecl) = TREE_STATIC (olddecl);
13372       DECL_EXTERNAL (newdecl) = DECL_EXTERNAL (olddecl);
13373       /* An extern decl does not override previous storage class.  */
13374       TREE_PUBLIC (newdecl) = TREE_PUBLIC (olddecl);
13375     }
13376   else
13377     {
13378       TREE_STATIC (olddecl) = TREE_STATIC (newdecl);
13379       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13380     }
13381
13382   /* If either decl says `inline', this fn is inline,
13383      unless its definition was passed already.  */
13384   if (DECL_INLINE (newdecl) && DECL_INITIAL (olddecl) == 0)
13385     DECL_INLINE (olddecl) = 1;
13386   DECL_INLINE (newdecl) = DECL_INLINE (olddecl);
13387
13388   /* Get rid of any built-in function if new arg types don't match it
13389      or if we have a function definition.  */
13390   if (TREE_CODE (newdecl) == FUNCTION_DECL
13391       && DECL_BUILT_IN (olddecl)
13392       && (!types_match || new_is_definition))
13393     {
13394       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13395       DECL_BUILT_IN_CLASS (olddecl) = NOT_BUILT_IN;
13396     }
13397
13398   /* If redeclaring a builtin function, and not a definition,
13399      it stays built in.
13400      Also preserve various other info from the definition.  */
13401   if (TREE_CODE (newdecl) == FUNCTION_DECL && !new_is_definition)
13402     {
13403       if (DECL_BUILT_IN (olddecl))
13404         {
13405           DECL_BUILT_IN_CLASS (newdecl) = DECL_BUILT_IN_CLASS (olddecl);
13406           DECL_FUNCTION_CODE (newdecl) = DECL_FUNCTION_CODE (olddecl);
13407         }
13408
13409       DECL_RESULT (newdecl) = DECL_RESULT (olddecl);
13410       DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13411       DECL_SAVED_INSNS (newdecl) = DECL_SAVED_INSNS (olddecl);
13412       DECL_ARGUMENTS (newdecl) = DECL_ARGUMENTS (olddecl);
13413     }
13414
13415   /* Copy most of the decl-specific fields of NEWDECL into OLDDECL.
13416      But preserve olddecl's DECL_UID.  */
13417   {
13418     register unsigned olddecl_uid = DECL_UID (olddecl);
13419
13420     memcpy ((char *) olddecl + sizeof (struct tree_common),
13421             (char *) newdecl + sizeof (struct tree_common),
13422             sizeof (struct tree_decl) - sizeof (struct tree_common));
13423     DECL_UID (olddecl) = olddecl_uid;
13424   }
13425
13426   return 1;
13427 }
13428
13429 /* Finish processing of a declaration;
13430    install its initial value.
13431    If the length of an array type is not known before,
13432    it must be determined now, from the initial value, or it is an error.  */
13433
13434 static void
13435 finish_decl (tree decl, tree init, bool is_top_level)
13436 {
13437   register tree type = TREE_TYPE (decl);
13438   int was_incomplete = (DECL_SIZE (decl) == 0);
13439   bool at_top_level = (current_binding_level == global_binding_level);
13440   bool top_level = is_top_level || at_top_level;
13441
13442   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13443      level anyway.  */
13444   assert (!is_top_level || !at_top_level);
13445
13446   if (TREE_CODE (decl) == PARM_DECL)
13447     assert (init == NULL_TREE);
13448   /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it
13449      overlaps DECL_ARG_TYPE.  */
13450   else if (init == NULL_TREE)
13451     assert (DECL_INITIAL (decl) == NULL_TREE);
13452   else
13453     assert (DECL_INITIAL (decl) == error_mark_node);
13454
13455   if (init != NULL_TREE)
13456     {
13457       if (TREE_CODE (decl) != TYPE_DECL)
13458         DECL_INITIAL (decl) = init;
13459       else
13460         {
13461           /* typedef foo = bar; store the type of bar as the type of foo.  */
13462           TREE_TYPE (decl) = TREE_TYPE (init);
13463           DECL_INITIAL (decl) = init = 0;
13464         }
13465     }
13466
13467   /* Deduce size of array from initialization, if not already known */
13468
13469   if (TREE_CODE (type) == ARRAY_TYPE
13470       && TYPE_DOMAIN (type) == 0
13471       && TREE_CODE (decl) != TYPE_DECL)
13472     {
13473       assert (top_level);
13474       assert (was_incomplete);
13475
13476       layout_decl (decl, 0);
13477     }
13478
13479   if (TREE_CODE (decl) == VAR_DECL)
13480     {
13481       if (DECL_SIZE (decl) == NULL_TREE
13482           && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
13483         layout_decl (decl, 0);
13484
13485       if (DECL_SIZE (decl) == NULL_TREE
13486           && (TREE_STATIC (decl)
13487               ?
13488       /* A static variable with an incomplete type is an error if it is
13489          initialized. Also if it is not file scope. Otherwise, let it
13490          through, but if it is not `extern' then it may cause an error
13491          message later.  */
13492               (DECL_INITIAL (decl) != 0 || DECL_CONTEXT (decl) != 0)
13493               :
13494       /* An automatic variable with an incomplete type is an error.  */
13495               !DECL_EXTERNAL (decl)))
13496         {
13497           assert ("storage size not known" == NULL);
13498           abort ();
13499         }
13500
13501       if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl))
13502           && (DECL_SIZE (decl) != 0)
13503           && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST))
13504         {
13505           assert ("storage size not constant" == NULL);
13506           abort ();
13507         }
13508     }
13509
13510   /* Output the assembler code and/or RTL code for variables and functions,
13511      unless the type is an undefined structure or union. If not, it will get
13512      done when the type is completed.  */
13513
13514   if (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == FUNCTION_DECL)
13515     {
13516       rest_of_decl_compilation (decl, NULL,
13517                                 DECL_CONTEXT (decl) == 0,
13518                                 0);
13519
13520       if (DECL_CONTEXT (decl) != 0)
13521         {
13522           /* Recompute the RTL of a local array now if it used to be an
13523              incomplete type.  */
13524           if (was_incomplete
13525               && !TREE_STATIC (decl) && !DECL_EXTERNAL (decl))
13526             {
13527               /* If we used it already as memory, it must stay in memory.  */
13528               TREE_ADDRESSABLE (decl) = TREE_USED (decl);
13529               /* If it's still incomplete now, no init will save it.  */
13530               if (DECL_SIZE (decl) == 0)
13531                 DECL_INITIAL (decl) = 0;
13532               expand_decl (decl);
13533             }
13534           /* Compute and store the initial value.  */
13535           if (TREE_CODE (decl) != FUNCTION_DECL)
13536             expand_decl_init (decl);
13537         }
13538     }
13539   else if (TREE_CODE (decl) == TYPE_DECL)
13540     {
13541       rest_of_decl_compilation (decl, NULL,
13542                                 DECL_CONTEXT (decl) == 0,
13543                                 0);
13544     }
13545
13546   /* At the end of a declaration, throw away any variable type sizes of types
13547      defined inside that declaration.  There is no use computing them in the
13548      following function definition.  */
13549   if (current_binding_level == global_binding_level)
13550     get_pending_sizes ();
13551 }
13552
13553 /* Finish up a function declaration and compile that function
13554    all the way to assembler language output.  The free the storage
13555    for the function definition.
13556
13557    This is called after parsing the body of the function definition.
13558
13559    NESTED is nonzero if the function being finished is nested in another.  */
13560
13561 static void
13562 finish_function (int nested)
13563 {
13564   register tree fndecl = current_function_decl;
13565
13566   assert (fndecl != NULL_TREE);
13567   if (TREE_CODE (fndecl) != ERROR_MARK)
13568     {
13569       if (nested)
13570         assert (DECL_CONTEXT (fndecl) != NULL_TREE);
13571       else
13572         assert (DECL_CONTEXT (fndecl) == NULL_TREE);
13573     }
13574
13575 /*  TREE_READONLY (fndecl) = 1;
13576     This caused &foo to be of type ptr-to-const-function
13577     which then got a warning when stored in a ptr-to-function variable.  */
13578
13579   poplevel (1, 0, 1);
13580
13581   if (TREE_CODE (fndecl) != ERROR_MARK)
13582     {
13583       BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
13584
13585       /* Must mark the RESULT_DECL as being in this function.  */
13586
13587       DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl;
13588
13589       /* Obey `register' declarations if `setjmp' is called in this fn.  */
13590       /* Generate rtl for function exit.  */
13591       expand_function_end (input_filename, lineno, 0);
13592
13593       /* If this is a nested function, protect the local variables in the stack
13594          above us from being collected while we're compiling this function.  */
13595       if (nested)
13596         ggc_push_context ();
13597
13598       /* Run the optimizers and output the assembler code for this function.  */
13599       rest_of_compilation (fndecl);
13600
13601       /* Undo the GC context switch.  */
13602       if (nested)
13603         ggc_pop_context ();
13604     }
13605
13606   if (TREE_CODE (fndecl) != ERROR_MARK
13607       && !nested
13608       && DECL_SAVED_INSNS (fndecl) == 0)
13609     {
13610       /* Stop pointing to the local nodes about to be freed.  */
13611       /* But DECL_INITIAL must remain nonzero so we know this was an actual
13612          function definition.  */
13613       /* For a nested function, this is done in pop_f_function_context.  */
13614       /* If rest_of_compilation set this to 0, leave it 0.  */
13615       if (DECL_INITIAL (fndecl) != 0)
13616         DECL_INITIAL (fndecl) = error_mark_node;
13617       DECL_ARGUMENTS (fndecl) = 0;
13618     }
13619
13620   if (!nested)
13621     {
13622       /* Let the error reporting routines know that we're outside a function.
13623          For a nested function, this value is used in pop_c_function_context
13624          and then reset via pop_function_context.  */
13625       ffecom_outer_function_decl_ = current_function_decl = NULL;
13626     }
13627 }
13628
13629 /* Plug-in replacement for identifying the name of a decl and, for a
13630    function, what we call it in diagnostics.  For now, "program unit"
13631    should suffice, since it's a bit of a hassle to figure out which
13632    of several kinds of things it is.  Note that it could conceivably
13633    be a statement function, which probably isn't really a program unit
13634    per se, but if that comes up, it should be easy to check (being a
13635    nested function and all).  */
13636
13637 static const char *
13638 ffe_printable_name (tree decl, int v)
13639 {
13640   /* Just to keep GCC quiet about the unused variable.
13641      In theory, differing values of V should produce different
13642      output.  */
13643   switch (v)
13644     {
13645     default:
13646       if (TREE_CODE (decl) == ERROR_MARK)
13647         return "erroneous code";
13648       return IDENTIFIER_POINTER (DECL_NAME (decl));
13649     }
13650 }
13651
13652 /* g77's function to print out name of current function that caused
13653    an error.  */
13654
13655 static void
13656 lang_print_error_function (diagnostic_context *context __attribute__((unused)),
13657                            const char *file)
13658 {
13659   static ffeglobal last_g = NULL;
13660   static ffesymbol last_s = NULL;
13661   ffeglobal g;
13662   ffesymbol s;
13663   const char *kind;
13664
13665   if ((ffecom_primary_entry_ == NULL)
13666       || (ffesymbol_global (ffecom_primary_entry_) == NULL))
13667     {
13668       g = NULL;
13669       s = NULL;
13670       kind = NULL;
13671     }
13672   else
13673     {
13674       g = ffesymbol_global (ffecom_primary_entry_);
13675       if (ffecom_nested_entry_ == NULL)
13676         {
13677           s = ffecom_primary_entry_;
13678           kind = _(ffeinfo_kind_message (ffesymbol_kind (s)));
13679         }
13680       else
13681         {
13682           s = ffecom_nested_entry_;
13683           kind = _("In statement function");
13684         }
13685     }
13686
13687   if ((last_g != g) || (last_s != s))
13688     {
13689       if (file)
13690         fprintf (stderr, "%s: ", file);
13691
13692       if (s == NULL)
13693         fprintf (stderr, _("Outside of any program unit:\n"));
13694       else
13695         {
13696           const char *name = ffesymbol_text (s);
13697
13698           fprintf (stderr, "%s `%s':\n", kind, name);
13699         }
13700
13701       last_g = g;
13702       last_s = s;
13703     }
13704 }
13705
13706 /* Similar to `lookup_name' but look only at current binding level.  */
13707
13708 static tree
13709 lookup_name_current_level (tree name)
13710 {
13711   register tree t;
13712
13713   if (current_binding_level == global_binding_level)
13714     return IDENTIFIER_GLOBAL_VALUE (name);
13715
13716   if (IDENTIFIER_LOCAL_VALUE (name) == 0)
13717     return 0;
13718
13719   for (t = current_binding_level->names; t; t = TREE_CHAIN (t))
13720     if (DECL_NAME (t) == name)
13721       break;
13722
13723   return t;
13724 }
13725
13726 /* Create a new `struct binding_level'.  */
13727
13728 static struct binding_level *
13729 make_binding_level ()
13730 {
13731   /* NOSTRICT */
13732   return (struct binding_level *) xmalloc (sizeof (struct binding_level));
13733 }
13734
13735 /* Save and restore the variables in this file and elsewhere
13736    that keep track of the progress of compilation of the current function.
13737    Used for nested functions.  */
13738
13739 struct f_function
13740 {
13741   struct f_function *next;
13742   tree named_labels;
13743   tree shadowed_labels;
13744   struct binding_level *binding_level;
13745 };
13746
13747 struct f_function *f_function_chain;
13748
13749 /* Restore the variables used during compilation of a C function.  */
13750
13751 static void
13752 pop_f_function_context ()
13753 {
13754   struct f_function *p = f_function_chain;
13755   tree link;
13756
13757   /* Bring back all the labels that were shadowed.  */
13758   for (link = shadowed_labels; link; link = TREE_CHAIN (link))
13759     if (DECL_NAME (TREE_VALUE (link)) != 0)
13760       IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link)))
13761         = TREE_VALUE (link);
13762
13763   if (current_function_decl != error_mark_node
13764       && DECL_SAVED_INSNS (current_function_decl) == 0)
13765     {
13766       /* Stop pointing to the local nodes about to be freed.  */
13767       /* But DECL_INITIAL must remain nonzero so we know this was an actual
13768          function definition.  */
13769       DECL_INITIAL (current_function_decl) = error_mark_node;
13770       DECL_ARGUMENTS (current_function_decl) = 0;
13771     }
13772
13773   pop_function_context ();
13774
13775   f_function_chain = p->next;
13776
13777   named_labels = p->named_labels;
13778   shadowed_labels = p->shadowed_labels;
13779   current_binding_level = p->binding_level;
13780
13781   free (p);
13782 }
13783
13784 /* Save and reinitialize the variables
13785    used during compilation of a C function.  */
13786
13787 static void
13788 push_f_function_context ()
13789 {
13790   struct f_function *p
13791   = (struct f_function *) xmalloc (sizeof (struct f_function));
13792
13793   push_function_context ();
13794
13795   p->next = f_function_chain;
13796   f_function_chain = p;
13797
13798   p->named_labels = named_labels;
13799   p->shadowed_labels = shadowed_labels;
13800   p->binding_level = current_binding_level;
13801 }
13802
13803 static void
13804 push_parm_decl (tree parm)
13805 {
13806   int old_immediate_size_expand = immediate_size_expand;
13807
13808   /* Don't try computing parm sizes now -- wait till fn is called.  */
13809
13810   immediate_size_expand = 0;
13811
13812   /* Fill in arg stuff.  */
13813
13814   DECL_ARG_TYPE (parm) = TREE_TYPE (parm);
13815   DECL_ARG_TYPE_AS_WRITTEN (parm) = TREE_TYPE (parm);
13816   TREE_READONLY (parm) = 1;     /* All implementation args are read-only. */
13817
13818   parm = pushdecl (parm);
13819
13820   immediate_size_expand = old_immediate_size_expand;
13821
13822   finish_decl (parm, NULL_TREE, FALSE);
13823 }
13824
13825 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate.  */
13826
13827 static tree
13828 pushdecl_top_level (x)
13829      tree x;
13830 {
13831   register tree t;
13832   register struct binding_level *b = current_binding_level;
13833   register tree f = current_function_decl;
13834
13835   current_binding_level = global_binding_level;
13836   current_function_decl = NULL_TREE;
13837   t = pushdecl (x);
13838   current_binding_level = b;
13839   current_function_decl = f;
13840   return t;
13841 }
13842
13843 /* Store the list of declarations of the current level.
13844    This is done for the parameter declarations of a function being defined,
13845    after they are modified in the light of any missing parameters.  */
13846
13847 static tree
13848 storedecls (decls)
13849      tree decls;
13850 {
13851   return current_binding_level->names = decls;
13852 }
13853
13854 /* Store the parameter declarations into the current function declaration.
13855    This is called after parsing the parameter declarations, before
13856    digesting the body of the function.
13857
13858    For an old-style definition, modify the function's type
13859    to specify at least the number of arguments.  */
13860
13861 static void
13862 store_parm_decls (int is_main_program UNUSED)
13863 {
13864   register tree fndecl = current_function_decl;
13865
13866   if (fndecl == error_mark_node)
13867     return;
13868
13869   /* This is a chain of PARM_DECLs from old-style parm declarations.  */
13870   DECL_ARGUMENTS (fndecl) = storedecls (nreverse (getdecls ()));
13871
13872   /* Initialize the RTL code for the function.  */
13873
13874   init_function_start (fndecl, input_filename, lineno);
13875
13876   /* Set up parameters and prepare for return, for the function.  */
13877
13878   expand_function_start (fndecl, 0);
13879 }
13880
13881 static tree
13882 start_decl (tree decl, bool is_top_level)
13883 {
13884   register tree tem;
13885   bool at_top_level = (current_binding_level == global_binding_level);
13886   bool top_level = is_top_level || at_top_level;
13887
13888   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13889      level anyway.  */
13890   assert (!is_top_level || !at_top_level);
13891
13892   if (DECL_INITIAL (decl) != NULL_TREE)
13893     {
13894       assert (DECL_INITIAL (decl) == error_mark_node);
13895       assert (!DECL_EXTERNAL (decl));
13896     }
13897   else if (top_level)
13898     assert ((TREE_STATIC (decl) == 1) || DECL_EXTERNAL (decl) == 1);
13899
13900   /* For Fortran, we by default put things in .common when possible.  */
13901   DECL_COMMON (decl) = 1;
13902
13903   /* Add this decl to the current binding level. TEM may equal DECL or it may
13904      be a previous decl of the same name.  */
13905   if (is_top_level)
13906     tem = pushdecl_top_level (decl);
13907   else
13908     tem = pushdecl (decl);
13909
13910   /* For a local variable, define the RTL now.  */
13911   if (!top_level
13912   /* But not if this is a duplicate decl and we preserved the rtl from the
13913      previous one (which may or may not happen).  */
13914       && !DECL_RTL_SET_P (tem))
13915     {
13916       if (TYPE_SIZE (TREE_TYPE (tem)) != 0)
13917         expand_decl (tem);
13918       else if (TREE_CODE (TREE_TYPE (tem)) == ARRAY_TYPE
13919                && DECL_INITIAL (tem) != 0)
13920         expand_decl (tem);
13921     }
13922
13923   return tem;
13924 }
13925
13926 /* Create the FUNCTION_DECL for a function definition.
13927    DECLSPECS and DECLARATOR are the parts of the declaration;
13928    they describe the function's name and the type it returns,
13929    but twisted together in a fashion that parallels the syntax of C.
13930
13931    This function creates a binding context for the function body
13932    as well as setting up the FUNCTION_DECL in current_function_decl.
13933
13934    Returns 1 on success.  If the DECLARATOR is not suitable for a function
13935    (it defines a datum instead), we return 0, which tells
13936    ffe_parse_file to report a parse error.
13937
13938    NESTED is nonzero for a function nested within another function.  */
13939
13940 static void
13941 start_function (tree name, tree type, int nested, int public)
13942 {
13943   tree decl1;
13944   tree restype;
13945   int old_immediate_size_expand = immediate_size_expand;
13946
13947   named_labels = 0;
13948   shadowed_labels = 0;
13949
13950   /* Don't expand any sizes in the return type of the function.  */
13951   immediate_size_expand = 0;
13952
13953   if (nested)
13954     {
13955       assert (!public);
13956       assert (current_function_decl != NULL_TREE);
13957       assert (DECL_CONTEXT (current_function_decl) == NULL_TREE);
13958     }
13959   else
13960     {
13961       assert (current_function_decl == NULL_TREE);
13962     }
13963
13964   if (TREE_CODE (type) == ERROR_MARK)
13965     decl1 = current_function_decl = error_mark_node;
13966   else
13967     {
13968       decl1 = build_decl (FUNCTION_DECL,
13969                           name,
13970                           type);
13971       TREE_PUBLIC (decl1) = public ? 1 : 0;
13972       if (nested)
13973         DECL_INLINE (decl1) = 1;
13974       TREE_STATIC (decl1) = 1;
13975       DECL_EXTERNAL (decl1) = 0;
13976
13977       announce_function (decl1);
13978
13979       /* Make the init_value nonzero so pushdecl knows this is not tentative.
13980          error_mark_node is replaced below (in poplevel) with the BLOCK.  */
13981       DECL_INITIAL (decl1) = error_mark_node;
13982
13983       /* Record the decl so that the function name is defined. If we already have
13984          a decl for this name, and it is a FUNCTION_DECL, use the old decl.  */
13985
13986       current_function_decl = pushdecl (decl1);
13987     }
13988
13989   if (!nested)
13990     ffecom_outer_function_decl_ = current_function_decl;
13991
13992   pushlevel (0);
13993   current_binding_level->prep_state = 2;
13994
13995   if (TREE_CODE (current_function_decl) != ERROR_MARK)
13996     {
13997       make_decl_rtl (current_function_decl, NULL);
13998
13999       restype = TREE_TYPE (TREE_TYPE (current_function_decl));
14000       DECL_RESULT (current_function_decl)
14001         = build_decl (RESULT_DECL, NULL_TREE, restype);
14002     }
14003
14004   if (!nested && (TREE_CODE (current_function_decl) != ERROR_MARK))
14005     TREE_ADDRESSABLE (current_function_decl) = 1;
14006
14007   immediate_size_expand = old_immediate_size_expand;
14008 }
14009 \f
14010 /* Here are the public functions the GNU back end needs.  */
14011
14012 tree
14013 convert (type, expr)
14014      tree type, expr;
14015 {
14016   register tree e = expr;
14017   register enum tree_code code = TREE_CODE (type);
14018
14019   if (type == TREE_TYPE (e)
14020       || TREE_CODE (e) == ERROR_MARK)
14021     return e;
14022   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
14023     return fold (build1 (NOP_EXPR, type, e));
14024   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
14025       || code == ERROR_MARK)
14026     return error_mark_node;
14027   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
14028     {
14029       assert ("void value not ignored as it ought to be" == NULL);
14030       return error_mark_node;
14031     }
14032   if (code == VOID_TYPE)
14033     return build1 (CONVERT_EXPR, type, e);
14034   if ((code != RECORD_TYPE)
14035       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
14036     e = ffecom_1 (REALPART_EXPR, TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e))),
14037                   e);
14038   if (code == INTEGER_TYPE || code == ENUMERAL_TYPE)
14039     return fold (convert_to_integer (type, e));
14040   if (code == POINTER_TYPE)
14041     return fold (convert_to_pointer (type, e));
14042   if (code == REAL_TYPE)
14043     return fold (convert_to_real (type, e));
14044   if (code == COMPLEX_TYPE)
14045     return fold (convert_to_complex (type, e));
14046   if (code == RECORD_TYPE)
14047     return fold (ffecom_convert_to_complex_ (type, e));
14048
14049   assert ("conversion to non-scalar type requested" == NULL);
14050   return error_mark_node;
14051 }
14052
14053 /* Return the list of declarations of the current level.
14054    Note that this list is in reverse order unless/until
14055    you nreverse it; and when you do nreverse it, you must
14056    store the result back using `storedecls' or you will lose.  */
14057
14058 tree
14059 getdecls ()
14060 {
14061   return current_binding_level->names;
14062 }
14063
14064 /* Nonzero if we are currently in the global binding level.  */
14065
14066 int
14067 global_bindings_p ()
14068 {
14069   return current_binding_level == global_binding_level;
14070 }
14071
14072 /* Print an error message for invalid use of an incomplete type.
14073    VALUE is the expression that was used (or 0 if that isn't known)
14074    and TYPE is the type that was invalid.  */
14075
14076 void
14077 incomplete_type_error (value, type)
14078      tree value UNUSED;
14079      tree type;
14080 {
14081   if (TREE_CODE (type) == ERROR_MARK)
14082     return;
14083
14084   assert ("incomplete type?!?" == NULL);
14085 }
14086
14087 /* Mark ARG for GC.  */
14088 static void
14089 mark_binding_level (void *arg)
14090 {
14091   struct binding_level *level = *(struct binding_level **) arg;
14092
14093   while (level)
14094     {
14095       ggc_mark_tree (level->names);
14096       ggc_mark_tree (level->blocks);
14097       ggc_mark_tree (level->this_block);
14098       level = level->level_chain;
14099     }
14100 }
14101
14102 static void
14103 ffecom_init_decl_processing ()
14104 {
14105   static tree *const tree_roots[] = {
14106     &current_function_decl,
14107     &string_type_node,
14108     &ffecom_tree_fun_type_void,
14109     &ffecom_integer_zero_node,
14110     &ffecom_integer_one_node,
14111     &ffecom_tree_subr_type,
14112     &ffecom_tree_ptr_to_subr_type,
14113     &ffecom_tree_blockdata_type,
14114     &ffecom_tree_xargc_,
14115     &ffecom_f2c_integer_type_node,
14116     &ffecom_f2c_ptr_to_integer_type_node,
14117     &ffecom_f2c_address_type_node,
14118     &ffecom_f2c_real_type_node,
14119     &ffecom_f2c_ptr_to_real_type_node,
14120     &ffecom_f2c_doublereal_type_node,
14121     &ffecom_f2c_complex_type_node,
14122     &ffecom_f2c_doublecomplex_type_node,
14123     &ffecom_f2c_longint_type_node,
14124     &ffecom_f2c_logical_type_node,
14125     &ffecom_f2c_flag_type_node,
14126     &ffecom_f2c_ftnlen_type_node,
14127     &ffecom_f2c_ftnlen_zero_node,
14128     &ffecom_f2c_ftnlen_one_node,
14129     &ffecom_f2c_ftnlen_two_node,
14130     &ffecom_f2c_ptr_to_ftnlen_type_node,
14131     &ffecom_f2c_ftnint_type_node,
14132     &ffecom_f2c_ptr_to_ftnint_type_node,
14133     &ffecom_outer_function_decl_,
14134     &ffecom_previous_function_decl_,
14135     &ffecom_which_entrypoint_decl_,
14136     &ffecom_float_zero_,
14137     &ffecom_float_half_,
14138     &ffecom_double_zero_,
14139     &ffecom_double_half_,
14140     &ffecom_func_result_,
14141     &ffecom_func_length_,
14142     &ffecom_multi_type_node_,
14143     &ffecom_multi_retval_,
14144     &named_labels,
14145     &shadowed_labels
14146   };
14147   size_t i;
14148
14149   malloc_init ();
14150
14151   /* Record our roots.  */
14152   for (i = 0; i < ARRAY_SIZE (tree_roots); i++)
14153     ggc_add_tree_root (tree_roots[i], 1);
14154   ggc_add_tree_root (&ffecom_tree_type[0][0],
14155                      FFEINFO_basictype*FFEINFO_kindtype);
14156   ggc_add_tree_root (&ffecom_tree_fun_type[0][0],
14157                      FFEINFO_basictype*FFEINFO_kindtype);
14158   ggc_add_tree_root (&ffecom_tree_ptr_to_fun_type[0][0],
14159                      FFEINFO_basictype*FFEINFO_kindtype);
14160   ggc_add_tree_root (ffecom_gfrt_, FFECOM_gfrt);
14161   ggc_add_root (&current_binding_level, 1, sizeof current_binding_level,
14162                 mark_binding_level);
14163   ggc_add_root (&free_binding_level, 1, sizeof current_binding_level,
14164                 mark_binding_level);
14165   ggc_add_root (&tracker_head, 1, sizeof tracker_head, mark_tracker_head);
14166
14167   ffe_init_0 ();
14168 }
14169
14170 /* Delete the node BLOCK from the current binding level.
14171    This is used for the block inside a stmt expr ({...})
14172    so that the block can be reinserted where appropriate.  */
14173
14174 static void
14175 delete_block (block)
14176      tree block;
14177 {
14178   tree t;
14179   if (current_binding_level->blocks == block)
14180     current_binding_level->blocks = TREE_CHAIN (block);
14181   for (t = current_binding_level->blocks; t;)
14182     {
14183       if (TREE_CHAIN (t) == block)
14184         TREE_CHAIN (t) = TREE_CHAIN (block);
14185       else
14186         t = TREE_CHAIN (t);
14187     }
14188   TREE_CHAIN (block) = NULL;
14189   /* Clear TREE_USED which is always set by poplevel.
14190      The flag is set again if insert_block is called.  */
14191   TREE_USED (block) = 0;
14192 }
14193
14194 void
14195 insert_block (block)
14196      tree block;
14197 {
14198   TREE_USED (block) = 1;
14199   current_binding_level->blocks
14200     = chainon (current_binding_level->blocks, block);
14201 }
14202
14203 /* Each front end provides its own.  */
14204 static const char *ffe_init PARAMS ((const char *));
14205 static void ffe_finish PARAMS ((void));
14206 static void ffe_init_options PARAMS ((void));
14207 static void ffe_print_identifier PARAMS ((FILE *, tree, int));
14208
14209 #undef  LANG_HOOKS_NAME
14210 #define LANG_HOOKS_NAME                 "GNU F77"
14211 #undef  LANG_HOOKS_INIT
14212 #define LANG_HOOKS_INIT                 ffe_init
14213 #undef  LANG_HOOKS_FINISH
14214 #define LANG_HOOKS_FINISH               ffe_finish
14215 #undef  LANG_HOOKS_INIT_OPTIONS
14216 #define LANG_HOOKS_INIT_OPTIONS         ffe_init_options
14217 #undef  LANG_HOOKS_DECODE_OPTION
14218 #define LANG_HOOKS_DECODE_OPTION        ffe_decode_option
14219 #undef  LANG_HOOKS_PARSE_FILE
14220 #define LANG_HOOKS_PARSE_FILE           ffe_parse_file
14221 #undef  LANG_HOOKS_PRINT_IDENTIFIER
14222 #define LANG_HOOKS_PRINT_IDENTIFIER     ffe_print_identifier
14223 #undef  LANG_HOOKS_DECL_PRINTABLE_NAME
14224 #define LANG_HOOKS_DECL_PRINTABLE_NAME  ffe_printable_name
14225
14226 /* We do not wish to use alias-set based aliasing at all.  Used in the
14227    extreme (every object with its own set, with equivalences recorded) it
14228    might be helpful, but there are problems when it comes to inlining.  We
14229    get on ok with flag_argument_noalias, and alias-set aliasing does
14230    currently limit how stack slots can be reused, which is a lose.  */
14231 #undef LANG_HOOKS_GET_ALIAS_SET
14232 #define LANG_HOOKS_GET_ALIAS_SET hook_get_alias_set_0
14233
14234 const struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER;
14235
14236 /* Table indexed by tree code giving a string containing a character
14237    classifying the tree code.  Possibilities are
14238    t, d, s, c, r, <, 1, 2 and e.  See tree.def for details.  */
14239
14240 #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) TYPE,
14241
14242 const char tree_code_type[] = {
14243 #include "tree.def"
14244 };
14245 #undef DEFTREECODE
14246
14247 /* Table indexed by tree code giving number of expression
14248    operands beyond the fixed part of the node structure.
14249    Not used for types or decls.  */
14250
14251 #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) LENGTH,
14252
14253 const unsigned char tree_code_length[] = {
14254 #include "tree.def"
14255 };
14256 #undef DEFTREECODE
14257
14258 /* Names of tree components.
14259    Used for printing out the tree and error messages.  */
14260 #define DEFTREECODE(SYM, NAME, TYPE, LEN) NAME,
14261
14262 const char *const tree_code_name[] = {
14263 #include "tree.def"
14264 };
14265 #undef DEFTREECODE
14266
14267 static const char *
14268 ffe_init (filename)
14269      const char *filename;
14270 {
14271   /* Open input file.  */
14272   if (filename == 0 || !strcmp (filename, "-"))
14273     {
14274       finput = stdin;
14275       filename = "stdin";
14276     }
14277   else
14278     finput = fopen (filename, "r");
14279   if (finput == 0)
14280     fatal_io_error ("can't open %s", filename);
14281
14282 #ifdef IO_BUFFER_SIZE
14283   setvbuf (finput, (char *) xmalloc (IO_BUFFER_SIZE), _IOFBF, IO_BUFFER_SIZE);
14284 #endif
14285
14286   ffecom_init_decl_processing ();
14287   print_error_function = lang_print_error_function;
14288
14289   /* If the file is output from cpp, it should contain a first line
14290      `# 1 "real-filename"', and the current design of gcc (toplev.c
14291      in particular and the way it sets up information relied on by
14292      INCLUDE) requires that we read this now, and store the
14293      "real-filename" info in master_input_filename.  Ask the lexer
14294      to try doing this.  */
14295   ffelex_hash_kludge (finput);
14296
14297   /* FIXME: The ffelex_hash_kludge code needs to be cleaned up to
14298      return the new file name.  */
14299   if (main_input_filename)
14300     filename = main_input_filename;
14301
14302   return filename;
14303 }
14304
14305 static void
14306 ffe_finish ()
14307 {
14308   ffe_terminate_0 ();
14309
14310   if (ffe_is_ffedebug ())
14311     malloc_pool_display (malloc_pool_image ());
14312
14313   fclose (finput);
14314 }
14315
14316 static void
14317 ffe_init_options ()
14318 {
14319   /* Set default options for Fortran.  */
14320   flag_move_all_movables = 1;
14321   flag_reduce_all_givs = 1;
14322   flag_argument_noalias = 2;
14323   flag_merge_constants = 2;
14324   flag_errno_math = 0;
14325   flag_complex_divide_method = 1;
14326 }
14327
14328 int
14329 mark_addressable (exp)
14330      tree exp;
14331 {
14332   register tree x = exp;
14333   while (1)
14334     switch (TREE_CODE (x))
14335       {
14336       case ADDR_EXPR:
14337       case COMPONENT_REF:
14338       case ARRAY_REF:
14339         x = TREE_OPERAND (x, 0);
14340         break;
14341
14342       case CONSTRUCTOR:
14343         TREE_ADDRESSABLE (x) = 1;
14344         return 1;
14345
14346       case VAR_DECL:
14347       case CONST_DECL:
14348       case PARM_DECL:
14349       case RESULT_DECL:
14350         if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x)
14351             && DECL_NONLOCAL (x))
14352           {
14353             if (TREE_PUBLIC (x))
14354               {
14355                 assert ("address of global register var requested" == NULL);
14356                 return 0;
14357               }
14358             assert ("address of register variable requested" == NULL);
14359           }
14360         else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x))
14361           {
14362             if (TREE_PUBLIC (x))
14363               {
14364                 assert ("address of global register var requested" == NULL);
14365                 return 0;
14366               }
14367             assert ("address of register var requested" == NULL);
14368           }
14369         put_var_into_stack (x);
14370
14371         /* drops in */
14372       case FUNCTION_DECL:
14373         TREE_ADDRESSABLE (x) = 1;
14374 #if 0                           /* poplevel deals with this now.  */
14375         if (DECL_CONTEXT (x) == 0)
14376           TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x)) = 1;
14377 #endif
14378
14379       default:
14380         return 1;
14381       }
14382 }
14383
14384 /* Exit a binding level.
14385    Pop the level off, and restore the state of the identifier-decl mappings
14386    that were in effect when this level was entered.
14387
14388    If KEEP is nonzero, this level had explicit declarations, so
14389    and create a "block" (a BLOCK node) for the level
14390    to record its declarations and subblocks for symbol table output.
14391
14392    If FUNCTIONBODY is nonzero, this level is the body of a function,
14393    so create a block as if KEEP were set and also clear out all
14394    label names.
14395
14396    If REVERSE is nonzero, reverse the order of decls before putting
14397    them into the BLOCK.  */
14398
14399 tree
14400 poplevel (keep, reverse, functionbody)
14401      int keep;
14402      int reverse;
14403      int functionbody;
14404 {
14405   register tree link;
14406   /* The chain of decls was accumulated in reverse order.
14407      Put it into forward order, just for cleanliness.  */
14408   tree decls;
14409   tree subblocks = current_binding_level->blocks;
14410   tree block = 0;
14411   tree decl;
14412   int block_previously_created;
14413
14414   /* Get the decls in the order they were written.
14415      Usually current_binding_level->names is in reverse order.
14416      But parameter decls were previously put in forward order.  */
14417
14418   if (reverse)
14419     current_binding_level->names
14420       = decls = nreverse (current_binding_level->names);
14421   else
14422     decls = current_binding_level->names;
14423
14424   /* Output any nested inline functions within this block
14425      if they weren't already output.  */
14426
14427   for (decl = decls; decl; decl = TREE_CHAIN (decl))
14428     if (TREE_CODE (decl) == FUNCTION_DECL
14429         && ! TREE_ASM_WRITTEN (decl)
14430         && DECL_INITIAL (decl) != 0
14431         && TREE_ADDRESSABLE (decl))
14432       {
14433         /* If this decl was copied from a file-scope decl
14434            on account of a block-scope extern decl,
14435            propagate TREE_ADDRESSABLE to the file-scope decl.
14436
14437            DECL_ABSTRACT_ORIGIN can be set to itself if warn_return_type is
14438            true, since then the decl goes through save_for_inline_copying.  */
14439         if (DECL_ABSTRACT_ORIGIN (decl) != 0
14440             && DECL_ABSTRACT_ORIGIN (decl) != decl)
14441           TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl)) = 1;
14442         else if (DECL_SAVED_INSNS (decl) != 0)
14443           {
14444             push_function_context ();
14445             output_inline_function (decl);
14446             pop_function_context ();
14447           }
14448       }
14449
14450   /* If there were any declarations or structure tags in that level,
14451      or if this level is a function body,
14452      create a BLOCK to record them for the life of this function.  */
14453
14454   block = 0;
14455   block_previously_created = (current_binding_level->this_block != 0);
14456   if (block_previously_created)
14457     block = current_binding_level->this_block;
14458   else if (keep || functionbody)
14459     block = make_node (BLOCK);
14460   if (block != 0)
14461     {
14462       BLOCK_VARS (block) = decls;
14463       BLOCK_SUBBLOCKS (block) = subblocks;
14464     }
14465
14466   /* In each subblock, record that this is its superior.  */
14467
14468   for (link = subblocks; link; link = TREE_CHAIN (link))
14469     BLOCK_SUPERCONTEXT (link) = block;
14470
14471   /* Clear out the meanings of the local variables of this level.  */
14472
14473   for (link = decls; link; link = TREE_CHAIN (link))
14474     {
14475       if (DECL_NAME (link) != 0)
14476         {
14477           /* If the ident. was used or addressed via a local extern decl,
14478              don't forget that fact.  */
14479           if (DECL_EXTERNAL (link))
14480             {
14481               if (TREE_USED (link))
14482                 TREE_USED (DECL_NAME (link)) = 1;
14483               if (TREE_ADDRESSABLE (link))
14484                 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (link)) = 1;
14485             }
14486           IDENTIFIER_LOCAL_VALUE (DECL_NAME (link)) = 0;
14487         }
14488     }
14489
14490   /* If the level being exited is the top level of a function,
14491      check over all the labels, and clear out the current
14492      (function local) meanings of their names.  */
14493
14494   if (functionbody)
14495     {
14496       /* If this is the top level block of a function,
14497          the vars are the function's parameters.
14498          Don't leave them in the BLOCK because they are
14499          found in the FUNCTION_DECL instead.  */
14500
14501       BLOCK_VARS (block) = 0;
14502     }
14503
14504   /* Pop the current level, and free the structure for reuse.  */
14505
14506   {
14507     register struct binding_level *level = current_binding_level;
14508     current_binding_level = current_binding_level->level_chain;
14509
14510     level->level_chain = free_binding_level;
14511     free_binding_level = level;
14512   }
14513
14514   /* Dispose of the block that we just made inside some higher level.  */
14515   if (functionbody
14516       && current_function_decl != error_mark_node)
14517     DECL_INITIAL (current_function_decl) = block;
14518   else if (block)
14519     {
14520       if (!block_previously_created)
14521         current_binding_level->blocks
14522           = chainon (current_binding_level->blocks, block);
14523     }
14524   /* If we did not make a block for the level just exited,
14525      any blocks made for inner levels
14526      (since they cannot be recorded as subblocks in that level)
14527      must be carried forward so they will later become subblocks
14528      of something else.  */
14529   else if (subblocks)
14530     current_binding_level->blocks
14531       = chainon (current_binding_level->blocks, subblocks);
14532
14533   if (block)
14534     TREE_USED (block) = 1;
14535   return block;
14536 }
14537
14538 static void
14539 ffe_print_identifier (file, node, indent)
14540      FILE *file;
14541      tree node;
14542      int indent;
14543 {
14544   print_node (file, "global", IDENTIFIER_GLOBAL_VALUE (node), indent + 4);
14545   print_node (file, "local", IDENTIFIER_LOCAL_VALUE (node), indent + 4);
14546 }
14547
14548 /* Record a decl-node X as belonging to the current lexical scope.
14549    Check for errors (such as an incompatible declaration for the same
14550    name already seen in the same scope).
14551
14552    Returns either X or an old decl for the same name.
14553    If an old decl is returned, it may have been smashed
14554    to agree with what X says.  */
14555
14556 tree
14557 pushdecl (x)
14558      tree x;
14559 {
14560   register tree t;
14561   register tree name = DECL_NAME (x);
14562   register struct binding_level *b = current_binding_level;
14563
14564   if ((TREE_CODE (x) == FUNCTION_DECL)
14565       && (DECL_INITIAL (x) == 0)
14566       && DECL_EXTERNAL (x))
14567     DECL_CONTEXT (x) = NULL_TREE;
14568   else
14569     DECL_CONTEXT (x) = current_function_decl;
14570
14571   if (name)
14572     {
14573       if (IDENTIFIER_INVENTED (name))
14574         {
14575           DECL_ARTIFICIAL (x) = 1;
14576           DECL_IN_SYSTEM_HEADER (x) = 1;
14577         }
14578
14579       t = lookup_name_current_level (name);
14580
14581       assert ((t == NULL_TREE) || (DECL_CONTEXT (x) == NULL_TREE));
14582
14583       /* Don't push non-parms onto list for parms until we understand
14584          why we're doing this and whether it works.  */
14585
14586       assert ((b == global_binding_level)
14587               || !ffecom_transform_only_dummies_
14588               || TREE_CODE (x) == PARM_DECL);
14589
14590       if ((t != NULL_TREE) && duplicate_decls (x, t))
14591         return t;
14592
14593       /* If we are processing a typedef statement, generate a whole new
14594          ..._TYPE node (which will be just an variant of the existing
14595          ..._TYPE node with identical properties) and then install the
14596          TYPE_DECL node generated to represent the typedef name as the
14597          TYPE_NAME of this brand new (duplicate) ..._TYPE node.
14598
14599          The whole point here is to end up with a situation where each and every
14600          ..._TYPE node the compiler creates will be uniquely associated with
14601          AT MOST one node representing a typedef name. This way, even though
14602          the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL
14603          (i.e. "typedef name") nodes very early on, later parts of the
14604          compiler can always do the reverse translation and get back the
14605          corresponding typedef name.  For example, given:
14606
14607          typedef struct S MY_TYPE; MY_TYPE object;
14608
14609          Later parts of the compiler might only know that `object' was of type
14610          `struct S' if it were not for code just below.  With this code
14611          however, later parts of the compiler see something like:
14612
14613          struct S' == struct S typedef struct S' MY_TYPE; struct S' object;
14614
14615          And they can then deduce (from the node for type struct S') that the
14616          original object declaration was:
14617
14618          MY_TYPE object;
14619
14620          Being able to do this is important for proper support of protoize, and
14621          also for generating precise symbolic debugging information which
14622          takes full account of the programmer's (typedef) vocabulary.
14623
14624          Obviously, we don't want to generate a duplicate ..._TYPE node if the
14625          TYPE_DECL node that we are now processing really represents a
14626          standard built-in type.
14627
14628          Since all standard types are effectively declared at line zero in the
14629          source file, we can easily check to see if we are working on a
14630          standard type by checking the current value of lineno.  */
14631
14632       if (TREE_CODE (x) == TYPE_DECL)
14633         {
14634           if (DECL_SOURCE_LINE (x) == 0)
14635             {
14636               if (TYPE_NAME (TREE_TYPE (x)) == 0)
14637                 TYPE_NAME (TREE_TYPE (x)) = x;
14638             }
14639           else if (TREE_TYPE (x) != error_mark_node)
14640             {
14641               tree tt = TREE_TYPE (x);
14642
14643               tt = build_type_copy (tt);
14644               TYPE_NAME (tt) = x;
14645               TREE_TYPE (x) = tt;
14646             }
14647         }
14648
14649       /* This name is new in its binding level. Install the new declaration
14650          and return it.  */
14651       if (b == global_binding_level)
14652         IDENTIFIER_GLOBAL_VALUE (name) = x;
14653       else
14654         IDENTIFIER_LOCAL_VALUE (name) = x;
14655     }
14656
14657   /* Put decls on list in reverse order. We will reverse them later if
14658      necessary.  */
14659   TREE_CHAIN (x) = b->names;
14660   b->names = x;
14661
14662   return x;
14663 }
14664
14665 /* Nonzero if the current level needs to have a BLOCK made.  */
14666
14667 static int
14668 kept_level_p ()
14669 {
14670   tree decl;
14671
14672   for (decl = current_binding_level->names;
14673        decl;
14674        decl = TREE_CHAIN (decl))
14675     {
14676       if (TREE_USED (decl) || TREE_CODE (decl) != VAR_DECL
14677           || (DECL_NAME (decl) && ! DECL_ARTIFICIAL (decl)))
14678         /* Currently, there aren't supposed to be non-artificial names
14679            at other than the top block for a function -- they're
14680            believed to always be temps.  But it's wise to check anyway.  */
14681         return 1;
14682     }
14683   return 0;
14684 }
14685
14686 /* Enter a new binding level.
14687    If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
14688    not for that of tags.  */
14689
14690 void
14691 pushlevel (tag_transparent)
14692      int tag_transparent;
14693 {
14694   register struct binding_level *newlevel = NULL_BINDING_LEVEL;
14695
14696   assert (! tag_transparent);
14697
14698   if (current_binding_level == global_binding_level)
14699     {
14700       named_labels = 0;
14701     }
14702
14703   /* Reuse or create a struct for this binding level.  */
14704
14705   if (free_binding_level)
14706     {
14707       newlevel = free_binding_level;
14708       free_binding_level = free_binding_level->level_chain;
14709     }
14710   else
14711     {
14712       newlevel = make_binding_level ();
14713     }
14714
14715   /* Add this level to the front of the chain (stack) of levels that
14716      are active.  */
14717
14718   *newlevel = clear_binding_level;
14719   newlevel->level_chain = current_binding_level;
14720   current_binding_level = newlevel;
14721 }
14722
14723 /* Set the BLOCK node for the innermost scope
14724    (the one we are currently in).  */
14725
14726 void
14727 set_block (block)
14728      register tree block;
14729 {
14730   current_binding_level->this_block = block;
14731   current_binding_level->names = chainon (current_binding_level->names,
14732                                           BLOCK_VARS (block));
14733   current_binding_level->blocks = chainon (current_binding_level->blocks,
14734                                            BLOCK_SUBBLOCKS (block));
14735 }
14736
14737 tree
14738 signed_or_unsigned_type (unsignedp, type)
14739      int unsignedp;
14740      tree type;
14741 {
14742   tree type2;
14743
14744   if (! INTEGRAL_TYPE_P (type))
14745     return type;
14746   if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node))
14747     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
14748   if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node))
14749     return unsignedp ? unsigned_type_node : integer_type_node;
14750   if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node))
14751     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
14752   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node))
14753     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
14754   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node))
14755     return (unsignedp ? long_long_unsigned_type_node
14756             : long_long_integer_type_node);
14757
14758   type2 = type_for_size (TYPE_PRECISION (type), unsignedp);
14759   if (type2 == NULL_TREE)
14760     return type;
14761
14762   return type2;
14763 }
14764
14765 tree
14766 signed_type (type)
14767      tree type;
14768 {
14769   tree type1 = TYPE_MAIN_VARIANT (type);
14770   ffeinfoKindtype kt;
14771   tree type2;
14772
14773   if (type1 == unsigned_char_type_node || type1 == char_type_node)
14774     return signed_char_type_node;
14775   if (type1 == unsigned_type_node)
14776     return integer_type_node;
14777   if (type1 == short_unsigned_type_node)
14778     return short_integer_type_node;
14779   if (type1 == long_unsigned_type_node)
14780     return long_integer_type_node;
14781   if (type1 == long_long_unsigned_type_node)
14782     return long_long_integer_type_node;
14783 #if 0   /* gcc/c-* files only */
14784   if (type1 == unsigned_intDI_type_node)
14785     return intDI_type_node;
14786   if (type1 == unsigned_intSI_type_node)
14787     return intSI_type_node;
14788   if (type1 == unsigned_intHI_type_node)
14789     return intHI_type_node;
14790   if (type1 == unsigned_intQI_type_node)
14791     return intQI_type_node;
14792 #endif
14793
14794   type2 = type_for_size (TYPE_PRECISION (type1), 0);
14795   if (type2 != NULL_TREE)
14796     return type2;
14797
14798   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
14799     {
14800       type2 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
14801
14802       if (type1 == type2)
14803         return ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
14804     }
14805
14806   return type;
14807 }
14808
14809 /* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
14810    or validate its data type for an `if' or `while' statement or ?..: exp.
14811
14812    This preparation consists of taking the ordinary
14813    representation of an expression expr and producing a valid tree
14814    boolean expression describing whether expr is nonzero.  We could
14815    simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
14816    but we optimize comparisons, &&, ||, and !.
14817
14818    The resulting type should always be `integer_type_node'.  */
14819
14820 tree
14821 truthvalue_conversion (expr)
14822      tree expr;
14823 {
14824   if (TREE_CODE (expr) == ERROR_MARK)
14825     return expr;
14826
14827 #if 0 /* This appears to be wrong for C++.  */
14828   /* These really should return error_mark_node after 2.4 is stable.
14829      But not all callers handle ERROR_MARK properly.  */
14830   switch (TREE_CODE (TREE_TYPE (expr)))
14831     {
14832     case RECORD_TYPE:
14833       error ("struct type value used where scalar is required");
14834       return integer_zero_node;
14835
14836     case UNION_TYPE:
14837       error ("union type value used where scalar is required");
14838       return integer_zero_node;
14839
14840     case ARRAY_TYPE:
14841       error ("array type value used where scalar is required");
14842       return integer_zero_node;
14843
14844     default:
14845       break;
14846     }
14847 #endif /* 0 */
14848
14849   switch (TREE_CODE (expr))
14850     {
14851       /* It is simpler and generates better code to have only TRUTH_*_EXPR
14852          or comparison expressions as truth values at this level.  */
14853 #if 0
14854     case COMPONENT_REF:
14855       /* A one-bit unsigned bit-field is already acceptable.  */
14856       if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr, 1)))
14857           && TREE_UNSIGNED (TREE_OPERAND (expr, 1)))
14858         return expr;
14859       break;
14860 #endif
14861
14862     case EQ_EXPR:
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       if (integer_zerop (TREE_OPERAND (expr, 1)))
14867         return build_unary_op (TRUTH_NOT_EXPR, TREE_OPERAND (expr, 0), 0);
14868 #endif
14869     case NE_EXPR: case LE_EXPR: case GE_EXPR: case LT_EXPR: case GT_EXPR:
14870     case TRUTH_ANDIF_EXPR:
14871     case TRUTH_ORIF_EXPR:
14872     case TRUTH_AND_EXPR:
14873     case TRUTH_OR_EXPR:
14874     case TRUTH_XOR_EXPR:
14875       TREE_TYPE (expr) = integer_type_node;
14876       return expr;
14877
14878     case ERROR_MARK:
14879       return expr;
14880
14881     case INTEGER_CST:
14882       return integer_zerop (expr) ? integer_zero_node : integer_one_node;
14883
14884     case REAL_CST:
14885       return real_zerop (expr) ? integer_zero_node : integer_one_node;
14886
14887     case ADDR_EXPR:
14888       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 0)))
14889         return build (COMPOUND_EXPR, integer_type_node,
14890                       TREE_OPERAND (expr, 0), integer_one_node);
14891       else
14892         return integer_one_node;
14893
14894     case COMPLEX_EXPR:
14895       return ffecom_2 ((TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1))
14896                         ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
14897                        integer_type_node,
14898                        truthvalue_conversion (TREE_OPERAND (expr, 0)),
14899                        truthvalue_conversion (TREE_OPERAND (expr, 1)));
14900
14901     case NEGATE_EXPR:
14902     case ABS_EXPR:
14903     case FLOAT_EXPR:
14904     case FFS_EXPR:
14905       /* These don't change whether an object is non-zero or zero.  */
14906       return truthvalue_conversion (TREE_OPERAND (expr, 0));
14907
14908     case LROTATE_EXPR:
14909     case RROTATE_EXPR:
14910       /* These don't change whether an object is zero or non-zero, but
14911          we can't ignore them if their second arg has side-effects.  */
14912       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1)))
14913         return build (COMPOUND_EXPR, integer_type_node, TREE_OPERAND (expr, 1),
14914                       truthvalue_conversion (TREE_OPERAND (expr, 0)));
14915       else
14916         return truthvalue_conversion (TREE_OPERAND (expr, 0));
14917
14918     case COND_EXPR:
14919       /* Distribute the conversion into the arms of a COND_EXPR.  */
14920       return fold (build (COND_EXPR, integer_type_node, TREE_OPERAND (expr, 0),
14921                           truthvalue_conversion (TREE_OPERAND (expr, 1)),
14922                           truthvalue_conversion (TREE_OPERAND (expr, 2))));
14923
14924     case CONVERT_EXPR:
14925       /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
14926          since that affects how `default_conversion' will behave.  */
14927       if (TREE_CODE (TREE_TYPE (expr)) == REFERENCE_TYPE
14928           || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) == REFERENCE_TYPE)
14929         break;
14930       /* fall through... */
14931     case NOP_EXPR:
14932       /* If this is widening the argument, we can ignore it.  */
14933       if (TYPE_PRECISION (TREE_TYPE (expr))
14934           >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr, 0))))
14935         return truthvalue_conversion (TREE_OPERAND (expr, 0));
14936       break;
14937
14938     case MINUS_EXPR:
14939       /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize
14940          this case.  */
14941       if (TARGET_FLOAT_FORMAT == IEEE_FLOAT_FORMAT
14942           && TREE_CODE (TREE_TYPE (expr)) == REAL_TYPE)
14943         break;
14944       /* fall through... */
14945     case BIT_XOR_EXPR:
14946       /* This and MINUS_EXPR can be changed into a comparison of the
14947          two objects.  */
14948       if (TREE_TYPE (TREE_OPERAND (expr, 0))
14949           == TREE_TYPE (TREE_OPERAND (expr, 1)))
14950         return ffecom_2 (NE_EXPR, integer_type_node,
14951                          TREE_OPERAND (expr, 0),
14952                          TREE_OPERAND (expr, 1));
14953       return ffecom_2 (NE_EXPR, integer_type_node,
14954                        TREE_OPERAND (expr, 0),
14955                        fold (build1 (NOP_EXPR,
14956                                      TREE_TYPE (TREE_OPERAND (expr, 0)),
14957                                      TREE_OPERAND (expr, 1))));
14958
14959     case BIT_AND_EXPR:
14960       if (integer_onep (TREE_OPERAND (expr, 1)))
14961         return expr;
14962       break;
14963
14964     case MODIFY_EXPR:
14965 #if 0                           /* No such thing in Fortran. */
14966       if (warn_parentheses && C_EXP_ORIGINAL_CODE (expr) == MODIFY_EXPR)
14967         warning ("suggest parentheses around assignment used as truth value");
14968 #endif
14969       break;
14970
14971     default:
14972       break;
14973     }
14974
14975   if (TREE_CODE (TREE_TYPE (expr)) == COMPLEX_TYPE)
14976     return (ffecom_2
14977             ((TREE_SIDE_EFFECTS (expr)
14978               ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
14979              integer_type_node,
14980              truthvalue_conversion (ffecom_1 (REALPART_EXPR,
14981                                               TREE_TYPE (TREE_TYPE (expr)),
14982                                               expr)),
14983              truthvalue_conversion (ffecom_1 (IMAGPART_EXPR,
14984                                               TREE_TYPE (TREE_TYPE (expr)),
14985                                               expr))));
14986
14987   return ffecom_2 (NE_EXPR, integer_type_node,
14988                    expr,
14989                    convert (TREE_TYPE (expr), integer_zero_node));
14990 }
14991
14992 tree
14993 type_for_mode (mode, unsignedp)
14994      enum machine_mode mode;
14995      int unsignedp;
14996 {
14997   int i;
14998   int j;
14999   tree t;
15000
15001   if (mode == TYPE_MODE (integer_type_node))
15002     return unsignedp ? unsigned_type_node : integer_type_node;
15003
15004   if (mode == TYPE_MODE (signed_char_type_node))
15005     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15006
15007   if (mode == TYPE_MODE (short_integer_type_node))
15008     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15009
15010   if (mode == TYPE_MODE (long_integer_type_node))
15011     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15012
15013   if (mode == TYPE_MODE (long_long_integer_type_node))
15014     return unsignedp ? long_long_unsigned_type_node : long_long_integer_type_node;
15015
15016 #if HOST_BITS_PER_WIDE_INT >= 64
15017   if (mode == TYPE_MODE (intTI_type_node))
15018     return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
15019 #endif
15020
15021   if (mode == TYPE_MODE (float_type_node))
15022     return float_type_node;
15023
15024   if (mode == TYPE_MODE (double_type_node))
15025     return double_type_node;
15026
15027   if (mode == TYPE_MODE (build_pointer_type (char_type_node)))
15028     return build_pointer_type (char_type_node);
15029
15030   if (mode == TYPE_MODE (build_pointer_type (integer_type_node)))
15031     return build_pointer_type (integer_type_node);
15032
15033   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
15034     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
15035       {
15036         if (((t = ffecom_tree_type[i][j]) != NULL_TREE)
15037             && (mode == TYPE_MODE (t)))
15038           {
15039             if ((i == FFEINFO_basictypeINTEGER) && unsignedp)
15040               return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][j];
15041             else
15042               return t;
15043           }
15044       }
15045
15046   return 0;
15047 }
15048
15049 tree
15050 type_for_size (bits, unsignedp)
15051      unsigned bits;
15052      int unsignedp;
15053 {
15054   ffeinfoKindtype kt;
15055   tree type_node;
15056
15057   if (bits == TYPE_PRECISION (integer_type_node))
15058     return unsignedp ? unsigned_type_node : integer_type_node;
15059
15060   if (bits == TYPE_PRECISION (signed_char_type_node))
15061     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15062
15063   if (bits == TYPE_PRECISION (short_integer_type_node))
15064     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15065
15066   if (bits == TYPE_PRECISION (long_integer_type_node))
15067     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15068
15069   if (bits == TYPE_PRECISION (long_long_integer_type_node))
15070     return (unsignedp ? long_long_unsigned_type_node
15071             : long_long_integer_type_node);
15072
15073   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15074     {
15075       type_node = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15076
15077       if ((type_node != NULL_TREE) && (bits == TYPE_PRECISION (type_node)))
15078         return unsignedp ? ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]
15079           : type_node;
15080     }
15081
15082   return 0;
15083 }
15084
15085 tree
15086 unsigned_type (type)
15087      tree type;
15088 {
15089   tree type1 = TYPE_MAIN_VARIANT (type);
15090   ffeinfoKindtype kt;
15091   tree type2;
15092
15093   if (type1 == signed_char_type_node || type1 == char_type_node)
15094     return unsigned_char_type_node;
15095   if (type1 == integer_type_node)
15096     return unsigned_type_node;
15097   if (type1 == short_integer_type_node)
15098     return short_unsigned_type_node;
15099   if (type1 == long_integer_type_node)
15100     return long_unsigned_type_node;
15101   if (type1 == long_long_integer_type_node)
15102     return long_long_unsigned_type_node;
15103 #if 0   /* gcc/c-* files only */
15104   if (type1 == intDI_type_node)
15105     return unsigned_intDI_type_node;
15106   if (type1 == intSI_type_node)
15107     return unsigned_intSI_type_node;
15108   if (type1 == intHI_type_node)
15109     return unsigned_intHI_type_node;
15110   if (type1 == intQI_type_node)
15111     return unsigned_intQI_type_node;
15112 #endif
15113
15114   type2 = type_for_size (TYPE_PRECISION (type1), 1);
15115   if (type2 != NULL_TREE)
15116     return type2;
15117
15118   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15119     {
15120       type2 = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15121
15122       if (type1 == type2)
15123         return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
15124     }
15125
15126   return type;
15127 }
15128
15129 void
15130 lang_mark_tree (t)
15131      union tree_node *t ATTRIBUTE_UNUSED;
15132 {
15133   if (TREE_CODE (t) == IDENTIFIER_NODE)
15134     {
15135       struct lang_identifier *i = (struct lang_identifier *) t;
15136       ggc_mark_tree (IDENTIFIER_GLOBAL_VALUE (i));
15137       ggc_mark_tree (IDENTIFIER_LOCAL_VALUE (i));
15138       ggc_mark_tree (IDENTIFIER_LABEL_VALUE (i));
15139     }
15140   else if (TYPE_P (t) && TYPE_LANG_SPECIFIC (t))
15141     ggc_mark (TYPE_LANG_SPECIFIC (t));
15142 }
15143 \f
15144 /* From gcc/cccp.c, the code to handle -I.  */
15145
15146 /* Skip leading "./" from a directory name.
15147    This may yield the empty string, which represents the current directory.  */
15148
15149 static const char *
15150 skip_redundant_dir_prefix (const char *dir)
15151 {
15152   while (dir[0] == '.' && dir[1] == '/')
15153     for (dir += 2; *dir == '/'; dir++)
15154       continue;
15155   if (dir[0] == '.' && !dir[1])
15156     dir++;
15157   return dir;
15158 }
15159
15160 /* The file_name_map structure holds a mapping of file names for a
15161    particular directory.  This mapping is read from the file named
15162    FILE_NAME_MAP_FILE in that directory.  Such a file can be used to
15163    map filenames on a file system with severe filename restrictions,
15164    such as DOS.  The format of the file name map file is just a series
15165    of lines with two tokens on each line.  The first token is the name
15166    to map, and the second token is the actual name to use.  */
15167
15168 struct file_name_map
15169 {
15170   struct file_name_map *map_next;
15171   char *map_from;
15172   char *map_to;
15173 };
15174
15175 #define FILE_NAME_MAP_FILE "header.gcc"
15176
15177 /* Current maximum length of directory names in the search path
15178    for include files.  (Altered as we get more of them.)  */
15179
15180 static int max_include_len = 0;
15181
15182 struct file_name_list
15183   {
15184     struct file_name_list *next;
15185     char *fname;
15186     /* Mapping of file names for this directory.  */
15187     struct file_name_map *name_map;
15188     /* Non-zero if name_map is valid.  */
15189     int got_name_map;
15190   };
15191
15192 static struct file_name_list *include = NULL;   /* First dir to search */
15193 static struct file_name_list *last_include = NULL;      /* Last in chain */
15194
15195 /* I/O buffer structure.
15196    The `fname' field is nonzero for source files and #include files
15197    and for the dummy text used for -D and -U.
15198    It is zero for rescanning results of macro expansion
15199    and for expanding macro arguments.  */
15200 #define INPUT_STACK_MAX 400
15201 static struct file_buf {
15202   const char *fname;
15203   /* Filename specified with #line command.  */
15204   const char *nominal_fname;
15205   /* Record where in the search path this file was found.
15206      For #include_next.  */
15207   struct file_name_list *dir;
15208   ffewhereLine line;
15209   ffewhereColumn column;
15210 } instack[INPUT_STACK_MAX];
15211
15212 static int last_error_tick = 0;    /* Incremented each time we print it.  */
15213 static int input_file_stack_tick = 0;  /* Incremented when status changes.  */
15214
15215 /* Current nesting level of input sources.
15216    `instack[indepth]' is the level currently being read.  */
15217 static int indepth = -1;
15218
15219 typedef struct file_buf FILE_BUF;
15220
15221 /* Nonzero means -I- has been seen,
15222    so don't look for #include "foo" the source-file directory.  */
15223 static int ignore_srcdir;
15224
15225 #ifndef INCLUDE_LEN_FUDGE
15226 #define INCLUDE_LEN_FUDGE 0
15227 #endif
15228
15229 static void append_include_chain (struct file_name_list *first,
15230                                   struct file_name_list *last);
15231 static FILE *open_include_file (char *filename,
15232                                 struct file_name_list *searchptr);
15233 static void print_containing_files (ffebadSeverity sev);
15234 static char *read_filename_string (int ch, FILE *f);
15235 static struct file_name_map *read_name_map (const char *dirname);
15236
15237 /* Append a chain of `struct file_name_list's
15238    to the end of the main include chain.
15239    FIRST is the beginning of the chain to append, and LAST is the end.  */
15240
15241 static void
15242 append_include_chain (first, last)
15243      struct file_name_list *first, *last;
15244 {
15245   struct file_name_list *dir;
15246
15247   if (!first || !last)
15248     return;
15249
15250   if (include == 0)
15251     include = first;
15252   else
15253     last_include->next = first;
15254
15255   for (dir = first; ; dir = dir->next) {
15256     int len = strlen (dir->fname) + INCLUDE_LEN_FUDGE;
15257     if (len > max_include_len)
15258       max_include_len = len;
15259     if (dir == last)
15260       break;
15261   }
15262
15263   last->next = NULL;
15264   last_include = last;
15265 }
15266
15267 /* Try to open include file FILENAME.  SEARCHPTR is the directory
15268    being tried from the include file search path.  This function maps
15269    filenames on file systems based on information read by
15270    read_name_map.  */
15271
15272 static FILE *
15273 open_include_file (filename, searchptr)
15274      char *filename;
15275      struct file_name_list *searchptr;
15276 {
15277   register struct file_name_map *map;
15278   register char *from;
15279   char *p, *dir;
15280
15281   if (searchptr && ! searchptr->got_name_map)
15282     {
15283       searchptr->name_map = read_name_map (searchptr->fname
15284                                            ? searchptr->fname : ".");
15285       searchptr->got_name_map = 1;
15286     }
15287
15288   /* First check the mapping for the directory we are using.  */
15289   if (searchptr && searchptr->name_map)
15290     {
15291       from = filename;
15292       if (searchptr->fname)
15293         from += strlen (searchptr->fname) + 1;
15294       for (map = searchptr->name_map; map; map = map->map_next)
15295         {
15296           if (! strcmp (map->map_from, from))
15297             {
15298               /* Found a match.  */
15299               return fopen (map->map_to, "r");
15300             }
15301         }
15302     }
15303
15304   /* Try to find a mapping file for the particular directory we are
15305      looking in.  Thus #include <sys/types.h> will look up sys/types.h
15306      in /usr/include/header.gcc and look up types.h in
15307      /usr/include/sys/header.gcc.  */
15308   p = strrchr (filename, '/');
15309 #ifdef DIR_SEPARATOR
15310   if (! p) p = strrchr (filename, DIR_SEPARATOR);
15311   else {
15312     char *tmp = strrchr (filename, DIR_SEPARATOR);
15313     if (tmp != NULL && tmp > p) p = tmp;
15314   }
15315 #endif
15316   if (! p)
15317     p = filename;
15318   if (searchptr
15319       && searchptr->fname
15320       && strlen (searchptr->fname) == (size_t) (p - filename)
15321       && ! strncmp (searchptr->fname, filename, (int) (p - filename)))
15322     {
15323       /* FILENAME is in SEARCHPTR, which we've already checked.  */
15324       return fopen (filename, "r");
15325     }
15326
15327   if (p == filename)
15328     {
15329       from = filename;
15330       map = read_name_map (".");
15331     }
15332   else
15333     {
15334       dir = (char *) xmalloc (p - filename + 1);
15335       memcpy (dir, filename, p - filename);
15336       dir[p - filename] = '\0';
15337       from = p + 1;
15338       map = read_name_map (dir);
15339       free (dir);
15340     }
15341   for (; map; map = map->map_next)
15342     if (! strcmp (map->map_from, from))
15343       return fopen (map->map_to, "r");
15344
15345   return fopen (filename, "r");
15346 }
15347
15348 /* Print the file names and line numbers of the #include
15349    commands which led to the current file.  */
15350
15351 static void
15352 print_containing_files (ffebadSeverity sev)
15353 {
15354   FILE_BUF *ip = NULL;
15355   int i;
15356   int first = 1;
15357   const char *str1;
15358   const char *str2;
15359
15360   /* If stack of files hasn't changed since we last printed
15361      this info, don't repeat it.  */
15362   if (last_error_tick == input_file_stack_tick)
15363     return;
15364
15365   for (i = indepth; i >= 0; i--)
15366     if (instack[i].fname != NULL) {
15367       ip = &instack[i];
15368       break;
15369     }
15370
15371   /* Give up if we don't find a source file.  */
15372   if (ip == NULL)
15373     return;
15374
15375   /* Find the other, outer source files.  */
15376   for (i--; i >= 0; i--)
15377     if (instack[i].fname != NULL)
15378       {
15379         ip = &instack[i];
15380         if (first)
15381           {
15382             first = 0;
15383             str1 = "In file included";
15384           }
15385         else
15386           {
15387             str1 = "...          ...";
15388           }
15389
15390         if (i == 1)
15391           str2 = ":";
15392         else
15393           str2 = "";
15394
15395         /* xgettext:no-c-format */
15396         ffebad_start_msg ("%A from %B at %0%C", sev);
15397         ffebad_here (0, ip->line, ip->column);
15398         ffebad_string (str1);
15399         ffebad_string (ip->nominal_fname);
15400         ffebad_string (str2);
15401         ffebad_finish ();
15402       }
15403
15404   /* Record we have printed the status as of this time.  */
15405   last_error_tick = input_file_stack_tick;
15406 }
15407
15408 /* Read a space delimited string of unlimited length from a stdio
15409    file.  */
15410
15411 static char *
15412 read_filename_string (ch, f)
15413      int ch;
15414      FILE *f;
15415 {
15416   char *alloc, *set;
15417   int len;
15418
15419   len = 20;
15420   set = alloc = xmalloc (len + 1);
15421   if (! ISSPACE (ch))
15422     {
15423       *set++ = ch;
15424       while ((ch = getc (f)) != EOF && ! ISSPACE (ch))
15425         {
15426           if (set - alloc == len)
15427             {
15428               len *= 2;
15429               alloc = xrealloc (alloc, len + 1);
15430               set = alloc + len / 2;
15431             }
15432           *set++ = ch;
15433         }
15434     }
15435   *set = '\0';
15436   ungetc (ch, f);
15437   return alloc;
15438 }
15439
15440 /* Read the file name map file for DIRNAME.  */
15441
15442 static struct file_name_map *
15443 read_name_map (dirname)
15444      const char *dirname;
15445 {
15446   /* This structure holds a linked list of file name maps, one per
15447      directory.  */
15448   struct file_name_map_list
15449     {
15450       struct file_name_map_list *map_list_next;
15451       char *map_list_name;
15452       struct file_name_map *map_list_map;
15453     };
15454   static struct file_name_map_list *map_list;
15455   register struct file_name_map_list *map_list_ptr;
15456   char *name;
15457   FILE *f;
15458   size_t dirlen;
15459   int separator_needed;
15460
15461   dirname = skip_redundant_dir_prefix (dirname);
15462
15463   for (map_list_ptr = map_list; map_list_ptr;
15464        map_list_ptr = map_list_ptr->map_list_next)
15465     if (! strcmp (map_list_ptr->map_list_name, dirname))
15466       return map_list_ptr->map_list_map;
15467
15468   map_list_ptr = ((struct file_name_map_list *)
15469                   xmalloc (sizeof (struct file_name_map_list)));
15470   map_list_ptr->map_list_name = xstrdup (dirname);
15471   map_list_ptr->map_list_map = NULL;
15472
15473   dirlen = strlen (dirname);
15474   separator_needed = dirlen != 0 && dirname[dirlen - 1] != '/';
15475   name = (char *) xmalloc (dirlen + strlen (FILE_NAME_MAP_FILE) + 2);
15476   strcpy (name, dirname);
15477   name[dirlen] = '/';
15478   strcpy (name + dirlen + separator_needed, FILE_NAME_MAP_FILE);
15479   f = fopen (name, "r");
15480   free (name);
15481   if (!f)
15482     map_list_ptr->map_list_map = NULL;
15483   else
15484     {
15485       int ch;
15486
15487       while ((ch = getc (f)) != EOF)
15488         {
15489           char *from, *to;
15490           struct file_name_map *ptr;
15491
15492           if (ISSPACE (ch))
15493             continue;
15494           from = read_filename_string (ch, f);
15495           while ((ch = getc (f)) != EOF && ISSPACE (ch) && ch != '\n')
15496             ;
15497           to = read_filename_string (ch, f);
15498
15499           ptr = ((struct file_name_map *)
15500                  xmalloc (sizeof (struct file_name_map)));
15501           ptr->map_from = from;
15502
15503           /* Make the real filename absolute.  */
15504           if (*to == '/')
15505             ptr->map_to = to;
15506           else
15507             {
15508               ptr->map_to = xmalloc (dirlen + strlen (to) + 2);
15509               strcpy (ptr->map_to, dirname);
15510               ptr->map_to[dirlen] = '/';
15511               strcpy (ptr->map_to + dirlen + separator_needed, to);
15512               free (to);
15513             }
15514
15515           ptr->map_next = map_list_ptr->map_list_map;
15516           map_list_ptr->map_list_map = ptr;
15517
15518           while ((ch = getc (f)) != '\n')
15519             if (ch == EOF)
15520               break;
15521         }
15522       fclose (f);
15523     }
15524
15525   map_list_ptr->map_list_next = map_list;
15526   map_list = map_list_ptr;
15527
15528   return map_list_ptr->map_list_map;
15529 }
15530
15531 static void
15532 ffecom_file_ (const char *name)
15533 {
15534   FILE_BUF *fp;
15535
15536   /* Do partial setup of input buffer for the sake of generating
15537      early #line directives (when -g is in effect).  */
15538
15539   fp = &instack[++indepth];
15540   memset ((char *) fp, 0, sizeof (FILE_BUF));
15541   if (name == NULL)
15542     name = "";
15543   fp->nominal_fname = fp->fname = name;
15544 }
15545
15546 static void
15547 ffecom_close_include_ (FILE *f)
15548 {
15549   fclose (f);
15550
15551   indepth--;
15552   input_file_stack_tick++;
15553
15554   ffewhere_line_kill (instack[indepth].line);
15555   ffewhere_column_kill (instack[indepth].column);
15556 }
15557
15558 static int
15559 ffecom_decode_include_option_ (char *spec)
15560 {
15561   struct file_name_list *dirtmp;
15562
15563   if (! ignore_srcdir && !strcmp (spec, "-"))
15564     ignore_srcdir = 1;
15565   else
15566     {
15567       dirtmp = (struct file_name_list *)
15568         xmalloc (sizeof (struct file_name_list));
15569       dirtmp->next = 0;         /* New one goes on the end */
15570       dirtmp->fname = spec;
15571       dirtmp->got_name_map = 0;
15572       if (spec[0] == 0)
15573         error ("directory name must immediately follow -I");
15574       else
15575         append_include_chain (dirtmp, dirtmp);
15576     }
15577   return 1;
15578 }
15579
15580 /* Open INCLUDEd file.  */
15581
15582 static FILE *
15583 ffecom_open_include_ (char *name, ffewhereLine l, ffewhereColumn c)
15584 {
15585   char *fbeg = name;
15586   size_t flen = strlen (fbeg);
15587   struct file_name_list *search_start = include; /* Chain of dirs to search */
15588   struct file_name_list dsp[1]; /* First in chain, if #include "..." */
15589   struct file_name_list *searchptr = 0;
15590   char *fname;          /* Dynamically allocated fname buffer */
15591   FILE *f;
15592   FILE_BUF *fp;
15593
15594   if (flen == 0)
15595     return NULL;
15596
15597   dsp[0].fname = NULL;
15598
15599   /* If -I- was specified, don't search current dir, only spec'd ones. */
15600   if (!ignore_srcdir)
15601     {
15602       for (fp = &instack[indepth]; fp >= instack; fp--)
15603         {
15604           int n;
15605           char *ep;
15606           const char *nam;
15607
15608           if ((nam = fp->nominal_fname) != NULL)
15609             {
15610               /* Found a named file.  Figure out dir of the file,
15611                  and put it in front of the search list.  */
15612               dsp[0].next = search_start;
15613               search_start = dsp;
15614 #ifndef VMS
15615               ep = strrchr (nam, '/');
15616 #ifdef DIR_SEPARATOR
15617             if (ep == NULL) ep = strrchr (nam, DIR_SEPARATOR);
15618             else {
15619               char *tmp = strrchr (nam, DIR_SEPARATOR);
15620               if (tmp != NULL && tmp > ep) ep = tmp;
15621             }
15622 #endif
15623 #else                           /* VMS */
15624               ep = strrchr (nam, ']');
15625               if (ep == NULL) ep = strrchr (nam, '>');
15626               if (ep == NULL) ep = strrchr (nam, ':');
15627               if (ep != NULL) ep++;
15628 #endif                          /* VMS */
15629               if (ep != NULL)
15630                 {
15631                   n = ep - nam;
15632                   dsp[0].fname = (char *) xmalloc (n + 1);
15633                   strncpy (dsp[0].fname, nam, n);
15634                   dsp[0].fname[n] = '\0';
15635                   if (n + INCLUDE_LEN_FUDGE > max_include_len)
15636                     max_include_len = n + INCLUDE_LEN_FUDGE;
15637                 }
15638               else
15639                 dsp[0].fname = NULL; /* Current directory */
15640               dsp[0].got_name_map = 0;
15641               break;
15642             }
15643         }
15644     }
15645
15646   /* Allocate this permanently, because it gets stored in the definitions
15647      of macros.  */
15648   fname = xmalloc (max_include_len + flen + 4);
15649   /* + 2 above for slash and terminating null.  */
15650   /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED
15651      for g77 yet).  */
15652
15653   /* If specified file name is absolute, just open it.  */
15654
15655   if (*fbeg == '/'
15656 #ifdef DIR_SEPARATOR
15657       || *fbeg == DIR_SEPARATOR
15658 #endif
15659       )
15660     {
15661       strncpy (fname, (char *) fbeg, flen);
15662       fname[flen] = 0;
15663       f = open_include_file (fname, NULL);
15664     }
15665   else
15666     {
15667       f = NULL;
15668
15669       /* Search directory path, trying to open the file.
15670          Copy each filename tried into FNAME.  */
15671
15672       for (searchptr = search_start; searchptr; searchptr = searchptr->next)
15673         {
15674           if (searchptr->fname)
15675             {
15676               /* The empty string in a search path is ignored.
15677                  This makes it possible to turn off entirely
15678                  a standard piece of the list.  */
15679               if (searchptr->fname[0] == 0)
15680                 continue;
15681               strcpy (fname, skip_redundant_dir_prefix (searchptr->fname));
15682               if (fname[0] && fname[strlen (fname) - 1] != '/')
15683                 strcat (fname, "/");
15684               fname[strlen (fname) + flen] = 0;
15685             }
15686           else
15687             fname[0] = 0;
15688
15689           strncat (fname, fbeg, flen);
15690 #ifdef VMS
15691           /* Change this 1/2 Unix 1/2 VMS file specification into a
15692              full VMS file specification */
15693           if (searchptr->fname && (searchptr->fname[0] != 0))
15694             {
15695               /* Fix up the filename */
15696               hack_vms_include_specification (fname);
15697             }
15698           else
15699             {
15700               /* This is a normal VMS filespec, so use it unchanged.  */
15701               strncpy (fname, (char *) fbeg, flen);
15702               fname[flen] = 0;
15703 #if 0   /* Not for g77.  */
15704               /* if it's '#include filename', add the missing .h */
15705               if (strchr (fname, '.') == NULL)
15706                 strcat (fname, ".h");
15707 #endif
15708             }
15709 #endif /* VMS */
15710           f = open_include_file (fname, searchptr);
15711 #ifdef EACCES
15712           if (f == NULL && errno == EACCES)
15713             {
15714               print_containing_files (FFEBAD_severityWARNING);
15715               /* xgettext:no-c-format */
15716               ffebad_start_msg ("At %0, INCLUDE file %A exists, but is not readable",
15717                                 FFEBAD_severityWARNING);
15718               ffebad_string (fname);
15719               ffebad_here (0, l, c);
15720               ffebad_finish ();
15721             }
15722 #endif
15723           if (f != NULL)
15724             break;
15725         }
15726     }
15727
15728   if (f == NULL)
15729     {
15730       /* A file that was not found.  */
15731
15732       strncpy (fname, (char *) fbeg, flen);
15733       fname[flen] = 0;
15734       print_containing_files (ffebad_severity (FFEBAD_OPEN_INCLUDE));
15735       ffebad_start (FFEBAD_OPEN_INCLUDE);
15736       ffebad_here (0, l, c);
15737       ffebad_string (fname);
15738       ffebad_finish ();
15739     }
15740
15741   if (dsp[0].fname != NULL)
15742     free (dsp[0].fname);
15743
15744   if (f == NULL)
15745     return NULL;
15746
15747   if (indepth >= (INPUT_STACK_MAX - 1))
15748     {
15749       print_containing_files (FFEBAD_severityFATAL);
15750       /* xgettext:no-c-format */
15751       ffebad_start_msg ("At %0, INCLUDE nesting too deep",
15752                         FFEBAD_severityFATAL);
15753       ffebad_string (fname);
15754       ffebad_here (0, l, c);
15755       ffebad_finish ();
15756       return NULL;
15757     }
15758
15759   instack[indepth].line = ffewhere_line_use (l);
15760   instack[indepth].column = ffewhere_column_use (c);
15761
15762   fp = &instack[indepth + 1];
15763   memset ((char *) fp, 0, sizeof (FILE_BUF));
15764   fp->nominal_fname = fp->fname = fname;
15765   fp->dir = searchptr;
15766
15767   indepth++;
15768   input_file_stack_tick++;
15769
15770   return f;
15771 }
15772
15773 /**INDENT* (Do not reformat this comment even with -fca option.)
15774    Data-gathering files: Given the source file listed below, compiled with
15775    f2c I obtained the output file listed after that, and from the output
15776    file I derived the above code.
15777
15778 -------- (begin input file to f2c)
15779         implicit none
15780         character*10 A1,A2
15781         complex C1,C2
15782         integer I1,I2
15783         real R1,R2
15784         double precision D1,D2
15785 C
15786         call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2)
15787 c /
15788         call fooI(I1/I2)
15789         call fooR(R1/I1)
15790         call fooD(D1/I1)
15791         call fooC(C1/I1)
15792         call fooR(R1/R2)
15793         call fooD(R1/D1)
15794         call fooD(D1/D2)
15795         call fooD(D1/R1)
15796         call fooC(C1/C2)
15797         call fooC(C1/R1)
15798         call fooZ(C1/D1)
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 FFEINTRIN_impABS
15812         call fooR(ABS(R1))
15813 c FFEINTRIN_impACOS
15814         call fooR(ACOS(R1))
15815 c FFEINTRIN_impAIMAG
15816         call fooR(AIMAG(C1))
15817 c FFEINTRIN_impAINT
15818         call fooR(AINT(R1))
15819 c FFEINTRIN_impALOG
15820         call fooR(ALOG(R1))
15821 c FFEINTRIN_impALOG10
15822         call fooR(ALOG10(R1))
15823 c FFEINTRIN_impAMAX0
15824         call fooR(AMAX0(I1,I2))
15825 c FFEINTRIN_impAMAX1
15826         call fooR(AMAX1(R1,R2))
15827 c FFEINTRIN_impAMIN0
15828         call fooR(AMIN0(I1,I2))
15829 c FFEINTRIN_impAMIN1
15830         call fooR(AMIN1(R1,R2))
15831 c FFEINTRIN_impAMOD
15832         call fooR(AMOD(R1,R2))
15833 c FFEINTRIN_impANINT
15834         call fooR(ANINT(R1))
15835 c FFEINTRIN_impASIN
15836         call fooR(ASIN(R1))
15837 c FFEINTRIN_impATAN
15838         call fooR(ATAN(R1))
15839 c FFEINTRIN_impATAN2
15840         call fooR(ATAN2(R1,R2))
15841 c FFEINTRIN_impCABS
15842         call fooR(CABS(C1))
15843 c FFEINTRIN_impCCOS
15844         call fooC(CCOS(C1))
15845 c FFEINTRIN_impCEXP
15846         call fooC(CEXP(C1))
15847 c FFEINTRIN_impCHAR
15848         call fooA(CHAR(I1))
15849 c FFEINTRIN_impCLOG
15850         call fooC(CLOG(C1))
15851 c FFEINTRIN_impCONJG
15852         call fooC(CONJG(C1))
15853 c FFEINTRIN_impCOS
15854         call fooR(COS(R1))
15855 c FFEINTRIN_impCOSH
15856         call fooR(COSH(R1))
15857 c FFEINTRIN_impCSIN
15858         call fooC(CSIN(C1))
15859 c FFEINTRIN_impCSQRT
15860         call fooC(CSQRT(C1))
15861 c FFEINTRIN_impDABS
15862         call fooD(DABS(D1))
15863 c FFEINTRIN_impDACOS
15864         call fooD(DACOS(D1))
15865 c FFEINTRIN_impDASIN
15866         call fooD(DASIN(D1))
15867 c FFEINTRIN_impDATAN
15868         call fooD(DATAN(D1))
15869 c FFEINTRIN_impDATAN2
15870         call fooD(DATAN2(D1,D2))
15871 c FFEINTRIN_impDCOS
15872         call fooD(DCOS(D1))
15873 c FFEINTRIN_impDCOSH
15874         call fooD(DCOSH(D1))
15875 c FFEINTRIN_impDDIM
15876         call fooD(DDIM(D1,D2))
15877 c FFEINTRIN_impDEXP
15878         call fooD(DEXP(D1))
15879 c FFEINTRIN_impDIM
15880         call fooR(DIM(R1,R2))
15881 c FFEINTRIN_impDINT
15882         call fooD(DINT(D1))
15883 c FFEINTRIN_impDLOG
15884         call fooD(DLOG(D1))
15885 c FFEINTRIN_impDLOG10
15886         call fooD(DLOG10(D1))
15887 c FFEINTRIN_impDMAX1
15888         call fooD(DMAX1(D1,D2))
15889 c FFEINTRIN_impDMIN1
15890         call fooD(DMIN1(D1,D2))
15891 c FFEINTRIN_impDMOD
15892         call fooD(DMOD(D1,D2))
15893 c FFEINTRIN_impDNINT
15894         call fooD(DNINT(D1))
15895 c FFEINTRIN_impDPROD
15896         call fooD(DPROD(R1,R2))
15897 c FFEINTRIN_impDSIGN
15898         call fooD(DSIGN(D1,D2))
15899 c FFEINTRIN_impDSIN
15900         call fooD(DSIN(D1))
15901 c FFEINTRIN_impDSINH
15902         call fooD(DSINH(D1))
15903 c FFEINTRIN_impDSQRT
15904         call fooD(DSQRT(D1))
15905 c FFEINTRIN_impDTAN
15906         call fooD(DTAN(D1))
15907 c FFEINTRIN_impDTANH
15908         call fooD(DTANH(D1))
15909 c FFEINTRIN_impEXP
15910         call fooR(EXP(R1))
15911 c FFEINTRIN_impIABS
15912         call fooI(IABS(I1))
15913 c FFEINTRIN_impICHAR
15914         call fooI(ICHAR(A1))
15915 c FFEINTRIN_impIDIM
15916         call fooI(IDIM(I1,I2))
15917 c FFEINTRIN_impIDNINT
15918         call fooI(IDNINT(D1))
15919 c FFEINTRIN_impINDEX
15920         call fooI(INDEX(A1,A2))
15921 c FFEINTRIN_impISIGN
15922         call fooI(ISIGN(I1,I2))
15923 c FFEINTRIN_impLEN
15924         call fooI(LEN(A1))
15925 c FFEINTRIN_impLGE
15926         call fooL(LGE(A1,A2))
15927 c FFEINTRIN_impLGT
15928         call fooL(LGT(A1,A2))
15929 c FFEINTRIN_impLLE
15930         call fooL(LLE(A1,A2))
15931 c FFEINTRIN_impLLT
15932         call fooL(LLT(A1,A2))
15933 c FFEINTRIN_impMAX0
15934         call fooI(MAX0(I1,I2))
15935 c FFEINTRIN_impMAX1
15936         call fooI(MAX1(R1,R2))
15937 c FFEINTRIN_impMIN0
15938         call fooI(MIN0(I1,I2))
15939 c FFEINTRIN_impMIN1
15940         call fooI(MIN1(R1,R2))
15941 c FFEINTRIN_impMOD
15942         call fooI(MOD(I1,I2))
15943 c FFEINTRIN_impNINT
15944         call fooI(NINT(R1))
15945 c FFEINTRIN_impSIGN
15946         call fooR(SIGN(R1,R2))
15947 c FFEINTRIN_impSIN
15948         call fooR(SIN(R1))
15949 c FFEINTRIN_impSINH
15950         call fooR(SINH(R1))
15951 c FFEINTRIN_impSQRT
15952         call fooR(SQRT(R1))
15953 c FFEINTRIN_impTAN
15954         call fooR(TAN(R1))
15955 c FFEINTRIN_impTANH
15956         call fooR(TANH(R1))
15957 c FFEINTRIN_imp_CMPLX_C
15958         call fooC(cmplx(C1,C2))
15959 c FFEINTRIN_imp_CMPLX_D
15960         call fooZ(cmplx(D1,D2))
15961 c FFEINTRIN_imp_CMPLX_I
15962         call fooC(cmplx(I1,I2))
15963 c FFEINTRIN_imp_CMPLX_R
15964         call fooC(cmplx(R1,R2))
15965 c FFEINTRIN_imp_DBLE_C
15966         call fooD(dble(C1))
15967 c FFEINTRIN_imp_DBLE_D
15968         call fooD(dble(D1))
15969 c FFEINTRIN_imp_DBLE_I
15970         call fooD(dble(I1))
15971 c FFEINTRIN_imp_DBLE_R
15972         call fooD(dble(R1))
15973 c FFEINTRIN_imp_INT_C
15974         call fooI(int(C1))
15975 c FFEINTRIN_imp_INT_D
15976         call fooI(int(D1))
15977 c FFEINTRIN_imp_INT_I
15978         call fooI(int(I1))
15979 c FFEINTRIN_imp_INT_R
15980         call fooI(int(R1))
15981 c FFEINTRIN_imp_REAL_C
15982         call fooR(real(C1))
15983 c FFEINTRIN_imp_REAL_D
15984         call fooR(real(D1))
15985 c FFEINTRIN_imp_REAL_I
15986         call fooR(real(I1))
15987 c FFEINTRIN_imp_REAL_R
15988         call fooR(real(R1))
15989 c
15990 c FFEINTRIN_imp_INT_D:
15991 c
15992 c FFEINTRIN_specIDINT
15993         call fooI(IDINT(D1))
15994 c
15995 c FFEINTRIN_imp_INT_R:
15996 c
15997 c FFEINTRIN_specIFIX
15998         call fooI(IFIX(R1))
15999 c FFEINTRIN_specINT
16000         call fooI(INT(R1))
16001 c
16002 c FFEINTRIN_imp_REAL_D:
16003 c
16004 c FFEINTRIN_specSNGL
16005         call fooR(SNGL(D1))
16006 c
16007 c FFEINTRIN_imp_REAL_I:
16008 c
16009 c FFEINTRIN_specFLOAT
16010         call fooR(FLOAT(I1))
16011 c FFEINTRIN_specREAL
16012         call fooR(REAL(I1))
16013 c
16014         end
16015 -------- (end input file to f2c)
16016
16017 -------- (begin output from providing above input file as input to:
16018 --------  `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
16019 --------     -e "s:^#.*$::g"')
16020
16021 //  -- translated by f2c (version 19950223).
16022    You must link the resulting object file with the libraries:
16023         -lf2c -lm   (in that order)
16024 //
16025
16026
16027 // f2c.h  --  Standard Fortran to C header file //
16028
16029 ///  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
16030
16031         - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
16032
16033
16034
16035
16036 // F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems //
16037 // we assume short, float are OK //
16038 typedef long int // long int // integer;
16039 typedef char *address;
16040 typedef short int shortint;
16041 typedef float real;
16042 typedef double doublereal;
16043 typedef struct { real r, i; } complex;
16044 typedef struct { doublereal r, i; } doublecomplex;
16045 typedef long int // long int // logical;
16046 typedef short int shortlogical;
16047 typedef char logical1;
16048 typedef char integer1;
16049 // typedef long long longint; // // system-dependent //
16050
16051
16052
16053
16054 // Extern is for use with -E //
16055
16056
16057
16058
16059 // I/O stuff //
16060
16061
16062
16063
16064
16065
16066
16067
16068 typedef long int // int or long int // flag;
16069 typedef long int // int or long int // ftnlen;
16070 typedef long int // int or long int // ftnint;
16071
16072
16073 //external read, write//
16074 typedef struct
16075 {       flag cierr;
16076         ftnint ciunit;
16077         flag ciend;
16078         char *cifmt;
16079         ftnint cirec;
16080 } cilist;
16081
16082 //internal read, write//
16083 typedef struct
16084 {       flag icierr;
16085         char *iciunit;
16086         flag iciend;
16087         char *icifmt;
16088         ftnint icirlen;
16089         ftnint icirnum;
16090 } icilist;
16091
16092 //open//
16093 typedef struct
16094 {       flag oerr;
16095         ftnint ounit;
16096         char *ofnm;
16097         ftnlen ofnmlen;
16098         char *osta;
16099         char *oacc;
16100         char *ofm;
16101         ftnint orl;
16102         char *oblnk;
16103 } olist;
16104
16105 //close//
16106 typedef struct
16107 {       flag cerr;
16108         ftnint cunit;
16109         char *csta;
16110 } cllist;
16111
16112 //rewind, backspace, endfile//
16113 typedef struct
16114 {       flag aerr;
16115         ftnint aunit;
16116 } alist;
16117
16118 // inquire //
16119 typedef struct
16120 {       flag inerr;
16121         ftnint inunit;
16122         char *infile;
16123         ftnlen infilen;
16124         ftnint  *inex;  //parameters in standard's order//
16125         ftnint  *inopen;
16126         ftnint  *innum;
16127         ftnint  *innamed;
16128         char    *inname;
16129         ftnlen  innamlen;
16130         char    *inacc;
16131         ftnlen  inacclen;
16132         char    *inseq;
16133         ftnlen  inseqlen;
16134         char    *indir;
16135         ftnlen  indirlen;
16136         char    *infmt;
16137         ftnlen  infmtlen;
16138         char    *inform;
16139         ftnint  informlen;
16140         char    *inunf;
16141         ftnlen  inunflen;
16142         ftnint  *inrecl;
16143         ftnint  *innrec;
16144         char    *inblank;
16145         ftnlen  inblanklen;
16146 } inlist;
16147
16148
16149
16150 union Multitype {       // for multiple entry points //
16151         integer1 g;
16152         shortint h;
16153         integer i;
16154         // longint j; //
16155         real r;
16156         doublereal d;
16157         complex c;
16158         doublecomplex z;
16159         };
16160
16161 typedef union Multitype Multitype;
16162
16163 typedef long Long;      // No longer used; formerly in Namelist //
16164
16165 struct Vardesc {        // for Namelist //
16166         char *name;
16167         char *addr;
16168         ftnlen *dims;
16169         int  type;
16170         };
16171 typedef struct Vardesc Vardesc;
16172
16173 struct Namelist {
16174         char *name;
16175         Vardesc **vars;
16176         int nvars;
16177         };
16178 typedef struct Namelist Namelist;
16179
16180
16181
16182
16183
16184
16185
16186
16187 // procedure parameter types for -A and -C++ //
16188
16189
16190
16191
16192 typedef int // Unknown procedure type // (*U_fp)();
16193 typedef shortint (*J_fp)();
16194 typedef integer (*I_fp)();
16195 typedef real (*R_fp)();
16196 typedef doublereal (*D_fp)(), (*E_fp)();
16197 typedef // Complex // void  (*C_fp)();
16198 typedef // Double Complex // void  (*Z_fp)();
16199 typedef logical (*L_fp)();
16200 typedef shortlogical (*K_fp)();
16201 typedef // Character // void  (*H_fp)();
16202 typedef // Subroutine // int (*S_fp)();
16203
16204 // E_fp is for real functions when -R is not specified //
16205 typedef void  C_f;      // complex function //
16206 typedef void  H_f;      // character function //
16207 typedef void  Z_f;      // double complex function //
16208 typedef doublereal E_f; // real function with -R not specified //
16209
16210 // undef any lower-case symbols that your C compiler predefines, e.g.: //
16211
16212
16213 // (No such symbols should be defined in a strict ANSI C compiler.
16214    We can avoid trouble with f2c-translated code by using
16215    gcc -ansi.) //
16216
16217
16218
16219
16220
16221
16222
16223
16224
16225
16226
16227
16228
16229
16230
16231
16232
16233
16234
16235
16236
16237
16238
16239 // Main program // MAIN__()
16240 {
16241     // System generated locals //
16242     integer i__1;
16243     real r__1, r__2;
16244     doublereal d__1, d__2;
16245     complex q__1;
16246     doublecomplex z__1, z__2, z__3;
16247     logical L__1;
16248     char ch__1[1];
16249
16250     // Builtin functions //
16251     void c_div();
16252     integer pow_ii();
16253     double pow_ri(), pow_di();
16254     void pow_ci();
16255     double pow_dd();
16256     void pow_zz();
16257     double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
16258             asin(), atan(), atan2(), c_abs();
16259     void c_cos(), c_exp(), c_log(), r_cnjg();
16260     double cos(), cosh();
16261     void c_sin(), c_sqrt();
16262     double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
16263             d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
16264     integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
16265     logical l_ge(), l_gt(), l_le(), l_lt();
16266     integer i_nint();
16267     double r_sign();
16268
16269     // Local variables //
16270     extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
16271             fool_(), fooz_(), getem_();
16272     static char a1[10], a2[10];
16273     static complex c1, c2;
16274     static doublereal d1, d2;
16275     static integer i1, i2;
16276     static real r1, r2;
16277
16278
16279     getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L);
16280 // / //
16281     i__1 = i1 / i2;
16282     fooi_(&i__1);
16283     r__1 = r1 / i1;
16284     foor_(&r__1);
16285     d__1 = d1 / i1;
16286     food_(&d__1);
16287     d__1 = (doublereal) i1;
16288     q__1.r = c1.r / d__1, q__1.i = c1.i / d__1;
16289     fooc_(&q__1);
16290     r__1 = r1 / r2;
16291     foor_(&r__1);
16292     d__1 = r1 / d1;
16293     food_(&d__1);
16294     d__1 = d1 / d2;
16295     food_(&d__1);
16296     d__1 = d1 / r1;
16297     food_(&d__1);
16298     c_div(&q__1, &c1, &c2);
16299     fooc_(&q__1);
16300     q__1.r = c1.r / r1, q__1.i = c1.i / r1;
16301     fooc_(&q__1);
16302     z__1.r = c1.r / d1, z__1.i = c1.i / d1;
16303     fooz_(&z__1);
16304 // ** //
16305     i__1 = pow_ii(&i1, &i2);
16306     fooi_(&i__1);
16307     r__1 = pow_ri(&r1, &i1);
16308     foor_(&r__1);
16309     d__1 = pow_di(&d1, &i1);
16310     food_(&d__1);
16311     pow_ci(&q__1, &c1, &i1);
16312     fooc_(&q__1);
16313     d__1 = (doublereal) r1;
16314     d__2 = (doublereal) r2;
16315     r__1 = pow_dd(&d__1, &d__2);
16316     foor_(&r__1);
16317     d__2 = (doublereal) r1;
16318     d__1 = pow_dd(&d__2, &d1);
16319     food_(&d__1);
16320     d__1 = pow_dd(&d1, &d2);
16321     food_(&d__1);
16322     d__2 = (doublereal) r1;
16323     d__1 = pow_dd(&d1, &d__2);
16324     food_(&d__1);
16325     z__2.r = c1.r, z__2.i = c1.i;
16326     z__3.r = c2.r, z__3.i = c2.i;
16327     pow_zz(&z__1, &z__2, &z__3);
16328     q__1.r = z__1.r, q__1.i = z__1.i;
16329     fooc_(&q__1);
16330     z__2.r = c1.r, z__2.i = c1.i;
16331     z__3.r = r1, z__3.i = 0.;
16332     pow_zz(&z__1, &z__2, &z__3);
16333     q__1.r = z__1.r, q__1.i = z__1.i;
16334     fooc_(&q__1);
16335     z__2.r = c1.r, z__2.i = c1.i;
16336     z__3.r = d1, z__3.i = 0.;
16337     pow_zz(&z__1, &z__2, &z__3);
16338     fooz_(&z__1);
16339 // FFEINTRIN_impABS //
16340     r__1 = (doublereal)((  r1  ) >= 0 ? (  r1  ) : -(  r1  ))  ;
16341     foor_(&r__1);
16342 // FFEINTRIN_impACOS //
16343     r__1 = acos(r1);
16344     foor_(&r__1);
16345 // FFEINTRIN_impAIMAG //
16346     r__1 = r_imag(&c1);
16347     foor_(&r__1);
16348 // FFEINTRIN_impAINT //
16349     r__1 = r_int(&r1);
16350     foor_(&r__1);
16351 // FFEINTRIN_impALOG //
16352     r__1 = log(r1);
16353     foor_(&r__1);
16354 // FFEINTRIN_impALOG10 //
16355     r__1 = r_lg10(&r1);
16356     foor_(&r__1);
16357 // FFEINTRIN_impAMAX0 //
16358     r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16359     foor_(&r__1);
16360 // FFEINTRIN_impAMAX1 //
16361     r__1 = (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16362     foor_(&r__1);
16363 // FFEINTRIN_impAMIN0 //
16364     r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16365     foor_(&r__1);
16366 // FFEINTRIN_impAMIN1 //
16367     r__1 = (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16368     foor_(&r__1);
16369 // FFEINTRIN_impAMOD //
16370     r__1 = r_mod(&r1, &r2);
16371     foor_(&r__1);
16372 // FFEINTRIN_impANINT //
16373     r__1 = r_nint(&r1);
16374     foor_(&r__1);
16375 // FFEINTRIN_impASIN //
16376     r__1 = asin(r1);
16377     foor_(&r__1);
16378 // FFEINTRIN_impATAN //
16379     r__1 = atan(r1);
16380     foor_(&r__1);
16381 // FFEINTRIN_impATAN2 //
16382     r__1 = atan2(r1, r2);
16383     foor_(&r__1);
16384 // FFEINTRIN_impCABS //
16385     r__1 = c_abs(&c1);
16386     foor_(&r__1);
16387 // FFEINTRIN_impCCOS //
16388     c_cos(&q__1, &c1);
16389     fooc_(&q__1);
16390 // FFEINTRIN_impCEXP //
16391     c_exp(&q__1, &c1);
16392     fooc_(&q__1);
16393 // FFEINTRIN_impCHAR //
16394     *(unsigned char *)&ch__1[0] = i1;
16395     fooa_(ch__1, 1L);
16396 // FFEINTRIN_impCLOG //
16397     c_log(&q__1, &c1);
16398     fooc_(&q__1);
16399 // FFEINTRIN_impCONJG //
16400     r_cnjg(&q__1, &c1);
16401     fooc_(&q__1);
16402 // FFEINTRIN_impCOS //
16403     r__1 = cos(r1);
16404     foor_(&r__1);
16405 // FFEINTRIN_impCOSH //
16406     r__1 = cosh(r1);
16407     foor_(&r__1);
16408 // FFEINTRIN_impCSIN //
16409     c_sin(&q__1, &c1);
16410     fooc_(&q__1);
16411 // FFEINTRIN_impCSQRT //
16412     c_sqrt(&q__1, &c1);
16413     fooc_(&q__1);
16414 // FFEINTRIN_impDABS //
16415     d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ;
16416     food_(&d__1);
16417 // FFEINTRIN_impDACOS //
16418     d__1 = acos(d1);
16419     food_(&d__1);
16420 // FFEINTRIN_impDASIN //
16421     d__1 = asin(d1);
16422     food_(&d__1);
16423 // FFEINTRIN_impDATAN //
16424     d__1 = atan(d1);
16425     food_(&d__1);
16426 // FFEINTRIN_impDATAN2 //
16427     d__1 = atan2(d1, d2);
16428     food_(&d__1);
16429 // FFEINTRIN_impDCOS //
16430     d__1 = cos(d1);
16431     food_(&d__1);
16432 // FFEINTRIN_impDCOSH //
16433     d__1 = cosh(d1);
16434     food_(&d__1);
16435 // FFEINTRIN_impDDIM //
16436     d__1 = d_dim(&d1, &d2);
16437     food_(&d__1);
16438 // FFEINTRIN_impDEXP //
16439     d__1 = exp(d1);
16440     food_(&d__1);
16441 // FFEINTRIN_impDIM //
16442     r__1 = r_dim(&r1, &r2);
16443     foor_(&r__1);
16444 // FFEINTRIN_impDINT //
16445     d__1 = d_int(&d1);
16446     food_(&d__1);
16447 // FFEINTRIN_impDLOG //
16448     d__1 = log(d1);
16449     food_(&d__1);
16450 // FFEINTRIN_impDLOG10 //
16451     d__1 = d_lg10(&d1);
16452     food_(&d__1);
16453 // FFEINTRIN_impDMAX1 //
16454     d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ;
16455     food_(&d__1);
16456 // FFEINTRIN_impDMIN1 //
16457     d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ;
16458     food_(&d__1);
16459 // FFEINTRIN_impDMOD //
16460     d__1 = d_mod(&d1, &d2);
16461     food_(&d__1);
16462 // FFEINTRIN_impDNINT //
16463     d__1 = d_nint(&d1);
16464     food_(&d__1);
16465 // FFEINTRIN_impDPROD //
16466     d__1 = (doublereal) r1 * r2;
16467     food_(&d__1);
16468 // FFEINTRIN_impDSIGN //
16469     d__1 = d_sign(&d1, &d2);
16470     food_(&d__1);
16471 // FFEINTRIN_impDSIN //
16472     d__1 = sin(d1);
16473     food_(&d__1);
16474 // FFEINTRIN_impDSINH //
16475     d__1 = sinh(d1);
16476     food_(&d__1);
16477 // FFEINTRIN_impDSQRT //
16478     d__1 = sqrt(d1);
16479     food_(&d__1);
16480 // FFEINTRIN_impDTAN //
16481     d__1 = tan(d1);
16482     food_(&d__1);
16483 // FFEINTRIN_impDTANH //
16484     d__1 = tanh(d1);
16485     food_(&d__1);
16486 // FFEINTRIN_impEXP //
16487     r__1 = exp(r1);
16488     foor_(&r__1);
16489 // FFEINTRIN_impIABS //
16490     i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ;
16491     fooi_(&i__1);
16492 // FFEINTRIN_impICHAR //
16493     i__1 = *(unsigned char *)a1;
16494     fooi_(&i__1);
16495 // FFEINTRIN_impIDIM //
16496     i__1 = i_dim(&i1, &i2);
16497     fooi_(&i__1);
16498 // FFEINTRIN_impIDNINT //
16499     i__1 = i_dnnt(&d1);
16500     fooi_(&i__1);
16501 // FFEINTRIN_impINDEX //
16502     i__1 = i_indx(a1, a2, 10L, 10L);
16503     fooi_(&i__1);
16504 // FFEINTRIN_impISIGN //
16505     i__1 = i_sign(&i1, &i2);
16506     fooi_(&i__1);
16507 // FFEINTRIN_impLEN //
16508     i__1 = i_len(a1, 10L);
16509     fooi_(&i__1);
16510 // FFEINTRIN_impLGE //
16511     L__1 = l_ge(a1, a2, 10L, 10L);
16512     fool_(&L__1);
16513 // FFEINTRIN_impLGT //
16514     L__1 = l_gt(a1, a2, 10L, 10L);
16515     fool_(&L__1);
16516 // FFEINTRIN_impLLE //
16517     L__1 = l_le(a1, a2, 10L, 10L);
16518     fool_(&L__1);
16519 // FFEINTRIN_impLLT //
16520     L__1 = l_lt(a1, a2, 10L, 10L);
16521     fool_(&L__1);
16522 // FFEINTRIN_impMAX0 //
16523     i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16524     fooi_(&i__1);
16525 // FFEINTRIN_impMAX1 //
16526     i__1 = (integer) (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16527     fooi_(&i__1);
16528 // FFEINTRIN_impMIN0 //
16529     i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16530     fooi_(&i__1);
16531 // FFEINTRIN_impMIN1 //
16532     i__1 = (integer) (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16533     fooi_(&i__1);
16534 // FFEINTRIN_impMOD //
16535     i__1 = i1 % i2;
16536     fooi_(&i__1);
16537 // FFEINTRIN_impNINT //
16538     i__1 = i_nint(&r1);
16539     fooi_(&i__1);
16540 // FFEINTRIN_impSIGN //
16541     r__1 = r_sign(&r1, &r2);
16542     foor_(&r__1);
16543 // FFEINTRIN_impSIN //
16544     r__1 = sin(r1);
16545     foor_(&r__1);
16546 // FFEINTRIN_impSINH //
16547     r__1 = sinh(r1);
16548     foor_(&r__1);
16549 // FFEINTRIN_impSQRT //
16550     r__1 = sqrt(r1);
16551     foor_(&r__1);
16552 // FFEINTRIN_impTAN //
16553     r__1 = tan(r1);
16554     foor_(&r__1);
16555 // FFEINTRIN_impTANH //
16556     r__1 = tanh(r1);
16557     foor_(&r__1);
16558 // FFEINTRIN_imp_CMPLX_C //
16559     r__1 = c1.r;
16560     r__2 = c2.r;
16561     q__1.r = r__1, q__1.i = r__2;
16562     fooc_(&q__1);
16563 // FFEINTRIN_imp_CMPLX_D //
16564     z__1.r = d1, z__1.i = d2;
16565     fooz_(&z__1);
16566 // FFEINTRIN_imp_CMPLX_I //
16567     r__1 = (real) i1;
16568     r__2 = (real) i2;
16569     q__1.r = r__1, q__1.i = r__2;
16570     fooc_(&q__1);
16571 // FFEINTRIN_imp_CMPLX_R //
16572     q__1.r = r1, q__1.i = r2;
16573     fooc_(&q__1);
16574 // FFEINTRIN_imp_DBLE_C //
16575     d__1 = (doublereal) c1.r;
16576     food_(&d__1);
16577 // FFEINTRIN_imp_DBLE_D //
16578     d__1 = d1;
16579     food_(&d__1);
16580 // FFEINTRIN_imp_DBLE_I //
16581     d__1 = (doublereal) i1;
16582     food_(&d__1);
16583 // FFEINTRIN_imp_DBLE_R //
16584     d__1 = (doublereal) r1;
16585     food_(&d__1);
16586 // FFEINTRIN_imp_INT_C //
16587     i__1 = (integer) c1.r;
16588     fooi_(&i__1);
16589 // FFEINTRIN_imp_INT_D //
16590     i__1 = (integer) d1;
16591     fooi_(&i__1);
16592 // FFEINTRIN_imp_INT_I //
16593     i__1 = i1;
16594     fooi_(&i__1);
16595 // FFEINTRIN_imp_INT_R //
16596     i__1 = (integer) r1;
16597     fooi_(&i__1);
16598 // FFEINTRIN_imp_REAL_C //
16599     r__1 = c1.r;
16600     foor_(&r__1);
16601 // FFEINTRIN_imp_REAL_D //
16602     r__1 = (real) d1;
16603     foor_(&r__1);
16604 // FFEINTRIN_imp_REAL_I //
16605     r__1 = (real) i1;
16606     foor_(&r__1);
16607 // FFEINTRIN_imp_REAL_R //
16608     r__1 = r1;
16609     foor_(&r__1);
16610
16611 // FFEINTRIN_imp_INT_D: //
16612
16613 // FFEINTRIN_specIDINT //
16614     i__1 = (integer) d1;
16615     fooi_(&i__1);
16616
16617 // FFEINTRIN_imp_INT_R: //
16618
16619 // FFEINTRIN_specIFIX //
16620     i__1 = (integer) r1;
16621     fooi_(&i__1);
16622 // FFEINTRIN_specINT //
16623     i__1 = (integer) r1;
16624     fooi_(&i__1);
16625
16626 // FFEINTRIN_imp_REAL_D: //
16627
16628 // FFEINTRIN_specSNGL //
16629     r__1 = (real) d1;
16630     foor_(&r__1);
16631
16632 // FFEINTRIN_imp_REAL_I: //
16633
16634 // FFEINTRIN_specFLOAT //
16635     r__1 = (real) i1;
16636     foor_(&r__1);
16637 // FFEINTRIN_specREAL //
16638     r__1 = (real) i1;
16639     foor_(&r__1);
16640
16641 } // MAIN__ //
16642
16643 -------- (end output file from f2c)
16644
16645 */