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, 2003
   3    Free Software Foundation, Inc.
   4    Contributed by James Craig Burley.
   5
   6 This file is part of GNU Fortran.
   7
   8 GNU Fortran is free software; you can redistribute it and/or modify
   9 it under the terms of the GNU General Public License as published by
  10 the Free Software Foundation; either version 2, or (at your option)
  11 any later version.
  12
  13 GNU Fortran is distributed in the hope that it will be useful,
  14 but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 GNU General Public License for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with GNU Fortran; see the file COPYING.  If not, write to
  20 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
  21 02111-1307, USA.
  22
  23    Related Modules:
  24       None
  25
  26    Description:
  27       Contains compiler-specific functions.
  28
  29    Modifications:
  30 */
  31
  32 /* Understanding this module means understanding the interface between
  33    the g77 front end and the gcc back end (or, perhaps, some other
  34    back end).  In here are the functions called by the front end proper
  35    to notify whatever back end is in place about certain things, and
  36    also the back-end-specific functions.  It's a bear to deal with, so
  37    lately I've been trying to simplify things, especially with regard
  38    to the gcc-back-end-specific stuff.
  39
  40    Building expressions generally seems quite easy, but building decls
  41    has been challenging and is undergoing revision.  gcc has several
  42    kinds of decls:
  43
  44    TYPE_DECL -- a type (int, float, struct, function, etc.)
  45    CONST_DECL -- a constant of some type other than function
  46    LABEL_DECL -- a variable or a constant?
  47    PARM_DECL -- an argument to a function (a variable that is a dummy)
  48    RESULT_DECL -- the return value of a function (a variable)
  49    VAR_DECL -- other variable (can hold a ptr-to-function, struct, int, etc.)
  50    FUNCTION_DECL -- a function (either the actual function or an extern ref)
  51    FIELD_DECL -- a field in a struct or union (goes into types)
  52
  53    g77 has a set of functions that somewhat parallels the gcc front end
  54    when it comes to building decls:
  55
  56    Internal Function (one we define, not just declare as extern):
  57    if (is_nested) push_f_function_context ();
  58    start_function (get_identifier ("function_name"), function_type,
  59                    is_nested, is_public);
  60    // for each arg, build PARM_DECL and call push_parm_decl (decl) with it;
  61    store_parm_decls (is_main_program);
  62    ffecom_start_compstmt ();
  63    // for stmts and decls inside function, do appropriate things;
  64    ffecom_end_compstmt ();
  65    finish_function (is_nested);
  66    if (is_nested) pop_f_function_context ();
  67
  68    Everything Else:
  69    tree d;
  70    tree init;
  71    // fill in external, public, static, &c for decl, and
  72    // set DECL_INITIAL to error_mark_node if going to initialize
  73    // set is_top_level TRUE only if not at top level and decl
  74    // must go in top level (i.e. not within current function decl context)
  75    d = start_decl (decl, is_top_level);
  76    init = ...;  // if have initializer
  77    finish_decl (d, init, is_top_level);
  78
  79 */
  80
  81 /* Include files. */
  82
  83 #include "proj.h"
  84 #include "flags.h"
  85 #include "real.h"
  86 #include "rtl.h"
  87 #include "toplev.h"
  88 #include "tree.h"
  89 #include "output.h"  /* Must follow tree.h so TREE_CODE is defined! */
  90 #include "convert.h"
  91 #include "ggc.h"
  92 #include "diagnostic.h"
  93 #include "intl.h"
  94 #include "langhooks.h"
  95 #include "langhooks-def.h"
  96 #include "debug.h"
  97
  98 /* VMS-specific definitions */
  99 #ifdef VMS
 100 #include <descrip.h>
 101 #define O_RDONLY        0       /* Open arg for Read/Only  */
 102 #define O_WRONLY        1       /* Open arg for Write/Only */
 103 #define read(fd,buf,size)       VMS_read (fd,buf,size)
 104 #define write(fd,buf,size)      VMS_write (fd,buf,size)
 105 #define open(fname,mode,prot)   VMS_open (fname,mode,prot)
 106 #define fopen(fname,mode)       VMS_fopen (fname,mode)
 107 #define freopen(fname,mode,ofile) VMS_freopen (fname,mode,ofile)
 108 #define strncat(dst,src,cnt) VMS_strncat (dst,src,cnt)
 109 #define fstat(fd,stbuf)         VMS_fstat (fd,stbuf)
 110 static int VMS_fstat (), VMS_stat ();
 111 static char * VMS_strncat ();
 112 static int VMS_read ();
 113 static int VMS_write ();
 114 static int VMS_open ();
 115 static FILE * VMS_fopen ();
 116 static FILE * VMS_freopen ();
 117 static void hack_vms_include_specification ();
 118 typedef struct { unsigned :16, :16, :16; } vms_ino_t;
 119 #define ino_t vms_ino_t
 120 #define INCLUDE_LEN_FUDGE 10    /* leave room for VMS syntax conversion */
 121 #endif /* VMS */
 122
 123 #define FFECOM_DETERMINE_TYPES 1 /* for com.h */
 124 #include "com.h"
 125 #include "bad.h"
 126 #include "bld.h"
 127 #include "equiv.h"
 128 #include "expr.h"
 129 #include "implic.h"
 130 #include "info.h"
 131 #include "malloc.h"
 132 #include "src.h"
 133 #include "st.h"
 134 #include "storag.h"
 135 #include "symbol.h"
 136 #include "target.h"
 137 #include "top.h"
 138 #include "type.h"
 139
 140 /* Externals defined here.  */
 141
 142 /* Stream for reading from the input file.  */
 143 FILE *finput;
 144
 145 /* These definitions parallel those in c-decl.c so that code from that
 146    module can be used pretty much as is.  Much of these defs aren't
 147    otherwise used, i.e. by g77 code per se, except some of them are used
 148    to build some of them that are.  The ones that are global (i.e. not
 149    "static") are those that ste.c and such might use (directly
 150    or by using com macros that reference them in their definitions).  */
 151
 152 tree string_type_node;
 153
 154 /* The rest of these are inventions for g77, though there might be
 155    similar things in the C front end.  As they are found, these
 156    inventions should be renamed to be canonical.  Note that only
 157    the ones currently required to be global are so.  */
 158
 159 static GTY(()) tree ffecom_tree_fun_type_void;
 160
 161 tree ffecom_integer_type_node;  /* Abbrev for _tree_type[blah][blah]. */
 162 tree ffecom_integer_zero_node;  /* Like *_*_* with g77's integer type. */
 163 tree ffecom_integer_one_node;   /* " */
 164 tree ffecom_tree_type[FFEINFO_basictype][FFEINFO_kindtype];
 165
 166 /* _fun_type things are the f2c-specific versions.  For -fno-f2c,
 167    just use build_function_type and build_pointer_type on the
 168    appropriate _tree_type array element.  */
 169
 170 static GTY(()) tree ffecom_tree_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
 171 static GTY(()) tree
 172   ffecom_tree_ptr_to_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
 173 static GTY(()) tree ffecom_tree_subr_type;
 174 static GTY(()) tree ffecom_tree_ptr_to_subr_type;
 175 static GTY(()) tree ffecom_tree_blockdata_type;
 176
 177 static GTY(()) tree ffecom_tree_xargc_;
 178
 179 ffecomSymbol ffecom_symbol_null_
 180 =
 181 {
 182   NULL_TREE,
 183   NULL_TREE,
 184   NULL_TREE,
 185   NULL_TREE,
 186   false
 187 };
 188 ffeinfoKindtype ffecom_pointer_kind_ = FFEINFO_basictypeNONE;
 189 ffeinfoKindtype ffecom_label_kind_ = FFEINFO_basictypeNONE;
 190
 191 int ffecom_f2c_typecode_[FFEINFO_basictype][FFEINFO_kindtype];
 192 tree ffecom_f2c_integer_type_node;
 193 static GTY(()) tree ffecom_f2c_ptr_to_integer_type_node;
 194 tree ffecom_f2c_address_type_node;
 195 tree ffecom_f2c_real_type_node;
 196 static GTY(()) tree ffecom_f2c_ptr_to_real_type_node;
 197 tree ffecom_f2c_doublereal_type_node;
 198 tree ffecom_f2c_complex_type_node;
 199 tree ffecom_f2c_doublecomplex_type_node;
 200 tree ffecom_f2c_longint_type_node;
 201 tree ffecom_f2c_logical_type_node;
 202 tree ffecom_f2c_flag_type_node;
 203 tree ffecom_f2c_ftnlen_type_node;
 204 tree ffecom_f2c_ftnlen_zero_node;
 205 tree ffecom_f2c_ftnlen_one_node;
 206 tree ffecom_f2c_ftnlen_two_node;
 207 tree ffecom_f2c_ptr_to_ftnlen_type_node;
 208 tree ffecom_f2c_ftnint_type_node;
 209 tree ffecom_f2c_ptr_to_ftnint_type_node;
 210
 211 /* Simple definitions and enumerations. */
 212
 213 #ifndef FFECOM_sizeMAXSTACKITEM
 214 #define FFECOM_sizeMAXSTACKITEM 32*1024 /* Keep user-declared things
 215                                            larger than this # bytes
 216                                            off stack if possible. */
 217 #endif
 218
 219 /* For systems that have large enough stacks, they should define
 220    this to 0, and here, for ease of use later on, we just undefine
 221    it if it is 0.  */
 222
 223 #if FFECOM_sizeMAXSTACKITEM == 0
 224 #undef FFECOM_sizeMAXSTACKITEM
 225 #endif
 226
 227 typedef enum
 228   {
 229     FFECOM_rttypeVOID_,
 230     FFECOM_rttypeVOIDSTAR_,     /* C's `void *' type. */
 231     FFECOM_rttypeFTNINT_,       /* f2c's `ftnint' type. */
 232     FFECOM_rttypeINTEGER_,      /* f2c's `integer' type. */
 233     FFECOM_rttypeLONGINT_,      /* f2c's `longint' type. */
 234     FFECOM_rttypeLOGICAL_,      /* f2c's `logical' type. */
 235     FFECOM_rttypeREAL_F2C_,     /* f2c's `real' returned as `double'. */
 236     FFECOM_rttypeREAL_GNU_,     /* `real' returned as such. */
 237     FFECOM_rttypeCOMPLEX_F2C_,  /* f2c's `complex' returned via 1st arg. */
 238     FFECOM_rttypeCOMPLEX_GNU_,  /* f2c's `complex' returned directly. */
 239     FFECOM_rttypeDOUBLE_,       /* C's `double' type. */
 240     FFECOM_rttypeDOUBLEREAL_,   /* f2c's `doublereal' type. */
 241     FFECOM_rttypeDBLCMPLX_F2C_, /* f2c's `doublecomplex' returned via 1st arg. */
 242     FFECOM_rttypeDBLCMPLX_GNU_, /* f2c's `doublecomplex' returned directly. */
 243     FFECOM_rttypeCHARACTER_,    /* f2c `char *'/`ftnlen' pair. */
 244     FFECOM_rttype_
 245   } ffecomRttype_;
 246
 247 /* Internal typedefs. */
 248
 249 typedef struct _ffecom_concat_list_ ffecomConcatList_;
 250
 251 /* Private include files. */
 252
 253
 254 /* Internal structure definitions. */
 255
 256 struct _ffecom_concat_list_
 257   {
 258     ffebld *exprs;
 259     int count;
 260     int max;
 261     ffetargetCharacterSize minlen;
 262     ffetargetCharacterSize maxlen;
 263   };
 264
 265 /* Static functions (internal). */
 266
 267 static tree ffe_type_for_mode PARAMS ((enum machine_mode, int));
 268 static tree ffe_type_for_size PARAMS ((unsigned int, int));
 269 static tree ffe_unsigned_type PARAMS ((tree));
 270 static tree ffe_signed_type PARAMS ((tree));
 271 static tree ffe_signed_or_unsigned_type PARAMS ((int, tree));
 272 static bool ffe_mark_addressable PARAMS ((tree));
 273 static tree ffe_truthvalue_conversion PARAMS ((tree));
 274 static void ffecom_init_decl_processing PARAMS ((void));
 275 static tree ffecom_arglist_expr_ (const char *argstring, ffebld args);
 276 static tree ffecom_widest_expr_type_ (ffebld list);
 277 static bool ffecom_overlap_ (tree dest_decl, tree dest_offset,
 278                              tree dest_size, tree source_tree,
 279                              ffebld source, bool scalar_arg);
 280 static bool ffecom_args_overlapping_ (tree dest_tree, ffebld dest,
 281                                       tree args, tree callee_commons,
 282                                       bool scalar_args);
 283 static tree ffecom_build_f2c_string_ (int i, const char *s);
 284 static tree ffecom_call_ (tree fn, ffeinfoKindtype kt,
 285                           bool is_f2c_complex, tree type,
 286                           tree args, tree dest_tree,
 287                           ffebld dest, bool *dest_used,
 288                           tree callee_commons, bool scalar_args, tree hook);
 289 static tree ffecom_call_binop_ (tree fn, ffeinfoKindtype kt,
 290                                 bool is_f2c_complex, tree type,
 291                                 ffebld left, ffebld right,
 292                                 tree dest_tree, ffebld dest,
 293                                 bool *dest_used, tree callee_commons,
 294                                 bool scalar_args, bool ref, tree hook);
 295 static void ffecom_char_args_x_ (tree *xitem, tree *length,
 296                                  ffebld expr, bool with_null);
 297 static tree ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy);
 298 static tree ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s);
 299 static ffecomConcatList_
 300   ffecom_concat_list_gather_ (ffecomConcatList_ catlist,
 301                               ffebld expr,
 302                               ffetargetCharacterSize max);
 303 static void ffecom_concat_list_kill_ (ffecomConcatList_ catlist);
 304 static ffecomConcatList_ ffecom_concat_list_new_ (ffebld expr,
 305                                                 ffetargetCharacterSize max);
 306 static void ffecom_debug_kludge_ (tree aggr, const char *aggr_type,
 307                                   ffesymbol member, tree member_type,
 308                                   ffetargetOffset offset);
 309 static void ffecom_do_entry_ (ffesymbol fn, int entrynum);
 310 static tree ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
 311                           bool *dest_used, bool assignp, bool widenp);
 312 static tree ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
 313                                     ffebld dest, bool *dest_used);
 314 static tree ffecom_expr_power_integer_ (ffebld expr);
 315 static void ffecom_expr_transform_ (ffebld expr);
 316 static void ffecom_f2c_make_type_ (tree *type, int tcode, const char *name);
 317 static void ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
 318                                       int code);
 319 static ffeglobal ffecom_finish_global_ (ffeglobal global);
 320 static ffesymbol ffecom_finish_symbol_transform_ (ffesymbol s);
 321 static tree ffecom_get_appended_identifier_ (char us, const char *text);
 322 static tree ffecom_get_external_identifier_ (ffesymbol s);
 323 static tree ffecom_get_identifier_ (const char *text);
 324 static tree ffecom_gen_sfuncdef_ (ffesymbol s,
 325                                   ffeinfoBasictype bt,
 326                                   ffeinfoKindtype kt);
 327 static const char *ffecom_gfrt_args_ (ffecomGfrt ix);
 328 static tree ffecom_gfrt_tree_ (ffecomGfrt ix);
 329 static tree ffecom_init_zero_ (tree decl);
 330 static tree ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
 331                                      tree *maybe_tree);
 332 static tree ffecom_intrinsic_len_ (ffebld expr);
 333 static void ffecom_let_char_ (tree dest_tree,
 334                               tree dest_length,
 335                               ffetargetCharacterSize dest_size,
 336                               ffebld source);
 337 static void ffecom_make_gfrt_ (ffecomGfrt ix);
 338 static void ffecom_member_phase1_ (ffestorag mst, ffestorag st);
 339 static void ffecom_member_phase2_ (ffestorag mst, ffestorag st);
 340 static void ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size,
 341                                       ffebld source);
 342 static void ffecom_push_dummy_decls_ (ffebld dumlist,
 343                                       bool stmtfunc);
 344 static void ffecom_start_progunit_ (void);
 345 static ffesymbol ffecom_sym_transform_ (ffesymbol s);
 346 static ffesymbol ffecom_sym_transform_assign_ (ffesymbol s);
 347 static void ffecom_transform_common_ (ffesymbol s);
 348 static void ffecom_transform_equiv_ (ffestorag st);
 349 static tree ffecom_transform_namelist_ (ffesymbol s);
 350 static void ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
 351                                        tree t);
 352 static void ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
 353                                        tree *size, tree tree);
 354 static tree ffecom_tree_divide_ (tree tree_type, tree left, tree right,
 355                                  tree dest_tree, ffebld dest,
 356                                  bool *dest_used, tree hook);
 357 static tree ffecom_type_localvar_ (ffesymbol s,
 358                                    ffeinfoBasictype bt,
 359                                    ffeinfoKindtype kt);
 360 static tree ffecom_type_namelist_ (void);
 361 static tree ffecom_type_vardesc_ (void);
 362 static tree ffecom_vardesc_ (ffebld expr);
 363 static tree ffecom_vardesc_array_ (ffesymbol s);
 364 static tree ffecom_vardesc_dims_ (ffesymbol s);
 365 static tree ffecom_convert_narrow_ (tree type, tree expr);
 366 static tree ffecom_convert_widen_ (tree type, tree expr);
 367
 368 /* These are static functions that parallel those found in the C front
 369    end and thus have the same names.  */
 370
 371 static tree bison_rule_compstmt_ (void);
 372 static void bison_rule_pushlevel_ (void);
 373 static void delete_block (tree block);
 374 static int duplicate_decls (tree newdecl, tree olddecl);
 375 static void finish_decl (tree decl, tree init, bool is_top_level);
 376 static void finish_function (int nested);
 377 static const char *ffe_printable_name (tree decl, int v);
 378 static void ffe_print_error_function (diagnostic_context *, const char *);
 379 static tree lookup_name_current_level (tree name);
 380 static struct f_binding_level *make_binding_level (void);
 381 static void pop_f_function_context (void);
 382 static void push_f_function_context (void);
 383 static void push_parm_decl (tree parm);
 384 static tree pushdecl_top_level (tree decl);
 385 static int kept_level_p (void);
 386 static tree storedecls (tree decls);
 387 static void store_parm_decls (int is_main_program);
 388 static tree start_decl (tree decl, bool is_top_level);
 389 static void start_function (tree name, tree type, int nested, int public);
 390 static void ffecom_file_ (const char *name);
 391 static void ffecom_close_include_ (FILE *f);
 392 static FILE *ffecom_open_include_ (char *name, ffewhereLine l,
 393                                    ffewhereColumn c);
 394
 395 /* Static objects accessed by functions in this module. */
 396
 397 static ffesymbol ffecom_primary_entry_ = NULL;
 398 static ffesymbol ffecom_nested_entry_ = NULL;
 399 static ffeinfoKind ffecom_primary_entry_kind_;
 400 static bool ffecom_primary_entry_is_proc_;
 401 static GTY(()) tree ffecom_outer_function_decl_;
 402 static GTY(()) tree ffecom_previous_function_decl_;
 403 static GTY(()) tree ffecom_which_entrypoint_decl_;
 404 static GTY(()) tree ffecom_float_zero_;
 405 static GTY(()) tree ffecom_float_half_;
 406 static GTY(()) tree ffecom_double_zero_;
 407 static GTY(()) tree ffecom_double_half_;
 408 static GTY(()) tree ffecom_func_result_;/* For functions. */
 409 static GTY(()) tree ffecom_func_length_;/* For CHARACTER fns. */
 410 static ffebld ffecom_list_blockdata_;
 411 static ffebld ffecom_list_common_;
 412 static ffebld ffecom_master_arglist_;
 413 static ffeinfoBasictype ffecom_master_bt_;
 414 static ffeinfoKindtype ffecom_master_kt_;
 415 static ffetargetCharacterSize ffecom_master_size_;
 416 static int ffecom_num_fns_ = 0;
 417 static int ffecom_num_entrypoints_ = 0;
 418 static bool ffecom_is_altreturning_ = FALSE;
 419 static GTY(()) tree ffecom_multi_type_node_;
 420 static GTY(()) tree ffecom_multi_retval_;
 421 static GTY(()) tree
 422   ffecom_multi_fields_[FFEINFO_basictype][FFEINFO_kindtype];
 423 static bool ffecom_member_namelisted_;  /* _member_phase1_ namelisted? */
 424 static bool ffecom_doing_entry_ = FALSE;
 425 static bool ffecom_transform_only_dummies_ = FALSE;
 426 static int ffecom_typesize_pointer_;
 427 static int ffecom_typesize_integer1_;
 428
 429 /* Holds pointer-to-function expressions.  */
 430
 431 static GTY(()) tree ffecom_gfrt_[FFECOM_gfrt];
 432
 433 /* Holds the external names of the functions.  */
 434
 435 static const char *const ffecom_gfrt_name_[FFECOM_gfrt]
 436 =
 437 {
 438 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NAME,
 439 #include "com-rt.def"
 440 #undef DEFGFRT
 441 };
 442
 443 /* Whether the function returns.  */
 444
 445 static const bool ffecom_gfrt_volatile_[FFECOM_gfrt]
 446 =
 447 {
 448 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) VOLATILE,
 449 #include "com-rt.def"
 450 #undef DEFGFRT
 451 };
 452
 453 /* Whether the function returns type complex.  */
 454
 455 static const bool ffecom_gfrt_complex_[FFECOM_gfrt]
 456 =
 457 {
 458 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) COMPLEX,
 459 #include "com-rt.def"
 460 #undef DEFGFRT
 461 };
 462
 463 /* Whether the function is const
 464    (i.e., has no side effects and only depends on its arguments).  */
 465
 466 static const bool ffecom_gfrt_const_[FFECOM_gfrt]
 467 =
 468 {
 469 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) CONST,
 470 #include "com-rt.def"
 471 #undef DEFGFRT
 472 };
 473
 474 /* Type code for the function return value.  */
 475
 476 static const ffecomRttype_ ffecom_gfrt_type_[FFECOM_gfrt]
 477 =
 478 {
 479 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) TYPE,
 480 #include "com-rt.def"
 481 #undef DEFGFRT
 482 };
 483
 484 /* String of codes for the function's arguments.  */
 485
 486 static const char *const ffecom_gfrt_argstring_[FFECOM_gfrt]
 487 =
 488 {
 489 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) ARGS,
 490 #include "com-rt.def"
 491 #undef DEFGFRT
 492 };
 493
 494 /* Internal macros. */
 495
 496 /* We let tm.h override the types used here, to handle trivial differences
 497    such as the choice of unsigned int or long unsigned int for size_t.
 498    When machines start needing nontrivial differences in the size type,
 499    it would be best to do something here to figure out automatically
 500    from other information what type to use.  */
 501
 502 #ifndef SIZE_TYPE
 503 #define SIZE_TYPE "long unsigned int"
 504 #endif
 505
 506 #define ffecom_concat_list_count_(catlist) ((catlist).count)
 507 #define ffecom_concat_list_expr_(catlist,i) ((catlist).exprs[(i)])
 508 #define ffecom_concat_list_maxlen_(catlist) ((catlist).maxlen)
 509 #define ffecom_concat_list_minlen_(catlist) ((catlist).minlen)
 510
 511 #define ffecom_char_args_(i,l,e) ffecom_char_args_x_((i),(l),(e),FALSE)
 512 #define ffecom_char_args_with_null_(i,l,e) ffecom_char_args_x_((i),(l),(e),TRUE)
 513
 514 /* For each binding contour we allocate a binding_level structure
 515  * which records the names defined in that contour.
 516  * Contours include:
 517  *  0) the global one
 518  *  1) one for each function definition,
 519  *     where internal declarations of the parameters appear.
 520  *
 521  * The current meaning of a name can be found by searching the levels from
 522  * the current one out to the global one.
 523  */
 524
 525 /* Note that the information in the `names' component of the global contour
 526    is duplicated in the IDENTIFIER_GLOBAL_VALUEs of all identifiers.  */
 527
 528 struct f_binding_level GTY(())
 529   {
 530     /* A chain of _DECL nodes for all variables, constants, functions,
 531        and typedef types.  These are in the reverse of the order supplied.
 532      */
 533     tree names;
 534
 535     /* For each level (except not the global one),
 536        a chain of BLOCK nodes for all the levels
 537        that were entered and exited one level down.  */
 538     tree blocks;
 539
 540     /* The BLOCK node for this level, if one has been preallocated.
 541        If 0, the BLOCK is allocated (if needed) when the level is popped.  */
 542     tree this_block;
 543
 544     /* The binding level which this one is contained in (inherits from).  */
 545     struct f_binding_level *level_chain;
 546
 547     /* 0: no ffecom_prepare_* functions called at this level yet;
 548        1: ffecom_prepare* functions called, except not ffecom_prepare_end;
 549        2: ffecom_prepare_end called.  */
 550     int prep_state;
 551   };
 552
 553 #define NULL_BINDING_LEVEL (struct f_binding_level *) NULL
 554
 555 /* The binding level currently in effect.  */
 556
 557 static GTY(()) struct f_binding_level *current_binding_level;
 558
 559 /* A chain of binding_level structures awaiting reuse.  */
 560
 561 static GTY((deletable (""))) struct f_binding_level *free_binding_level;
 562
 563 /* The outermost binding level, for names of file scope.
 564    This is created when the compiler is started and exists
 565    through the entire run.  */
 566
 567 static struct f_binding_level *global_binding_level;
 568
 569 /* Binding level structures are initialized by copying this one.  */
 570
 571 static const struct f_binding_level clear_binding_level
 572 =
 573 {NULL, NULL, NULL, NULL_BINDING_LEVEL, 0};
 574
 575 /* Language-dependent contents of an identifier.  */
 576
 577 struct lang_identifier GTY(())
 578 {
 579   struct tree_identifier common;
 580   tree global_value;
 581   tree local_value;
 582   tree label_value;
 583   bool invented;
 584 };
 585
 586 /* Macros for access to language-specific slots in an identifier.  */
 587 /* Each of these slots contains a DECL node or null.  */
 588
 589 /* This represents the value which the identifier has in the
 590    file-scope namespace.  */
 591 #define IDENTIFIER_GLOBAL_VALUE(NODE)   \
 592   (((struct lang_identifier *)(NODE))->global_value)
 593 /* This represents the value which the identifier has in the current
 594    scope.  */
 595 #define IDENTIFIER_LOCAL_VALUE(NODE)    \
 596   (((struct lang_identifier *)(NODE))->local_value)
 597 /* This represents the value which the identifier has as a label in
 598    the current label scope.  */
 599 #define IDENTIFIER_LABEL_VALUE(NODE)    \
 600   (((struct lang_identifier *)(NODE))->label_value)
 601 /* This is nonzero if the identifier was "made up" by g77 code.  */
 602 #define IDENTIFIER_INVENTED(NODE)       \
 603   (((struct lang_identifier *)(NODE))->invented)
 604
 605 /* The resulting tree type.  */
 606 union lang_tree_node
 607   GTY((desc ("TREE_CODE (&%h.generic) == IDENTIFIER_NODE"),
 608        chain_next ("(union lang_tree_node *)TREE_CHAIN (&%h.generic)")))
 609 {
 610   union tree_node GTY ((tag ("0"),
 611                         desc ("tree_node_structure (&%h)")))
 612     generic;
 613   struct lang_identifier GTY ((tag ("1"))) identifier;
 614 };
 615
 616 /* Fortran doesn't use either of these.  */
 617 struct lang_decl GTY(())
 618 {
 619 };
 620 struct lang_type GTY(())
 621 {
 622 };
 623
 624 /* In identifiers, C uses the following fields in a special way:
 625    TREE_PUBLIC        to record that there was a previous local extern decl.
 626    TREE_USED          to record that such a decl was used.
 627    TREE_ADDRESSABLE   to record that the address of such a decl was used.  */
 628
 629 /* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function
 630    that have names.  Here so we can clear out their names' definitions
 631    at the end of the function.  */
 632
 633 static GTY(()) tree named_labels;
 634
 635 /* A list of LABEL_DECLs from outer contexts that are currently shadowed.  */
 636
 637 static GTY(()) tree shadowed_labels;
 638 \f
 639 /* Return the subscript expression, modified to do range-checking.
 640
 641    `array' is the array to be checked against.
 642    `element' is the subscript expression to check.
 643    `dim' is the dimension number (starting at 0).
 644    `total_dims' is the total number of dimensions (0 for CHARACTER substring).
 645 */
 646
 647 static tree
 648 ffecom_subscript_check_ (tree array, tree element, int dim, int total_dims,
 649                          const char *array_name)
 650 {
 651   tree low = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
 652   tree high = TYPE_MAX_VALUE (TYPE_DOMAIN (array));
 653   tree cond;
 654   tree die;
 655   tree args;
 656
 657   if (element == error_mark_node)
 658     return element;
 659
 660   if (TREE_TYPE (low) != TREE_TYPE (element))
 661     {
 662       if (TYPE_PRECISION (TREE_TYPE (low))
 663           > TYPE_PRECISION (TREE_TYPE (element)))
 664         element = convert (TREE_TYPE (low), element);
 665       else
 666         {
 667           low = convert (TREE_TYPE (element), low);
 668           if (high)
 669             high = convert (TREE_TYPE (element), high);
 670         }
 671     }
 672
 673   element = ffecom_save_tree (element);
 674   if (total_dims == 0)
 675     {
 676       /* Special handling for substring range checks.  Fortran allows the
 677          end subscript < begin subscript, which means that expressions like
 678        string(1:0) are valid (and yield a null string).  In view of this,
 679        enforce two simpler conditions:
 680           1) element<=high for end-substring;
 681           2) element>=low for start-substring.
 682        Run-time character movement will enforce remaining conditions.
 683
 684        More complicated checks would be better, but present structure only
 685        provides one index element at a time, so it is not possible to
 686        enforce a check of both i and j in string(i:j).  If it were, the
 687        complete set of rules would read,
 688          if ( ((j<i) && ((low<=i<=high) || (low<=j<=high))) ||
 689               ((low<=i<=high) && (low<=j<=high)) )
 690            ok ;
 691          else
 692            range error ;
 693       */
 694       if (dim)
 695         cond = ffecom_2 (LE_EXPR, integer_type_node, element, high);
 696       else
 697         cond = ffecom_2 (LE_EXPR, integer_type_node, low, element);
 698     }
 699   else
 700     {
 701       /* Array reference substring range checking.  */
 702
 703       cond = ffecom_2 (LE_EXPR, integer_type_node,
 704                      low,
 705                      element);
 706       if (high)
 707         {
 708           cond = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
 709                          cond,
 710                          ffecom_2 (LE_EXPR, integer_type_node,
 711                                    element,
 712                                    high));
 713         }
 714     }
 715
 716   {
 717     int len;
 718     char *proc;
 719     char *var;
 720     tree arg3;
 721     tree arg2;
 722     tree arg1;
 723     tree arg4;
 724
 725     switch (total_dims)
 726       {
 727       case 0:
 728         var = concat (array_name, "[", (dim ? "end" : "start"),
 729                       "-substring]", NULL);
 730         len = strlen (var) + 1;
 731         arg1 = build_string (len, var);
 732         free (var);
 733         break;
 734
 735       case 1:
 736         len = strlen (array_name) + 1;
 737         arg1 = build_string (len, array_name);
 738         break;
 739
 740       default:
 741         var = xmalloc (strlen (array_name) + 40);
 742         sprintf (var, "%s[subscript-%d-of-%d]",
 743                  array_name,
 744                  dim + 1, total_dims);
 745         len = strlen (var) + 1;
 746         arg1 = build_string (len, var);
 747         free (var);
 748         break;
 749       }
 750
 751     TREE_TYPE (arg1)
 752       = build_type_variant (build_array_type (char_type_node,
 753                                               build_range_type
 754                                               (integer_type_node,
 755                                                integer_one_node,
 756                                                build_int_2 (len, 0))),
 757                             1, 0);
 758     TREE_CONSTANT (arg1) = 1;
 759     TREE_STATIC (arg1) = 1;
 760     arg1 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg1)),
 761                      arg1);
 762
 763     /* s_rnge adds one to the element to print it, so bias against
 764        that -- want to print a faithful *subscript* value.  */
 765     arg2 = convert (ffecom_f2c_ftnint_type_node,
 766                     ffecom_2 (MINUS_EXPR,
 767                               TREE_TYPE (element),
 768                               element,
 769                               convert (TREE_TYPE (element),
 770                                        integer_one_node)));
 771
 772     proc = concat (input_filename, "/",
 773                    IDENTIFIER_POINTER (DECL_NAME (current_function_decl)),
 774                    NULL);
 775     len = strlen (proc) + 1;
 776     arg3 = build_string (len, proc);
 777
 778     free (proc);
 779
 780     TREE_TYPE (arg3)
 781       = build_type_variant (build_array_type (char_type_node,
 782                                               build_range_type
 783                                               (integer_type_node,
 784                                                integer_one_node,
 785                                                build_int_2 (len, 0))),
 786                             1, 0);
 787     TREE_CONSTANT (arg3) = 1;
 788     TREE_STATIC (arg3) = 1;
 789     arg3 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg3)),
 790                      arg3);
 791
 792     arg4 = convert (ffecom_f2c_ftnint_type_node,
 793                     build_int_2 (input_line, 0));
 794
 795     arg1 = build_tree_list (NULL_TREE, arg1);
 796     arg2 = build_tree_list (NULL_TREE, arg2);
 797     arg3 = build_tree_list (NULL_TREE, arg3);
 798     arg4 = build_tree_list (NULL_TREE, arg4);
 799     TREE_CHAIN (arg3) = arg4;
 800     TREE_CHAIN (arg2) = arg3;
 801     TREE_CHAIN (arg1) = arg2;
 802
 803     args = arg1;
 804   }
 805   die = ffecom_call_gfrt (FFECOM_gfrtRANGE,
 806                           args, NULL_TREE);
 807   TREE_SIDE_EFFECTS (die) = 1;
 808   die = convert (void_type_node, die);
 809
 810   element = ffecom_3 (COND_EXPR,
 811                       TREE_TYPE (element),
 812                       cond,
 813                       element,
 814                       die);
 815
 816   return element;
 817 }
 818
 819 /* Return the computed element of an array reference.
 820
 821    `item' is NULL_TREE, or the transformed pointer to the array.
 822    `expr' is the original opARRAYREF expression, which is transformed
 823      if `item' is NULL_TREE.
 824    `want_ptr' is nonzero if a pointer to the element, instead of
 825      the element itself, is to be returned.  */
 826
 827 static tree
 828 ffecom_arrayref_ (tree item, ffebld expr, int want_ptr)
 829 {
 830   ffebld dims[FFECOM_dimensionsMAX];
 831   int i;
 832   int total_dims;
 833   int flatten = ffe_is_flatten_arrays ();
 834   int need_ptr;
 835   tree array;
 836   tree element;
 837   tree tree_type;
 838   tree tree_type_x;
 839   const char *array_name;
 840   ffetype type;
 841   ffebld list;
 842
 843   if (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER)
 844     array_name = ffesymbol_text (ffebld_symter (ffebld_left (expr)));
 845   else
 846     array_name = "[expr?]";
 847
 848   /* Build up ARRAY_REFs in reverse order (since we're column major
 849      here in Fortran land). */
 850
 851   for (i = 0, list = ffebld_right (expr);
 852        list != NULL;
 853        ++i, list = ffebld_trail (list))
 854     {
 855       dims[i] = ffebld_head (list);
 856       type = ffeinfo_type (ffebld_basictype (dims[i]),
 857                            ffebld_kindtype (dims[i]));
 858       if (! flatten
 859           && ffecom_typesize_pointer_ > ffecom_typesize_integer1_
 860           && ffetype_size (type) > ffecom_typesize_integer1_)
 861         /* E.g. ARRAY(INDEX), given INTEGER*8 INDEX, on a system with 64-bit
 862            pointers and 32-bit integers.  Do the full 64-bit pointer
 863            arithmetic, for codes using arrays for nonstandard heap-like
 864            work.  */
 865         flatten = 1;
 866     }
 867
 868   total_dims = i;
 869
 870   need_ptr = want_ptr || flatten;
 871
 872   if (! item)
 873     {
 874       if (need_ptr)
 875         item = ffecom_ptr_to_expr (ffebld_left (expr));
 876       else
 877         item = ffecom_expr (ffebld_left (expr));
 878
 879       if (item == error_mark_node)
 880         return item;
 881
 882       if (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereFLEETING
 883           && ! ffe_mark_addressable (item))
 884         return error_mark_node;
 885     }
 886
 887   if (item == error_mark_node)
 888     return item;
 889
 890   if (need_ptr)
 891     {
 892       tree min;
 893
 894       for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
 895            i >= 0;
 896            --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array)))
 897         {
 898           min = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
 899           element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
 900           if (flag_bounds_check)
 901             element = ffecom_subscript_check_ (array, element, i, total_dims,
 902                                                array_name);
 903           if (element == error_mark_node)
 904             return element;
 905
 906           /* Widen integral arithmetic as desired while preserving
 907              signedness.  */
 908           tree_type = TREE_TYPE (element);
 909           tree_type_x = tree_type;
 910           if (tree_type
 911               && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
 912               && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
 913             tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
 914
 915           if (TREE_TYPE (min) != tree_type_x)
 916             min = convert (tree_type_x, min);
 917           if (TREE_TYPE (element) != tree_type_x)
 918             element = convert (tree_type_x, element);
 919
 920           item = ffecom_2 (PLUS_EXPR,
 921                            build_pointer_type (TREE_TYPE (array)),
 922                            item,
 923                            size_binop (MULT_EXPR,
 924                                        size_in_bytes (TREE_TYPE (array)),
 925                                        convert (sizetype,
 926                                                 fold (build (MINUS_EXPR,
 927                                                              tree_type_x,
 928                                                              element, min)))));
 929         }
 930       if (! want_ptr)
 931         {
 932           item = ffecom_1 (INDIRECT_REF,
 933                            TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
 934                            item);
 935         }
 936     }
 937   else
 938     {
 939       for (--i;
 940            i >= 0;
 941            --i)
 942         {
 943           array = TYPE_MAIN_VARIANT (TREE_TYPE (item));
 944
 945           element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
 946           if (flag_bounds_check)
 947             element = ffecom_subscript_check_ (array, element, i, total_dims,
 948                                                array_name);
 949           if (element == error_mark_node)
 950             return element;
 951
 952           /* Widen integral arithmetic as desired while preserving
 953              signedness.  */
 954           tree_type = TREE_TYPE (element);
 955           tree_type_x = tree_type;
 956           if (tree_type
 957               && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
 958               && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
 959             tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
 960
 961           element = convert (tree_type_x, element);
 962
 963           item = ffecom_2 (ARRAY_REF,
 964                            TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
 965                            item,
 966                            element);
 967         }
 968     }
 969
 970   return item;
 971 }
 972
 973 /* This is like gcc's stabilize_reference -- in fact, most of the code
 974    comes from that -- but it handles the situation where the reference
 975    is going to have its subparts picked at, and it shouldn't change
 976    (or trigger extra invocations of functions in the subtrees) due to
 977    this.  save_expr is a bit overzealous, because we don't need the
 978    entire thing calculated and saved like a temp.  So, for DECLs, no
 979    change is needed, because these are stable aggregates, and ARRAY_REF
 980    and such might well be stable too, but for things like calculations,
 981    we do need to calculate a snapshot of a value before picking at it.  */
 982
 983 static tree
 984 ffecom_stabilize_aggregate_ (tree ref)
 985 {
 986   tree result;
 987   enum tree_code code = TREE_CODE (ref);
 988
 989   switch (code)
 990     {
 991     case VAR_DECL:
 992     case PARM_DECL:
 993     case RESULT_DECL:
 994       /* No action is needed in this case.  */
 995       return ref;
 996
 997     case NOP_EXPR:
 998     case CONVERT_EXPR:
 999     case FLOAT_EXPR:
1000     case FIX_TRUNC_EXPR:
1001     case FIX_FLOOR_EXPR:
1002     case FIX_ROUND_EXPR:
1003     case FIX_CEIL_EXPR:
1004       result = build_nt (code, stabilize_reference (TREE_OPERAND (ref, 0)));
1005       break;
1006
1007     case INDIRECT_REF:
1008       result = build_nt (INDIRECT_REF,
1009                          stabilize_reference_1 (TREE_OPERAND (ref, 0)));
1010       break;
1011
1012     case COMPONENT_REF:
1013       result = build_nt (COMPONENT_REF,
1014                          stabilize_reference (TREE_OPERAND (ref, 0)),
1015                          TREE_OPERAND (ref, 1));
1016       break;
1017
1018     case BIT_FIELD_REF:
1019       result = build_nt (BIT_FIELD_REF,
1020                          stabilize_reference (TREE_OPERAND (ref, 0)),
1021                          stabilize_reference_1 (TREE_OPERAND (ref, 1)),
1022                          stabilize_reference_1 (TREE_OPERAND (ref, 2)));
1023       break;
1024
1025     case ARRAY_REF:
1026       result = build_nt (ARRAY_REF,
1027                          stabilize_reference (TREE_OPERAND (ref, 0)),
1028                          stabilize_reference_1 (TREE_OPERAND (ref, 1)));
1029       break;
1030
1031     case COMPOUND_EXPR:
1032       result = build_nt (COMPOUND_EXPR,
1033                          stabilize_reference_1 (TREE_OPERAND (ref, 0)),
1034                          stabilize_reference (TREE_OPERAND (ref, 1)));
1035       break;
1036
1037     case RTL_EXPR:
1038       abort ();
1039
1040
1041     default:
1042       return save_expr (ref);
1043
1044     case ERROR_MARK:
1045       return error_mark_node;
1046     }
1047
1048   TREE_TYPE (result) = TREE_TYPE (ref);
1049   TREE_READONLY (result) = TREE_READONLY (ref);
1050   TREE_SIDE_EFFECTS (result) = TREE_SIDE_EFFECTS (ref);
1051   TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref);
1052
1053   return result;
1054 }
1055
1056 /* A rip-off of gcc's convert.c convert_to_complex function,
1057    reworked to handle complex implemented as C structures
1058    (RECORD_TYPE with two fields, real and imaginary `r' and `i').  */
1059
1060 static tree
1061 ffecom_convert_to_complex_ (tree type, tree expr)
1062 {
1063   register enum tree_code form = TREE_CODE (TREE_TYPE (expr));
1064   tree subtype;
1065
1066   assert (TREE_CODE (type) == RECORD_TYPE);
1067
1068   subtype = TREE_TYPE (TYPE_FIELDS (type));
1069
1070   if (form == REAL_TYPE || form == INTEGER_TYPE || form == ENUMERAL_TYPE)
1071     {
1072       expr = convert (subtype, expr);
1073       return ffecom_2 (COMPLEX_EXPR, type, expr,
1074                        convert (subtype, integer_zero_node));
1075     }
1076
1077   if (form == RECORD_TYPE)
1078     {
1079       tree elt_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr)));
1080       if (TYPE_MAIN_VARIANT (elt_type) == TYPE_MAIN_VARIANT (subtype))
1081         return expr;
1082       else
1083         {
1084           expr = save_expr (expr);
1085           return ffecom_2 (COMPLEX_EXPR,
1086                            type,
1087                            convert (subtype,
1088                                     ffecom_1 (REALPART_EXPR,
1089                                               TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1090                                               expr)),
1091                            convert (subtype,
1092                                     ffecom_1 (IMAGPART_EXPR,
1093                                               TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1094                                               expr)));
1095         }
1096     }
1097
1098   if (form == POINTER_TYPE || form == REFERENCE_TYPE)
1099     error ("pointer value used where a complex was expected");
1100   else
1101     error ("aggregate value used where a complex was expected");
1102
1103   return ffecom_2 (COMPLEX_EXPR, type,
1104                    convert (subtype, integer_zero_node),
1105                    convert (subtype, integer_zero_node));
1106 }
1107
1108 /* Like gcc's convert(), but crashes if widening might happen.  */
1109
1110 static tree
1111 ffecom_convert_narrow_ (tree type, tree expr)
1112 {
1113   register tree e = expr;
1114   register enum tree_code code = TREE_CODE (type);
1115
1116   if (type == TREE_TYPE (e)
1117       || TREE_CODE (e) == ERROR_MARK)
1118     return e;
1119   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1120     return fold (build1 (NOP_EXPR, type, e));
1121   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1122       || code == ERROR_MARK)
1123     return error_mark_node;
1124   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1125     {
1126       assert ("void value not ignored as it ought to be" == NULL);
1127       return error_mark_node;
1128     }
1129   assert (code != VOID_TYPE);
1130   if ((code != RECORD_TYPE)
1131       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1132     assert ("converting COMPLEX to REAL" == NULL);
1133   assert (code != ENUMERAL_TYPE);
1134   if (code == INTEGER_TYPE)
1135     {
1136       assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1137                && TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)))
1138               || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1139                   && (TYPE_PRECISION (type)
1140                       == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1141       return fold (convert_to_integer (type, e));
1142     }
1143   if (code == POINTER_TYPE)
1144     {
1145       assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1146       return fold (convert_to_pointer (type, e));
1147     }
1148   if (code == REAL_TYPE)
1149     {
1150       assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1151       assert (TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)));
1152       return fold (convert_to_real (type, e));
1153     }
1154   if (code == COMPLEX_TYPE)
1155     {
1156       assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1157       assert (TYPE_PRECISION (TREE_TYPE (type)) <= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1158       return fold (convert_to_complex (type, e));
1159     }
1160   if (code == RECORD_TYPE)
1161     {
1162       assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1163       /* Check that at least the first field name agrees.  */
1164       assert (DECL_NAME (TYPE_FIELDS (type))
1165               == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1166       assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1167               <= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1168       if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1169           == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1170         return e;
1171       return fold (ffecom_convert_to_complex_ (type, e));
1172     }
1173
1174   assert ("conversion to non-scalar type requested" == NULL);
1175   return error_mark_node;
1176 }
1177
1178 /* Like gcc's convert(), but crashes if narrowing might happen.  */
1179
1180 static tree
1181 ffecom_convert_widen_ (tree type, tree expr)
1182 {
1183   register tree e = expr;
1184   register enum tree_code code = TREE_CODE (type);
1185
1186   if (type == TREE_TYPE (e)
1187       || TREE_CODE (e) == ERROR_MARK)
1188     return e;
1189   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1190     return fold (build1 (NOP_EXPR, type, e));
1191   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1192       || code == ERROR_MARK)
1193     return error_mark_node;
1194   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1195     {
1196       assert ("void value not ignored as it ought to be" == NULL);
1197       return error_mark_node;
1198     }
1199   assert (code != VOID_TYPE);
1200   if ((code != RECORD_TYPE)
1201       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1202     assert ("narrowing COMPLEX to REAL" == NULL);
1203   assert (code != ENUMERAL_TYPE);
1204   if (code == INTEGER_TYPE)
1205     {
1206       assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1207                && TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)))
1208               || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1209                   && (TYPE_PRECISION (type)
1210                       == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1211       return fold (convert_to_integer (type, e));
1212     }
1213   if (code == POINTER_TYPE)
1214     {
1215       assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1216       return fold (convert_to_pointer (type, e));
1217     }
1218   if (code == REAL_TYPE)
1219     {
1220       assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1221       assert (TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)));
1222       return fold (convert_to_real (type, e));
1223     }
1224   if (code == COMPLEX_TYPE)
1225     {
1226       assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1227       assert (TYPE_PRECISION (TREE_TYPE (type)) >= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1228       return fold (convert_to_complex (type, e));
1229     }
1230   if (code == RECORD_TYPE)
1231     {
1232       assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1233       /* Check that at least the first field name agrees.  */
1234       assert (DECL_NAME (TYPE_FIELDS (type))
1235               == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1236       assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1237               >= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1238       if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1239           == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1240         return e;
1241       return fold (ffecom_convert_to_complex_ (type, e));
1242     }
1243
1244   assert ("conversion to non-scalar type requested" == NULL);
1245   return error_mark_node;
1246 }
1247
1248 /* Handles making a COMPLEX type, either the standard
1249    (but buggy?) gbe way, or the safer (but less elegant?)
1250    f2c way.  */
1251
1252 static tree
1253 ffecom_make_complex_type_ (tree subtype)
1254 {
1255   tree type;
1256   tree realfield;
1257   tree imagfield;
1258
1259   if (ffe_is_emulate_complex ())
1260     {
1261       type = make_node (RECORD_TYPE);
1262       realfield = ffecom_decl_field (type, NULL_TREE, "r", subtype);
1263       imagfield = ffecom_decl_field (type, realfield, "i", subtype);
1264       TYPE_FIELDS (type) = realfield;
1265       layout_type (type);
1266     }
1267   else
1268     {
1269       type = make_node (COMPLEX_TYPE);
1270       TREE_TYPE (type) = subtype;
1271       layout_type (type);
1272     }
1273
1274   return type;
1275 }
1276
1277 /* Chooses either the gbe or the f2c way to build a
1278    complex constant.  */
1279
1280 static tree
1281 ffecom_build_complex_constant_ (tree type, tree realpart, tree imagpart)
1282 {
1283   tree bothparts;
1284
1285   if (ffe_is_emulate_complex ())
1286     {
1287       bothparts = build_tree_list (TYPE_FIELDS (type), realpart);
1288       TREE_CHAIN (bothparts) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), imagpart);
1289       bothparts = build_constructor (type, bothparts);
1290     }
1291   else
1292     {
1293       bothparts = build_complex (type, realpart, imagpart);
1294     }
1295
1296   return bothparts;
1297 }
1298
1299 static tree
1300 ffecom_arglist_expr_ (const char *c, ffebld expr)
1301 {
1302   tree list;
1303   tree *plist = &list;
1304   tree trail = NULL_TREE;       /* Append char length args here. */
1305   tree *ptrail = &trail;
1306   tree length;
1307   ffebld exprh;
1308   tree item;
1309   bool ptr = FALSE;
1310   tree wanted = NULL_TREE;
1311   static const char zed[] = "0";
1312
1313   if (c == NULL)
1314     c = &zed[0];
1315
1316   while (expr != NULL)
1317     {
1318       if (*c != '\0')
1319         {
1320           ptr = FALSE;
1321           if (*c == '&')
1322             {
1323               ptr = TRUE;
1324               ++c;
1325             }
1326           switch (*(c++))
1327             {
1328             case '\0':
1329               ptr = TRUE;
1330               wanted = NULL_TREE;
1331               break;
1332
1333             case 'a':
1334               assert (ptr);
1335               wanted = NULL_TREE;
1336               break;
1337
1338             case 'c':
1339               wanted = ffecom_f2c_complex_type_node;
1340               break;
1341
1342             case 'd':
1343               wanted = ffecom_f2c_doublereal_type_node;
1344               break;
1345
1346             case 'e':
1347               wanted = ffecom_f2c_doublecomplex_type_node;
1348               break;
1349
1350             case 'f':
1351               wanted = ffecom_f2c_real_type_node;
1352               break;
1353
1354             case 'i':
1355               wanted = ffecom_f2c_integer_type_node;
1356               break;
1357
1358             case 'j':
1359               wanted = ffecom_f2c_longint_type_node;
1360               break;
1361
1362             default:
1363               assert ("bad argstring code" == NULL);
1364               wanted = NULL_TREE;
1365               break;
1366             }
1367         }
1368
1369       exprh = ffebld_head (expr);
1370       if (exprh == NULL)
1371         wanted = NULL_TREE;
1372
1373       if ((wanted == NULL_TREE)
1374           || (ptr
1375               && (TYPE_MODE
1376                   (ffecom_tree_type[ffeinfo_basictype (ffebld_info (exprh))]
1377                    [ffeinfo_kindtype (ffebld_info (exprh))])
1378                    == TYPE_MODE (wanted))))
1379         *plist
1380           = build_tree_list (NULL_TREE,
1381                              ffecom_arg_ptr_to_expr (exprh,
1382                                                      &length));
1383       else
1384         {
1385           item = ffecom_arg_expr (exprh, &length);
1386           item = ffecom_convert_widen_ (wanted, item);
1387           if (ptr)
1388             {
1389               item = ffecom_1 (ADDR_EXPR,
1390                                build_pointer_type (TREE_TYPE (item)),
1391                                item);
1392             }
1393           *plist
1394             = build_tree_list (NULL_TREE,
1395                                item);
1396         }
1397
1398       plist = &TREE_CHAIN (*plist);
1399       expr = ffebld_trail (expr);
1400       if (length != NULL_TREE)
1401         {
1402           *ptrail = build_tree_list (NULL_TREE, length);
1403           ptrail = &TREE_CHAIN (*ptrail);
1404         }
1405     }
1406
1407   /* We've run out of args in the call; if the implementation expects
1408      more, supply null pointers for them, which the implementation can
1409      check to see if an arg was omitted. */
1410
1411   while (*c != '\0' && *c != '0')
1412     {
1413       if (*c == '&')
1414         ++c;
1415       else
1416         assert ("missing arg to run-time routine!" == NULL);
1417
1418       switch (*(c++))
1419         {
1420         case '\0':
1421         case 'a':
1422         case 'c':
1423         case 'd':
1424         case 'e':
1425         case 'f':
1426         case 'i':
1427         case 'j':
1428           break;
1429
1430         default:
1431           assert ("bad arg string code" == NULL);
1432           break;
1433         }
1434       *plist
1435         = build_tree_list (NULL_TREE,
1436                            null_pointer_node);
1437       plist = &TREE_CHAIN (*plist);
1438     }
1439
1440   *plist = trail;
1441
1442   return list;
1443 }
1444
1445 static tree
1446 ffecom_widest_expr_type_ (ffebld list)
1447 {
1448   ffebld item;
1449   ffebld widest = NULL;
1450   ffetype type;
1451   ffetype widest_type = NULL;
1452   tree t;
1453
1454   for (; list != NULL; list = ffebld_trail (list))
1455     {
1456       item = ffebld_head (list);
1457       if (item == NULL)
1458         continue;
1459       if ((widest != NULL)
1460           && (ffeinfo_basictype (ffebld_info (item))
1461               != ffeinfo_basictype (ffebld_info (widest))))
1462         continue;
1463       type = ffeinfo_type (ffeinfo_basictype (ffebld_info (item)),
1464                            ffeinfo_kindtype (ffebld_info (item)));
1465       if ((widest == FFEINFO_kindtypeNONE)
1466           || (ffetype_size (type)
1467               > ffetype_size (widest_type)))
1468         {
1469           widest = item;
1470           widest_type = type;
1471         }
1472     }
1473
1474   assert (widest != NULL);
1475   t = ffecom_tree_type[ffeinfo_basictype (ffebld_info (widest))]
1476     [ffeinfo_kindtype (ffebld_info (widest))];
1477   assert (t != NULL_TREE);
1478   return t;
1479 }
1480
1481 /* Check whether a partial overlap between two expressions is possible.
1482
1483    Can *starting* to write a portion of expr1 change the value
1484    computed (perhaps already, *partially*) by expr2?
1485
1486    Currently, this is a concern only for a COMPLEX expr1.  But if it
1487    isn't in COMMON or local EQUIVALENCE, since we don't support
1488    aliasing of arguments, it isn't a concern.  */
1489
1490 static bool
1491 ffecom_possible_partial_overlap_ (ffebld expr1, ffebld expr2 ATTRIBUTE_UNUSED)
1492 {
1493   ffesymbol sym;
1494   ffestorag st;
1495
1496   switch (ffebld_op (expr1))
1497     {
1498     case FFEBLD_opSYMTER:
1499       sym = ffebld_symter (expr1);
1500       break;
1501
1502     case FFEBLD_opARRAYREF:
1503       if (ffebld_op (ffebld_left (expr1)) != FFEBLD_opSYMTER)
1504         return FALSE;
1505       sym = ffebld_symter (ffebld_left (expr1));
1506       break;
1507
1508     default:
1509       return FALSE;
1510     }
1511
1512   if (ffesymbol_where (sym) != FFEINFO_whereCOMMON
1513       && (ffesymbol_where (sym) != FFEINFO_whereLOCAL
1514           || ! (st = ffesymbol_storage (sym))
1515           || ! ffestorag_parent (st)))
1516     return FALSE;
1517
1518   /* It's in COMMON or local EQUIVALENCE.  */
1519
1520   return TRUE;
1521 }
1522
1523 /* Check whether dest and source might overlap.  ffebld versions of these
1524    might or might not be passed, will be NULL if not.
1525
1526    The test is really whether source_tree is modifiable and, if modified,
1527    might overlap destination such that the value(s) in the destination might
1528    change before it is finally modified.  dest_* are the canonized
1529    destination itself.  */
1530
1531 static bool
1532 ffecom_overlap_ (tree dest_decl, tree dest_offset, tree dest_size,
1533                  tree source_tree, ffebld source UNUSED,
1534                  bool scalar_arg)
1535 {
1536   tree source_decl;
1537   tree source_offset;
1538   tree source_size;
1539   tree t;
1540
1541   if (source_tree == NULL_TREE)
1542     return FALSE;
1543
1544   switch (TREE_CODE (source_tree))
1545     {
1546     case ERROR_MARK:
1547     case IDENTIFIER_NODE:
1548     case INTEGER_CST:
1549     case REAL_CST:
1550     case COMPLEX_CST:
1551     case STRING_CST:
1552     case CONST_DECL:
1553     case VAR_DECL:
1554     case RESULT_DECL:
1555     case FIELD_DECL:
1556     case MINUS_EXPR:
1557     case MULT_EXPR:
1558     case TRUNC_DIV_EXPR:
1559     case CEIL_DIV_EXPR:
1560     case FLOOR_DIV_EXPR:
1561     case ROUND_DIV_EXPR:
1562     case TRUNC_MOD_EXPR:
1563     case CEIL_MOD_EXPR:
1564     case FLOOR_MOD_EXPR:
1565     case ROUND_MOD_EXPR:
1566     case RDIV_EXPR:
1567     case EXACT_DIV_EXPR:
1568     case FIX_TRUNC_EXPR:
1569     case FIX_CEIL_EXPR:
1570     case FIX_FLOOR_EXPR:
1571     case FIX_ROUND_EXPR:
1572     case FLOAT_EXPR:
1573     case NEGATE_EXPR:
1574     case MIN_EXPR:
1575     case MAX_EXPR:
1576     case ABS_EXPR:
1577     case FFS_EXPR:
1578     case LSHIFT_EXPR:
1579     case RSHIFT_EXPR:
1580     case LROTATE_EXPR:
1581     case RROTATE_EXPR:
1582     case BIT_IOR_EXPR:
1583     case BIT_XOR_EXPR:
1584     case BIT_AND_EXPR:
1585     case BIT_ANDTC_EXPR:
1586     case BIT_NOT_EXPR:
1587     case TRUTH_ANDIF_EXPR:
1588     case TRUTH_ORIF_EXPR:
1589     case TRUTH_AND_EXPR:
1590     case TRUTH_OR_EXPR:
1591     case TRUTH_XOR_EXPR:
1592     case TRUTH_NOT_EXPR:
1593     case LT_EXPR:
1594     case LE_EXPR:
1595     case GT_EXPR:
1596     case GE_EXPR:
1597     case EQ_EXPR:
1598     case NE_EXPR:
1599     case COMPLEX_EXPR:
1600     case CONJ_EXPR:
1601     case REALPART_EXPR:
1602     case IMAGPART_EXPR:
1603     case LABEL_EXPR:
1604     case COMPONENT_REF:
1605       return FALSE;
1606
1607     case COMPOUND_EXPR:
1608       return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1609                               TREE_OPERAND (source_tree, 1), NULL,
1610                               scalar_arg);
1611
1612     case MODIFY_EXPR:
1613       return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1614                               TREE_OPERAND (source_tree, 0), NULL,
1615                               scalar_arg);
1616
1617     case CONVERT_EXPR:
1618     case NOP_EXPR:
1619     case NON_LVALUE_EXPR:
1620     case PLUS_EXPR:
1621       if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1622         return TRUE;
1623
1624       ffecom_tree_canonize_ptr_ (&source_decl, &source_offset,
1625                                  source_tree);
1626       source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1627       break;
1628
1629     case COND_EXPR:
1630       return
1631         ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1632                          TREE_OPERAND (source_tree, 1), NULL,
1633                          scalar_arg)
1634           || ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1635                               TREE_OPERAND (source_tree, 2), NULL,
1636                               scalar_arg);
1637
1638
1639     case ADDR_EXPR:
1640       ffecom_tree_canonize_ref_ (&source_decl, &source_offset,
1641                                  &source_size,
1642                                  TREE_OPERAND (source_tree, 0));
1643       break;
1644
1645     case PARM_DECL:
1646       if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1647         return TRUE;
1648
1649       source_decl = source_tree;
1650       source_offset = bitsize_zero_node;
1651       source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1652       break;
1653
1654     case SAVE_EXPR:
1655     case REFERENCE_EXPR:
1656     case PREDECREMENT_EXPR:
1657     case PREINCREMENT_EXPR:
1658     case POSTDECREMENT_EXPR:
1659     case POSTINCREMENT_EXPR:
1660     case INDIRECT_REF:
1661     case ARRAY_REF:
1662     case CALL_EXPR:
1663     default:
1664       return TRUE;
1665     }
1666
1667   /* Come here when source_decl, source_offset, and source_size filled
1668      in appropriately.  */
1669
1670   if (source_decl == NULL_TREE)
1671     return FALSE;               /* No decl involved, so no overlap. */
1672
1673   if (source_decl != dest_decl)
1674     return FALSE;               /* Different decl, no overlap. */
1675
1676   if (TREE_CODE (dest_size) == ERROR_MARK)
1677     return TRUE;                /* Assignment into entire assumed-size
1678                                    array?  Shouldn't happen.... */
1679
1680   t = ffecom_2 (LE_EXPR, integer_type_node,
1681                 ffecom_2 (PLUS_EXPR, TREE_TYPE (dest_offset),
1682                           dest_offset,
1683                           convert (TREE_TYPE (dest_offset),
1684                                    dest_size)),
1685                 convert (TREE_TYPE (dest_offset),
1686                          source_offset));
1687
1688   if (integer_onep (t))
1689     return FALSE;               /* Destination precedes source. */
1690
1691   if (!scalar_arg
1692       || (source_size == NULL_TREE)
1693       || (TREE_CODE (source_size) == ERROR_MARK)
1694       || integer_zerop (source_size))
1695     return TRUE;                /* No way to tell if dest follows source. */
1696
1697   t = ffecom_2 (LE_EXPR, integer_type_node,
1698                 ffecom_2 (PLUS_EXPR, TREE_TYPE (source_offset),
1699                           source_offset,
1700                           convert (TREE_TYPE (source_offset),
1701                                    source_size)),
1702                 convert (TREE_TYPE (source_offset),
1703                          dest_offset));
1704
1705   if (integer_onep (t))
1706     return FALSE;               /* Destination follows source. */
1707
1708   return TRUE;          /* Destination and source overlap. */
1709 }
1710
1711 /* Check whether dest might overlap any of a list of arguments or is
1712    in a COMMON area the callee might know about (and thus modify).  */
1713
1714 static bool
1715 ffecom_args_overlapping_ (tree dest_tree, ffebld dest UNUSED,
1716                           tree args, tree callee_commons,
1717                           bool scalar_args)
1718 {
1719   tree arg;
1720   tree dest_decl;
1721   tree dest_offset;
1722   tree dest_size;
1723
1724   ffecom_tree_canonize_ref_ (&dest_decl, &dest_offset, &dest_size,
1725                              dest_tree);
1726
1727   if (dest_decl == NULL_TREE)
1728     return FALSE;               /* Seems unlikely! */
1729
1730   /* If the decl cannot be determined reliably, or if its in COMMON
1731      and the callee isn't known to not futz with COMMON via other
1732      means, overlap might happen.  */
1733
1734   if ((TREE_CODE (dest_decl) == ERROR_MARK)
1735       || ((callee_commons != NULL_TREE)
1736           && TREE_PUBLIC (dest_decl)))
1737     return TRUE;
1738
1739   for (; args != NULL_TREE; args = TREE_CHAIN (args))
1740     {
1741       if (((arg = TREE_VALUE (args)) != NULL_TREE)
1742           && ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1743                               arg, NULL, scalar_args))
1744         return TRUE;
1745     }
1746
1747   return FALSE;
1748 }
1749
1750 /* Build a string for a variable name as used by NAMELIST.  This means that
1751    if we're using the f2c library, we build an uppercase string, since
1752    f2c does this.  */
1753
1754 static tree
1755 ffecom_build_f2c_string_ (int i, const char *s)
1756 {
1757   if (!ffe_is_f2c_library ())
1758     return build_string (i, s);
1759
1760   {
1761     char *tmp;
1762     const char *p;
1763     char *q;
1764     char space[34];
1765     tree t;
1766
1767     if (((size_t) i) > ARRAY_SIZE (space))
1768       tmp = malloc_new_ks (malloc_pool_image (), "f2c_string", i);
1769     else
1770       tmp = &space[0];
1771
1772     for (p = s, q = tmp; *p != '\0'; ++p, ++q)
1773       *q = TOUPPER (*p);
1774     *q = '\0';
1775
1776     t = build_string (i, tmp);
1777
1778     if (((size_t) i) > ARRAY_SIZE (space))
1779       malloc_kill_ks (malloc_pool_image (), tmp, i);
1780
1781     return t;
1782   }
1783 }
1784
1785 /* Returns CALL_EXPR or equivalent with given type (pass NULL_TREE for
1786    type to just get whatever the function returns), handling the
1787    f2c value-returning convention, if required, by prepending
1788    to the arglist a pointer to a temporary to receive the return value.  */
1789
1790 static tree
1791 ffecom_call_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1792               tree type, tree args, tree dest_tree,
1793               ffebld dest, bool *dest_used, tree callee_commons,
1794               bool scalar_args, tree hook)
1795 {
1796   tree item;
1797   tree tempvar;
1798
1799   if (dest_used != NULL)
1800     *dest_used = FALSE;
1801
1802   if (is_f2c_complex)
1803     {
1804       if ((dest_used == NULL)
1805           || (dest == NULL)
1806           || (ffeinfo_basictype (ffebld_info (dest))
1807               != FFEINFO_basictypeCOMPLEX)
1808           || (ffeinfo_kindtype (ffebld_info (dest)) != kt)
1809           || ((type != NULL_TREE) && (TREE_TYPE (dest_tree) != type))
1810           || ffecom_args_overlapping_ (dest_tree, dest, args,
1811                                        callee_commons,
1812                                        scalar_args))
1813         {
1814           tempvar = hook;
1815           assert (tempvar);
1816         }
1817       else
1818         {
1819           *dest_used = TRUE;
1820           tempvar = dest_tree;
1821           type = NULL_TREE;
1822         }
1823
1824       item
1825         = build_tree_list (NULL_TREE,
1826                            ffecom_1 (ADDR_EXPR,
1827                                      build_pointer_type (TREE_TYPE (tempvar)),
1828                                      tempvar));
1829       TREE_CHAIN (item) = args;
1830
1831       item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1832                         item, NULL_TREE);
1833
1834       if (tempvar != dest_tree)
1835         item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item, tempvar);
1836     }
1837   else
1838     item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1839                       args, NULL_TREE);
1840
1841   if ((type != NULL_TREE) && (TREE_TYPE (item) != type))
1842     item = ffecom_convert_narrow_ (type, item);
1843
1844   return item;
1845 }
1846
1847 /* Given two arguments, transform them and make a call to the given
1848    function via ffecom_call_.  */
1849
1850 static tree
1851 ffecom_call_binop_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1852                     tree type, ffebld left, ffebld right,
1853                     tree dest_tree, ffebld dest, bool *dest_used,
1854                     tree callee_commons, bool scalar_args, bool ref, tree hook)
1855 {
1856   tree left_tree;
1857   tree right_tree;
1858   tree left_length;
1859   tree right_length;
1860
1861   if (ref)
1862     {
1863       /* Pass arguments by reference.  */
1864       left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
1865       right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
1866     }
1867   else
1868     {
1869       /* Pass arguments by value.  */
1870       left_tree = ffecom_arg_expr (left, &left_length);
1871       right_tree = ffecom_arg_expr (right, &right_length);
1872     }
1873
1874
1875   left_tree = build_tree_list (NULL_TREE, left_tree);
1876   right_tree = build_tree_list (NULL_TREE, right_tree);
1877   TREE_CHAIN (left_tree) = right_tree;
1878
1879   if (left_length != NULL_TREE)
1880     {
1881       left_length = build_tree_list (NULL_TREE, left_length);
1882       TREE_CHAIN (right_tree) = left_length;
1883     }
1884
1885   if (right_length != NULL_TREE)
1886     {
1887       right_length = build_tree_list (NULL_TREE, right_length);
1888       if (left_length != NULL_TREE)
1889         TREE_CHAIN (left_length) = right_length;
1890       else
1891         TREE_CHAIN (right_tree) = right_length;
1892     }
1893
1894   return ffecom_call_ (fn, kt, is_f2c_complex, type, left_tree,
1895                        dest_tree, dest, dest_used, callee_commons,
1896                        scalar_args, hook);
1897 }
1898
1899 /* Return ptr/length args for char subexpression
1900
1901    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
1902    subexpressions by constructing the appropriate trees for the ptr-to-
1903    character-text and length-of-character-text arguments in a calling
1904    sequence.
1905
1906    Note that if with_null is TRUE, and the expression is an opCONTER,
1907    a null byte is appended to the string.  */
1908
1909 static void
1910 ffecom_char_args_x_ (tree *xitem, tree *length, ffebld expr, bool with_null)
1911 {
1912   tree item;
1913   tree high;
1914   ffetargetCharacter1 val;
1915   ffetargetCharacterSize newlen;
1916
1917   switch (ffebld_op (expr))
1918     {
1919     case FFEBLD_opCONTER:
1920       val = ffebld_constant_character1 (ffebld_conter (expr));
1921       newlen = ffetarget_length_character1 (val);
1922       if (with_null)
1923         {
1924           /* Begin FFETARGET-NULL-KLUDGE.  */
1925           if (newlen != 0)
1926             ++newlen;
1927         }
1928       *length = build_int_2 (newlen, 0);
1929       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
1930       high = build_int_2 (newlen, 0);
1931       TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
1932       item = build_string (newlen,
1933                            ffetarget_text_character1 (val));
1934       /* End FFETARGET-NULL-KLUDGE.  */
1935       TREE_TYPE (item)
1936         = build_type_variant
1937           (build_array_type
1938            (char_type_node,
1939             build_range_type
1940             (ffecom_f2c_ftnlen_type_node,
1941              ffecom_f2c_ftnlen_one_node,
1942              high)),
1943            1, 0);
1944       TREE_CONSTANT (item) = 1;
1945       TREE_STATIC (item) = 1;
1946       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
1947                        item);
1948       break;
1949
1950     case FFEBLD_opSYMTER:
1951       {
1952         ffesymbol s = ffebld_symter (expr);
1953
1954         item = ffesymbol_hook (s).decl_tree;
1955         if (item == NULL_TREE)
1956           {
1957             s = ffecom_sym_transform_ (s);
1958             item = ffesymbol_hook (s).decl_tree;
1959           }
1960         if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
1961           {
1962             if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
1963               *length = ffesymbol_hook (s).length_tree;
1964             else
1965               {
1966                 *length = build_int_2 (ffesymbol_size (s), 0);
1967                 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
1968               }
1969           }
1970         else if (item == error_mark_node)
1971           *length = error_mark_node;
1972         else
1973           /* FFEINFO_kindFUNCTION.  */
1974           *length = NULL_TREE;
1975         if (!ffesymbol_hook (s).addr
1976             && (item != error_mark_node))
1977           item = ffecom_1 (ADDR_EXPR,
1978                            build_pointer_type (TREE_TYPE (item)),
1979                            item);
1980       }
1981       break;
1982
1983     case FFEBLD_opARRAYREF:
1984       {
1985         ffecom_char_args_ (&item, length, ffebld_left (expr));
1986
1987         if (item == error_mark_node || *length == error_mark_node)
1988           {
1989             item = *length = error_mark_node;
1990             break;
1991           }
1992
1993         item = ffecom_arrayref_ (item, expr, 1);
1994       }
1995       break;
1996
1997     case FFEBLD_opSUBSTR:
1998       {
1999         ffebld start;
2000         ffebld end;
2001         ffebld thing = ffebld_right (expr);
2002         tree start_tree;
2003         tree end_tree;
2004         const char *char_name;
2005         ffebld left_symter;
2006         tree array;
2007
2008         assert (ffebld_op (thing) == FFEBLD_opITEM);
2009         start = ffebld_head (thing);
2010         thing = ffebld_trail (thing);
2011         assert (ffebld_trail (thing) == NULL);
2012         end = ffebld_head (thing);
2013
2014         /* Determine name for pretty-printing range-check errors.  */
2015         for (left_symter = ffebld_left (expr);
2016              left_symter && ffebld_op (left_symter) == FFEBLD_opARRAYREF;
2017              left_symter = ffebld_left (left_symter))
2018           ;
2019         if (ffebld_op (left_symter) == FFEBLD_opSYMTER)
2020           char_name = ffesymbol_text (ffebld_symter (left_symter));
2021         else
2022           char_name = "[expr?]";
2023
2024         ffecom_char_args_ (&item, length, ffebld_left (expr));
2025
2026         if (item == error_mark_node || *length == error_mark_node)
2027           {
2028             item = *length = error_mark_node;
2029             break;
2030           }
2031
2032         array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
2033
2034         /* ~~~~Handle INTEGER*8 start/end, a la FFEBLD_opARRAYREF.  */
2035
2036         if (start == NULL)
2037           {
2038             if (end == NULL)
2039               ;
2040             else
2041               {
2042                 end_tree = ffecom_expr (end);
2043                 if (flag_bounds_check)
2044                   end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2045                                                       char_name);
2046                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2047                                     end_tree);
2048
2049                 if (end_tree == error_mark_node)
2050                   {
2051                     item = *length = error_mark_node;
2052                     break;
2053                   }
2054
2055                 *length = end_tree;
2056               }
2057           }
2058         else
2059           {
2060             start_tree = ffecom_expr (start);
2061             if (flag_bounds_check)
2062               start_tree = ffecom_subscript_check_ (array, start_tree, 0, 0,
2063                                                     char_name);
2064             start_tree = convert (ffecom_f2c_ftnlen_type_node,
2065                                   start_tree);
2066
2067             if (start_tree == error_mark_node)
2068               {
2069                 item = *length = error_mark_node;
2070                 break;
2071               }
2072
2073             start_tree = ffecom_save_tree (start_tree);
2074
2075             item = ffecom_2 (PLUS_EXPR, TREE_TYPE (item),
2076                              item,
2077                              ffecom_2 (MINUS_EXPR,
2078                                        TREE_TYPE (start_tree),
2079                                        start_tree,
2080                                        ffecom_f2c_ftnlen_one_node));
2081
2082             if (end == NULL)
2083               {
2084                 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2085                                     ffecom_f2c_ftnlen_one_node,
2086                                     ffecom_2 (MINUS_EXPR,
2087                                               ffecom_f2c_ftnlen_type_node,
2088                                               *length,
2089                                               start_tree));
2090               }
2091             else
2092               {
2093                 end_tree = ffecom_expr (end);
2094                 if (flag_bounds_check)
2095                   end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2096                                                       char_name);
2097                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2098                                     end_tree);
2099
2100                 if (end_tree == error_mark_node)
2101                   {
2102                     item = *length = error_mark_node;
2103                     break;
2104                   }
2105
2106                 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2107                                     ffecom_f2c_ftnlen_one_node,
2108                                     ffecom_2 (MINUS_EXPR,
2109                                               ffecom_f2c_ftnlen_type_node,
2110                                               end_tree, start_tree));
2111               }
2112           }
2113       }
2114       break;
2115
2116     case FFEBLD_opFUNCREF:
2117       {
2118         ffesymbol s = ffebld_symter (ffebld_left (expr));
2119         tree tempvar;
2120         tree args;
2121         ffetargetCharacterSize size = ffeinfo_size (ffebld_info (expr));
2122         ffecomGfrt ix;
2123
2124         if (size == FFETARGET_charactersizeNONE)
2125           /* ~~Kludge alert!  This should someday be fixed. */
2126           size = 24;
2127
2128         *length = build_int_2 (size, 0);
2129         TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2130
2131         if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
2132             == FFEINFO_whereINTRINSIC)
2133           {
2134             if (size == 1)
2135               {
2136                 /* Invocation of an intrinsic returning CHARACTER*1.  */
2137                 item = ffecom_expr_intrinsic_ (expr, NULL_TREE,
2138                                                NULL, NULL);
2139                 break;
2140               }
2141             ix = ffeintrin_gfrt_direct (ffebld_symter_implementation (ffebld_left (expr)));
2142             assert (ix != FFECOM_gfrt);
2143             item = ffecom_gfrt_tree_ (ix);
2144           }
2145         else
2146           {
2147             ix = FFECOM_gfrt;
2148             item = ffesymbol_hook (s).decl_tree;
2149             if (item == NULL_TREE)
2150               {
2151                 s = ffecom_sym_transform_ (s);
2152                 item = ffesymbol_hook (s).decl_tree;
2153               }
2154             if (item == error_mark_node)
2155               {
2156                 item = *length = error_mark_node;
2157                 break;
2158               }
2159
2160             if (!ffesymbol_hook (s).addr)
2161               item = ffecom_1_fn (item);
2162           }
2163         tempvar = ffebld_nonter_hook (expr);
2164         assert (tempvar);
2165         tempvar = ffecom_1 (ADDR_EXPR,
2166                             build_pointer_type (TREE_TYPE (tempvar)),
2167                             tempvar);
2168
2169         args = build_tree_list (NULL_TREE, tempvar);
2170
2171         if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)       /* Sfunc args by value. */
2172           TREE_CHAIN (args) = ffecom_list_expr (ffebld_right (expr));
2173         else
2174           {
2175             TREE_CHAIN (args) = build_tree_list (NULL_TREE, *length);
2176             if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
2177               {
2178                 TREE_CHAIN (TREE_CHAIN (args))
2179                   = ffecom_arglist_expr_ (ffecom_gfrt_args_ (ix),
2180                                           ffebld_right (expr));
2181               }
2182             else
2183               {
2184                 TREE_CHAIN (TREE_CHAIN (args))
2185                   = ffecom_list_ptr_to_expr (ffebld_right (expr));
2186               }
2187           }
2188
2189         item = ffecom_3s (CALL_EXPR,
2190                           TREE_TYPE (TREE_TYPE (TREE_TYPE (item))),
2191                           item, args, NULL_TREE);
2192         item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item,
2193                          tempvar);
2194       }
2195       break;
2196
2197     case FFEBLD_opCONVERT:
2198
2199       ffecom_char_args_ (&item, length, ffebld_left (expr));
2200
2201       if (item == error_mark_node || *length == error_mark_node)
2202         {
2203           item = *length = error_mark_node;
2204           break;
2205         }
2206
2207       if ((ffebld_size_known (ffebld_left (expr))
2208            == FFETARGET_charactersizeNONE)
2209           || (ffebld_size_known (ffebld_left (expr)) < (ffebld_size (expr))))
2210         {                       /* Possible blank-padding needed, copy into
2211                                    temporary. */
2212           tree tempvar;
2213           tree args;
2214           tree newlen;
2215
2216           tempvar = ffebld_nonter_hook (expr);
2217           assert (tempvar);
2218           tempvar = ffecom_1 (ADDR_EXPR,
2219                               build_pointer_type (TREE_TYPE (tempvar)),
2220                               tempvar);
2221
2222           newlen = build_int_2 (ffebld_size (expr), 0);
2223           TREE_TYPE (newlen) = ffecom_f2c_ftnlen_type_node;
2224
2225           args = build_tree_list (NULL_TREE, tempvar);
2226           TREE_CHAIN (args) = build_tree_list (NULL_TREE, item);
2227           TREE_CHAIN (TREE_CHAIN (args)) = build_tree_list (NULL_TREE, newlen);
2228           TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (args)))
2229             = build_tree_list (NULL_TREE, *length);
2230
2231           item = ffecom_call_gfrt (FFECOM_gfrtCOPY, args, NULL_TREE);
2232           TREE_SIDE_EFFECTS (item) = 1;
2233           item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), fold (item),
2234                            tempvar);
2235           *length = newlen;
2236         }
2237       else
2238         {                       /* Just truncate the length. */
2239           *length = build_int_2 (ffebld_size (expr), 0);
2240           TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2241         }
2242       break;
2243
2244     default:
2245       assert ("bad op for single char arg expr" == NULL);
2246       item = NULL_TREE;
2247       break;
2248     }
2249
2250   *xitem = item;
2251 }
2252
2253 /* Check the size of the type to be sure it doesn't overflow the
2254    "portable" capacities of the compiler back end.  `dummy' types
2255    can generally overflow the normal sizes as long as the computations
2256    themselves don't overflow.  A particular target of the back end
2257    must still enforce its size requirements, though, and the back
2258    end takes care of this in stor-layout.c.  */
2259
2260 static tree
2261 ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy)
2262 {
2263   if (TREE_CODE (type) == ERROR_MARK)
2264     return type;
2265
2266   if (TYPE_SIZE (type) == NULL_TREE)
2267     return type;
2268
2269   if (TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST)
2270     return type;
2271
2272   /* An array is too large if size is negative or the type_size overflows
2273      or its "upper half" is larger than 3 (which would make the signed
2274      byte size and offset computations overflow).  */
2275
2276   if ((tree_int_cst_sgn (TYPE_SIZE (type)) < 0)
2277       || (!dummy && (TREE_INT_CST_HIGH (TYPE_SIZE (type)) > 3
2278                      || TREE_OVERFLOW (TYPE_SIZE (type)))))
2279     {
2280       ffebad_start (FFEBAD_ARRAY_LARGE);
2281       ffebad_string (ffesymbol_text (s));
2282       ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s));
2283       ffebad_finish ();
2284
2285       return error_mark_node;
2286     }
2287
2288   return type;
2289 }
2290
2291 /* Builds a length argument (PARM_DECL).  Also wraps type in an array type
2292    where the dimension info is (1:size) where <size> is ffesymbol_size(s) if
2293    known, length_arg if not known (FFETARGET_charactersizeNONE).  */
2294
2295 static tree
2296 ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s)
2297 {
2298   ffetargetCharacterSize sz = ffesymbol_size (s);
2299   tree highval;
2300   tree tlen;
2301   tree type = *xtype;
2302
2303   if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
2304     tlen = NULL_TREE;           /* A statement function, no length passed. */
2305   else
2306     {
2307       if (ffesymbol_where (s) == FFEINFO_whereDUMMY)
2308         tlen = ffecom_get_invented_identifier ("__g77_length_%s",
2309                                                ffesymbol_text (s));
2310       else
2311         tlen = ffecom_get_invented_identifier ("__g77_%s", "length");
2312       tlen = build_decl (PARM_DECL, tlen, ffecom_f2c_ftnlen_type_node);
2313       DECL_ARTIFICIAL (tlen) = 1;
2314     }
2315
2316   if (sz == FFETARGET_charactersizeNONE)
2317     {
2318       assert (tlen != NULL_TREE);
2319       highval = variable_size (tlen);
2320     }
2321   else
2322     {
2323       highval = build_int_2 (sz, 0);
2324       TREE_TYPE (highval) = ffecom_f2c_ftnlen_type_node;
2325     }
2326
2327   type = build_array_type (type,
2328                            build_range_type (ffecom_f2c_ftnlen_type_node,
2329                                              ffecom_f2c_ftnlen_one_node,
2330                                              highval));
2331
2332   *xtype = type;
2333   return tlen;
2334 }
2335
2336 /* ffecom_concat_list_gather_ -- Gather list of concatenated string exprs
2337
2338    ffecomConcatList_ catlist;
2339    ffebld expr;  // expr of CHARACTER basictype.
2340    ffetargetCharacterSize max;  // max chars to gather or _...NONE if no max
2341    catlist = ffecom_concat_list_gather_(catlist,expr,max);
2342
2343    Scans expr for character subexpressions, updates and returns catlist
2344    accordingly.  */
2345
2346 static ffecomConcatList_
2347 ffecom_concat_list_gather_ (ffecomConcatList_ catlist, ffebld expr,
2348                             ffetargetCharacterSize max)
2349 {
2350   ffetargetCharacterSize sz;
2351
2352  recurse:
2353
2354   if (expr == NULL)
2355     return catlist;
2356
2357   if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen >= max))
2358     return catlist;             /* Don't append any more items. */
2359
2360   switch (ffebld_op (expr))
2361     {
2362     case FFEBLD_opCONTER:
2363     case FFEBLD_opSYMTER:
2364     case FFEBLD_opARRAYREF:
2365     case FFEBLD_opFUNCREF:
2366     case FFEBLD_opSUBSTR:
2367     case FFEBLD_opCONVERT:      /* Callers should strip this off beforehand
2368                                    if they don't need to preserve it. */
2369       if (catlist.count == catlist.max)
2370         {                       /* Make a (larger) list. */
2371           ffebld *newx;
2372           int newmax;
2373
2374           newmax = (catlist.max == 0) ? 8 : catlist.max * 2;
2375           newx = malloc_new_ks (malloc_pool_image (), "catlist",
2376                                 newmax * sizeof (newx[0]));
2377           if (catlist.max != 0)
2378             {
2379               memcpy (newx, catlist.exprs, catlist.max * sizeof (newx[0]));
2380               malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2381                               catlist.max * sizeof (newx[0]));
2382             }
2383           catlist.max = newmax;
2384           catlist.exprs = newx;
2385         }
2386       if ((sz = ffebld_size_known (expr)) != FFETARGET_charactersizeNONE)
2387         catlist.minlen += sz;
2388       else
2389         ++catlist.minlen;       /* Not true for F90; can be 0 length. */
2390       if ((sz = ffebld_size_max (expr)) == FFETARGET_charactersizeNONE)
2391         catlist.maxlen = sz;
2392       else
2393         catlist.maxlen += sz;
2394       if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen > max))
2395         {                       /* This item overlaps (or is beyond) the end
2396                                    of the destination. */
2397           switch (ffebld_op (expr))
2398             {
2399             case FFEBLD_opCONTER:
2400             case FFEBLD_opSYMTER:
2401             case FFEBLD_opARRAYREF:
2402             case FFEBLD_opFUNCREF:
2403             case FFEBLD_opSUBSTR:
2404               /* ~~Do useful truncations here. */
2405               break;
2406
2407             default:
2408               assert ("op changed or inconsistent switches!" == NULL);
2409               break;
2410             }
2411         }
2412       catlist.exprs[catlist.count++] = expr;
2413       return catlist;
2414
2415     case FFEBLD_opPAREN:
2416       expr = ffebld_left (expr);
2417       goto recurse;             /* :::::::::::::::::::: */
2418
2419     case FFEBLD_opCONCATENATE:
2420       catlist = ffecom_concat_list_gather_ (catlist, ffebld_left (expr), max);
2421       expr = ffebld_right (expr);
2422       goto recurse;             /* :::::::::::::::::::: */
2423
2424 #if 0                           /* Breaks passing small actual arg to larger
2425                                    dummy arg of sfunc */
2426     case FFEBLD_opCONVERT:
2427       expr = ffebld_left (expr);
2428       {
2429         ffetargetCharacterSize cmax;
2430
2431         cmax = catlist.len + ffebld_size_known (expr);
2432
2433         if ((max == FFETARGET_charactersizeNONE) || (max > cmax))
2434           max = cmax;
2435       }
2436       goto recurse;             /* :::::::::::::::::::: */
2437 #endif
2438
2439     case FFEBLD_opANY:
2440       return catlist;
2441
2442     default:
2443       assert ("bad op in _gather_" == NULL);
2444       return catlist;
2445     }
2446 }
2447
2448 /* ffecom_concat_list_kill_ -- Kill list of concatenated string exprs
2449
2450    ffecomConcatList_ catlist;
2451    ffecom_concat_list_kill_(catlist);
2452
2453    Anything allocated within the list info is deallocated.  */
2454
2455 static void
2456 ffecom_concat_list_kill_ (ffecomConcatList_ catlist)
2457 {
2458   if (catlist.max != 0)
2459     malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2460                     catlist.max * sizeof (catlist.exprs[0]));
2461 }
2462
2463 /* Make list of concatenated string exprs.
2464
2465    Returns a flattened list of concatenated subexpressions given a
2466    tree of such expressions.  */
2467
2468 static ffecomConcatList_
2469 ffecom_concat_list_new_ (ffebld expr, ffetargetCharacterSize max)
2470 {
2471   ffecomConcatList_ catlist;
2472
2473   catlist.maxlen = catlist.minlen = catlist.max = catlist.count = 0;
2474   return ffecom_concat_list_gather_ (catlist, expr, max);
2475 }
2476
2477 /* Provide some kind of useful info on member of aggregate area,
2478    since current g77/gcc technology does not provide debug info
2479    on these members.  */
2480
2481 static void
2482 ffecom_debug_kludge_ (tree aggr, const char *aggr_type, ffesymbol member,
2483                       tree member_type UNUSED, ffetargetOffset offset)
2484 {
2485   tree value;
2486   tree decl;
2487   int len;
2488   char *buff;
2489   char space[120];
2490 #if 0
2491   tree type_id;
2492
2493   for (type_id = member_type;
2494        TREE_CODE (type_id) != IDENTIFIER_NODE;
2495        )
2496     {
2497       switch (TREE_CODE (type_id))
2498         {
2499         case INTEGER_TYPE:
2500         case REAL_TYPE:
2501           type_id = TYPE_NAME (type_id);
2502           break;
2503
2504         case ARRAY_TYPE:
2505         case COMPLEX_TYPE:
2506           type_id = TREE_TYPE (type_id);
2507           break;
2508
2509         default:
2510           assert ("no IDENTIFIER_NODE for type!" == NULL);
2511           type_id = error_mark_node;
2512           break;
2513         }
2514     }
2515 #endif
2516
2517   if (ffecom_transform_only_dummies_
2518       || !ffe_is_debug_kludge ())
2519     return;     /* Can't do this yet, maybe later. */
2520
2521   len = 60
2522     + strlen (aggr_type)
2523     + IDENTIFIER_LENGTH (DECL_NAME (aggr));
2524 #if 0
2525     + IDENTIFIER_LENGTH (type_id);
2526 #endif
2527
2528   if (((size_t) len) >= ARRAY_SIZE (space))
2529     buff = malloc_new_ks (malloc_pool_image (), "debug_kludge", len + 1);
2530   else
2531     buff = &space[0];
2532
2533   sprintf (&buff[0], "At (%s) `%s' plus %ld bytes",
2534            aggr_type,
2535            IDENTIFIER_POINTER (DECL_NAME (aggr)),
2536            (long int) offset);
2537
2538   value = build_string (len, buff);
2539   TREE_TYPE (value)
2540     = build_type_variant (build_array_type (char_type_node,
2541                                             build_range_type
2542                                             (integer_type_node,
2543                                              integer_one_node,
2544                                              build_int_2 (strlen (buff), 0))),
2545                           1, 0);
2546   decl = build_decl (VAR_DECL,
2547                      ffecom_get_identifier_ (ffesymbol_text (member)),
2548                      TREE_TYPE (value));
2549   TREE_CONSTANT (decl) = 1;
2550   TREE_STATIC (decl) = 1;
2551   DECL_INITIAL (decl) = error_mark_node;
2552   DECL_IN_SYSTEM_HEADER (decl) = 1;     /* Don't let -Wunused complain. */
2553   decl = start_decl (decl, FALSE);
2554   finish_decl (decl, value, FALSE);
2555
2556   if (buff != &space[0])
2557     malloc_kill_ks (malloc_pool_image (), buff, len + 1);
2558 }
2559
2560 /* ffecom_do_entry_ -- Do compilation of a particular entrypoint
2561
2562    ffesymbol fn;  // the SUBROUTINE, FUNCTION, or ENTRY symbol itself
2563    int i;  // entry# for this entrypoint (used by master fn)
2564    ffecom_do_entrypoint_(s,i);
2565
2566    Makes a public entry point that calls our private master fn (already
2567    compiled).  */
2568
2569 static void
2570 ffecom_do_entry_ (ffesymbol fn, int entrynum)
2571 {
2572   ffebld item;
2573   tree type;                    /* Type of function. */
2574   tree multi_retval;            /* Var holding return value (union). */
2575   tree result;                  /* Var holding result. */
2576   ffeinfoBasictype bt;
2577   ffeinfoKindtype kt;
2578   ffeglobal g;
2579   ffeglobalType gt;
2580   bool charfunc;                /* All entry points return same type
2581                                    CHARACTER. */
2582   bool cmplxfunc;               /* Use f2c way of returning COMPLEX. */
2583   bool multi;                   /* Master fn has multiple return types. */
2584   bool altreturning = FALSE;    /* This entry point has alternate
2585                                    returns. */
2586   location_t old_loc = input_location;
2587
2588   input_filename = ffesymbol_where_filename (fn);
2589   input_line = ffesymbol_where_filelinenum (fn);
2590
2591   ffecom_doing_entry_ = TRUE;   /* Don't bother with array dimensions. */
2592
2593   switch (ffecom_primary_entry_kind_)
2594     {
2595     case FFEINFO_kindFUNCTION:
2596
2597       /* Determine actual return type for function. */
2598
2599       gt = FFEGLOBAL_typeFUNC;
2600       bt = ffesymbol_basictype (fn);
2601       kt = ffesymbol_kindtype (fn);
2602       if (bt == FFEINFO_basictypeNONE)
2603         {
2604           ffeimplic_establish_symbol (fn);
2605           if (ffesymbol_funcresult (fn) != NULL)
2606             ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
2607           bt = ffesymbol_basictype (fn);
2608           kt = ffesymbol_kindtype (fn);
2609         }
2610
2611       if (bt == FFEINFO_basictypeCHARACTER)
2612         charfunc = TRUE, cmplxfunc = FALSE;
2613       else if ((bt == FFEINFO_basictypeCOMPLEX)
2614                && ffesymbol_is_f2c (fn))
2615         charfunc = FALSE, cmplxfunc = TRUE;
2616       else
2617         charfunc = cmplxfunc = FALSE;
2618
2619       if (charfunc)
2620         type = ffecom_tree_fun_type_void;
2621       else if (ffesymbol_is_f2c (fn))
2622         type = ffecom_tree_fun_type[bt][kt];
2623       else
2624         type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
2625
2626       if ((type == NULL_TREE)
2627           || (TREE_TYPE (type) == NULL_TREE))
2628         type = ffecom_tree_fun_type_void;       /* _sym_exec_transition. */
2629
2630       multi = (ffecom_master_bt_ == FFEINFO_basictypeNONE);
2631       break;
2632
2633     case FFEINFO_kindSUBROUTINE:
2634       gt = FFEGLOBAL_typeSUBR;
2635       bt = FFEINFO_basictypeNONE;
2636       kt = FFEINFO_kindtypeNONE;
2637       if (ffecom_is_altreturning_)
2638         {                       /* Am _I_ altreturning? */
2639           for (item = ffesymbol_dummyargs (fn);
2640                item != NULL;
2641                item = ffebld_trail (item))
2642             {
2643               if (ffebld_op (ffebld_head (item)) == FFEBLD_opSTAR)
2644                 {
2645                   altreturning = TRUE;
2646                   break;
2647                 }
2648             }
2649           if (altreturning)
2650             type = ffecom_tree_subr_type;
2651           else
2652             type = ffecom_tree_fun_type_void;
2653         }
2654       else
2655         type = ffecom_tree_fun_type_void;
2656       charfunc = FALSE;
2657       cmplxfunc = FALSE;
2658       multi = FALSE;
2659       break;
2660
2661     default:
2662       assert ("say what??" == NULL);
2663       /* Fall through. */
2664     case FFEINFO_kindANY:
2665       gt = FFEGLOBAL_typeANY;
2666       bt = FFEINFO_basictypeNONE;
2667       kt = FFEINFO_kindtypeNONE;
2668       type = error_mark_node;
2669       charfunc = FALSE;
2670       cmplxfunc = FALSE;
2671       multi = FALSE;
2672       break;
2673     }
2674
2675   /* build_decl uses the current lineno and input_filename to set the decl
2676      source info.  So, I've putzed with ffestd and ffeste code to update that
2677      source info to point to the appropriate statement just before calling
2678      ffecom_do_entrypoint (which calls this fn).  */
2679
2680   start_function (ffecom_get_external_identifier_ (fn),
2681                   type,
2682                   0,            /* nested/inline */
2683                   1);           /* TREE_PUBLIC */
2684
2685   if (((g = ffesymbol_global (fn)) != NULL)
2686       && ((ffeglobal_type (g) == gt)
2687           || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
2688     {
2689       ffeglobal_set_hook (g, current_function_decl);
2690     }
2691
2692   /* Reset args in master arg list so they get retransitioned. */
2693
2694   for (item = ffecom_master_arglist_;
2695        item != NULL;
2696        item = ffebld_trail (item))
2697     {
2698       ffebld arg;
2699       ffesymbol s;
2700
2701       arg = ffebld_head (item);
2702       if (ffebld_op (arg) != FFEBLD_opSYMTER)
2703         continue;               /* Alternate return or some such thing. */
2704       s = ffebld_symter (arg);
2705       ffesymbol_hook (s).decl_tree = NULL_TREE;
2706       ffesymbol_hook (s).length_tree = NULL_TREE;
2707     }
2708
2709   /* Build dummy arg list for this entry point. */
2710
2711   if (charfunc || cmplxfunc)
2712     {                           /* Prepend arg for where result goes. */
2713       tree type;
2714       tree length;
2715
2716       if (charfunc)
2717         type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
2718       else
2719         type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
2720
2721       result = ffecom_get_invented_identifier ("__g77_%s", "result");
2722
2723       /* Make length arg _and_ enhance type info for CHAR arg itself.  */
2724
2725       if (charfunc)
2726         length = ffecom_char_enhance_arg_ (&type, fn);
2727       else
2728         length = NULL_TREE;     /* Not ref'd if !charfunc. */
2729
2730       type = build_pointer_type (type);
2731       result = build_decl (PARM_DECL, result, type);
2732
2733       push_parm_decl (result);
2734       ffecom_func_result_ = result;
2735
2736       if (charfunc)
2737         {
2738           push_parm_decl (length);
2739           ffecom_func_length_ = length;
2740         }
2741     }
2742   else
2743     result = DECL_RESULT (current_function_decl);
2744
2745   ffecom_push_dummy_decls_ (ffesymbol_dummyargs (fn), FALSE);
2746
2747   store_parm_decls (0);
2748
2749   ffecom_start_compstmt ();
2750   /* Disallow temp vars at this level.  */
2751   current_binding_level->prep_state = 2;
2752
2753   /* Make local var to hold return type for multi-type master fn. */
2754
2755   if (multi)
2756     {
2757       multi_retval = ffecom_get_invented_identifier ("__g77_%s",
2758                                                      "multi_retval");
2759       multi_retval = build_decl (VAR_DECL, multi_retval,
2760                                  ffecom_multi_type_node_);
2761       multi_retval = start_decl (multi_retval, FALSE);
2762       finish_decl (multi_retval, NULL_TREE, FALSE);
2763     }
2764   else
2765     multi_retval = NULL_TREE;   /* Not actually ref'd if !multi. */
2766
2767   /* Here we emit the actual code for the entry point. */
2768
2769   {
2770     ffebld list;
2771     ffebld arg;
2772     ffesymbol s;
2773     tree arglist = NULL_TREE;
2774     tree *plist = &arglist;
2775     tree prepend;
2776     tree call;
2777     tree actarg;
2778     tree master_fn;
2779
2780     /* Prepare actual arg list based on master arg list. */
2781
2782     for (list = ffecom_master_arglist_;
2783          list != NULL;
2784          list = ffebld_trail (list))
2785       {
2786         arg = ffebld_head (list);
2787         if (ffebld_op (arg) != FFEBLD_opSYMTER)
2788           continue;
2789         s = ffebld_symter (arg);
2790         if (ffesymbol_hook (s).decl_tree == NULL_TREE
2791             || ffesymbol_hook (s).decl_tree == error_mark_node)
2792           actarg = null_pointer_node;   /* We don't have this arg. */
2793         else
2794           actarg = ffesymbol_hook (s).decl_tree;
2795         *plist = build_tree_list (NULL_TREE, actarg);
2796         plist = &TREE_CHAIN (*plist);
2797       }
2798
2799     /* This code appends the length arguments for character
2800        variables/arrays.  */
2801
2802     for (list = ffecom_master_arglist_;
2803          list != NULL;
2804          list = ffebld_trail (list))
2805       {
2806         arg = ffebld_head (list);
2807         if (ffebld_op (arg) != FFEBLD_opSYMTER)
2808           continue;
2809         s = ffebld_symter (arg);
2810         if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
2811           continue;             /* Only looking for CHARACTER arguments. */
2812         if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
2813           continue;             /* Only looking for variables and arrays. */
2814         if (ffesymbol_hook (s).length_tree == NULL_TREE
2815             || ffesymbol_hook (s).length_tree == error_mark_node)
2816           actarg = ffecom_f2c_ftnlen_zero_node; /* We don't have this arg. */
2817         else
2818           actarg = ffesymbol_hook (s).length_tree;
2819         *plist = build_tree_list (NULL_TREE, actarg);
2820         plist = &TREE_CHAIN (*plist);
2821       }
2822
2823     /* Prepend character-value return info to actual arg list. */
2824
2825     if (charfunc)
2826       {
2827         prepend = build_tree_list (NULL_TREE, ffecom_func_result_);
2828         TREE_CHAIN (prepend)
2829           = build_tree_list (NULL_TREE, ffecom_func_length_);
2830         TREE_CHAIN (TREE_CHAIN (prepend)) = arglist;
2831         arglist = prepend;
2832       }
2833
2834     /* Prepend multi-type return value to actual arg list. */
2835
2836     if (multi)
2837       {
2838         prepend
2839           = build_tree_list (NULL_TREE,
2840                              ffecom_1 (ADDR_EXPR,
2841                               build_pointer_type (TREE_TYPE (multi_retval)),
2842                                        multi_retval));
2843         TREE_CHAIN (prepend) = arglist;
2844         arglist = prepend;
2845       }
2846
2847     /* Prepend my entry-point number to the actual arg list. */
2848
2849     prepend = build_tree_list (NULL_TREE, build_int_2 (entrynum, 0));
2850     TREE_CHAIN (prepend) = arglist;
2851     arglist = prepend;
2852
2853     /* Build the call to the master function. */
2854
2855     master_fn = ffecom_1_fn (ffecom_previous_function_decl_);
2856     call = ffecom_3s (CALL_EXPR,
2857                       TREE_TYPE (TREE_TYPE (TREE_TYPE (master_fn))),
2858                       master_fn, arglist, NULL_TREE);
2859
2860     /* Decide whether the master function is a function or subroutine, and
2861        handle the return value for my entry point. */
2862
2863     if (charfunc || ((ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
2864                      && !altreturning))
2865       {
2866         expand_expr_stmt (call);
2867         expand_null_return ();
2868       }
2869     else if (multi && cmplxfunc)
2870       {
2871         expand_expr_stmt (call);
2872         result
2873           = ffecom_1 (INDIRECT_REF,
2874                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
2875                       result);
2876         result = ffecom_modify (NULL_TREE, result,
2877                                 ffecom_2 (COMPONENT_REF, TREE_TYPE (result),
2878                                           multi_retval,
2879                                           ffecom_multi_fields_[bt][kt]));
2880         expand_expr_stmt (result);
2881         expand_null_return ();
2882       }
2883     else if (multi)
2884       {
2885         expand_expr_stmt (call);
2886         result
2887           = ffecom_modify (NULL_TREE, result,
2888                            convert (TREE_TYPE (result),
2889                                     ffecom_2 (COMPONENT_REF,
2890                                               ffecom_tree_type[bt][kt],
2891                                               multi_retval,
2892                                               ffecom_multi_fields_[bt][kt])));
2893         expand_return (result);
2894       }
2895     else if (cmplxfunc)
2896       {
2897         result
2898           = ffecom_1 (INDIRECT_REF,
2899                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
2900                       result);
2901         result = ffecom_modify (NULL_TREE, result, call);
2902         expand_expr_stmt (result);
2903         expand_null_return ();
2904       }
2905     else
2906       {
2907         result = ffecom_modify (NULL_TREE,
2908                                 result,
2909                                 convert (TREE_TYPE (result),
2910                                          call));
2911         expand_return (result);
2912       }
2913   }
2914
2915   ffecom_end_compstmt ();
2916
2917   finish_function (0);
2918
2919   input_location = old_loc;
2920
2921   ffecom_doing_entry_ = FALSE;
2922 }
2923
2924 /* Transform expr into gcc tree with possible destination
2925
2926    Recursive descent on expr while making corresponding tree nodes and
2927    attaching type info and such.  If destination supplied and compatible
2928    with temporary that would be made in certain cases, temporary isn't
2929    made, destination used instead, and dest_used flag set TRUE.  */
2930
2931 static tree
2932 ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
2933               bool *dest_used, bool assignp, bool widenp)
2934 {
2935   tree item;
2936   tree list;
2937   tree args;
2938   ffeinfoBasictype bt;
2939   ffeinfoKindtype kt;
2940   tree t;
2941   tree dt;                      /* decl_tree for an ffesymbol. */
2942   tree tree_type, tree_type_x;
2943   tree left, right;
2944   ffesymbol s;
2945   enum tree_code code;
2946
2947   assert (expr != NULL);
2948
2949   if (dest_used != NULL)
2950     *dest_used = FALSE;
2951
2952   bt = ffeinfo_basictype (ffebld_info (expr));
2953   kt = ffeinfo_kindtype (ffebld_info (expr));
2954   tree_type = ffecom_tree_type[bt][kt];
2955
2956   /* Widen integral arithmetic as desired while preserving signedness.  */
2957   tree_type_x = NULL_TREE;
2958   if (widenp && tree_type
2959       && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
2960       && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
2961     tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
2962
2963   switch (ffebld_op (expr))
2964     {
2965     case FFEBLD_opACCTER:
2966       {
2967         ffebitCount i;
2968         ffebit bits = ffebld_accter_bits (expr);
2969         ffetargetOffset source_offset = 0;
2970         ffetargetOffset dest_offset = ffebld_accter_pad (expr);
2971         tree purpose;
2972
2973         assert (dest_offset == 0
2974                 || (bt == FFEINFO_basictypeCHARACTER
2975                     && kt == FFEINFO_kindtypeCHARACTER1));
2976
2977         list = item = NULL;
2978         for (;;)
2979           {
2980             ffebldConstantUnion cu;
2981             ffebitCount length;
2982             bool value;
2983             ffebldConstantArray ca = ffebld_accter (expr);
2984
2985             ffebit_test (bits, source_offset, &value, &length);
2986             if (length == 0)
2987               break;
2988
2989             if (value)
2990               {
2991                 for (i = 0; i < length; ++i)
2992                   {
2993                     cu = ffebld_constantarray_get (ca, bt, kt,
2994                                                    source_offset + i);
2995
2996                     t = ffecom_constantunion (&cu, bt, kt, tree_type);
2997
2998                     if (i == 0
2999                         && dest_offset != 0)
3000                       purpose = build_int_2 (dest_offset, 0);
3001                     else
3002                       purpose = NULL_TREE;
3003
3004                     if (list == NULL_TREE)
3005                       list = item = build_tree_list (purpose, t);
3006                     else
3007                       {
3008                         TREE_CHAIN (item) = build_tree_list (purpose, t);
3009                         item = TREE_CHAIN (item);
3010                       }
3011                   }
3012               }
3013             source_offset += length;
3014             dest_offset += length;
3015           }
3016       }
3017
3018       item = build_int_2 ((ffebld_accter_size (expr)
3019                            + ffebld_accter_pad (expr)) - 1, 0);
3020       ffebit_kill (ffebld_accter_bits (expr));
3021       TREE_TYPE (item) = ffecom_integer_type_node;
3022       item
3023         = build_array_type
3024           (tree_type,
3025            build_range_type (ffecom_integer_type_node,
3026                              ffecom_integer_zero_node,
3027                              item));
3028       list = build_constructor (item, list);
3029       TREE_CONSTANT (list) = 1;
3030       TREE_STATIC (list) = 1;
3031       return list;
3032
3033     case FFEBLD_opARRTER:
3034       {
3035         ffetargetOffset i;
3036
3037         list = NULL_TREE;
3038         if (ffebld_arrter_pad (expr) == 0)
3039           item = NULL_TREE;
3040         else
3041           {
3042             assert (bt == FFEINFO_basictypeCHARACTER
3043                     && kt == FFEINFO_kindtypeCHARACTER1);
3044
3045             /* Becomes PURPOSE first time through loop.  */
3046             item = build_int_2 (ffebld_arrter_pad (expr), 0);
3047           }
3048
3049         for (i = 0; i < ffebld_arrter_size (expr); ++i)
3050           {
3051             ffebldConstantUnion cu
3052             = ffebld_constantarray_get (ffebld_arrter (expr), bt, kt, i);
3053
3054             t = ffecom_constantunion (&cu, bt, kt, tree_type);
3055
3056             if (list == NULL_TREE)
3057               /* Assume item is PURPOSE first time through loop.  */
3058               list = item = build_tree_list (item, t);
3059             else
3060               {
3061                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
3062                 item = TREE_CHAIN (item);
3063               }
3064           }
3065       }
3066
3067       item = build_int_2 ((ffebld_arrter_size (expr)
3068                           + ffebld_arrter_pad (expr)) - 1, 0);
3069       TREE_TYPE (item) = ffecom_integer_type_node;
3070       item
3071         = build_array_type
3072           (tree_type,
3073            build_range_type (ffecom_integer_type_node,
3074                              ffecom_integer_zero_node,
3075                              item));
3076       list = build_constructor (item, list);
3077       TREE_CONSTANT (list) = 1;
3078       TREE_STATIC (list) = 1;
3079       return list;
3080
3081     case FFEBLD_opCONTER:
3082       assert (ffebld_conter_pad (expr) == 0);
3083       item
3084         = ffecom_constantunion (&ffebld_constant_union (ffebld_conter (expr)),
3085                                 bt, kt, tree_type);
3086       return item;
3087
3088     case FFEBLD_opSYMTER:
3089       if ((ffebld_symter_generic (expr) != FFEINTRIN_genNONE)
3090           || (ffebld_symter_specific (expr) != FFEINTRIN_specNONE))
3091         return ffecom_ptr_to_expr (expr);       /* Same as %REF(intrinsic). */
3092       s = ffebld_symter (expr);
3093       t = ffesymbol_hook (s).decl_tree;
3094
3095       if (assignp)
3096         {                       /* ASSIGN'ed-label expr. */
3097           if (ffe_is_ugly_assign ())
3098             {
3099               /* User explicitly wants ASSIGN'ed variables to be at the same
3100                  memory address as the variables when used in non-ASSIGN
3101                  contexts.  That can make old, arcane, non-standard code
3102                  work, but don't try to do it when a pointer wouldn't fit
3103                  in the normal variable (take other approach, and warn,
3104                  instead).  */
3105
3106               if (t == NULL_TREE)
3107                 {
3108                   s = ffecom_sym_transform_ (s);
3109                   t = ffesymbol_hook (s).decl_tree;
3110                   assert (t != NULL_TREE);
3111                 }
3112
3113               if (t == error_mark_node)
3114                 return t;
3115
3116               if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t)))
3117                   >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
3118                 {
3119                   if (ffesymbol_hook (s).addr)
3120                     t = ffecom_1 (INDIRECT_REF,
3121                                   TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3122                   return t;
3123                 }
3124
3125               if (ffesymbol_hook (s).assign_tree == NULL_TREE)
3126                 {
3127                   /* xgettext:no-c-format */
3128                   ffebad_start_msg ("ASSIGN'ed label cannot fit into `%A' at %0 -- using wider sibling",
3129                                     FFEBAD_severityWARNING);
3130                   ffebad_string (ffesymbol_text (s));
3131                   ffebad_here (0, ffesymbol_where_line (s),
3132                                ffesymbol_where_column (s));
3133                   ffebad_finish ();
3134                 }
3135             }
3136
3137           /* Don't use the normal variable's tree for ASSIGN, though mark
3138              it as in the system header (housekeeping).  Use an explicit,
3139              specially created sibling that is known to be wide enough
3140              to hold pointers to labels.  */
3141
3142           if (t != NULL_TREE
3143               && TREE_CODE (t) == VAR_DECL)
3144             DECL_IN_SYSTEM_HEADER (t) = 1;      /* Don't let -Wunused complain. */
3145
3146           t = ffesymbol_hook (s).assign_tree;
3147           if (t == NULL_TREE)
3148             {
3149               s = ffecom_sym_transform_assign_ (s);
3150               t = ffesymbol_hook (s).assign_tree;
3151               assert (t != NULL_TREE);
3152             }
3153         }
3154       else
3155         {
3156           if (t == NULL_TREE)
3157             {
3158               s = ffecom_sym_transform_ (s);
3159               t = ffesymbol_hook (s).decl_tree;
3160               assert (t != NULL_TREE);
3161             }
3162           if (ffesymbol_hook (s).addr)
3163             t = ffecom_1 (INDIRECT_REF,
3164                           TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3165         }
3166       return t;
3167
3168     case FFEBLD_opARRAYREF:
3169       return ffecom_arrayref_ (NULL_TREE, expr, 0);
3170
3171     case FFEBLD_opUPLUS:
3172       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3173       return ffecom_1 (NOP_EXPR, tree_type, left);
3174
3175     case FFEBLD_opPAREN:
3176       /* ~~~Make sure Fortran rules respected here */
3177       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3178       return ffecom_1 (NOP_EXPR, tree_type, left);
3179
3180     case FFEBLD_opUMINUS:
3181       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3182       if (tree_type_x)
3183         {
3184           tree_type = tree_type_x;
3185           left = convert (tree_type, left);
3186         }
3187       return ffecom_1 (NEGATE_EXPR, tree_type, left);
3188
3189     case FFEBLD_opADD:
3190       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3191       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3192       if (tree_type_x)
3193         {
3194           tree_type = tree_type_x;
3195           left = convert (tree_type, left);
3196           right = convert (tree_type, right);
3197         }
3198       return ffecom_2 (PLUS_EXPR, tree_type, left, right);
3199
3200     case FFEBLD_opSUBTRACT:
3201       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3202       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3203       if (tree_type_x)
3204         {
3205           tree_type = tree_type_x;
3206           left = convert (tree_type, left);
3207           right = convert (tree_type, right);
3208         }
3209       return ffecom_2 (MINUS_EXPR, tree_type, left, right);
3210
3211     case FFEBLD_opMULTIPLY:
3212       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3213       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3214       if (tree_type_x)
3215         {
3216           tree_type = tree_type_x;
3217           left = convert (tree_type, left);
3218           right = convert (tree_type, right);
3219         }
3220       return ffecom_2 (MULT_EXPR, tree_type, left, right);
3221
3222     case FFEBLD_opDIVIDE:
3223       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3224       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3225       if (tree_type_x)
3226         {
3227           tree_type = tree_type_x;
3228           left = convert (tree_type, left);
3229           right = convert (tree_type, right);
3230         }
3231       return ffecom_tree_divide_ (tree_type, left, right,
3232                                   dest_tree, dest, dest_used,
3233                                   ffebld_nonter_hook (expr));
3234
3235     case FFEBLD_opPOWER:
3236       {
3237         ffebld left = ffebld_left (expr);
3238         ffebld right = ffebld_right (expr);
3239         ffecomGfrt code;
3240         ffeinfoKindtype rtkt;
3241         ffeinfoKindtype ltkt;
3242         bool ref = TRUE;
3243
3244         switch (ffeinfo_basictype (ffebld_info (right)))
3245           {
3246
3247           case FFEINFO_basictypeINTEGER:
3248             if (1 || optimize)
3249               {
3250                 item = ffecom_expr_power_integer_ (expr);
3251                 if (item != NULL_TREE)
3252                   return item;
3253               }
3254
3255             rtkt = FFEINFO_kindtypeINTEGER1;
3256             switch (ffeinfo_basictype (ffebld_info (left)))
3257               {
3258               case FFEINFO_basictypeINTEGER:
3259                 if ((ffeinfo_kindtype (ffebld_info (left))
3260                     == FFEINFO_kindtypeINTEGER4)
3261                     || (ffeinfo_kindtype (ffebld_info (right))
3262                         == FFEINFO_kindtypeINTEGER4))
3263                   {
3264                     code = FFECOM_gfrtPOW_QQ;
3265                     ltkt = FFEINFO_kindtypeINTEGER4;
3266                     rtkt = FFEINFO_kindtypeINTEGER4;
3267                   }
3268                 else
3269                   {
3270                     code = FFECOM_gfrtPOW_II;
3271                     ltkt = FFEINFO_kindtypeINTEGER1;
3272                   }
3273                 break;
3274
3275               case FFEINFO_basictypeREAL:
3276                 if (ffeinfo_kindtype (ffebld_info (left))
3277                     == FFEINFO_kindtypeREAL1)
3278                   {
3279                     code = FFECOM_gfrtPOW_RI;
3280                     ltkt = FFEINFO_kindtypeREAL1;
3281                   }
3282                 else
3283                   {
3284                     code = FFECOM_gfrtPOW_DI;
3285                     ltkt = FFEINFO_kindtypeREAL2;
3286                   }
3287                 break;
3288
3289               case FFEINFO_basictypeCOMPLEX:
3290                 if (ffeinfo_kindtype (ffebld_info (left))
3291                     == FFEINFO_kindtypeREAL1)
3292                   {
3293                     code = FFECOM_gfrtPOW_CI;   /* Overlapping result okay. */
3294                     ltkt = FFEINFO_kindtypeREAL1;
3295                   }
3296                 else
3297                   {
3298                     code = FFECOM_gfrtPOW_ZI;   /* Overlapping result okay. */
3299                     ltkt = FFEINFO_kindtypeREAL2;
3300                   }
3301                 break;
3302
3303               default:
3304                 assert ("bad pow_*i" == NULL);
3305                 code = FFECOM_gfrtPOW_CI;       /* Overlapping result okay. */
3306                 ltkt = FFEINFO_kindtypeREAL1;
3307                 break;
3308               }
3309             if (ffeinfo_kindtype (ffebld_info (left)) != ltkt)
3310               left = ffeexpr_convert (left, NULL, NULL,
3311                                       ffeinfo_basictype (ffebld_info (left)),
3312                                       ltkt, 0,
3313                                       FFETARGET_charactersizeNONE,
3314                                       FFEEXPR_contextLET);
3315             if (ffeinfo_kindtype (ffebld_info (right)) != rtkt)
3316               right = ffeexpr_convert (right, NULL, NULL,
3317                                        FFEINFO_basictypeINTEGER,
3318                                        rtkt, 0,
3319                                        FFETARGET_charactersizeNONE,
3320                                        FFEEXPR_contextLET);
3321             break;
3322
3323           case FFEINFO_basictypeREAL:
3324             if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3325               left = ffeexpr_convert (left, NULL, NULL, FFEINFO_basictypeREAL,
3326                                       FFEINFO_kindtypeREALDOUBLE, 0,
3327                                       FFETARGET_charactersizeNONE,
3328                                       FFEEXPR_contextLET);
3329             if (ffeinfo_kindtype (ffebld_info (right))
3330                 == FFEINFO_kindtypeREAL1)
3331               right = ffeexpr_convert (right, NULL, NULL,
3332                                        FFEINFO_basictypeREAL,
3333                                        FFEINFO_kindtypeREALDOUBLE, 0,
3334                                        FFETARGET_charactersizeNONE,
3335                                        FFEEXPR_contextLET);
3336             /* We used to call FFECOM_gfrtPOW_DD here,
3337                which passes arguments by reference.  */
3338             code = FFECOM_gfrtL_POW;
3339             /* Pass arguments by value. */
3340             ref  = FALSE;
3341             break;
3342
3343           case FFEINFO_basictypeCOMPLEX:
3344             if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3345               left = ffeexpr_convert (left, NULL, NULL,
3346                                       FFEINFO_basictypeCOMPLEX,
3347                                       FFEINFO_kindtypeREALDOUBLE, 0,
3348                                       FFETARGET_charactersizeNONE,
3349                                       FFEEXPR_contextLET);
3350             if (ffeinfo_kindtype (ffebld_info (right))
3351                 == FFEINFO_kindtypeREAL1)
3352               right = ffeexpr_convert (right, NULL, NULL,
3353                                        FFEINFO_basictypeCOMPLEX,
3354                                        FFEINFO_kindtypeREALDOUBLE, 0,
3355                                        FFETARGET_charactersizeNONE,
3356                                        FFEEXPR_contextLET);
3357             code = FFECOM_gfrtPOW_ZZ;   /* Overlapping result okay. */
3358             ref = TRUE;                 /* Pass arguments by reference. */
3359             break;
3360
3361           default:
3362             assert ("bad pow_x*" == NULL);
3363             code = FFECOM_gfrtPOW_II;
3364             break;
3365           }
3366         return ffecom_call_binop_ (ffecom_gfrt_tree_ (code),
3367                                    ffecom_gfrt_kindtype (code),
3368                                    (ffe_is_f2c_library ()
3369                                     && ffecom_gfrt_complex_[code]),
3370                                    tree_type, left, right,
3371                                    dest_tree, dest, dest_used,
3372                                    NULL_TREE, FALSE, ref,
3373                                    ffebld_nonter_hook (expr));
3374       }
3375
3376     case FFEBLD_opNOT:
3377       switch (bt)
3378         {
3379         case FFEINFO_basictypeLOGICAL:
3380           item = ffecom_truth_value_invert (ffecom_expr (ffebld_left (expr)));
3381           return convert (tree_type, item);
3382
3383         case FFEINFO_basictypeINTEGER:
3384           return ffecom_1 (BIT_NOT_EXPR, tree_type,
3385                            ffecom_expr (ffebld_left (expr)));
3386
3387         default:
3388           assert ("NOT bad basictype" == NULL);
3389           /* Fall through. */
3390         case FFEINFO_basictypeANY:
3391           return error_mark_node;
3392         }
3393       break;
3394
3395     case FFEBLD_opFUNCREF:
3396       assert (ffeinfo_basictype (ffebld_info (expr))
3397               != FFEINFO_basictypeCHARACTER);
3398       /* Fall through.   */
3399     case FFEBLD_opSUBRREF:
3400       if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
3401           == FFEINFO_whereINTRINSIC)
3402         {                       /* Invocation of an intrinsic. */
3403           item = ffecom_expr_intrinsic_ (expr, dest_tree, dest,
3404                                          dest_used);
3405           return item;
3406         }
3407       s = ffebld_symter (ffebld_left (expr));
3408       dt = ffesymbol_hook (s).decl_tree;
3409       if (dt == NULL_TREE)
3410         {
3411           s = ffecom_sym_transform_ (s);
3412           dt = ffesymbol_hook (s).decl_tree;
3413         }
3414       if (dt == error_mark_node)
3415         return dt;
3416
3417       if (ffesymbol_hook (s).addr)
3418         item = dt;
3419       else
3420         item = ffecom_1_fn (dt);
3421
3422       if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
3423         args = ffecom_list_expr (ffebld_right (expr));
3424       else
3425         args = ffecom_list_ptr_to_expr (ffebld_right (expr));
3426
3427       if (args == error_mark_node)
3428         return error_mark_node;
3429
3430       item = ffecom_call_ (item, kt,
3431                            ffesymbol_is_f2c (s)
3432                            && (bt == FFEINFO_basictypeCOMPLEX)
3433                            && (ffesymbol_where (s)
3434                                != FFEINFO_whereCONSTANT),
3435                            tree_type,
3436                            args,
3437                            dest_tree, dest, dest_used,
3438                            error_mark_node, FALSE,
3439                            ffebld_nonter_hook (expr));
3440       TREE_SIDE_EFFECTS (item) = 1;
3441       return item;
3442
3443     case FFEBLD_opAND:
3444       switch (bt)
3445         {
3446         case FFEINFO_basictypeLOGICAL:
3447           item
3448             = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3449                        ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3450                      ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3451           return convert (tree_type, item);
3452
3453         case FFEINFO_basictypeINTEGER:
3454           return ffecom_2 (BIT_AND_EXPR, tree_type,
3455                            ffecom_expr (ffebld_left (expr)),
3456                            ffecom_expr (ffebld_right (expr)));
3457
3458         default:
3459           assert ("AND bad basictype" == NULL);
3460           /* Fall through. */
3461         case FFEINFO_basictypeANY:
3462           return error_mark_node;
3463         }
3464       break;
3465
3466     case FFEBLD_opOR:
3467       switch (bt)
3468         {
3469         case FFEINFO_basictypeLOGICAL:
3470           item
3471             = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
3472                        ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3473                      ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3474           return convert (tree_type, item);
3475
3476         case FFEINFO_basictypeINTEGER:
3477           return ffecom_2 (BIT_IOR_EXPR, tree_type,
3478                            ffecom_expr (ffebld_left (expr)),
3479                            ffecom_expr (ffebld_right (expr)));
3480
3481         default:
3482           assert ("OR bad basictype" == NULL);
3483           /* Fall through. */
3484         case FFEINFO_basictypeANY:
3485           return error_mark_node;
3486         }
3487       break;
3488
3489     case FFEBLD_opXOR:
3490     case FFEBLD_opNEQV:
3491       switch (bt)
3492         {
3493         case FFEINFO_basictypeLOGICAL:
3494           item
3495             = ffecom_2 (NE_EXPR, integer_type_node,
3496                         ffecom_expr (ffebld_left (expr)),
3497                         ffecom_expr (ffebld_right (expr)));
3498           return convert (tree_type, ffecom_truth_value (item));
3499
3500         case FFEINFO_basictypeINTEGER:
3501           return ffecom_2 (BIT_XOR_EXPR, tree_type,
3502                            ffecom_expr (ffebld_left (expr)),
3503                            ffecom_expr (ffebld_right (expr)));
3504
3505         default:
3506           assert ("XOR/NEQV bad basictype" == NULL);
3507           /* Fall through. */
3508         case FFEINFO_basictypeANY:
3509           return error_mark_node;
3510         }
3511       break;
3512
3513     case FFEBLD_opEQV:
3514       switch (bt)
3515         {
3516         case FFEINFO_basictypeLOGICAL:
3517           item
3518             = ffecom_2 (EQ_EXPR, integer_type_node,
3519                         ffecom_expr (ffebld_left (expr)),
3520                         ffecom_expr (ffebld_right (expr)));
3521           return convert (tree_type, ffecom_truth_value (item));
3522
3523         case FFEINFO_basictypeINTEGER:
3524           return
3525             ffecom_1 (BIT_NOT_EXPR, tree_type,
3526                       ffecom_2 (BIT_XOR_EXPR, tree_type,
3527                                 ffecom_expr (ffebld_left (expr)),
3528                                 ffecom_expr (ffebld_right (expr))));
3529
3530         default:
3531           assert ("EQV bad basictype" == NULL);
3532           /* Fall through. */
3533         case FFEINFO_basictypeANY:
3534           return error_mark_node;
3535         }
3536       break;
3537
3538     case FFEBLD_opCONVERT:
3539       if (ffebld_op (ffebld_left (expr)) == FFEBLD_opANY)
3540         return error_mark_node;
3541
3542       switch (bt)
3543         {
3544         case FFEINFO_basictypeLOGICAL:
3545         case FFEINFO_basictypeINTEGER:
3546         case FFEINFO_basictypeREAL:
3547           return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3548
3549         case FFEINFO_basictypeCOMPLEX:
3550           switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3551             {
3552             case FFEINFO_basictypeINTEGER:
3553             case FFEINFO_basictypeLOGICAL:
3554             case FFEINFO_basictypeREAL:
3555               item = ffecom_expr (ffebld_left (expr));
3556               if (item == error_mark_node)
3557                 return error_mark_node;
3558               /* convert() takes care of converting to the subtype first,
3559                  at least in gcc-2.7.2. */
3560               item = convert (tree_type, item);
3561               return item;
3562
3563             case FFEINFO_basictypeCOMPLEX:
3564               return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3565
3566             default:
3567               assert ("CONVERT COMPLEX bad basictype" == NULL);
3568               /* Fall through. */
3569             case FFEINFO_basictypeANY:
3570               return error_mark_node;
3571             }
3572           break;
3573
3574         default:
3575           assert ("CONVERT bad basictype" == NULL);
3576           /* Fall through. */
3577         case FFEINFO_basictypeANY:
3578           return error_mark_node;
3579         }
3580       break;
3581
3582     case FFEBLD_opLT:
3583       code = LT_EXPR;
3584       goto relational;          /* :::::::::::::::::::: */
3585
3586     case FFEBLD_opLE:
3587       code = LE_EXPR;
3588       goto relational;          /* :::::::::::::::::::: */
3589
3590     case FFEBLD_opEQ:
3591       code = EQ_EXPR;
3592       goto relational;          /* :::::::::::::::::::: */
3593
3594     case FFEBLD_opNE:
3595       code = NE_EXPR;
3596       goto relational;          /* :::::::::::::::::::: */
3597
3598     case FFEBLD_opGT:
3599       code = GT_EXPR;
3600       goto relational;          /* :::::::::::::::::::: */
3601
3602     case FFEBLD_opGE:
3603       code = GE_EXPR;
3604
3605     relational:         /* :::::::::::::::::::: */
3606       switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3607         {
3608         case FFEINFO_basictypeLOGICAL:
3609         case FFEINFO_basictypeINTEGER:
3610         case FFEINFO_basictypeREAL:
3611           item = ffecom_2 (code, integer_type_node,
3612                            ffecom_expr (ffebld_left (expr)),
3613                            ffecom_expr (ffebld_right (expr)));
3614           return convert (tree_type, item);
3615
3616         case FFEINFO_basictypeCOMPLEX:
3617           assert (code == EQ_EXPR || code == NE_EXPR);
3618           {
3619             tree real_type;
3620             tree arg1 = ffecom_expr (ffebld_left (expr));
3621             tree arg2 = ffecom_expr (ffebld_right (expr));
3622
3623             if (arg1 == error_mark_node || arg2 == error_mark_node)
3624               return error_mark_node;
3625
3626             arg1 = ffecom_save_tree (arg1);
3627             arg2 = ffecom_save_tree (arg2);
3628
3629             if (TREE_CODE (TREE_TYPE (arg1)) == COMPLEX_TYPE)
3630               {
3631                 real_type = TREE_TYPE (TREE_TYPE (arg1));
3632                 assert (real_type == TREE_TYPE (TREE_TYPE (arg2)));
3633               }
3634             else
3635               {
3636                 real_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg1)));
3637                 assert (real_type == TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg2))));
3638               }
3639
3640             item
3641               = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3642                           ffecom_2 (EQ_EXPR, integer_type_node,
3643                                   ffecom_1 (REALPART_EXPR, real_type, arg1),
3644                                  ffecom_1 (REALPART_EXPR, real_type, arg2)),
3645                           ffecom_2 (EQ_EXPR, integer_type_node,
3646                                   ffecom_1 (IMAGPART_EXPR, real_type, arg1),
3647                                     ffecom_1 (IMAGPART_EXPR, real_type,
3648                                               arg2)));
3649             if (code == EQ_EXPR)
3650               item = ffecom_truth_value (item);
3651             else
3652               item = ffecom_truth_value_invert (item);
3653             return convert (tree_type, item);
3654           }
3655
3656         case FFEINFO_basictypeCHARACTER:
3657           {
3658             ffebld left = ffebld_left (expr);
3659             ffebld right = ffebld_right (expr);
3660             tree left_tree;
3661             tree right_tree;
3662             tree left_length;
3663             tree right_length;
3664
3665             /* f2c run-time functions do the implicit blank-padding for us,
3666                so we don't usually have to implement blank-padding ourselves.
3667                (The exception is when we pass an argument to a separately
3668                compiled statement function -- if we know the arg is not the
3669                same length as the dummy, we must truncate or extend it.  If
3670                we "inline" statement functions, that necessity goes away as
3671                well.)
3672
3673                Strip off the CONVERT operators that blank-pad.  (Truncation by
3674                CONVERT shouldn't happen here, but it can happen in
3675                assignments.) */
3676
3677             while (ffebld_op (left) == FFEBLD_opCONVERT)
3678               left = ffebld_left (left);
3679             while (ffebld_op (right) == FFEBLD_opCONVERT)
3680               right = ffebld_left (right);
3681
3682             left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
3683             right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
3684
3685             if (left_tree == error_mark_node || left_length == error_mark_node
3686                 || right_tree == error_mark_node
3687                 || right_length == error_mark_node)
3688               return error_mark_node;
3689
3690             if ((ffebld_size_known (left) == 1)
3691                 && (ffebld_size_known (right) == 1))
3692               {
3693                 left_tree
3694                   = ffecom_1 (INDIRECT_REF,
3695                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3696                               left_tree);
3697                 right_tree
3698                   = ffecom_1 (INDIRECT_REF,
3699                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3700                               right_tree);
3701
3702                 item
3703                   = ffecom_2 (code, integer_type_node,
3704                               ffecom_2 (ARRAY_REF,
3705                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3706                                         left_tree,
3707                                         integer_one_node),
3708                               ffecom_2 (ARRAY_REF,
3709                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3710                                         right_tree,
3711                                         integer_one_node));
3712               }
3713             else
3714               {
3715                 item = build_tree_list (NULL_TREE, left_tree);
3716                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, right_tree);
3717                 TREE_CHAIN (TREE_CHAIN (item)) = build_tree_list (NULL_TREE,
3718                                                                left_length);
3719                 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
3720                   = build_tree_list (NULL_TREE, right_length);
3721                 item = ffecom_call_gfrt (FFECOM_gfrtCMP, item, NULL_TREE);
3722                 item = ffecom_2 (code, integer_type_node,
3723                                  item,
3724                                  convert (TREE_TYPE (item),
3725                                           integer_zero_node));
3726               }
3727             item = convert (tree_type, item);
3728           }
3729
3730           return item;
3731
3732         default:
3733           assert ("relational bad basictype" == NULL);
3734           /* Fall through. */
3735         case FFEINFO_basictypeANY:
3736           return error_mark_node;
3737         }
3738       break;
3739
3740     case FFEBLD_opPERCENT_LOC:
3741       item = ffecom_arg_ptr_to_expr (ffebld_left (expr), &list);
3742       return convert (tree_type, item);
3743
3744     case FFEBLD_opPERCENT_VAL:
3745       item = ffecom_arg_expr (ffebld_left (expr), &list);
3746       return convert (tree_type, item);
3747
3748     case FFEBLD_opITEM:
3749     case FFEBLD_opSTAR:
3750     case FFEBLD_opBOUNDS:
3751     case FFEBLD_opREPEAT:
3752     case FFEBLD_opLABTER:
3753     case FFEBLD_opLABTOK:
3754     case FFEBLD_opIMPDO:
3755     case FFEBLD_opCONCATENATE:
3756     case FFEBLD_opSUBSTR:
3757     default:
3758       assert ("bad op" == NULL);
3759       /* Fall through. */
3760     case FFEBLD_opANY:
3761       return error_mark_node;
3762     }
3763
3764 #if 1
3765   assert ("didn't think anything got here anymore!!" == NULL);
3766 #else
3767   switch (ffebld_arity (expr))
3768     {
3769     case 2:
3770       TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3771       TREE_OPERAND (item, 1) = ffecom_expr (ffebld_right (expr));
3772       if (TREE_OPERAND (item, 0) == error_mark_node
3773           || TREE_OPERAND (item, 1) == error_mark_node)
3774         return error_mark_node;
3775       break;
3776
3777     case 1:
3778       TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3779       if (TREE_OPERAND (item, 0) == error_mark_node)
3780         return error_mark_node;
3781       break;
3782
3783     default:
3784       break;
3785     }
3786
3787   return fold (item);
3788 #endif
3789 }
3790
3791 /* Returns the tree that does the intrinsic invocation.
3792
3793    Note: this function applies only to intrinsics returning
3794    CHARACTER*1 or non-CHARACTER results, and to intrinsic
3795    subroutines.  */
3796
3797 static tree
3798 ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
3799                         ffebld dest, bool *dest_used)
3800 {
3801   tree expr_tree;
3802   tree saved_expr1;             /* For those who need it. */
3803   tree saved_expr2;             /* For those who need it. */
3804   ffeinfoBasictype bt;
3805   ffeinfoKindtype kt;
3806   tree tree_type;
3807   tree arg1_type;
3808   tree real_type;               /* REAL type corresponding to COMPLEX. */
3809   tree tempvar;
3810   ffebld list = ffebld_right (expr);    /* List of (some) args. */
3811   ffebld arg1;                  /* For handy reference. */
3812   ffebld arg2;
3813   ffebld arg3;
3814   ffeintrinImp codegen_imp;
3815   ffecomGfrt gfrt;
3816
3817   assert (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER);
3818
3819   if (dest_used != NULL)
3820     *dest_used = FALSE;
3821
3822   bt = ffeinfo_basictype (ffebld_info (expr));
3823   kt = ffeinfo_kindtype (ffebld_info (expr));
3824   tree_type = ffecom_tree_type[bt][kt];
3825
3826   if (list != NULL)
3827     {
3828       arg1 = ffebld_head (list);
3829       if (arg1 != NULL && ffebld_op (arg1) == FFEBLD_opANY)
3830         return error_mark_node;
3831       if ((list = ffebld_trail (list)) != NULL)
3832         {
3833           arg2 = ffebld_head (list);
3834           if (arg2 != NULL && ffebld_op (arg2) == FFEBLD_opANY)
3835             return error_mark_node;
3836           if ((list = ffebld_trail (list)) != NULL)
3837             {
3838               arg3 = ffebld_head (list);
3839               if (arg3 != NULL && ffebld_op (arg3) == FFEBLD_opANY)
3840                 return error_mark_node;
3841             }
3842           else
3843             arg3 = NULL;
3844         }
3845       else
3846         arg2 = arg3 = NULL;
3847     }
3848   else
3849     arg1 = arg2 = arg3 = NULL;
3850
3851   /* <list> ends up at the opITEM of the 3rd arg, or NULL if there are < 3
3852      args.  This is used by the MAX/MIN expansions. */
3853
3854   if (arg1 != NULL)
3855     arg1_type = ffecom_tree_type
3856       [ffeinfo_basictype (ffebld_info (arg1))]
3857       [ffeinfo_kindtype (ffebld_info (arg1))];
3858   else
3859     arg1_type = NULL_TREE;      /* Really not needed, but might catch bugs
3860                                    here. */
3861
3862   /* There are several ways for each of the cases in the following switch
3863      statements to exit (from simplest to use to most complicated):
3864
3865      break;  (when expr_tree == NULL)
3866
3867      A standard call is made to the specific intrinsic just as if it had been
3868      passed in as a dummy procedure and called as any old procedure.  This
3869      method can produce slower code but in some cases it's the easiest way for
3870      now.  However, if a (presumably faster) direct call is available,
3871      that is used, so this is the easiest way in many more cases now.
3872
3873      gfrt = FFECOM_gfrtWHATEVER;
3874      break;
3875
3876      gfrt contains the gfrt index of a library function to call, passing the
3877      argument(s) by value rather than by reference.  Used when a more
3878      careful choice of library function is needed than that provided
3879      by the vanilla `break;'.
3880
3881      return expr_tree;
3882
3883      The expr_tree has been completely set up and is ready to be returned
3884      as is.  No further actions are taken.  Use this when the tree is not
3885      in the simple form for one of the arity_n labels.   */
3886
3887   /* For info on how the switch statement cases were written, see the files
3888      enclosed in comments below the switch statement. */
3889
3890   codegen_imp = ffebld_symter_implementation (ffebld_left (expr));
3891   gfrt = ffeintrin_gfrt_direct (codegen_imp);
3892   if (gfrt == FFECOM_gfrt)
3893     gfrt = ffeintrin_gfrt_indirect (codegen_imp);
3894
3895   switch (codegen_imp)
3896     {
3897     case FFEINTRIN_impABS:
3898     case FFEINTRIN_impCABS:
3899     case FFEINTRIN_impCDABS:
3900     case FFEINTRIN_impDABS:
3901     case FFEINTRIN_impIABS:
3902       if (ffeinfo_basictype (ffebld_info (arg1))
3903           == FFEINFO_basictypeCOMPLEX)
3904         {
3905           if (kt == FFEINFO_kindtypeREAL1)
3906             gfrt = FFECOM_gfrtCABS;
3907           else if (kt == FFEINFO_kindtypeREAL2)
3908             gfrt = FFECOM_gfrtCDABS;
3909           break;
3910         }
3911       return ffecom_1 (ABS_EXPR, tree_type,
3912                        convert (tree_type, ffecom_expr (arg1)));
3913
3914     case FFEINTRIN_impACOS:
3915     case FFEINTRIN_impDACOS:
3916       break;
3917
3918     case FFEINTRIN_impAIMAG:
3919     case FFEINTRIN_impDIMAG:
3920     case FFEINTRIN_impIMAGPART:
3921       if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
3922         arg1_type = TREE_TYPE (arg1_type);
3923       else
3924         arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
3925
3926       return
3927         convert (tree_type,
3928                  ffecom_1 (IMAGPART_EXPR, arg1_type,
3929                            ffecom_expr (arg1)));
3930
3931     case FFEINTRIN_impAINT:
3932     case FFEINTRIN_impDINT:
3933 #if 0
3934       /* ~~Someday implement FIX_TRUNC_EXPR yielding same type as arg.  */
3935       return ffecom_1 (FIX_TRUNC_EXPR, tree_type, ffecom_expr (arg1));
3936 #else /* in the meantime, must use floor to avoid range problems with ints */
3937       /* r__1 = r1 >= 0 ? floor(r1) : -floor(-r1); */
3938       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
3939       return
3940         convert (tree_type,
3941                  ffecom_3 (COND_EXPR, double_type_node,
3942                            ffecom_truth_value
3943                            (ffecom_2 (GE_EXPR, integer_type_node,
3944                                       saved_expr1,
3945                                       convert (arg1_type,
3946                                                ffecom_float_zero_))),
3947                            ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
3948                                              build_tree_list (NULL_TREE,
3949                                                   convert (double_type_node,
3950                                                            saved_expr1)),
3951                                              NULL_TREE),
3952                            ffecom_1 (NEGATE_EXPR, double_type_node,
3953                                      ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
3954                                                  build_tree_list (NULL_TREE,
3955                                                   convert (double_type_node,
3956                                                       ffecom_1 (NEGATE_EXPR,
3957                                                                 arg1_type,
3958                                                                saved_expr1))),
3959                                                        NULL_TREE)
3960                                      ))
3961                  );
3962 #endif
3963
3964     case FFEINTRIN_impANINT:
3965     case FFEINTRIN_impDNINT:
3966 #if 0                           /* This way of doing it won't handle real
3967                                    numbers of large magnitudes. */
3968       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
3969       expr_tree = convert (tree_type,
3970                            convert (integer_type_node,
3971                                     ffecom_3 (COND_EXPR, tree_type,
3972                                               ffecom_truth_value
3973                                               (ffecom_2 (GE_EXPR,
3974                                                          integer_type_node,
3975                                                          saved_expr1,
3976                                                        ffecom_float_zero_)),
3977                                               ffecom_2 (PLUS_EXPR,
3978                                                         tree_type,
3979                                                         saved_expr1,
3980                                                         ffecom_float_half_),
3981                                               ffecom_2 (MINUS_EXPR,
3982                                                         tree_type,
3983                                                         saved_expr1,
3984                                                      ffecom_float_half_))));
3985       return expr_tree;
3986 #else /* So we instead call floor. */
3987       /* r__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1) */
3988       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
3989       return
3990         convert (tree_type,
3991                  ffecom_3 (COND_EXPR, double_type_node,
3992                            ffecom_truth_value
3993                            (ffecom_2 (GE_EXPR, integer_type_node,
3994                                       saved_expr1,
3995                                       convert (arg1_type,
3996                                                ffecom_float_zero_))),
3997                            ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
3998                                              build_tree_list (NULL_TREE,
3999                                                   convert (double_type_node,
4000                                                            ffecom_2 (PLUS_EXPR,
4001                                                                      arg1_type,
4002                                                                      saved_expr1,
4003                                                                      convert (arg1_type,
4004                                                                               ffecom_float_half_)))),
4005                                              NULL_TREE),
4006                            ffecom_1 (NEGATE_EXPR, double_type_node,
4007                                      ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4008                                                        build_tree_list (NULL_TREE,
4009                                                                         convert (double_type_node,
4010                                                                                  ffecom_2 (MINUS_EXPR,
4011                                                                                            arg1_type,
4012                                                                                            convert (arg1_type,
4013                                                                                                     ffecom_float_half_),
4014                                                                                            saved_expr1))),
4015                                                        NULL_TREE))
4016                            )
4017                  );
4018 #endif
4019
4020     case FFEINTRIN_impASIN:
4021     case FFEINTRIN_impDASIN:
4022     case FFEINTRIN_impATAN:
4023     case FFEINTRIN_impDATAN:
4024     case FFEINTRIN_impATAN2:
4025     case FFEINTRIN_impDATAN2:
4026       break;
4027
4028     case FFEINTRIN_impCHAR:
4029     case FFEINTRIN_impACHAR:
4030       tempvar = ffebld_nonter_hook (expr);
4031       assert (tempvar);
4032       {
4033         tree tmv = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (tempvar)));
4034
4035         expr_tree = ffecom_modify (tmv,
4036                                    ffecom_2 (ARRAY_REF, tmv, tempvar,
4037                                              integer_one_node),
4038                                    convert (tmv, ffecom_expr (arg1)));
4039       }
4040       expr_tree = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar),
4041                             expr_tree,
4042                             tempvar);
4043       expr_tree = ffecom_1 (ADDR_EXPR,
4044                             build_pointer_type (TREE_TYPE (expr_tree)),
4045                             expr_tree);
4046       return expr_tree;
4047
4048     case FFEINTRIN_impCMPLX:
4049     case FFEINTRIN_impDCMPLX:
4050       if (arg2 == NULL)
4051         return
4052           convert (tree_type, ffecom_expr (arg1));
4053
4054       real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4055       return
4056         ffecom_2 (COMPLEX_EXPR, tree_type,
4057                   convert (real_type, ffecom_expr (arg1)),
4058                   convert (real_type,
4059                            ffecom_expr (arg2)));
4060
4061     case FFEINTRIN_impCOMPLEX:
4062       return
4063         ffecom_2 (COMPLEX_EXPR, tree_type,
4064                   ffecom_expr (arg1),
4065                   ffecom_expr (arg2));
4066
4067     case FFEINTRIN_impCONJG:
4068     case FFEINTRIN_impDCONJG:
4069       {
4070         tree arg1_tree;
4071
4072         real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4073         arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4074         return
4075           ffecom_2 (COMPLEX_EXPR, tree_type,
4076                     ffecom_1 (REALPART_EXPR, real_type, arg1_tree),
4077                     ffecom_1 (NEGATE_EXPR, real_type,
4078                               ffecom_1 (IMAGPART_EXPR, real_type, arg1_tree)));
4079       }
4080
4081     case FFEINTRIN_impCOS:
4082     case FFEINTRIN_impCCOS:
4083     case FFEINTRIN_impCDCOS:
4084     case FFEINTRIN_impDCOS:
4085       if (bt == FFEINFO_basictypeCOMPLEX)
4086         {
4087           if (kt == FFEINFO_kindtypeREAL1)
4088             gfrt = FFECOM_gfrtCCOS;     /* Overlapping result okay. */
4089           else if (kt == FFEINFO_kindtypeREAL2)
4090             gfrt = FFECOM_gfrtCDCOS;    /* Overlapping result okay. */
4091         }
4092       break;
4093
4094     case FFEINTRIN_impCOSH:
4095     case FFEINTRIN_impDCOSH:
4096       break;
4097
4098     case FFEINTRIN_impDBLE:
4099     case FFEINTRIN_impDFLOAT:
4100     case FFEINTRIN_impDREAL:
4101     case FFEINTRIN_impFLOAT:
4102     case FFEINTRIN_impIDINT:
4103     case FFEINTRIN_impIFIX:
4104     case FFEINTRIN_impINT2:
4105     case FFEINTRIN_impINT8:
4106     case FFEINTRIN_impINT:
4107     case FFEINTRIN_impLONG:
4108     case FFEINTRIN_impREAL:
4109     case FFEINTRIN_impSHORT:
4110     case FFEINTRIN_impSNGL:
4111       return convert (tree_type, ffecom_expr (arg1));
4112
4113     case FFEINTRIN_impDIM:
4114     case FFEINTRIN_impDDIM:
4115     case FFEINTRIN_impIDIM:
4116       saved_expr1 = ffecom_save_tree (convert (tree_type,
4117                                                ffecom_expr (arg1)));
4118       saved_expr2 = ffecom_save_tree (convert (tree_type,
4119                                                ffecom_expr (arg2)));
4120       return
4121         ffecom_3 (COND_EXPR, tree_type,
4122                   ffecom_truth_value
4123                   (ffecom_2 (GT_EXPR, integer_type_node,
4124                              saved_expr1,
4125                              saved_expr2)),
4126                   ffecom_2 (MINUS_EXPR, tree_type,
4127                             saved_expr1,
4128                             saved_expr2),
4129                   convert (tree_type, ffecom_float_zero_));
4130
4131     case FFEINTRIN_impDPROD:
4132       return
4133         ffecom_2 (MULT_EXPR, tree_type,
4134                   convert (tree_type, ffecom_expr (arg1)),
4135                   convert (tree_type, ffecom_expr (arg2)));
4136
4137     case FFEINTRIN_impEXP:
4138     case FFEINTRIN_impCDEXP:
4139     case FFEINTRIN_impCEXP:
4140     case FFEINTRIN_impDEXP:
4141       if (bt == FFEINFO_basictypeCOMPLEX)
4142         {
4143           if (kt == FFEINFO_kindtypeREAL1)
4144             gfrt = FFECOM_gfrtCEXP;     /* Overlapping result okay. */
4145           else if (kt == FFEINFO_kindtypeREAL2)
4146             gfrt = FFECOM_gfrtCDEXP;    /* Overlapping result okay. */
4147         }
4148       break;
4149
4150     case FFEINTRIN_impICHAR:
4151     case FFEINTRIN_impIACHAR:
4152 #if 0                           /* The simple approach. */
4153       ffecom_char_args_ (&expr_tree, &saved_expr1 /* Ignored */ , arg1);
4154       expr_tree
4155         = ffecom_1 (INDIRECT_REF,
4156                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4157                     expr_tree);
4158       expr_tree
4159         = ffecom_2 (ARRAY_REF,
4160                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4161                     expr_tree,
4162                     integer_one_node);
4163       return convert (tree_type, expr_tree);
4164 #else /* The more interesting (and more optimal) approach. */
4165       expr_tree = ffecom_intrinsic_ichar_ (tree_type, arg1, &saved_expr1);
4166       expr_tree = ffecom_3 (COND_EXPR, tree_type,
4167                             saved_expr1,
4168                             expr_tree,
4169                             convert (tree_type, integer_zero_node));
4170       return expr_tree;
4171 #endif
4172
4173     case FFEINTRIN_impINDEX:
4174       break;
4175
4176     case FFEINTRIN_impLEN:
4177 #if 0
4178       break;                                    /* The simple approach. */
4179 #else
4180       return ffecom_intrinsic_len_ (arg1);      /* The more optimal approach. */
4181 #endif
4182
4183     case FFEINTRIN_impLGE:
4184     case FFEINTRIN_impLGT:
4185     case FFEINTRIN_impLLE:
4186     case FFEINTRIN_impLLT:
4187       break;
4188
4189     case FFEINTRIN_impLOG:
4190     case FFEINTRIN_impALOG:
4191     case FFEINTRIN_impCDLOG:
4192     case FFEINTRIN_impCLOG:
4193     case FFEINTRIN_impDLOG:
4194       if (bt == FFEINFO_basictypeCOMPLEX)
4195         {
4196           if (kt == FFEINFO_kindtypeREAL1)
4197             gfrt = FFECOM_gfrtCLOG;     /* Overlapping result okay. */
4198           else if (kt == FFEINFO_kindtypeREAL2)
4199             gfrt = FFECOM_gfrtCDLOG;    /* Overlapping result okay. */
4200         }
4201       break;
4202
4203     case FFEINTRIN_impLOG10:
4204     case FFEINTRIN_impALOG10:
4205     case FFEINTRIN_impDLOG10:
4206       if (gfrt != FFECOM_gfrt)
4207         break;  /* Already picked one, stick with it. */
4208
4209       if (kt == FFEINFO_kindtypeREAL1)
4210         /* We used to call FFECOM_gfrtALOG10 here.  */
4211         gfrt = FFECOM_gfrtL_LOG10;
4212       else if (kt == FFEINFO_kindtypeREAL2)
4213         /* We used to call FFECOM_gfrtDLOG10 here.  */
4214         gfrt = FFECOM_gfrtL_LOG10;
4215       break;
4216
4217     case FFEINTRIN_impMAX:
4218     case FFEINTRIN_impAMAX0:
4219     case FFEINTRIN_impAMAX1:
4220     case FFEINTRIN_impDMAX1:
4221     case FFEINTRIN_impMAX0:
4222     case FFEINTRIN_impMAX1:
4223       if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4224         arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4225       else
4226         arg1_type = tree_type;
4227       expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4228                             convert (arg1_type, ffecom_expr (arg1)),
4229                             convert (arg1_type, ffecom_expr (arg2)));
4230       for (; list != NULL; list = ffebld_trail (list))
4231         {
4232           if ((ffebld_head (list) == NULL)
4233               || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4234             continue;
4235           expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4236                                 expr_tree,
4237                                 convert (arg1_type,
4238                                          ffecom_expr (ffebld_head (list))));
4239         }
4240       return convert (tree_type, expr_tree);
4241
4242     case FFEINTRIN_impMIN:
4243     case FFEINTRIN_impAMIN0:
4244     case FFEINTRIN_impAMIN1:
4245     case FFEINTRIN_impDMIN1:
4246     case FFEINTRIN_impMIN0:
4247     case FFEINTRIN_impMIN1:
4248       if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4249         arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4250       else
4251         arg1_type = tree_type;
4252       expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4253                             convert (arg1_type, ffecom_expr (arg1)),
4254                             convert (arg1_type, ffecom_expr (arg2)));
4255       for (; list != NULL; list = ffebld_trail (list))
4256         {
4257           if ((ffebld_head (list) == NULL)
4258               || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4259             continue;
4260           expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4261                                 expr_tree,
4262                                 convert (arg1_type,
4263                                          ffecom_expr (ffebld_head (list))));
4264         }
4265       return convert (tree_type, expr_tree);
4266
4267     case FFEINTRIN_impMOD:
4268     case FFEINTRIN_impAMOD:
4269     case FFEINTRIN_impDMOD:
4270       if (bt != FFEINFO_basictypeREAL)
4271         return ffecom_2 (TRUNC_MOD_EXPR, tree_type,
4272                          convert (tree_type, ffecom_expr (arg1)),
4273                          convert (tree_type, ffecom_expr (arg2)));
4274
4275       if (kt == FFEINFO_kindtypeREAL1)
4276         /* We used to call FFECOM_gfrtAMOD here.  */
4277         gfrt = FFECOM_gfrtL_FMOD;
4278       else if (kt == FFEINFO_kindtypeREAL2)
4279         /* We used to call FFECOM_gfrtDMOD here.  */
4280         gfrt = FFECOM_gfrtL_FMOD;
4281       break;
4282
4283     case FFEINTRIN_impNINT:
4284     case FFEINTRIN_impIDNINT:
4285 #if 0
4286       /* ~~Ideally FIX_ROUND_EXPR would be implemented, but it ain't yet.  */
4287       return ffecom_1 (FIX_ROUND_EXPR, tree_type, ffecom_expr (arg1));
4288 #else
4289       /* i__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1); */
4290       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4291       return
4292         convert (ffecom_integer_type_node,
4293                  ffecom_3 (COND_EXPR, arg1_type,
4294                            ffecom_truth_value
4295                            (ffecom_2 (GE_EXPR, integer_type_node,
4296                                       saved_expr1,
4297                                       convert (arg1_type,
4298                                                ffecom_float_zero_))),
4299                            ffecom_2 (PLUS_EXPR, arg1_type,
4300                                      saved_expr1,
4301                                      convert (arg1_type,
4302                                               ffecom_float_half_)),
4303                            ffecom_2 (MINUS_EXPR, arg1_type,
4304                                      saved_expr1,
4305                                      convert (arg1_type,
4306                                               ffecom_float_half_))));
4307 #endif
4308
4309     case FFEINTRIN_impSIGN:
4310     case FFEINTRIN_impDSIGN:
4311     case FFEINTRIN_impISIGN:
4312       {
4313         tree arg2_tree = ffecom_expr (arg2);
4314
4315         saved_expr1
4316           = ffecom_save_tree
4317           (ffecom_1 (ABS_EXPR, tree_type,
4318                      convert (tree_type,
4319                               ffecom_expr (arg1))));
4320         expr_tree
4321           = ffecom_3 (COND_EXPR, tree_type,
4322                       ffecom_truth_value
4323                       (ffecom_2 (GE_EXPR, integer_type_node,
4324                                  arg2_tree,
4325                                  convert (TREE_TYPE (arg2_tree),
4326                                           integer_zero_node))),
4327                       saved_expr1,
4328                       ffecom_1 (NEGATE_EXPR, tree_type, saved_expr1));
4329         /* Make sure SAVE_EXPRs get referenced early enough. */
4330         expr_tree
4331           = ffecom_2 (COMPOUND_EXPR, tree_type,
4332                       convert (void_type_node, saved_expr1),
4333                       expr_tree);
4334       }
4335       return expr_tree;
4336
4337     case FFEINTRIN_impSIN:
4338     case FFEINTRIN_impCDSIN:
4339     case FFEINTRIN_impCSIN:
4340     case FFEINTRIN_impDSIN:
4341       if (bt == FFEINFO_basictypeCOMPLEX)
4342         {
4343           if (kt == FFEINFO_kindtypeREAL1)
4344             gfrt = FFECOM_gfrtCSIN;     /* Overlapping result okay. */
4345           else if (kt == FFEINFO_kindtypeREAL2)
4346             gfrt = FFECOM_gfrtCDSIN;    /* Overlapping result okay. */
4347         }
4348       break;
4349
4350     case FFEINTRIN_impSINH:
4351     case FFEINTRIN_impDSINH:
4352       break;
4353
4354     case FFEINTRIN_impSQRT:
4355     case FFEINTRIN_impCDSQRT:
4356     case FFEINTRIN_impCSQRT:
4357     case FFEINTRIN_impDSQRT:
4358       if (bt == FFEINFO_basictypeCOMPLEX)
4359         {
4360           if (kt == FFEINFO_kindtypeREAL1)
4361             gfrt = FFECOM_gfrtCSQRT;    /* Overlapping result okay. */
4362           else if (kt == FFEINFO_kindtypeREAL2)
4363             gfrt = FFECOM_gfrtCDSQRT;   /* Overlapping result okay. */
4364         }
4365       break;
4366
4367     case FFEINTRIN_impTAN:
4368     case FFEINTRIN_impDTAN:
4369     case FFEINTRIN_impTANH:
4370     case FFEINTRIN_impDTANH:
4371       break;
4372
4373     case FFEINTRIN_impREALPART:
4374       if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
4375         arg1_type = TREE_TYPE (arg1_type);
4376       else
4377         arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
4378
4379       return
4380         convert (tree_type,
4381                  ffecom_1 (REALPART_EXPR, arg1_type,
4382                            ffecom_expr (arg1)));
4383
4384     case FFEINTRIN_impIAND:
4385     case FFEINTRIN_impAND:
4386       return ffecom_2 (BIT_AND_EXPR, tree_type,
4387                        convert (tree_type,
4388                                 ffecom_expr (arg1)),
4389                        convert (tree_type,
4390                                 ffecom_expr (arg2)));
4391
4392     case FFEINTRIN_impIOR:
4393     case FFEINTRIN_impOR:
4394       return ffecom_2 (BIT_IOR_EXPR, tree_type,
4395                        convert (tree_type,
4396                                 ffecom_expr (arg1)),
4397                        convert (tree_type,
4398                                 ffecom_expr (arg2)));
4399
4400     case FFEINTRIN_impIEOR:
4401     case FFEINTRIN_impXOR:
4402       return ffecom_2 (BIT_XOR_EXPR, tree_type,
4403                        convert (tree_type,
4404                                 ffecom_expr (arg1)),
4405                        convert (tree_type,
4406                                 ffecom_expr (arg2)));
4407
4408     case FFEINTRIN_impLSHIFT:
4409       return ffecom_2 (LSHIFT_EXPR, tree_type,
4410                        ffecom_expr (arg1),
4411                        convert (integer_type_node,
4412                                 ffecom_expr (arg2)));
4413
4414     case FFEINTRIN_impRSHIFT:
4415       return ffecom_2 (RSHIFT_EXPR, tree_type,
4416                        ffecom_expr (arg1),
4417                        convert (integer_type_node,
4418                                 ffecom_expr (arg2)));
4419
4420     case FFEINTRIN_impNOT:
4421       return ffecom_1 (BIT_NOT_EXPR, tree_type, ffecom_expr (arg1));
4422
4423     case FFEINTRIN_impBIT_SIZE:
4424       return convert (tree_type, TYPE_SIZE (arg1_type));
4425
4426     case FFEINTRIN_impBTEST:
4427       {
4428         ffetargetLogical1 target_true;
4429         ffetargetLogical1 target_false;
4430         tree true_tree;
4431         tree false_tree;
4432
4433         ffetarget_logical1 (&target_true, TRUE);
4434         ffetarget_logical1 (&target_false, FALSE);
4435         if (target_true == 1)
4436           true_tree = convert (tree_type, integer_one_node);
4437         else
4438           true_tree = convert (tree_type, build_int_2 (target_true, 0));
4439         if (target_false == 0)
4440           false_tree = convert (tree_type, integer_zero_node);
4441         else
4442           false_tree = convert (tree_type, build_int_2 (target_false, 0));
4443
4444         return
4445           ffecom_3 (COND_EXPR, tree_type,
4446                     ffecom_truth_value
4447                     (ffecom_2 (EQ_EXPR, integer_type_node,
4448                                ffecom_2 (BIT_AND_EXPR, arg1_type,
4449                                          ffecom_expr (arg1),
4450                                          ffecom_2 (LSHIFT_EXPR, arg1_type,
4451                                                    convert (arg1_type,
4452                                                           integer_one_node),
4453                                                    convert (integer_type_node,
4454                                                             ffecom_expr (arg2)))),
4455                                convert (arg1_type,
4456                                         integer_zero_node))),
4457                     false_tree,
4458                     true_tree);
4459       }
4460
4461     case FFEINTRIN_impIBCLR:
4462       return
4463         ffecom_2 (BIT_AND_EXPR, tree_type,
4464                   ffecom_expr (arg1),
4465                   ffecom_1 (BIT_NOT_EXPR, tree_type,
4466                             ffecom_2 (LSHIFT_EXPR, tree_type,
4467                                       convert (tree_type,
4468                                                integer_one_node),
4469                                       convert (integer_type_node,
4470                                                ffecom_expr (arg2)))));
4471
4472     case FFEINTRIN_impIBITS:
4473       {
4474         tree arg3_tree = ffecom_save_tree (convert (integer_type_node,
4475                                                     ffecom_expr (arg3)));
4476         tree uns_type
4477         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4478
4479         expr_tree
4480           = ffecom_2 (BIT_AND_EXPR, tree_type,
4481                       ffecom_2 (RSHIFT_EXPR, tree_type,
4482                                 ffecom_expr (arg1),
4483                                 convert (integer_type_node,
4484                                          ffecom_expr (arg2))),
4485                       convert (tree_type,
4486                                ffecom_2 (RSHIFT_EXPR, uns_type,
4487                                          ffecom_1 (BIT_NOT_EXPR,
4488                                                    uns_type,
4489                                                    convert (uns_type,
4490                                                         integer_zero_node)),
4491                                          ffecom_2 (MINUS_EXPR,
4492                                                    integer_type_node,
4493                                                    TYPE_SIZE (uns_type),
4494                                                    arg3_tree))));
4495         /* Fix up, because the RSHIFT_EXPR above can't shift over TYPE_SIZE.  */
4496         expr_tree
4497           = ffecom_3 (COND_EXPR, tree_type,
4498                       ffecom_truth_value
4499                       (ffecom_2 (NE_EXPR, integer_type_node,
4500                                  arg3_tree,
4501                                  integer_zero_node)),
4502                       expr_tree,
4503                       convert (tree_type, integer_zero_node));
4504       }
4505       return expr_tree;
4506
4507     case FFEINTRIN_impIBSET:
4508       return
4509         ffecom_2 (BIT_IOR_EXPR, tree_type,
4510                   ffecom_expr (arg1),
4511                   ffecom_2 (LSHIFT_EXPR, tree_type,
4512                             convert (tree_type, integer_one_node),
4513                             convert (integer_type_node,
4514                                      ffecom_expr (arg2))));
4515
4516     case FFEINTRIN_impISHFT:
4517       {
4518         tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4519         tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4520                                                     ffecom_expr (arg2)));
4521         tree uns_type
4522         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4523
4524         expr_tree
4525           = ffecom_3 (COND_EXPR, tree_type,
4526                       ffecom_truth_value
4527                       (ffecom_2 (GE_EXPR, integer_type_node,
4528                                  arg2_tree,
4529                                  integer_zero_node)),
4530                       ffecom_2 (LSHIFT_EXPR, tree_type,
4531                                 arg1_tree,
4532                                 arg2_tree),
4533                       convert (tree_type,
4534                                ffecom_2 (RSHIFT_EXPR, uns_type,
4535                                          convert (uns_type, arg1_tree),
4536                                          ffecom_1 (NEGATE_EXPR,
4537                                                    integer_type_node,
4538                                                    arg2_tree))));
4539         /* Fix up, because {L|R}SHIFT_EXPR don't go over TYPE_SIZE bounds.  */
4540         expr_tree
4541           = ffecom_3 (COND_EXPR, tree_type,
4542                       ffecom_truth_value
4543                       (ffecom_2 (NE_EXPR, integer_type_node,
4544                                  ffecom_1 (ABS_EXPR,
4545                                            integer_type_node,
4546                                            arg2_tree),
4547                                  TYPE_SIZE (uns_type))),
4548                       expr_tree,
4549                       convert (tree_type, integer_zero_node));
4550         /* Make sure SAVE_EXPRs get referenced early enough. */
4551         expr_tree
4552           = ffecom_2 (COMPOUND_EXPR, tree_type,
4553                       convert (void_type_node, arg1_tree),
4554                       ffecom_2 (COMPOUND_EXPR, tree_type,
4555                                 convert (void_type_node, arg2_tree),
4556                                 expr_tree));
4557       }
4558       return expr_tree;
4559
4560     case FFEINTRIN_impISHFTC:
4561       {
4562         tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4563         tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4564                                                     ffecom_expr (arg2)));
4565         tree arg3_tree = (arg3 == NULL) ? TYPE_SIZE (tree_type)
4566         : ffecom_save_tree (convert (integer_type_node, ffecom_expr (arg3)));
4567         tree shift_neg;
4568         tree shift_pos;
4569         tree mask_arg1;
4570         tree masked_arg1;
4571         tree uns_type
4572         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4573
4574         mask_arg1
4575           = ffecom_2 (LSHIFT_EXPR, tree_type,
4576                       ffecom_1 (BIT_NOT_EXPR, tree_type,
4577                                 convert (tree_type, integer_zero_node)),
4578                       arg3_tree);
4579         /* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE.  */
4580         mask_arg1
4581           = ffecom_3 (COND_EXPR, tree_type,
4582                       ffecom_truth_value
4583                       (ffecom_2 (NE_EXPR, integer_type_node,
4584                                  arg3_tree,
4585                                  TYPE_SIZE (uns_type))),
4586                       mask_arg1,
4587                       convert (tree_type, integer_zero_node));
4588         mask_arg1 = ffecom_save_tree (mask_arg1);
4589         masked_arg1
4590           = ffecom_2 (BIT_AND_EXPR, tree_type,
4591                       arg1_tree,
4592                       ffecom_1 (BIT_NOT_EXPR, tree_type,
4593                                 mask_arg1));
4594         masked_arg1 = ffecom_save_tree (masked_arg1);
4595         shift_neg
4596           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4597                       convert (tree_type,
4598                                ffecom_2 (RSHIFT_EXPR, uns_type,
4599                                          convert (uns_type, masked_arg1),
4600                                          ffecom_1 (NEGATE_EXPR,
4601                                                    integer_type_node,
4602                                                    arg2_tree))),
4603                       ffecom_2 (LSHIFT_EXPR, tree_type,
4604                                 arg1_tree,
4605                                 ffecom_2 (PLUS_EXPR, integer_type_node,
4606                                           arg2_tree,
4607                                           arg3_tree)));
4608         shift_pos
4609           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4610                       ffecom_2 (LSHIFT_EXPR, tree_type,
4611                                 arg1_tree,
4612                                 arg2_tree),
4613                       convert (tree_type,
4614                                ffecom_2 (RSHIFT_EXPR, uns_type,
4615                                          convert (uns_type, masked_arg1),
4616                                          ffecom_2 (MINUS_EXPR,
4617                                                    integer_type_node,
4618                                                    arg3_tree,
4619                                                    arg2_tree))));
4620         expr_tree
4621           = ffecom_3 (COND_EXPR, tree_type,
4622                       ffecom_truth_value
4623                       (ffecom_2 (LT_EXPR, integer_type_node,
4624                                  arg2_tree,
4625                                  integer_zero_node)),
4626                       shift_neg,
4627                       shift_pos);
4628         expr_tree
4629           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4630                       ffecom_2 (BIT_AND_EXPR, tree_type,
4631                                 mask_arg1,
4632                                 arg1_tree),
4633                       ffecom_2 (BIT_AND_EXPR, tree_type,
4634                                 ffecom_1 (BIT_NOT_EXPR, tree_type,
4635                                           mask_arg1),
4636                                 expr_tree));
4637         expr_tree
4638           = ffecom_3 (COND_EXPR, tree_type,
4639                       ffecom_truth_value
4640                       (ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
4641                                  ffecom_2 (EQ_EXPR, integer_type_node,
4642                                            ffecom_1 (ABS_EXPR,
4643                                                      integer_type_node,
4644                                                      arg2_tree),
4645                                            arg3_tree),
4646                                  ffecom_2 (EQ_EXPR, integer_type_node,
4647                                            arg2_tree,
4648                                            integer_zero_node))),
4649                       arg1_tree,
4650                       expr_tree);
4651         /* Make sure SAVE_EXPRs get referenced early enough. */
4652         expr_tree
4653           = ffecom_2 (COMPOUND_EXPR, tree_type,
4654                       convert (void_type_node, arg1_tree),
4655                       ffecom_2 (COMPOUND_EXPR, tree_type,
4656                                 convert (void_type_node, arg2_tree),
4657                                 ffecom_2 (COMPOUND_EXPR, tree_type,
4658                                           convert (void_type_node,
4659                                                    mask_arg1),
4660                                           ffecom_2 (COMPOUND_EXPR, tree_type,
4661                                                     convert (void_type_node,
4662                                                              masked_arg1),
4663                                                     expr_tree))));
4664         expr_tree
4665           = ffecom_2 (COMPOUND_EXPR, tree_type,
4666                       convert (void_type_node,
4667                                arg3_tree),
4668                       expr_tree);
4669       }
4670       return expr_tree;
4671
4672     case FFEINTRIN_impLOC:
4673       {
4674         tree arg1_tree = ffecom_expr (arg1);
4675
4676         expr_tree
4677           = convert (tree_type,
4678                      ffecom_1 (ADDR_EXPR,
4679                                build_pointer_type (TREE_TYPE (arg1_tree)),
4680                                arg1_tree));
4681       }
4682       return expr_tree;
4683
4684     case FFEINTRIN_impMVBITS:
4685       {
4686         tree arg1_tree;
4687         tree arg2_tree;
4688         tree arg3_tree;
4689         ffebld arg4 = ffebld_head (ffebld_trail (list));
4690         tree arg4_tree;
4691         tree arg4_type;
4692         ffebld arg5 = ffebld_head (ffebld_trail (ffebld_trail (list)));
4693         tree arg5_tree;
4694         tree prep_arg1;
4695         tree prep_arg4;
4696         tree arg5_plus_arg3;
4697
4698         arg2_tree = convert (integer_type_node,
4699                              ffecom_expr (arg2));
4700         arg3_tree = ffecom_save_tree (convert (integer_type_node,
4701                                                ffecom_expr (arg3)));
4702         arg4_tree = ffecom_expr_rw (NULL_TREE, arg4);
4703         arg4_type = TREE_TYPE (arg4_tree);
4704
4705         arg1_tree = ffecom_save_tree (convert (arg4_type,
4706                                                ffecom_expr (arg1)));
4707
4708         arg5_tree = ffecom_save_tree (convert (integer_type_node,
4709                                                ffecom_expr (arg5)));
4710
4711         prep_arg1
4712           = ffecom_2 (LSHIFT_EXPR, arg4_type,
4713                       ffecom_2 (BIT_AND_EXPR, arg4_type,
4714                                 ffecom_2 (RSHIFT_EXPR, arg4_type,
4715                                           arg1_tree,
4716                                           arg2_tree),
4717                                 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4718                                           ffecom_2 (LSHIFT_EXPR, arg4_type,
4719                                                     ffecom_1 (BIT_NOT_EXPR,
4720                                                               arg4_type,
4721                                                               convert
4722                                                               (arg4_type,
4723                                                         integer_zero_node)),
4724                                                     arg3_tree))),
4725                       arg5_tree);
4726         arg5_plus_arg3
4727           = ffecom_save_tree (ffecom_2 (PLUS_EXPR, arg4_type,
4728                                         arg5_tree,
4729                                         arg3_tree));
4730         prep_arg4
4731           = ffecom_2 (LSHIFT_EXPR, arg4_type,
4732                       ffecom_1 (BIT_NOT_EXPR, arg4_type,
4733                                 convert (arg4_type,
4734                                          integer_zero_node)),
4735                       arg5_plus_arg3);
4736         /* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE.  */
4737         prep_arg4
4738           = ffecom_3 (COND_EXPR, arg4_type,
4739                       ffecom_truth_value
4740                       (ffecom_2 (NE_EXPR, integer_type_node,
4741                                  arg5_plus_arg3,
4742                                  convert (TREE_TYPE (arg5_plus_arg3),
4743                                           TYPE_SIZE (arg4_type)))),
4744                       prep_arg4,
4745                       convert (arg4_type, integer_zero_node));
4746         prep_arg4
4747           = ffecom_2 (BIT_AND_EXPR, arg4_type,
4748                       arg4_tree,
4749                       ffecom_2 (BIT_IOR_EXPR, arg4_type,
4750                                 prep_arg4,
4751                                 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4752                                           ffecom_2 (LSHIFT_EXPR, arg4_type,
4753                                                     ffecom_1 (BIT_NOT_EXPR,
4754                                                               arg4_type,
4755                                                               convert
4756                                                               (arg4_type,
4757                                                         integer_zero_node)),
4758                                                     arg5_tree))));
4759         prep_arg1
4760           = ffecom_2 (BIT_IOR_EXPR, arg4_type,
4761                       prep_arg1,
4762                       prep_arg4);
4763         /* Fix up (twice), because LSHIFT_EXPR above
4764            can't shift over TYPE_SIZE.  */
4765         prep_arg1
4766           = ffecom_3 (COND_EXPR, arg4_type,
4767                       ffecom_truth_value
4768                       (ffecom_2 (NE_EXPR, integer_type_node,
4769                                  arg3_tree,
4770                                  convert (TREE_TYPE (arg3_tree),
4771                                           integer_zero_node))),
4772                       prep_arg1,
4773                       arg4_tree);
4774         prep_arg1
4775           = ffecom_3 (COND_EXPR, arg4_type,
4776                       ffecom_truth_value
4777                       (ffecom_2 (NE_EXPR, integer_type_node,
4778                                  arg3_tree,
4779                                  convert (TREE_TYPE (arg3_tree),
4780                                           TYPE_SIZE (arg4_type)))),
4781                       prep_arg1,
4782                       arg1_tree);
4783         expr_tree
4784           = ffecom_2s (MODIFY_EXPR, void_type_node,
4785                        arg4_tree,
4786                        prep_arg1);
4787         /* Make sure SAVE_EXPRs get referenced early enough. */
4788         expr_tree
4789           = ffecom_2 (COMPOUND_EXPR, void_type_node,
4790                       arg1_tree,
4791                       ffecom_2 (COMPOUND_EXPR, void_type_node,
4792                                 arg3_tree,
4793                                 ffecom_2 (COMPOUND_EXPR, void_type_node,
4794                                           arg5_tree,
4795                                           ffecom_2 (COMPOUND_EXPR, void_type_node,
4796                                                     arg5_plus_arg3,
4797                                                     expr_tree))));
4798         expr_tree
4799           = ffecom_2 (COMPOUND_EXPR, void_type_node,
4800                       arg4_tree,
4801                       expr_tree);
4802
4803       }
4804       return expr_tree;
4805
4806     case FFEINTRIN_impDERF:
4807     case FFEINTRIN_impERF:
4808     case FFEINTRIN_impDERFC:
4809     case FFEINTRIN_impERFC:
4810       break;
4811
4812     case FFEINTRIN_impIARGC:
4813       /* extern int xargc; i__1 = xargc - 1; */
4814       expr_tree = ffecom_2 (MINUS_EXPR, TREE_TYPE (ffecom_tree_xargc_),
4815                             ffecom_tree_xargc_,
4816                             convert (TREE_TYPE (ffecom_tree_xargc_),
4817                                      integer_one_node));
4818       return expr_tree;
4819
4820     case FFEINTRIN_impSIGNAL_func:
4821     case FFEINTRIN_impSIGNAL_subr:
4822       {
4823         tree arg1_tree;
4824         tree arg2_tree;
4825         tree arg3_tree;
4826
4827         arg1_tree = convert (ffecom_f2c_integer_type_node,
4828                              ffecom_expr (arg1));
4829         arg1_tree = ffecom_1 (ADDR_EXPR,
4830                               build_pointer_type (TREE_TYPE (arg1_tree)),
4831                               arg1_tree);
4832
4833         /* Pass procedure as a pointer to it, anything else by value.  */
4834         if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
4835           arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
4836         else
4837           arg2_tree = ffecom_ptr_to_expr (arg2);
4838         arg2_tree = convert (TREE_TYPE (null_pointer_node),
4839                              arg2_tree);
4840
4841         if (arg3 != NULL)
4842           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
4843         else
4844           arg3_tree = NULL_TREE;
4845
4846         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4847         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4848         TREE_CHAIN (arg1_tree) = arg2_tree;
4849
4850         expr_tree
4851           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4852                           ffecom_gfrt_kindtype (gfrt),
4853                           FALSE,
4854                           ((codegen_imp == FFEINTRIN_impSIGNAL_subr) ?
4855                            NULL_TREE :
4856                            tree_type),
4857                           arg1_tree,
4858                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4859                           ffebld_nonter_hook (expr));
4860
4861         if (arg3_tree != NULL_TREE)
4862           expr_tree
4863             = ffecom_modify (NULL_TREE, arg3_tree,
4864                              convert (TREE_TYPE (arg3_tree),
4865                                       expr_tree));
4866       }
4867       return expr_tree;
4868
4869     case FFEINTRIN_impALARM:
4870       {
4871         tree arg1_tree;
4872         tree arg2_tree;
4873         tree arg3_tree;
4874
4875         arg1_tree = convert (ffecom_f2c_integer_type_node,
4876                              ffecom_expr (arg1));
4877         arg1_tree = ffecom_1 (ADDR_EXPR,
4878                               build_pointer_type (TREE_TYPE (arg1_tree)),
4879                               arg1_tree);
4880
4881         /* Pass procedure as a pointer to it, anything else by value.  */
4882         if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
4883           arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
4884         else
4885           arg2_tree = ffecom_ptr_to_expr (arg2);
4886         arg2_tree = convert (TREE_TYPE (null_pointer_node),
4887                              arg2_tree);
4888
4889         if (arg3 != NULL)
4890           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
4891         else
4892           arg3_tree = NULL_TREE;
4893
4894         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4895         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4896         TREE_CHAIN (arg1_tree) = arg2_tree;
4897
4898         expr_tree
4899           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4900                           ffecom_gfrt_kindtype (gfrt),
4901                           FALSE,
4902                           NULL_TREE,
4903                           arg1_tree,
4904                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4905                           ffebld_nonter_hook (expr));
4906
4907         if (arg3_tree != NULL_TREE)
4908           expr_tree
4909             = ffecom_modify (NULL_TREE, arg3_tree,
4910                              convert (TREE_TYPE (arg3_tree),
4911                                       expr_tree));
4912       }
4913       return expr_tree;
4914
4915     case FFEINTRIN_impCHDIR_subr:
4916     case FFEINTRIN_impFDATE_subr:
4917     case FFEINTRIN_impFGET_subr:
4918     case FFEINTRIN_impFPUT_subr:
4919     case FFEINTRIN_impGETCWD_subr:
4920     case FFEINTRIN_impHOSTNM_subr:
4921     case FFEINTRIN_impSYSTEM_subr:
4922     case FFEINTRIN_impUNLINK_subr:
4923       {
4924         tree arg1_len = integer_zero_node;
4925         tree arg1_tree;
4926         tree arg2_tree;
4927
4928         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
4929
4930         if (arg2 != NULL)
4931           arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
4932         else
4933           arg2_tree = NULL_TREE;
4934
4935         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4936         arg1_len = build_tree_list (NULL_TREE, arg1_len);
4937         TREE_CHAIN (arg1_tree) = arg1_len;
4938
4939         expr_tree
4940           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4941                           ffecom_gfrt_kindtype (gfrt),
4942                           FALSE,
4943                           NULL_TREE,
4944                           arg1_tree,
4945                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4946                           ffebld_nonter_hook (expr));
4947
4948         if (arg2_tree != NULL_TREE)
4949           expr_tree
4950             = ffecom_modify (NULL_TREE, arg2_tree,
4951                              convert (TREE_TYPE (arg2_tree),
4952                                       expr_tree));
4953       }
4954       return expr_tree;
4955
4956     case FFEINTRIN_impEXIT:
4957       if (arg1 != NULL)
4958         break;
4959
4960       expr_tree = build_tree_list (NULL_TREE,
4961                                    ffecom_1 (ADDR_EXPR,
4962                                              build_pointer_type
4963                                              (ffecom_integer_type_node),
4964                                              integer_zero_node));
4965
4966       return
4967         ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4968                       ffecom_gfrt_kindtype (gfrt),
4969                       FALSE,
4970                       void_type_node,
4971                       expr_tree,
4972                       NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4973                       ffebld_nonter_hook (expr));
4974
4975     case FFEINTRIN_impFLUSH:
4976       if (arg1 == NULL)
4977         gfrt = FFECOM_gfrtFLUSH;
4978       else
4979         gfrt = FFECOM_gfrtFLUSH1;
4980       break;
4981
4982     case FFEINTRIN_impCHMOD_subr:
4983     case FFEINTRIN_impLINK_subr:
4984     case FFEINTRIN_impRENAME_subr:
4985     case FFEINTRIN_impSYMLNK_subr:
4986       {
4987         tree arg1_len = integer_zero_node;
4988         tree arg1_tree;
4989         tree arg2_len = integer_zero_node;
4990         tree arg2_tree;
4991         tree arg3_tree;
4992
4993         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
4994         arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
4995         if (arg3 != NULL)
4996           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
4997         else
4998           arg3_tree = NULL_TREE;
4999
5000         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5001         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5002         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5003         arg2_len = build_tree_list (NULL_TREE, arg2_len);
5004         TREE_CHAIN (arg1_tree) = arg2_tree;
5005         TREE_CHAIN (arg2_tree) = arg1_len;
5006         TREE_CHAIN (arg1_len) = arg2_len;
5007         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5008                                   ffecom_gfrt_kindtype (gfrt),
5009                                   FALSE,
5010                                   NULL_TREE,
5011                                   arg1_tree,
5012                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5013                                   ffebld_nonter_hook (expr));
5014         if (arg3_tree != NULL_TREE)
5015           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5016                                      convert (TREE_TYPE (arg3_tree),
5017                                               expr_tree));
5018       }
5019       return expr_tree;
5020
5021     case FFEINTRIN_impLSTAT_subr:
5022     case FFEINTRIN_impSTAT_subr:
5023       {
5024         tree arg1_len = integer_zero_node;
5025         tree arg1_tree;
5026         tree arg2_tree;
5027         tree arg3_tree;
5028
5029         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5030
5031         arg2_tree = ffecom_ptr_to_expr (arg2);
5032
5033         if (arg3 != NULL)
5034           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5035         else
5036           arg3_tree = NULL_TREE;
5037
5038         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5039         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5040         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5041         TREE_CHAIN (arg1_tree) = arg2_tree;
5042         TREE_CHAIN (arg2_tree) = arg1_len;
5043         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5044                                   ffecom_gfrt_kindtype (gfrt),
5045                                   FALSE,
5046                                   NULL_TREE,
5047                                   arg1_tree,
5048                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5049                                   ffebld_nonter_hook (expr));
5050         if (arg3_tree != NULL_TREE)
5051           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5052                                      convert (TREE_TYPE (arg3_tree),
5053                                               expr_tree));
5054       }
5055       return expr_tree;
5056
5057     case FFEINTRIN_impFGETC_subr:
5058     case FFEINTRIN_impFPUTC_subr:
5059       {
5060         tree arg1_tree;
5061         tree arg2_tree;
5062         tree arg2_len = integer_zero_node;
5063         tree arg3_tree;
5064
5065         arg1_tree = convert (ffecom_f2c_integer_type_node,
5066                              ffecom_expr (arg1));
5067         arg1_tree = ffecom_1 (ADDR_EXPR,
5068                               build_pointer_type (TREE_TYPE (arg1_tree)),
5069                               arg1_tree);
5070
5071         arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
5072         if (arg3 != NULL)
5073           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5074         else
5075           arg3_tree = NULL_TREE;
5076
5077         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5078         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5079         arg2_len = build_tree_list (NULL_TREE, arg2_len);
5080         TREE_CHAIN (arg1_tree) = arg2_tree;
5081         TREE_CHAIN (arg2_tree) = arg2_len;
5082
5083         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5084                                   ffecom_gfrt_kindtype (gfrt),
5085                                   FALSE,
5086                                   NULL_TREE,
5087                                   arg1_tree,
5088                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5089                                   ffebld_nonter_hook (expr));
5090         if (arg3_tree != NULL_TREE)
5091           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5092                                      convert (TREE_TYPE (arg3_tree),
5093                                               expr_tree));
5094       }
5095       return expr_tree;
5096
5097     case FFEINTRIN_impFSTAT_subr:
5098       {
5099         tree arg1_tree;
5100         tree arg2_tree;
5101         tree arg3_tree;
5102
5103         arg1_tree = convert (ffecom_f2c_integer_type_node,
5104                              ffecom_expr (arg1));
5105         arg1_tree = ffecom_1 (ADDR_EXPR,
5106                               build_pointer_type (TREE_TYPE (arg1_tree)),
5107                               arg1_tree);
5108
5109         arg2_tree = convert (ffecom_f2c_ptr_to_integer_type_node,
5110                              ffecom_ptr_to_expr (arg2));
5111
5112         if (arg3 == NULL)
5113           arg3_tree = NULL_TREE;
5114         else
5115           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5116
5117         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5118         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5119         TREE_CHAIN (arg1_tree) = arg2_tree;
5120         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5121                                   ffecom_gfrt_kindtype (gfrt),
5122                                   FALSE,
5123                                   NULL_TREE,
5124                                   arg1_tree,
5125                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5126                                   ffebld_nonter_hook (expr));
5127         if (arg3_tree != NULL_TREE) {
5128           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5129                                      convert (TREE_TYPE (arg3_tree),
5130                                               expr_tree));
5131         }
5132       }
5133       return expr_tree;
5134
5135     case FFEINTRIN_impKILL_subr:
5136       {
5137         tree arg1_tree;
5138         tree arg2_tree;
5139         tree arg3_tree;
5140
5141         arg1_tree = convert (ffecom_f2c_integer_type_node,
5142                              ffecom_expr (arg1));
5143         arg1_tree = ffecom_1 (ADDR_EXPR,
5144                               build_pointer_type (TREE_TYPE (arg1_tree)),
5145                               arg1_tree);
5146
5147         arg2_tree = convert (ffecom_f2c_integer_type_node,
5148                              ffecom_expr (arg2));
5149         arg2_tree = ffecom_1 (ADDR_EXPR,
5150                               build_pointer_type (TREE_TYPE (arg2_tree)),
5151                               arg2_tree);
5152
5153         if (arg3 == NULL)
5154           arg3_tree = NULL_TREE;
5155         else
5156           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5157
5158         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5159         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5160         TREE_CHAIN (arg1_tree) = arg2_tree;
5161         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5162                                   ffecom_gfrt_kindtype (gfrt),
5163                                   FALSE,
5164                                   NULL_TREE,
5165                                   arg1_tree,
5166                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5167                                   ffebld_nonter_hook (expr));
5168         if (arg3_tree != NULL_TREE) {
5169           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5170                                      convert (TREE_TYPE (arg3_tree),
5171                                               expr_tree));
5172         }
5173       }
5174       return expr_tree;
5175
5176     case FFEINTRIN_impCTIME_subr:
5177     case FFEINTRIN_impTTYNAM_subr:
5178       {
5179         tree arg1_len = integer_zero_node;
5180         tree arg1_tree;
5181         tree arg2_tree;
5182
5183         arg1_tree = ffecom_arg_ptr_to_expr (arg2, &arg1_len);
5184
5185         arg2_tree = convert (((codegen_imp == FFEINTRIN_impCTIME_subr) ?
5186                               ffecom_f2c_longint_type_node :
5187                               ffecom_f2c_integer_type_node),
5188                              ffecom_expr (arg1));
5189         arg2_tree = ffecom_1 (ADDR_EXPR,
5190                               build_pointer_type (TREE_TYPE (arg2_tree)),
5191                               arg2_tree);
5192
5193         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5194         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5195         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5196         TREE_CHAIN (arg1_len) = arg2_tree;
5197         TREE_CHAIN (arg1_tree) = arg1_len;
5198
5199         expr_tree
5200           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5201                           ffecom_gfrt_kindtype (gfrt),
5202                           FALSE,
5203                           NULL_TREE,
5204                           arg1_tree,
5205                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5206                           ffebld_nonter_hook (expr));
5207         TREE_SIDE_EFFECTS (expr_tree) = 1;
5208       }
5209       return expr_tree;
5210
5211     case FFEINTRIN_impIRAND:
5212     case FFEINTRIN_impRAND:
5213       /* Arg defaults to 0 (normal random case) */
5214       {
5215         tree arg1_tree;
5216
5217         if (arg1 == NULL)
5218           arg1_tree = ffecom_integer_zero_node;
5219         else
5220           arg1_tree = ffecom_expr (arg1);
5221         arg1_tree = convert (ffecom_f2c_integer_type_node,
5222                              arg1_tree);
5223         arg1_tree = ffecom_1 (ADDR_EXPR,
5224                               build_pointer_type (TREE_TYPE (arg1_tree)),
5225                               arg1_tree);
5226         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5227
5228         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5229                                   ffecom_gfrt_kindtype (gfrt),
5230                                   FALSE,
5231                                   ((codegen_imp == FFEINTRIN_impIRAND) ?
5232                                    ffecom_f2c_integer_type_node :
5233                                    ffecom_f2c_real_type_node),
5234                                   arg1_tree,
5235                                   dest_tree, dest, dest_used,
5236                                   NULL_TREE, TRUE,
5237                                   ffebld_nonter_hook (expr));
5238       }
5239       return expr_tree;
5240
5241     case FFEINTRIN_impFTELL_subr:
5242     case FFEINTRIN_impUMASK_subr:
5243       {
5244         tree arg1_tree;
5245         tree arg2_tree;
5246
5247         arg1_tree = convert (ffecom_f2c_integer_type_node,
5248                              ffecom_expr (arg1));
5249         arg1_tree = ffecom_1 (ADDR_EXPR,
5250                               build_pointer_type (TREE_TYPE (arg1_tree)),
5251                               arg1_tree);
5252
5253         if (arg2 == NULL)
5254           arg2_tree = NULL_TREE;
5255         else
5256           arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
5257
5258         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5259                                   ffecom_gfrt_kindtype (gfrt),
5260                                   FALSE,
5261                                   NULL_TREE,
5262                                   build_tree_list (NULL_TREE, arg1_tree),
5263                                   NULL_TREE, NULL, NULL, NULL_TREE,
5264                                   TRUE,
5265                                   ffebld_nonter_hook (expr));
5266         if (arg2_tree != NULL_TREE) {
5267           expr_tree = ffecom_modify (NULL_TREE, arg2_tree,
5268                                      convert (TREE_TYPE (arg2_tree),
5269                                               expr_tree));
5270         }
5271       }
5272       return expr_tree;
5273
5274     case FFEINTRIN_impCPU_TIME:
5275     case FFEINTRIN_impSECOND_subr:
5276       {
5277         tree arg1_tree;
5278
5279         arg1_tree = ffecom_expr_w (NULL_TREE, arg1);
5280
5281         expr_tree
5282           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5283                           ffecom_gfrt_kindtype (gfrt),
5284                           FALSE,
5285                           NULL_TREE,
5286                           NULL_TREE,
5287                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5288                           ffebld_nonter_hook (expr));
5289
5290         expr_tree
5291           = ffecom_modify (NULL_TREE, arg1_tree,
5292                            convert (TREE_TYPE (arg1_tree),
5293                                     expr_tree));
5294       }
5295       return expr_tree;
5296
5297     case FFEINTRIN_impDTIME_subr:
5298     case FFEINTRIN_impETIME_subr:
5299       {
5300         tree arg1_tree;
5301         tree result_tree;
5302
5303         result_tree = ffecom_expr_w (NULL_TREE, arg2);
5304
5305         arg1_tree = ffecom_ptr_to_expr (arg1);
5306
5307         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5308                                   ffecom_gfrt_kindtype (gfrt),
5309                                   FALSE,
5310                                   NULL_TREE,
5311                                   build_tree_list (NULL_TREE, arg1_tree),
5312                                   NULL_TREE, NULL, NULL, NULL_TREE,
5313                                   TRUE,
5314                                   ffebld_nonter_hook (expr));
5315         expr_tree = ffecom_modify (NULL_TREE, result_tree,
5316                                    convert (TREE_TYPE (result_tree),
5317                                             expr_tree));
5318       }
5319       return expr_tree;
5320
5321       /* Straightforward calls of libf2c routines: */
5322     case FFEINTRIN_impABORT:
5323     case FFEINTRIN_impACCESS:
5324     case FFEINTRIN_impBESJ0:
5325     case FFEINTRIN_impBESJ1:
5326     case FFEINTRIN_impBESJN:
5327     case FFEINTRIN_impBESY0:
5328     case FFEINTRIN_impBESY1:
5329     case FFEINTRIN_impBESYN:
5330     case FFEINTRIN_impCHDIR_func:
5331     case FFEINTRIN_impCHMOD_func:
5332     case FFEINTRIN_impDATE:
5333     case FFEINTRIN_impDATE_AND_TIME:
5334     case FFEINTRIN_impDBESJ0:
5335     case FFEINTRIN_impDBESJ1:
5336     case FFEINTRIN_impDBESJN:
5337     case FFEINTRIN_impDBESY0:
5338     case FFEINTRIN_impDBESY1:
5339     case FFEINTRIN_impDBESYN:
5340     case FFEINTRIN_impDTIME_func:
5341     case FFEINTRIN_impETIME_func:
5342     case FFEINTRIN_impFGETC_func:
5343     case FFEINTRIN_impFGET_func:
5344     case FFEINTRIN_impFNUM:
5345     case FFEINTRIN_impFPUTC_func:
5346     case FFEINTRIN_impFPUT_func:
5347     case FFEINTRIN_impFSEEK:
5348     case FFEINTRIN_impFSTAT_func:
5349     case FFEINTRIN_impFTELL_func:
5350     case FFEINTRIN_impGERROR:
5351     case FFEINTRIN_impGETARG:
5352     case FFEINTRIN_impGETCWD_func:
5353     case FFEINTRIN_impGETENV:
5354     case FFEINTRIN_impGETGID:
5355     case FFEINTRIN_impGETLOG:
5356     case FFEINTRIN_impGETPID:
5357     case FFEINTRIN_impGETUID:
5358     case FFEINTRIN_impGMTIME:
5359     case FFEINTRIN_impHOSTNM_func:
5360     case FFEINTRIN_impIDATE_unix:
5361     case FFEINTRIN_impIDATE_vxt:
5362     case FFEINTRIN_impIERRNO:
5363     case FFEINTRIN_impISATTY:
5364     case FFEINTRIN_impITIME:
5365     case FFEINTRIN_impKILL_func:
5366     case FFEINTRIN_impLINK_func:
5367     case FFEINTRIN_impLNBLNK:
5368     case FFEINTRIN_impLSTAT_func:
5369     case FFEINTRIN_impLTIME:
5370     case FFEINTRIN_impMCLOCK8:
5371     case FFEINTRIN_impMCLOCK:
5372     case FFEINTRIN_impPERROR:
5373     case FFEINTRIN_impRENAME_func:
5374     case FFEINTRIN_impSECNDS:
5375     case FFEINTRIN_impSECOND_func:
5376     case FFEINTRIN_impSLEEP:
5377     case FFEINTRIN_impSRAND:
5378     case FFEINTRIN_impSTAT_func:
5379     case FFEINTRIN_impSYMLNK_func:
5380     case FFEINTRIN_impSYSTEM_CLOCK:
5381     case FFEINTRIN_impSYSTEM_func:
5382     case FFEINTRIN_impTIME8:
5383     case FFEINTRIN_impTIME_unix:
5384     case FFEINTRIN_impTIME_vxt:
5385     case FFEINTRIN_impUMASK_func:
5386     case FFEINTRIN_impUNLINK_func:
5387       break;
5388
5389     case FFEINTRIN_impCTIME_func:       /* CHARACTER functions not handled here. */
5390     case FFEINTRIN_impFDATE_func:       /* CHARACTER functions not handled here. */
5391     case FFEINTRIN_impTTYNAM_func:      /* CHARACTER functions not handled here. */
5392     case FFEINTRIN_impNONE:
5393     case FFEINTRIN_imp:         /* Hush up gcc warning. */
5394       fprintf (stderr, "No %s implementation.\n",
5395                ffeintrin_name_implementation (ffebld_symter_implementation (ffebld_left (expr))));
5396       assert ("unimplemented intrinsic" == NULL);
5397       return error_mark_node;
5398     }
5399
5400   assert (gfrt != FFECOM_gfrt); /* Must have an implementation! */
5401
5402   expr_tree = ffecom_arglist_expr_ (ffecom_gfrt_args_ (gfrt),
5403                                     ffebld_right (expr));
5404
5405   return ffecom_call_ (ffecom_gfrt_tree_ (gfrt), ffecom_gfrt_kindtype (gfrt),
5406                        (ffe_is_f2c_library () && ffecom_gfrt_complex_[gfrt]),
5407                        tree_type,
5408                        expr_tree, dest_tree, dest, dest_used,
5409                        NULL_TREE, TRUE,
5410                        ffebld_nonter_hook (expr));
5411
5412   /* See bottom of this file for f2c transforms used to determine
5413      many of the above implementations.  The info seems to confuse
5414      Emacs's C mode indentation, which is why it's been moved to
5415      the bottom of this source file.  */
5416 }
5417
5418 /* For power (exponentiation) where right-hand operand is type INTEGER,
5419    generate in-line code to do it the fast way (which, if the operand
5420    is a constant, might just mean a series of multiplies).  */
5421
5422 static tree
5423 ffecom_expr_power_integer_ (ffebld expr)
5424 {
5425   tree l = ffecom_expr (ffebld_left (expr));
5426   tree r = ffecom_expr (ffebld_right (expr));
5427   tree ltype = TREE_TYPE (l);
5428   tree rtype = TREE_TYPE (r);
5429   tree result = NULL_TREE;
5430
5431   if (l == error_mark_node
5432       || r == error_mark_node)
5433     return error_mark_node;
5434
5435   if (TREE_CODE (r) == INTEGER_CST)
5436     {
5437       int sgn = tree_int_cst_sgn (r);
5438
5439       if (sgn == 0)
5440         return convert (ltype, integer_one_node);
5441
5442       if ((TREE_CODE (ltype) == INTEGER_TYPE)
5443           && (sgn < 0))
5444         {
5445           /* Reciprocal of integer is either 0, -1, or 1, so after
5446              calculating that (which we leave to the back end to do
5447              or not do optimally), don't bother with any multiplying.  */
5448
5449           result = ffecom_tree_divide_ (ltype,
5450                                         convert (ltype, integer_one_node),
5451                                         l,
5452                                         NULL_TREE, NULL, NULL, NULL_TREE);
5453           r = ffecom_1 (NEGATE_EXPR,
5454                         rtype,
5455                         r);
5456           if ((TREE_INT_CST_LOW (r) & 1) == 0)
5457             result = ffecom_1 (ABS_EXPR, rtype,
5458                                result);
5459         }
5460
5461       /* Generate appropriate series of multiplies, preceded
5462          by divide if the exponent is negative.  */
5463
5464       l = save_expr (l);
5465
5466       if (sgn < 0)
5467         {
5468           l = ffecom_tree_divide_ (ltype,
5469                                    convert (ltype, integer_one_node),
5470                                    l,
5471                                    NULL_TREE, NULL, NULL,
5472                                    ffebld_nonter_hook (expr));
5473           r = ffecom_1 (NEGATE_EXPR, rtype, r);
5474           assert (TREE_CODE (r) == INTEGER_CST);
5475
5476           if (tree_int_cst_sgn (r) < 0)
5477             {                   /* The "most negative" number.  */
5478               r = ffecom_1 (NEGATE_EXPR, rtype,
5479                             ffecom_2 (RSHIFT_EXPR, rtype,
5480                                       r,
5481                                       integer_one_node));
5482               l = save_expr (l);
5483               l = ffecom_2 (MULT_EXPR, ltype,
5484                             l,
5485                             l);
5486             }
5487         }
5488
5489       for (;;)
5490         {
5491           if (TREE_INT_CST_LOW (r) & 1)
5492             {
5493               if (result == NULL_TREE)
5494                 result = l;
5495               else
5496                 result = ffecom_2 (MULT_EXPR, ltype,
5497                                    result,
5498                                    l);
5499             }
5500
5501           r = ffecom_2 (RSHIFT_EXPR, rtype,
5502                         r,
5503                         integer_one_node);
5504           if (integer_zerop (r))
5505             break;
5506           assert (TREE_CODE (r) == INTEGER_CST);
5507
5508           l = save_expr (l);
5509           l = ffecom_2 (MULT_EXPR, ltype,
5510                         l,
5511                         l);
5512         }
5513       return result;
5514     }
5515
5516   /* Though rhs isn't a constant, in-line code cannot be expanded
5517      while transforming dummies
5518      because the back end cannot be easily convinced to generate
5519      stores (MODIFY_EXPR), handle temporaries, and so on before
5520      all the appropriate rtx's have been generated for things like
5521      dummy args referenced in rhs -- which doesn't happen until
5522      store_parm_decls() is called (expand_function_start, I believe,
5523      does the actual rtx-stuffing of PARM_DECLs).
5524
5525      So, in this case, let the caller generate the call to the
5526      run-time-library function to evaluate the power for us.  */
5527
5528   if (ffecom_transform_only_dummies_)
5529     return NULL_TREE;
5530
5531   /* Right-hand operand not a constant, expand in-line code to figure
5532      out how to do the multiplies, &c.
5533
5534      The returned expression is expressed this way in GNU C, where l and
5535      r are the "inputs":
5536
5537      ({ typeof (r) rtmp = r;
5538         typeof (l) ltmp = l;
5539         typeof (l) result;
5540
5541         if (rtmp == 0)
5542           result = 1;
5543         else
5544           {
5545             if ((basetypeof (l) == basetypeof (int))
5546                 && (rtmp < 0))
5547               {
5548                 result = ((typeof (l)) 1) / ltmp;
5549                 if ((ltmp < 0) && (((-rtmp) & 1) == 0))
5550                   result = -result;
5551               }
5552             else
5553               {
5554                 result = 1;
5555                 if ((basetypeof (l) != basetypeof (int))
5556                     && (rtmp < 0))
5557                   {
5558                     ltmp = ((typeof (l)) 1) / ltmp;
5559                     rtmp = -rtmp;
5560                     if (rtmp < 0)
5561                       {
5562                         rtmp = -(rtmp >> 1);
5563                         ltmp *= ltmp;
5564                       }
5565                   }
5566                 for (;;)
5567                   {
5568                     if (rtmp & 1)
5569                       result *= ltmp;
5570                     if ((rtmp >>= 1) == 0)
5571                       break;
5572                     ltmp *= ltmp;
5573                   }
5574               }
5575           }
5576         result;
5577      })
5578
5579      Note that some of the above is compile-time collapsable, such as
5580      the first part of the if statements that checks the base type of
5581      l against int.  The if statements are phrased that way to suggest
5582      an easy way to generate the if/else constructs here, knowing that
5583      the back end should (and probably does) eliminate the resulting
5584      dead code (either the int case or the non-int case), something
5585      it couldn't do without the redundant phrasing, requiring explicit
5586      dead-code elimination here, which would be kind of difficult to
5587      read.  */
5588
5589   {
5590     tree rtmp;
5591     tree ltmp;
5592     tree divide;
5593     tree basetypeof_l_is_int;
5594     tree se;
5595     tree t;
5596
5597     basetypeof_l_is_int
5598       = build_int_2 ((TREE_CODE (ltype) == INTEGER_TYPE), 0);
5599
5600     se = expand_start_stmt_expr (/*has_scope=*/1);
5601
5602     ffecom_start_compstmt ();
5603
5604     rtmp = ffecom_make_tempvar ("power_r", rtype,
5605                                 FFETARGET_charactersizeNONE, -1);
5606     ltmp = ffecom_make_tempvar ("power_l", ltype,
5607                                 FFETARGET_charactersizeNONE, -1);
5608     result = ffecom_make_tempvar ("power_res", ltype,
5609                                   FFETARGET_charactersizeNONE, -1);
5610     if (TREE_CODE (ltype) == COMPLEX_TYPE
5611         || TREE_CODE (ltype) == RECORD_TYPE)
5612       divide = ffecom_make_tempvar ("power_div", ltype,
5613                                     FFETARGET_charactersizeNONE, -1);
5614     else
5615       divide = NULL_TREE;
5616
5617     expand_expr_stmt (ffecom_modify (void_type_node,
5618                                      rtmp,
5619                                      r));
5620     expand_expr_stmt (ffecom_modify (void_type_node,
5621                                      ltmp,
5622                                      l));
5623     expand_start_cond (ffecom_truth_value
5624                        (ffecom_2 (EQ_EXPR, integer_type_node,
5625                                   rtmp,
5626                                   convert (rtype, integer_zero_node))),
5627                        0);
5628     expand_expr_stmt (ffecom_modify (void_type_node,
5629                                      result,
5630                                      convert (ltype, integer_one_node)));
5631     expand_start_else ();
5632     if (! integer_zerop (basetypeof_l_is_int))
5633       {
5634         expand_start_cond (ffecom_2 (LT_EXPR, integer_type_node,
5635                                      rtmp,
5636                                      convert (rtype,
5637                                               integer_zero_node)),
5638                            0);
5639         expand_expr_stmt (ffecom_modify (void_type_node,
5640                                          result,
5641                                          ffecom_tree_divide_
5642                                          (ltype,
5643                                           convert (ltype, integer_one_node),
5644                                           ltmp,
5645                                           NULL_TREE, NULL, NULL,
5646                                           divide)));
5647         expand_start_cond (ffecom_truth_value
5648                            (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5649                                       ffecom_2 (LT_EXPR, integer_type_node,
5650                                                 ltmp,
5651                                                 convert (ltype,
5652                                                          integer_zero_node)),
5653                                       ffecom_2 (EQ_EXPR, integer_type_node,
5654                                                 ffecom_2 (BIT_AND_EXPR,
5655                                                           rtype,
5656                                                           ffecom_1 (NEGATE_EXPR,
5657                                                                     rtype,
5658                                                                     rtmp),
5659                                                           convert (rtype,
5660                                                                    integer_one_node)),
5661                                                 convert (rtype,
5662                                                          integer_zero_node)))),
5663                            0);
5664         expand_expr_stmt (ffecom_modify (void_type_node,
5665                                          result,
5666                                          ffecom_1 (NEGATE_EXPR,
5667                                                    ltype,
5668                                                    result)));
5669         expand_end_cond ();
5670         expand_start_else ();
5671       }
5672     expand_expr_stmt (ffecom_modify (void_type_node,
5673                                      result,
5674                                      convert (ltype, integer_one_node)));
5675     expand_start_cond (ffecom_truth_value
5676                        (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5677                                   ffecom_truth_value_invert
5678                                   (basetypeof_l_is_int),
5679                                   ffecom_2 (LT_EXPR, integer_type_node,
5680                                             rtmp,
5681                                             convert (rtype,
5682                                                      integer_zero_node)))),
5683                        0);
5684     expand_expr_stmt (ffecom_modify (void_type_node,
5685                                      ltmp,
5686                                      ffecom_tree_divide_
5687                                      (ltype,
5688                                       convert (ltype, integer_one_node),
5689                                       ltmp,
5690                                       NULL_TREE, NULL, NULL,
5691                                       divide)));
5692     expand_expr_stmt (ffecom_modify (void_type_node,
5693                                      rtmp,
5694                                      ffecom_1 (NEGATE_EXPR, rtype,
5695                                                rtmp)));
5696     expand_start_cond (ffecom_truth_value
5697                        (ffecom_2 (LT_EXPR, integer_type_node,
5698                                   rtmp,
5699                                   convert (rtype, integer_zero_node))),
5700                        0);
5701     expand_expr_stmt (ffecom_modify (void_type_node,
5702                                      rtmp,
5703                                      ffecom_1 (NEGATE_EXPR, rtype,
5704                                                ffecom_2 (RSHIFT_EXPR,
5705                                                          rtype,
5706                                                          rtmp,
5707                                                          integer_one_node))));
5708     expand_expr_stmt (ffecom_modify (void_type_node,
5709                                      ltmp,
5710                                      ffecom_2 (MULT_EXPR, ltype,
5711                                                ltmp,
5712                                                ltmp)));
5713     expand_end_cond ();
5714     expand_end_cond ();
5715     expand_start_loop (1);
5716     expand_start_cond (ffecom_truth_value
5717                        (ffecom_2 (BIT_AND_EXPR, rtype,
5718                                   rtmp,
5719                                   convert (rtype, integer_one_node))),
5720                        0);
5721     expand_expr_stmt (ffecom_modify (void_type_node,
5722                                      result,
5723                                      ffecom_2 (MULT_EXPR, ltype,
5724                                                result,
5725                                                ltmp)));
5726     expand_end_cond ();
5727     expand_exit_loop_if_false (NULL,
5728                                ffecom_truth_value
5729                                (ffecom_modify (rtype,
5730                                                rtmp,
5731                                                ffecom_2 (RSHIFT_EXPR,
5732                                                          rtype,
5733                                                          rtmp,
5734                                                          integer_one_node))));
5735     expand_expr_stmt (ffecom_modify (void_type_node,
5736                                      ltmp,
5737                                      ffecom_2 (MULT_EXPR, ltype,
5738                                                ltmp,
5739                                                ltmp)));
5740     expand_end_loop ();
5741     expand_end_cond ();
5742     if (!integer_zerop (basetypeof_l_is_int))
5743       expand_end_cond ();
5744     expand_expr_stmt (result);
5745
5746     t = ffecom_end_compstmt ();
5747
5748     result = expand_end_stmt_expr (se);
5749
5750     /* This code comes from c-parse.in, after its expand_end_stmt_expr.  */
5751
5752     if (TREE_CODE (t) == BLOCK)
5753       {
5754         /* Make a BIND_EXPR for the BLOCK already made.  */
5755         result = build (BIND_EXPR, TREE_TYPE (result),
5756                         NULL_TREE, result, t);
5757         /* Remove the block from the tree at this point.
5758            It gets put back at the proper place
5759            when the BIND_EXPR is expanded.  */
5760         delete_block (t);
5761       }
5762     else
5763       result = t;
5764   }
5765
5766   return result;
5767 }
5768
5769 /* ffecom_expr_transform_ -- Transform symbols in expr
5770
5771    ffebld expr;  // FFE expression.
5772    ffecom_expr_transform_ (expr);
5773
5774    Recursive descent on expr while transforming any untransformed SYMTERs.  */
5775
5776 static void
5777 ffecom_expr_transform_ (ffebld expr)
5778 {
5779   tree t;
5780   ffesymbol s;
5781
5782  tail_recurse:
5783
5784   if (expr == NULL)
5785     return;
5786
5787   switch (ffebld_op (expr))
5788     {
5789     case FFEBLD_opSYMTER:
5790       s = ffebld_symter (expr);
5791       t = ffesymbol_hook (s).decl_tree;
5792       if ((t == NULL_TREE)
5793           && ((ffesymbol_kind (s) != FFEINFO_kindNONE)
5794               || ((ffesymbol_where (s) != FFEINFO_whereNONE)
5795                   && (ffesymbol_where (s) != FFEINFO_whereINTRINSIC))))
5796         {
5797           s = ffecom_sym_transform_ (s);
5798           t = ffesymbol_hook (s).decl_tree;     /* Sfunc expr non-dummy,
5799                                                    DIMENSION expr? */
5800         }
5801       break;                    /* Ok if (t == NULL) here. */
5802
5803     case FFEBLD_opITEM:
5804       ffecom_expr_transform_ (ffebld_head (expr));
5805       expr = ffebld_trail (expr);
5806       goto tail_recurse;        /* :::::::::::::::::::: */
5807
5808     default:
5809       break;
5810     }
5811
5812   switch (ffebld_arity (expr))
5813     {
5814     case 2:
5815       ffecom_expr_transform_ (ffebld_left (expr));
5816       expr = ffebld_right (expr);
5817       goto tail_recurse;        /* :::::::::::::::::::: */
5818
5819     case 1:
5820       expr = ffebld_left (expr);
5821       goto tail_recurse;        /* :::::::::::::::::::: */
5822
5823     default:
5824       break;
5825     }
5826
5827   return;
5828 }
5829
5830 /* Make a type based on info in live f2c.h file.  */
5831
5832 static void
5833 ffecom_f2c_make_type_ (tree *type, int tcode, const char *name)
5834 {
5835   switch (tcode)
5836     {
5837     case FFECOM_f2ccodeCHAR:
5838       *type = make_signed_type (CHAR_TYPE_SIZE);
5839       break;
5840
5841     case FFECOM_f2ccodeSHORT:
5842       *type = make_signed_type (SHORT_TYPE_SIZE);
5843       break;
5844
5845     case FFECOM_f2ccodeINT:
5846       *type = make_signed_type (INT_TYPE_SIZE);
5847       break;
5848
5849     case FFECOM_f2ccodeLONG:
5850       *type = make_signed_type (LONG_TYPE_SIZE);
5851       break;
5852
5853     case FFECOM_f2ccodeLONGLONG:
5854       *type = make_signed_type (LONG_LONG_TYPE_SIZE);
5855       break;
5856
5857     case FFECOM_f2ccodeCHARPTR:
5858       *type = build_pointer_type (DEFAULT_SIGNED_CHAR
5859                                   ? signed_char_type_node
5860                                   : unsigned_char_type_node);
5861       break;
5862
5863     case FFECOM_f2ccodeFLOAT:
5864       *type = make_node (REAL_TYPE);
5865       TYPE_PRECISION (*type) = FLOAT_TYPE_SIZE;
5866       layout_type (*type);
5867       break;
5868
5869     case FFECOM_f2ccodeDOUBLE:
5870       *type = make_node (REAL_TYPE);
5871       TYPE_PRECISION (*type) = DOUBLE_TYPE_SIZE;
5872       layout_type (*type);
5873       break;
5874
5875     case FFECOM_f2ccodeLONGDOUBLE:
5876       *type = make_node (REAL_TYPE);
5877       TYPE_PRECISION (*type) = LONG_DOUBLE_TYPE_SIZE;
5878       layout_type (*type);
5879       break;
5880
5881     case FFECOM_f2ccodeTWOREALS:
5882       *type = ffecom_make_complex_type_ (ffecom_f2c_real_type_node);
5883       break;
5884
5885     case FFECOM_f2ccodeTWODOUBLEREALS:
5886       *type = ffecom_make_complex_type_ (ffecom_f2c_doublereal_type_node);
5887       break;
5888
5889     default:
5890       assert ("unexpected FFECOM_f2ccodeXYZZY!" == NULL);
5891       *type = error_mark_node;
5892       return;
5893     }
5894
5895   pushdecl (build_decl (TYPE_DECL,
5896                         ffecom_get_invented_identifier ("__g77_f2c_%s", name),
5897                         *type));
5898 }
5899
5900 /* Set the f2c list-directed-I/O code for whatever (integral) type has the
5901    given size.  */
5902
5903 static void
5904 ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
5905                           int code)
5906 {
5907   int j;
5908   tree t;
5909
5910   for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
5911     if ((t = ffecom_tree_type[bt][j]) != NULL_TREE
5912         && compare_tree_int (TYPE_SIZE (t), size) == 0)
5913       {
5914         assert (code != -1);
5915         ffecom_f2c_typecode_[bt][j] = code;
5916         code = -1;
5917       }
5918 }
5919
5920 /* Finish up globals after doing all program units in file
5921
5922    Need to handle only uninitialized COMMON areas.  */
5923
5924 static ffeglobal
5925 ffecom_finish_global_ (ffeglobal global)
5926 {
5927   tree cbtype;
5928   tree cbt;
5929   tree size;
5930
5931   if (ffeglobal_type (global) != FFEGLOBAL_typeCOMMON)
5932       return global;
5933
5934   if (ffeglobal_common_init (global))
5935       return global;
5936
5937   cbt = ffeglobal_hook (global);
5938   if ((cbt == NULL_TREE)
5939       || !ffeglobal_common_have_size (global))
5940     return global;              /* No need to make common, never ref'd. */
5941
5942   DECL_EXTERNAL (cbt) = 0;
5943
5944   /* Give the array a size now.  */
5945
5946   size = build_int_2 ((ffeglobal_common_size (global)
5947                       + ffeglobal_common_pad (global)) - 1,
5948                       0);
5949
5950   cbtype = TREE_TYPE (cbt);
5951   TYPE_DOMAIN (cbtype) = build_range_type (integer_type_node,
5952                                            integer_zero_node,
5953                                            size);
5954   if (!TREE_TYPE (size))
5955     TREE_TYPE (size) = TYPE_DOMAIN (cbtype);
5956   layout_type (cbtype);
5957
5958   cbt = start_decl (cbt, FALSE);
5959   assert (cbt == ffeglobal_hook (global));
5960
5961   finish_decl (cbt, NULL_TREE, FALSE);
5962
5963   return global;
5964 }
5965
5966 /* Finish up any untransformed symbols.  */
5967
5968 static ffesymbol
5969 ffecom_finish_symbol_transform_ (ffesymbol s)
5970 {
5971   if ((s == NULL) || (TREE_CODE (current_function_decl) == ERROR_MARK))
5972     return s;
5973
5974   /* It's easy to know to transform an untransformed symbol, to make sure
5975      we put out debugging info for it.  But COMMON variables, unlike
5976      EQUIVALENCE ones, aren't given declarations in addition to the
5977      tree expressions that specify offsets, because COMMON variables
5978      can be referenced in the outer scope where only dummy arguments
5979      (PARM_DECLs) should really be seen.  To be safe, just don't do any
5980      VAR_DECLs for COMMON variables when we transform them for real
5981      use, and therefore we do all the VAR_DECL creating here.  */
5982
5983   if (ffesymbol_hook (s).decl_tree == NULL_TREE)
5984     {
5985       if (ffesymbol_kind (s) != FFEINFO_kindNONE
5986           || (ffesymbol_where (s) != FFEINFO_whereNONE
5987               && ffesymbol_where (s) != FFEINFO_whereINTRINSIC
5988               && ffesymbol_where (s) != FFEINFO_whereDUMMY))
5989         /* Not transformed, and not CHARACTER*(*), and not a dummy
5990            argument, which can happen only if the entry point names
5991            it "rides in on" are all invalidated for other reasons.  */
5992         s = ffecom_sym_transform_ (s);
5993     }
5994
5995   if ((ffesymbol_where (s) == FFEINFO_whereCOMMON)
5996       && (ffesymbol_hook (s).decl_tree != error_mark_node))
5997     {
5998       /* This isn't working, at least for dbxout.  The .s file looks
5999          okay to me (burley), but in gdb 4.9 at least, the variables
6000          appear to reside somewhere outside of the common area, so
6001          it doesn't make sense to mislead anyone by generating the info
6002          on those variables until this is fixed.  NOTE: Same problem
6003          with EQUIVALENCE, sadly...see similar #if later.  */
6004       ffecom_member_phase2_ (ffesymbol_storage (ffesymbol_common (s)),
6005                              ffesymbol_storage (s));
6006     }
6007
6008   return s;
6009 }
6010
6011 /* Append underscore(s) to name before calling get_identifier.  "us"
6012    is nonzero if the name already contains an underscore and thus
6013    needs two underscores appended.  */
6014
6015 static tree
6016 ffecom_get_appended_identifier_ (char us, const char *name)
6017 {
6018   int i;
6019   char *newname;
6020   tree id;
6021
6022   newname = xmalloc ((i = strlen (name)) + 1
6023                      + ffe_is_underscoring ()
6024                      + us);
6025   memcpy (newname, name, i);
6026   newname[i] = '_';
6027   newname[i + us] = '_';
6028   newname[i + 1 + us] = '\0';
6029   id = get_identifier (newname);
6030
6031   free (newname);
6032
6033   return id;
6034 }
6035
6036 /* Decide whether to append underscore to name before calling
6037    get_identifier.  */
6038
6039 static tree
6040 ffecom_get_external_identifier_ (ffesymbol s)
6041 {
6042   char us;
6043   const char *name = ffesymbol_text (s);
6044
6045   /* If name is a built-in name, just return it as is.  */
6046
6047   if (!ffe_is_underscoring ()
6048       || (strcmp (name, FFETARGET_nameBLANK_COMMON) == 0)
6049       || (strcmp (name, FFETARGET_nameUNNAMED_MAIN) == 0)
6050       || (strcmp (name, FFETARGET_nameUNNAMED_BLOCK_DATA) == 0))
6051     return get_identifier (name);
6052
6053   us = ffe_is_second_underscore ()
6054     ? (strchr (name, '_') != NULL)
6055       : 0;
6056
6057   return ffecom_get_appended_identifier_ (us, name);
6058 }
6059
6060 /* Decide whether to append underscore to internal name before calling
6061    get_identifier.
6062
6063    This is for non-external, top-function-context names only.  Transform
6064    identifier so it doesn't conflict with the transformed result
6065    of using a _different_ external name.  E.g. if "CALL FOO" is
6066    transformed into "FOO_();", then the variable in "FOO_ = 3"
6067    must be transformed into something that does not conflict, since
6068    these two things should be independent.
6069
6070    The transformation is as follows.  If the name does not contain
6071    an underscore, there is no possible conflict, so just return.
6072    If the name does contain an underscore, then transform it just
6073    like we transform an external identifier.  */
6074
6075 static tree
6076 ffecom_get_identifier_ (const char *name)
6077 {
6078   /* If name does not contain an underscore, just return it as is.  */
6079
6080   if (!ffe_is_underscoring ()
6081       || (strchr (name, '_') == NULL))
6082     return get_identifier (name);
6083
6084   return ffecom_get_appended_identifier_ (ffe_is_second_underscore (),
6085                                           name);
6086 }
6087
6088 /* ffecom_gen_sfuncdef_ -- Generate definition of statement function
6089
6090    tree t;
6091    ffesymbol s;  // kindFUNCTION, whereIMMEDIATE.
6092    t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s),
6093          ffesymbol_kindtype(s));
6094
6095    Call after setting up containing function and getting trees for all
6096    other symbols.  */
6097
6098 static tree
6099 ffecom_gen_sfuncdef_ (ffesymbol s, ffeinfoBasictype bt, ffeinfoKindtype kt)
6100 {
6101   ffebld expr = ffesymbol_sfexpr (s);
6102   tree type;
6103   tree func;
6104   tree result;
6105   bool charfunc = (bt == FFEINFO_basictypeCHARACTER);
6106   static bool recurse = FALSE;
6107   location_t old_loc = input_location;
6108
6109   ffecom_nested_entry_ = s;
6110
6111   /* For now, we don't have a handy pointer to where the sfunc is actually
6112      defined, though that should be easy to add to an ffesymbol. (The
6113      token/where info available might well point to the place where the type
6114      of the sfunc is declared, especially if that precedes the place where
6115      the sfunc itself is defined, which is typically the case.)  We should
6116      put out a null pointer rather than point somewhere wrong, but I want to
6117      see how it works at this point.  */
6118
6119   input_filename = ffesymbol_where_filename (s);
6120   input_line = ffesymbol_where_filelinenum (s);
6121
6122   /* Pretransform the expression so any newly discovered things belong to the
6123      outer program unit, not to the statement function. */
6124
6125   ffecom_expr_transform_ (expr);
6126
6127   /* Make sure no recursive invocation of this fn (a specific case of failing
6128      to pretransform an sfunc's expression, i.e. where its expression
6129      references another untransformed sfunc) happens. */
6130
6131   assert (!recurse);
6132   recurse = TRUE;
6133
6134   push_f_function_context ();
6135
6136   if (charfunc)
6137     type = void_type_node;
6138   else
6139     {
6140       type = ffecom_tree_type[bt][kt];
6141       if (type == NULL_TREE)
6142         type = integer_type_node;       /* _sym_exec_transition reports
6143                                            error. */
6144     }
6145
6146   start_function (ffecom_get_identifier_ (ffesymbol_text (s)),
6147                   build_function_type (type, NULL_TREE),
6148                   1,            /* nested/inline */
6149                   0);           /* TREE_PUBLIC */
6150
6151   /* We don't worry about COMPLEX return values here, because this is
6152      entirely internal to our code, and gcc has the ability to return COMPLEX
6153      directly as a value.  */
6154
6155   if (charfunc)
6156     {                           /* Prepend arg for where result goes. */
6157       tree type;
6158
6159       type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
6160
6161       result = ffecom_get_invented_identifier ("__g77_%s", "result");
6162
6163       ffecom_char_enhance_arg_ (&type, s);      /* Ignore returned length. */
6164
6165       type = build_pointer_type (type);
6166       result = build_decl (PARM_DECL, result, type);
6167
6168       push_parm_decl (result);
6169     }
6170   else
6171     result = NULL_TREE;         /* Not ref'd if !charfunc. */
6172
6173   ffecom_push_dummy_decls_ (ffesymbol_dummyargs (s), TRUE);
6174
6175   store_parm_decls (0);
6176
6177   ffecom_start_compstmt ();
6178
6179   if (expr != NULL)
6180     {
6181       if (charfunc)
6182         {
6183           ffetargetCharacterSize sz = ffesymbol_size (s);
6184           tree result_length;
6185
6186           result_length = build_int_2 (sz, 0);
6187           TREE_TYPE (result_length) = ffecom_f2c_ftnlen_type_node;
6188
6189           ffecom_prepare_let_char_ (sz, expr);
6190
6191           ffecom_prepare_end ();
6192
6193           ffecom_let_char_ (result, result_length, sz, expr);
6194           expand_null_return ();
6195         }
6196       else
6197         {
6198           ffecom_prepare_expr (expr);
6199
6200           ffecom_prepare_end ();
6201
6202           expand_return (ffecom_modify (NULL_TREE,
6203                                         DECL_RESULT (current_function_decl),
6204                                         ffecom_expr (expr)));
6205         }
6206     }
6207
6208   ffecom_end_compstmt ();
6209
6210   func = current_function_decl;
6211   finish_function (1);
6212
6213   pop_f_function_context ();
6214
6215   recurse = FALSE;
6216
6217   input_location = old_loc;
6218
6219   ffecom_nested_entry_ = NULL;
6220
6221   return func;
6222 }
6223
6224 static const char *
6225 ffecom_gfrt_args_ (ffecomGfrt ix)
6226 {
6227   return ffecom_gfrt_argstring_[ix];
6228 }
6229
6230 static tree
6231 ffecom_gfrt_tree_ (ffecomGfrt ix)
6232 {
6233   if (ffecom_gfrt_[ix] == NULL_TREE)
6234     ffecom_make_gfrt_ (ix);
6235
6236   return ffecom_1 (ADDR_EXPR,
6237                    build_pointer_type (TREE_TYPE (ffecom_gfrt_[ix])),
6238                    ffecom_gfrt_[ix]);
6239 }
6240
6241 /* Return initialize-to-zero expression for this VAR_DECL.  */
6242
6243 /* A somewhat evil way to prevent the garbage collector
6244    from collecting 'tree' structures.  */
6245 #define NUM_TRACKED_CHUNK 63
6246 struct tree_ggc_tracker GTY(())
6247 {
6248   struct tree_ggc_tracker *next;
6249   tree trees[NUM_TRACKED_CHUNK];
6250 };
6251 static GTY(()) struct tree_ggc_tracker *tracker_head;
6252
6253 void
6254 ffecom_save_tree_forever (tree t)
6255 {
6256   int i;
6257   if (tracker_head != NULL)
6258     for (i = 0; i < NUM_TRACKED_CHUNK; i++)
6259       if (tracker_head->trees[i] == NULL)
6260         {
6261           tracker_head->trees[i] = t;
6262           return;
6263         }
6264
6265   {
6266     /* Need to allocate a new block.  */
6267     struct tree_ggc_tracker *old_head = tracker_head;
6268
6269     tracker_head = ggc_alloc (sizeof (*tracker_head));
6270     tracker_head->next = old_head;
6271     tracker_head->trees[0] = t;
6272     for (i = 1; i < NUM_TRACKED_CHUNK; i++)
6273       tracker_head->trees[i] = NULL;
6274   }
6275 }
6276
6277 static tree
6278 ffecom_init_zero_ (tree decl)
6279 {
6280   tree init;
6281   int incremental = TREE_STATIC (decl);
6282   tree type = TREE_TYPE (decl);
6283
6284   if (incremental)
6285     {
6286       make_decl_rtl (decl, NULL);
6287       assemble_variable (decl, TREE_PUBLIC (decl) ? 1 : 0, 0, 1);
6288     }
6289
6290   if ((TREE_CODE (type) != ARRAY_TYPE)
6291       && (TREE_CODE (type) != RECORD_TYPE)
6292       && (TREE_CODE (type) != UNION_TYPE)
6293       && !incremental)
6294     init = convert (type, integer_zero_node);
6295   else if (!incremental)
6296     {
6297       init = build_constructor (type, NULL_TREE);
6298       TREE_CONSTANT (init) = 1;
6299       TREE_STATIC (init) = 1;
6300     }
6301   else
6302     {
6303       assemble_zeros (int_size_in_bytes (type));
6304       init = error_mark_node;
6305     }
6306
6307   return init;
6308 }
6309
6310 static tree
6311 ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
6312                          tree *maybe_tree)
6313 {
6314   tree expr_tree;
6315   tree length_tree;
6316
6317   switch (ffebld_op (arg))
6318     {
6319     case FFEBLD_opCONTER:       /* For F90, check 0-length. */
6320       if (ffetarget_length_character1
6321           (ffebld_constant_character1
6322            (ffebld_conter (arg))) == 0)
6323         {
6324           *maybe_tree = integer_zero_node;
6325           return convert (tree_type, integer_zero_node);
6326         }
6327
6328       *maybe_tree = integer_one_node;
6329       expr_tree = build_int_2 (*ffetarget_text_character1
6330                                (ffebld_constant_character1
6331                                 (ffebld_conter (arg))),
6332                                0);
6333       TREE_TYPE (expr_tree) = tree_type;
6334       return expr_tree;
6335
6336     case FFEBLD_opSYMTER:
6337     case FFEBLD_opARRAYREF:
6338     case FFEBLD_opFUNCREF:
6339     case FFEBLD_opSUBSTR:
6340       ffecom_char_args_ (&expr_tree, &length_tree, arg);
6341
6342       if ((expr_tree == error_mark_node)
6343           || (length_tree == error_mark_node))
6344         {
6345           *maybe_tree = error_mark_node;
6346           return error_mark_node;
6347         }
6348
6349       if (integer_zerop (length_tree))
6350         {
6351           *maybe_tree = integer_zero_node;
6352           return convert (tree_type, integer_zero_node);
6353         }
6354
6355       expr_tree
6356         = ffecom_1 (INDIRECT_REF,
6357                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6358                     expr_tree);
6359       expr_tree
6360         = ffecom_2 (ARRAY_REF,
6361                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6362                     expr_tree,
6363                     integer_one_node);
6364       expr_tree = convert (tree_type, expr_tree);
6365
6366       if (TREE_CODE (length_tree) == INTEGER_CST)
6367         *maybe_tree = integer_one_node;
6368       else                      /* Must check length at run time.  */
6369         *maybe_tree
6370           = ffecom_truth_value
6371             (ffecom_2 (GT_EXPR, integer_type_node,
6372                        length_tree,
6373                        ffecom_f2c_ftnlen_zero_node));
6374       return expr_tree;
6375
6376     case FFEBLD_opPAREN:
6377     case FFEBLD_opCONVERT:
6378       if (ffeinfo_size (ffebld_info (arg)) == 0)
6379         {
6380           *maybe_tree = integer_zero_node;
6381           return convert (tree_type, integer_zero_node);
6382         }
6383       return ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6384                                       maybe_tree);
6385
6386     case FFEBLD_opCONCATENATE:
6387       {
6388         tree maybe_left;
6389         tree maybe_right;
6390         tree expr_left;
6391         tree expr_right;
6392
6393         expr_left = ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6394                                              &maybe_left);
6395         expr_right = ffecom_intrinsic_ichar_ (tree_type, ffebld_right (arg),
6396                                               &maybe_right);
6397         *maybe_tree = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
6398                                 maybe_left,
6399                                 maybe_right);
6400         expr_tree = ffecom_3 (COND_EXPR, tree_type,
6401                               maybe_left,
6402                               expr_left,
6403                               expr_right);
6404         return expr_tree;
6405       }
6406
6407     default:
6408       assert ("bad op in ICHAR" == NULL);
6409       return error_mark_node;
6410     }
6411 }
6412
6413 /* ffecom_intrinsic_len_ -- Return length info for char arg (LEN())
6414
6415    tree length_arg;
6416    ffebld expr;
6417    length_arg = ffecom_intrinsic_len_ (expr);
6418
6419    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
6420    subexpressions by constructing the appropriate tree for the
6421    length-of-character-text argument in a calling sequence.  */
6422
6423 static tree
6424 ffecom_intrinsic_len_ (ffebld expr)
6425 {
6426   ffetargetCharacter1 val;
6427   tree length;
6428
6429   switch (ffebld_op (expr))
6430     {
6431     case FFEBLD_opCONTER:
6432       val = ffebld_constant_character1 (ffebld_conter (expr));
6433       length = build_int_2 (ffetarget_length_character1 (val), 0);
6434       TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6435       break;
6436
6437     case FFEBLD_opSYMTER:
6438       {
6439         ffesymbol s = ffebld_symter (expr);
6440         tree item;
6441
6442         item = ffesymbol_hook (s).decl_tree;
6443         if (item == NULL_TREE)
6444           {
6445             s = ffecom_sym_transform_ (s);
6446             item = ffesymbol_hook (s).decl_tree;
6447           }
6448         if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
6449           {
6450             if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
6451               length = ffesymbol_hook (s).length_tree;
6452             else
6453               {
6454                 length = build_int_2 (ffesymbol_size (s), 0);
6455                 TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6456               }
6457           }
6458         else if (item == error_mark_node)
6459           length = error_mark_node;
6460         else                    /* FFEINFO_kindFUNCTION: */
6461           length = NULL_TREE;
6462       }
6463       break;
6464
6465     case FFEBLD_opARRAYREF:
6466       length = ffecom_intrinsic_len_ (ffebld_left (expr));
6467       break;
6468
6469     case FFEBLD_opSUBSTR:
6470       {
6471         ffebld start;
6472         ffebld end;
6473         ffebld thing = ffebld_right (expr);
6474         tree start_tree;
6475         tree end_tree;
6476
6477         assert (ffebld_op (thing) == FFEBLD_opITEM);
6478         start = ffebld_head (thing);
6479         thing = ffebld_trail (thing);
6480         assert (ffebld_trail (thing) == NULL);
6481         end = ffebld_head (thing);
6482
6483         length = ffecom_intrinsic_len_ (ffebld_left (expr));
6484
6485         if (length == error_mark_node)
6486           break;
6487
6488         if (start == NULL)
6489           {
6490             if (end == NULL)
6491               ;
6492             else
6493               {
6494                 length = convert (ffecom_f2c_ftnlen_type_node,
6495                                   ffecom_expr (end));
6496               }
6497           }
6498         else
6499           {
6500             start_tree = convert (ffecom_f2c_ftnlen_type_node,
6501                                   ffecom_expr (start));
6502
6503             if (start_tree == error_mark_node)
6504               {
6505                 length = error_mark_node;
6506                 break;
6507               }
6508
6509             if (end == NULL)
6510               {
6511                 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6512                                    ffecom_f2c_ftnlen_one_node,
6513                                    ffecom_2 (MINUS_EXPR,
6514                                              ffecom_f2c_ftnlen_type_node,
6515                                              length,
6516                                              start_tree));
6517               }
6518             else
6519               {
6520                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
6521                                     ffecom_expr (end));
6522
6523                 if (end_tree == error_mark_node)
6524                   {
6525                     length = error_mark_node;
6526                     break;
6527                   }
6528
6529                 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6530                                    ffecom_f2c_ftnlen_one_node,
6531                                    ffecom_2 (MINUS_EXPR,
6532                                              ffecom_f2c_ftnlen_type_node,
6533                                              end_tree, start_tree));
6534               }
6535           }
6536       }
6537       break;
6538
6539     case FFEBLD_opCONCATENATE:
6540       length
6541         = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6542                     ffecom_intrinsic_len_ (ffebld_left (expr)),
6543                     ffecom_intrinsic_len_ (ffebld_right (expr)));
6544       break;
6545
6546     case FFEBLD_opFUNCREF:
6547     case FFEBLD_opCONVERT:
6548       length = build_int_2 (ffebld_size (expr), 0);
6549       TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6550       break;
6551
6552     default:
6553       assert ("bad op for single char arg expr" == NULL);
6554       length = ffecom_f2c_ftnlen_zero_node;
6555       break;
6556     }
6557
6558   assert (length != NULL_TREE);
6559
6560   return length;
6561 }
6562
6563 /* Handle CHARACTER assignments.
6564
6565    Generates code to do the assignment.  Used by ordinary assignment
6566    statement handler ffecom_let_stmt and by statement-function
6567    handler to generate code for a statement function.  */
6568
6569 static void
6570 ffecom_let_char_ (tree dest_tree, tree dest_length,
6571                   ffetargetCharacterSize dest_size, ffebld source)
6572 {
6573   ffecomConcatList_ catlist;
6574   tree source_length;
6575   tree source_tree;
6576   tree expr_tree;
6577
6578   if ((dest_tree == error_mark_node)
6579       || (dest_length == error_mark_node))
6580     return;
6581
6582   assert (dest_tree != NULL_TREE);
6583   assert (dest_length != NULL_TREE);
6584
6585   /* Source might be an opCONVERT, which just means it is a different size
6586      than the destination.  Since the underlying implementation here handles
6587      that (directly or via the s_copy or s_cat run-time-library functions),
6588      we don't need the "convenience" of an opCONVERT that tells us to
6589      truncate or blank-pad, particularly since the resulting implementation
6590      would probably be slower than otherwise. */
6591
6592   while (ffebld_op (source) == FFEBLD_opCONVERT)
6593     source = ffebld_left (source);
6594
6595   catlist = ffecom_concat_list_new_ (source, dest_size);
6596   switch (ffecom_concat_list_count_ (catlist))
6597     {
6598     case 0:                     /* Shouldn't happen, but in case it does... */
6599       ffecom_concat_list_kill_ (catlist);
6600       source_tree = null_pointer_node;
6601       source_length = ffecom_f2c_ftnlen_zero_node;
6602       expr_tree = build_tree_list (NULL_TREE, dest_tree);
6603       TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6604       TREE_CHAIN (TREE_CHAIN (expr_tree))
6605         = build_tree_list (NULL_TREE, dest_length);
6606       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6607         = build_tree_list (NULL_TREE, source_length);
6608
6609       expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6610       TREE_SIDE_EFFECTS (expr_tree) = 1;
6611
6612       expand_expr_stmt (expr_tree);
6613
6614       return;
6615
6616     case 1:                     /* The (fairly) easy case. */
6617       ffecom_char_args_ (&source_tree, &source_length,
6618                          ffecom_concat_list_expr_ (catlist, 0));
6619       ffecom_concat_list_kill_ (catlist);
6620       assert (source_tree != NULL_TREE);
6621       assert (source_length != NULL_TREE);
6622
6623       if ((source_tree == error_mark_node)
6624           || (source_length == error_mark_node))
6625         return;
6626
6627       if (dest_size == 1)
6628         {
6629           dest_tree
6630             = ffecom_1 (INDIRECT_REF,
6631                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6632                                                       (dest_tree))),
6633                         dest_tree);
6634           dest_tree
6635             = ffecom_2 (ARRAY_REF,
6636                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6637                                                       (dest_tree))),
6638                         dest_tree,
6639                         integer_one_node);
6640           source_tree
6641             = ffecom_1 (INDIRECT_REF,
6642                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6643                                                       (source_tree))),
6644                         source_tree);
6645           source_tree
6646             = ffecom_2 (ARRAY_REF,
6647                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6648                                                       (source_tree))),
6649                         source_tree,
6650                         integer_one_node);
6651
6652           expr_tree = ffecom_modify (void_type_node, dest_tree, source_tree);
6653
6654           expand_expr_stmt (expr_tree);
6655
6656           return;
6657         }
6658
6659       expr_tree = build_tree_list (NULL_TREE, dest_tree);
6660       TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6661       TREE_CHAIN (TREE_CHAIN (expr_tree))
6662         = build_tree_list (NULL_TREE, dest_length);
6663       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6664         = build_tree_list (NULL_TREE, source_length);
6665
6666       expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6667       TREE_SIDE_EFFECTS (expr_tree) = 1;
6668
6669       expand_expr_stmt (expr_tree);
6670
6671       return;
6672
6673     default:                    /* Must actually concatenate things. */
6674       break;
6675     }
6676
6677   /* Heavy-duty concatenation. */
6678
6679   {
6680     int count = ffecom_concat_list_count_ (catlist);
6681     int i;
6682     tree lengths;
6683     tree items;
6684     tree length_array;
6685     tree item_array;
6686     tree citem;
6687     tree clength;
6688
6689     {
6690       tree hook;
6691
6692       hook = ffebld_nonter_hook (source);
6693       assert (hook);
6694       assert (TREE_CODE (hook) == TREE_VEC);
6695       assert (TREE_VEC_LENGTH (hook) == 2);
6696       length_array = lengths = TREE_VEC_ELT (hook, 0);
6697       item_array = items = TREE_VEC_ELT (hook, 1);
6698     }
6699
6700     for (i = 0; i < count; ++i)
6701       {
6702         ffecom_char_args_ (&citem, &clength,
6703                            ffecom_concat_list_expr_ (catlist, i));
6704         if ((citem == error_mark_node)
6705             || (clength == error_mark_node))
6706           {
6707             ffecom_concat_list_kill_ (catlist);
6708             return;
6709           }
6710
6711         items
6712           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
6713                       ffecom_modify (void_type_node,
6714                                      ffecom_2 (ARRAY_REF,
6715                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
6716                                                item_array,
6717                                                build_int_2 (i, 0)),
6718                                      citem),
6719                       items);
6720         lengths
6721           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
6722                       ffecom_modify (void_type_node,
6723                                      ffecom_2 (ARRAY_REF,
6724                    TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
6725                                                length_array,
6726                                                build_int_2 (i, 0)),
6727                                      clength),
6728                       lengths);
6729       }
6730
6731     expr_tree = build_tree_list (NULL_TREE, dest_tree);
6732     TREE_CHAIN (expr_tree)
6733       = build_tree_list (NULL_TREE,
6734                          ffecom_1 (ADDR_EXPR,
6735                                    build_pointer_type (TREE_TYPE (items)),
6736                                    items));
6737     TREE_CHAIN (TREE_CHAIN (expr_tree))
6738       = build_tree_list (NULL_TREE,
6739                          ffecom_1 (ADDR_EXPR,
6740                                    build_pointer_type (TREE_TYPE (lengths)),
6741                                    lengths));
6742     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6743       = build_tree_list
6744         (NULL_TREE,
6745          ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
6746                    convert (ffecom_f2c_ftnlen_type_node,
6747                             build_int_2 (count, 0))));
6748     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree))))
6749       = build_tree_list (NULL_TREE, dest_length);
6750
6751     expr_tree = ffecom_call_gfrt (FFECOM_gfrtCAT, expr_tree, NULL_TREE);
6752     TREE_SIDE_EFFECTS (expr_tree) = 1;
6753
6754     expand_expr_stmt (expr_tree);
6755   }
6756
6757   ffecom_concat_list_kill_ (catlist);
6758 }
6759
6760 /* ffecom_make_gfrt_ -- Make initial info for run-time routine
6761
6762    ffecomGfrt ix;
6763    ffecom_make_gfrt_(ix);
6764
6765    Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL
6766    for the indicated run-time routine (ix).  */
6767
6768 static void
6769 ffecom_make_gfrt_ (ffecomGfrt ix)
6770 {
6771   tree t;
6772   tree ttype;
6773
6774   switch (ffecom_gfrt_type_[ix])
6775     {
6776     case FFECOM_rttypeVOID_:
6777       ttype = void_type_node;
6778       break;
6779
6780     case FFECOM_rttypeVOIDSTAR_:
6781       ttype = TREE_TYPE (null_pointer_node);    /* `void *'. */
6782       break;
6783
6784     case FFECOM_rttypeFTNINT_:
6785       ttype = ffecom_f2c_ftnint_type_node;
6786       break;
6787
6788     case FFECOM_rttypeINTEGER_:
6789       ttype = ffecom_f2c_integer_type_node;
6790       break;
6791
6792     case FFECOM_rttypeLONGINT_:
6793       ttype = ffecom_f2c_longint_type_node;
6794       break;
6795
6796     case FFECOM_rttypeLOGICAL_:
6797       ttype = ffecom_f2c_logical_type_node;
6798       break;
6799
6800     case FFECOM_rttypeREAL_F2C_:
6801       ttype = double_type_node;
6802       break;
6803
6804     case FFECOM_rttypeREAL_GNU_:
6805       ttype = float_type_node;
6806       break;
6807
6808     case FFECOM_rttypeCOMPLEX_F2C_:
6809       ttype = void_type_node;
6810       break;
6811
6812     case FFECOM_rttypeCOMPLEX_GNU_:
6813       ttype = ffecom_f2c_complex_type_node;
6814       break;
6815
6816     case FFECOM_rttypeDOUBLE_:
6817       ttype = double_type_node;
6818       break;
6819
6820     case FFECOM_rttypeDOUBLEREAL_:
6821       ttype = ffecom_f2c_doublereal_type_node;
6822       break;
6823
6824     case FFECOM_rttypeDBLCMPLX_F2C_:
6825       ttype = void_type_node;
6826       break;
6827
6828     case FFECOM_rttypeDBLCMPLX_GNU_:
6829       ttype = ffecom_f2c_doublecomplex_type_node;
6830       break;
6831
6832     case FFECOM_rttypeCHARACTER_:
6833       ttype = void_type_node;
6834       break;
6835
6836     default:
6837       ttype = NULL;
6838       assert ("bad rttype" == NULL);
6839       break;
6840     }
6841
6842   ttype = build_function_type (ttype, NULL_TREE);
6843   t = build_decl (FUNCTION_DECL,
6844                   get_identifier (ffecom_gfrt_name_[ix]),
6845                   ttype);
6846   DECL_EXTERNAL (t) = 1;
6847   TREE_READONLY (t) = ffecom_gfrt_const_[ix] ? 1 : 0;
6848   TREE_PUBLIC (t) = 1;
6849   TREE_THIS_VOLATILE (t) = ffecom_gfrt_volatile_[ix] ? 1 : 0;
6850
6851   /* Sanity check:  A function that's const cannot be volatile.  */
6852
6853   assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_volatile_[ix] : 1);
6854
6855   /* Sanity check: A function that's const cannot return complex.  */
6856
6857   assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_complex_[ix] : 1);
6858
6859   t = start_decl (t, TRUE);
6860
6861   finish_decl (t, NULL_TREE, TRUE);
6862
6863   ffecom_gfrt_[ix] = t;
6864 }
6865
6866 /* Phase 1 pass over each member of a COMMON/EQUIVALENCE group.  */
6867
6868 static void
6869 ffecom_member_phase1_ (ffestorag mst UNUSED, ffestorag st)
6870 {
6871   ffesymbol s = ffestorag_symbol (st);
6872
6873   if (ffesymbol_namelisted (s))
6874     ffecom_member_namelisted_ = TRUE;
6875 }
6876
6877 /* Phase 2 pass over each member of a COMMON/EQUIVALENCE group.  Declare
6878    the member so debugger will see it.  Otherwise nobody should be
6879    referencing the member.  */
6880
6881 static void
6882 ffecom_member_phase2_ (ffestorag mst, ffestorag st)
6883 {
6884   ffesymbol s;
6885   tree t;
6886   tree mt;
6887   tree type;
6888
6889   if ((mst == NULL)
6890       || ((mt = ffestorag_hook (mst)) == NULL)
6891       || (mt == error_mark_node))
6892     return;
6893
6894   if ((st == NULL)
6895       || ((s = ffestorag_symbol (st)) == NULL))
6896     return;
6897
6898   type = ffecom_type_localvar_ (s,
6899                                 ffesymbol_basictype (s),
6900                                 ffesymbol_kindtype (s));
6901   if (type == error_mark_node)
6902     return;
6903
6904   t = build_decl (VAR_DECL,
6905                   ffecom_get_identifier_ (ffesymbol_text (s)),
6906                   type);
6907
6908   TREE_STATIC (t) = TREE_STATIC (mt);
6909   DECL_INITIAL (t) = NULL_TREE;
6910   TREE_ASM_WRITTEN (t) = 1;
6911   TREE_USED (t) = 1;
6912
6913   SET_DECL_RTL (t,
6914                 gen_rtx (MEM, TYPE_MODE (type),
6915                          plus_constant (XEXP (DECL_RTL (mt), 0),
6916                                         ffestorag_modulo (mst)
6917                                         + ffestorag_offset (st)
6918                                         - ffestorag_offset (mst))));
6919
6920   t = start_decl (t, FALSE);
6921
6922   finish_decl (t, NULL_TREE, FALSE);
6923 }
6924
6925 /* Prepare source expression for assignment into a destination perhaps known
6926    to be of a specific size.  */
6927
6928 static void
6929 ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size, ffebld source)
6930 {
6931   ffecomConcatList_ catlist;
6932   int count;
6933   int i;
6934   tree ltmp;
6935   tree itmp;
6936   tree tempvar = NULL_TREE;
6937
6938   while (ffebld_op (source) == FFEBLD_opCONVERT)
6939     source = ffebld_left (source);
6940
6941   catlist = ffecom_concat_list_new_ (source, dest_size);
6942   count = ffecom_concat_list_count_ (catlist);
6943
6944   if (count >= 2)
6945     {
6946       ltmp
6947         = ffecom_make_tempvar ("let_char_len", ffecom_f2c_ftnlen_type_node,
6948                                FFETARGET_charactersizeNONE, count);
6949       itmp
6950         = ffecom_make_tempvar ("let_char_item", ffecom_f2c_address_type_node,
6951                                FFETARGET_charactersizeNONE, count);
6952
6953       tempvar = make_tree_vec (2);
6954       TREE_VEC_ELT (tempvar, 0) = ltmp;
6955       TREE_VEC_ELT (tempvar, 1) = itmp;
6956     }
6957
6958   for (i = 0; i < count; ++i)
6959     ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist, i));
6960
6961   ffecom_concat_list_kill_ (catlist);
6962
6963   if (tempvar)
6964     {
6965       ffebld_nonter_set_hook (source, tempvar);
6966       current_binding_level->prep_state = 1;
6967     }
6968 }
6969
6970 /* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order
6971
6972    Ignores STAR (alternate-return) dummies.  All other get exec-transitioned
6973    (which generates their trees) and then their trees get push_parm_decl'd.
6974
6975    The second arg is TRUE if the dummies are for a statement function, in
6976    which case lengths are not pushed for character arguments (since they are
6977    always known by both the caller and the callee, though the code allows
6978    for someday permitting CHAR*(*) stmtfunc dummies).  */
6979
6980 static void
6981 ffecom_push_dummy_decls_ (ffebld dummy_list, bool stmtfunc)
6982 {
6983   ffebld dummy;
6984   ffebld dumlist;
6985   ffesymbol s;
6986   tree parm;
6987
6988   ffecom_transform_only_dummies_ = TRUE;
6989
6990   /* First push the parms corresponding to actual dummy "contents".  */
6991
6992   for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
6993     {
6994       dummy = ffebld_head (dumlist);
6995       switch (ffebld_op (dummy))
6996         {
6997         case FFEBLD_opSTAR:
6998         case FFEBLD_opANY:
6999           continue;             /* Forget alternate returns. */
7000
7001         default:
7002           break;
7003         }
7004       assert (ffebld_op (dummy) == FFEBLD_opSYMTER);
7005       s = ffebld_symter (dummy);
7006       parm = ffesymbol_hook (s).decl_tree;
7007       if (parm == NULL_TREE)
7008         {
7009           s = ffecom_sym_transform_ (s);
7010           parm = ffesymbol_hook (s).decl_tree;
7011           assert (parm != NULL_TREE);
7012         }
7013       if (parm != error_mark_node)
7014         push_parm_decl (parm);
7015     }
7016
7017   /* Then, for CHARACTER dummies, push the parms giving their lengths.  */
7018
7019   for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7020     {
7021       dummy = ffebld_head (dumlist);
7022       switch (ffebld_op (dummy))
7023         {
7024         case FFEBLD_opSTAR:
7025         case FFEBLD_opANY:
7026           continue;             /* Forget alternate returns, they mean
7027                                    NOTHING! */
7028
7029         default:
7030           break;
7031         }
7032       s = ffebld_symter (dummy);
7033       if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
7034         continue;               /* Only looking for CHARACTER arguments. */
7035       if (stmtfunc && (ffesymbol_size (s) != FFETARGET_charactersizeNONE))
7036         continue;               /* Stmtfunc arg with known size needs no
7037                                    length param. */
7038       if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
7039         continue;               /* Only looking for variables and arrays. */
7040       parm = ffesymbol_hook (s).length_tree;
7041       assert (parm != NULL_TREE);
7042       if (parm != error_mark_node)
7043         push_parm_decl (parm);
7044     }
7045
7046   ffecom_transform_only_dummies_ = FALSE;
7047 }
7048
7049 /* ffecom_start_progunit_ -- Beginning of program unit
7050
7051    Does GNU back end stuff necessary to teach it about the start of its
7052    equivalent of a Fortran program unit.  */
7053
7054 static void
7055 ffecom_start_progunit_ ()
7056 {
7057   ffesymbol fn = ffecom_primary_entry_;
7058   ffebld arglist;
7059   tree id;                      /* Identifier (name) of function. */
7060   tree type;                    /* Type of function. */
7061   tree result;                  /* Result of function. */
7062   ffeinfoBasictype bt;
7063   ffeinfoKindtype kt;
7064   ffeglobal g;
7065   ffeglobalType gt;
7066   ffeglobalType egt = FFEGLOBAL_type;
7067   bool charfunc;
7068   bool cmplxfunc;
7069   bool altentries = (ffecom_num_entrypoints_ != 0);
7070   bool multi
7071   = altentries
7072   && (ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
7073   && (ffecom_master_bt_ == FFEINFO_basictypeNONE);
7074   bool main_program = FALSE;
7075   location_t old_loc = input_location;
7076
7077   assert (fn != NULL);
7078   assert (ffesymbol_hook (fn).decl_tree == NULL_TREE);
7079
7080   input_filename = ffesymbol_where_filename (fn);
7081   input_line = ffesymbol_where_filelinenum (fn);
7082
7083   switch (ffecom_primary_entry_kind_)
7084     {
7085     case FFEINFO_kindPROGRAM:
7086       main_program = TRUE;
7087       gt = FFEGLOBAL_typeMAIN;
7088       bt = FFEINFO_basictypeNONE;
7089       kt = FFEINFO_kindtypeNONE;
7090       type = ffecom_tree_fun_type_void;
7091       charfunc = FALSE;
7092       cmplxfunc = FALSE;
7093       break;
7094
7095     case FFEINFO_kindBLOCKDATA:
7096       gt = FFEGLOBAL_typeBDATA;
7097       bt = FFEINFO_basictypeNONE;
7098       kt = FFEINFO_kindtypeNONE;
7099       type = ffecom_tree_fun_type_void;
7100       charfunc = FALSE;
7101       cmplxfunc = FALSE;
7102       break;
7103
7104     case FFEINFO_kindFUNCTION:
7105       gt = FFEGLOBAL_typeFUNC;
7106       egt = FFEGLOBAL_typeEXT;
7107       bt = ffesymbol_basictype (fn);
7108       kt = ffesymbol_kindtype (fn);
7109       if (bt == FFEINFO_basictypeNONE)
7110         {
7111           ffeimplic_establish_symbol (fn);
7112           if (ffesymbol_funcresult (fn) != NULL)
7113             ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
7114           bt = ffesymbol_basictype (fn);
7115           kt = ffesymbol_kindtype (fn);
7116         }
7117
7118       if (multi)
7119         charfunc = cmplxfunc = FALSE;
7120       else if (bt == FFEINFO_basictypeCHARACTER)
7121         charfunc = TRUE, cmplxfunc = FALSE;
7122       else if ((bt == FFEINFO_basictypeCOMPLEX)
7123                && ffesymbol_is_f2c (fn)
7124                && !altentries)
7125         charfunc = FALSE, cmplxfunc = TRUE;
7126       else
7127         charfunc = cmplxfunc = FALSE;
7128
7129       if (multi || charfunc)
7130         type = ffecom_tree_fun_type_void;
7131       else if (ffesymbol_is_f2c (fn) && !altentries)
7132         type = ffecom_tree_fun_type[bt][kt];
7133       else
7134         type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
7135
7136       if ((type == NULL_TREE)
7137           || (TREE_TYPE (type) == NULL_TREE))
7138         type = ffecom_tree_fun_type_void;       /* _sym_exec_transition. */
7139       break;
7140
7141     case FFEINFO_kindSUBROUTINE:
7142       gt = FFEGLOBAL_typeSUBR;
7143       egt = FFEGLOBAL_typeEXT;
7144       bt = FFEINFO_basictypeNONE;
7145       kt = FFEINFO_kindtypeNONE;
7146       if (ffecom_is_altreturning_)
7147         type = ffecom_tree_subr_type;
7148       else
7149         type = ffecom_tree_fun_type_void;
7150       charfunc = FALSE;
7151       cmplxfunc = FALSE;
7152       break;
7153
7154     default:
7155       assert ("say what??" == NULL);
7156       /* Fall through. */
7157     case FFEINFO_kindANY:
7158       gt = FFEGLOBAL_typeANY;
7159       bt = FFEINFO_basictypeNONE;
7160       kt = FFEINFO_kindtypeNONE;
7161       type = error_mark_node;
7162       charfunc = FALSE;
7163       cmplxfunc = FALSE;
7164       break;
7165     }
7166
7167   if (altentries)
7168     {
7169       id = ffecom_get_invented_identifier ("__g77_masterfun_%s",
7170                                            ffesymbol_text (fn));
7171     }
7172 #if FFETARGET_isENFORCED_MAIN
7173   else if (main_program)
7174     id = get_identifier (FFETARGET_nameENFORCED_MAIN_NAME);
7175 #endif
7176   else
7177     id = ffecom_get_external_identifier_ (fn);
7178
7179   start_function (id,
7180                   type,
7181                   0,            /* nested/inline */
7182                   !altentries); /* TREE_PUBLIC */
7183
7184   TREE_USED (current_function_decl) = 1;        /* Avoid spurious warning if altentries. */
7185
7186   if (!altentries
7187       && ((g = ffesymbol_global (fn)) != NULL)
7188       && ((ffeglobal_type (g) == gt)
7189           || (ffeglobal_type (g) == egt)))
7190     {
7191       ffeglobal_set_hook (g, current_function_decl);
7192     }
7193
7194   /* Arg handling needs exec-transitioned ffesymbols to work with.  But
7195      exec-transitioning needs current_function_decl to be filled in.  So we
7196      do these things in two phases. */
7197
7198   if (altentries)
7199     {                           /* 1st arg identifies which entrypoint. */
7200       ffecom_which_entrypoint_decl_
7201         = build_decl (PARM_DECL,
7202                       ffecom_get_invented_identifier ("__g77_%s",
7203                                                       "which_entrypoint"),
7204                       integer_type_node);
7205       push_parm_decl (ffecom_which_entrypoint_decl_);
7206     }
7207
7208   if (charfunc
7209       || cmplxfunc
7210       || multi)
7211     {                           /* Arg for result (return value). */
7212       tree type;
7213       tree length;
7214
7215       if (charfunc)
7216         type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
7217       else if (cmplxfunc)
7218         type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
7219       else
7220         type = ffecom_multi_type_node_;
7221
7222       result = ffecom_get_invented_identifier ("__g77_%s", "result");
7223
7224       /* Make length arg _and_ enhance type info for CHAR arg itself.  */
7225
7226       if (charfunc)
7227         length = ffecom_char_enhance_arg_ (&type, fn);
7228       else
7229         length = NULL_TREE;     /* Not ref'd if !charfunc. */
7230
7231       type = build_pointer_type (type);
7232       result = build_decl (PARM_DECL, result, type);
7233
7234       push_parm_decl (result);
7235       if (multi)
7236         ffecom_multi_retval_ = result;
7237       else
7238         ffecom_func_result_ = result;
7239
7240       if (charfunc)
7241         {
7242           push_parm_decl (length);
7243           ffecom_func_length_ = length;
7244         }
7245     }
7246
7247   if (ffecom_primary_entry_is_proc_)
7248     {
7249       if (altentries)
7250         arglist = ffecom_master_arglist_;
7251       else
7252         arglist = ffesymbol_dummyargs (fn);
7253       ffecom_push_dummy_decls_ (arglist, FALSE);
7254     }
7255
7256   if (TREE_CODE (current_function_decl) != ERROR_MARK)
7257     store_parm_decls (main_program ? 1 : 0);
7258
7259   ffecom_start_compstmt ();
7260   /* Disallow temp vars at this level.  */
7261   current_binding_level->prep_state = 2;
7262
7263   input_location = old_loc;
7264
7265   /* This handles any symbols still untransformed, in case -g specified.
7266      This used to be done in ffecom_finish_progunit, but it turns out to
7267      be necessary to do it here so that statement functions are
7268      expanded before code.  But don't bother for BLOCK DATA.  */
7269
7270   if (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
7271     ffesymbol_drive (ffecom_finish_symbol_transform_);
7272 }
7273
7274 /* ffecom_sym_transform_ -- Transform FFE sym into backend sym
7275
7276    ffesymbol s;
7277    ffecom_sym_transform_(s);
7278
7279    The ffesymbol_hook info for s is updated with appropriate backend info
7280    on the symbol.  */
7281
7282 static ffesymbol
7283 ffecom_sym_transform_ (ffesymbol s)
7284 {
7285   tree t;                       /* Transformed thingy. */
7286   tree tlen;                    /* Length if CHAR*(*). */
7287   bool addr;                    /* Is t the address of the thingy? */
7288   ffeinfoBasictype bt;
7289   ffeinfoKindtype kt;
7290   ffeglobal g;
7291   location_t old_loc = input_location;
7292
7293   /* Must ensure special ASSIGN variables are declared at top of outermost
7294      block, else they'll end up in the innermost block when their first
7295      ASSIGN is seen, which leaves them out of scope when they're the
7296      subject of a GOTO or I/O statement.
7297
7298      We make this variable even if -fugly-assign.  Just let it go unused,
7299      in case it turns out there are cases where we really want to use this
7300      variable anyway (e.g. ASSIGN to INTEGER*2 variable).  */
7301
7302   if (! ffecom_transform_only_dummies_
7303       && ffesymbol_assigned (s)
7304       && ! ffesymbol_hook (s).assign_tree)
7305     s = ffecom_sym_transform_assign_ (s);
7306
7307   if (ffesymbol_sfdummyparent (s) == NULL)
7308     {
7309       input_filename = ffesymbol_where_filename (s);
7310       input_line = ffesymbol_where_filelinenum (s);
7311     }
7312   else
7313     {
7314       ffesymbol sf = ffesymbol_sfdummyparent (s);
7315
7316       input_filename = ffesymbol_where_filename (sf);
7317       input_line = ffesymbol_where_filelinenum (sf);
7318     }
7319
7320   bt = ffeinfo_basictype (ffebld_info (s));
7321   kt = ffeinfo_kindtype (ffebld_info (s));
7322
7323   t = NULL_TREE;
7324   tlen = NULL_TREE;
7325   addr = FALSE;
7326
7327   switch (ffesymbol_kind (s))
7328     {
7329     case FFEINFO_kindNONE:
7330       switch (ffesymbol_where (s))
7331         {
7332         case FFEINFO_whereDUMMY:        /* Subroutine or function. */
7333           assert (ffecom_transform_only_dummies_);
7334
7335           /* Before 0.4, this could be ENTITY/DUMMY, but see
7336              ffestu_sym_end_transition -- no longer true (in particular, if
7337              it could be an ENTITY, it _will_ be made one, so that
7338              possibility won't come through here).  So we never make length
7339              arg for CHARACTER type.  */
7340
7341           t = build_decl (PARM_DECL,
7342                           ffecom_get_identifier_ (ffesymbol_text (s)),
7343                           ffecom_tree_ptr_to_subr_type);
7344           DECL_ARTIFICIAL (t) = 1;
7345           addr = TRUE;
7346           break;
7347
7348         case FFEINFO_whereGLOBAL:       /* Subroutine or function. */
7349           assert (!ffecom_transform_only_dummies_);
7350
7351           if (((g = ffesymbol_global (s)) != NULL)
7352               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7353                   || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7354                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
7355               && (ffeglobal_hook (g) != NULL_TREE)
7356               && ffe_is_globals ())
7357             {
7358               t = ffeglobal_hook (g);
7359               break;
7360             }
7361
7362           t = build_decl (FUNCTION_DECL,
7363                           ffecom_get_external_identifier_ (s),
7364                           ffecom_tree_subr_type);       /* Assume subr. */
7365           DECL_EXTERNAL (t) = 1;
7366           TREE_PUBLIC (t) = 1;
7367
7368           t = start_decl (t, FALSE);
7369           finish_decl (t, NULL_TREE, FALSE);
7370
7371           if ((g != NULL)
7372               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7373                   || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7374                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
7375             ffeglobal_set_hook (g, t);
7376
7377           ffecom_save_tree_forever (t);
7378
7379           break;
7380
7381         default:
7382           assert ("NONE where unexpected" == NULL);
7383           /* Fall through. */
7384         case FFEINFO_whereANY:
7385           break;
7386         }
7387       break;
7388
7389     case FFEINFO_kindENTITY:
7390       switch (ffeinfo_where (ffesymbol_info (s)))
7391         {
7392
7393         case FFEINFO_whereCONSTANT:
7394           /* ~~Debugging info needed? */
7395           assert (!ffecom_transform_only_dummies_);
7396           t = error_mark_node;  /* Shouldn't ever see this in expr. */
7397           break;
7398
7399         case FFEINFO_whereLOCAL:
7400           assert (!ffecom_transform_only_dummies_);
7401
7402           {
7403             ffestorag st = ffesymbol_storage (s);
7404             tree type;
7405
7406             type = ffecom_type_localvar_ (s, bt, kt);
7407
7408             if (type == error_mark_node)
7409               {
7410                 t = error_mark_node;
7411                 break;
7412               }
7413
7414             if ((st != NULL)
7415                 && (ffestorag_size (st) == 0))
7416               {
7417                 t = error_mark_node;
7418                 break;
7419               }
7420
7421             if ((st != NULL)
7422                 && (ffestorag_parent (st) != NULL))
7423               {                 /* Child of EQUIVALENCE parent. */
7424                 ffestorag est;
7425                 tree et;
7426                 ffetargetOffset offset;
7427
7428                 est = ffestorag_parent (st);
7429                 ffecom_transform_equiv_ (est);
7430
7431                 et = ffestorag_hook (est);
7432                 assert (et != NULL_TREE);
7433
7434                 if (! TREE_STATIC (et))
7435                   put_var_into_stack (et, /*rescan=*/true);
7436
7437                 offset = ffestorag_modulo (est)
7438                   + ffestorag_offset (ffesymbol_storage (s))
7439                   - ffestorag_offset (est);
7440
7441                 ffecom_debug_kludge_ (et, "EQUIVALENCE", s, type, offset);
7442
7443                 /* (t_type *) (((char *) &et) + offset) */
7444
7445                 t = convert (string_type_node,  /* (char *) */
7446                              ffecom_1 (ADDR_EXPR,
7447                                        build_pointer_type (TREE_TYPE (et)),
7448                                        et));
7449                 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
7450                               t,
7451                               build_int_2 (offset, 0));
7452                 t = convert (build_pointer_type (type),
7453                              t);
7454                 TREE_CONSTANT (t) = staticp (et);
7455
7456                 addr = TRUE;
7457               }
7458             else
7459               {
7460                 tree initexpr;
7461                 bool init = ffesymbol_is_init (s);
7462
7463                 t = build_decl (VAR_DECL,
7464                                 ffecom_get_identifier_ (ffesymbol_text (s)),
7465                                 type);
7466
7467                 if (init
7468                     || ffesymbol_namelisted (s)
7469 #ifdef FFECOM_sizeMAXSTACKITEM
7470                     || ((st != NULL)
7471                         && (ffestorag_size (st) > FFECOM_sizeMAXSTACKITEM))
7472 #endif
7473                     || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
7474                         && (ffecom_primary_entry_kind_
7475                             != FFEINFO_kindBLOCKDATA)
7476                         && (ffesymbol_is_save (s) || ffe_is_saveall ())))
7477                   TREE_STATIC (t) = !ffesymbol_attr (s, FFESYMBOL_attrADJUSTABLE);
7478                 else
7479                   TREE_STATIC (t) = 0;  /* No need to make static. */
7480
7481                 if (init || ffe_is_init_local_zero ())
7482                   DECL_INITIAL (t) = error_mark_node;
7483
7484                 /* Keep -Wunused from complaining about var if it
7485                    is used as sfunc arg or DATA implied-DO.  */
7486                 if (ffesymbol_attrs (s) & FFESYMBOL_attrsSFARG)
7487                   DECL_IN_SYSTEM_HEADER (t) = 1;
7488
7489                 t = start_decl (t, FALSE);
7490
7491                 if (init)
7492                   {
7493                     if (ffesymbol_init (s) != NULL)
7494                       initexpr = ffecom_expr (ffesymbol_init (s));
7495                     else
7496                       initexpr = ffecom_init_zero_ (t);
7497                   }
7498                 else if (ffe_is_init_local_zero ())
7499                   initexpr = ffecom_init_zero_ (t);
7500                 else
7501                   initexpr = NULL_TREE; /* Not ref'd if !init. */
7502
7503                 finish_decl (t, initexpr, FALSE);
7504
7505                 if (st != NULL && DECL_SIZE (t) != error_mark_node)
7506                   {
7507                     assert (TREE_CODE (DECL_SIZE_UNIT (t)) == INTEGER_CST);
7508                     assert (0 == compare_tree_int (DECL_SIZE_UNIT (t),
7509                                                    ffestorag_size (st)));
7510                   }
7511               }
7512           }
7513           break;
7514
7515         case FFEINFO_whereRESULT:
7516           assert (!ffecom_transform_only_dummies_);
7517
7518           if (bt == FFEINFO_basictypeCHARACTER)
7519             {                   /* Result is already in list of dummies, use
7520                                    it (& length). */
7521               t = ffecom_func_result_;
7522               tlen = ffecom_func_length_;
7523               addr = TRUE;
7524               break;
7525             }
7526           if ((ffecom_num_entrypoints_ == 0)
7527               && (bt == FFEINFO_basictypeCOMPLEX)
7528               && (ffesymbol_is_f2c (ffecom_primary_entry_)))
7529             {                   /* Result is already in list of dummies, use
7530                                    it. */
7531               t = ffecom_func_result_;
7532               addr = TRUE;
7533               break;
7534             }
7535           if (ffecom_func_result_ != NULL_TREE)
7536             {
7537               t = ffecom_func_result_;
7538               break;
7539             }
7540           if ((ffecom_num_entrypoints_ != 0)
7541               && (ffecom_master_bt_ == FFEINFO_basictypeNONE))
7542             {
7543               assert (ffecom_multi_retval_ != NULL_TREE);
7544               t = ffecom_1 (INDIRECT_REF, ffecom_multi_type_node_,
7545                             ffecom_multi_retval_);
7546               t = ffecom_2 (COMPONENT_REF, ffecom_tree_type[bt][kt],
7547                             t, ffecom_multi_fields_[bt][kt]);
7548
7549               break;
7550             }
7551
7552           t = build_decl (VAR_DECL,
7553                           ffecom_get_identifier_ (ffesymbol_text (s)),
7554                           ffecom_tree_type[bt][kt]);
7555           TREE_STATIC (t) = 0;  /* Put result on stack. */
7556           t = start_decl (t, FALSE);
7557           finish_decl (t, NULL_TREE, FALSE);
7558
7559           ffecom_func_result_ = t;
7560
7561           break;
7562
7563         case FFEINFO_whereDUMMY:
7564           {
7565             tree type;
7566             ffebld dl;
7567             ffebld dim;
7568             tree low;
7569             tree high;
7570             tree old_sizes;
7571             bool adjustable = FALSE;    /* Conditionally adjustable? */
7572
7573             type = ffecom_tree_type[bt][kt];
7574             if (ffesymbol_sfdummyparent (s) != NULL)
7575               {
7576                 if (current_function_decl == ffecom_outer_function_decl_)
7577                   {                     /* Exec transition before sfunc
7578                                            context; get it later. */
7579                     break;
7580                   }
7581                 t = ffecom_get_identifier_ (ffesymbol_text
7582                                             (ffesymbol_sfdummyparent (s)));
7583               }
7584             else
7585               t = ffecom_get_identifier_ (ffesymbol_text (s));
7586
7587             assert (ffecom_transform_only_dummies_);
7588
7589             old_sizes = get_pending_sizes ();
7590             put_pending_sizes (old_sizes);
7591
7592             if (bt == FFEINFO_basictypeCHARACTER)
7593               tlen = ffecom_char_enhance_arg_ (&type, s);
7594             type = ffecom_check_size_overflow_ (s, type, TRUE);
7595
7596             for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
7597               {
7598                 if (type == error_mark_node)
7599                   break;
7600
7601                 dim = ffebld_head (dl);
7602                 assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
7603                 if ((ffebld_left (dim) == NULL) || ffecom_doing_entry_)
7604                   low = ffecom_integer_one_node;
7605                 else
7606                   low = ffecom_expr (ffebld_left (dim));
7607                 assert (ffebld_right (dim) != NULL);
7608                 if ((ffebld_op (ffebld_right (dim)) == FFEBLD_opSTAR)
7609                     || ffecom_doing_entry_)
7610                   {
7611                     /* Used to just do high=low.  But for ffecom_tree_
7612                        canonize_ref_, it probably is important to correctly
7613                        assess the size.  E.g. given COMPLEX C(*),CFUNC and
7614                        C(2)=CFUNC(C), overlap can happen, while it can't
7615                        for, say, C(1)=CFUNC(C(2)).  */
7616                     /* Even more recently used to set to INT_MAX, but that
7617                        broke when some overflow checking went into the back
7618                        end.  Now we just leave the upper bound unspecified.  */
7619                     high = NULL;
7620                   }
7621                 else
7622                   high = ffecom_expr (ffebld_right (dim));
7623
7624                 /* Determine whether array is conditionally adjustable,
7625                    to decide whether back-end magic is needed.
7626
7627                    Normally the front end uses the back-end function
7628                    variable_size to wrap SAVE_EXPR's around expressions
7629                    affecting the size/shape of an array so that the
7630                    size/shape info doesn't change during execution
7631                    of the compiled code even though variables and
7632                    functions referenced in those expressions might.
7633
7634                    variable_size also makes sure those saved expressions
7635                    get evaluated immediately upon entry to the
7636                    compiled procedure -- the front end normally doesn't
7637                    have to worry about that.
7638
7639                    However, there is a problem with this that affects
7640                    g77's implementation of entry points, and that is
7641                    that it is _not_ true that each invocation of the
7642                    compiled procedure is permitted to evaluate
7643                    array size/shape info -- because it is possible
7644                    that, for some invocations, that info is invalid (in
7645                    which case it is "promised" -- i.e. a violation of
7646                    the Fortran standard -- that the compiled code
7647                    won't reference the array or its size/shape
7648                    during that particular invocation).
7649
7650                    To phrase this in C terms, consider this gcc function:
7651
7652                      void foo (int *n, float (*a)[*n])
7653                      {
7654                        // a is "pointer to array ...", fyi.
7655                      }
7656
7657                    Suppose that, for some invocations, it is permitted
7658                    for a caller of foo to do this:
7659
7660                        foo (NULL, NULL);
7661
7662                    Now the _written_ code for foo can take such a call
7663                    into account by either testing explicitly for whether
7664                    (a == NULL) || (n == NULL) -- presumably it is
7665                    not permitted to reference *a in various fashions
7666                    if (n == NULL) I suppose -- or it can avoid it by
7667                    looking at other info (other arguments, static/global
7668                    data, etc.).
7669
7670                    However, this won't work in gcc 2.5.8 because it'll
7671                    automatically emit the code to save the "*n"
7672                    expression, which'll yield a NULL dereference for
7673                    the "foo (NULL, NULL)" call, something the code
7674                    for foo cannot prevent.
7675
7676                    g77 definitely needs to avoid executing such
7677                    code anytime the pointer to the adjustable array
7678                    is NULL, because even if its bounds expressions
7679                    don't have any references to possible "absent"
7680                    variables like "*n" -- say all variable references
7681                    are to COMMON variables, i.e. global (though in C,
7682                    local static could actually make sense) -- the
7683                    expressions could yield other run-time problems
7684                    for allowably "dead" values in those variables.
7685
7686                    For example, let's consider a more complicated
7687                    version of foo:
7688
7689                      extern int i;
7690                      extern int j;
7691
7692                      void foo (float (*a)[i/j])
7693                      {
7694                        ...
7695                      }
7696
7697                    The above is (essentially) quite valid for Fortran
7698                    but, again, for a call like "foo (NULL);", it is
7699                    permitted for i and j to be undefined when the
7700                    call is made.  If j happened to be zero, for
7701                    example, emitting the code to evaluate "i/j"
7702                    could result in a run-time error.
7703
7704                    Offhand, though I don't have my F77 or F90
7705                    standards handy, it might even be valid for a
7706                    bounds expression to contain a function reference,
7707                    in which case I doubt it is permitted for an
7708                    implementation to invoke that function in the
7709                    Fortran case involved here (invocation of an
7710                    alternate ENTRY point that doesn't have the adjustable
7711                    array as one of its arguments).
7712
7713                    So, the code that the compiler would normally emit
7714                    to preevaluate the size/shape info for an
7715                    adjustable array _must not_ be executed at run time
7716                    in certain cases.  Specifically, for Fortran,
7717                    the case is when the pointer to the adjustable
7718                    array == NULL.  (For gnu-ish C, it might be nice
7719                    for the source code itself to specify an expression
7720                    that, if TRUE, inhibits execution of the code.  Or
7721                    reverse the sense for elegance.)
7722
7723                    (Note that g77 could use a different test than NULL,
7724                    actually, since it happens to always pass an
7725                    integer to the called function that specifies which
7726                    entry point is being invoked.  Hmm, this might
7727                    solve the next problem.)
7728
7729                    One way a user could, I suppose, write "foo" so
7730                    it works is to insert COND_EXPR's for the
7731                    size/shape info so the dangerous stuff isn't
7732                    actually done, as in:
7733
7734                      void foo (int *n, float (*a)[(a == NULL) ? 0 : *n])
7735                      {
7736                        ...
7737                      }
7738
7739                    The next problem is that the front end needs to
7740                    be able to tell the back end about the array's
7741                    decl _before_ it tells it about the conditional
7742                    expression to inhibit evaluation of size/shape info,
7743                    as shown above.
7744
7745                    To solve this, the front end needs to be able
7746                    to give the back end the expression to inhibit
7747                    generation of the preevaluation code _after_
7748                    it makes the decl for the adjustable array.
7749
7750                    Until then, the above example using the COND_EXPR
7751                    doesn't pass muster with gcc because the "(a == NULL)"
7752                    part has a reference to "a", which is still
7753                    undefined at that point.
7754
7755                    g77 will therefore use a different mechanism in the
7756                    meantime.  */
7757
7758                 if (!adjustable
7759                     && ((TREE_CODE (low) != INTEGER_CST)
7760                         || (high && TREE_CODE (high) != INTEGER_CST)))
7761                   adjustable = TRUE;
7762
7763 #if 0                           /* Old approach -- see below. */
7764                 if (TREE_CODE (low) != INTEGER_CST)
7765                   low = ffecom_3 (COND_EXPR, integer_type_node,
7766                                   ffecom_adjarray_passed_ (s),
7767                                   low,
7768                                   ffecom_integer_zero_node);
7769
7770                 if (high && TREE_CODE (high) != INTEGER_CST)
7771                   high = ffecom_3 (COND_EXPR, integer_type_node,
7772                                    ffecom_adjarray_passed_ (s),
7773                                    high,
7774                                    ffecom_integer_zero_node);
7775 #endif
7776
7777                 /* ~~~gcc/stor-layout.c (layout_type) should do this,
7778                    probably.  Fixes 950302-1.f.  */
7779
7780                 if (TREE_CODE (low) != INTEGER_CST)
7781                   low = variable_size (low);
7782
7783                 /* ~~~Similarly, this fixes dumb0.f.  The C front end
7784                    does this, which is why dumb0.c would work.  */
7785
7786                 if (high && TREE_CODE (high) != INTEGER_CST)
7787                   high = variable_size (high);
7788
7789                 type
7790                   = build_array_type
7791                     (type,
7792                      build_range_type (ffecom_integer_type_node,
7793                                        low, high));
7794                 type = ffecom_check_size_overflow_ (s, type, TRUE);
7795               }
7796
7797             if (type == error_mark_node)
7798               {
7799                 t = error_mark_node;
7800                 break;
7801               }
7802
7803             if ((ffesymbol_sfdummyparent (s) == NULL)
7804                  || (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER))
7805               {
7806                 type = build_pointer_type (type);
7807                 addr = TRUE;
7808               }
7809
7810             t = build_decl (PARM_DECL, t, type);
7811             DECL_ARTIFICIAL (t) = 1;
7812
7813             /* If this arg is present in every entry point's list of
7814                dummy args, then we're done.  */
7815
7816             if (ffesymbol_numentries (s)
7817                 == (ffecom_num_entrypoints_ + 1))
7818               break;
7819
7820 #if 1
7821
7822             /* If variable_size in stor-layout has been called during
7823                the above, then get_pending_sizes should have the
7824                yet-to-be-evaluated saved expressions pending.
7825                Make the whole lot of them get emitted, conditionally
7826                on whether the array decl ("t" above) is not NULL.  */
7827
7828             {
7829               tree sizes = get_pending_sizes ();
7830               tree tem;
7831
7832               for (tem = sizes;
7833                    tem != old_sizes;
7834                    tem = TREE_CHAIN (tem))
7835                 {
7836                   tree temv = TREE_VALUE (tem);
7837
7838                   if (sizes == tem)
7839                     sizes = temv;
7840                   else
7841                     sizes
7842                       = ffecom_2 (COMPOUND_EXPR,
7843                                   TREE_TYPE (sizes),
7844                                   temv,
7845                                   sizes);
7846                 }
7847
7848               if (sizes != tem)
7849                 {
7850                   sizes
7851                     = ffecom_3 (COND_EXPR,
7852                                 TREE_TYPE (sizes),
7853                                 ffecom_2 (NE_EXPR,
7854                                           integer_type_node,
7855                                           t,
7856                                           null_pointer_node),
7857                                 sizes,
7858                                 convert (TREE_TYPE (sizes),
7859                                          integer_zero_node));
7860                   sizes = ffecom_save_tree (sizes);
7861
7862                   sizes
7863                     = tree_cons (NULL_TREE, sizes, tem);
7864                 }
7865
7866               if (sizes)
7867                 put_pending_sizes (sizes);
7868             }
7869
7870 #else
7871 #if 0
7872             if (adjustable
7873                 && (ffesymbol_numentries (s)
7874                     != ffecom_num_entrypoints_ + 1))
7875               DECL_SOMETHING (t)
7876                 = ffecom_2 (NE_EXPR, integer_type_node,
7877                             t,
7878                             null_pointer_node);
7879 #else
7880 #if 0
7881             if (adjustable
7882                 && (ffesymbol_numentries (s)
7883                     != ffecom_num_entrypoints_ + 1))
7884               {
7885                 ffebad_start (FFEBAD_MISSING_ADJARRAY_UNSUPPORTED);
7886                 ffebad_here (0, ffesymbol_where_line (s),
7887                              ffesymbol_where_column (s));
7888                 ffebad_string (ffesymbol_text (s));
7889                 ffebad_finish ();
7890               }
7891 #endif
7892 #endif
7893 #endif
7894           }
7895           break;
7896
7897         case FFEINFO_whereCOMMON:
7898           {
7899             ffesymbol cs;
7900             ffeglobal cg;
7901             tree ct;
7902             ffestorag st = ffesymbol_storage (s);
7903             tree type;
7904
7905             cs = ffesymbol_common (s);  /* The COMMON area itself.  */
7906             if (st != NULL)     /* Else not laid out. */
7907               {
7908                 ffecom_transform_common_ (cs);
7909                 st = ffesymbol_storage (s);
7910               }
7911
7912             type = ffecom_type_localvar_ (s, bt, kt);
7913
7914             cg = ffesymbol_global (cs); /* The global COMMON info.  */
7915             if ((cg == NULL)
7916                 || (ffeglobal_type (cg) != FFEGLOBAL_typeCOMMON))
7917               ct = NULL_TREE;
7918             else
7919               ct = ffeglobal_hook (cg); /* The common area's tree.  */
7920
7921             if ((ct == NULL_TREE)
7922                 || (st == NULL)
7923                 || (type == error_mark_node))
7924               t = error_mark_node;
7925             else
7926               {
7927                 ffetargetOffset offset;
7928                 ffestorag cst;
7929
7930                 cst = ffestorag_parent (st);
7931                 assert (cst == ffesymbol_storage (cs));
7932
7933                 offset = ffestorag_modulo (cst)
7934                   + ffestorag_offset (st)
7935                   - ffestorag_offset (cst);
7936
7937                 ffecom_debug_kludge_ (ct, "COMMON", s, type, offset);
7938
7939                 /* (t_type *) (((char *) &ct) + offset) */
7940
7941                 t = convert (string_type_node,  /* (char *) */
7942                              ffecom_1 (ADDR_EXPR,
7943                                        build_pointer_type (TREE_TYPE (ct)),
7944                                        ct));
7945                 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
7946                               t,
7947                               build_int_2 (offset, 0));
7948                 t = convert (build_pointer_type (type),
7949                              t);
7950                 TREE_CONSTANT (t) = 1;
7951
7952                 addr = TRUE;
7953               }
7954           }
7955           break;
7956
7957         case FFEINFO_whereIMMEDIATE:
7958         case FFEINFO_whereGLOBAL:
7959         case FFEINFO_whereFLEETING:
7960         case FFEINFO_whereFLEETING_CADDR:
7961         case FFEINFO_whereFLEETING_IADDR:
7962         case FFEINFO_whereINTRINSIC:
7963         case FFEINFO_whereCONSTANT_SUBOBJECT:
7964         default:
7965           assert ("ENTITY where unheard of" == NULL);
7966           /* Fall through. */
7967         case FFEINFO_whereANY:
7968           t = error_mark_node;
7969           break;
7970         }
7971       break;
7972
7973     case FFEINFO_kindFUNCTION:
7974       switch (ffeinfo_where (ffesymbol_info (s)))
7975         {
7976         case FFEINFO_whereLOCAL:        /* Me. */
7977           assert (!ffecom_transform_only_dummies_);
7978           t = current_function_decl;
7979           break;
7980
7981         case FFEINFO_whereGLOBAL:
7982           assert (!ffecom_transform_only_dummies_);
7983
7984           if (((g = ffesymbol_global (s)) != NULL)
7985               && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7986                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
7987               && (ffeglobal_hook (g) != NULL_TREE)
7988               && ffe_is_globals ())
7989             {
7990               t = ffeglobal_hook (g);
7991               break;
7992             }
7993
7994           if (ffesymbol_is_f2c (s)
7995               && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
7996             t = ffecom_tree_fun_type[bt][kt];
7997           else
7998             t = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
7999
8000           t = build_decl (FUNCTION_DECL,
8001                           ffecom_get_external_identifier_ (s),
8002                           t);
8003           DECL_EXTERNAL (t) = 1;
8004           TREE_PUBLIC (t) = 1;
8005
8006           t = start_decl (t, FALSE);
8007           finish_decl (t, NULL_TREE, FALSE);
8008
8009           if ((g != NULL)
8010               && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8011                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8012             ffeglobal_set_hook (g, t);
8013
8014           ffecom_save_tree_forever (t);
8015
8016           break;
8017
8018         case FFEINFO_whereDUMMY:
8019           assert (ffecom_transform_only_dummies_);
8020
8021           if (ffesymbol_is_f2c (s)
8022               && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8023             t = ffecom_tree_ptr_to_fun_type[bt][kt];
8024           else
8025             t = build_pointer_type
8026               (build_function_type (ffecom_tree_type[bt][kt], NULL_TREE));
8027
8028           t = build_decl (PARM_DECL,
8029                           ffecom_get_identifier_ (ffesymbol_text (s)),
8030                           t);
8031           DECL_ARTIFICIAL (t) = 1;
8032           addr = TRUE;
8033           break;
8034
8035         case FFEINFO_whereCONSTANT:     /* Statement function. */
8036           assert (!ffecom_transform_only_dummies_);
8037           t = ffecom_gen_sfuncdef_ (s, bt, kt);
8038           break;
8039
8040         case FFEINFO_whereINTRINSIC:
8041           assert (!ffecom_transform_only_dummies_);
8042           break;                /* Let actual references generate their
8043                                    decls. */
8044
8045         default:
8046           assert ("FUNCTION where unheard of" == NULL);
8047           /* Fall through. */
8048         case FFEINFO_whereANY:
8049           t = error_mark_node;
8050           break;
8051         }
8052       break;
8053
8054     case FFEINFO_kindSUBROUTINE:
8055       switch (ffeinfo_where (ffesymbol_info (s)))
8056         {
8057         case FFEINFO_whereLOCAL:        /* Me. */
8058           assert (!ffecom_transform_only_dummies_);
8059           t = current_function_decl;
8060           break;
8061
8062         case FFEINFO_whereGLOBAL:
8063           assert (!ffecom_transform_only_dummies_);
8064
8065           if (((g = ffesymbol_global (s)) != NULL)
8066               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8067                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8068               && (ffeglobal_hook (g) != NULL_TREE)
8069               && ffe_is_globals ())
8070             {
8071               t = ffeglobal_hook (g);
8072               break;
8073             }
8074
8075           t = build_decl (FUNCTION_DECL,
8076                           ffecom_get_external_identifier_ (s),
8077                           ffecom_tree_subr_type);
8078           DECL_EXTERNAL (t) = 1;
8079           TREE_PUBLIC (t) = 1;
8080
8081           t = start_decl (t, TRUE);
8082           finish_decl (t, NULL_TREE, TRUE);
8083
8084           if ((g != NULL)
8085               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8086                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8087             ffeglobal_set_hook (g, t);
8088
8089           ffecom_save_tree_forever (t);
8090
8091           break;
8092
8093         case FFEINFO_whereDUMMY:
8094           assert (ffecom_transform_only_dummies_);
8095
8096           t = build_decl (PARM_DECL,
8097                           ffecom_get_identifier_ (ffesymbol_text (s)),
8098                           ffecom_tree_ptr_to_subr_type);
8099           DECL_ARTIFICIAL (t) = 1;
8100           addr = TRUE;
8101           break;
8102
8103         case FFEINFO_whereINTRINSIC:
8104           assert (!ffecom_transform_only_dummies_);
8105           break;                /* Let actual references generate their
8106                                    decls. */
8107
8108         default:
8109           assert ("SUBROUTINE where unheard of" == NULL);
8110           /* Fall through. */
8111         case FFEINFO_whereANY:
8112           t = error_mark_node;
8113           break;
8114         }
8115       break;
8116
8117     case FFEINFO_kindPROGRAM:
8118       switch (ffeinfo_where (ffesymbol_info (s)))
8119         {
8120         case FFEINFO_whereLOCAL:        /* Me. */
8121           assert (!ffecom_transform_only_dummies_);
8122           t = current_function_decl;
8123           break;
8124
8125         case FFEINFO_whereCOMMON:
8126         case FFEINFO_whereDUMMY:
8127         case FFEINFO_whereGLOBAL:
8128         case FFEINFO_whereRESULT:
8129         case FFEINFO_whereFLEETING:
8130         case FFEINFO_whereFLEETING_CADDR:
8131         case FFEINFO_whereFLEETING_IADDR:
8132         case FFEINFO_whereIMMEDIATE:
8133         case FFEINFO_whereINTRINSIC:
8134         case FFEINFO_whereCONSTANT:
8135         case FFEINFO_whereCONSTANT_SUBOBJECT:
8136         default:
8137           assert ("PROGRAM where unheard of" == NULL);
8138           /* Fall through. */
8139         case FFEINFO_whereANY:
8140           t = error_mark_node;
8141           break;
8142         }
8143       break;
8144
8145     case FFEINFO_kindBLOCKDATA:
8146       switch (ffeinfo_where (ffesymbol_info (s)))
8147         {
8148         case FFEINFO_whereLOCAL:        /* Me. */
8149           assert (!ffecom_transform_only_dummies_);
8150           t = current_function_decl;
8151           break;
8152
8153         case FFEINFO_whereGLOBAL:
8154           assert (!ffecom_transform_only_dummies_);
8155
8156           t = build_decl (FUNCTION_DECL,
8157                           ffecom_get_external_identifier_ (s),
8158                           ffecom_tree_blockdata_type);
8159           DECL_EXTERNAL (t) = 1;
8160           TREE_PUBLIC (t) = 1;
8161
8162           t = start_decl (t, FALSE);
8163           finish_decl (t, NULL_TREE, FALSE);
8164
8165           ffecom_save_tree_forever (t);
8166
8167           break;
8168
8169         case FFEINFO_whereCOMMON:
8170         case FFEINFO_whereDUMMY:
8171         case FFEINFO_whereRESULT:
8172         case FFEINFO_whereFLEETING:
8173         case FFEINFO_whereFLEETING_CADDR:
8174         case FFEINFO_whereFLEETING_IADDR:
8175         case FFEINFO_whereIMMEDIATE:
8176         case FFEINFO_whereINTRINSIC:
8177         case FFEINFO_whereCONSTANT:
8178         case FFEINFO_whereCONSTANT_SUBOBJECT:
8179         default:
8180           assert ("BLOCKDATA where unheard of" == NULL);
8181           /* Fall through. */
8182         case FFEINFO_whereANY:
8183           t = error_mark_node;
8184           break;
8185         }
8186       break;
8187
8188     case FFEINFO_kindCOMMON:
8189       switch (ffeinfo_where (ffesymbol_info (s)))
8190         {
8191         case FFEINFO_whereLOCAL:
8192           assert (!ffecom_transform_only_dummies_);
8193           ffecom_transform_common_ (s);
8194           break;
8195
8196         case FFEINFO_whereNONE:
8197         case FFEINFO_whereCOMMON:
8198         case FFEINFO_whereDUMMY:
8199         case FFEINFO_whereGLOBAL:
8200         case FFEINFO_whereRESULT:
8201         case FFEINFO_whereFLEETING:
8202         case FFEINFO_whereFLEETING_CADDR:
8203         case FFEINFO_whereFLEETING_IADDR:
8204         case FFEINFO_whereIMMEDIATE:
8205         case FFEINFO_whereINTRINSIC:
8206         case FFEINFO_whereCONSTANT:
8207         case FFEINFO_whereCONSTANT_SUBOBJECT:
8208         default:
8209           assert ("COMMON where unheard of" == NULL);
8210           /* Fall through. */
8211         case FFEINFO_whereANY:
8212           t = error_mark_node;
8213           break;
8214         }
8215       break;
8216
8217     case FFEINFO_kindCONSTRUCT:
8218       switch (ffeinfo_where (ffesymbol_info (s)))
8219         {
8220         case FFEINFO_whereLOCAL:
8221           assert (!ffecom_transform_only_dummies_);
8222           break;
8223
8224         case FFEINFO_whereNONE:
8225         case FFEINFO_whereCOMMON:
8226         case FFEINFO_whereDUMMY:
8227         case FFEINFO_whereGLOBAL:
8228         case FFEINFO_whereRESULT:
8229         case FFEINFO_whereFLEETING:
8230         case FFEINFO_whereFLEETING_CADDR:
8231         case FFEINFO_whereFLEETING_IADDR:
8232         case FFEINFO_whereIMMEDIATE:
8233         case FFEINFO_whereINTRINSIC:
8234         case FFEINFO_whereCONSTANT:
8235         case FFEINFO_whereCONSTANT_SUBOBJECT:
8236         default:
8237           assert ("CONSTRUCT where unheard of" == NULL);
8238           /* Fall through. */
8239         case FFEINFO_whereANY:
8240           t = error_mark_node;
8241           break;
8242         }
8243       break;
8244
8245     case FFEINFO_kindNAMELIST:
8246       switch (ffeinfo_where (ffesymbol_info (s)))
8247         {
8248         case FFEINFO_whereLOCAL:
8249           assert (!ffecom_transform_only_dummies_);
8250           t = ffecom_transform_namelist_ (s);
8251           break;
8252
8253         case FFEINFO_whereNONE:
8254         case FFEINFO_whereCOMMON:
8255         case FFEINFO_whereDUMMY:
8256         case FFEINFO_whereGLOBAL:
8257         case FFEINFO_whereRESULT:
8258         case FFEINFO_whereFLEETING:
8259         case FFEINFO_whereFLEETING_CADDR:
8260         case FFEINFO_whereFLEETING_IADDR:
8261         case FFEINFO_whereIMMEDIATE:
8262         case FFEINFO_whereINTRINSIC:
8263         case FFEINFO_whereCONSTANT:
8264         case FFEINFO_whereCONSTANT_SUBOBJECT:
8265         default:
8266           assert ("NAMELIST where unheard of" == NULL);
8267           /* Fall through. */
8268         case FFEINFO_whereANY:
8269           t = error_mark_node;
8270           break;
8271         }
8272       break;
8273
8274     default:
8275       assert ("kind unheard of" == NULL);
8276       /* Fall through. */
8277     case FFEINFO_kindANY:
8278       t = error_mark_node;
8279       break;
8280     }
8281
8282   ffesymbol_hook (s).decl_tree = t;
8283   ffesymbol_hook (s).length_tree = tlen;
8284   ffesymbol_hook (s).addr = addr;
8285
8286   input_location = old_loc;
8287
8288   return s;
8289 }
8290
8291 /* Transform into ASSIGNable symbol.
8292
8293    Symbol has already been transformed, but for whatever reason, the
8294    resulting decl_tree has been deemed not usable for an ASSIGN target.
8295    (E.g. it isn't wide enough to hold a pointer.)  So, here we invent
8296    another local symbol of type void * and stuff that in the assign_tree
8297    argument.  The F77/F90 standards allow this implementation.  */
8298
8299 static ffesymbol
8300 ffecom_sym_transform_assign_ (ffesymbol s)
8301 {
8302   tree t;                       /* Transformed thingy. */
8303   location_t old_loc = input_location;
8304
8305   if (ffesymbol_sfdummyparent (s) == NULL)
8306     {
8307       input_filename = ffesymbol_where_filename (s);
8308       input_line = ffesymbol_where_filelinenum (s);
8309     }
8310   else
8311     {
8312       ffesymbol sf = ffesymbol_sfdummyparent (s);
8313
8314       input_filename = ffesymbol_where_filename (sf);
8315       input_line = ffesymbol_where_filelinenum (sf);
8316     }
8317
8318   assert (!ffecom_transform_only_dummies_);
8319
8320   t = build_decl (VAR_DECL,
8321                   ffecom_get_invented_identifier ("__g77_ASSIGN_%s",
8322                                                    ffesymbol_text (s)),
8323                   TREE_TYPE (null_pointer_node));
8324
8325   switch (ffesymbol_where (s))
8326     {
8327     case FFEINFO_whereLOCAL:
8328       /* Unlike for regular vars, SAVE status is easy to determine for
8329          ASSIGNed vars, since there's no initialization, there's no
8330          effective storage association (so "SAVE J" does not apply to
8331          K even given "EQUIVALENCE (J,K)"), there's no size issue
8332          to worry about, etc.  */
8333       if ((ffesymbol_is_save (s) || ffe_is_saveall ())
8334           && (ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8335           && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA))
8336         TREE_STATIC (t) = 1;    /* SAVEd in proc, make static. */
8337       else
8338         TREE_STATIC (t) = 0;    /* No need to make static. */
8339       break;
8340
8341     case FFEINFO_whereCOMMON:
8342       TREE_STATIC (t) = 1;      /* Assume COMMONs always SAVEd. */
8343       break;
8344
8345     case FFEINFO_whereDUMMY:
8346       /* Note that twinning a DUMMY means the caller won't see
8347          the ASSIGNed value.  But both F77 and F90 allow implementations
8348          to do this, i.e. disallow Fortran code that would try and
8349          take advantage of actually putting a label into a variable
8350          via a dummy argument (or any other storage association, for
8351          that matter).  */
8352       TREE_STATIC (t) = 0;
8353       break;
8354
8355     default:
8356       TREE_STATIC (t) = 0;
8357       break;
8358     }
8359
8360   t = start_decl (t, FALSE);
8361   finish_decl (t, NULL_TREE, FALSE);
8362
8363   ffesymbol_hook (s).assign_tree = t;
8364
8365   input_location = old_loc;
8366
8367   return s;
8368 }
8369
8370 /* Implement COMMON area in back end.
8371
8372    Because COMMON-based variables can be referenced in the dimension
8373    expressions of dummy (adjustable) arrays, and because dummies
8374    (in the gcc back end) need to be put in the outer binding level
8375    of a function (which has two binding levels, the outer holding
8376    the dummies and the inner holding the other vars), special care
8377    must be taken to handle COMMON areas.
8378
8379    The current strategy is basically to always tell the back end about
8380    the COMMON area as a top-level external reference to just a block
8381    of storage of the master type of that area (e.g. integer, real,
8382    character, whatever -- not a structure).  As a distinct action,
8383    if initial values are provided, tell the back end about the area
8384    as a top-level non-external (initialized) area and remember not to
8385    allow further initialization or expansion of the area.  Meanwhile,
8386    if no initialization happens at all, tell the back end about
8387    the largest size we've seen declared so the space does get reserved.
8388    (This function doesn't handle all that stuff, but it does some
8389    of the important things.)
8390
8391    Meanwhile, for COMMON variables themselves, just keep creating
8392    references like *((float *) (&common_area + offset)) each time
8393    we reference the variable.  In other words, don't make a VAR_DECL
8394    or any kind of component reference (like we used to do before 0.4),
8395    though we might do that as well just for debugging purposes (and
8396    stuff the rtl with the appropriate offset expression).  */
8397
8398 static void
8399 ffecom_transform_common_ (ffesymbol s)
8400 {
8401   ffestorag st = ffesymbol_storage (s);
8402   ffeglobal g = ffesymbol_global (s);
8403   tree cbt;
8404   tree cbtype;
8405   tree init;
8406   tree high;
8407   bool is_init = ffestorag_is_init (st);
8408
8409   assert (st != NULL);
8410
8411   if ((g == NULL)
8412       || (ffeglobal_type (g) != FFEGLOBAL_typeCOMMON))
8413     return;
8414
8415   /* First update the size of the area in global terms.  */
8416
8417   ffeglobal_size_common (s, ffestorag_size (st));
8418
8419   if (!ffeglobal_common_init (g))
8420     is_init = FALSE;    /* No explicit init, don't let erroneous joins init. */
8421
8422   cbt = ffeglobal_hook (g);
8423
8424   /* If we already have declared this common block for a previous program
8425      unit, and either we already initialized it or we don't have new
8426      initialization for it, just return what we have without changing it.  */
8427
8428   if ((cbt != NULL_TREE)
8429       && (!is_init
8430           || !DECL_EXTERNAL (cbt)))
8431     {
8432       if (st->hook == NULL) ffestorag_set_hook (st, cbt);
8433       return;
8434     }
8435
8436   /* Process inits.  */
8437
8438   if (is_init)
8439     {
8440       if (ffestorag_init (st) != NULL)
8441         {
8442           ffebld sexp;
8443
8444           /* Set the padding for the expression, so ffecom_expr
8445              knows to insert that many zeros.  */
8446           switch (ffebld_op (sexp = ffestorag_init (st)))
8447             {
8448             case FFEBLD_opCONTER:
8449               ffebld_conter_set_pad (sexp, ffestorag_modulo (st));
8450               break;
8451
8452             case FFEBLD_opARRTER:
8453               ffebld_arrter_set_pad (sexp, ffestorag_modulo (st));
8454               break;
8455
8456             case FFEBLD_opACCTER:
8457               ffebld_accter_set_pad (sexp, ffestorag_modulo (st));
8458               break;
8459
8460             default:
8461               assert ("bad op for cmn init (pad)" == NULL);
8462               break;
8463             }
8464
8465           init = ffecom_expr (sexp);
8466           if (init == error_mark_node)
8467             {                   /* Hopefully the back end complained! */
8468               init = NULL_TREE;
8469               if (cbt != NULL_TREE)
8470                 return;
8471             }
8472         }
8473       else
8474         init = error_mark_node;
8475     }
8476   else
8477     init = NULL_TREE;
8478
8479   /* cbtype must be permanently allocated!  */
8480
8481   /* Allocate the MAX of the areas so far, seen filewide.  */
8482   high = build_int_2 ((ffeglobal_common_size (g)
8483                        + ffeglobal_common_pad (g)) - 1, 0);
8484   TREE_TYPE (high) = ffecom_integer_type_node;
8485
8486   if (init)
8487     cbtype = build_array_type (char_type_node,
8488                                build_range_type (integer_type_node,
8489                                                  integer_zero_node,
8490                                                  high));
8491   else
8492     cbtype = build_array_type (char_type_node, NULL_TREE);
8493
8494   if (cbt == NULL_TREE)
8495     {
8496       cbt
8497         = build_decl (VAR_DECL,
8498                       ffecom_get_external_identifier_ (s),
8499                       cbtype);
8500       TREE_STATIC (cbt) = 1;
8501       TREE_PUBLIC (cbt) = 1;
8502     }
8503   else
8504     {
8505       assert (is_init);
8506       TREE_TYPE (cbt) = cbtype;
8507     }
8508   DECL_EXTERNAL (cbt) = init ? 0 : 1;
8509   DECL_INITIAL (cbt) = init ? error_mark_node : NULL_TREE;
8510
8511   cbt = start_decl (cbt, TRUE);
8512   if (ffeglobal_hook (g) != NULL)
8513     assert (cbt == ffeglobal_hook (g));
8514
8515   assert (!init || !DECL_EXTERNAL (cbt));
8516
8517   /* Make sure that any type can live in COMMON and be referenced
8518      without getting a bus error.  We could pick the most restrictive
8519      alignment of all entities actually placed in the COMMON, but
8520      this seems easy enough.  */
8521
8522   DECL_ALIGN (cbt) = BIGGEST_ALIGNMENT;
8523   DECL_USER_ALIGN (cbt) = 0;
8524
8525   if (is_init && (ffestorag_init (st) == NULL))
8526     init = ffecom_init_zero_ (cbt);
8527
8528   finish_decl (cbt, init, TRUE);
8529
8530   if (is_init)
8531     ffestorag_set_init (st, ffebld_new_any ());
8532
8533   if (init)
8534     {
8535       assert (DECL_SIZE_UNIT (cbt) != NULL_TREE);
8536       assert (TREE_CODE (DECL_SIZE_UNIT (cbt)) == INTEGER_CST);
8537       assert (0 == compare_tree_int (DECL_SIZE_UNIT (cbt),
8538                                      (ffeglobal_common_size (g)
8539                                       + ffeglobal_common_pad (g))));
8540     }
8541
8542   ffeglobal_set_hook (g, cbt);
8543
8544   ffestorag_set_hook (st, cbt);
8545
8546   ffecom_save_tree_forever (cbt);
8547 }
8548
8549 /* Make master area for local EQUIVALENCE.  */
8550
8551 static void
8552 ffecom_transform_equiv_ (ffestorag eqst)
8553 {
8554   tree eqt;
8555   tree eqtype;
8556   tree init;
8557   tree high;
8558   bool is_init = ffestorag_is_init (eqst);
8559
8560   assert (eqst != NULL);
8561
8562   eqt = ffestorag_hook (eqst);
8563
8564   if (eqt != NULL_TREE)
8565     return;
8566
8567   /* Process inits.  */
8568
8569   if (is_init)
8570     {
8571       if (ffestorag_init (eqst) != NULL)
8572         {
8573           ffebld sexp;
8574
8575           /* Set the padding for the expression, so ffecom_expr
8576              knows to insert that many zeros.  */
8577           switch (ffebld_op (sexp = ffestorag_init (eqst)))
8578             {
8579             case FFEBLD_opCONTER:
8580               ffebld_conter_set_pad (sexp, ffestorag_modulo (eqst));
8581               break;
8582
8583             case FFEBLD_opARRTER:
8584               ffebld_arrter_set_pad (sexp, ffestorag_modulo (eqst));
8585               break;
8586
8587             case FFEBLD_opACCTER:
8588               ffebld_accter_set_pad (sexp, ffestorag_modulo (eqst));
8589               break;
8590
8591             default:
8592               assert ("bad op for eqv init (pad)" == NULL);
8593               break;
8594             }
8595
8596           init = ffecom_expr (sexp);
8597           if (init == error_mark_node)
8598             init = NULL_TREE;   /* Hopefully the back end complained! */
8599         }
8600       else
8601         init = error_mark_node;
8602     }
8603   else if (ffe_is_init_local_zero ())
8604     init = error_mark_node;
8605   else
8606     init = NULL_TREE;
8607
8608   ffecom_member_namelisted_ = FALSE;
8609   ffestorag_drive (ffestorag_list_equivs (eqst),
8610                    &ffecom_member_phase1_,
8611                    eqst);
8612
8613   high = build_int_2 ((ffestorag_size (eqst)
8614                        + ffestorag_modulo (eqst)) - 1, 0);
8615   TREE_TYPE (high) = ffecom_integer_type_node;
8616
8617   eqtype = build_array_type (char_type_node,
8618                              build_range_type (ffecom_integer_type_node,
8619                                                ffecom_integer_zero_node,
8620                                                high));
8621
8622   eqt = build_decl (VAR_DECL,
8623                     ffecom_get_invented_identifier ("__g77_equiv_%s",
8624                                                     ffesymbol_text
8625                                                     (ffestorag_symbol (eqst))),
8626                     eqtype);
8627   DECL_EXTERNAL (eqt) = 0;
8628   if (is_init
8629       || ffecom_member_namelisted_
8630 #ifdef FFECOM_sizeMAXSTACKITEM
8631       || (ffestorag_size (eqst) > FFECOM_sizeMAXSTACKITEM)
8632 #endif
8633       || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8634           && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
8635           && (ffestorag_is_save (eqst) || ffe_is_saveall ())))
8636     TREE_STATIC (eqt) = 1;
8637   else
8638     TREE_STATIC (eqt) = 0;
8639   TREE_PUBLIC (eqt) = 0;
8640   TREE_ADDRESSABLE (eqt) = 1;  /* Ensure non-register allocation */
8641   DECL_CONTEXT (eqt) = current_function_decl;
8642   if (init)
8643     DECL_INITIAL (eqt) = error_mark_node;
8644   else
8645     DECL_INITIAL (eqt) = NULL_TREE;
8646
8647   eqt = start_decl (eqt, FALSE);
8648
8649   /* Make sure that any type can live in EQUIVALENCE and be referenced
8650      without getting a bus error.  We could pick the most restrictive
8651      alignment of all entities actually placed in the EQUIVALENCE, but
8652      this seems easy enough.  */
8653
8654   DECL_ALIGN (eqt) = BIGGEST_ALIGNMENT;
8655   DECL_USER_ALIGN (eqt) = 0;
8656
8657   if ((!is_init && ffe_is_init_local_zero ())
8658       || (is_init && (ffestorag_init (eqst) == NULL)))
8659     init = ffecom_init_zero_ (eqt);
8660
8661   finish_decl (eqt, init, FALSE);
8662
8663   if (is_init)
8664     ffestorag_set_init (eqst, ffebld_new_any ());
8665
8666   {
8667     assert (TREE_CODE (DECL_SIZE_UNIT (eqt)) == INTEGER_CST);
8668     assert (0 == compare_tree_int (DECL_SIZE_UNIT (eqt),
8669                                    (ffestorag_size (eqst)
8670                                     + ffestorag_modulo (eqst))));
8671   }
8672
8673   ffestorag_set_hook (eqst, eqt);
8674
8675   ffestorag_drive (ffestorag_list_equivs (eqst),
8676                    &ffecom_member_phase2_,
8677                    eqst);
8678 }
8679
8680 /* Implement NAMELIST in back end.  See f2c/format.c for more info.  */
8681
8682 static tree
8683 ffecom_transform_namelist_ (ffesymbol s)
8684 {
8685   tree nmlt;
8686   tree nmltype = ffecom_type_namelist_ ();
8687   tree nmlinits;
8688   tree nameinit;
8689   tree varsinit;
8690   tree nvarsinit;
8691   tree field;
8692   tree high;
8693   int i;
8694   static int mynumber = 0;
8695
8696   nmlt = build_decl (VAR_DECL,
8697                      ffecom_get_invented_identifier ("__g77_namelist_%d",
8698                                                      mynumber++),
8699                      nmltype);
8700   TREE_STATIC (nmlt) = 1;
8701   DECL_INITIAL (nmlt) = error_mark_node;
8702
8703   nmlt = start_decl (nmlt, FALSE);
8704
8705   /* Process inits.  */
8706
8707   i = strlen (ffesymbol_text (s));
8708
8709   high = build_int_2 (i, 0);
8710   TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
8711
8712   nameinit = ffecom_build_f2c_string_ (i + 1,
8713                                        ffesymbol_text (s));
8714   TREE_TYPE (nameinit)
8715     = build_type_variant
8716     (build_array_type
8717      (char_type_node,
8718       build_range_type (ffecom_f2c_ftnlen_type_node,
8719                         ffecom_f2c_ftnlen_one_node,
8720                         high)),
8721      1, 0);
8722   TREE_CONSTANT (nameinit) = 1;
8723   TREE_STATIC (nameinit) = 1;
8724   nameinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (nameinit)),
8725                        nameinit);
8726
8727   varsinit = ffecom_vardesc_array_ (s);
8728   varsinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (varsinit)),
8729                        varsinit);
8730   TREE_CONSTANT (varsinit) = 1;
8731   TREE_STATIC (varsinit) = 1;
8732
8733   {
8734     ffebld b;
8735
8736     for (i = 0, b = ffesymbol_namelist (s); b != NULL; b = ffebld_trail (b))
8737       ++i;
8738   }
8739   nvarsinit = build_int_2 (i, 0);
8740   TREE_TYPE (nvarsinit) = integer_type_node;
8741   TREE_CONSTANT (nvarsinit) = 1;
8742   TREE_STATIC (nvarsinit) = 1;
8743
8744   nmlinits = build_tree_list ((field = TYPE_FIELDS (nmltype)), nameinit);
8745   TREE_CHAIN (nmlinits) = build_tree_list ((field = TREE_CHAIN (field)),
8746                                            varsinit);
8747   TREE_CHAIN (TREE_CHAIN (nmlinits))
8748     = build_tree_list ((field = TREE_CHAIN (field)), nvarsinit);
8749
8750   nmlinits = build_constructor (nmltype, nmlinits);
8751   TREE_CONSTANT (nmlinits) = 1;
8752   TREE_STATIC (nmlinits) = 1;
8753
8754   finish_decl (nmlt, nmlinits, FALSE);
8755
8756   nmlt = ffecom_1 (ADDR_EXPR, build_pointer_type (nmltype), nmlt);
8757
8758   return nmlt;
8759 }
8760
8761 /* A subroutine of ffecom_tree_canonize_ref_.  The incoming tree is
8762    analyzed on the assumption it is calculating a pointer to be
8763    indirected through.  It must return the proper decl and offset,
8764    taking into account different units of measurements for offsets.  */
8765
8766 static void
8767 ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
8768                            tree t)
8769 {
8770   switch (TREE_CODE (t))
8771     {
8772     case NOP_EXPR:
8773     case CONVERT_EXPR:
8774     case NON_LVALUE_EXPR:
8775       ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
8776       break;
8777
8778     case PLUS_EXPR:
8779       ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
8780       if ((*decl == NULL_TREE)
8781           || (*decl == error_mark_node))
8782         break;
8783
8784       if (TREE_CODE (TREE_OPERAND (t, 1)) == INTEGER_CST)
8785         {
8786           /* An offset into COMMON.  */
8787           *offset = fold (build (PLUS_EXPR, TREE_TYPE (*offset),
8788                                  *offset, TREE_OPERAND (t, 1)));
8789           /* Convert offset (presumably in bytes) into canonical units
8790              (presumably bits).  */
8791           *offset = size_binop (MULT_EXPR,
8792                                 convert (bitsizetype, *offset),
8793                                 TYPE_SIZE (TREE_TYPE (TREE_TYPE (t))));
8794           break;
8795         }
8796       /* Not a COMMON reference, so an unrecognized pattern.  */
8797       *decl = error_mark_node;
8798       break;
8799
8800     case PARM_DECL:
8801       *decl = t;
8802       *offset = bitsize_zero_node;
8803       break;
8804
8805     case ADDR_EXPR:
8806       if (TREE_CODE (TREE_OPERAND (t, 0)) == VAR_DECL)
8807         {
8808           /* A reference to COMMON.  */
8809           *decl = TREE_OPERAND (t, 0);
8810           *offset = bitsize_zero_node;
8811           break;
8812         }
8813       /* Fall through.  */
8814     default:
8815       /* Not a COMMON reference, so an unrecognized pattern.  */
8816       *decl = error_mark_node;
8817       break;
8818     }
8819 }
8820
8821 /* Given a tree that is possibly intended for use as an lvalue, return
8822    information representing a canonical view of that tree as a decl, an
8823    offset into that decl, and a size for the lvalue.
8824
8825    If there's no applicable decl, NULL_TREE is returned for the decl,
8826    and the other fields are left undefined.
8827
8828    If the tree doesn't fit the recognizable forms, an ERROR_MARK node
8829    is returned for the decl, and the other fields are left undefined.
8830
8831    Otherwise, the decl returned currently is either a VAR_DECL or a
8832    PARM_DECL.
8833
8834    The offset returned is always valid, but of course not necessarily
8835    a constant, and not necessarily converted into the appropriate
8836    type, leaving that up to the caller (so as to avoid that overhead
8837    if the decls being looked at are different anyway).
8838
8839    If the size cannot be determined (e.g. an adjustable array),
8840    an ERROR_MARK node is returned for the size.  Otherwise, the
8841    size returned is valid, not necessarily a constant, and not
8842    necessarily converted into the appropriate type as with the
8843    offset.
8844
8845    Note that the offset and size expressions are expressed in the
8846    base storage units (usually bits) rather than in the units of
8847    the type of the decl, because two decls with different types
8848    might overlap but with apparently non-overlapping array offsets,
8849    whereas converting the array offsets to consistant offsets will
8850    reveal the overlap.  */
8851
8852 static void
8853 ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
8854                            tree *size, tree t)
8855 {
8856   /* The default path is to report a nonexistant decl.  */
8857   *decl = NULL_TREE;
8858
8859   if (t == NULL_TREE)
8860     return;
8861
8862   switch (TREE_CODE (t))
8863     {
8864     case ERROR_MARK:
8865     case IDENTIFIER_NODE:
8866     case INTEGER_CST:
8867     case REAL_CST:
8868     case COMPLEX_CST:
8869     case STRING_CST:
8870     case CONST_DECL:
8871     case PLUS_EXPR:
8872     case MINUS_EXPR:
8873     case MULT_EXPR:
8874     case TRUNC_DIV_EXPR:
8875     case CEIL_DIV_EXPR:
8876     case FLOOR_DIV_EXPR:
8877     case ROUND_DIV_EXPR:
8878     case TRUNC_MOD_EXPR:
8879     case CEIL_MOD_EXPR:
8880     case FLOOR_MOD_EXPR:
8881     case ROUND_MOD_EXPR:
8882     case RDIV_EXPR:
8883     case EXACT_DIV_EXPR:
8884     case FIX_TRUNC_EXPR:
8885     case FIX_CEIL_EXPR:
8886     case FIX_FLOOR_EXPR:
8887     case FIX_ROUND_EXPR:
8888     case FLOAT_EXPR:
8889     case NEGATE_EXPR:
8890     case MIN_EXPR:
8891     case MAX_EXPR:
8892     case ABS_EXPR:
8893     case FFS_EXPR:
8894     case LSHIFT_EXPR:
8895     case RSHIFT_EXPR:
8896     case LROTATE_EXPR:
8897     case RROTATE_EXPR:
8898     case BIT_IOR_EXPR:
8899     case BIT_XOR_EXPR:
8900     case BIT_AND_EXPR:
8901     case BIT_ANDTC_EXPR:
8902     case BIT_NOT_EXPR:
8903     case TRUTH_ANDIF_EXPR:
8904     case TRUTH_ORIF_EXPR:
8905     case TRUTH_AND_EXPR:
8906     case TRUTH_OR_EXPR:
8907     case TRUTH_XOR_EXPR:
8908     case TRUTH_NOT_EXPR:
8909     case LT_EXPR:
8910     case LE_EXPR:
8911     case GT_EXPR:
8912     case GE_EXPR:
8913     case EQ_EXPR:
8914     case NE_EXPR:
8915     case COMPLEX_EXPR:
8916     case CONJ_EXPR:
8917     case REALPART_EXPR:
8918     case IMAGPART_EXPR:
8919     case LABEL_EXPR:
8920     case COMPONENT_REF:
8921     case COMPOUND_EXPR:
8922     case ADDR_EXPR:
8923       return;
8924
8925     case VAR_DECL:
8926     case PARM_DECL:
8927       *decl = t;
8928       *offset = bitsize_zero_node;
8929       *size = TYPE_SIZE (TREE_TYPE (t));
8930       return;
8931
8932     case ARRAY_REF:
8933       {
8934         tree array = TREE_OPERAND (t, 0);
8935         tree element = TREE_OPERAND (t, 1);
8936         tree init_offset;
8937
8938         if ((array == NULL_TREE)
8939             || (element == NULL_TREE))
8940           {
8941             *decl = error_mark_node;
8942             return;
8943           }
8944
8945         ffecom_tree_canonize_ref_ (decl, &init_offset, size,
8946                                    array);
8947         if ((*decl == NULL_TREE)
8948             || (*decl == error_mark_node))
8949           return;
8950
8951         /* Calculate ((element - base) * NBBY) + init_offset.  */
8952         *offset = fold (build (MINUS_EXPR, TREE_TYPE (element),
8953                                element,
8954                                TYPE_MIN_VALUE (TYPE_DOMAIN
8955                                                (TREE_TYPE (array)))));
8956
8957         *offset = size_binop (MULT_EXPR,
8958                               convert (bitsizetype, *offset),
8959                               TYPE_SIZE (TREE_TYPE (TREE_TYPE (array))));
8960
8961         *offset = size_binop (PLUS_EXPR, init_offset, *offset);
8962
8963         *size = TYPE_SIZE (TREE_TYPE (t));
8964         return;
8965       }
8966
8967     case INDIRECT_REF:
8968
8969       /* Most of this code is to handle references to COMMON.  And so
8970          far that is useful only for calling library functions, since
8971          external (user) functions might reference common areas.  But
8972          even calling an external function, it's worthwhile to decode
8973          COMMON references because if not storing into COMMON, we don't
8974          want COMMON-based arguments to gratuitously force use of a
8975          temporary.  */
8976
8977       *size = TYPE_SIZE (TREE_TYPE (t));
8978
8979       ffecom_tree_canonize_ptr_ (decl, offset,
8980                                  TREE_OPERAND (t, 0));
8981
8982       return;
8983
8984     case CONVERT_EXPR:
8985     case NOP_EXPR:
8986     case MODIFY_EXPR:
8987     case NON_LVALUE_EXPR:
8988     case RESULT_DECL:
8989     case FIELD_DECL:
8990     case COND_EXPR:             /* More cases than we can handle. */
8991     case SAVE_EXPR:
8992     case REFERENCE_EXPR:
8993     case PREDECREMENT_EXPR:
8994     case PREINCREMENT_EXPR:
8995     case POSTDECREMENT_EXPR:
8996     case POSTINCREMENT_EXPR:
8997     case CALL_EXPR:
8998     default:
8999       *decl = error_mark_node;
9000       return;
9001     }
9002 }
9003
9004 /* Do divide operation appropriate to type of operands.  */
9005
9006 static tree
9007 ffecom_tree_divide_ (tree tree_type, tree left, tree right,
9008                      tree dest_tree, ffebld dest, bool *dest_used,
9009                      tree hook)
9010 {
9011   if ((left == error_mark_node)
9012       || (right == error_mark_node))
9013     return error_mark_node;
9014
9015   switch (TREE_CODE (tree_type))
9016     {
9017     case INTEGER_TYPE:
9018       return ffecom_2 (TRUNC_DIV_EXPR, tree_type,
9019                        left,
9020                        right);
9021
9022     case COMPLEX_TYPE:
9023       if (! optimize_size)
9024         return ffecom_2 (RDIV_EXPR, tree_type,
9025                          left,
9026                          right);
9027       {
9028         ffecomGfrt ix;
9029
9030         if (TREE_TYPE (tree_type)
9031             == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9032           ix = FFECOM_gfrtDIV_CC;       /* Overlapping result okay. */
9033         else
9034           ix = FFECOM_gfrtDIV_ZZ;       /* Overlapping result okay. */
9035
9036         left = ffecom_1 (ADDR_EXPR,
9037                          build_pointer_type (TREE_TYPE (left)),
9038                          left);
9039         left = build_tree_list (NULL_TREE, left);
9040         right = ffecom_1 (ADDR_EXPR,
9041                           build_pointer_type (TREE_TYPE (right)),
9042                           right);
9043         right = build_tree_list (NULL_TREE, right);
9044         TREE_CHAIN (left) = right;
9045
9046         return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9047                              ffecom_gfrt_kindtype (ix),
9048                              ffe_is_f2c_library (),
9049                              tree_type,
9050                              left,
9051                              dest_tree, dest, dest_used,
9052                              NULL_TREE, TRUE, hook);
9053       }
9054       break;
9055
9056     case RECORD_TYPE:
9057       {
9058         ffecomGfrt ix;
9059
9060         if (TREE_TYPE (TYPE_FIELDS (tree_type))
9061             == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9062           ix = FFECOM_gfrtDIV_CC;       /* Overlapping result okay. */
9063         else
9064           ix = FFECOM_gfrtDIV_ZZ;       /* Overlapping result okay. */
9065
9066         left = ffecom_1 (ADDR_EXPR,
9067                          build_pointer_type (TREE_TYPE (left)),
9068                          left);
9069         left = build_tree_list (NULL_TREE, left);
9070         right = ffecom_1 (ADDR_EXPR,
9071                           build_pointer_type (TREE_TYPE (right)),
9072                           right);
9073         right = build_tree_list (NULL_TREE, right);
9074         TREE_CHAIN (left) = right;
9075
9076         return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9077                              ffecom_gfrt_kindtype (ix),
9078                              ffe_is_f2c_library (),
9079                              tree_type,
9080                              left,
9081                              dest_tree, dest, dest_used,
9082                              NULL_TREE, TRUE, hook);
9083       }
9084       break;
9085
9086     default:
9087       return ffecom_2 (RDIV_EXPR, tree_type,
9088                        left,
9089                        right);
9090     }
9091 }
9092
9093 /* Build type info for non-dummy variable.  */
9094
9095 static tree
9096 ffecom_type_localvar_ (ffesymbol s, ffeinfoBasictype bt,
9097                        ffeinfoKindtype kt)
9098 {
9099   tree type;
9100   ffebld dl;
9101   ffebld dim;
9102   tree lowt;
9103   tree hight;
9104
9105   type = ffecom_tree_type[bt][kt];
9106   if (bt == FFEINFO_basictypeCHARACTER)
9107     {
9108       hight = build_int_2 (ffesymbol_size (s), 0);
9109       TREE_TYPE (hight) = ffecom_f2c_ftnlen_type_node;
9110
9111       type
9112         = build_array_type
9113           (type,
9114            build_range_type (ffecom_f2c_ftnlen_type_node,
9115                              ffecom_f2c_ftnlen_one_node,
9116                              hight));
9117       type = ffecom_check_size_overflow_ (s, type, FALSE);
9118     }
9119
9120   for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
9121     {
9122       if (type == error_mark_node)
9123         break;
9124
9125       dim = ffebld_head (dl);
9126       assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
9127
9128       if (ffebld_left (dim) == NULL)
9129         lowt = integer_one_node;
9130       else
9131         lowt = ffecom_expr (ffebld_left (dim));
9132
9133       if (TREE_CODE (lowt) != INTEGER_CST)
9134         lowt = variable_size (lowt);
9135
9136       assert (ffebld_right (dim) != NULL);
9137       hight = ffecom_expr (ffebld_right (dim));
9138
9139       if (TREE_CODE (hight) != INTEGER_CST)
9140         hight = variable_size (hight);
9141
9142       type = build_array_type (type,
9143                                build_range_type (ffecom_integer_type_node,
9144                                                  lowt, hight));
9145       type = ffecom_check_size_overflow_ (s, type, FALSE);
9146     }
9147
9148   return type;
9149 }
9150
9151 /* Build Namelist type.  */
9152
9153 static GTY(()) tree ffecom_type_namelist_var;
9154 static tree
9155 ffecom_type_namelist_ ()
9156 {
9157   if (ffecom_type_namelist_var == NULL_TREE)
9158     {
9159       tree namefield, varsfield, nvarsfield, vardesctype, type;
9160
9161       vardesctype = ffecom_type_vardesc_ ();
9162
9163       type = make_node (RECORD_TYPE);
9164
9165       vardesctype = build_pointer_type (build_pointer_type (vardesctype));
9166
9167       namefield = ffecom_decl_field (type, NULL_TREE, "name",
9168                                      string_type_node);
9169       varsfield = ffecom_decl_field (type, namefield, "vars", vardesctype);
9170       nvarsfield = ffecom_decl_field (type, varsfield, "nvars",
9171                                       integer_type_node);
9172
9173       TYPE_FIELDS (type) = namefield;
9174       layout_type (type);
9175
9176       ffecom_type_namelist_var = type;
9177     }
9178
9179   return ffecom_type_namelist_var;
9180 }
9181
9182 /* Build Vardesc type.  */
9183
9184 static GTY(()) tree ffecom_type_vardesc_var;
9185 static tree
9186 ffecom_type_vardesc_ ()
9187 {
9188   if (ffecom_type_vardesc_var == NULL_TREE)
9189     {
9190       tree namefield, addrfield, dimsfield, typefield, type;
9191       type = make_node (RECORD_TYPE);
9192
9193       namefield = ffecom_decl_field (type, NULL_TREE, "name",
9194                                      string_type_node);
9195       addrfield = ffecom_decl_field (type, namefield, "addr",
9196                                      string_type_node);
9197       dimsfield = ffecom_decl_field (type, addrfield, "dims",
9198                                      ffecom_f2c_ptr_to_ftnlen_type_node);
9199       typefield = ffecom_decl_field (type, dimsfield, "type",
9200                                      integer_type_node);
9201
9202       TYPE_FIELDS (type) = namefield;
9203       layout_type (type);
9204
9205       ffecom_type_vardesc_var = type;
9206     }
9207
9208   return ffecom_type_vardesc_var;
9209 }
9210
9211 static tree
9212 ffecom_vardesc_ (ffebld expr)
9213 {
9214   ffesymbol s;
9215
9216   assert (ffebld_op (expr) == FFEBLD_opSYMTER);
9217   s = ffebld_symter (expr);
9218
9219   if (ffesymbol_hook (s).vardesc_tree == NULL_TREE)
9220     {
9221       int i;
9222       tree vardesctype = ffecom_type_vardesc_ ();
9223       tree var;
9224       tree nameinit;
9225       tree dimsinit;
9226       tree addrinit;
9227       tree typeinit;
9228       tree field;
9229       tree varinits;
9230       static int mynumber = 0;
9231
9232       var = build_decl (VAR_DECL,
9233                         ffecom_get_invented_identifier ("__g77_vardesc_%d",
9234                                                         mynumber++),
9235                         vardesctype);
9236       TREE_STATIC (var) = 1;
9237       DECL_INITIAL (var) = error_mark_node;
9238
9239       var = start_decl (var, FALSE);
9240
9241       /* Process inits.  */
9242
9243       nameinit = ffecom_build_f2c_string_ ((i = strlen (ffesymbol_text (s)))
9244                                            + 1,
9245                                            ffesymbol_text (s));
9246       TREE_TYPE (nameinit)
9247         = build_type_variant
9248         (build_array_type
9249          (char_type_node,
9250           build_range_type (integer_type_node,
9251                             integer_one_node,
9252                             build_int_2 (i, 0))),
9253          1, 0);
9254       TREE_CONSTANT (nameinit) = 1;
9255       TREE_STATIC (nameinit) = 1;
9256       nameinit = ffecom_1 (ADDR_EXPR,
9257                            build_pointer_type (TREE_TYPE (nameinit)),
9258                            nameinit);
9259
9260       addrinit = ffecom_arg_ptr_to_expr (expr, &typeinit);
9261
9262       dimsinit = ffecom_vardesc_dims_ (s);
9263
9264       if (typeinit == NULL_TREE)
9265         {
9266           ffeinfoBasictype bt = ffesymbol_basictype (s);
9267           ffeinfoKindtype kt = ffesymbol_kindtype (s);
9268           int tc = ffecom_f2c_typecode (bt, kt);
9269
9270           assert (tc != -1);
9271           typeinit = build_int_2 (tc, (tc < 0) ? -1 : 0);
9272         }
9273       else
9274         typeinit = ffecom_1 (NEGATE_EXPR, TREE_TYPE (typeinit), typeinit);
9275
9276       varinits = build_tree_list ((field = TYPE_FIELDS (vardesctype)),
9277                                   nameinit);
9278       TREE_CHAIN (varinits) = build_tree_list ((field = TREE_CHAIN (field)),
9279                                                addrinit);
9280       TREE_CHAIN (TREE_CHAIN (varinits))
9281         = build_tree_list ((field = TREE_CHAIN (field)), dimsinit);
9282       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (varinits)))
9283         = build_tree_list ((field = TREE_CHAIN (field)), typeinit);
9284
9285       varinits = build_constructor (vardesctype, varinits);
9286       TREE_CONSTANT (varinits) = 1;
9287       TREE_STATIC (varinits) = 1;
9288
9289       finish_decl (var, varinits, FALSE);
9290
9291       var = ffecom_1 (ADDR_EXPR, build_pointer_type (vardesctype), var);
9292
9293       ffesymbol_hook (s).vardesc_tree = var;
9294     }
9295
9296   return ffesymbol_hook (s).vardesc_tree;
9297 }
9298
9299 static tree
9300 ffecom_vardesc_array_ (ffesymbol s)
9301 {
9302   ffebld b;
9303   tree list;
9304   tree item = NULL_TREE;
9305   tree var;
9306   int i;
9307   static int mynumber = 0;
9308
9309   for (i = 0, list = NULL_TREE, b = ffesymbol_namelist (s);
9310        b != NULL;
9311        b = ffebld_trail (b), ++i)
9312     {
9313       tree t;
9314
9315       t = ffecom_vardesc_ (ffebld_head (b));
9316
9317       if (list == NULL_TREE)
9318         list = item = build_tree_list (NULL_TREE, t);
9319       else
9320         {
9321           TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9322           item = TREE_CHAIN (item);
9323         }
9324     }
9325
9326   item = build_array_type (build_pointer_type (ffecom_type_vardesc_ ()),
9327                            build_range_type (integer_type_node,
9328                                              integer_one_node,
9329                                              build_int_2 (i, 0)));
9330   list = build_constructor (item, list);
9331   TREE_CONSTANT (list) = 1;
9332   TREE_STATIC (list) = 1;
9333
9334   var = ffecom_get_invented_identifier ("__g77_vardesc_array_%d", mynumber++);
9335   var = build_decl (VAR_DECL, var, item);
9336   TREE_STATIC (var) = 1;
9337   DECL_INITIAL (var) = error_mark_node;
9338   var = start_decl (var, FALSE);
9339   finish_decl (var, list, FALSE);
9340
9341   return var;
9342 }
9343
9344 static tree
9345 ffecom_vardesc_dims_ (ffesymbol s)
9346 {
9347   if (ffesymbol_dims (s) == NULL)
9348     return convert (ffecom_f2c_ptr_to_ftnlen_type_node,
9349                     integer_zero_node);
9350
9351   {
9352     ffebld b;
9353     ffebld e;
9354     tree list;
9355     tree backlist;
9356     tree item = NULL_TREE;
9357     tree var;
9358     tree numdim;
9359     tree numelem;
9360     tree baseoff = NULL_TREE;
9361     static int mynumber = 0;
9362
9363     numdim = build_int_2 ((int) ffesymbol_rank (s), 0);
9364     TREE_TYPE (numdim) = ffecom_f2c_ftnlen_type_node;
9365
9366     numelem = ffecom_expr (ffesymbol_arraysize (s));
9367     TREE_TYPE (numelem) = ffecom_f2c_ftnlen_type_node;
9368
9369     list = NULL_TREE;
9370     backlist = NULL_TREE;
9371     for (b = ffesymbol_dims (s), e = ffesymbol_extents (s);
9372          b != NULL;
9373          b = ffebld_trail (b), e = ffebld_trail (e))
9374       {
9375         tree t;
9376         tree low;
9377         tree back;
9378
9379         if (ffebld_trail (b) == NULL)
9380           t = NULL_TREE;
9381         else
9382           {
9383             t = convert (ffecom_f2c_ftnlen_type_node,
9384                          ffecom_expr (ffebld_head (e)));
9385
9386             if (list == NULL_TREE)
9387               list = item = build_tree_list (NULL_TREE, t);
9388             else
9389               {
9390                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9391                 item = TREE_CHAIN (item);
9392               }
9393           }
9394
9395         if (ffebld_left (ffebld_head (b)) == NULL)
9396           low = ffecom_integer_one_node;
9397         else
9398           low = ffecom_expr (ffebld_left (ffebld_head (b)));
9399         low = convert (ffecom_f2c_ftnlen_type_node, low);
9400
9401         back = build_tree_list (low, t);
9402         TREE_CHAIN (back) = backlist;
9403         backlist = back;
9404       }
9405
9406     for (item = backlist; item != NULL_TREE; item = TREE_CHAIN (item))
9407       {
9408         if (TREE_VALUE (item) == NULL_TREE)
9409           baseoff = TREE_PURPOSE (item);
9410         else
9411           baseoff = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
9412                               TREE_PURPOSE (item),
9413                               ffecom_2 (MULT_EXPR,
9414                                         ffecom_f2c_ftnlen_type_node,
9415                                         TREE_VALUE (item),
9416                                         baseoff));
9417       }
9418
9419     /* backlist now dead, along with all TREE_PURPOSEs on it.  */
9420
9421     baseoff = build_tree_list (NULL_TREE, baseoff);
9422     TREE_CHAIN (baseoff) = list;
9423
9424     numelem = build_tree_list (NULL_TREE, numelem);
9425     TREE_CHAIN (numelem) = baseoff;
9426
9427     numdim = build_tree_list (NULL_TREE, numdim);
9428     TREE_CHAIN (numdim) = numelem;
9429
9430     item = build_array_type (ffecom_f2c_ftnlen_type_node,
9431                              build_range_type (integer_type_node,
9432                                                integer_zero_node,
9433                                                build_int_2
9434                                                ((int) ffesymbol_rank (s)
9435                                                 + 2, 0)));
9436     list = build_constructor (item, numdim);
9437     TREE_CONSTANT (list) = 1;
9438     TREE_STATIC (list) = 1;
9439
9440     var = ffecom_get_invented_identifier ("__g77_dims_%d", mynumber++);
9441     var = build_decl (VAR_DECL, var, item);
9442     TREE_STATIC (var) = 1;
9443     DECL_INITIAL (var) = error_mark_node;
9444     var = start_decl (var, FALSE);
9445     finish_decl (var, list, FALSE);
9446
9447     var = ffecom_1 (ADDR_EXPR, build_pointer_type (item), var);
9448
9449     return var;
9450   }
9451 }
9452
9453 /* Essentially does a "fold (build1 (code, type, node))" while checking
9454    for certain housekeeping things.
9455
9456    NOTE: for building an ADDR_EXPR around a FUNCTION_DECL, use
9457    ffecom_1_fn instead.  */
9458
9459 tree
9460 ffecom_1 (enum tree_code code, tree type, tree node)
9461 {
9462   tree item;
9463
9464   if ((node == error_mark_node)
9465       || (type == error_mark_node))
9466     return error_mark_node;
9467
9468   if (code == ADDR_EXPR)
9469     {
9470       if (!ffe_mark_addressable (node))
9471         assert ("can't mark_addressable this node!" == NULL);
9472     }
9473
9474   switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9475     {
9476       tree realtype;
9477
9478     case REALPART_EXPR:
9479       item = build (COMPONENT_REF, type, node, TYPE_FIELDS (TREE_TYPE (node)));
9480       break;
9481
9482     case IMAGPART_EXPR:
9483       item = build (COMPONENT_REF, type, node, TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (node))));
9484       break;
9485
9486
9487     case NEGATE_EXPR:
9488       if (TREE_CODE (type) != RECORD_TYPE)
9489         {
9490           item = build1 (code, type, node);
9491           break;
9492         }
9493       node = ffecom_stabilize_aggregate_ (node);
9494       realtype = TREE_TYPE (TYPE_FIELDS (type));
9495       item =
9496         ffecom_2 (COMPLEX_EXPR, type,
9497                   ffecom_1 (NEGATE_EXPR, realtype,
9498                             ffecom_1 (REALPART_EXPR, realtype,
9499                                       node)),
9500                   ffecom_1 (NEGATE_EXPR, realtype,
9501                             ffecom_1 (IMAGPART_EXPR, realtype,
9502                                       node)));
9503       break;
9504
9505     default:
9506       item = build1 (code, type, node);
9507       break;
9508     }
9509
9510   if (TREE_SIDE_EFFECTS (node))
9511     TREE_SIDE_EFFECTS (item) = 1;
9512   if (code == ADDR_EXPR && staticp (node))
9513     TREE_CONSTANT (item) = 1;
9514   else if (code == INDIRECT_REF)
9515     TREE_READONLY (item) = TYPE_READONLY (type);
9516   return fold (item);
9517 }
9518
9519 /* Like ffecom_1 (ADDR_EXPR, TREE_TYPE (node), node), except
9520    handles TREE_CODE (node) == FUNCTION_DECL.  In particular,
9521    does not set TREE_ADDRESSABLE (because calling an inline
9522    function does not mean the function needs to be separately
9523    compiled).  */
9524
9525 tree
9526 ffecom_1_fn (tree node)
9527 {
9528   tree item;
9529   tree type;
9530
9531   if (node == error_mark_node)
9532     return error_mark_node;
9533
9534   type = build_type_variant (TREE_TYPE (node),
9535                              TREE_READONLY (node),
9536                              TREE_THIS_VOLATILE (node));
9537   item = build1 (ADDR_EXPR,
9538                  build_pointer_type (type), node);
9539   if (TREE_SIDE_EFFECTS (node))
9540     TREE_SIDE_EFFECTS (item) = 1;
9541   if (staticp (node))
9542     TREE_CONSTANT (item) = 1;
9543   return fold (item);
9544 }
9545
9546 /* Essentially does a "fold (build (code, type, node1, node2))" while
9547    checking for certain housekeeping things.  */
9548
9549 tree
9550 ffecom_2 (enum tree_code code, tree type, tree node1,
9551           tree node2)
9552 {
9553   tree item;
9554
9555   if ((node1 == error_mark_node)
9556       || (node2 == error_mark_node)
9557       || (type == error_mark_node))
9558     return error_mark_node;
9559
9560   switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9561     {
9562       tree a, b, c, d, realtype;
9563
9564     case CONJ_EXPR:
9565       assert ("no CONJ_EXPR support yet" == NULL);
9566       return error_mark_node;
9567
9568     case COMPLEX_EXPR:
9569       item = build_tree_list (TYPE_FIELDS (type), node1);
9570       TREE_CHAIN (item) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), node2);
9571       item = build_constructor (type, item);
9572       break;
9573
9574     case PLUS_EXPR:
9575       if (TREE_CODE (type) != RECORD_TYPE)
9576         {
9577           item = build (code, type, node1, node2);
9578           break;
9579         }
9580       node1 = ffecom_stabilize_aggregate_ (node1);
9581       node2 = ffecom_stabilize_aggregate_ (node2);
9582       realtype = TREE_TYPE (TYPE_FIELDS (type));
9583       item =
9584         ffecom_2 (COMPLEX_EXPR, type,
9585                   ffecom_2 (PLUS_EXPR, realtype,
9586                             ffecom_1 (REALPART_EXPR, realtype,
9587                                       node1),
9588                             ffecom_1 (REALPART_EXPR, realtype,
9589                                       node2)),
9590                   ffecom_2 (PLUS_EXPR, realtype,
9591                             ffecom_1 (IMAGPART_EXPR, realtype,
9592                                       node1),
9593                             ffecom_1 (IMAGPART_EXPR, realtype,
9594                                       node2)));
9595       break;
9596
9597     case MINUS_EXPR:
9598       if (TREE_CODE (type) != RECORD_TYPE)
9599         {
9600           item = build (code, type, node1, node2);
9601           break;
9602         }
9603       node1 = ffecom_stabilize_aggregate_ (node1);
9604       node2 = ffecom_stabilize_aggregate_ (node2);
9605       realtype = TREE_TYPE (TYPE_FIELDS (type));
9606       item =
9607         ffecom_2 (COMPLEX_EXPR, type,
9608                   ffecom_2 (MINUS_EXPR, realtype,
9609                             ffecom_1 (REALPART_EXPR, realtype,
9610                                       node1),
9611                             ffecom_1 (REALPART_EXPR, realtype,
9612                                       node2)),
9613                   ffecom_2 (MINUS_EXPR, realtype,
9614                             ffecom_1 (IMAGPART_EXPR, realtype,
9615                                       node1),
9616                             ffecom_1 (IMAGPART_EXPR, realtype,
9617                                       node2)));
9618       break;
9619
9620     case MULT_EXPR:
9621       if (TREE_CODE (type) != RECORD_TYPE)
9622         {
9623           item = build (code, type, node1, node2);
9624           break;
9625         }
9626       node1 = ffecom_stabilize_aggregate_ (node1);
9627       node2 = ffecom_stabilize_aggregate_ (node2);
9628       realtype = TREE_TYPE (TYPE_FIELDS (type));
9629       a = save_expr (ffecom_1 (REALPART_EXPR, realtype,
9630                                node1));
9631       b = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
9632                                node1));
9633       c = save_expr (ffecom_1 (REALPART_EXPR, realtype,
9634                                node2));
9635       d = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
9636                                node2));
9637       item =
9638         ffecom_2 (COMPLEX_EXPR, type,
9639                   ffecom_2 (MINUS_EXPR, realtype,
9640                             ffecom_2 (MULT_EXPR, realtype,
9641                                       a,
9642                                       c),
9643                             ffecom_2 (MULT_EXPR, realtype,
9644                                       b,
9645                                       d)),
9646                   ffecom_2 (PLUS_EXPR, realtype,
9647                             ffecom_2 (MULT_EXPR, realtype,
9648                                       a,
9649                                       d),
9650                             ffecom_2 (MULT_EXPR, realtype,
9651                                       c,
9652                                       b)));
9653       break;
9654
9655     case EQ_EXPR:
9656       if ((TREE_CODE (node1) != RECORD_TYPE)
9657           && (TREE_CODE (node2) != RECORD_TYPE))
9658         {
9659           item = build (code, type, node1, node2);
9660           break;
9661         }
9662       assert (TREE_CODE (node1) == RECORD_TYPE);
9663       assert (TREE_CODE (node2) == RECORD_TYPE);
9664       node1 = ffecom_stabilize_aggregate_ (node1);
9665       node2 = ffecom_stabilize_aggregate_ (node2);
9666       realtype = TREE_TYPE (TYPE_FIELDS (type));
9667       item =
9668         ffecom_2 (TRUTH_ANDIF_EXPR, type,
9669                   ffecom_2 (code, type,
9670                             ffecom_1 (REALPART_EXPR, realtype,
9671                                       node1),
9672                             ffecom_1 (REALPART_EXPR, realtype,
9673                                       node2)),
9674                   ffecom_2 (code, type,
9675                             ffecom_1 (IMAGPART_EXPR, realtype,
9676                                       node1),
9677                             ffecom_1 (IMAGPART_EXPR, realtype,
9678                                       node2)));
9679       break;
9680
9681     case NE_EXPR:
9682       if ((TREE_CODE (node1) != RECORD_TYPE)
9683           && (TREE_CODE (node2) != RECORD_TYPE))
9684         {
9685           item = build (code, type, node1, node2);
9686           break;
9687         }
9688       assert (TREE_CODE (node1) == RECORD_TYPE);
9689       assert (TREE_CODE (node2) == RECORD_TYPE);
9690       node1 = ffecom_stabilize_aggregate_ (node1);
9691       node2 = ffecom_stabilize_aggregate_ (node2);
9692       realtype = TREE_TYPE (TYPE_FIELDS (type));
9693       item =
9694         ffecom_2 (TRUTH_ORIF_EXPR, type,
9695                   ffecom_2 (code, type,
9696                             ffecom_1 (REALPART_EXPR, realtype,
9697                                       node1),
9698                             ffecom_1 (REALPART_EXPR, realtype,
9699                                       node2)),
9700                   ffecom_2 (code, type,
9701                             ffecom_1 (IMAGPART_EXPR, realtype,
9702                                       node1),
9703                             ffecom_1 (IMAGPART_EXPR, realtype,
9704                                       node2)));
9705       break;
9706
9707     default:
9708       item = build (code, type, node1, node2);
9709       break;
9710     }
9711
9712   if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2))
9713     TREE_SIDE_EFFECTS (item) = 1;
9714   return fold (item);
9715 }
9716
9717 /* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint
9718
9719    ffesymbol s;  // the ENTRY point itself
9720    if (ffecom_2pass_advise_entrypoint(s))
9721        // the ENTRY point has been accepted
9722
9723    Does whatever compiler needs to do when it learns about the entrypoint,
9724    like determine the return type of the master function, count the
9725    number of entrypoints, etc.  Returns FALSE if the return type is
9726    not compatible with the return type(s) of other entrypoint(s).
9727
9728    NOTE: for every call to this fn that returns TRUE, _do_entrypoint must
9729    later (after _finish_progunit) be called with the same entrypoint(s)
9730    as passed to this fn for which TRUE was returned.
9731
9732    03-Jan-92  JCB  2.0
9733       Return FALSE if the return type conflicts with previous entrypoints.  */
9734
9735 bool
9736 ffecom_2pass_advise_entrypoint (ffesymbol entry)
9737 {
9738   ffebld list;                  /* opITEM. */
9739   ffebld mlist;                 /* opITEM. */
9740   ffebld plist;                 /* opITEM. */
9741   ffebld arg;                   /* ffebld_head(opITEM). */
9742   ffebld item;                  /* opITEM. */
9743   ffesymbol s;                  /* ffebld_symter(arg). */
9744   ffeinfoBasictype bt = ffesymbol_basictype (entry);
9745   ffeinfoKindtype kt = ffesymbol_kindtype (entry);
9746   ffetargetCharacterSize size = ffesymbol_size (entry);
9747   bool ok;
9748
9749   if (ffecom_num_entrypoints_ == 0)
9750     {                           /* First entrypoint, make list of main
9751                                    arglist's dummies. */
9752       assert (ffecom_primary_entry_ != NULL);
9753
9754       ffecom_master_bt_ = ffesymbol_basictype (ffecom_primary_entry_);
9755       ffecom_master_kt_ = ffesymbol_kindtype (ffecom_primary_entry_);
9756       ffecom_master_size_ = ffesymbol_size (ffecom_primary_entry_);
9757
9758       for (plist = NULL, list = ffesymbol_dummyargs (ffecom_primary_entry_);
9759            list != NULL;
9760            list = ffebld_trail (list))
9761         {
9762           arg = ffebld_head (list);
9763           if (ffebld_op (arg) != FFEBLD_opSYMTER)
9764             continue;           /* Alternate return or some such thing. */
9765           item = ffebld_new_item (arg, NULL);
9766           if (plist == NULL)
9767             ffecom_master_arglist_ = item;
9768           else
9769             ffebld_set_trail (plist, item);
9770           plist = item;
9771         }
9772     }
9773
9774   /* If necessary, scan entry arglist for alternate returns.  Do this scan
9775      apparently redundantly (it's done below to UNIONize the arglists) so
9776      that we don't complain about RETURN 1 if an offending ENTRY is the only
9777      one with an alternate return.  */
9778
9779   if (!ffecom_is_altreturning_)
9780     {
9781       for (list = ffesymbol_dummyargs (entry);
9782            list != NULL;
9783            list = ffebld_trail (list))
9784         {
9785           arg = ffebld_head (list);
9786           if (ffebld_op (arg) == FFEBLD_opSTAR)
9787             {
9788               ffecom_is_altreturning_ = TRUE;
9789               break;
9790             }
9791         }
9792     }
9793
9794   /* Now check type compatibility. */
9795
9796   switch (ffecom_master_bt_)
9797     {
9798     case FFEINFO_basictypeNONE:
9799       ok = (bt != FFEINFO_basictypeCHARACTER);
9800       break;
9801
9802     case FFEINFO_basictypeCHARACTER:
9803       ok
9804         = (bt == FFEINFO_basictypeCHARACTER)
9805         && (kt == ffecom_master_kt_)
9806         && (size == ffecom_master_size_);
9807       break;
9808
9809     case FFEINFO_basictypeANY:
9810       return FALSE;             /* Just don't bother. */
9811
9812     default:
9813       if (bt == FFEINFO_basictypeCHARACTER)
9814         {
9815           ok = FALSE;
9816           break;
9817         }
9818       ok = TRUE;
9819       if ((bt != ffecom_master_bt_) || (kt != ffecom_master_kt_))
9820         {
9821           ffecom_master_bt_ = FFEINFO_basictypeNONE;
9822           ffecom_master_kt_ = FFEINFO_kindtypeNONE;
9823         }
9824       break;
9825     }
9826
9827   if (!ok)
9828     {
9829       ffebad_start (FFEBAD_ENTRY_CONFLICTS);
9830       ffest_ffebad_here_current_stmt (0);
9831       ffebad_finish ();
9832       return FALSE;             /* Can't handle entrypoint. */
9833     }
9834
9835   /* Entrypoint type compatible with previous types. */
9836
9837   ++ffecom_num_entrypoints_;
9838
9839   /* Master-arg-list = UNION(Master-arg-list,entry-arg-list). */
9840
9841   for (list = ffesymbol_dummyargs (entry);
9842        list != NULL;
9843        list = ffebld_trail (list))
9844     {
9845       arg = ffebld_head (list);
9846       if (ffebld_op (arg) != FFEBLD_opSYMTER)
9847         continue;               /* Alternate return or some such thing. */
9848       s = ffebld_symter (arg);
9849       for (plist = NULL, mlist = ffecom_master_arglist_;
9850            mlist != NULL;
9851            plist = mlist, mlist = ffebld_trail (mlist))
9852         {                       /* plist points to previous item for easy
9853                                    appending of arg. */
9854           if (ffebld_symter (ffebld_head (mlist)) == s)
9855             break;              /* Already have this arg in the master list. */
9856         }
9857       if (mlist != NULL)
9858         continue;               /* Already have this arg in the master list. */
9859
9860       /* Append this arg to the master list. */
9861
9862       item = ffebld_new_item (arg, NULL);
9863       if (plist == NULL)
9864         ffecom_master_arglist_ = item;
9865       else
9866         ffebld_set_trail (plist, item);
9867     }
9868
9869   return TRUE;
9870 }
9871
9872 /* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint
9873
9874    ffesymbol s;  // the ENTRY point itself
9875    ffecom_2pass_do_entrypoint(s);
9876
9877    Does whatever compiler needs to do to make the entrypoint actually
9878    happen.  Must be called for each entrypoint after
9879    ffecom_finish_progunit is called.  */
9880
9881 void
9882 ffecom_2pass_do_entrypoint (ffesymbol entry)
9883 {
9884   static int mfn_num = 0;
9885   static int ent_num;
9886
9887   if (mfn_num != ffecom_num_fns_)
9888     {                           /* First entrypoint for this program unit. */
9889       ent_num = 1;
9890       mfn_num = ffecom_num_fns_;
9891       ffecom_do_entry_ (ffecom_primary_entry_, 0);
9892     }
9893   else
9894     ++ent_num;
9895
9896   --ffecom_num_entrypoints_;
9897
9898   ffecom_do_entry_ (entry, ent_num);
9899 }
9900
9901 /* Essentially does a "fold (build (code, type, node1, node2))" while
9902    checking for certain housekeeping things.  Always sets
9903    TREE_SIDE_EFFECTS.  */
9904
9905 tree
9906 ffecom_2s (enum tree_code code, tree type, tree node1,
9907            tree node2)
9908 {
9909   tree item;
9910
9911   if ((node1 == error_mark_node)
9912       || (node2 == error_mark_node)
9913       || (type == error_mark_node))
9914     return error_mark_node;
9915
9916   item = build (code, type, node1, node2);
9917   TREE_SIDE_EFFECTS (item) = 1;
9918   return fold (item);
9919 }
9920
9921 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
9922    checking for certain housekeeping things.  */
9923
9924 tree
9925 ffecom_3 (enum tree_code code, tree type, tree node1,
9926           tree node2, tree node3)
9927 {
9928   tree item;
9929
9930   if ((node1 == error_mark_node)
9931       || (node2 == error_mark_node)
9932       || (node3 == error_mark_node)
9933       || (type == error_mark_node))
9934     return error_mark_node;
9935
9936   item = build (code, type, node1, node2, node3);
9937   if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2)
9938       || (node3 != NULL_TREE && TREE_SIDE_EFFECTS (node3)))
9939     TREE_SIDE_EFFECTS (item) = 1;
9940   return fold (item);
9941 }
9942
9943 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
9944    checking for certain housekeeping things.  Always sets
9945    TREE_SIDE_EFFECTS.  */
9946
9947 tree
9948 ffecom_3s (enum tree_code code, tree type, tree node1,
9949            tree node2, tree node3)
9950 {
9951   tree item;
9952
9953   if ((node1 == error_mark_node)
9954       || (node2 == error_mark_node)
9955       || (node3 == error_mark_node)
9956       || (type == error_mark_node))
9957     return error_mark_node;
9958
9959   item = build (code, type, node1, node2, node3);
9960   TREE_SIDE_EFFECTS (item) = 1;
9961   return fold (item);
9962 }
9963
9964 /* ffecom_arg_expr -- Transform argument expr into gcc tree
9965
9966    See use by ffecom_list_expr.
9967
9968    If expression is NULL, returns an integer zero tree.  If it is not
9969    a CHARACTER expression, returns whatever ffecom_expr
9970    returns and sets the length return value to NULL_TREE.  Otherwise
9971    generates code to evaluate the character expression, returns the proper
9972    pointer to the result, but does NOT set the length return value to a tree
9973    that specifies the length of the result.  (In other words, the length
9974    variable is always set to NULL_TREE, because a length is never passed.)
9975
9976    21-Dec-91  JCB  1.1
9977       Don't set returned length, since nobody needs it (yet; someday if
9978       we allow CHARACTER*(*) dummies to statement functions, we'll need
9979       it).  */
9980
9981 tree
9982 ffecom_arg_expr (ffebld expr, tree *length)
9983 {
9984   tree ign;
9985
9986   *length = NULL_TREE;
9987
9988   if (expr == NULL)
9989     return integer_zero_node;
9990
9991   if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
9992     return ffecom_expr (expr);
9993
9994   return ffecom_arg_ptr_to_expr (expr, &ign);
9995 }
9996
9997 /* Transform expression into constant argument-pointer-to-expression tree.
9998
9999    If the expression can be transformed into a argument-pointer-to-expression
10000    tree that is constant, that is done, and the tree returned.  Else
10001    NULL_TREE is returned.
10002
10003    That way, a caller can attempt to provide compile-time initialization
10004    of a variable and, if that fails, *then* choose to start a new block
10005    and resort to using temporaries, as appropriate.  */
10006
10007 tree
10008 ffecom_arg_ptr_to_const_expr (ffebld expr, tree *length)
10009 {
10010   if (! expr)
10011     return integer_zero_node;
10012
10013   if (ffebld_op (expr) == FFEBLD_opANY)
10014     {
10015       if (length)
10016         *length = error_mark_node;
10017       return error_mark_node;
10018     }
10019
10020   if (ffebld_arity (expr) == 0
10021       && (ffebld_op (expr) != FFEBLD_opSYMTER
10022           || ffebld_where (expr) == FFEINFO_whereCOMMON
10023           || ffebld_where (expr) == FFEINFO_whereGLOBAL
10024           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10025     {
10026       tree t;
10027
10028       t = ffecom_arg_ptr_to_expr (expr, length);
10029       assert (TREE_CONSTANT (t));
10030       assert (! length || TREE_CONSTANT (*length));
10031       return t;
10032     }
10033
10034   if (length
10035       && ffebld_size (expr) != FFETARGET_charactersizeNONE)
10036     *length = build_int_2 (ffebld_size (expr), 0);
10037   else if (length)
10038     *length = NULL_TREE;
10039   return NULL_TREE;
10040 }
10041
10042 /* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree
10043
10044    See use by ffecom_list_ptr_to_expr.
10045
10046    If expression is NULL, returns an integer zero tree.  If it is not
10047    a CHARACTER expression, returns whatever ffecom_ptr_to_expr
10048    returns and sets the length return value to NULL_TREE.  Otherwise
10049    generates code to evaluate the character expression, returns the proper
10050    pointer to the result, AND sets the length return value to a tree that
10051    specifies the length of the result.
10052
10053    If the length argument is NULL, this is a slightly special
10054    case of building a FORMAT expression, that is, an expression that
10055    will be used at run time without regard to length.  For the current
10056    implementation, which uses the libf2c library, this means it is nice
10057    to append a null byte to the end of the expression, where feasible,
10058    to make sure any diagnostic about the FORMAT string terminates at
10059    some useful point.
10060
10061    For now, treat %REF(char-expr) as the same as char-expr with a NULL
10062    length argument.  This might even be seen as a feature, if a null
10063    byte can always be appended.  */
10064
10065 tree
10066 ffecom_arg_ptr_to_expr (ffebld expr, tree *length)
10067 {
10068   tree item;
10069   tree ign_length;
10070   ffecomConcatList_ catlist;
10071
10072   if (length != NULL)
10073     *length = NULL_TREE;
10074
10075   if (expr == NULL)
10076     return integer_zero_node;
10077
10078   switch (ffebld_op (expr))
10079     {
10080     case FFEBLD_opPERCENT_VAL:
10081       if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10082         return ffecom_expr (ffebld_left (expr));
10083       {
10084         tree temp_exp;
10085         tree temp_length;
10086
10087         temp_exp = ffecom_arg_ptr_to_expr (ffebld_left (expr), &temp_length);
10088         if (temp_exp == error_mark_node)
10089           return error_mark_node;
10090
10091         return ffecom_1 (INDIRECT_REF, TREE_TYPE (TREE_TYPE (temp_exp)),
10092                          temp_exp);
10093       }
10094
10095     case FFEBLD_opPERCENT_REF:
10096       if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10097         return ffecom_ptr_to_expr (ffebld_left (expr));
10098       if (length != NULL)
10099         {
10100           ign_length = NULL_TREE;
10101           length = &ign_length;
10102         }
10103       expr = ffebld_left (expr);
10104       break;
10105
10106     case FFEBLD_opPERCENT_DESCR:
10107       switch (ffeinfo_basictype (ffebld_info (expr)))
10108         {
10109         case FFEINFO_basictypeCHARACTER:
10110           break;                /* Passed by descriptor anyway. */
10111
10112         default:
10113           item = ffecom_ptr_to_expr (expr);
10114           if (item != error_mark_node)
10115             *length = TYPE_SIZE (TREE_TYPE (TREE_TYPE (item)));
10116           break;
10117         }
10118       break;
10119
10120     default:
10121       break;
10122     }
10123
10124   if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10125     return ffecom_ptr_to_expr (expr);
10126
10127   assert (ffeinfo_kindtype (ffebld_info (expr))
10128           == FFEINFO_kindtypeCHARACTER1);
10129
10130   while (ffebld_op (expr) == FFEBLD_opPAREN)
10131     expr = ffebld_left (expr);
10132
10133   catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
10134   switch (ffecom_concat_list_count_ (catlist))
10135     {
10136     case 0:                     /* Shouldn't happen, but in case it does... */
10137       if (length != NULL)
10138         {
10139           *length = ffecom_f2c_ftnlen_zero_node;
10140           TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10141         }
10142       ffecom_concat_list_kill_ (catlist);
10143       return null_pointer_node;
10144
10145     case 1:                     /* The (fairly) easy case. */
10146       if (length == NULL)
10147         ffecom_char_args_with_null_ (&item, &ign_length,
10148                                      ffecom_concat_list_expr_ (catlist, 0));
10149       else
10150         ffecom_char_args_ (&item, length,
10151                            ffecom_concat_list_expr_ (catlist, 0));
10152       ffecom_concat_list_kill_ (catlist);
10153       assert (item != NULL_TREE);
10154       return item;
10155
10156     default:                    /* Must actually concatenate things. */
10157       break;
10158     }
10159
10160   {
10161     int count = ffecom_concat_list_count_ (catlist);
10162     int i;
10163     tree lengths;
10164     tree items;
10165     tree length_array;
10166     tree item_array;
10167     tree citem;
10168     tree clength;
10169     tree temporary;
10170     tree num;
10171     tree known_length;
10172     ffetargetCharacterSize sz;
10173
10174     sz = ffecom_concat_list_maxlen_ (catlist);
10175     /* ~~Kludge! */
10176     assert (sz != FFETARGET_charactersizeNONE);
10177
10178     {
10179       tree hook;
10180
10181       hook = ffebld_nonter_hook (expr);
10182       assert (hook);
10183       assert (TREE_CODE (hook) == TREE_VEC);
10184       assert (TREE_VEC_LENGTH (hook) == 3);
10185       length_array = lengths = TREE_VEC_ELT (hook, 0);
10186       item_array = items = TREE_VEC_ELT (hook, 1);
10187       temporary = TREE_VEC_ELT (hook, 2);
10188     }
10189
10190     known_length = ffecom_f2c_ftnlen_zero_node;
10191
10192     for (i = 0; i < count; ++i)
10193       {
10194         if ((i == count)
10195             && (length == NULL))
10196           ffecom_char_args_with_null_ (&citem, &clength,
10197                                        ffecom_concat_list_expr_ (catlist, i));
10198         else
10199           ffecom_char_args_ (&citem, &clength,
10200                              ffecom_concat_list_expr_ (catlist, i));
10201         if ((citem == error_mark_node)
10202             || (clength == error_mark_node))
10203           {
10204             ffecom_concat_list_kill_ (catlist);
10205             *length = error_mark_node;
10206             return error_mark_node;
10207           }
10208
10209         items
10210           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
10211                       ffecom_modify (void_type_node,
10212                                      ffecom_2 (ARRAY_REF,
10213                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
10214                                                item_array,
10215                                                build_int_2 (i, 0)),
10216                                      citem),
10217                       items);
10218         clength = ffecom_save_tree (clength);
10219         if (length != NULL)
10220           known_length
10221             = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
10222                         known_length,
10223                         clength);
10224         lengths
10225           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
10226                       ffecom_modify (void_type_node,
10227                                      ffecom_2 (ARRAY_REF,
10228                    TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
10229                                                length_array,
10230                                                build_int_2 (i, 0)),
10231                                      clength),
10232                       lengths);
10233       }
10234
10235     temporary = ffecom_1 (ADDR_EXPR,
10236                           build_pointer_type (TREE_TYPE (temporary)),
10237                           temporary);
10238
10239     item = build_tree_list (NULL_TREE, temporary);
10240     TREE_CHAIN (item)
10241       = build_tree_list (NULL_TREE,
10242                          ffecom_1 (ADDR_EXPR,
10243                                    build_pointer_type (TREE_TYPE (items)),
10244                                    items));
10245     TREE_CHAIN (TREE_CHAIN (item))
10246       = build_tree_list (NULL_TREE,
10247                          ffecom_1 (ADDR_EXPR,
10248                                    build_pointer_type (TREE_TYPE (lengths)),
10249                                    lengths));
10250     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
10251       = build_tree_list
10252         (NULL_TREE,
10253          ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
10254                    convert (ffecom_f2c_ftnlen_type_node,
10255                             build_int_2 (count, 0))));
10256     num = build_int_2 (sz, 0);
10257     TREE_TYPE (num) = ffecom_f2c_ftnlen_type_node;
10258     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item))))
10259       = build_tree_list (NULL_TREE, num);
10260
10261     item = ffecom_call_gfrt (FFECOM_gfrtCAT, item, NULL_TREE);
10262     TREE_SIDE_EFFECTS (item) = 1;
10263     item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (temporary),
10264                      item,
10265                      temporary);
10266
10267     if (length != NULL)
10268       *length = known_length;
10269   }
10270
10271   ffecom_concat_list_kill_ (catlist);
10272   assert (item != NULL_TREE);
10273   return item;
10274 }
10275
10276 /* Generate call to run-time function.
10277
10278    The first arg is the GNU Fortran Run-Time function index, the second
10279    arg is the list of arguments to pass to it.  Returned is the expression
10280    (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the
10281    result (which may be void).  */
10282
10283 tree
10284 ffecom_call_gfrt (ffecomGfrt ix, tree args, tree hook)
10285 {
10286   return ffecom_call_ (ffecom_gfrt_tree_ (ix),
10287                        ffecom_gfrt_kindtype (ix),
10288                        ffe_is_f2c_library () && ffecom_gfrt_complex_[ix],
10289                        NULL_TREE, args, NULL_TREE, NULL,
10290                        NULL, NULL_TREE, TRUE, hook);
10291 }
10292
10293 /* Transform constant-union to tree.  */
10294
10295 tree
10296 ffecom_constantunion (ffebldConstantUnion *cu, ffeinfoBasictype bt,
10297                       ffeinfoKindtype kt, tree tree_type)
10298 {
10299   tree item;
10300
10301   switch (bt)
10302     {
10303     case FFEINFO_basictypeINTEGER:
10304       {
10305         HOST_WIDE_INT hi, lo;
10306
10307         switch (kt)
10308           {
10309 #if FFETARGET_okINTEGER1
10310           case FFEINFO_kindtypeINTEGER1:
10311             lo = ffebld_cu_val_integer1 (*cu);
10312             hi = (lo < 0) ? -1 : 0;
10313             break;
10314 #endif
10315
10316 #if FFETARGET_okINTEGER2
10317           case FFEINFO_kindtypeINTEGER2:
10318             lo = ffebld_cu_val_integer2 (*cu);
10319             hi = (lo < 0) ? -1 : 0;
10320             break;
10321 #endif
10322
10323 #if FFETARGET_okINTEGER3
10324           case FFEINFO_kindtypeINTEGER3:
10325             lo = ffebld_cu_val_integer3 (*cu);
10326             hi = (lo < 0) ? -1 : 0;
10327             break;
10328 #endif
10329
10330 #if FFETARGET_okINTEGER4
10331           case FFEINFO_kindtypeINTEGER4:
10332 #if HOST_BITS_PER_LONGLONG > HOST_BITS_PER_WIDE_INT
10333             {
10334               long long int big = ffebld_cu_val_integer4 (*cu);
10335               hi = (HOST_WIDE_INT) (big >> HOST_BITS_PER_WIDE_INT);
10336               lo = (HOST_WIDE_INT) big;
10337             }
10338 #else
10339             lo = ffebld_cu_val_integer4 (*cu);
10340             hi = (lo < 0) ? -1 : 0;
10341 #endif
10342             break;
10343 #endif
10344
10345           default:
10346             assert ("bad INTEGER constant kind type" == NULL);
10347             /* Fall through. */
10348           case FFEINFO_kindtypeANY:
10349             return error_mark_node;
10350           }
10351         item = build_int_2 (lo, hi);
10352         TREE_TYPE (item) = tree_type;
10353       }
10354       break;
10355
10356     case FFEINFO_basictypeLOGICAL:
10357       {
10358         int val;
10359
10360         switch (kt)
10361           {
10362 #if FFETARGET_okLOGICAL1
10363           case FFEINFO_kindtypeLOGICAL1:
10364             val = ffebld_cu_val_logical1 (*cu);
10365             break;
10366 #endif
10367
10368 #if FFETARGET_okLOGICAL2
10369           case FFEINFO_kindtypeLOGICAL2:
10370             val = ffebld_cu_val_logical2 (*cu);
10371             break;
10372 #endif
10373
10374 #if FFETARGET_okLOGICAL3
10375           case FFEINFO_kindtypeLOGICAL3:
10376             val = ffebld_cu_val_logical3 (*cu);
10377             break;
10378 #endif
10379
10380 #if FFETARGET_okLOGICAL4
10381           case FFEINFO_kindtypeLOGICAL4:
10382             val = ffebld_cu_val_logical4 (*cu);
10383             break;
10384 #endif
10385
10386           default:
10387             assert ("bad LOGICAL constant kind type" == NULL);
10388             /* Fall through. */
10389           case FFEINFO_kindtypeANY:
10390             return error_mark_node;
10391           }
10392         item = build_int_2 (val, (val < 0) ? -1 : 0);
10393         TREE_TYPE (item) = tree_type;
10394       }
10395       break;
10396
10397     case FFEINFO_basictypeREAL:
10398       {
10399         REAL_VALUE_TYPE val;
10400
10401         switch (kt)
10402           {
10403 #if FFETARGET_okREAL1
10404           case FFEINFO_kindtypeREAL1:
10405             val = ffetarget_value_real1 (ffebld_cu_val_real1 (*cu));
10406             break;
10407 #endif
10408
10409 #if FFETARGET_okREAL2
10410           case FFEINFO_kindtypeREAL2:
10411             val = ffetarget_value_real2 (ffebld_cu_val_real2 (*cu));
10412             break;
10413 #endif
10414
10415 #if FFETARGET_okREAL3
10416           case FFEINFO_kindtypeREAL3:
10417             val = ffetarget_value_real3 (ffebld_cu_val_real3 (*cu));
10418             break;
10419 #endif
10420
10421           default:
10422             assert ("bad REAL constant kind type" == NULL);
10423             /* Fall through. */
10424           case FFEINFO_kindtypeANY:
10425             return error_mark_node;
10426           }
10427         item = build_real (tree_type, val);
10428       }
10429       break;
10430
10431     case FFEINFO_basictypeCOMPLEX:
10432       {
10433         REAL_VALUE_TYPE real;
10434         REAL_VALUE_TYPE imag;
10435         tree el_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
10436
10437         switch (kt)
10438           {
10439 #if FFETARGET_okCOMPLEX1
10440           case FFEINFO_kindtypeREAL1:
10441             real = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).real);
10442             imag = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).imaginary);
10443             break;
10444 #endif
10445
10446 #if FFETARGET_okCOMPLEX2
10447           case FFEINFO_kindtypeREAL2:
10448             real = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).real);
10449             imag = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).imaginary);
10450             break;
10451 #endif
10452
10453 #if FFETARGET_okCOMPLEX3
10454           case FFEINFO_kindtypeREAL3:
10455             real = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).real);
10456             imag = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).imaginary);
10457             break;
10458 #endif
10459
10460           default:
10461             assert ("bad REAL constant kind type" == NULL);
10462             /* Fall through. */
10463           case FFEINFO_kindtypeANY:
10464             return error_mark_node;
10465           }
10466         item = ffecom_build_complex_constant_ (tree_type,
10467                                                build_real (el_type, real),
10468                                                build_real (el_type, imag));
10469       }
10470       break;
10471
10472     case FFEINFO_basictypeCHARACTER:
10473       {                         /* Happens only in DATA and similar contexts. */
10474         ffetargetCharacter1 val;
10475
10476         switch (kt)
10477           {
10478 #if FFETARGET_okCHARACTER1
10479           case FFEINFO_kindtypeLOGICAL1:
10480             val = ffebld_cu_val_character1 (*cu);
10481             break;
10482 #endif
10483
10484           default:
10485             assert ("bad CHARACTER constant kind type" == NULL);
10486             /* Fall through. */
10487           case FFEINFO_kindtypeANY:
10488             return error_mark_node;
10489           }
10490         item = build_string (ffetarget_length_character1 (val),
10491                              ffetarget_text_character1 (val));
10492         TREE_TYPE (item)
10493           = build_type_variant (build_array_type (char_type_node,
10494                                                   build_range_type
10495                                                   (integer_type_node,
10496                                                    integer_one_node,
10497                                                    build_int_2
10498                                                 (ffetarget_length_character1
10499                                                  (val), 0))),
10500                                 1, 0);
10501       }
10502       break;
10503
10504     case FFEINFO_basictypeHOLLERITH:
10505       {
10506         ffetargetHollerith h;
10507
10508         h = ffebld_cu_val_hollerith (*cu);
10509
10510         /* If not at least as wide as default INTEGER, widen it.  */
10511         if (h.length >= FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE)
10512           item = build_string (h.length, h.text);
10513         else
10514           {
10515             char str[FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE];
10516
10517             memcpy (str, h.text, h.length);
10518             memset (&str[h.length], ' ',
10519                     FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE
10520                     - h.length);
10521             item = build_string (FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE,
10522                                  str);
10523           }
10524         TREE_TYPE (item)
10525           = build_type_variant (build_array_type (char_type_node,
10526                                                   build_range_type
10527                                                   (integer_type_node,
10528                                                    integer_one_node,
10529                                                    build_int_2
10530                                                    (h.length, 0))),
10531                                 1, 0);
10532       }
10533       break;
10534
10535     case FFEINFO_basictypeTYPELESS:
10536       {
10537         ffetargetInteger1 ival;
10538         ffetargetTypeless tless;
10539         ffebad error;
10540
10541         tless = ffebld_cu_val_typeless (*cu);
10542         error = ffetarget_convert_integer1_typeless (&ival, tless);
10543         assert (error == FFEBAD);
10544
10545         item = build_int_2 ((int) ival, 0);
10546       }
10547       break;
10548
10549     default:
10550       assert ("not yet on constant type" == NULL);
10551       /* Fall through. */
10552     case FFEINFO_basictypeANY:
10553       return error_mark_node;
10554     }
10555
10556   TREE_CONSTANT (item) = 1;
10557
10558   return item;
10559 }
10560
10561 /* Transform constant-union to tree, with the type known.  */
10562
10563 tree
10564 ffecom_constantunion_with_type (ffebldConstantUnion *cu,
10565                       tree tree_type, ffebldConst ct)
10566 {
10567   tree item;
10568
10569   int val;
10570
10571   switch (ct)
10572   {
10573 #if FFETARGET_okINTEGER1
10574           case  FFEBLD_constINTEGER1:
10575           val = ffebld_cu_val_integer1 (*cu);
10576                   item = build_int_2 (val, (val < 0) ? -1 : 0);
10577                   break;
10578 #endif
10579 #if FFETARGET_okINTEGER2
10580           case  FFEBLD_constINTEGER2:
10581                   val = ffebld_cu_val_integer2 (*cu);
10582                   item = build_int_2 (val, (val < 0) ? -1 : 0);
10583                   break;
10584 #endif
10585 #if FFETARGET_okINTEGER3
10586           case  FFEBLD_constINTEGER3:
10587                   val = ffebld_cu_val_integer3 (*cu);
10588                   item = build_int_2 (val, (val < 0) ? -1 : 0);
10589                   break;
10590 #endif
10591 #if FFETARGET_okINTEGER4
10592           case  FFEBLD_constINTEGER4:
10593 #if HOST_BITS_PER_LONGLONG > HOST_BITS_PER_WIDE_INT
10594                   {
10595                     long long int big = ffebld_cu_val_integer4 (*cu);
10596                     item = build_int_2 ((HOST_WIDE_INT) big,
10597                                         (HOST_WIDE_INT)
10598                                         (big >> HOST_BITS_PER_WIDE_INT));
10599                   }
10600 #else
10601                   val = ffebld_cu_val_integer4 (*cu);
10602                   item = build_int_2 (val, (val < 0) ? -1 : 0);
10603 #endif
10604                   break;
10605 #endif
10606 #if FFETARGET_okLOGICAL1
10607           case  FFEBLD_constLOGICAL1:
10608                   val = ffebld_cu_val_logical1 (*cu);
10609                   item = build_int_2 (val, (val < 0) ? -1 : 0);
10610                   break;
10611 #endif
10612 #if FFETARGET_okLOGICAL2
10613           case  FFEBLD_constLOGICAL2:
10614                   val = ffebld_cu_val_logical2 (*cu);
10615                   item = build_int_2 (val, (val < 0) ? -1 : 0);
10616                   break;
10617 #endif
10618 #if FFETARGET_okLOGICAL3
10619           case  FFEBLD_constLOGICAL3:
10620                   val = ffebld_cu_val_logical3 (*cu);
10621                   item = build_int_2 (val, (val < 0) ? -1 : 0);
10622                   break;
10623 #endif
10624 #if FFETARGET_okLOGICAL4
10625           case  FFEBLD_constLOGICAL4:
10626                   val = ffebld_cu_val_logical4 (*cu);
10627                   item = build_int_2 (val, (val < 0) ? -1 : 0);
10628                   break;
10629 #endif
10630           default:
10631                   assert ("constant type not supported"==NULL);
10632                   return error_mark_node;
10633                   break;
10634   }
10635
10636   TREE_TYPE (item) = tree_type;
10637
10638   TREE_CONSTANT (item) = 1;
10639
10640   return item;
10641 }
10642 /* Transform expression into constant tree.
10643
10644    If the expression can be transformed into a tree that is constant,
10645    that is done, and the tree returned.  Else NULL_TREE is returned.
10646
10647    That way, a caller can attempt to provide compile-time initialization
10648    of a variable and, if that fails, *then* choose to start a new block
10649    and resort to using temporaries, as appropriate.  */
10650
10651 tree
10652 ffecom_const_expr (ffebld expr)
10653 {
10654   if (! expr)
10655     return integer_zero_node;
10656
10657   if (ffebld_op (expr) == FFEBLD_opANY)
10658     return error_mark_node;
10659
10660   if (ffebld_arity (expr) == 0
10661       && (ffebld_op (expr) != FFEBLD_opSYMTER
10662           || ffebld_where (expr) == FFEINFO_whereGLOBAL
10663           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10664     {
10665       tree t;
10666
10667       t = ffecom_expr (expr);
10668       assert (TREE_CONSTANT (t));
10669       return t;
10670     }
10671
10672   return NULL_TREE;
10673 }
10674
10675 /* Handy way to make a field in a struct/union.  */
10676
10677 tree
10678 ffecom_decl_field (tree context, tree prevfield,
10679                    const char *name, tree type)
10680 {
10681   tree field;
10682
10683   field = build_decl (FIELD_DECL, get_identifier (name), type);
10684   DECL_CONTEXT (field) = context;
10685   DECL_ALIGN (field) = 0;
10686   DECL_USER_ALIGN (field) = 0;
10687   if (prevfield != NULL_TREE)
10688     TREE_CHAIN (prevfield) = field;
10689
10690   return field;
10691 }
10692
10693 void
10694 ffecom_close_include (FILE *f)
10695 {
10696   ffecom_close_include_ (f);
10697 }
10698
10699 /* End a compound statement (block).  */
10700
10701 tree
10702 ffecom_end_compstmt (void)
10703 {
10704   return bison_rule_compstmt_ ();
10705 }
10706
10707 /* ffecom_end_transition -- Perform end transition on all symbols
10708
10709    ffecom_end_transition();
10710
10711    Calls ffecom_sym_end_transition for each global and local symbol.  */
10712
10713 void
10714 ffecom_end_transition ()
10715 {
10716   ffebld item;
10717
10718   if (ffe_is_ffedebug ())
10719     fprintf (dmpout, "; end_stmt_transition\n");
10720
10721   ffecom_list_blockdata_ = NULL;
10722   ffecom_list_common_ = NULL;
10723
10724   ffesymbol_drive (ffecom_sym_end_transition);
10725   if (ffe_is_ffedebug ())
10726     {
10727       ffestorag_report ();
10728     }
10729
10730   ffecom_start_progunit_ ();
10731
10732   for (item = ffecom_list_blockdata_;
10733        item != NULL;
10734        item = ffebld_trail (item))
10735     {
10736       ffebld callee;
10737       ffesymbol s;
10738       tree dt;
10739       tree t;
10740       tree var;
10741       static int number = 0;
10742
10743       callee = ffebld_head (item);
10744       s = ffebld_symter (callee);
10745       t = ffesymbol_hook (s).decl_tree;
10746       if (t == NULL_TREE)
10747         {
10748           s = ffecom_sym_transform_ (s);
10749           t = ffesymbol_hook (s).decl_tree;
10750         }
10751
10752       dt = build_pointer_type (TREE_TYPE (t));
10753
10754       var = build_decl (VAR_DECL,
10755                         ffecom_get_invented_identifier ("__g77_forceload_%d",
10756                                                         number++),
10757                         dt);
10758       DECL_EXTERNAL (var) = 0;
10759       TREE_STATIC (var) = 1;
10760       TREE_PUBLIC (var) = 0;
10761       DECL_INITIAL (var) = error_mark_node;
10762       TREE_USED (var) = 1;
10763
10764       var = start_decl (var, FALSE);
10765
10766       t = ffecom_1 (ADDR_EXPR, dt, t);
10767
10768       finish_decl (var, t, FALSE);
10769     }
10770
10771   /* This handles any COMMON areas that weren't referenced but have, for
10772      example, important initial data.  */
10773
10774   for (item = ffecom_list_common_;
10775        item != NULL;
10776        item = ffebld_trail (item))
10777     ffecom_transform_common_ (ffebld_symter (ffebld_head (item)));
10778
10779   ffecom_list_common_ = NULL;
10780 }
10781
10782 /* ffecom_exec_transition -- Perform exec transition on all symbols
10783
10784    ffecom_exec_transition();
10785
10786    Calls ffecom_sym_exec_transition for each global and local symbol.
10787    Make sure error updating not inhibited.  */
10788
10789 void
10790 ffecom_exec_transition ()
10791 {
10792   bool inhibited;
10793
10794   if (ffe_is_ffedebug ())
10795     fprintf (dmpout, "; exec_stmt_transition\n");
10796
10797   inhibited = ffebad_inhibit ();
10798   ffebad_set_inhibit (FALSE);
10799
10800   ffesymbol_drive (ffecom_sym_exec_transition); /* Don't retract! */
10801   ffeequiv_exec_transition ();  /* Handle all pending EQUIVALENCEs. */
10802   if (ffe_is_ffedebug ())
10803     {
10804       ffestorag_report ();
10805     }
10806
10807   if (inhibited)
10808     ffebad_set_inhibit (TRUE);
10809 }
10810
10811 /* Handle assignment statement.
10812
10813    Convert dest and source using ffecom_expr, then join them
10814    with an ASSIGN op and pass the whole thing to expand_expr_stmt.  */
10815
10816 void
10817 ffecom_expand_let_stmt (ffebld dest, ffebld source)
10818 {
10819   tree dest_tree;
10820   tree dest_length;
10821   tree source_tree;
10822   tree expr_tree;
10823
10824   if (ffeinfo_basictype (ffebld_info (dest)) != FFEINFO_basictypeCHARACTER)
10825     {
10826       bool dest_used;
10827       tree assign_temp;
10828
10829       /* This attempts to replicate the test below, but must not be
10830          true when the test below is false.  (Always err on the side
10831          of creating unused temporaries, to avoid ICEs.)  */
10832       if (ffebld_op (dest) != FFEBLD_opSYMTER
10833           || ((dest_tree = ffesymbol_hook (ffebld_symter (dest)).decl_tree)
10834               && (TREE_CODE (dest_tree) != VAR_DECL
10835                   || TREE_ADDRESSABLE (dest_tree))))
10836         {
10837           ffecom_prepare_expr_ (source, dest);
10838           dest_used = TRUE;
10839         }
10840       else
10841         {
10842           ffecom_prepare_expr_ (source, NULL);
10843           dest_used = FALSE;
10844         }
10845
10846       ffecom_prepare_expr_w (NULL_TREE, dest);
10847
10848       /* For COMPLEX assignment like C1=C2, if partial overlap is possible,
10849          create a temporary through which the assignment is to take place,
10850          since MODIFY_EXPR doesn't handle partial overlap properly.  */
10851       if (ffebld_basictype (dest) == FFEINFO_basictypeCOMPLEX
10852           && ffecom_possible_partial_overlap_ (dest, source))
10853         {
10854           assign_temp = ffecom_make_tempvar ("complex_let",
10855                                              ffecom_tree_type
10856                                              [ffebld_basictype (dest)]
10857                                              [ffebld_kindtype (dest)],
10858                                              FFETARGET_charactersizeNONE,
10859                                              -1);
10860         }
10861       else
10862         assign_temp = NULL_TREE;
10863
10864       ffecom_prepare_end ();
10865
10866       dest_tree = ffecom_expr_w (NULL_TREE, dest);
10867       if (dest_tree == error_mark_node)
10868         return;
10869
10870       if ((TREE_CODE (dest_tree) != VAR_DECL)
10871           || TREE_ADDRESSABLE (dest_tree))
10872         source_tree = ffecom_expr_ (source, dest_tree, dest, &dest_used,
10873                                     FALSE, FALSE);
10874       else
10875         {
10876           assert (! dest_used);
10877           dest_used = FALSE;
10878           source_tree = ffecom_expr (source);
10879         }
10880       if (source_tree == error_mark_node)
10881         return;
10882
10883       if (dest_used)
10884         expr_tree = source_tree;
10885       else if (assign_temp)
10886         {
10887           expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
10888                                  assign_temp,
10889                                  source_tree);
10890           expand_expr_stmt (expr_tree);
10891           expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
10892                                  dest_tree,
10893                                  assign_temp);
10894         }
10895       else
10896         expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
10897                                dest_tree,
10898                                source_tree);
10899
10900       expand_expr_stmt (expr_tree);
10901       return;
10902     }
10903
10904   ffecom_prepare_let_char_ (ffebld_size_known (dest), source);
10905   ffecom_prepare_expr_w (NULL_TREE, dest);
10906
10907   ffecom_prepare_end ();
10908
10909   ffecom_char_args_ (&dest_tree, &dest_length, dest);
10910   ffecom_let_char_ (dest_tree, dest_length, ffebld_size_known (dest),
10911                     source);
10912 }
10913
10914 /* ffecom_expr -- Transform expr into gcc tree
10915
10916    tree t;
10917    ffebld expr;  // FFE expression.
10918    tree = ffecom_expr(expr);
10919
10920    Recursive descent on expr while making corresponding tree nodes and
10921    attaching type info and such.  */
10922
10923 tree
10924 ffecom_expr (ffebld expr)
10925 {
10926   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, FALSE, FALSE);
10927 }
10928
10929 /* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT.  */
10930
10931 tree
10932 ffecom_expr_assign (ffebld expr)
10933 {
10934   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
10935 }
10936
10937 /* Like ffecom_expr_rw, but return tree usable for ASSIGN.  */
10938
10939 tree
10940 ffecom_expr_assign_w (ffebld expr)
10941 {
10942   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
10943 }
10944
10945 /* Transform expr for use as into read/write tree and stabilize the
10946    reference.  Not for use on CHARACTER expressions.
10947
10948    Recursive descent on expr while making corresponding tree nodes and
10949    attaching type info and such.  */
10950
10951 tree
10952 ffecom_expr_rw (tree type, ffebld expr)
10953 {
10954   assert (expr != NULL);
10955   /* Different target types not yet supported.  */
10956   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
10957
10958   return stabilize_reference (ffecom_expr (expr));
10959 }
10960
10961 /* Transform expr for use as into write tree and stabilize the
10962    reference.  Not for use on CHARACTER expressions.
10963
10964    Recursive descent on expr while making corresponding tree nodes and
10965    attaching type info and such.  */
10966
10967 tree
10968 ffecom_expr_w (tree type, ffebld expr)
10969 {
10970   assert (expr != NULL);
10971   /* Different target types not yet supported.  */
10972   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
10973
10974   return stabilize_reference (ffecom_expr (expr));
10975 }
10976
10977 /* Do global stuff.  */
10978
10979 void
10980 ffecom_finish_compile ()
10981 {
10982   assert (ffecom_outer_function_decl_ == NULL_TREE);
10983   assert (current_function_decl == NULL_TREE);
10984
10985   ffeglobal_drive (ffecom_finish_global_);
10986 }
10987
10988 /* Public entry point for front end to access finish_decl.  */
10989
10990 void
10991 ffecom_finish_decl (tree decl, tree init, bool is_top_level)
10992 {
10993   assert (!is_top_level);
10994   finish_decl (decl, init, FALSE);
10995 }
10996
10997 /* Finish a program unit.  */
10998
10999 void
11000 ffecom_finish_progunit ()
11001 {
11002   ffecom_end_compstmt ();
11003
11004   ffecom_previous_function_decl_ = current_function_decl;
11005   ffecom_which_entrypoint_decl_ = NULL_TREE;
11006
11007   finish_function (0);
11008 }
11009
11010 /* Wrapper for get_identifier.  pattern is sprintf-like.  */
11011
11012 tree
11013 ffecom_get_invented_identifier (const char *pattern, ...)
11014 {
11015   tree decl;
11016   char *nam;
11017   va_list ap;
11018
11019   va_start (ap, pattern);
11020   if (vasprintf (&nam, pattern, ap) == 0)
11021     abort ();
11022   va_end (ap);
11023   decl = get_identifier (nam);
11024   free (nam);
11025   IDENTIFIER_INVENTED (decl) = 1;
11026   return decl;
11027 }
11028
11029 ffeinfoBasictype
11030 ffecom_gfrt_basictype (ffecomGfrt gfrt)
11031 {
11032   assert (gfrt < FFECOM_gfrt);
11033
11034   switch (ffecom_gfrt_type_[gfrt])
11035     {
11036     case FFECOM_rttypeVOID_:
11037     case FFECOM_rttypeVOIDSTAR_:
11038       return FFEINFO_basictypeNONE;
11039
11040     case FFECOM_rttypeFTNINT_:
11041       return FFEINFO_basictypeINTEGER;
11042
11043     case FFECOM_rttypeINTEGER_:
11044       return FFEINFO_basictypeINTEGER;
11045
11046     case FFECOM_rttypeLONGINT_:
11047       return FFEINFO_basictypeINTEGER;
11048
11049     case FFECOM_rttypeLOGICAL_:
11050       return FFEINFO_basictypeLOGICAL;
11051
11052     case FFECOM_rttypeREAL_F2C_:
11053     case FFECOM_rttypeREAL_GNU_:
11054       return FFEINFO_basictypeREAL;
11055
11056     case FFECOM_rttypeCOMPLEX_F2C_:
11057     case FFECOM_rttypeCOMPLEX_GNU_:
11058       return FFEINFO_basictypeCOMPLEX;
11059
11060     case FFECOM_rttypeDOUBLE_:
11061     case FFECOM_rttypeDOUBLEREAL_:
11062       return FFEINFO_basictypeREAL;
11063
11064     case FFECOM_rttypeDBLCMPLX_F2C_:
11065     case FFECOM_rttypeDBLCMPLX_GNU_:
11066       return FFEINFO_basictypeCOMPLEX;
11067
11068     case FFECOM_rttypeCHARACTER_:
11069       return FFEINFO_basictypeCHARACTER;
11070
11071     default:
11072       return FFEINFO_basictypeANY;
11073     }
11074 }
11075
11076 ffeinfoKindtype
11077 ffecom_gfrt_kindtype (ffecomGfrt gfrt)
11078 {
11079   assert (gfrt < FFECOM_gfrt);
11080
11081   switch (ffecom_gfrt_type_[gfrt])
11082     {
11083     case FFECOM_rttypeVOID_:
11084     case FFECOM_rttypeVOIDSTAR_:
11085       return FFEINFO_kindtypeNONE;
11086
11087     case FFECOM_rttypeFTNINT_:
11088       return FFEINFO_kindtypeINTEGER1;
11089
11090     case FFECOM_rttypeINTEGER_:
11091       return FFEINFO_kindtypeINTEGER1;
11092
11093     case FFECOM_rttypeLONGINT_:
11094       return FFEINFO_kindtypeINTEGER4;
11095
11096     case FFECOM_rttypeLOGICAL_:
11097       return FFEINFO_kindtypeLOGICAL1;
11098
11099     case FFECOM_rttypeREAL_F2C_:
11100     case FFECOM_rttypeREAL_GNU_:
11101       return FFEINFO_kindtypeREAL1;
11102
11103     case FFECOM_rttypeCOMPLEX_F2C_:
11104     case FFECOM_rttypeCOMPLEX_GNU_:
11105       return FFEINFO_kindtypeREAL1;
11106
11107     case FFECOM_rttypeDOUBLE_:
11108     case FFECOM_rttypeDOUBLEREAL_:
11109       return FFEINFO_kindtypeREAL2;
11110
11111     case FFECOM_rttypeDBLCMPLX_F2C_:
11112     case FFECOM_rttypeDBLCMPLX_GNU_:
11113       return FFEINFO_kindtypeREAL2;
11114
11115     case FFECOM_rttypeCHARACTER_:
11116       return FFEINFO_kindtypeCHARACTER1;
11117
11118     default:
11119       return FFEINFO_kindtypeANY;
11120     }
11121 }
11122
11123 void
11124 ffecom_init_0 ()
11125 {
11126   tree endlink;
11127   int i;
11128   int j;
11129   tree t;
11130   tree field;
11131   ffetype type;
11132   ffetype base_type;
11133   tree double_ftype_double, double_ftype_double_double;
11134   tree float_ftype_float, float_ftype_float_float;
11135   tree ldouble_ftype_ldouble, ldouble_ftype_ldouble_ldouble;
11136   tree ffecom_tree_ptr_to_fun_type_void;
11137
11138   /* This block of code comes from the now-obsolete cktyps.c.  It checks
11139      whether the compiler environment is buggy in known ways, some of which
11140      would, if not explicitly checked here, result in subtle bugs in g77.  */
11141
11142   if (ffe_is_do_internal_checks ())
11143     {
11144       static const char names[][12]
11145         =
11146       {"bar", "bletch", "foo", "foobar"};
11147       const char *name;
11148       unsigned long ul;
11149       double fl;
11150
11151       name = bsearch ("foo", &names[0], ARRAY_SIZE (names), sizeof (names[0]),
11152                       (int (*)(const void *, const void *)) strcmp);
11153       if (name != &names[2][0])
11154         {
11155           assert ("bsearch doesn't work, #define FFEPROJ_BSEARCH 0 in proj.h"
11156                   == NULL);
11157           abort ();
11158         }
11159
11160       ul = strtoul ("123456789", NULL, 10);
11161       if (ul != 123456789L)
11162         {
11163           assert ("strtoul doesn't have enough range, #define FFEPROJ_STRTOUL 0\
11164  in proj.h" == NULL);
11165           abort ();
11166         }
11167
11168       fl = atof ("56.789");
11169       if ((fl < 56.788) || (fl > 56.79))
11170         {
11171           assert ("atof not type double, fix your #include <stdio.h>"
11172                   == NULL);
11173           abort ();
11174         }
11175     }
11176
11177   ffecom_outer_function_decl_ = NULL_TREE;
11178   current_function_decl = NULL_TREE;
11179   named_labels = NULL_TREE;
11180   current_binding_level = NULL_BINDING_LEVEL;
11181   free_binding_level = NULL_BINDING_LEVEL;
11182   /* Make the binding_level structure for global names.  */
11183   pushlevel (0);
11184   global_binding_level = current_binding_level;
11185   current_binding_level->prep_state = 2;
11186
11187   build_common_tree_nodes (1);
11188
11189   /* Define `int' and `char' first so that dbx will output them first.  */
11190   pushdecl (build_decl (TYPE_DECL, get_identifier ("int"),
11191                         integer_type_node));
11192   /* CHARACTER*1 is unsigned in ICHAR contexts.  */
11193   char_type_node = make_unsigned_type (CHAR_TYPE_SIZE);
11194   pushdecl (build_decl (TYPE_DECL, get_identifier ("char"),
11195                         char_type_node));
11196   pushdecl (build_decl (TYPE_DECL, get_identifier ("long int"),
11197                         long_integer_type_node));
11198   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned int"),
11199                         unsigned_type_node));
11200   pushdecl (build_decl (TYPE_DECL, get_identifier ("long unsigned int"),
11201                         long_unsigned_type_node));
11202   pushdecl (build_decl (TYPE_DECL, get_identifier ("long long int"),
11203                         long_long_integer_type_node));
11204   pushdecl (build_decl (TYPE_DECL, get_identifier ("long long unsigned int"),
11205                         long_long_unsigned_type_node));
11206   pushdecl (build_decl (TYPE_DECL, get_identifier ("short int"),
11207                         short_integer_type_node));
11208   pushdecl (build_decl (TYPE_DECL, get_identifier ("short unsigned int"),
11209                         short_unsigned_type_node));
11210
11211   /* Set the sizetype before we make other types.  This *should* be the
11212      first type we create.  */
11213
11214   set_sizetype
11215     (TREE_TYPE (IDENTIFIER_GLOBAL_VALUE (get_identifier (SIZE_TYPE))));
11216   ffecom_typesize_pointer_
11217     = TREE_INT_CST_LOW (TYPE_SIZE (sizetype)) / BITS_PER_UNIT;
11218
11219   build_common_tree_nodes_2 (0);
11220
11221   /* Define both `signed char' and `unsigned char'.  */
11222   pushdecl (build_decl (TYPE_DECL, get_identifier ("signed char"),
11223                         signed_char_type_node));
11224
11225   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned char"),
11226                         unsigned_char_type_node));
11227
11228   pushdecl (build_decl (TYPE_DECL, get_identifier ("float"),
11229                         float_type_node));
11230   pushdecl (build_decl (TYPE_DECL, get_identifier ("double"),
11231                         double_type_node));
11232   pushdecl (build_decl (TYPE_DECL, get_identifier ("long double"),
11233                         long_double_type_node));
11234
11235   /* For now, override what build_common_tree_nodes has done.  */
11236   complex_integer_type_node = ffecom_make_complex_type_ (integer_type_node);
11237   complex_float_type_node = ffecom_make_complex_type_ (float_type_node);
11238   complex_double_type_node = ffecom_make_complex_type_ (double_type_node);
11239   complex_long_double_type_node
11240     = ffecom_make_complex_type_ (long_double_type_node);
11241
11242   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex int"),
11243                         complex_integer_type_node));
11244   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex float"),
11245                         complex_float_type_node));
11246   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex double"),
11247                         complex_double_type_node));
11248   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex long double"),
11249                         complex_long_double_type_node));
11250
11251   pushdecl (build_decl (TYPE_DECL, get_identifier ("void"),
11252                         void_type_node));
11253   /* We are not going to have real types in C with less than byte alignment,
11254      so we might as well not have any types that claim to have it.  */
11255   TYPE_ALIGN (void_type_node) = BITS_PER_UNIT;
11256   TYPE_USER_ALIGN (void_type_node) = 0;
11257
11258   string_type_node = build_pointer_type (char_type_node);
11259
11260   ffecom_tree_fun_type_void
11261     = build_function_type (void_type_node, NULL_TREE);
11262
11263   ffecom_tree_ptr_to_fun_type_void
11264     = build_pointer_type (ffecom_tree_fun_type_void);
11265
11266   endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE);
11267
11268   t = tree_cons (NULL_TREE, float_type_node, endlink);
11269   float_ftype_float = build_function_type (float_type_node, t);
11270   t = tree_cons (NULL_TREE, float_type_node, t);
11271   float_ftype_float_float = build_function_type (float_type_node, t);
11272
11273   t = tree_cons (NULL_TREE, double_type_node, endlink);
11274   double_ftype_double = build_function_type (double_type_node, t);
11275   t = tree_cons (NULL_TREE, double_type_node, t);
11276   double_ftype_double_double = build_function_type (double_type_node, t);
11277
11278   t = tree_cons (NULL_TREE, long_double_type_node, endlink);
11279   ldouble_ftype_ldouble = build_function_type (long_double_type_node, t);
11280   t = tree_cons (NULL_TREE, long_double_type_node, t);
11281   ldouble_ftype_ldouble_ldouble = build_function_type (long_double_type_node,
11282                                                        t);
11283
11284   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11285     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11286       {
11287         ffecom_tree_type[i][j] = NULL_TREE;
11288         ffecom_tree_fun_type[i][j] = NULL_TREE;
11289         ffecom_tree_ptr_to_fun_type[i][j] = NULL_TREE;
11290         ffecom_f2c_typecode_[i][j] = -1;
11291       }
11292
11293   /* Set up standard g77 types.  Note that INTEGER and LOGICAL are set
11294      to size FLOAT_TYPE_SIZE because they have to be the same size as
11295      REAL, which also is FLOAT_TYPE_SIZE, according to the standard.
11296      Compiler options and other such stuff that change the ways these
11297      types are set should not affect this particular setup.  */
11298
11299   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1]
11300     = t = make_signed_type (FLOAT_TYPE_SIZE);
11301   pushdecl (build_decl (TYPE_DECL, get_identifier ("integer"),
11302                         t));
11303   type = ffetype_new ();
11304   base_type = type;
11305   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER1,
11306                     type);
11307   ffetype_set_ams (type,
11308                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11309                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11310   ffetype_set_star (base_type,
11311                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11312                     type);
11313   ffetype_set_kind (base_type, 1, type);
11314   ffecom_typesize_integer1_ = ffetype_size (type);
11315   assert (ffetype_size (type) == sizeof (ffetargetInteger1));
11316
11317   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER1]
11318     = t = make_unsigned_type (FLOAT_TYPE_SIZE); /* HOLLERITH means unsigned. */
11319   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned"),
11320                         t));
11321
11322   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER2]
11323     = t = make_signed_type (CHAR_TYPE_SIZE);
11324   pushdecl (build_decl (TYPE_DECL, get_identifier ("byte"),
11325                         t));
11326   type = ffetype_new ();
11327   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER2,
11328                     type);
11329   ffetype_set_ams (type,
11330                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11331                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11332   ffetype_set_star (base_type,
11333                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11334                     type);
11335   ffetype_set_kind (base_type, 3, type);
11336   assert (ffetype_size (type) == sizeof (ffetargetInteger2));
11337
11338   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER2]
11339     = t = make_unsigned_type (CHAR_TYPE_SIZE);
11340   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned byte"),
11341                         t));
11342
11343   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER3]
11344     = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11345   pushdecl (build_decl (TYPE_DECL, get_identifier ("word"),
11346                         t));
11347   type = ffetype_new ();
11348   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER3,
11349                     type);
11350   ffetype_set_ams (type,
11351                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11352                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11353   ffetype_set_star (base_type,
11354                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11355                     type);
11356   ffetype_set_kind (base_type, 6, type);
11357   assert (ffetype_size (type) == sizeof (ffetargetInteger3));
11358
11359   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER3]
11360     = t = make_unsigned_type (CHAR_TYPE_SIZE * 2);
11361   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned word"),
11362                         t));
11363
11364   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER4]
11365     = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11366   pushdecl (build_decl (TYPE_DECL, get_identifier ("integer4"),
11367                         t));
11368   type = ffetype_new ();
11369   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER4,
11370                     type);
11371   ffetype_set_ams (type,
11372                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11373                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11374   ffetype_set_star (base_type,
11375                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11376                     type);
11377   ffetype_set_kind (base_type, 2, type);
11378   assert (ffetype_size (type) == sizeof (ffetargetInteger4));
11379
11380   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER4]
11381     = t = make_unsigned_type (FLOAT_TYPE_SIZE * 2);
11382   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned4"),
11383                         t));
11384
11385 #if 0
11386   if (ffe_is_do_internal_checks ()
11387       && LONG_TYPE_SIZE != FLOAT_TYPE_SIZE
11388       && LONG_TYPE_SIZE != CHAR_TYPE_SIZE
11389       && LONG_TYPE_SIZE != SHORT_TYPE_SIZE
11390       && LONG_TYPE_SIZE != LONG_LONG_TYPE_SIZE)
11391     {
11392       fprintf (stderr, "Sorry, no g77 support for LONG_TYPE_SIZE (%d bits) yet.\n",
11393                LONG_TYPE_SIZE);
11394     }
11395 #endif
11396
11397   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL1]
11398     = t = make_signed_type (FLOAT_TYPE_SIZE);
11399   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical"),
11400                         t));
11401   type = ffetype_new ();
11402   base_type = type;
11403   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL1,
11404                     type);
11405   ffetype_set_ams (type,
11406                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11407                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11408   ffetype_set_star (base_type,
11409                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11410                     type);
11411   ffetype_set_kind (base_type, 1, type);
11412   assert (ffetype_size (type) == sizeof (ffetargetLogical1));
11413
11414   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL2]
11415     = t = make_signed_type (CHAR_TYPE_SIZE);
11416   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical2"),
11417                         t));
11418   type = ffetype_new ();
11419   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL2,
11420                     type);
11421   ffetype_set_ams (type,
11422                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11423                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11424   ffetype_set_star (base_type,
11425                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11426                     type);
11427   ffetype_set_kind (base_type, 3, type);
11428   assert (ffetype_size (type) == sizeof (ffetargetLogical2));
11429
11430   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL3]
11431     = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11432   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical3"),
11433                         t));
11434   type = ffetype_new ();
11435   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL3,
11436                     type);
11437   ffetype_set_ams (type,
11438                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11439                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11440   ffetype_set_star (base_type,
11441                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11442                     type);
11443   ffetype_set_kind (base_type, 6, type);
11444   assert (ffetype_size (type) == sizeof (ffetargetLogical3));
11445
11446   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL4]
11447     = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11448   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical4"),
11449                         t));
11450   type = ffetype_new ();
11451   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL4,
11452                     type);
11453   ffetype_set_ams (type,
11454                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11455                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11456   ffetype_set_star (base_type,
11457                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11458                     type);
11459   ffetype_set_kind (base_type, 2, type);
11460   assert (ffetype_size (type) == sizeof (ffetargetLogical4));
11461
11462   ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11463     = t = make_node (REAL_TYPE);
11464   TYPE_PRECISION (t) = FLOAT_TYPE_SIZE;
11465   pushdecl (build_decl (TYPE_DECL, get_identifier ("real"),
11466                         t));
11467   layout_type (t);
11468   type = ffetype_new ();
11469   base_type = type;
11470   ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL1,
11471                     type);
11472   ffetype_set_ams (type,
11473                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11474                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11475   ffetype_set_star (base_type,
11476                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11477                     type);
11478   ffetype_set_kind (base_type, 1, type);
11479   ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11480     = FFETARGET_f2cTYREAL;
11481   assert (ffetype_size (type) == sizeof (ffetargetReal1));
11482
11483   ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREALDOUBLE]
11484     = t = make_node (REAL_TYPE);
11485   TYPE_PRECISION (t) = FLOAT_TYPE_SIZE * 2;     /* Always twice REAL. */
11486   pushdecl (build_decl (TYPE_DECL, get_identifier ("double precision"),
11487                         t));
11488   layout_type (t);
11489   type = ffetype_new ();
11490   ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE,
11491                     type);
11492   ffetype_set_ams (type,
11493                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11494                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11495   ffetype_set_star (base_type,
11496                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11497                     type);
11498   ffetype_set_kind (base_type, 2, type);
11499   ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]
11500     = FFETARGET_f2cTYDREAL;
11501   assert (ffetype_size (type) == sizeof (ffetargetReal2));
11502
11503   ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11504     = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]);
11505   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex"),
11506                         t));
11507   type = ffetype_new ();
11508   base_type = type;
11509   ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL1,
11510                     type);
11511   ffetype_set_ams (type,
11512                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11513                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11514   ffetype_set_star (base_type,
11515                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11516                     type);
11517   ffetype_set_kind (base_type, 1, type);
11518   ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11519     = FFETARGET_f2cTYCOMPLEX;
11520   assert (ffetype_size (type) == sizeof (ffetargetComplex1));
11521
11522   ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREALDOUBLE]
11523     = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]);
11524   pushdecl (build_decl (TYPE_DECL, get_identifier ("double complex"),
11525                         t));
11526   type = ffetype_new ();
11527   ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREALDOUBLE,
11528                     type);
11529   ffetype_set_ams (type,
11530                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11531                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11532   ffetype_set_star (base_type,
11533                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11534                     type);
11535   ffetype_set_kind (base_type, 2,
11536                     type);
11537   ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL2]
11538     = FFETARGET_f2cTYDCOMPLEX;
11539   assert (ffetype_size (type) == sizeof (ffetargetComplex2));
11540
11541   /* Make function and ptr-to-function types for non-CHARACTER types. */
11542
11543   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11544     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11545       {
11546         if ((t = ffecom_tree_type[i][j]) != NULL_TREE)
11547           {
11548             if (i == FFEINFO_basictypeINTEGER)
11549               {
11550                 /* Figure out the smallest INTEGER type that can hold
11551                    a pointer on this machine. */
11552                 if (GET_MODE_SIZE (TYPE_MODE (t))
11553                     >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
11554                   {
11555                     if ((ffecom_pointer_kind_ == FFEINFO_kindtypeNONE)
11556                         || (GET_MODE_SIZE (TYPE_MODE (ffecom_tree_type[i][ffecom_pointer_kind_]))
11557                             > GET_MODE_SIZE (TYPE_MODE (t))))
11558                       ffecom_pointer_kind_ = j;
11559                   }
11560               }
11561             else if (i == FFEINFO_basictypeCOMPLEX)
11562               t = void_type_node;
11563             /* For f2c compatibility, REAL functions are really
11564                implemented as DOUBLE PRECISION.  */
11565             else if ((i == FFEINFO_basictypeREAL)
11566                      && (j == FFEINFO_kindtypeREAL1))
11567               t = ffecom_tree_type
11568                 [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2];
11569
11570             t = ffecom_tree_fun_type[i][j] = build_function_type (t,
11571                                                                   NULL_TREE);
11572             ffecom_tree_ptr_to_fun_type[i][j] = build_pointer_type (t);
11573           }
11574       }
11575
11576   /* Set up pointer types.  */
11577
11578   if (ffecom_pointer_kind_ == FFEINFO_basictypeNONE)
11579     fatal_error ("no INTEGER type can hold a pointer on this configuration");
11580   else if (0 && ffe_is_do_internal_checks ())
11581     fprintf (stderr, "Pointer type kt=%d\n", ffecom_pointer_kind_);
11582   ffetype_set_kind (ffeinfo_type (FFEINFO_basictypeINTEGER,
11583                                   FFEINFO_kindtypeINTEGERDEFAULT),
11584                     7,
11585                     ffeinfo_type (FFEINFO_basictypeINTEGER,
11586                                   ffecom_pointer_kind_));
11587
11588   if (ffe_is_ugly_assign ())
11589     ffecom_label_kind_ = ffecom_pointer_kind_;  /* Require ASSIGN etc to this. */
11590   else
11591     ffecom_label_kind_ = FFEINFO_kindtypeINTEGERDEFAULT;
11592   if (0 && ffe_is_do_internal_checks ())
11593     fprintf (stderr, "Label type kt=%d\n", ffecom_label_kind_);
11594
11595   ffecom_integer_type_node
11596     = ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1];
11597   ffecom_integer_zero_node = convert (ffecom_integer_type_node,
11598                                       integer_zero_node);
11599   ffecom_integer_one_node = convert (ffecom_integer_type_node,
11600                                      integer_one_node);
11601
11602   /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional.
11603      Turns out that by TYLONG, runtime/libI77/lio.h really means
11604      "whatever size an ftnint is".  For consistency and sanity,
11605      com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen
11606      all are INTEGER, which we also make out of whatever back-end
11607      integer type is FLOAT_TYPE_SIZE bits wide.  This change, from
11608      LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to
11609      accommodate machines like the Alpha.  Note that this suggests
11610      f2c and libf2c are missing a distinction perhaps needed on
11611      some machines between "int" and "long int".  -- burley 0.5.5 950215 */
11612
11613   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, FLOAT_TYPE_SIZE,
11614                             FFETARGET_f2cTYLONG);
11615   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, SHORT_TYPE_SIZE,
11616                             FFETARGET_f2cTYSHORT);
11617   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, CHAR_TYPE_SIZE,
11618                             FFETARGET_f2cTYINT1);
11619   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, LONG_LONG_TYPE_SIZE,
11620                             FFETARGET_f2cTYQUAD);
11621   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, FLOAT_TYPE_SIZE,
11622                             FFETARGET_f2cTYLOGICAL);
11623   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, SHORT_TYPE_SIZE,
11624                             FFETARGET_f2cTYLOGICAL2);
11625   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, CHAR_TYPE_SIZE,
11626                             FFETARGET_f2cTYLOGICAL1);
11627   /* ~~~Not really such a type in libf2c, e.g. I/O support?  */
11628   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, LONG_LONG_TYPE_SIZE,
11629                             FFETARGET_f2cTYQUAD);
11630
11631   /* CHARACTER stuff is all special-cased, so it is not handled in the above
11632      loop.  CHARACTER items are built as arrays of unsigned char.  */
11633
11634   ffecom_tree_type[FFEINFO_basictypeCHARACTER]
11635     [FFEINFO_kindtypeCHARACTER1] = t = char_type_node;
11636   type = ffetype_new ();
11637   base_type = type;
11638   ffeinfo_set_type (FFEINFO_basictypeCHARACTER,
11639                     FFEINFO_kindtypeCHARACTER1,
11640                     type);
11641   ffetype_set_ams (type,
11642                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11643                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11644   ffetype_set_kind (base_type, 1, type);
11645   assert (ffetype_size (type)
11646           == sizeof (((ffetargetCharacter1) { 0, NULL }).text[0]));
11647
11648   ffecom_tree_fun_type[FFEINFO_basictypeCHARACTER]
11649     [FFEINFO_kindtypeCHARACTER1] = ffecom_tree_fun_type_void;
11650   ffecom_tree_ptr_to_fun_type[FFEINFO_basictypeCHARACTER]
11651     [FFEINFO_kindtypeCHARACTER1]
11652     = ffecom_tree_ptr_to_fun_type_void;
11653   ffecom_f2c_typecode_[FFEINFO_basictypeCHARACTER][FFEINFO_kindtypeCHARACTER1]
11654     = FFETARGET_f2cTYCHAR;
11655
11656   ffecom_f2c_typecode_[FFEINFO_basictypeANY][FFEINFO_kindtypeANY]
11657     = 0;
11658
11659   /* Make multi-return-value type and fields. */
11660
11661   ffecom_multi_type_node_ = make_node (UNION_TYPE);
11662
11663   field = NULL_TREE;
11664
11665   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11666     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11667       {
11668         char name[30];
11669
11670         if (ffecom_tree_type[i][j] == NULL_TREE)
11671           continue;             /* Not supported. */
11672         sprintf (&name[0], "bt_%s_kt_%s",
11673                  ffeinfo_basictype_string ((ffeinfoBasictype) i),
11674                  ffeinfo_kindtype_string ((ffeinfoKindtype) j));
11675         ffecom_multi_fields_[i][j] = build_decl (FIELD_DECL,
11676                                                  get_identifier (name),
11677                                                  ffecom_tree_type[i][j]);
11678         DECL_CONTEXT (ffecom_multi_fields_[i][j])
11679           = ffecom_multi_type_node_;
11680         DECL_ALIGN (ffecom_multi_fields_[i][j]) = 0;
11681         DECL_USER_ALIGN (ffecom_multi_fields_[i][j]) = 0;
11682         TREE_CHAIN (ffecom_multi_fields_[i][j]) = field;
11683         field = ffecom_multi_fields_[i][j];
11684       }
11685
11686   TYPE_FIELDS (ffecom_multi_type_node_) = field;
11687   layout_type (ffecom_multi_type_node_);
11688
11689   /* Subroutines usually return integer because they might have alternate
11690      returns. */
11691
11692   ffecom_tree_subr_type
11693     = build_function_type (integer_type_node, NULL_TREE);
11694   ffecom_tree_ptr_to_subr_type
11695     = build_pointer_type (ffecom_tree_subr_type);
11696   ffecom_tree_blockdata_type
11697     = build_function_type (void_type_node, NULL_TREE);
11698
11699   builtin_function ("__builtin_atanf", float_ftype_float,
11700                     BUILT_IN_ATANF, BUILT_IN_NORMAL, "atanf", NULL_TREE);
11701   builtin_function ("__builtin_atan", double_ftype_double,
11702                     BUILT_IN_ATAN, BUILT_IN_NORMAL, "atan", NULL_TREE);
11703   builtin_function ("__builtin_atanl", ldouble_ftype_ldouble,
11704                     BUILT_IN_ATANL, BUILT_IN_NORMAL, "atanl", NULL_TREE);
11705
11706   builtin_function ("__builtin_atan2f", float_ftype_float_float,
11707                     BUILT_IN_ATAN2F, BUILT_IN_NORMAL, "atan2f", NULL_TREE);
11708   builtin_function ("__builtin_atan2", double_ftype_double_double,
11709                     BUILT_IN_ATAN2, BUILT_IN_NORMAL, "atan2", NULL_TREE);
11710   builtin_function ("__builtin_atan2l", ldouble_ftype_ldouble_ldouble,
11711                     BUILT_IN_ATAN2L, BUILT_IN_NORMAL, "atan2l", NULL_TREE);
11712
11713   builtin_function ("__builtin_cosf", float_ftype_float,
11714                     BUILT_IN_COSF, BUILT_IN_NORMAL, "cosf", NULL_TREE);
11715   builtin_function ("__builtin_cos", double_ftype_double,
11716                     BUILT_IN_COS, BUILT_IN_NORMAL, "cos", NULL_TREE);
11717   builtin_function ("__builtin_cosl", ldouble_ftype_ldouble,
11718                     BUILT_IN_COSL, BUILT_IN_NORMAL, "cosl", NULL_TREE);
11719
11720   builtin_function ("__builtin_expf", float_ftype_float,
11721                     BUILT_IN_EXPF, BUILT_IN_NORMAL, "expf", NULL_TREE);
11722   builtin_function ("__builtin_exp", double_ftype_double,
11723                     BUILT_IN_EXP, BUILT_IN_NORMAL, "exp", NULL_TREE);
11724   builtin_function ("__builtin_expl", ldouble_ftype_ldouble,
11725                     BUILT_IN_EXPL, BUILT_IN_NORMAL, "expl", NULL_TREE);
11726
11727   builtin_function ("__builtin_floorf", float_ftype_float,
11728                     BUILT_IN_FLOORF, BUILT_IN_NORMAL, "floorf", NULL_TREE);
11729   builtin_function ("__builtin_floor", double_ftype_double,
11730                     BUILT_IN_FLOOR, BUILT_IN_NORMAL, "floor", NULL_TREE);
11731   builtin_function ("__builtin_floorl", ldouble_ftype_ldouble,
11732                     BUILT_IN_FLOORL, BUILT_IN_NORMAL, "floorl", NULL_TREE);
11733
11734   builtin_function ("__builtin_fmodf", float_ftype_float_float,
11735                     BUILT_IN_FMODF, BUILT_IN_NORMAL, "fmodf", NULL_TREE);
11736   builtin_function ("__builtin_fmod", double_ftype_double_double,
11737                     BUILT_IN_FMOD, BUILT_IN_NORMAL, "fmod", NULL_TREE);
11738   builtin_function ("__builtin_fmodl", ldouble_ftype_ldouble_ldouble,
11739                     BUILT_IN_FMODL, BUILT_IN_NORMAL, "fmodl", NULL_TREE);
11740
11741   builtin_function ("__builtin_logf", float_ftype_float,
11742                     BUILT_IN_LOGF, BUILT_IN_NORMAL, "logf", NULL_TREE);
11743   builtin_function ("__builtin_log", double_ftype_double,
11744                     BUILT_IN_LOG, BUILT_IN_NORMAL, "log", NULL_TREE);
11745   builtin_function ("__builtin_logl", ldouble_ftype_ldouble,
11746                     BUILT_IN_LOGL, BUILT_IN_NORMAL, "logl", NULL_TREE);
11747
11748   builtin_function ("__builtin_powf", float_ftype_float_float,
11749                     BUILT_IN_POWF, BUILT_IN_NORMAL, "powf", NULL_TREE);
11750   builtin_function ("__builtin_pow", double_ftype_double_double,
11751                     BUILT_IN_POW, BUILT_IN_NORMAL, "pow", NULL_TREE);
11752   builtin_function ("__builtin_powl", ldouble_ftype_ldouble_ldouble,
11753                     BUILT_IN_POWL, BUILT_IN_NORMAL, "powl", NULL_TREE);
11754
11755   builtin_function ("__builtin_sinf", float_ftype_float,
11756                     BUILT_IN_SINF, BUILT_IN_NORMAL, "sinf", NULL_TREE);
11757   builtin_function ("__builtin_sin", double_ftype_double,
11758                     BUILT_IN_SIN, BUILT_IN_NORMAL, "sin", NULL_TREE);
11759   builtin_function ("__builtin_sinl", ldouble_ftype_ldouble,
11760                     BUILT_IN_SINL, BUILT_IN_NORMAL, "sinl", NULL_TREE);
11761
11762   builtin_function ("__builtin_sqrtf", float_ftype_float,
11763                     BUILT_IN_SQRTF, BUILT_IN_NORMAL, "sqrtf", NULL_TREE);
11764   builtin_function ("__builtin_sqrt", double_ftype_double,
11765                     BUILT_IN_SQRT, BUILT_IN_NORMAL, "sqrt", NULL_TREE);
11766   builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble,
11767                     BUILT_IN_SQRTL, BUILT_IN_NORMAL, "sqrtl", NULL_TREE);
11768
11769   builtin_function ("__builtin_tanf", float_ftype_float,
11770                     BUILT_IN_TANF, BUILT_IN_NORMAL, "tanf", NULL_TREE);
11771   builtin_function ("__builtin_tan", double_ftype_double,
11772                     BUILT_IN_TAN, BUILT_IN_NORMAL, "tan", NULL_TREE);
11773   builtin_function ("__builtin_tanl", ldouble_ftype_ldouble,
11774                     BUILT_IN_TANL, BUILT_IN_NORMAL, "tanl", NULL_TREE);
11775
11776   pedantic_lvalues = FALSE;
11777
11778   ffecom_f2c_make_type_ (&ffecom_f2c_integer_type_node,
11779                          FFECOM_f2cINTEGER,
11780                          "integer");
11781   ffecom_f2c_make_type_ (&ffecom_f2c_address_type_node,
11782                          FFECOM_f2cADDRESS,
11783                          "address");
11784   ffecom_f2c_make_type_ (&ffecom_f2c_real_type_node,
11785                          FFECOM_f2cREAL,
11786                          "real");
11787   ffecom_f2c_make_type_ (&ffecom_f2c_doublereal_type_node,
11788                          FFECOM_f2cDOUBLEREAL,
11789                          "doublereal");
11790   ffecom_f2c_make_type_ (&ffecom_f2c_complex_type_node,
11791                          FFECOM_f2cCOMPLEX,
11792                          "complex");
11793   ffecom_f2c_make_type_ (&ffecom_f2c_doublecomplex_type_node,
11794                          FFECOM_f2cDOUBLECOMPLEX,
11795                          "doublecomplex");
11796   ffecom_f2c_make_type_ (&ffecom_f2c_longint_type_node,
11797                          FFECOM_f2cLONGINT,
11798                          "longint");
11799   ffecom_f2c_make_type_ (&ffecom_f2c_logical_type_node,
11800                          FFECOM_f2cLOGICAL,
11801                          "logical");
11802   ffecom_f2c_make_type_ (&ffecom_f2c_flag_type_node,
11803                          FFECOM_f2cFLAG,
11804                          "flag");
11805   ffecom_f2c_make_type_ (&ffecom_f2c_ftnlen_type_node,
11806                          FFECOM_f2cFTNLEN,
11807                          "ftnlen");
11808   ffecom_f2c_make_type_ (&ffecom_f2c_ftnint_type_node,
11809                          FFECOM_f2cFTNINT,
11810                          "ftnint");
11811
11812   ffecom_f2c_ftnlen_zero_node
11813     = convert (ffecom_f2c_ftnlen_type_node, integer_zero_node);
11814
11815   ffecom_f2c_ftnlen_one_node
11816     = convert (ffecom_f2c_ftnlen_type_node, integer_one_node);
11817
11818   ffecom_f2c_ftnlen_two_node = build_int_2 (2, 0);
11819   TREE_TYPE (ffecom_f2c_ftnlen_two_node) = ffecom_integer_type_node;
11820
11821   ffecom_f2c_ptr_to_ftnlen_type_node
11822     = build_pointer_type (ffecom_f2c_ftnlen_type_node);
11823
11824   ffecom_f2c_ptr_to_ftnint_type_node
11825     = build_pointer_type (ffecom_f2c_ftnint_type_node);
11826
11827   ffecom_f2c_ptr_to_integer_type_node
11828     = build_pointer_type (ffecom_f2c_integer_type_node);
11829
11830   ffecom_f2c_ptr_to_real_type_node
11831     = build_pointer_type (ffecom_f2c_real_type_node);
11832
11833   ffecom_float_zero_ = build_real (float_type_node, dconst0);
11834   ffecom_double_zero_ = build_real (double_type_node, dconst0);
11835   {
11836     REAL_VALUE_TYPE point_5;
11837
11838     REAL_ARITHMETIC (point_5, RDIV_EXPR, dconst1, dconst2);
11839     ffecom_float_half_ = build_real (float_type_node, point_5);
11840     ffecom_double_half_ = build_real (double_type_node, point_5);
11841   }
11842
11843   /* Do "extern int xargc;".  */
11844
11845   ffecom_tree_xargc_ = build_decl (VAR_DECL,
11846                                    get_identifier ("f__xargc"),
11847                                    integer_type_node);
11848   DECL_EXTERNAL (ffecom_tree_xargc_) = 1;
11849   TREE_STATIC (ffecom_tree_xargc_) = 1;
11850   TREE_PUBLIC (ffecom_tree_xargc_) = 1;
11851   ffecom_tree_xargc_ = start_decl (ffecom_tree_xargc_, FALSE);
11852   finish_decl (ffecom_tree_xargc_, NULL_TREE, FALSE);
11853
11854 #if 0   /* This is being fixed, and seems to be working now. */
11855   if ((FLOAT_TYPE_SIZE != 32)
11856       || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))) != 32))
11857     {
11858       warning ("configuration: REAL, INTEGER, and LOGICAL are %d bits wide,",
11859                (int) FLOAT_TYPE_SIZE);
11860       warning ("and pointers are %d bits wide, but g77 doesn't yet work",
11861           (int) TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))));
11862       warning ("properly unless they all are 32 bits wide");
11863       warning ("Please keep this in mind before you report bugs.");
11864     }
11865 #endif
11866
11867 #if 0   /* Code in ste.c that would crash has been commented out. */
11868   if (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)
11869       < TYPE_PRECISION (string_type_node))
11870     /* I/O will probably crash.  */
11871     warning ("configuration: char * holds %d bits, but ftnlen only %d",
11872              TYPE_PRECISION (string_type_node),
11873              TYPE_PRECISION (ffecom_f2c_ftnlen_type_node));
11874 #endif
11875
11876 #if 0   /* ASSIGN-related stuff has been changed to accommodate this. */
11877   if (TYPE_PRECISION (ffecom_integer_type_node)
11878       < TYPE_PRECISION (string_type_node))
11879     /* ASSIGN 10 TO I will crash.  */
11880     warning ("configuration: char * holds %d bits, but INTEGER only %d --\n\
11881  ASSIGN statement might fail",
11882              TYPE_PRECISION (string_type_node),
11883              TYPE_PRECISION (ffecom_integer_type_node));
11884 #endif
11885 }
11886
11887 /* ffecom_init_2 -- Initialize
11888
11889    ffecom_init_2();  */
11890
11891 void
11892 ffecom_init_2 ()
11893 {
11894   assert (ffecom_outer_function_decl_ == NULL_TREE);
11895   assert (current_function_decl == NULL_TREE);
11896   assert (ffecom_which_entrypoint_decl_ == NULL_TREE);
11897
11898   ffecom_master_arglist_ = NULL;
11899   ++ffecom_num_fns_;
11900   ffecom_primary_entry_ = NULL;
11901   ffecom_is_altreturning_ = FALSE;
11902   ffecom_func_result_ = NULL_TREE;
11903   ffecom_multi_retval_ = NULL_TREE;
11904 }
11905
11906 /* ffecom_list_expr -- Transform list of exprs into gcc tree
11907
11908    tree t;
11909    ffebld expr;  // FFE opITEM list.
11910    tree = ffecom_list_expr(expr);
11911
11912    List of actual args is transformed into corresponding gcc backend list.  */
11913
11914 tree
11915 ffecom_list_expr (ffebld expr)
11916 {
11917   tree list;
11918   tree *plist = &list;
11919   tree trail = NULL_TREE;       /* Append char length args here. */
11920   tree *ptrail = &trail;
11921   tree length;
11922
11923   while (expr != NULL)
11924     {
11925       tree texpr = ffecom_arg_expr (ffebld_head (expr), &length);
11926
11927       if (texpr == error_mark_node)
11928         return error_mark_node;
11929
11930       *plist = build_tree_list (NULL_TREE, texpr);
11931       plist = &TREE_CHAIN (*plist);
11932       expr = ffebld_trail (expr);
11933       if (length != NULL_TREE)
11934         {
11935           *ptrail = build_tree_list (NULL_TREE, length);
11936           ptrail = &TREE_CHAIN (*ptrail);
11937         }
11938     }
11939
11940   *plist = trail;
11941
11942   return list;
11943 }
11944
11945 /* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree
11946
11947    tree t;
11948    ffebld expr;  // FFE opITEM list.
11949    tree = ffecom_list_ptr_to_expr(expr);
11950
11951    List of actual args is transformed into corresponding gcc backend list for
11952    use in calling an external procedure (vs. a statement function).  */
11953
11954 tree
11955 ffecom_list_ptr_to_expr (ffebld expr)
11956 {
11957   tree list;
11958   tree *plist = &list;
11959   tree trail = NULL_TREE;       /* Append char length args here. */
11960   tree *ptrail = &trail;
11961   tree length;
11962
11963   while (expr != NULL)
11964     {
11965       tree texpr = ffecom_arg_ptr_to_expr (ffebld_head (expr), &length);
11966
11967       if (texpr == error_mark_node)
11968         return error_mark_node;
11969
11970       *plist = build_tree_list (NULL_TREE, texpr);
11971       plist = &TREE_CHAIN (*plist);
11972       expr = ffebld_trail (expr);
11973       if (length != NULL_TREE)
11974         {
11975           *ptrail = build_tree_list (NULL_TREE, length);
11976           ptrail = &TREE_CHAIN (*ptrail);
11977         }
11978     }
11979
11980   *plist = trail;
11981
11982   return list;
11983 }
11984
11985 /* Obtain gcc's LABEL_DECL tree for label.  */
11986
11987 tree
11988 ffecom_lookup_label (ffelab label)
11989 {
11990   tree glabel;
11991
11992   if (ffelab_hook (label) == NULL_TREE)
11993     {
11994       char labelname[16];
11995
11996       switch (ffelab_type (label))
11997         {
11998         case FFELAB_typeLOOPEND:
11999         case FFELAB_typeNOTLOOP:
12000         case FFELAB_typeENDIF:
12001           sprintf (labelname, "%" ffelabValue_f "u", ffelab_value (label));
12002           glabel = build_decl (LABEL_DECL, get_identifier (labelname),
12003                                void_type_node);
12004           DECL_CONTEXT (glabel) = current_function_decl;
12005           DECL_MODE (glabel) = VOIDmode;
12006           break;
12007
12008         case FFELAB_typeFORMAT:
12009           glabel = build_decl (VAR_DECL,
12010                                ffecom_get_invented_identifier
12011                                ("__g77_format_%d", (int) ffelab_value (label)),
12012                                build_type_variant (build_array_type
12013                                                    (char_type_node,
12014                                                     NULL_TREE),
12015                                                    1, 0));
12016           TREE_CONSTANT (glabel) = 1;
12017           TREE_STATIC (glabel) = 1;
12018           DECL_CONTEXT (glabel) = current_function_decl;
12019           DECL_INITIAL (glabel) = NULL;
12020           make_decl_rtl (glabel, NULL);
12021           expand_decl (glabel);
12022
12023           ffecom_save_tree_forever (glabel);
12024
12025           break;
12026
12027         case FFELAB_typeANY:
12028           glabel = error_mark_node;
12029           break;
12030
12031         default:
12032           assert ("bad label type" == NULL);
12033           glabel = NULL;
12034           break;
12035         }
12036       ffelab_set_hook (label, glabel);
12037     }
12038   else
12039     {
12040       glabel = ffelab_hook (label);
12041     }
12042
12043   return glabel;
12044 }
12045
12046 /* Stabilizes the arguments.  Don't use this if the lhs and rhs come from
12047    a single source specification (as in the fourth argument of MVBITS).
12048    If the type is NULL_TREE, the type of lhs is used to make the type of
12049    the MODIFY_EXPR.  */
12050
12051 tree
12052 ffecom_modify (tree newtype, tree lhs,
12053                tree rhs)
12054 {
12055   if (lhs == error_mark_node || rhs == error_mark_node)
12056     return error_mark_node;
12057
12058   if (newtype == NULL_TREE)
12059     newtype = TREE_TYPE (lhs);
12060
12061   if (TREE_SIDE_EFFECTS (lhs))
12062     lhs = stabilize_reference (lhs);
12063
12064   return ffecom_2s (MODIFY_EXPR, newtype, lhs, rhs);
12065 }
12066
12067 /* Register source file name.  */
12068
12069 void
12070 ffecom_file (const char *name)
12071 {
12072   ffecom_file_ (name);
12073 }
12074
12075 /* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed
12076
12077    ffestorag st;
12078    ffecom_notify_init_storage(st);
12079
12080    Gets called when all possible units in an aggregate storage area (a LOCAL
12081    with equivalences or a COMMON) have been initialized.  The initialization
12082    info either is in ffestorag_init or, if that is NULL,
12083    ffestorag_accretion:
12084
12085    ffestorag_init may contain an opCONTER or opARRTER.  opCONTER may occur
12086    even for an array if the array is one element in length!
12087
12088    ffestorag_accretion will contain an opACCTER.  It is much like an
12089    opARRTER except it has an ffebit object in it instead of just a size.
12090    The back end can use the info in the ffebit object, if it wants, to
12091    reduce the amount of actual initialization, but in any case it should
12092    kill the ffebit object when done.  Also, set accretion to NULL but
12093    init to a non-NULL value.
12094
12095    After performing initialization, DO NOT set init to NULL, because that'll
12096    tell the front end it is ok for more initialization to happen.  Instead,
12097    set init to an opANY expression or some such thing that you can use to
12098    tell that you've already initialized the object.
12099
12100    27-Oct-91  JCB  1.1
12101       Support two-pass FFE.  */
12102
12103 void
12104 ffecom_notify_init_storage (ffestorag st)
12105 {
12106   ffebld init;                  /* The initialization expression. */
12107
12108   if (ffestorag_init (st) == NULL)
12109     {
12110       init = ffestorag_accretion (st);
12111       assert (init != NULL);
12112       ffestorag_set_accretion (st, NULL);
12113       ffestorag_set_accretes (st, 0);
12114       ffestorag_set_init (st, init);
12115     }
12116 }
12117
12118 /* ffecom_notify_init_symbol -- A symbol is now fully init'ed
12119
12120    ffesymbol s;
12121    ffecom_notify_init_symbol(s);
12122
12123    Gets called when all possible units in a symbol (not placed in COMMON
12124    or involved in EQUIVALENCE, unless it as yet has no ffestorag object)
12125    have been initialized.  The initialization info either is in
12126    ffesymbol_init or, if that is NULL, ffesymbol_accretion:
12127
12128    ffesymbol_init may contain an opCONTER or opARRTER.  opCONTER may occur
12129    even for an array if the array is one element in length!
12130
12131    ffesymbol_accretion will contain an opACCTER.  It is much like an
12132    opARRTER except it has an ffebit object in it instead of just a size.
12133    The back end can use the info in the ffebit object, if it wants, to
12134    reduce the amount of actual initialization, but in any case it should
12135    kill the ffebit object when done.  Also, set accretion to NULL but
12136    init to a non-NULL value.
12137
12138    After performing initialization, DO NOT set init to NULL, because that'll
12139    tell the front end it is ok for more initialization to happen.  Instead,
12140    set init to an opANY expression or some such thing that you can use to
12141    tell that you've already initialized the object.
12142
12143    27-Oct-91  JCB  1.1
12144       Support two-pass FFE.  */
12145
12146 void
12147 ffecom_notify_init_symbol (ffesymbol s)
12148 {
12149   ffebld init;                  /* The initialization expression. */
12150
12151   if (ffesymbol_storage (s) == NULL)
12152     return;                     /* Do nothing until COMMON/EQUIVALENCE
12153                                    possibilities checked. */
12154
12155   if ((ffesymbol_init (s) == NULL)
12156       && ((init = ffesymbol_accretion (s)) != NULL))
12157     {
12158       ffesymbol_set_accretion (s, NULL);
12159       ffesymbol_set_accretes (s, 0);
12160       ffesymbol_set_init (s, init);
12161     }
12162 }
12163
12164 /* ffecom_notify_primary_entry -- Learn which is the primary entry point
12165
12166    ffesymbol s;
12167    ffecom_notify_primary_entry(s);
12168
12169    Gets called when implicit or explicit PROGRAM statement seen or when
12170    FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary
12171    global symbol that serves as the entry point.  */
12172
12173 void
12174 ffecom_notify_primary_entry (ffesymbol s)
12175 {
12176   ffecom_primary_entry_ = s;
12177   ffecom_primary_entry_kind_ = ffesymbol_kind (s);
12178
12179   if ((ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
12180       || (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE))
12181     ffecom_primary_entry_is_proc_ = TRUE;
12182   else
12183     ffecom_primary_entry_is_proc_ = FALSE;
12184
12185   if (!ffe_is_silent ())
12186     {
12187       if (ffecom_primary_entry_kind_ == FFEINFO_kindPROGRAM)
12188         fprintf (stderr, "%s:\n", ffesymbol_text (s));
12189       else
12190         fprintf (stderr, "  %s:\n", ffesymbol_text (s));
12191     }
12192
12193   if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
12194     {
12195       ffebld list;
12196       ffebld arg;
12197
12198       for (list = ffesymbol_dummyargs (s);
12199            list != NULL;
12200            list = ffebld_trail (list))
12201         {
12202           arg = ffebld_head (list);
12203           if (ffebld_op (arg) == FFEBLD_opSTAR)
12204             {
12205               ffecom_is_altreturning_ = TRUE;
12206               break;
12207             }
12208         }
12209     }
12210 }
12211
12212 FILE *
12213 ffecom_open_include (char *name, ffewhereLine l, ffewhereColumn c)
12214 {
12215   return ffecom_open_include_ (name, l, c);
12216 }
12217
12218 /* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front
12219
12220    tree t;
12221    ffebld expr;  // FFE expression.
12222    tree = ffecom_ptr_to_expr(expr);
12223
12224    Like ffecom_expr, but sticks address-of in front of most things.  */
12225
12226 tree
12227 ffecom_ptr_to_expr (ffebld expr)
12228 {
12229   tree item;
12230   ffeinfoBasictype bt;
12231   ffeinfoKindtype kt;
12232   ffesymbol s;
12233
12234   assert (expr != NULL);
12235
12236   switch (ffebld_op (expr))
12237     {
12238     case FFEBLD_opSYMTER:
12239       s = ffebld_symter (expr);
12240       if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
12241         {
12242           ffecomGfrt ix;
12243
12244           ix = ffeintrin_gfrt_indirect (ffebld_symter_implementation (expr));
12245           assert (ix != FFECOM_gfrt);
12246           if ((item = ffecom_gfrt_[ix]) == NULL_TREE)
12247             {
12248               ffecom_make_gfrt_ (ix);
12249               item = ffecom_gfrt_[ix];
12250             }
12251         }
12252       else
12253         {
12254           item = ffesymbol_hook (s).decl_tree;
12255           if (item == NULL_TREE)
12256             {
12257               s = ffecom_sym_transform_ (s);
12258               item = ffesymbol_hook (s).decl_tree;
12259             }
12260         }
12261       assert (item != NULL);
12262       if (item == error_mark_node)
12263         return item;
12264       if (!ffesymbol_hook (s).addr)
12265         item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12266                          item);
12267       return item;
12268
12269     case FFEBLD_opARRAYREF:
12270       return ffecom_arrayref_ (NULL_TREE, expr, 1);
12271
12272     case FFEBLD_opCONTER:
12273
12274       bt = ffeinfo_basictype (ffebld_info (expr));
12275       kt = ffeinfo_kindtype (ffebld_info (expr));
12276
12277       item = ffecom_constantunion (&ffebld_constant_union
12278                                    (ffebld_conter (expr)), bt, kt,
12279                                    ffecom_tree_type[bt][kt]);
12280       if (item == error_mark_node)
12281         return error_mark_node;
12282       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12283                        item);
12284       return item;
12285
12286     case FFEBLD_opANY:
12287       return error_mark_node;
12288
12289     default:
12290       bt = ffeinfo_basictype (ffebld_info (expr));
12291       kt = ffeinfo_kindtype (ffebld_info (expr));
12292
12293       item = ffecom_expr (expr);
12294       if (item == error_mark_node)
12295         return error_mark_node;
12296
12297       /* The back end currently optimizes a bit too zealously for us, in that
12298          we fail JCB001 if the following block of code is omitted.  It checks
12299          to see if the transformed expression is a symbol or array reference,
12300          and encloses it in a SAVE_EXPR if that is the case.  */
12301
12302       STRIP_NOPS (item);
12303       if ((TREE_CODE (item) == VAR_DECL)
12304           || (TREE_CODE (item) == PARM_DECL)
12305           || (TREE_CODE (item) == RESULT_DECL)
12306           || (TREE_CODE (item) == INDIRECT_REF)
12307           || (TREE_CODE (item) == ARRAY_REF)
12308           || (TREE_CODE (item) == COMPONENT_REF)
12309 #ifdef OFFSET_REF
12310           || (TREE_CODE (item) == OFFSET_REF)
12311 #endif
12312           || (TREE_CODE (item) == BUFFER_REF)
12313           || (TREE_CODE (item) == REALPART_EXPR)
12314           || (TREE_CODE (item) == IMAGPART_EXPR))
12315         {
12316           item = ffecom_save_tree (item);
12317         }
12318
12319       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12320                        item);
12321       return item;
12322     }
12323
12324   assert ("fall-through error" == NULL);
12325   return error_mark_node;
12326 }
12327
12328 /* Obtain a temp var with given data type.
12329
12330    size is FFETARGET_charactersizeNONE for a non-CHARACTER type
12331    or >= 0 for a CHARACTER type.
12332
12333    elements is -1 for a scalar or > 0 for an array of type.  */
12334
12335 tree
12336 ffecom_make_tempvar (const char *commentary, tree type,
12337                      ffetargetCharacterSize size, int elements)
12338 {
12339   tree t;
12340   static int mynumber;
12341
12342   assert (current_binding_level->prep_state < 2);
12343
12344   if (type == error_mark_node)
12345     return error_mark_node;
12346
12347   if (size != FFETARGET_charactersizeNONE)
12348     type = build_array_type (type,
12349                              build_range_type (ffecom_f2c_ftnlen_type_node,
12350                                                ffecom_f2c_ftnlen_one_node,
12351                                                build_int_2 (size, 0)));
12352   if (elements != -1)
12353     type = build_array_type (type,
12354                              build_range_type (integer_type_node,
12355                                                integer_zero_node,
12356                                                build_int_2 (elements - 1,
12357                                                             0)));
12358   t = build_decl (VAR_DECL,
12359                   ffecom_get_invented_identifier ("__g77_%s_%d",
12360                                                   commentary,
12361                                                   mynumber++),
12362                   type);
12363
12364   t = start_decl (t, FALSE);
12365   finish_decl (t, NULL_TREE, FALSE);
12366
12367   return t;
12368 }
12369
12370 /* Prepare argument pointer to expression.
12371
12372    Like ffecom_prepare_expr, except for expressions to be evaluated
12373    via ffecom_arg_ptr_to_expr.  */
12374
12375 void
12376 ffecom_prepare_arg_ptr_to_expr (ffebld expr)
12377 {
12378   /* ~~For now, it seems to be the same thing.  */
12379   ffecom_prepare_expr (expr);
12380   return;
12381 }
12382
12383 /* End of preparations.  */
12384
12385 bool
12386 ffecom_prepare_end (void)
12387 {
12388   int prep_state = current_binding_level->prep_state;
12389
12390   assert (prep_state < 2);
12391   current_binding_level->prep_state = 2;
12392
12393   return (prep_state == 1) ? TRUE : FALSE;
12394 }
12395
12396 /* Prepare expression.
12397
12398    This is called before any code is generated for the current block.
12399    It scans the expression, declares any temporaries that might be needed
12400    during evaluation of the expression, and stores those temporaries in
12401    the appropriate "hook" fields of the expression.  `dest', if not NULL,
12402    specifies the destination that ffecom_expr_ will see, in case that
12403    helps avoid generating unused temporaries.
12404
12405    ~~Improve to avoid allocating unused temporaries by taking `dest'
12406    into account vis-a-vis aliasing requirements of complex/character
12407    functions.  */
12408
12409 void
12410 ffecom_prepare_expr_ (ffebld expr, ffebld dest UNUSED)
12411 {
12412   ffeinfoBasictype bt;
12413   ffeinfoKindtype kt;
12414   ffetargetCharacterSize sz;
12415   tree tempvar = NULL_TREE;
12416
12417   assert (current_binding_level->prep_state < 2);
12418
12419   if (! expr)
12420     return;
12421
12422   bt = ffeinfo_basictype (ffebld_info (expr));
12423   kt = ffeinfo_kindtype (ffebld_info (expr));
12424   sz = ffeinfo_size (ffebld_info (expr));
12425
12426   /* Generate whatever temporaries are needed to represent the result
12427      of the expression.  */
12428
12429   if (bt == FFEINFO_basictypeCHARACTER)
12430     {
12431       while (ffebld_op (expr) == FFEBLD_opPAREN)
12432         expr = ffebld_left (expr);
12433     }
12434
12435   switch (ffebld_op (expr))
12436     {
12437     default:
12438       /* Don't make temps for SYMTER, CONTER, etc.  */
12439       if (ffebld_arity (expr) == 0)
12440         break;
12441
12442       switch (bt)
12443         {
12444         case FFEINFO_basictypeCOMPLEX:
12445           if (ffebld_op (expr) == FFEBLD_opFUNCREF)
12446             {
12447               ffesymbol s;
12448
12449               if (ffebld_op (ffebld_left (expr)) != FFEBLD_opSYMTER)
12450                 break;
12451
12452               s = ffebld_symter (ffebld_left (expr));
12453               if (ffesymbol_where (s) == FFEINFO_whereCONSTANT
12454                   || (ffesymbol_where (s) != FFEINFO_whereINTRINSIC
12455                       && ! ffesymbol_is_f2c (s))
12456                   || (ffesymbol_where (s) == FFEINFO_whereINTRINSIC
12457                       && ! ffe_is_f2c_library ()))
12458                 break;
12459             }
12460           else if (ffebld_op (expr) == FFEBLD_opPOWER)
12461             {
12462               /* Requires special treatment.  There's no POW_CC function
12463                  in libg2c, so POW_ZZ is used, which means we always
12464                  need a double-complex temp, not a single-complex.  */
12465               kt = FFEINFO_kindtypeREAL2;
12466             }
12467           else if (ffebld_op (expr) != FFEBLD_opDIVIDE)
12468             /* The other ops don't need temps for complex operands.  */
12469             break;
12470
12471           /* ~~~Avoid making temps for some intrinsics, such as AIMAG(C),
12472              REAL(C).  See 19990325-0.f, routine `check', for cases.  */
12473           tempvar = ffecom_make_tempvar ("complex",
12474                                          ffecom_tree_type
12475                                          [FFEINFO_basictypeCOMPLEX][kt],
12476                                          FFETARGET_charactersizeNONE,
12477                                          -1);
12478           break;
12479
12480         case FFEINFO_basictypeCHARACTER:
12481           if (ffebld_op (expr) != FFEBLD_opFUNCREF)
12482             break;
12483
12484           if (sz == FFETARGET_charactersizeNONE)
12485             /* ~~Kludge alert!  This should someday be fixed. */
12486             sz = 24;
12487
12488           tempvar = ffecom_make_tempvar ("char", char_type_node, sz, -1);
12489           break;
12490
12491         default:
12492           break;
12493         }
12494       break;
12495
12496     case FFEBLD_opCONCATENATE:
12497       {
12498         /* This gets special handling, because only one set of temps
12499            is needed for a tree of these -- the tree is treated as
12500            a flattened list of concatenations when generating code.  */
12501
12502         ffecomConcatList_ catlist;
12503         tree ltmp, itmp, result;
12504         int count;
12505         int i;
12506
12507         catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
12508         count = ffecom_concat_list_count_ (catlist);
12509
12510         if (count >= 2)
12511           {
12512             ltmp
12513               = ffecom_make_tempvar ("concat_len",
12514                                      ffecom_f2c_ftnlen_type_node,
12515                                      FFETARGET_charactersizeNONE, count);
12516             itmp
12517               = ffecom_make_tempvar ("concat_item",
12518                                      ffecom_f2c_address_type_node,
12519                                      FFETARGET_charactersizeNONE, count);
12520             result
12521               = ffecom_make_tempvar ("concat_res",
12522                                      char_type_node,
12523                                      ffecom_concat_list_maxlen_ (catlist),
12524                                      -1);
12525
12526             tempvar = make_tree_vec (3);
12527             TREE_VEC_ELT (tempvar, 0) = ltmp;
12528             TREE_VEC_ELT (tempvar, 1) = itmp;
12529             TREE_VEC_ELT (tempvar, 2) = result;
12530           }
12531
12532         for (i = 0; i < count; ++i)
12533           ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist,
12534                                                                     i));
12535
12536         ffecom_concat_list_kill_ (catlist);
12537
12538         if (tempvar)
12539           {
12540             ffebld_nonter_set_hook (expr, tempvar);
12541             current_binding_level->prep_state = 1;
12542           }
12543       }
12544       return;
12545
12546     case FFEBLD_opCONVERT:
12547       if (bt == FFEINFO_basictypeCHARACTER
12548           && ((ffebld_size_known (ffebld_left (expr))
12549                == FFETARGET_charactersizeNONE)
12550               || (ffebld_size_known (ffebld_left (expr)) >= sz)))
12551         tempvar = ffecom_make_tempvar ("convert", char_type_node, sz, -1);
12552       break;
12553     }
12554
12555   if (tempvar)
12556     {
12557       ffebld_nonter_set_hook (expr, tempvar);
12558       current_binding_level->prep_state = 1;
12559     }
12560
12561   /* Prepare subexpressions for this expr.  */
12562
12563   switch (ffebld_op (expr))
12564     {
12565     case FFEBLD_opPERCENT_LOC:
12566       ffecom_prepare_ptr_to_expr (ffebld_left (expr));
12567       break;
12568
12569     case FFEBLD_opPERCENT_VAL:
12570     case FFEBLD_opPERCENT_REF:
12571       ffecom_prepare_expr (ffebld_left (expr));
12572       break;
12573
12574     case FFEBLD_opPERCENT_DESCR:
12575       ffecom_prepare_arg_ptr_to_expr (ffebld_left (expr));
12576       break;
12577
12578     case FFEBLD_opITEM:
12579       {
12580         ffebld item;
12581
12582         for (item = expr;
12583              item != NULL;
12584              item = ffebld_trail (item))
12585           if (ffebld_head (item) != NULL)
12586             ffecom_prepare_expr (ffebld_head (item));
12587       }
12588       break;
12589
12590     default:
12591       /* Need to handle character conversion specially.  */
12592       switch (ffebld_arity (expr))
12593         {
12594         case 2:
12595           ffecom_prepare_expr (ffebld_left (expr));
12596           ffecom_prepare_expr (ffebld_right (expr));
12597           break;
12598
12599         case 1:
12600           ffecom_prepare_expr (ffebld_left (expr));
12601           break;
12602
12603         default:
12604           break;
12605         }
12606     }
12607
12608   return;
12609 }
12610
12611 /* Prepare expression for reading and writing.
12612
12613    Like ffecom_prepare_expr, except for expressions to be evaluated
12614    via ffecom_expr_rw.  */
12615
12616 void
12617 ffecom_prepare_expr_rw (tree type, ffebld expr)
12618 {
12619   /* This is all we support for now.  */
12620   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
12621
12622   /* ~~For now, it seems to be the same thing.  */
12623   ffecom_prepare_expr (expr);
12624   return;
12625 }
12626
12627 /* Prepare expression for writing.
12628
12629    Like ffecom_prepare_expr, except for expressions to be evaluated
12630    via ffecom_expr_w.  */
12631
12632 void
12633 ffecom_prepare_expr_w (tree type, ffebld expr)
12634 {
12635   /* This is all we support for now.  */
12636   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
12637
12638   /* ~~For now, it seems to be the same thing.  */
12639   ffecom_prepare_expr (expr);
12640   return;
12641 }
12642
12643 /* Prepare expression for returning.
12644
12645    Like ffecom_prepare_expr, except for expressions to be evaluated
12646    via ffecom_return_expr.  */
12647
12648 void
12649 ffecom_prepare_return_expr (ffebld expr)
12650 {
12651   assert (current_binding_level->prep_state < 2);
12652
12653   if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE
12654       && ffecom_is_altreturning_
12655       && expr != NULL)
12656     ffecom_prepare_expr (expr);
12657 }
12658
12659 /* Prepare pointer to expression.
12660
12661    Like ffecom_prepare_expr, except for expressions to be evaluated
12662    via ffecom_ptr_to_expr.  */
12663
12664 void
12665 ffecom_prepare_ptr_to_expr (ffebld expr)
12666 {
12667   /* ~~For now, it seems to be the same thing.  */
12668   ffecom_prepare_expr (expr);
12669   return;
12670 }
12671
12672 /* Transform expression into constant pointer-to-expression tree.
12673
12674    If the expression can be transformed into a pointer-to-expression tree
12675    that is constant, that is done, and the tree returned.  Else NULL_TREE
12676    is returned.
12677
12678    That way, a caller can attempt to provide compile-time initialization
12679    of a variable and, if that fails, *then* choose to start a new block
12680    and resort to using temporaries, as appropriate.  */
12681
12682 tree
12683 ffecom_ptr_to_const_expr (ffebld expr)
12684 {
12685   if (! expr)
12686     return integer_zero_node;
12687
12688   if (ffebld_op (expr) == FFEBLD_opANY)
12689     return error_mark_node;
12690
12691   if (ffebld_arity (expr) == 0
12692       && (ffebld_op (expr) != FFEBLD_opSYMTER
12693           || ffebld_where (expr) == FFEINFO_whereCOMMON
12694           || ffebld_where (expr) == FFEINFO_whereGLOBAL
12695           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
12696     {
12697       tree t;
12698
12699       t = ffecom_ptr_to_expr (expr);
12700       assert (TREE_CONSTANT (t));
12701       return t;
12702     }
12703
12704   return NULL_TREE;
12705 }
12706
12707 /* ffecom_return_expr -- Returns return-value expr given alt return expr
12708
12709    tree rtn;  // NULL_TREE means use expand_null_return()
12710    ffebld expr;  // NULL if no alt return expr to RETURN stmt
12711    rtn = ffecom_return_expr(expr);
12712
12713    Based on the program unit type and other info (like return function
12714    type, return master function type when alternate ENTRY points,
12715    whether subroutine has any alternate RETURN points, etc), returns the
12716    appropriate expression to be returned to the caller, or NULL_TREE
12717    meaning no return value or the caller expects it to be returned somewhere
12718    else (which is handled by other parts of this module).  */
12719
12720 tree
12721 ffecom_return_expr (ffebld expr)
12722 {
12723   tree rtn;
12724
12725   switch (ffecom_primary_entry_kind_)
12726     {
12727     case FFEINFO_kindPROGRAM:
12728     case FFEINFO_kindBLOCKDATA:
12729       rtn = NULL_TREE;
12730       break;
12731
12732     case FFEINFO_kindSUBROUTINE:
12733       if (!ffecom_is_altreturning_)
12734         rtn = NULL_TREE;        /* No alt returns, never an expr. */
12735       else if (expr == NULL)
12736         rtn = integer_zero_node;
12737       else
12738         rtn = ffecom_expr (expr);
12739       break;
12740
12741     case FFEINFO_kindFUNCTION:
12742       if ((ffecom_multi_retval_ != NULL_TREE)
12743           || (ffesymbol_basictype (ffecom_primary_entry_)
12744               == FFEINFO_basictypeCHARACTER)
12745           || ((ffesymbol_basictype (ffecom_primary_entry_)
12746                == FFEINFO_basictypeCOMPLEX)
12747               && (ffecom_num_entrypoints_ == 0)
12748               && ffesymbol_is_f2c (ffecom_primary_entry_)))
12749         {                       /* Value is returned by direct assignment
12750                                    into (implicit) dummy. */
12751           rtn = NULL_TREE;
12752           break;
12753         }
12754       rtn = ffecom_func_result_;
12755 #if 0
12756       /* Spurious error if RETURN happens before first reference!  So elide
12757          this code.  In particular, for debugging registry, rtn should always
12758          be non-null after all, but TREE_USED won't be set until we encounter
12759          a reference in the code.  Perfectly okay (but weird) code that,
12760          e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in
12761          this diagnostic for no reason.  Have people use -O -Wuninitialized
12762          and leave it to the back end to find obviously weird cases.  */
12763
12764       /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid
12765          situation; if the return value has never been referenced, it won't
12766          have a tree under 2pass mode. */
12767       if ((rtn == NULL_TREE)
12768           || !TREE_USED (rtn))
12769         {
12770           ffebad_start (FFEBAD_RETURN_VALUE_UNSET);
12771           ffebad_here (0, ffesymbol_where_line (ffecom_primary_entry_),
12772                        ffesymbol_where_column (ffecom_primary_entry_));
12773           ffebad_string (ffesymbol_text (ffesymbol_funcresult
12774                                          (ffecom_primary_entry_)));
12775           ffebad_finish ();
12776         }
12777 #endif
12778       break;
12779
12780     default:
12781       assert ("bad unit kind" == NULL);
12782     case FFEINFO_kindANY:
12783       rtn = error_mark_node;
12784       break;
12785     }
12786
12787   return rtn;
12788 }
12789
12790 /* Do save_expr only if tree is not error_mark_node.  */
12791
12792 tree
12793 ffecom_save_tree (tree t)
12794 {
12795   return save_expr (t);
12796 }
12797
12798 /* Start a compound statement (block).  */
12799
12800 void
12801 ffecom_start_compstmt (void)
12802 {
12803   bison_rule_pushlevel_ ();
12804 }
12805
12806 /* Public entry point for front end to access start_decl.  */
12807
12808 tree
12809 ffecom_start_decl (tree decl, bool is_initialized)
12810 {
12811   DECL_INITIAL (decl) = is_initialized ? error_mark_node : NULL_TREE;
12812   return start_decl (decl, FALSE);
12813 }
12814
12815 /* ffecom_sym_commit -- Symbol's state being committed to reality
12816
12817    ffesymbol s;
12818    ffecom_sym_commit(s);
12819
12820    Does whatever the backend needs when a symbol is committed after having
12821    been backtrackable for a period of time.  */
12822
12823 void
12824 ffecom_sym_commit (ffesymbol s UNUSED)
12825 {
12826   assert (!ffesymbol_retractable ());
12827 }
12828
12829 /* ffecom_sym_end_transition -- Perform end transition on all symbols
12830
12831    ffecom_sym_end_transition();
12832
12833    Does backend-specific stuff and also calls ffest_sym_end_transition
12834    to do the necessary FFE stuff.
12835
12836    Backtracking is never enabled when this fn is called, so don't worry
12837    about it.  */
12838
12839 ffesymbol
12840 ffecom_sym_end_transition (ffesymbol s)
12841 {
12842   ffestorag st;
12843
12844   assert (!ffesymbol_retractable ());
12845
12846   s = ffest_sym_end_transition (s);
12847
12848   if ((ffesymbol_kind (s) == FFEINFO_kindBLOCKDATA)
12849       && (ffesymbol_where (s) == FFEINFO_whereGLOBAL))
12850     {
12851       ffecom_list_blockdata_
12852         = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
12853                                               FFEINTRIN_specNONE,
12854                                               FFEINTRIN_impNONE),
12855                            ffecom_list_blockdata_);
12856     }
12857
12858   /* This is where we finally notice that a symbol has partial initialization
12859      and finalize it. */
12860
12861   if (ffesymbol_accretion (s) != NULL)
12862     {
12863       assert (ffesymbol_init (s) == NULL);
12864       ffecom_notify_init_symbol (s);
12865     }
12866   else if (((st = ffesymbol_storage (s)) != NULL)
12867            && ((st = ffestorag_parent (st)) != NULL)
12868            && (ffestorag_accretion (st) != NULL))
12869     {
12870       assert (ffestorag_init (st) == NULL);
12871       ffecom_notify_init_storage (st);
12872     }
12873
12874   if ((ffesymbol_kind (s) == FFEINFO_kindCOMMON)
12875       && (ffesymbol_where (s) == FFEINFO_whereLOCAL)
12876       && (ffesymbol_storage (s) != NULL))
12877     {
12878       ffecom_list_common_
12879         = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
12880                                               FFEINTRIN_specNONE,
12881                                               FFEINTRIN_impNONE),
12882                            ffecom_list_common_);
12883     }
12884
12885   return s;
12886 }
12887
12888 /* ffecom_sym_exec_transition -- Perform exec transition on all symbols
12889
12890    ffecom_sym_exec_transition();
12891
12892    Does backend-specific stuff and also calls ffest_sym_exec_transition
12893    to do the necessary FFE stuff.
12894
12895    See the long-winded description in ffecom_sym_learned for info
12896    on handling the situation where backtracking is inhibited.  */
12897
12898 ffesymbol
12899 ffecom_sym_exec_transition (ffesymbol s)
12900 {
12901   s = ffest_sym_exec_transition (s);
12902
12903   return s;
12904 }
12905
12906 /* ffecom_sym_learned -- Initial or more info gained on symbol after exec
12907
12908    ffesymbol s;
12909    s = ffecom_sym_learned(s);
12910
12911    Called when a new symbol is seen after the exec transition or when more
12912    info (perhaps) is gained for an UNCERTAIN symbol.  The symbol state when
12913    it arrives here is that all its latest info is updated already, so its
12914    state may be UNCERTAIN or UNDERSTOOD, it might already have the hook
12915    field filled in if its gone through here or exec_transition first, and
12916    so on.
12917
12918    The backend probably wants to check ffesymbol_retractable() to see if
12919    backtracking is in effect.  If so, the FFE's changes to the symbol may
12920    be retracted (undone) or committed (ratified), at which time the
12921    appropriate ffecom_sym_retract or _commit function will be called
12922    for that function.
12923
12924    If the backend has its own backtracking mechanism, great, use it so that
12925    committal is a simple operation.  Though it doesn't make much difference,
12926    I suppose: the reason for tentative symbol evolution in the FFE is to
12927    enable error detection in weird incorrect statements early and to disable
12928    incorrect error detection on a correct statement.  The backend is not
12929    likely to introduce any information that'll get involved in these
12930    considerations, so it is probably just fine that the implementation
12931    model for this fn and for _exec_transition is to not do anything
12932    (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE
12933    and instead wait until ffecom_sym_commit is called (which it never
12934    will be as long as we're using ambiguity-detecting statement analysis in
12935    the FFE, which we are initially to shake out the code, but don't depend
12936    on this), otherwise go ahead and do whatever is needed.
12937
12938    In essence, then, when this fn and _exec_transition get called while
12939    backtracking is enabled, a general mechanism would be to flag which (or
12940    both) of these were called (and in what order? neat question as to what
12941    might happen that I'm too lame to think through right now) and then when
12942    _commit is called reproduce the original calling sequence, if any, for
12943    the two fns (at which point backtracking will, of course, be disabled).  */
12944
12945 ffesymbol
12946 ffecom_sym_learned (ffesymbol s)
12947 {
12948   ffestorag_exec_layout (s);
12949
12950   return s;
12951 }
12952
12953 /* ffecom_sym_retract -- Symbol's state being retracted from reality
12954
12955    ffesymbol s;
12956    ffecom_sym_retract(s);
12957
12958    Does whatever the backend needs when a symbol is retracted after having
12959    been backtrackable for a period of time.  */
12960
12961 void
12962 ffecom_sym_retract (ffesymbol s UNUSED)
12963 {
12964   assert (!ffesymbol_retractable ());
12965
12966 #if 0                           /* GCC doesn't commit any backtrackable sins,
12967                                    so nothing needed here. */
12968   switch (ffesymbol_hook (s).state)
12969     {
12970     case 0:                     /* nothing happened yet. */
12971       break;
12972
12973     case 1:                     /* exec transition happened. */
12974       break;
12975
12976     case 2:                     /* learned happened. */
12977       break;
12978
12979     case 3:                     /* learned then exec. */
12980       break;
12981
12982     case 4:                     /* exec then learned. */
12983       break;
12984
12985     default:
12986       assert ("bad hook state" == NULL);
12987       break;
12988     }
12989 #endif
12990 }
12991
12992 /* Create temporary gcc label.  */
12993
12994 tree
12995 ffecom_temp_label ()
12996 {
12997   tree glabel;
12998   static int mynumber = 0;
12999
13000   glabel = build_decl (LABEL_DECL,
13001                        ffecom_get_invented_identifier ("__g77_label_%d",
13002                                                        mynumber++),
13003                        void_type_node);
13004   DECL_CONTEXT (glabel) = current_function_decl;
13005   DECL_MODE (glabel) = VOIDmode;
13006
13007   return glabel;
13008 }
13009
13010 /* Return an expression that is usable as an arg in a conditional context
13011    (IF, DO WHILE, .NOT., and so on).
13012
13013    Use the one provided for the back end as of >2.6.0.  */
13014
13015 tree
13016 ffecom_truth_value (tree expr)
13017 {
13018   return ffe_truthvalue_conversion (expr);
13019 }
13020
13021 /* Return the inversion of a truth value (the inversion of what
13022    ffecom_truth_value builds).
13023
13024    Apparently invert_truthvalue, which is properly in the back end, is
13025    enough for now, so just use it.  */
13026
13027 tree
13028 ffecom_truth_value_invert (tree expr)
13029 {
13030   return invert_truthvalue (ffecom_truth_value (expr));
13031 }
13032
13033 /* Return the tree that is the type of the expression, as would be
13034    returned in TREE_TYPE(ffecom_expr(expr)), without otherwise
13035    transforming the expression, generating temporaries, etc.  */
13036
13037 tree
13038 ffecom_type_expr (ffebld expr)
13039 {
13040   ffeinfoBasictype bt;
13041   ffeinfoKindtype kt;
13042   tree tree_type;
13043
13044   assert (expr != NULL);
13045
13046   bt = ffeinfo_basictype (ffebld_info (expr));
13047   kt = ffeinfo_kindtype (ffebld_info (expr));
13048   tree_type = ffecom_tree_type[bt][kt];
13049
13050   switch (ffebld_op (expr))
13051     {
13052     case FFEBLD_opCONTER:
13053     case FFEBLD_opSYMTER:
13054     case FFEBLD_opARRAYREF:
13055     case FFEBLD_opUPLUS:
13056     case FFEBLD_opPAREN:
13057     case FFEBLD_opUMINUS:
13058     case FFEBLD_opADD:
13059     case FFEBLD_opSUBTRACT:
13060     case FFEBLD_opMULTIPLY:
13061     case FFEBLD_opDIVIDE:
13062     case FFEBLD_opPOWER:
13063     case FFEBLD_opNOT:
13064     case FFEBLD_opFUNCREF:
13065     case FFEBLD_opSUBRREF:
13066     case FFEBLD_opAND:
13067     case FFEBLD_opOR:
13068     case FFEBLD_opXOR:
13069     case FFEBLD_opNEQV:
13070     case FFEBLD_opEQV:
13071     case FFEBLD_opCONVERT:
13072     case FFEBLD_opLT:
13073     case FFEBLD_opLE:
13074     case FFEBLD_opEQ:
13075     case FFEBLD_opNE:
13076     case FFEBLD_opGT:
13077     case FFEBLD_opGE:
13078     case FFEBLD_opPERCENT_LOC:
13079       return tree_type;
13080
13081     case FFEBLD_opACCTER:
13082     case FFEBLD_opARRTER:
13083     case FFEBLD_opITEM:
13084     case FFEBLD_opSTAR:
13085     case FFEBLD_opBOUNDS:
13086     case FFEBLD_opREPEAT:
13087     case FFEBLD_opLABTER:
13088     case FFEBLD_opLABTOK:
13089     case FFEBLD_opIMPDO:
13090     case FFEBLD_opCONCATENATE:
13091     case FFEBLD_opSUBSTR:
13092     default:
13093       assert ("bad op for ffecom_type_expr" == NULL);
13094       /* Fall through. */
13095     case FFEBLD_opANY:
13096       return error_mark_node;
13097     }
13098 }
13099
13100 /* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points
13101
13102    If the PARM_DECL already exists, return it, else create it.  It's an
13103    integer_type_node argument for the master function that implements a
13104    subroutine or function with more than one entrypoint and is bound at
13105    run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for
13106    first ENTRY statement, and so on).  */
13107
13108 tree
13109 ffecom_which_entrypoint_decl ()
13110 {
13111   assert (ffecom_which_entrypoint_decl_ != NULL_TREE);
13112
13113   return ffecom_which_entrypoint_decl_;
13114 }
13115 \f
13116 /* The following sections consists of private and public functions
13117    that have the same names and perform roughly the same functions
13118    as counterparts in the C front end.  Changes in the C front end
13119    might affect how things should be done here.  Only functions
13120    needed by the back end should be public here; the rest should
13121    be private (static in the C sense).  Functions needed by other
13122    g77 front-end modules should be accessed by them via public
13123    ffecom_* names, which should themselves call private versions
13124    in this section so the private versions are easy to recognize
13125    when upgrading to a new gcc and finding interesting changes
13126    in the front end.
13127
13128    Functions named after rule "foo:" in c-parse.y are named
13129    "bison_rule_foo_" so they are easy to find.  */
13130
13131 static void
13132 bison_rule_pushlevel_ ()
13133 {
13134   emit_line_note (input_filename, input_line);
13135   pushlevel (0);
13136   clear_last_expr ();
13137   expand_start_bindings (0);
13138 }
13139
13140 static tree
13141 bison_rule_compstmt_ ()
13142 {
13143   tree t;
13144   int keep = kept_level_p ();
13145
13146   /* Make the temps go away.  */
13147   if (! keep)
13148     current_binding_level->names = NULL_TREE;
13149
13150   emit_line_note (input_filename, input_line);
13151   expand_end_bindings (getdecls (), keep, 0);
13152   t = poplevel (keep, 1, 0);
13153
13154   return t;
13155 }
13156
13157 /* Return a definition for a builtin function named NAME and whose data type
13158    is TYPE.  TYPE should be a function type with argument types.
13159    FUNCTION_CODE tells later passes how to compile calls to this function.
13160    See tree.h for its possible values.
13161
13162    If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
13163    the name to be called if we can't opencode the function.  If
13164    ATTRS is nonzero, use that for the function's attribute list.  */
13165
13166 tree
13167 builtin_function (const char *name, tree type, int function_code,
13168                   enum built_in_class class,
13169                   const char *library_name,
13170                   tree attrs ATTRIBUTE_UNUSED)
13171 {
13172   tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type);
13173   DECL_EXTERNAL (decl) = 1;
13174   TREE_PUBLIC (decl) = 1;
13175   if (library_name)
13176     SET_DECL_ASSEMBLER_NAME (decl, get_identifier (library_name));
13177   make_decl_rtl (decl, NULL);
13178   pushdecl (decl);
13179   DECL_BUILT_IN_CLASS (decl) = class;
13180   DECL_FUNCTION_CODE (decl) = function_code;
13181
13182   return decl;
13183 }
13184
13185 /* Handle when a new declaration NEWDECL
13186    has the same name as an old one OLDDECL
13187    in the same binding contour.
13188    Prints an error message if appropriate.
13189
13190    If safely possible, alter OLDDECL to look like NEWDECL, and return 1.
13191    Otherwise, return 0.  */
13192
13193 static int
13194 duplicate_decls (tree newdecl, tree olddecl)
13195 {
13196   int types_match = 1;
13197   int new_is_definition = (TREE_CODE (newdecl) == FUNCTION_DECL
13198                            && DECL_INITIAL (newdecl) != 0);
13199   tree oldtype = TREE_TYPE (olddecl);
13200   tree newtype = TREE_TYPE (newdecl);
13201
13202   if (olddecl == newdecl)
13203     return 1;
13204
13205   if (TREE_CODE (newtype) == ERROR_MARK
13206       || TREE_CODE (oldtype) == ERROR_MARK)
13207     types_match = 0;
13208
13209   /* New decl is completely inconsistent with the old one =>
13210      tell caller to replace the old one.
13211      This is always an error except in the case of shadowing a builtin.  */
13212   if (TREE_CODE (olddecl) != TREE_CODE (newdecl))
13213     return 0;
13214
13215   /* For real parm decl following a forward decl,
13216      return 1 so old decl will be reused.  */
13217   if (types_match && TREE_CODE (newdecl) == PARM_DECL
13218       && TREE_ASM_WRITTEN (olddecl) && ! TREE_ASM_WRITTEN (newdecl))
13219     return 1;
13220
13221   /* The new declaration is the same kind of object as the old one.
13222      The declarations may partially match.  Print warnings if they don't
13223      match enough.  Ultimately, copy most of the information from the new
13224      decl to the old one, and keep using the old one.  */
13225
13226   if (TREE_CODE (olddecl) == FUNCTION_DECL
13227       && DECL_BUILT_IN (olddecl))
13228     {
13229       /* A function declaration for a built-in function.  */
13230       if (!TREE_PUBLIC (newdecl))
13231         return 0;
13232       else if (!types_match)
13233         {
13234           /* Accept the return type of the new declaration if same modes.  */
13235           tree oldreturntype = TREE_TYPE (TREE_TYPE (olddecl));
13236           tree newreturntype = TREE_TYPE (TREE_TYPE (newdecl));
13237
13238           if (TYPE_MODE (oldreturntype) == TYPE_MODE (newreturntype))
13239             {
13240               /* Function types may be shared, so we can't just modify
13241                  the return type of olddecl's function type.  */
13242               tree newtype
13243                 = build_function_type (newreturntype,
13244                                        TYPE_ARG_TYPES (TREE_TYPE (olddecl)));
13245
13246               types_match = 1;
13247               if (types_match)
13248                 TREE_TYPE (olddecl) = newtype;
13249             }
13250         }
13251       if (!types_match)
13252         return 0;
13253     }
13254   else if (TREE_CODE (olddecl) == FUNCTION_DECL
13255            && DECL_SOURCE_LINE (olddecl) == 0)
13256     {
13257       /* A function declaration for a predeclared function
13258          that isn't actually built in.  */
13259       if (!TREE_PUBLIC (newdecl))
13260         return 0;
13261       else if (!types_match)
13262         {
13263           /* If the types don't match, preserve volatility indication.
13264              Later on, we will discard everything else about the
13265              default declaration.  */
13266           TREE_THIS_VOLATILE (newdecl) |= TREE_THIS_VOLATILE (olddecl);
13267         }
13268     }
13269
13270   /* Copy all the DECL_... slots specified in the new decl
13271      except for any that we copy here from the old type.
13272
13273      Past this point, we don't change OLDTYPE and NEWTYPE
13274      even if we change the types of NEWDECL and OLDDECL.  */
13275
13276   if (types_match)
13277     {
13278       /* Merge the data types specified in the two decls.  */
13279       if (TREE_CODE (newdecl) != FUNCTION_DECL || !DECL_BUILT_IN (olddecl))
13280         TREE_TYPE (newdecl)
13281           = TREE_TYPE (olddecl)
13282             = TREE_TYPE (newdecl);
13283
13284       /* Lay the type out, unless already done.  */
13285       if (oldtype != TREE_TYPE (newdecl))
13286         {
13287           if (TREE_TYPE (newdecl) != error_mark_node)
13288             layout_type (TREE_TYPE (newdecl));
13289           if (TREE_CODE (newdecl) != FUNCTION_DECL
13290               && TREE_CODE (newdecl) != TYPE_DECL
13291               && TREE_CODE (newdecl) != CONST_DECL)
13292             layout_decl (newdecl, 0);
13293         }
13294       else
13295         {
13296           /* Since the type is OLDDECL's, make OLDDECL's size go with.  */
13297           DECL_SIZE (newdecl) = DECL_SIZE (olddecl);
13298           DECL_SIZE_UNIT (newdecl) = DECL_SIZE_UNIT (olddecl);
13299           if (TREE_CODE (olddecl) != FUNCTION_DECL)
13300             if (DECL_ALIGN (olddecl) > DECL_ALIGN (newdecl))
13301               {
13302                 DECL_ALIGN (newdecl) = DECL_ALIGN (olddecl);
13303                 DECL_USER_ALIGN (newdecl) |= DECL_USER_ALIGN (olddecl);
13304               }
13305         }
13306
13307       /* Keep the old rtl since we can safely use it.  */
13308       COPY_DECL_RTL (olddecl, newdecl);
13309
13310       /* Merge the type qualifiers.  */
13311       if (TREE_READONLY (newdecl))
13312         TREE_READONLY (olddecl) = 1;
13313       if (TREE_THIS_VOLATILE (newdecl))
13314         {
13315           TREE_THIS_VOLATILE (olddecl) = 1;
13316           if (TREE_CODE (newdecl) == VAR_DECL)
13317             make_var_volatile (newdecl);
13318         }
13319
13320       /* Keep source location of definition rather than declaration.
13321          Likewise, keep decl at outer scope.  */
13322       if ((DECL_INITIAL (newdecl) == 0 && DECL_INITIAL (olddecl) != 0)
13323           || (DECL_CONTEXT (newdecl) != 0 && DECL_CONTEXT (olddecl) == 0))
13324         {
13325           DECL_SOURCE_LINE (newdecl) = DECL_SOURCE_LINE (olddecl);
13326           DECL_SOURCE_FILE (newdecl) = DECL_SOURCE_FILE (olddecl);
13327
13328           if (DECL_CONTEXT (olddecl) == 0
13329               && TREE_CODE (newdecl) != FUNCTION_DECL)
13330             DECL_CONTEXT (newdecl) = 0;
13331         }
13332
13333       /* Merge the unused-warning information.  */
13334       if (DECL_IN_SYSTEM_HEADER (olddecl))
13335         DECL_IN_SYSTEM_HEADER (newdecl) = 1;
13336       else if (DECL_IN_SYSTEM_HEADER (newdecl))
13337         DECL_IN_SYSTEM_HEADER (olddecl) = 1;
13338
13339       /* Merge the initialization information.  */
13340       if (DECL_INITIAL (newdecl) == 0)
13341         DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13342
13343       /* Merge the section attribute.
13344          We want to issue an error if the sections conflict but that must be
13345          done later in decl_attributes since we are called before attributes
13346          are assigned.  */
13347       if (DECL_SECTION_NAME (newdecl) == NULL_TREE)
13348         DECL_SECTION_NAME (newdecl) = DECL_SECTION_NAME (olddecl);
13349
13350       /* Copy the assembler name.  */
13351       COPY_DECL_ASSEMBLER_NAME (olddecl, newdecl);
13352
13353       if (TREE_CODE (newdecl) == FUNCTION_DECL)
13354         {
13355           DECL_STATIC_CONSTRUCTOR(newdecl) |= DECL_STATIC_CONSTRUCTOR(olddecl);
13356           DECL_STATIC_DESTRUCTOR (newdecl) |= DECL_STATIC_DESTRUCTOR (olddecl);
13357           TREE_THIS_VOLATILE (newdecl) |= TREE_THIS_VOLATILE (olddecl);
13358           TREE_READONLY (newdecl) |= TREE_READONLY (olddecl);
13359           DECL_IS_MALLOC (newdecl) |= DECL_IS_MALLOC (olddecl);
13360           DECL_IS_PURE (newdecl) |= DECL_IS_PURE (olddecl);
13361         }
13362     }
13363   /* If cannot merge, then use the new type and qualifiers,
13364      and don't preserve the old rtl.  */
13365   else
13366     {
13367       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13368       TREE_READONLY (olddecl) = TREE_READONLY (newdecl);
13369       TREE_THIS_VOLATILE (olddecl) = TREE_THIS_VOLATILE (newdecl);
13370       TREE_SIDE_EFFECTS (olddecl) = TREE_SIDE_EFFECTS (newdecl);
13371     }
13372
13373   /* Merge the storage class information.  */
13374   /* For functions, static overrides non-static.  */
13375   if (TREE_CODE (newdecl) == FUNCTION_DECL)
13376     {
13377       TREE_PUBLIC (newdecl) &= TREE_PUBLIC (olddecl);
13378       /* This is since we don't automatically
13379          copy the attributes of NEWDECL into OLDDECL.  */
13380       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13381       /* If this clears `static', clear it in the identifier too.  */
13382       if (! TREE_PUBLIC (olddecl))
13383         TREE_PUBLIC (DECL_NAME (olddecl)) = 0;
13384     }
13385   if (DECL_EXTERNAL (newdecl))
13386     {
13387       TREE_STATIC (newdecl) = TREE_STATIC (olddecl);
13388       DECL_EXTERNAL (newdecl) = DECL_EXTERNAL (olddecl);
13389       /* An extern decl does not override previous storage class.  */
13390       TREE_PUBLIC (newdecl) = TREE_PUBLIC (olddecl);
13391     }
13392   else
13393     {
13394       TREE_STATIC (olddecl) = TREE_STATIC (newdecl);
13395       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13396     }
13397
13398   /* If either decl says `inline', this fn is inline,
13399      unless its definition was passed already.  */
13400   if (DECL_INLINE (newdecl) && DECL_INITIAL (olddecl) == 0)
13401     DECL_INLINE (olddecl) = 1;
13402   DECL_INLINE (newdecl) = DECL_INLINE (olddecl);
13403
13404   /* Get rid of any built-in function if new arg types don't match it
13405      or if we have a function definition.  */
13406   if (TREE_CODE (newdecl) == FUNCTION_DECL
13407       && DECL_BUILT_IN (olddecl)
13408       && (!types_match || new_is_definition))
13409     {
13410       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13411       DECL_BUILT_IN_CLASS (olddecl) = NOT_BUILT_IN;
13412     }
13413
13414   /* If redeclaring a builtin function, and not a definition,
13415      it stays built in.
13416      Also preserve various other info from the definition.  */
13417   if (TREE_CODE (newdecl) == FUNCTION_DECL && !new_is_definition)
13418     {
13419       if (DECL_BUILT_IN (olddecl))
13420         {
13421           DECL_BUILT_IN_CLASS (newdecl) = DECL_BUILT_IN_CLASS (olddecl);
13422           DECL_FUNCTION_CODE (newdecl) = DECL_FUNCTION_CODE (olddecl);
13423         }
13424
13425       DECL_RESULT (newdecl) = DECL_RESULT (olddecl);
13426       DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13427       DECL_SAVED_INSNS (newdecl) = DECL_SAVED_INSNS (olddecl);
13428       DECL_ARGUMENTS (newdecl) = DECL_ARGUMENTS (olddecl);
13429     }
13430
13431   /* Copy most of the decl-specific fields of NEWDECL into OLDDECL.
13432      But preserve olddecl's DECL_UID.  */
13433   {
13434     register unsigned olddecl_uid = DECL_UID (olddecl);
13435
13436     memcpy ((char *) olddecl + sizeof (struct tree_common),
13437             (char *) newdecl + sizeof (struct tree_common),
13438             sizeof (struct tree_decl) - sizeof (struct tree_common));
13439     DECL_UID (olddecl) = olddecl_uid;
13440   }
13441
13442   return 1;
13443 }
13444
13445 /* Finish processing of a declaration;
13446    install its initial value.
13447    If the length of an array type is not known before,
13448    it must be determined now, from the initial value, or it is an error.  */
13449
13450 static void
13451 finish_decl (tree decl, tree init, bool is_top_level)
13452 {
13453   register tree type = TREE_TYPE (decl);
13454   int was_incomplete = (DECL_SIZE (decl) == 0);
13455   bool at_top_level = (current_binding_level == global_binding_level);
13456   bool top_level = is_top_level || at_top_level;
13457
13458   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13459      level anyway.  */
13460   assert (!is_top_level || !at_top_level);
13461
13462   if (TREE_CODE (decl) == PARM_DECL)
13463     assert (init == NULL_TREE);
13464   /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it
13465      overlaps DECL_ARG_TYPE.  */
13466   else if (init == NULL_TREE)
13467     assert (DECL_INITIAL (decl) == NULL_TREE);
13468   else
13469     assert (DECL_INITIAL (decl) == error_mark_node);
13470
13471   if (init != NULL_TREE)
13472     {
13473       if (TREE_CODE (decl) != TYPE_DECL)
13474         DECL_INITIAL (decl) = init;
13475       else
13476         {
13477           /* typedef foo = bar; store the type of bar as the type of foo.  */
13478           TREE_TYPE (decl) = TREE_TYPE (init);
13479           DECL_INITIAL (decl) = init = 0;
13480         }
13481     }
13482
13483   /* Deduce size of array from initialization, if not already known */
13484
13485   if (TREE_CODE (type) == ARRAY_TYPE
13486       && TYPE_DOMAIN (type) == 0
13487       && TREE_CODE (decl) != TYPE_DECL)
13488     {
13489       assert (top_level);
13490       assert (was_incomplete);
13491
13492       layout_decl (decl, 0);
13493     }
13494
13495   if (TREE_CODE (decl) == VAR_DECL)
13496     {
13497       if (DECL_SIZE (decl) == NULL_TREE
13498           && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
13499         layout_decl (decl, 0);
13500
13501       if (DECL_SIZE (decl) == NULL_TREE
13502           && (TREE_STATIC (decl)
13503               ?
13504       /* A static variable with an incomplete type is an error if it is
13505          initialized. Also if it is not file scope. Otherwise, let it
13506          through, but if it is not `extern' then it may cause an error
13507          message later.  */
13508               (DECL_INITIAL (decl) != 0 || DECL_CONTEXT (decl) != 0)
13509               :
13510       /* An automatic variable with an incomplete type is an error.  */
13511               !DECL_EXTERNAL (decl)))
13512         {
13513           assert ("storage size not known" == NULL);
13514           abort ();
13515         }
13516
13517       if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl))
13518           && (DECL_SIZE (decl) != 0)
13519           && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST))
13520         {
13521           assert ("storage size not constant" == NULL);
13522           abort ();
13523         }
13524     }
13525
13526   /* Output the assembler code and/or RTL code for variables and functions,
13527      unless the type is an undefined structure or union. If not, it will get
13528      done when the type is completed.  */
13529
13530   if (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == FUNCTION_DECL)
13531     {
13532       rest_of_decl_compilation (decl, NULL,
13533                                 DECL_CONTEXT (decl) == 0,
13534                                 0);
13535
13536       if (DECL_CONTEXT (decl) != 0)
13537         {
13538           /* Recompute the RTL of a local array now if it used to be an
13539              incomplete type.  */
13540           if (was_incomplete
13541               && !TREE_STATIC (decl) && !DECL_EXTERNAL (decl))
13542             {
13543               /* If we used it already as memory, it must stay in memory.  */
13544               TREE_ADDRESSABLE (decl) = TREE_USED (decl);
13545               /* If it's still incomplete now, no init will save it.  */
13546               if (DECL_SIZE (decl) == 0)
13547                 DECL_INITIAL (decl) = 0;
13548               expand_decl (decl);
13549             }
13550           /* Compute and store the initial value.  */
13551           if (TREE_CODE (decl) != FUNCTION_DECL)
13552             expand_decl_init (decl);
13553         }
13554     }
13555   else if (TREE_CODE (decl) == TYPE_DECL)
13556     {
13557       rest_of_decl_compilation (decl, NULL,
13558                                 DECL_CONTEXT (decl) == 0,
13559                                 0);
13560     }
13561
13562   /* At the end of a declaration, throw away any variable type sizes of types
13563      defined inside that declaration.  There is no use computing them in the
13564      following function definition.  */
13565   if (current_binding_level == global_binding_level)
13566     get_pending_sizes ();
13567 }
13568
13569 /* Finish up a function declaration and compile that function
13570    all the way to assembler language output.  The free the storage
13571    for the function definition.
13572
13573    This is called after parsing the body of the function definition.
13574
13575    NESTED is nonzero if the function being finished is nested in another.  */
13576
13577 static void
13578 finish_function (int nested)
13579 {
13580   register tree fndecl = current_function_decl;
13581
13582   assert (fndecl != NULL_TREE);
13583   if (TREE_CODE (fndecl) != ERROR_MARK)
13584     {
13585       if (nested)
13586         assert (DECL_CONTEXT (fndecl) != NULL_TREE);
13587       else
13588         assert (DECL_CONTEXT (fndecl) == NULL_TREE);
13589     }
13590
13591 /*  TREE_READONLY (fndecl) = 1;
13592     This caused &foo to be of type ptr-to-const-function
13593     which then got a warning when stored in a ptr-to-function variable.  */
13594
13595   poplevel (1, 0, 1);
13596
13597   if (TREE_CODE (fndecl) != ERROR_MARK)
13598     {
13599       BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
13600
13601       /* Must mark the RESULT_DECL as being in this function.  */
13602
13603       DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl;
13604
13605       /* Obey `register' declarations if `setjmp' is called in this fn.  */
13606       /* Generate rtl for function exit.  */
13607       expand_function_end (input_filename, input_line, 0);
13608
13609       /* If this is a nested function, protect the local variables in the stack
13610          above us from being collected while we're compiling this function.  */
13611       if (nested)
13612         ggc_push_context ();
13613
13614       /* Run the optimizers and output the assembler code for this function.  */
13615       rest_of_compilation (fndecl);
13616
13617       /* Undo the GC context switch.  */
13618       if (nested)
13619         ggc_pop_context ();
13620     }
13621
13622   if (TREE_CODE (fndecl) != ERROR_MARK
13623       && !nested
13624       && DECL_SAVED_INSNS (fndecl) == 0)
13625     {
13626       /* Stop pointing to the local nodes about to be freed.  */
13627       /* But DECL_INITIAL must remain nonzero so we know this was an actual
13628          function definition.  */
13629       /* For a nested function, this is done in pop_f_function_context.  */
13630       /* If rest_of_compilation set this to 0, leave it 0.  */
13631       if (DECL_INITIAL (fndecl) != 0)
13632         DECL_INITIAL (fndecl) = error_mark_node;
13633       DECL_ARGUMENTS (fndecl) = 0;
13634     }
13635
13636   if (!nested)
13637     {
13638       /* Let the error reporting routines know that we're outside a function.
13639          For a nested function, this value is used in pop_c_function_context
13640          and then reset via pop_function_context.  */
13641       ffecom_outer_function_decl_ = current_function_decl = NULL;
13642     }
13643 }
13644
13645 /* Plug-in replacement for identifying the name of a decl and, for a
13646    function, what we call it in diagnostics.  For now, "program unit"
13647    should suffice, since it's a bit of a hassle to figure out which
13648    of several kinds of things it is.  Note that it could conceivably
13649    be a statement function, which probably isn't really a program unit
13650    per se, but if that comes up, it should be easy to check (being a
13651    nested function and all).  */
13652
13653 static const char *
13654 ffe_printable_name (tree decl, int v)
13655 {
13656   /* Just to keep GCC quiet about the unused variable.
13657      In theory, differing values of V should produce different
13658      output.  */
13659   switch (v)
13660     {
13661     default:
13662       if (TREE_CODE (decl) == ERROR_MARK)
13663         return "erroneous code";
13664       return IDENTIFIER_POINTER (DECL_NAME (decl));
13665     }
13666 }
13667
13668 /* g77's function to print out name of current function that caused
13669    an error.  */
13670
13671 static void
13672 ffe_print_error_function (diagnostic_context *context __attribute__((unused)),
13673                           const char *file)
13674 {
13675   static ffeglobal last_g = NULL;
13676   static ffesymbol last_s = NULL;
13677   ffeglobal g;
13678   ffesymbol s;
13679   const char *kind;
13680
13681   if ((ffecom_primary_entry_ == NULL)
13682       || (ffesymbol_global (ffecom_primary_entry_) == NULL))
13683     {
13684       g = NULL;
13685       s = NULL;
13686       kind = NULL;
13687     }
13688   else
13689     {
13690       g = ffesymbol_global (ffecom_primary_entry_);
13691       if (ffecom_nested_entry_ == NULL)
13692         {
13693           s = ffecom_primary_entry_;
13694           kind = _(ffeinfo_kind_message (ffesymbol_kind (s)));
13695         }
13696       else
13697         {
13698           s = ffecom_nested_entry_;
13699           kind = _("In statement function");
13700         }
13701     }
13702
13703   if ((last_g != g) || (last_s != s))
13704     {
13705       if (file)
13706         fprintf (stderr, "%s: ", file);
13707
13708       if (s == NULL)
13709         fprintf (stderr, _("Outside of any program unit:\n"));
13710       else
13711         {
13712           const char *name = ffesymbol_text (s);
13713
13714           fprintf (stderr, "%s `%s':\n", kind, name);
13715         }
13716
13717       last_g = g;
13718       last_s = s;
13719     }
13720 }
13721
13722 /* Similar to `lookup_name' but look only at current binding level.  */
13723
13724 static tree
13725 lookup_name_current_level (tree name)
13726 {
13727   register tree t;
13728
13729   if (current_binding_level == global_binding_level)
13730     return IDENTIFIER_GLOBAL_VALUE (name);
13731
13732   if (IDENTIFIER_LOCAL_VALUE (name) == 0)
13733     return 0;
13734
13735   for (t = current_binding_level->names; t; t = TREE_CHAIN (t))
13736     if (DECL_NAME (t) == name)
13737       break;
13738
13739   return t;
13740 }
13741
13742 /* Create a new `struct f_binding_level'.  */
13743
13744 static struct f_binding_level *
13745 make_binding_level ()
13746 {
13747   /* NOSTRICT */
13748   return ggc_alloc (sizeof (struct f_binding_level));
13749 }
13750
13751 /* Save and restore the variables in this file and elsewhere
13752    that keep track of the progress of compilation of the current function.
13753    Used for nested functions.  */
13754
13755 struct f_function
13756 {
13757   struct f_function *next;
13758   tree named_labels;
13759   tree shadowed_labels;
13760   struct f_binding_level *binding_level;
13761 };
13762
13763 struct f_function *f_function_chain;
13764
13765 /* Restore the variables used during compilation of a C function.  */
13766
13767 static void
13768 pop_f_function_context ()
13769 {
13770   struct f_function *p = f_function_chain;
13771   tree link;
13772
13773   /* Bring back all the labels that were shadowed.  */
13774   for (link = shadowed_labels; link; link = TREE_CHAIN (link))
13775     if (DECL_NAME (TREE_VALUE (link)) != 0)
13776       IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link)))
13777         = TREE_VALUE (link);
13778
13779   if (current_function_decl != error_mark_node
13780       && DECL_SAVED_INSNS (current_function_decl) == 0)
13781     {
13782       /* Stop pointing to the local nodes about to be freed.  */
13783       /* But DECL_INITIAL must remain nonzero so we know this was an actual
13784          function definition.  */
13785       DECL_INITIAL (current_function_decl) = error_mark_node;
13786       DECL_ARGUMENTS (current_function_decl) = 0;
13787     }
13788
13789   pop_function_context ();
13790
13791   f_function_chain = p->next;
13792
13793   named_labels = p->named_labels;
13794   shadowed_labels = p->shadowed_labels;
13795   current_binding_level = p->binding_level;
13796
13797   free (p);
13798 }
13799
13800 /* Save and reinitialize the variables
13801    used during compilation of a C function.  */
13802
13803 static void
13804 push_f_function_context ()
13805 {
13806   struct f_function *p
13807   = (struct f_function *) xmalloc (sizeof (struct f_function));
13808
13809   push_function_context ();
13810
13811   p->next = f_function_chain;
13812   f_function_chain = p;
13813
13814   p->named_labels = named_labels;
13815   p->shadowed_labels = shadowed_labels;
13816   p->binding_level = current_binding_level;
13817 }
13818
13819 static void
13820 push_parm_decl (tree parm)
13821 {
13822   int old_immediate_size_expand = immediate_size_expand;
13823
13824   /* Don't try computing parm sizes now -- wait till fn is called.  */
13825
13826   immediate_size_expand = 0;
13827
13828   /* Fill in arg stuff.  */
13829
13830   DECL_ARG_TYPE (parm) = TREE_TYPE (parm);
13831   DECL_ARG_TYPE_AS_WRITTEN (parm) = TREE_TYPE (parm);
13832   TREE_READONLY (parm) = 1;     /* All implementation args are read-only. */
13833
13834   parm = pushdecl (parm);
13835
13836   immediate_size_expand = old_immediate_size_expand;
13837
13838   finish_decl (parm, NULL_TREE, FALSE);
13839 }
13840
13841 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate.  */
13842
13843 static tree
13844 pushdecl_top_level (tree x)
13845 {
13846   register tree t;
13847   register struct f_binding_level *b = current_binding_level;
13848   register tree f = current_function_decl;
13849
13850   current_binding_level = global_binding_level;
13851   current_function_decl = NULL_TREE;
13852   t = pushdecl (x);
13853   current_binding_level = b;
13854   current_function_decl = f;
13855   return t;
13856 }
13857
13858 /* Store the list of declarations of the current level.
13859    This is done for the parameter declarations of a function being defined,
13860    after they are modified in the light of any missing parameters.  */
13861
13862 static tree
13863 storedecls (tree decls)
13864 {
13865   return current_binding_level->names = decls;
13866 }
13867
13868 /* Store the parameter declarations into the current function declaration.
13869    This is called after parsing the parameter declarations, before
13870    digesting the body of the function.
13871
13872    For an old-style definition, modify the function's type
13873    to specify at least the number of arguments.  */
13874
13875 static void
13876 store_parm_decls (int is_main_program UNUSED)
13877 {
13878   register tree fndecl = current_function_decl;
13879
13880   if (fndecl == error_mark_node)
13881     return;
13882
13883   /* This is a chain of PARM_DECLs from old-style parm declarations.  */
13884   DECL_ARGUMENTS (fndecl) = storedecls (nreverse (getdecls ()));
13885
13886   /* Initialize the RTL code for the function.  */
13887
13888   init_function_start (fndecl, input_filename, input_line);
13889
13890   /* Set up parameters and prepare for return, for the function.  */
13891
13892   expand_function_start (fndecl, 0);
13893 }
13894
13895 static tree
13896 start_decl (tree decl, bool is_top_level)
13897 {
13898   register tree tem;
13899   bool at_top_level = (current_binding_level == global_binding_level);
13900   bool top_level = is_top_level || at_top_level;
13901
13902   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13903      level anyway.  */
13904   assert (!is_top_level || !at_top_level);
13905
13906   if (DECL_INITIAL (decl) != NULL_TREE)
13907     {
13908       assert (DECL_INITIAL (decl) == error_mark_node);
13909       assert (!DECL_EXTERNAL (decl));
13910     }
13911   else if (top_level)
13912     assert ((TREE_STATIC (decl) == 1) || DECL_EXTERNAL (decl) == 1);
13913
13914   /* For Fortran, we by default put things in .common when possible.  */
13915   DECL_COMMON (decl) = 1;
13916
13917   /* Add this decl to the current binding level. TEM may equal DECL or it may
13918      be a previous decl of the same name.  */
13919   if (is_top_level)
13920     tem = pushdecl_top_level (decl);
13921   else
13922     tem = pushdecl (decl);
13923
13924   /* For a local variable, define the RTL now.  */
13925   if (!top_level
13926   /* But not if this is a duplicate decl and we preserved the rtl from the
13927      previous one (which may or may not happen).  */
13928       && !DECL_RTL_SET_P (tem))
13929     {
13930       if (TYPE_SIZE (TREE_TYPE (tem)) != 0)
13931         expand_decl (tem);
13932       else if (TREE_CODE (TREE_TYPE (tem)) == ARRAY_TYPE
13933                && DECL_INITIAL (tem) != 0)
13934         expand_decl (tem);
13935     }
13936
13937   return tem;
13938 }
13939
13940 /* Create the FUNCTION_DECL for a function definition.
13941    DECLSPECS and DECLARATOR are the parts of the declaration;
13942    they describe the function's name and the type it returns,
13943    but twisted together in a fashion that parallels the syntax of C.
13944
13945    This function creates a binding context for the function body
13946    as well as setting up the FUNCTION_DECL in current_function_decl.
13947
13948    Returns 1 on success.  If the DECLARATOR is not suitable for a function
13949    (it defines a datum instead), we return 0, which tells
13950    ffe_parse_file to report a parse error.
13951
13952    NESTED is nonzero for a function nested within another function.  */
13953
13954 static void
13955 start_function (tree name, tree type, int nested, int public)
13956 {
13957   tree decl1;
13958   tree restype;
13959   int old_immediate_size_expand = immediate_size_expand;
13960
13961   named_labels = 0;
13962   shadowed_labels = 0;
13963
13964   /* Don't expand any sizes in the return type of the function.  */
13965   immediate_size_expand = 0;
13966
13967   if (nested)
13968     {
13969       assert (!public);
13970       assert (current_function_decl != NULL_TREE);
13971       assert (DECL_CONTEXT (current_function_decl) == NULL_TREE);
13972     }
13973   else
13974     {
13975       assert (current_function_decl == NULL_TREE);
13976     }
13977
13978   if (TREE_CODE (type) == ERROR_MARK)
13979     decl1 = current_function_decl = error_mark_node;
13980   else
13981     {
13982       decl1 = build_decl (FUNCTION_DECL,
13983                           name,
13984                           type);
13985       TREE_PUBLIC (decl1) = public ? 1 : 0;
13986       if (nested)
13987         DECL_INLINE (decl1) = 1;
13988       TREE_STATIC (decl1) = 1;
13989       DECL_EXTERNAL (decl1) = 0;
13990
13991       announce_function (decl1);
13992
13993       /* Make the init_value nonzero so pushdecl knows this is not tentative.
13994          error_mark_node is replaced below (in poplevel) with the BLOCK.  */
13995       DECL_INITIAL (decl1) = error_mark_node;
13996
13997       /* Record the decl so that the function name is defined. If we already have
13998          a decl for this name, and it is a FUNCTION_DECL, use the old decl.  */
13999
14000       current_function_decl = pushdecl (decl1);
14001     }
14002
14003   if (!nested)
14004     ffecom_outer_function_decl_ = current_function_decl;
14005
14006   pushlevel (0);
14007   current_binding_level->prep_state = 2;
14008
14009   if (TREE_CODE (current_function_decl) != ERROR_MARK)
14010     {
14011       make_decl_rtl (current_function_decl, NULL);
14012
14013       restype = TREE_TYPE (TREE_TYPE (current_function_decl));
14014       DECL_RESULT (current_function_decl)
14015         = build_decl (RESULT_DECL, NULL_TREE, restype);
14016     }
14017
14018   if (!nested && (TREE_CODE (current_function_decl) != ERROR_MARK))
14019     TREE_ADDRESSABLE (current_function_decl) = 1;
14020
14021   immediate_size_expand = old_immediate_size_expand;
14022 }
14023 \f
14024 /* Here are the public functions the GNU back end needs.  */
14025
14026 tree
14027 convert (tree type, tree expr)
14028 {
14029   register tree e = expr;
14030   register enum tree_code code = TREE_CODE (type);
14031
14032   if (type == TREE_TYPE (e)
14033       || TREE_CODE (e) == ERROR_MARK)
14034     return e;
14035   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
14036     return fold (build1 (NOP_EXPR, type, e));
14037   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
14038       || code == ERROR_MARK)
14039     return error_mark_node;
14040   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
14041     {
14042       assert ("void value not ignored as it ought to be" == NULL);
14043       return error_mark_node;
14044     }
14045   if (code == VOID_TYPE)
14046     return build1 (CONVERT_EXPR, type, e);
14047   if ((code != RECORD_TYPE)
14048       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
14049     e = ffecom_1 (REALPART_EXPR, TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e))),
14050                   e);
14051   if (code == INTEGER_TYPE || code == ENUMERAL_TYPE)
14052     return fold (convert_to_integer (type, e));
14053   if (code == POINTER_TYPE)
14054     return fold (convert_to_pointer (type, e));
14055   if (code == REAL_TYPE)
14056     return fold (convert_to_real (type, e));
14057   if (code == COMPLEX_TYPE)
14058     return fold (convert_to_complex (type, e));
14059   if (code == RECORD_TYPE)
14060     return fold (ffecom_convert_to_complex_ (type, e));
14061
14062   assert ("conversion to non-scalar type requested" == NULL);
14063   return error_mark_node;
14064 }
14065
14066 /* Return the list of declarations of the current level.
14067    Note that this list is in reverse order unless/until
14068    you nreverse it; and when you do nreverse it, you must
14069    store the result back using `storedecls' or you will lose.  */
14070
14071 tree
14072 getdecls ()
14073 {
14074   return current_binding_level->names;
14075 }
14076
14077 /* Nonzero if we are currently in the global binding level.  */
14078
14079 int
14080 global_bindings_p ()
14081 {
14082   return current_binding_level == global_binding_level;
14083 }
14084
14085 static void
14086 ffecom_init_decl_processing ()
14087 {
14088   malloc_init ();
14089
14090   ffe_init_0 ();
14091 }
14092
14093 /* Delete the node BLOCK from the current binding level.
14094    This is used for the block inside a stmt expr ({...})
14095    so that the block can be reinserted where appropriate.  */
14096
14097 static void
14098 delete_block (tree block)
14099 {
14100   tree t;
14101   if (current_binding_level->blocks == block)
14102     current_binding_level->blocks = TREE_CHAIN (block);
14103   for (t = current_binding_level->blocks; t;)
14104     {
14105       if (TREE_CHAIN (t) == block)
14106         TREE_CHAIN (t) = TREE_CHAIN (block);
14107       else
14108         t = TREE_CHAIN (t);
14109     }
14110   TREE_CHAIN (block) = NULL;
14111   /* Clear TREE_USED which is always set by poplevel.
14112      The flag is set again if insert_block is called.  */
14113   TREE_USED (block) = 0;
14114 }
14115
14116 void
14117 insert_block (tree block)
14118 {
14119   TREE_USED (block) = 1;
14120   current_binding_level->blocks
14121     = chainon (current_binding_level->blocks, block);
14122 }
14123
14124 /* Each front end provides its own.  */
14125 static bool ffe_init PARAMS ((void));
14126 static void ffe_finish PARAMS ((void));
14127 static bool ffe_post_options PARAMS ((const char **));
14128 static int ffe_init_options PARAMS ((void));
14129 static void ffe_print_identifier PARAMS ((FILE *, tree, int));
14130
14131 struct language_function GTY(())
14132 {
14133   int unused;
14134 };
14135
14136 #undef  LANG_HOOKS_NAME
14137 #define LANG_HOOKS_NAME                 "GNU F77"
14138 #undef  LANG_HOOKS_INIT
14139 #define LANG_HOOKS_INIT                 ffe_init
14140 #undef  LANG_HOOKS_FINISH
14141 #define LANG_HOOKS_FINISH               ffe_finish
14142 #undef  LANG_HOOKS_INIT_OPTIONS
14143 #define LANG_HOOKS_INIT_OPTIONS         ffe_init_options
14144 #undef  LANG_HOOKS_HANDLE_OPTION
14145 #define LANG_HOOKS_HANDLE_OPTION        ffe_handle_option
14146 #undef  LANG_HOOKS_POST_OPTIONS
14147 #define LANG_HOOKS_POST_OPTIONS         ffe_post_options
14148 #undef  LANG_HOOKS_PARSE_FILE
14149 #define LANG_HOOKS_PARSE_FILE           ffe_parse_file
14150 #undef  LANG_HOOKS_MARK_ADDRESSABLE
14151 #define LANG_HOOKS_MARK_ADDRESSABLE     ffe_mark_addressable
14152 #undef  LANG_HOOKS_PRINT_IDENTIFIER
14153 #define LANG_HOOKS_PRINT_IDENTIFIER     ffe_print_identifier
14154 #undef  LANG_HOOKS_DECL_PRINTABLE_NAME
14155 #define LANG_HOOKS_DECL_PRINTABLE_NAME  ffe_printable_name
14156 #undef  LANG_HOOKS_PRINT_ERROR_FUNCTION
14157 #define LANG_HOOKS_PRINT_ERROR_FUNCTION ffe_print_error_function
14158 #undef  LANG_HOOKS_TRUTHVALUE_CONVERSION
14159 #define LANG_HOOKS_TRUTHVALUE_CONVERSION ffe_truthvalue_conversion
14160
14161 #undef  LANG_HOOKS_TYPE_FOR_MODE
14162 #define LANG_HOOKS_TYPE_FOR_MODE        ffe_type_for_mode
14163 #undef  LANG_HOOKS_TYPE_FOR_SIZE
14164 #define LANG_HOOKS_TYPE_FOR_SIZE        ffe_type_for_size
14165 #undef  LANG_HOOKS_SIGNED_TYPE
14166 #define LANG_HOOKS_SIGNED_TYPE          ffe_signed_type
14167 #undef  LANG_HOOKS_UNSIGNED_TYPE
14168 #define LANG_HOOKS_UNSIGNED_TYPE        ffe_unsigned_type
14169 #undef  LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE
14170 #define LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE ffe_signed_or_unsigned_type
14171
14172 /* We do not wish to use alias-set based aliasing at all.  Used in the
14173    extreme (every object with its own set, with equivalences recorded) it
14174    might be helpful, but there are problems when it comes to inlining.  We
14175    get on ok with flag_argument_noalias, and alias-set aliasing does
14176    currently limit how stack slots can be reused, which is a lose.  */
14177 #undef LANG_HOOKS_GET_ALIAS_SET
14178 #define LANG_HOOKS_GET_ALIAS_SET hook_get_alias_set_0
14179
14180 const struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER;
14181
14182 /* Table indexed by tree code giving a string containing a character
14183    classifying the tree code.  Possibilities are
14184    t, d, s, c, r, <, 1, 2 and e.  See tree.def for details.  */
14185
14186 #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) TYPE,
14187
14188 const char tree_code_type[] = {
14189 #include "tree.def"
14190 };
14191 #undef DEFTREECODE
14192
14193 /* Table indexed by tree code giving number of expression
14194    operands beyond the fixed part of the node structure.
14195    Not used for types or decls.  */
14196
14197 #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) LENGTH,
14198
14199 const unsigned char tree_code_length[] = {
14200 #include "tree.def"
14201 };
14202 #undef DEFTREECODE
14203
14204 /* Names of tree components.
14205    Used for printing out the tree and error messages.  */
14206 #define DEFTREECODE(SYM, NAME, TYPE, LEN) NAME,
14207
14208 const char *const tree_code_name[] = {
14209 #include "tree.def"
14210 };
14211 #undef DEFTREECODE
14212
14213 static bool
14214 ffe_post_options (pfilename)
14215      const char **pfilename;
14216 {
14217   const char *filename = *pfilename;
14218
14219   /* Open input file.  */
14220   if (filename == 0 || !strcmp (filename, "-"))
14221     {
14222       finput = stdin;
14223       filename = "stdin";
14224     }
14225   else
14226     finput = fopen (filename, "r");
14227
14228   if (finput == 0)
14229     fatal_error ("can't open %s: %m", filename);
14230
14231   return false;
14232 }
14233
14234
14235 static bool
14236 ffe_init ()
14237 {
14238 #ifdef IO_BUFFER_SIZE
14239   setvbuf (finput, (char *) xmalloc (IO_BUFFER_SIZE), _IOFBF, IO_BUFFER_SIZE);
14240 #endif
14241
14242   ffecom_init_decl_processing ();
14243
14244   /* If the file is output from cpp, it should contain a first line
14245      `# 1 "real-filename"', and the current design of gcc (toplev.c
14246      in particular and the way it sets up information relied on by
14247      INCLUDE) requires that we read this now, and store the
14248      "real-filename" info in master_input_filename.  Ask the lexer
14249      to try doing this.  */
14250   ffelex_hash_kludge (finput);
14251
14252   /* FIXME: The ffelex_hash_kludge code needs to be cleaned up to
14253      set the new file name.  Maybe in ffe_post_options.  */
14254   return true;
14255 }
14256
14257 static void
14258 ffe_finish ()
14259 {
14260   ffe_terminate_0 ();
14261
14262   if (ffe_is_ffedebug ())
14263     malloc_pool_display (malloc_pool_image ());
14264
14265   fclose (finput);
14266 }
14267
14268 static int
14269 ffe_init_options ()
14270 {
14271   /* Set default options for Fortran.  */
14272   flag_move_all_movables = 1;
14273   flag_reduce_all_givs = 1;
14274   flag_argument_noalias = 2;
14275   flag_merge_constants = 2;
14276   flag_errno_math = 0;
14277   flag_complex_divide_method = 1;
14278
14279   return 0;
14280 }
14281
14282 static bool
14283 ffe_mark_addressable (tree exp)
14284 {
14285   register tree x = exp;
14286   while (1)
14287     switch (TREE_CODE (x))
14288       {
14289       case ADDR_EXPR:
14290       case COMPONENT_REF:
14291       case ARRAY_REF:
14292         x = TREE_OPERAND (x, 0);
14293         break;
14294
14295       case CONSTRUCTOR:
14296         TREE_ADDRESSABLE (x) = 1;
14297         return true;
14298
14299       case VAR_DECL:
14300       case CONST_DECL:
14301       case PARM_DECL:
14302       case RESULT_DECL:
14303         if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x)
14304             && DECL_NONLOCAL (x))
14305           {
14306             if (TREE_PUBLIC (x))
14307               {
14308                 assert ("address of global register var requested" == NULL);
14309                 return false;
14310               }
14311             assert ("address of register variable requested" == NULL);
14312           }
14313         else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x))
14314           {
14315             if (TREE_PUBLIC (x))
14316               {
14317                 assert ("address of global register var requested" == NULL);
14318                 return false;
14319               }
14320             assert ("address of register var requested" == NULL);
14321           }
14322         put_var_into_stack (x, /*rescan=*/true);
14323
14324         /* drops in */
14325       case FUNCTION_DECL:
14326         TREE_ADDRESSABLE (x) = 1;
14327 #if 0                           /* poplevel deals with this now.  */
14328         if (DECL_CONTEXT (x) == 0)
14329           TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x)) = 1;
14330 #endif
14331
14332       default:
14333         return true;
14334       }
14335 }
14336
14337 /* Exit a binding level.
14338    Pop the level off, and restore the state of the identifier-decl mappings
14339    that were in effect when this level was entered.
14340
14341    If KEEP is nonzero, this level had explicit declarations, so
14342    and create a "block" (a BLOCK node) for the level
14343    to record its declarations and subblocks for symbol table output.
14344
14345    If FUNCTIONBODY is nonzero, this level is the body of a function,
14346    so create a block as if KEEP were set and also clear out all
14347    label names.
14348
14349    If REVERSE is nonzero, reverse the order of decls before putting
14350    them into the BLOCK.  */
14351
14352 tree
14353 poplevel (int keep, int reverse, int functionbody)
14354 {
14355   register tree link;
14356   /* The chain of decls was accumulated in reverse order.
14357      Put it into forward order, just for cleanliness.  */
14358   tree decls;
14359   tree subblocks = current_binding_level->blocks;
14360   tree block = 0;
14361   tree decl;
14362   int block_previously_created;
14363
14364   /* Get the decls in the order they were written.
14365      Usually current_binding_level->names is in reverse order.
14366      But parameter decls were previously put in forward order.  */
14367
14368   if (reverse)
14369     current_binding_level->names
14370       = decls = nreverse (current_binding_level->names);
14371   else
14372     decls = current_binding_level->names;
14373
14374   /* Output any nested inline functions within this block
14375      if they weren't already output.  */
14376
14377   for (decl = decls; decl; decl = TREE_CHAIN (decl))
14378     if (TREE_CODE (decl) == FUNCTION_DECL
14379         && ! TREE_ASM_WRITTEN (decl)
14380         && DECL_INITIAL (decl) != 0
14381         && TREE_ADDRESSABLE (decl))
14382       {
14383         /* If this decl was copied from a file-scope decl
14384            on account of a block-scope extern decl,
14385            propagate TREE_ADDRESSABLE to the file-scope decl.
14386
14387            DECL_ABSTRACT_ORIGIN can be set to itself if warn_return_type is
14388            true, since then the decl goes through save_for_inline_copying.  */
14389         if (DECL_ABSTRACT_ORIGIN (decl) != 0
14390             && DECL_ABSTRACT_ORIGIN (decl) != decl)
14391           TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl)) = 1;
14392         else if (DECL_SAVED_INSNS (decl) != 0)
14393           {
14394             push_function_context ();
14395             output_inline_function (decl);
14396             pop_function_context ();
14397           }
14398       }
14399
14400   /* If there were any declarations or structure tags in that level,
14401      or if this level is a function body,
14402      create a BLOCK to record them for the life of this function.  */
14403
14404   block = 0;
14405   block_previously_created = (current_binding_level->this_block != 0);
14406   if (block_previously_created)
14407     block = current_binding_level->this_block;
14408   else if (keep || functionbody)
14409     block = make_node (BLOCK);
14410   if (block != 0)
14411     {
14412       BLOCK_VARS (block) = decls;
14413       BLOCK_SUBBLOCKS (block) = subblocks;
14414     }
14415
14416   /* In each subblock, record that this is its superior.  */
14417
14418   for (link = subblocks; link; link = TREE_CHAIN (link))
14419     BLOCK_SUPERCONTEXT (link) = block;
14420
14421   /* Clear out the meanings of the local variables of this level.  */
14422
14423   for (link = decls; link; link = TREE_CHAIN (link))
14424     {
14425       if (DECL_NAME (link) != 0)
14426         {
14427           /* If the ident. was used or addressed via a local extern decl,
14428              don't forget that fact.  */
14429           if (DECL_EXTERNAL (link))
14430             {
14431               if (TREE_USED (link))
14432                 TREE_USED (DECL_NAME (link)) = 1;
14433               if (TREE_ADDRESSABLE (link))
14434                 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (link)) = 1;
14435             }
14436           IDENTIFIER_LOCAL_VALUE (DECL_NAME (link)) = 0;
14437         }
14438     }
14439
14440   /* If the level being exited is the top level of a function,
14441      check over all the labels, and clear out the current
14442      (function local) meanings of their names.  */
14443
14444   if (functionbody)
14445     {
14446       /* If this is the top level block of a function,
14447          the vars are the function's parameters.
14448          Don't leave them in the BLOCK because they are
14449          found in the FUNCTION_DECL instead.  */
14450
14451       BLOCK_VARS (block) = 0;
14452     }
14453
14454   /* Pop the current level, and free the structure for reuse.  */
14455
14456   {
14457     register struct f_binding_level *level = current_binding_level;
14458     current_binding_level = current_binding_level->level_chain;
14459
14460     level->level_chain = free_binding_level;
14461     free_binding_level = level;
14462   }
14463
14464   /* Dispose of the block that we just made inside some higher level.  */
14465   if (functionbody
14466       && current_function_decl != error_mark_node)
14467     DECL_INITIAL (current_function_decl) = block;
14468   else if (block)
14469     {
14470       if (!block_previously_created)
14471         current_binding_level->blocks
14472           = chainon (current_binding_level->blocks, block);
14473     }
14474   /* If we did not make a block for the level just exited,
14475      any blocks made for inner levels
14476      (since they cannot be recorded as subblocks in that level)
14477      must be carried forward so they will later become subblocks
14478      of something else.  */
14479   else if (subblocks)
14480     current_binding_level->blocks
14481       = chainon (current_binding_level->blocks, subblocks);
14482
14483   if (block)
14484     TREE_USED (block) = 1;
14485   return block;
14486 }
14487
14488 static void
14489 ffe_print_identifier (FILE *file, tree node, int indent)
14490 {
14491   print_node (file, "global", IDENTIFIER_GLOBAL_VALUE (node), indent + 4);
14492   print_node (file, "local", IDENTIFIER_LOCAL_VALUE (node), indent + 4);
14493 }
14494
14495 /* Record a decl-node X as belonging to the current lexical scope.
14496    Check for errors (such as an incompatible declaration for the same
14497    name already seen in the same scope).
14498
14499    Returns either X or an old decl for the same name.
14500    If an old decl is returned, it may have been smashed
14501    to agree with what X says.  */
14502
14503 tree
14504 pushdecl (tree x)
14505 {
14506   register tree t;
14507   register tree name = DECL_NAME (x);
14508   register struct f_binding_level *b = current_binding_level;
14509
14510   if ((TREE_CODE (x) == FUNCTION_DECL)
14511       && (DECL_INITIAL (x) == 0)
14512       && DECL_EXTERNAL (x))
14513     DECL_CONTEXT (x) = NULL_TREE;
14514   else
14515     DECL_CONTEXT (x) = current_function_decl;
14516
14517   if (name)
14518     {
14519       if (IDENTIFIER_INVENTED (name))
14520         {
14521           DECL_ARTIFICIAL (x) = 1;
14522           DECL_IN_SYSTEM_HEADER (x) = 1;
14523         }
14524
14525       t = lookup_name_current_level (name);
14526
14527       assert ((t == NULL_TREE) || (DECL_CONTEXT (x) == NULL_TREE));
14528
14529       /* Don't push non-parms onto list for parms until we understand
14530          why we're doing this and whether it works.  */
14531
14532       assert ((b == global_binding_level)
14533               || !ffecom_transform_only_dummies_
14534               || TREE_CODE (x) == PARM_DECL);
14535
14536       if ((t != NULL_TREE) && duplicate_decls (x, t))
14537         return t;
14538
14539       /* If we are processing a typedef statement, generate a whole new
14540          ..._TYPE node (which will be just an variant of the existing
14541          ..._TYPE node with identical properties) and then install the
14542          TYPE_DECL node generated to represent the typedef name as the
14543          TYPE_NAME of this brand new (duplicate) ..._TYPE node.
14544
14545          The whole point here is to end up with a situation where each and every
14546          ..._TYPE node the compiler creates will be uniquely associated with
14547          AT MOST one node representing a typedef name. This way, even though
14548          the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL
14549          (i.e. "typedef name") nodes very early on, later parts of the
14550          compiler can always do the reverse translation and get back the
14551          corresponding typedef name.  For example, given:
14552
14553          typedef struct S MY_TYPE; MY_TYPE object;
14554
14555          Later parts of the compiler might only know that `object' was of type
14556          `struct S' if it were not for code just below.  With this code
14557          however, later parts of the compiler see something like:
14558
14559          struct S' == struct S typedef struct S' MY_TYPE; struct S' object;
14560
14561          And they can then deduce (from the node for type struct S') that the
14562          original object declaration was:
14563
14564          MY_TYPE object;
14565
14566          Being able to do this is important for proper support of protoize, and
14567          also for generating precise symbolic debugging information which
14568          takes full account of the programmer's (typedef) vocabulary.
14569
14570          Obviously, we don't want to generate a duplicate ..._TYPE node if the
14571          TYPE_DECL node that we are now processing really represents a
14572          standard built-in type.
14573
14574          Since all standard types are effectively declared at line zero in the
14575          source file, we can easily check to see if we are working on a
14576          standard type by checking the current value of lineno.  */
14577
14578       if (TREE_CODE (x) == TYPE_DECL)
14579         {
14580           if (DECL_SOURCE_LINE (x) == 0)
14581             {
14582               if (TYPE_NAME (TREE_TYPE (x)) == 0)
14583                 TYPE_NAME (TREE_TYPE (x)) = x;
14584             }
14585           else if (TREE_TYPE (x) != error_mark_node)
14586             {
14587               tree tt = TREE_TYPE (x);
14588
14589               tt = build_type_copy (tt);
14590               TYPE_NAME (tt) = x;
14591               TREE_TYPE (x) = tt;
14592             }
14593         }
14594
14595       /* This name is new in its binding level. Install the new declaration
14596          and return it.  */
14597       if (b == global_binding_level)
14598         IDENTIFIER_GLOBAL_VALUE (name) = x;
14599       else
14600         IDENTIFIER_LOCAL_VALUE (name) = x;
14601     }
14602
14603   /* Put decls on list in reverse order. We will reverse them later if
14604      necessary.  */
14605   TREE_CHAIN (x) = b->names;
14606   b->names = x;
14607
14608   return x;
14609 }
14610
14611 /* Nonzero if the current level needs to have a BLOCK made.  */
14612
14613 static int
14614 kept_level_p ()
14615 {
14616   tree decl;
14617
14618   for (decl = current_binding_level->names;
14619        decl;
14620        decl = TREE_CHAIN (decl))
14621     {
14622       if (TREE_USED (decl) || TREE_CODE (decl) != VAR_DECL
14623           || (DECL_NAME (decl) && ! DECL_ARTIFICIAL (decl)))
14624         /* Currently, there aren't supposed to be non-artificial names
14625            at other than the top block for a function -- they're
14626            believed to always be temps.  But it's wise to check anyway.  */
14627         return 1;
14628     }
14629   return 0;
14630 }
14631
14632 /* Enter a new binding level.
14633    If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
14634    not for that of tags.  */
14635
14636 void
14637 pushlevel (int tag_transparent)
14638 {
14639   register struct f_binding_level *newlevel = NULL_BINDING_LEVEL;
14640
14641   assert (! tag_transparent);
14642
14643   if (current_binding_level == global_binding_level)
14644     {
14645       named_labels = 0;
14646     }
14647
14648   /* Reuse or create a struct for this binding level.  */
14649
14650   if (free_binding_level)
14651     {
14652       newlevel = free_binding_level;
14653       free_binding_level = free_binding_level->level_chain;
14654     }
14655   else
14656     {
14657       newlevel = make_binding_level ();
14658     }
14659
14660   /* Add this level to the front of the chain (stack) of levels that
14661      are active.  */
14662
14663   *newlevel = clear_binding_level;
14664   newlevel->level_chain = current_binding_level;
14665   current_binding_level = newlevel;
14666 }
14667
14668 /* Set the BLOCK node for the innermost scope
14669    (the one we are currently in).  */
14670
14671 void
14672 set_block (tree block)
14673 {
14674   current_binding_level->this_block = block;
14675   current_binding_level->names = chainon (current_binding_level->names,
14676                                           BLOCK_VARS (block));
14677   current_binding_level->blocks = chainon (current_binding_level->blocks,
14678                                            BLOCK_SUBBLOCKS (block));
14679 }
14680
14681 static tree
14682 ffe_signed_or_unsigned_type (int unsignedp, tree type)
14683 {
14684   tree type2;
14685
14686   if (! INTEGRAL_TYPE_P (type))
14687     return type;
14688   if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node))
14689     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
14690   if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node))
14691     return unsignedp ? unsigned_type_node : integer_type_node;
14692   if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node))
14693     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
14694   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node))
14695     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
14696   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node))
14697     return (unsignedp ? long_long_unsigned_type_node
14698             : long_long_integer_type_node);
14699
14700   type2 = ffe_type_for_size (TYPE_PRECISION (type), unsignedp);
14701   if (type2 == NULL_TREE)
14702     return type;
14703
14704   return type2;
14705 }
14706
14707 static tree
14708 ffe_signed_type (tree type)
14709 {
14710   tree type1 = TYPE_MAIN_VARIANT (type);
14711   ffeinfoKindtype kt;
14712   tree type2;
14713
14714   if (type1 == unsigned_char_type_node || type1 == char_type_node)
14715     return signed_char_type_node;
14716   if (type1 == unsigned_type_node)
14717     return integer_type_node;
14718   if (type1 == short_unsigned_type_node)
14719     return short_integer_type_node;
14720   if (type1 == long_unsigned_type_node)
14721     return long_integer_type_node;
14722   if (type1 == long_long_unsigned_type_node)
14723     return long_long_integer_type_node;
14724 #if 0   /* gcc/c-* files only */
14725   if (type1 == unsigned_intDI_type_node)
14726     return intDI_type_node;
14727   if (type1 == unsigned_intSI_type_node)
14728     return intSI_type_node;
14729   if (type1 == unsigned_intHI_type_node)
14730     return intHI_type_node;
14731   if (type1 == unsigned_intQI_type_node)
14732     return intQI_type_node;
14733 #endif
14734
14735   type2 = ffe_type_for_size (TYPE_PRECISION (type1), 0);
14736   if (type2 != NULL_TREE)
14737     return type2;
14738
14739   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
14740     {
14741       type2 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
14742
14743       if (type1 == type2)
14744         return ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
14745     }
14746
14747   return type;
14748 }
14749
14750 /* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
14751    or validate its data type for an `if' or `while' statement or ?..: exp.
14752
14753    This preparation consists of taking the ordinary
14754    representation of an expression expr and producing a valid tree
14755    boolean expression describing whether expr is nonzero.  We could
14756    simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
14757    but we optimize comparisons, &&, ||, and !.
14758
14759    The resulting type should always be `integer_type_node'.  */
14760
14761 static tree
14762 ffe_truthvalue_conversion (tree expr)
14763 {
14764   if (TREE_CODE (expr) == ERROR_MARK)
14765     return expr;
14766
14767 #if 0 /* This appears to be wrong for C++.  */
14768   /* These really should return error_mark_node after 2.4 is stable.
14769      But not all callers handle ERROR_MARK properly.  */
14770   switch (TREE_CODE (TREE_TYPE (expr)))
14771     {
14772     case RECORD_TYPE:
14773       error ("struct type value used where scalar is required");
14774       return integer_zero_node;
14775
14776     case UNION_TYPE:
14777       error ("union type value used where scalar is required");
14778       return integer_zero_node;
14779
14780     case ARRAY_TYPE:
14781       error ("array type value used where scalar is required");
14782       return integer_zero_node;
14783
14784     default:
14785       break;
14786     }
14787 #endif /* 0 */
14788
14789   switch (TREE_CODE (expr))
14790     {
14791       /* It is simpler and generates better code to have only TRUTH_*_EXPR
14792          or comparison expressions as truth values at this level.  */
14793 #if 0
14794     case COMPONENT_REF:
14795       /* A one-bit unsigned bit-field is already acceptable.  */
14796       if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr, 1)))
14797           && TREE_UNSIGNED (TREE_OPERAND (expr, 1)))
14798         return expr;
14799       break;
14800 #endif
14801
14802     case EQ_EXPR:
14803       /* It is simpler and generates better code to have only TRUTH_*_EXPR
14804          or comparison expressions as truth values at this level.  */
14805 #if 0
14806       if (integer_zerop (TREE_OPERAND (expr, 1)))
14807         return build_unary_op (TRUTH_NOT_EXPR, TREE_OPERAND (expr, 0), 0);
14808 #endif
14809     case NE_EXPR: case LE_EXPR: case GE_EXPR: case LT_EXPR: case GT_EXPR:
14810     case TRUTH_ANDIF_EXPR:
14811     case TRUTH_ORIF_EXPR:
14812     case TRUTH_AND_EXPR:
14813     case TRUTH_OR_EXPR:
14814     case TRUTH_XOR_EXPR:
14815       TREE_TYPE (expr) = integer_type_node;
14816       return expr;
14817
14818     case ERROR_MARK:
14819       return expr;
14820
14821     case INTEGER_CST:
14822       return integer_zerop (expr) ? integer_zero_node : integer_one_node;
14823
14824     case REAL_CST:
14825       return real_zerop (expr) ? integer_zero_node : integer_one_node;
14826
14827     case ADDR_EXPR:
14828       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 0)))
14829         return build (COMPOUND_EXPR, integer_type_node,
14830                       TREE_OPERAND (expr, 0), integer_one_node);
14831       else
14832         return integer_one_node;
14833
14834     case COMPLEX_EXPR:
14835       return ffecom_2 ((TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1))
14836                         ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
14837                        integer_type_node,
14838                        ffe_truthvalue_conversion (TREE_OPERAND (expr, 0)),
14839                        ffe_truthvalue_conversion (TREE_OPERAND (expr, 1)));
14840
14841     case NEGATE_EXPR:
14842     case ABS_EXPR:
14843     case FLOAT_EXPR:
14844     case FFS_EXPR:
14845       /* These don't change whether an object is nonzero or zero.  */
14846       return ffe_truthvalue_conversion (TREE_OPERAND (expr, 0));
14847
14848     case LROTATE_EXPR:
14849     case RROTATE_EXPR:
14850       /* These don't change whether an object is zero or nonzero, but
14851          we can't ignore them if their second arg has side-effects.  */
14852       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1)))
14853         return build (COMPOUND_EXPR, integer_type_node, TREE_OPERAND (expr, 1),
14854                       ffe_truthvalue_conversion (TREE_OPERAND (expr, 0)));
14855       else
14856         return ffe_truthvalue_conversion (TREE_OPERAND (expr, 0));
14857
14858     case COND_EXPR:
14859       {
14860         /* Distribute the conversion into the arms of a COND_EXPR.  */
14861         tree arg1 = TREE_OPERAND (expr, 1);
14862         tree arg2 = TREE_OPERAND (expr, 2);
14863         if (! VOID_TYPE_P (TREE_TYPE (arg1)))
14864           arg1 = ffe_truthvalue_conversion (arg1);
14865         if (! VOID_TYPE_P (TREE_TYPE (arg2)))
14866           arg2 = ffe_truthvalue_conversion (arg2);
14867         return fold (build (COND_EXPR, integer_type_node,
14868                             TREE_OPERAND (expr, 0), arg1, arg2));
14869       }
14870
14871     case CONVERT_EXPR:
14872       /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
14873          since that affects how `default_conversion' will behave.  */
14874       if (TREE_CODE (TREE_TYPE (expr)) == REFERENCE_TYPE
14875           || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) == REFERENCE_TYPE)
14876         break;
14877       /* fall through... */
14878     case NOP_EXPR:
14879       /* If this is widening the argument, we can ignore it.  */
14880       if (TYPE_PRECISION (TREE_TYPE (expr))
14881           >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr, 0))))
14882         return ffe_truthvalue_conversion (TREE_OPERAND (expr, 0));
14883       break;
14884
14885     case MINUS_EXPR:
14886       /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize
14887          this case.  */
14888       if (TARGET_FLOAT_FORMAT == IEEE_FLOAT_FORMAT
14889           && TREE_CODE (TREE_TYPE (expr)) == REAL_TYPE)
14890         break;
14891       /* fall through... */
14892     case BIT_XOR_EXPR:
14893       /* This and MINUS_EXPR can be changed into a comparison of the
14894          two objects.  */
14895       if (TREE_TYPE (TREE_OPERAND (expr, 0))
14896           == TREE_TYPE (TREE_OPERAND (expr, 1)))
14897         return ffecom_2 (NE_EXPR, integer_type_node,
14898                          TREE_OPERAND (expr, 0),
14899                          TREE_OPERAND (expr, 1));
14900       return ffecom_2 (NE_EXPR, integer_type_node,
14901                        TREE_OPERAND (expr, 0),
14902                        fold (build1 (NOP_EXPR,
14903                                      TREE_TYPE (TREE_OPERAND (expr, 0)),
14904                                      TREE_OPERAND (expr, 1))));
14905
14906     case BIT_AND_EXPR:
14907       if (integer_onep (TREE_OPERAND (expr, 1)))
14908         return expr;
14909       break;
14910
14911     case MODIFY_EXPR:
14912 #if 0                           /* No such thing in Fortran. */
14913       if (warn_parentheses && C_EXP_ORIGINAL_CODE (expr) == MODIFY_EXPR)
14914         warning ("suggest parentheses around assignment used as truth value");
14915 #endif
14916       break;
14917
14918     default:
14919       break;
14920     }
14921
14922   if (TREE_CODE (TREE_TYPE (expr)) == COMPLEX_TYPE)
14923     return (ffecom_2
14924             ((TREE_SIDE_EFFECTS (expr)
14925               ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
14926              integer_type_node,
14927              ffe_truthvalue_conversion (ffecom_1 (REALPART_EXPR,
14928                                                   TREE_TYPE (TREE_TYPE (expr)),
14929                                                   expr)),
14930              ffe_truthvalue_conversion (ffecom_1 (IMAGPART_EXPR,
14931                                                   TREE_TYPE (TREE_TYPE (expr)),
14932                                                   expr))));
14933
14934   return ffecom_2 (NE_EXPR, integer_type_node,
14935                    expr,
14936                    convert (TREE_TYPE (expr), integer_zero_node));
14937 }
14938
14939 static tree
14940 ffe_type_for_mode (enum machine_mode mode, int unsignedp)
14941 {
14942   int i;
14943   int j;
14944   tree t;
14945
14946   if (mode == TYPE_MODE (integer_type_node))
14947     return unsignedp ? unsigned_type_node : integer_type_node;
14948
14949   if (mode == TYPE_MODE (signed_char_type_node))
14950     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
14951
14952   if (mode == TYPE_MODE (short_integer_type_node))
14953     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
14954
14955   if (mode == TYPE_MODE (long_integer_type_node))
14956     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
14957
14958   if (mode == TYPE_MODE (long_long_integer_type_node))
14959     return unsignedp ? long_long_unsigned_type_node : long_long_integer_type_node;
14960
14961 #if HOST_BITS_PER_WIDE_INT >= 64
14962   if (mode == TYPE_MODE (intTI_type_node))
14963     return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
14964 #endif
14965
14966   if (mode == TYPE_MODE (float_type_node))
14967     return float_type_node;
14968
14969   if (mode == TYPE_MODE (double_type_node))
14970     return double_type_node;
14971
14972   if (mode == TYPE_MODE (long_double_type_node))
14973     return long_double_type_node;
14974
14975  if (mode == TYPE_MODE (build_pointer_type (char_type_node)))
14976     return build_pointer_type (char_type_node);
14977
14978   if (mode == TYPE_MODE (build_pointer_type (integer_type_node)))
14979     return build_pointer_type (integer_type_node);
14980
14981   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
14982     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
14983       {
14984         if (((t = ffecom_tree_type[i][j]) != NULL_TREE)
14985             && (mode == TYPE_MODE (t)))
14986           {
14987             if ((i == FFEINFO_basictypeINTEGER) && unsignedp)
14988               return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][j];
14989             else
14990               return t;
14991           }
14992       }
14993
14994   return 0;
14995 }
14996
14997 static tree
14998 ffe_type_for_size (unsigned bits, int unsignedp)
14999 {
15000   ffeinfoKindtype kt;
15001   tree type_node;
15002
15003   if (bits == TYPE_PRECISION (integer_type_node))
15004     return unsignedp ? unsigned_type_node : integer_type_node;
15005
15006   if (bits == TYPE_PRECISION (signed_char_type_node))
15007     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15008
15009   if (bits == TYPE_PRECISION (short_integer_type_node))
15010     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15011
15012   if (bits == TYPE_PRECISION (long_integer_type_node))
15013     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15014
15015   if (bits == TYPE_PRECISION (long_long_integer_type_node))
15016     return (unsignedp ? long_long_unsigned_type_node
15017             : long_long_integer_type_node);
15018
15019   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15020     {
15021       type_node = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15022
15023       if ((type_node != NULL_TREE) && (bits == TYPE_PRECISION (type_node)))
15024         return unsignedp ? ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]
15025           : type_node;
15026     }
15027
15028   return 0;
15029 }
15030
15031 static tree
15032 ffe_unsigned_type (tree type)
15033 {
15034   tree type1 = TYPE_MAIN_VARIANT (type);
15035   ffeinfoKindtype kt;
15036   tree type2;
15037
15038   if (type1 == signed_char_type_node || type1 == char_type_node)
15039     return unsigned_char_type_node;
15040   if (type1 == integer_type_node)
15041     return unsigned_type_node;
15042   if (type1 == short_integer_type_node)
15043     return short_unsigned_type_node;
15044   if (type1 == long_integer_type_node)
15045     return long_unsigned_type_node;
15046   if (type1 == long_long_integer_type_node)
15047     return long_long_unsigned_type_node;
15048 #if 0   /* gcc/c-* files only */
15049   if (type1 == intDI_type_node)
15050     return unsigned_intDI_type_node;
15051   if (type1 == intSI_type_node)
15052     return unsigned_intSI_type_node;
15053   if (type1 == intHI_type_node)
15054     return unsigned_intHI_type_node;
15055   if (type1 == intQI_type_node)
15056     return unsigned_intQI_type_node;
15057 #endif
15058
15059   type2 = ffe_type_for_size (TYPE_PRECISION (type1), 1);
15060   if (type2 != NULL_TREE)
15061     return type2;
15062
15063   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15064     {
15065       type2 = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15066
15067       if (type1 == type2)
15068         return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
15069     }
15070
15071   return type;
15072 }
15073 \f
15074 /* From gcc/cccp.c, the code to handle -I.  */
15075
15076 /* Skip leading "./" from a directory name.
15077    This may yield the empty string, which represents the current directory.  */
15078
15079 static const char *
15080 skip_redundant_dir_prefix (const char *dir)
15081 {
15082   while (dir[0] == '.' && dir[1] == '/')
15083     for (dir += 2; *dir == '/'; dir++)
15084       continue;
15085   if (dir[0] == '.' && !dir[1])
15086     dir++;
15087   return dir;
15088 }
15089
15090 /* The file_name_map structure holds a mapping of file names for a
15091    particular directory.  This mapping is read from the file named
15092    FILE_NAME_MAP_FILE in that directory.  Such a file can be used to
15093    map filenames on a file system with severe filename restrictions,
15094    such as DOS.  The format of the file name map file is just a series
15095    of lines with two tokens on each line.  The first token is the name
15096    to map, and the second token is the actual name to use.  */
15097
15098 struct file_name_map
15099 {
15100   struct file_name_map *map_next;
15101   char *map_from;
15102   char *map_to;
15103 };
15104
15105 #define FILE_NAME_MAP_FILE "header.gcc"
15106
15107 /* Current maximum length of directory names in the search path
15108    for include files.  (Altered as we get more of them.)  */
15109
15110 static int max_include_len = 0;
15111
15112 struct file_name_list
15113   {
15114     struct file_name_list *next;
15115     const char *fname;
15116     /* Mapping of file names for this directory.  */
15117     struct file_name_map *name_map;
15118     /* Nonzero if name_map is valid.  */
15119     int got_name_map;
15120   };
15121
15122 static struct file_name_list *include = NULL;   /* First dir to search */
15123 static struct file_name_list *last_include = NULL;      /* Last in chain */
15124
15125 /* I/O buffer structure.
15126    The `fname' field is nonzero for source files and #include files
15127    and for the dummy text used for -D and -U.
15128    It is zero for rescanning results of macro expansion
15129    and for expanding macro arguments.  */
15130 #define INPUT_STACK_MAX 400
15131 static struct file_buf {
15132   const char *fname;
15133   /* Filename specified with #line command.  */
15134   const char *nominal_fname;
15135   /* Record where in the search path this file was found.
15136      For #include_next.  */
15137   struct file_name_list *dir;
15138   ffewhereLine line;
15139   ffewhereColumn column;
15140 } instack[INPUT_STACK_MAX];
15141
15142 static int last_error_tick = 0;    /* Incremented each time we print it.  */
15143 static int input_file_stack_tick = 0;  /* Incremented when status changes.  */
15144
15145 /* Current nesting level of input sources.
15146    `instack[indepth]' is the level currently being read.  */
15147 static int indepth = -1;
15148
15149 typedef struct file_buf FILE_BUF;
15150
15151 /* Nonzero means -I- has been seen,
15152    so don't look for #include "foo" the source-file directory.  */
15153 static int ignore_srcdir;
15154
15155 #ifndef INCLUDE_LEN_FUDGE
15156 #define INCLUDE_LEN_FUDGE 0
15157 #endif
15158
15159 static void append_include_chain (struct file_name_list *first,
15160                                   struct file_name_list *last);
15161 static FILE *open_include_file (char *filename,
15162                                 struct file_name_list *searchptr);
15163 static void print_containing_files (ffebadSeverity sev);
15164 static char *read_filename_string (int ch, FILE *f);
15165 static struct file_name_map *read_name_map (const char *dirname);
15166
15167 /* Append a chain of `struct file_name_list's
15168    to the end of the main include chain.
15169    FIRST is the beginning of the chain to append, and LAST is the end.  */
15170
15171 static void
15172 append_include_chain (struct file_name_list *first, struct file_name_list *last)
15173 {
15174   struct file_name_list *dir;
15175
15176   if (!first || !last)
15177     return;
15178
15179   if (include == 0)
15180     include = first;
15181   else
15182     last_include->next = first;
15183
15184   for (dir = first; ; dir = dir->next) {
15185     int len = strlen (dir->fname) + INCLUDE_LEN_FUDGE;
15186     if (len > max_include_len)
15187       max_include_len = len;
15188     if (dir == last)
15189       break;
15190   }
15191
15192   last->next = NULL;
15193   last_include = last;
15194 }
15195
15196 /* Try to open include file FILENAME.  SEARCHPTR is the directory
15197    being tried from the include file search path.  This function maps
15198    filenames on file systems based on information read by
15199    read_name_map.  */
15200
15201 static FILE *
15202 open_include_file (char *filename, struct file_name_list *searchptr)
15203 {
15204   register struct file_name_map *map;
15205   register char *from;
15206   char *p, *dir;
15207
15208   if (searchptr && ! searchptr->got_name_map)
15209     {
15210       searchptr->name_map = read_name_map (searchptr->fname
15211                                            ? searchptr->fname : ".");
15212       searchptr->got_name_map = 1;
15213     }
15214
15215   /* First check the mapping for the directory we are using.  */
15216   if (searchptr && searchptr->name_map)
15217     {
15218       from = filename;
15219       if (searchptr->fname)
15220         from += strlen (searchptr->fname) + 1;
15221       for (map = searchptr->name_map; map; map = map->map_next)
15222         {
15223           if (! strcmp (map->map_from, from))
15224             {
15225               /* Found a match.  */
15226               return fopen (map->map_to, "r");
15227             }
15228         }
15229     }
15230
15231   /* Try to find a mapping file for the particular directory we are
15232      looking in.  Thus #include <sys/types.h> will look up sys/types.h
15233      in /usr/include/header.gcc and look up types.h in
15234      /usr/include/sys/header.gcc.  */
15235   p = strrchr (filename, '/');
15236 #ifdef DIR_SEPARATOR
15237   if (! p) p = strrchr (filename, DIR_SEPARATOR);
15238   else {
15239     char *tmp = strrchr (filename, DIR_SEPARATOR);
15240     if (tmp != NULL && tmp > p) p = tmp;
15241   }
15242 #endif
15243   if (! p)
15244     p = filename;
15245   if (searchptr
15246       && searchptr->fname
15247       && strlen (searchptr->fname) == (size_t) (p - filename)
15248       && ! strncmp (searchptr->fname, filename, (int) (p - filename)))
15249     {
15250       /* FILENAME is in SEARCHPTR, which we've already checked.  */
15251       return fopen (filename, "r");
15252     }
15253
15254   if (p == filename)
15255     {
15256       from = filename;
15257       map = read_name_map (".");
15258     }
15259   else
15260     {
15261       dir = (char *) xmalloc (p - filename + 1);
15262       memcpy (dir, filename, p - filename);
15263       dir[p - filename] = '\0';
15264       from = p + 1;
15265       map = read_name_map (dir);
15266       free (dir);
15267     }
15268   for (; map; map = map->map_next)
15269     if (! strcmp (map->map_from, from))
15270       return fopen (map->map_to, "r");
15271
15272   return fopen (filename, "r");
15273 }
15274
15275 /* Print the file names and line numbers of the #include
15276    commands which led to the current file.  */
15277
15278 static void
15279 print_containing_files (ffebadSeverity sev)
15280 {
15281   FILE_BUF *ip = NULL;
15282   int i;
15283   int first = 1;
15284   const char *str1;
15285   const char *str2;
15286
15287   /* If stack of files hasn't changed since we last printed
15288      this info, don't repeat it.  */
15289   if (last_error_tick == input_file_stack_tick)
15290     return;
15291
15292   for (i = indepth; i >= 0; i--)
15293     if (instack[i].fname != NULL) {
15294       ip = &instack[i];
15295       break;
15296     }
15297
15298   /* Give up if we don't find a source file.  */
15299   if (ip == NULL)
15300     return;
15301
15302   /* Find the other, outer source files.  */
15303   for (i--; i >= 0; i--)
15304     if (instack[i].fname != NULL)
15305       {
15306         ip = &instack[i];
15307         if (first)
15308           {
15309             first = 0;
15310             str1 = "In file included";
15311           }
15312         else
15313           {
15314             str1 = "...          ...";
15315           }
15316
15317         if (i == 1)
15318           str2 = ":";
15319         else
15320           str2 = "";
15321
15322         /* xgettext:no-c-format */
15323         ffebad_start_msg ("%A from %B at %0%C", sev);
15324         ffebad_here (0, ip->line, ip->column);
15325         ffebad_string (str1);
15326         ffebad_string (ip->nominal_fname);
15327         ffebad_string (str2);
15328         ffebad_finish ();
15329       }
15330
15331   /* Record we have printed the status as of this time.  */
15332   last_error_tick = input_file_stack_tick;
15333 }
15334
15335 /* Read a space delimited string of unlimited length from a stdio
15336    file.  */
15337
15338 static char *
15339 read_filename_string (int ch, FILE *f)
15340 {
15341   char *alloc, *set;
15342   int len;
15343
15344   len = 20;
15345   set = alloc = xmalloc (len + 1);
15346   if (! ISSPACE (ch))
15347     {
15348       *set++ = ch;
15349       while ((ch = getc (f)) != EOF && ! ISSPACE (ch))
15350         {
15351           if (set - alloc == len)
15352             {
15353               len *= 2;
15354               alloc = xrealloc (alloc, len + 1);
15355               set = alloc + len / 2;
15356             }
15357           *set++ = ch;
15358         }
15359     }
15360   *set = '\0';
15361   ungetc (ch, f);
15362   return alloc;
15363 }
15364
15365 /* Read the file name map file for DIRNAME.  */
15366
15367 static struct file_name_map *
15368 read_name_map (const char *dirname)
15369 {
15370   /* This structure holds a linked list of file name maps, one per
15371      directory.  */
15372   struct file_name_map_list
15373     {
15374       struct file_name_map_list *map_list_next;
15375       char *map_list_name;
15376       struct file_name_map *map_list_map;
15377     };
15378   static struct file_name_map_list *map_list;
15379   register struct file_name_map_list *map_list_ptr;
15380   char *name;
15381   FILE *f;
15382   size_t dirlen;
15383   int separator_needed;
15384
15385   dirname = skip_redundant_dir_prefix (dirname);
15386
15387   for (map_list_ptr = map_list; map_list_ptr;
15388        map_list_ptr = map_list_ptr->map_list_next)
15389     if (! strcmp (map_list_ptr->map_list_name, dirname))
15390       return map_list_ptr->map_list_map;
15391
15392   map_list_ptr = ((struct file_name_map_list *)
15393                   xmalloc (sizeof (struct file_name_map_list)));
15394   map_list_ptr->map_list_name = xstrdup (dirname);
15395   map_list_ptr->map_list_map = NULL;
15396
15397   dirlen = strlen (dirname);
15398   separator_needed = dirlen != 0 && dirname[dirlen - 1] != '/';
15399   if (separator_needed)
15400     name = concat (dirname, "/", FILE_NAME_MAP_FILE, NULL);
15401   else
15402     name = concat (dirname, FILE_NAME_MAP_FILE, NULL);
15403   f = fopen (name, "r");
15404   free (name);
15405   if (!f)
15406     map_list_ptr->map_list_map = NULL;
15407   else
15408     {
15409       int ch;
15410
15411       while ((ch = getc (f)) != EOF)
15412         {
15413           char *from, *to;
15414           struct file_name_map *ptr;
15415
15416           if (ISSPACE (ch))
15417             continue;
15418           from = read_filename_string (ch, f);
15419           while ((ch = getc (f)) != EOF && ISSPACE (ch) && ch != '\n')
15420             ;
15421           to = read_filename_string (ch, f);
15422
15423           ptr = ((struct file_name_map *)
15424                  xmalloc (sizeof (struct file_name_map)));
15425           ptr->map_from = from;
15426
15427           /* Make the real filename absolute.  */
15428           if (*to == '/')
15429             ptr->map_to = to;
15430           else
15431             {
15432               if (separator_needed)
15433                 ptr->map_to = concat (dirname, "/", to, NULL);
15434               else
15435                 ptr->map_to = concat (dirname, to, NULL);
15436               free (to);
15437             }
15438
15439           ptr->map_next = map_list_ptr->map_list_map;
15440           map_list_ptr->map_list_map = ptr;
15441
15442           while ((ch = getc (f)) != '\n')
15443             if (ch == EOF)
15444               break;
15445         }
15446       fclose (f);
15447     }
15448
15449   map_list_ptr->map_list_next = map_list;
15450   map_list = map_list_ptr;
15451
15452   return map_list_ptr->map_list_map;
15453 }
15454
15455 static void
15456 ffecom_file_ (const char *name)
15457 {
15458   FILE_BUF *fp;
15459
15460   /* Do partial setup of input buffer for the sake of generating
15461      early #line directives (when -g is in effect).  */
15462
15463   fp = &instack[++indepth];
15464   memset ((char *) fp, 0, sizeof (FILE_BUF));
15465   if (name == NULL)
15466     name = "";
15467   fp->nominal_fname = fp->fname = name;
15468 }
15469
15470 static void
15471 ffecom_close_include_ (FILE *f)
15472 {
15473   fclose (f);
15474
15475   indepth--;
15476   input_file_stack_tick++;
15477
15478   ffewhere_line_kill (instack[indepth].line);
15479   ffewhere_column_kill (instack[indepth].column);
15480 }
15481
15482 void
15483 ffecom_decode_include_option (const char *dir)
15484 {
15485   if (! ignore_srcdir && !strcmp (dir, "-"))
15486     ignore_srcdir = 1;
15487   else
15488     {
15489       struct file_name_list *dirtmp = (struct file_name_list *)
15490         xmalloc (sizeof (struct file_name_list));
15491       dirtmp->next = 0;         /* New one goes on the end */
15492       dirtmp->fname = dir;
15493       dirtmp->got_name_map = 0;
15494       append_include_chain (dirtmp, dirtmp);
15495     }
15496 }
15497
15498 /* Open INCLUDEd file.  */
15499
15500 static FILE *
15501 ffecom_open_include_ (char *name, ffewhereLine l, ffewhereColumn c)
15502 {
15503   char *fbeg = name;
15504   size_t flen = strlen (fbeg);
15505   struct file_name_list *search_start = include; /* Chain of dirs to search */
15506   struct file_name_list dsp[1]; /* First in chain, if #include "..." */
15507   struct file_name_list *searchptr = 0;
15508   char *fname;          /* Dynamically allocated fname buffer */
15509   FILE *f;
15510   FILE_BUF *fp;
15511
15512   if (flen == 0)
15513     return NULL;
15514
15515   dsp[0].fname = NULL;
15516
15517   /* If -I- was specified, don't search current dir, only spec'd ones. */
15518   if (!ignore_srcdir)
15519     {
15520       for (fp = &instack[indepth]; fp >= instack; fp--)
15521         {
15522           int n;
15523           char *ep;
15524           const char *nam;
15525
15526           if ((nam = fp->nominal_fname) != NULL)
15527             {
15528               /* Found a named file.  Figure out dir of the file,
15529                  and put it in front of the search list.  */
15530               dsp[0].next = search_start;
15531               search_start = dsp;
15532 #ifndef VMS
15533               ep = strrchr (nam, '/');
15534 #ifdef DIR_SEPARATOR
15535             if (ep == NULL) ep = strrchr (nam, DIR_SEPARATOR);
15536             else {
15537               char *tmp = strrchr (nam, DIR_SEPARATOR);
15538               if (tmp != NULL && tmp > ep) ep = tmp;
15539             }
15540 #endif
15541 #else                           /* VMS */
15542               ep = strrchr (nam, ']');
15543               if (ep == NULL) ep = strrchr (nam, '>');
15544               if (ep == NULL) ep = strrchr (nam, ':');
15545               if (ep != NULL) ep++;
15546 #endif                          /* VMS */
15547               if (ep != NULL)
15548                 {
15549                   n = ep - nam;
15550                   fname = xmalloc (n + 1);
15551                   strncpy (fname, nam, n);
15552                   fname[n] = '\0';
15553                   dsp[0].fname = fname;
15554                   if (n + INCLUDE_LEN_FUDGE > max_include_len)
15555                     max_include_len = n + INCLUDE_LEN_FUDGE;
15556                 }
15557               else
15558                 dsp[0].fname = NULL; /* Current directory */
15559               dsp[0].got_name_map = 0;
15560               break;
15561             }
15562         }
15563     }
15564
15565   /* Allocate this permanently, because it gets stored in the definitions
15566      of macros.  */
15567   fname = xmalloc (max_include_len + flen + 4);
15568   /* + 2 above for slash and terminating null.  */
15569   /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED
15570      for g77 yet).  */
15571
15572   /* If specified file name is absolute, just open it.  */
15573
15574   if (*fbeg == '/'
15575 #ifdef DIR_SEPARATOR
15576       || *fbeg == DIR_SEPARATOR
15577 #endif
15578       )
15579     {
15580       strncpy (fname, (char *) fbeg, flen);
15581       fname[flen] = 0;
15582       f = open_include_file (fname, NULL);
15583     }
15584   else
15585     {
15586       f = NULL;
15587
15588       /* Search directory path, trying to open the file.
15589          Copy each filename tried into FNAME.  */
15590
15591       for (searchptr = search_start; searchptr; searchptr = searchptr->next)
15592         {
15593           if (searchptr->fname)
15594             {
15595               /* The empty string in a search path is ignored.
15596                  This makes it possible to turn off entirely
15597                  a standard piece of the list.  */
15598               if (searchptr->fname[0] == 0)
15599                 continue;
15600               strcpy (fname, skip_redundant_dir_prefix (searchptr->fname));
15601               if (fname[0] && fname[strlen (fname) - 1] != '/')
15602                 strcat (fname, "/");
15603               fname[strlen (fname) + flen] = 0;
15604             }
15605           else
15606             fname[0] = 0;
15607
15608           strncat (fname, fbeg, flen);
15609 #ifdef VMS
15610           /* Change this 1/2 Unix 1/2 VMS file specification into a
15611              full VMS file specification */
15612           if (searchptr->fname && (searchptr->fname[0] != 0))
15613             {
15614               /* Fix up the filename */
15615               hack_vms_include_specification (fname);
15616             }
15617           else
15618             {
15619               /* This is a normal VMS filespec, so use it unchanged.  */
15620               strncpy (fname, (char *) fbeg, flen);
15621               fname[flen] = 0;
15622 #if 0   /* Not for g77.  */
15623               /* if it's '#include filename', add the missing .h */
15624               if (strchr (fname, '.') == NULL)
15625                 strcat (fname, ".h");
15626 #endif
15627             }
15628 #endif /* VMS */
15629           f = open_include_file (fname, searchptr);
15630 #ifdef EACCES
15631           if (f == NULL && errno == EACCES)
15632             {
15633               print_containing_files (FFEBAD_severityWARNING);
15634               /* xgettext:no-c-format */
15635               ffebad_start_msg ("At %0, INCLUDE file %A exists, but is not readable",
15636                                 FFEBAD_severityWARNING);
15637               ffebad_string (fname);
15638               ffebad_here (0, l, c);
15639               ffebad_finish ();
15640             }
15641 #endif
15642           if (f != NULL)
15643             break;
15644         }
15645     }
15646
15647   if (f == NULL)
15648     {
15649       /* A file that was not found.  */
15650
15651       strncpy (fname, (char *) fbeg, flen);
15652       fname[flen] = 0;
15653       print_containing_files (ffebad_severity (FFEBAD_OPEN_INCLUDE));
15654       ffebad_start (FFEBAD_OPEN_INCLUDE);
15655       ffebad_here (0, l, c);
15656       ffebad_string (fname);
15657       ffebad_finish ();
15658     }
15659
15660   if (dsp[0].fname != NULL)
15661     free ((char *) dsp[0].fname);
15662
15663   if (f == NULL)
15664     return NULL;
15665
15666   if (indepth >= (INPUT_STACK_MAX - 1))
15667     {
15668       print_containing_files (FFEBAD_severityFATAL);
15669       /* xgettext:no-c-format */
15670       ffebad_start_msg ("At %0, INCLUDE nesting too deep",
15671                         FFEBAD_severityFATAL);
15672       ffebad_string (fname);
15673       ffebad_here (0, l, c);
15674       ffebad_finish ();
15675       return NULL;
15676     }
15677
15678   instack[indepth].line = ffewhere_line_use (l);
15679   instack[indepth].column = ffewhere_column_use (c);
15680
15681   fp = &instack[indepth + 1];
15682   memset ((char *) fp, 0, sizeof (FILE_BUF));
15683   fp->nominal_fname = fp->fname = fname;
15684   fp->dir = searchptr;
15685
15686   indepth++;
15687   input_file_stack_tick++;
15688
15689   return f;
15690 }
15691
15692 /**INDENT* (Do not reformat this comment even with -fca option.)
15693    Data-gathering files: Given the source file listed below, compiled with
15694    f2c I obtained the output file listed after that, and from the output
15695    file I derived the above code.
15696
15697 -------- (begin input file to f2c)
15698         implicit none
15699         character*10 A1,A2
15700         complex C1,C2
15701         integer I1,I2
15702         real R1,R2
15703         double precision D1,D2
15704 C
15705         call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2)
15706 c /
15707         call fooI(I1/I2)
15708         call fooR(R1/I1)
15709         call fooD(D1/I1)
15710         call fooC(C1/I1)
15711         call fooR(R1/R2)
15712         call fooD(R1/D1)
15713         call fooD(D1/D2)
15714         call fooD(D1/R1)
15715         call fooC(C1/C2)
15716         call fooC(C1/R1)
15717         call fooZ(C1/D1)
15718 c **
15719         call fooI(I1**I2)
15720         call fooR(R1**I1)
15721         call fooD(D1**I1)
15722         call fooC(C1**I1)
15723         call fooR(R1**R2)
15724         call fooD(R1**D1)
15725         call fooD(D1**D2)
15726         call fooD(D1**R1)
15727         call fooC(C1**C2)
15728         call fooC(C1**R1)
15729         call fooZ(C1**D1)
15730 c FFEINTRIN_impABS
15731         call fooR(ABS(R1))
15732 c FFEINTRIN_impACOS
15733         call fooR(ACOS(R1))
15734 c FFEINTRIN_impAIMAG
15735         call fooR(AIMAG(C1))
15736 c FFEINTRIN_impAINT
15737         call fooR(AINT(R1))
15738 c FFEINTRIN_impALOG
15739         call fooR(ALOG(R1))
15740 c FFEINTRIN_impALOG10
15741         call fooR(ALOG10(R1))
15742 c FFEINTRIN_impAMAX0
15743         call fooR(AMAX0(I1,I2))
15744 c FFEINTRIN_impAMAX1
15745         call fooR(AMAX1(R1,R2))
15746 c FFEINTRIN_impAMIN0
15747         call fooR(AMIN0(I1,I2))
15748 c FFEINTRIN_impAMIN1
15749         call fooR(AMIN1(R1,R2))
15750 c FFEINTRIN_impAMOD
15751         call fooR(AMOD(R1,R2))
15752 c FFEINTRIN_impANINT
15753         call fooR(ANINT(R1))
15754 c FFEINTRIN_impASIN
15755         call fooR(ASIN(R1))
15756 c FFEINTRIN_impATAN
15757         call fooR(ATAN(R1))
15758 c FFEINTRIN_impATAN2
15759         call fooR(ATAN2(R1,R2))
15760 c FFEINTRIN_impCABS
15761         call fooR(CABS(C1))
15762 c FFEINTRIN_impCCOS
15763         call fooC(CCOS(C1))
15764 c FFEINTRIN_impCEXP
15765         call fooC(CEXP(C1))
15766 c FFEINTRIN_impCHAR
15767         call fooA(CHAR(I1))
15768 c FFEINTRIN_impCLOG
15769         call fooC(CLOG(C1))
15770 c FFEINTRIN_impCONJG
15771         call fooC(CONJG(C1))
15772 c FFEINTRIN_impCOS
15773         call fooR(COS(R1))
15774 c FFEINTRIN_impCOSH
15775         call fooR(COSH(R1))
15776 c FFEINTRIN_impCSIN
15777         call fooC(CSIN(C1))
15778 c FFEINTRIN_impCSQRT
15779         call fooC(CSQRT(C1))
15780 c FFEINTRIN_impDABS
15781         call fooD(DABS(D1))
15782 c FFEINTRIN_impDACOS
15783         call fooD(DACOS(D1))
15784 c FFEINTRIN_impDASIN
15785         call fooD(DASIN(D1))
15786 c FFEINTRIN_impDATAN
15787         call fooD(DATAN(D1))
15788 c FFEINTRIN_impDATAN2
15789         call fooD(DATAN2(D1,D2))
15790 c FFEINTRIN_impDCOS
15791         call fooD(DCOS(D1))
15792 c FFEINTRIN_impDCOSH
15793         call fooD(DCOSH(D1))
15794 c FFEINTRIN_impDDIM
15795         call fooD(DDIM(D1,D2))
15796 c FFEINTRIN_impDEXP
15797         call fooD(DEXP(D1))
15798 c FFEINTRIN_impDIM
15799         call fooR(DIM(R1,R2))
15800 c FFEINTRIN_impDINT
15801         call fooD(DINT(D1))
15802 c FFEINTRIN_impDLOG
15803         call fooD(DLOG(D1))
15804 c FFEINTRIN_impDLOG10
15805         call fooD(DLOG10(D1))
15806 c FFEINTRIN_impDMAX1
15807         call fooD(DMAX1(D1,D2))
15808 c FFEINTRIN_impDMIN1
15809         call fooD(DMIN1(D1,D2))
15810 c FFEINTRIN_impDMOD
15811         call fooD(DMOD(D1,D2))
15812 c FFEINTRIN_impDNINT
15813         call fooD(DNINT(D1))
15814 c FFEINTRIN_impDPROD
15815         call fooD(DPROD(R1,R2))
15816 c FFEINTRIN_impDSIGN
15817         call fooD(DSIGN(D1,D2))
15818 c FFEINTRIN_impDSIN
15819         call fooD(DSIN(D1))
15820 c FFEINTRIN_impDSINH
15821         call fooD(DSINH(D1))
15822 c FFEINTRIN_impDSQRT
15823         call fooD(DSQRT(D1))
15824 c FFEINTRIN_impDTAN
15825         call fooD(DTAN(D1))
15826 c FFEINTRIN_impDTANH
15827         call fooD(DTANH(D1))
15828 c FFEINTRIN_impEXP
15829         call fooR(EXP(R1))
15830 c FFEINTRIN_impIABS
15831         call fooI(IABS(I1))
15832 c FFEINTRIN_impICHAR
15833         call fooI(ICHAR(A1))
15834 c FFEINTRIN_impIDIM
15835         call fooI(IDIM(I1,I2))
15836 c FFEINTRIN_impIDNINT
15837         call fooI(IDNINT(D1))
15838 c FFEINTRIN_impINDEX
15839         call fooI(INDEX(A1,A2))
15840 c FFEINTRIN_impISIGN
15841         call fooI(ISIGN(I1,I2))
15842 c FFEINTRIN_impLEN
15843         call fooI(LEN(A1))
15844 c FFEINTRIN_impLGE
15845         call fooL(LGE(A1,A2))
15846 c FFEINTRIN_impLGT
15847         call fooL(LGT(A1,A2))
15848 c FFEINTRIN_impLLE
15849         call fooL(LLE(A1,A2))
15850 c FFEINTRIN_impLLT
15851         call fooL(LLT(A1,A2))
15852 c FFEINTRIN_impMAX0
15853         call fooI(MAX0(I1,I2))
15854 c FFEINTRIN_impMAX1
15855         call fooI(MAX1(R1,R2))
15856 c FFEINTRIN_impMIN0
15857         call fooI(MIN0(I1,I2))
15858 c FFEINTRIN_impMIN1
15859         call fooI(MIN1(R1,R2))
15860 c FFEINTRIN_impMOD
15861         call fooI(MOD(I1,I2))
15862 c FFEINTRIN_impNINT
15863         call fooI(NINT(R1))
15864 c FFEINTRIN_impSIGN
15865         call fooR(SIGN(R1,R2))
15866 c FFEINTRIN_impSIN
15867         call fooR(SIN(R1))
15868 c FFEINTRIN_impSINH
15869         call fooR(SINH(R1))
15870 c FFEINTRIN_impSQRT
15871         call fooR(SQRT(R1))
15872 c FFEINTRIN_impTAN
15873         call fooR(TAN(R1))
15874 c FFEINTRIN_impTANH
15875         call fooR(TANH(R1))
15876 c FFEINTRIN_imp_CMPLX_C
15877         call fooC(cmplx(C1,C2))
15878 c FFEINTRIN_imp_CMPLX_D
15879         call fooZ(cmplx(D1,D2))
15880 c FFEINTRIN_imp_CMPLX_I
15881         call fooC(cmplx(I1,I2))
15882 c FFEINTRIN_imp_CMPLX_R
15883         call fooC(cmplx(R1,R2))
15884 c FFEINTRIN_imp_DBLE_C
15885         call fooD(dble(C1))
15886 c FFEINTRIN_imp_DBLE_D
15887         call fooD(dble(D1))
15888 c FFEINTRIN_imp_DBLE_I
15889         call fooD(dble(I1))
15890 c FFEINTRIN_imp_DBLE_R
15891         call fooD(dble(R1))
15892 c FFEINTRIN_imp_INT_C
15893         call fooI(int(C1))
15894 c FFEINTRIN_imp_INT_D
15895         call fooI(int(D1))
15896 c FFEINTRIN_imp_INT_I
15897         call fooI(int(I1))
15898 c FFEINTRIN_imp_INT_R
15899         call fooI(int(R1))
15900 c FFEINTRIN_imp_REAL_C
15901         call fooR(real(C1))
15902 c FFEINTRIN_imp_REAL_D
15903         call fooR(real(D1))
15904 c FFEINTRIN_imp_REAL_I
15905         call fooR(real(I1))
15906 c FFEINTRIN_imp_REAL_R
15907         call fooR(real(R1))
15908 c
15909 c FFEINTRIN_imp_INT_D:
15910 c
15911 c FFEINTRIN_specIDINT
15912         call fooI(IDINT(D1))
15913 c
15914 c FFEINTRIN_imp_INT_R:
15915 c
15916 c FFEINTRIN_specIFIX
15917         call fooI(IFIX(R1))
15918 c FFEINTRIN_specINT
15919         call fooI(INT(R1))
15920 c
15921 c FFEINTRIN_imp_REAL_D:
15922 c
15923 c FFEINTRIN_specSNGL
15924         call fooR(SNGL(D1))
15925 c
15926 c FFEINTRIN_imp_REAL_I:
15927 c
15928 c FFEINTRIN_specFLOAT
15929         call fooR(FLOAT(I1))
15930 c FFEINTRIN_specREAL
15931         call fooR(REAL(I1))
15932 c
15933         end
15934 -------- (end input file to f2c)
15935
15936 -------- (begin output from providing above input file as input to:
15937 --------  `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
15938 --------     -e "s:^#.*$::g"')
15939
15940 //  -- translated by f2c (version 19950223).
15941    You must link the resulting object file with the libraries:
15942         -lf2c -lm   (in that order)
15943 //
15944
15945
15946 // f2c.h  --  Standard Fortran to C header file //
15947
15948 ///  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
15949
15950         - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
15951
15952
15953
15954
15955 // F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems //
15956 // we assume short, float are OK //
15957 typedef long int // long int // integer;
15958 typedef char *address;
15959 typedef short int shortint;
15960 typedef float real;
15961 typedef double doublereal;
15962 typedef struct { real r, i; } complex;
15963 typedef struct { doublereal r, i; } doublecomplex;
15964 typedef long int // long int // logical;
15965 typedef short int shortlogical;
15966 typedef char logical1;
15967 typedef char integer1;
15968 // typedef long long longint; // // system-dependent //
15969
15970
15971
15972
15973 // Extern is for use with -E //
15974
15975
15976
15977
15978 // I/O stuff //
15979
15980
15981
15982
15983
15984
15985
15986
15987 typedef long int // int or long int // flag;
15988 typedef long int // int or long int // ftnlen;
15989 typedef long int // int or long int // ftnint;
15990
15991
15992 //external read, write//
15993 typedef struct
15994 {       flag cierr;
15995         ftnint ciunit;
15996         flag ciend;
15997         char *cifmt;
15998         ftnint cirec;
15999 } cilist;
16000
16001 //internal read, write//
16002 typedef struct
16003 {       flag icierr;
16004         char *iciunit;
16005         flag iciend;
16006         char *icifmt;
16007         ftnint icirlen;
16008         ftnint icirnum;
16009 } icilist;
16010
16011 //open//
16012 typedef struct
16013 {       flag oerr;
16014         ftnint ounit;
16015         char *ofnm;
16016         ftnlen ofnmlen;
16017         char *osta;
16018         char *oacc;
16019         char *ofm;
16020         ftnint orl;
16021         char *oblnk;
16022 } olist;
16023
16024 //close//
16025 typedef struct
16026 {       flag cerr;
16027         ftnint cunit;
16028         char *csta;
16029 } cllist;
16030
16031 //rewind, backspace, endfile//
16032 typedef struct
16033 {       flag aerr;
16034         ftnint aunit;
16035 } alist;
16036
16037 // inquire //
16038 typedef struct
16039 {       flag inerr;
16040         ftnint inunit;
16041         char *infile;
16042         ftnlen infilen;
16043         ftnint  *inex;  //parameters in standard's order//
16044         ftnint  *inopen;
16045         ftnint  *innum;
16046         ftnint  *innamed;
16047         char    *inname;
16048         ftnlen  innamlen;
16049         char    *inacc;
16050         ftnlen  inacclen;
16051         char    *inseq;
16052         ftnlen  inseqlen;
16053         char    *indir;
16054         ftnlen  indirlen;
16055         char    *infmt;
16056         ftnlen  infmtlen;
16057         char    *inform;
16058         ftnint  informlen;
16059         char    *inunf;
16060         ftnlen  inunflen;
16061         ftnint  *inrecl;
16062         ftnint  *innrec;
16063         char    *inblank;
16064         ftnlen  inblanklen;
16065 } inlist;
16066
16067
16068
16069 union Multitype {       // for multiple entry points //
16070         integer1 g;
16071         shortint h;
16072         integer i;
16073         // longint j; //
16074         real r;
16075         doublereal d;
16076         complex c;
16077         doublecomplex z;
16078         };
16079
16080 typedef union Multitype Multitype;
16081
16082 typedef long Long;      // No longer used; formerly in Namelist //
16083
16084 struct Vardesc {        // for Namelist //
16085         char *name;
16086         char *addr;
16087         ftnlen *dims;
16088         int  type;
16089         };
16090 typedef struct Vardesc Vardesc;
16091
16092 struct Namelist {
16093         char *name;
16094         Vardesc **vars;
16095         int nvars;
16096         };
16097 typedef struct Namelist Namelist;
16098
16099
16100
16101
16102
16103
16104
16105
16106 // procedure parameter types for -A and -C++ //
16107
16108
16109
16110
16111 typedef int // Unknown procedure type // (*U_fp)();
16112 typedef shortint (*J_fp)();
16113 typedef integer (*I_fp)();
16114 typedef real (*R_fp)();
16115 typedef doublereal (*D_fp)(), (*E_fp)();
16116 typedef // Complex // void  (*C_fp)();
16117 typedef // Double Complex // void  (*Z_fp)();
16118 typedef logical (*L_fp)();
16119 typedef shortlogical (*K_fp)();
16120 typedef // Character // void  (*H_fp)();
16121 typedef // Subroutine // int (*S_fp)();
16122
16123 // E_fp is for real functions when -R is not specified //
16124 typedef void  C_f;      // complex function //
16125 typedef void  H_f;      // character function //
16126 typedef void  Z_f;      // double complex function //
16127 typedef doublereal E_f; // real function with -R not specified //
16128
16129 // undef any lower-case symbols that your C compiler predefines, e.g.: //
16130
16131
16132 // (No such symbols should be defined in a strict ANSI C compiler.
16133    We can avoid trouble with f2c-translated code by using
16134    gcc -ansi.) //
16135
16136
16137
16138
16139
16140
16141
16142
16143
16144
16145
16146
16147
16148
16149
16150
16151
16152
16153
16154
16155
16156
16157
16158 // Main program // MAIN__()
16159 {
16160     // System generated locals //
16161     integer i__1;
16162     real r__1, r__2;
16163     doublereal d__1, d__2;
16164     complex q__1;
16165     doublecomplex z__1, z__2, z__3;
16166     logical L__1;
16167     char ch__1[1];
16168
16169     // Builtin functions //
16170     void c_div();
16171     integer pow_ii();
16172     double pow_ri(), pow_di();
16173     void pow_ci();
16174     double pow_dd();
16175     void pow_zz();
16176     double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
16177             asin(), atan(), atan2(), c_abs();
16178     void c_cos(), c_exp(), c_log(), r_cnjg();
16179     double cos(), cosh();
16180     void c_sin(), c_sqrt();
16181     double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
16182             d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
16183     integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
16184     logical l_ge(), l_gt(), l_le(), l_lt();
16185     integer i_nint();
16186     double r_sign();
16187
16188     // Local variables //
16189     extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
16190             fool_(), fooz_(), getem_();
16191     static char a1[10], a2[10];
16192     static complex c1, c2;
16193     static doublereal d1, d2;
16194     static integer i1, i2;
16195     static real r1, r2;
16196
16197
16198     getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L);
16199 // / //
16200     i__1 = i1 / i2;
16201     fooi_(&i__1);
16202     r__1 = r1 / i1;
16203     foor_(&r__1);
16204     d__1 = d1 / i1;
16205     food_(&d__1);
16206     d__1 = (doublereal) i1;
16207     q__1.r = c1.r / d__1, q__1.i = c1.i / d__1;
16208     fooc_(&q__1);
16209     r__1 = r1 / r2;
16210     foor_(&r__1);
16211     d__1 = r1 / d1;
16212     food_(&d__1);
16213     d__1 = d1 / d2;
16214     food_(&d__1);
16215     d__1 = d1 / r1;
16216     food_(&d__1);
16217     c_div(&q__1, &c1, &c2);
16218     fooc_(&q__1);
16219     q__1.r = c1.r / r1, q__1.i = c1.i / r1;
16220     fooc_(&q__1);
16221     z__1.r = c1.r / d1, z__1.i = c1.i / d1;
16222     fooz_(&z__1);
16223 // ** //
16224     i__1 = pow_ii(&i1, &i2);
16225     fooi_(&i__1);
16226     r__1 = pow_ri(&r1, &i1);
16227     foor_(&r__1);
16228     d__1 = pow_di(&d1, &i1);
16229     food_(&d__1);
16230     pow_ci(&q__1, &c1, &i1);
16231     fooc_(&q__1);
16232     d__1 = (doublereal) r1;
16233     d__2 = (doublereal) r2;
16234     r__1 = pow_dd(&d__1, &d__2);
16235     foor_(&r__1);
16236     d__2 = (doublereal) r1;
16237     d__1 = pow_dd(&d__2, &d1);
16238     food_(&d__1);
16239     d__1 = pow_dd(&d1, &d2);
16240     food_(&d__1);
16241     d__2 = (doublereal) r1;
16242     d__1 = pow_dd(&d1, &d__2);
16243     food_(&d__1);
16244     z__2.r = c1.r, z__2.i = c1.i;
16245     z__3.r = c2.r, z__3.i = c2.i;
16246     pow_zz(&z__1, &z__2, &z__3);
16247     q__1.r = z__1.r, q__1.i = z__1.i;
16248     fooc_(&q__1);
16249     z__2.r = c1.r, z__2.i = c1.i;
16250     z__3.r = r1, z__3.i = 0.;
16251     pow_zz(&z__1, &z__2, &z__3);
16252     q__1.r = z__1.r, q__1.i = z__1.i;
16253     fooc_(&q__1);
16254     z__2.r = c1.r, z__2.i = c1.i;
16255     z__3.r = d1, z__3.i = 0.;
16256     pow_zz(&z__1, &z__2, &z__3);
16257     fooz_(&z__1);
16258 // FFEINTRIN_impABS //
16259     r__1 = (doublereal)((  r1  ) >= 0 ? (  r1  ) : -(  r1  ))  ;
16260     foor_(&r__1);
16261 // FFEINTRIN_impACOS //
16262     r__1 = acos(r1);
16263     foor_(&r__1);
16264 // FFEINTRIN_impAIMAG //
16265     r__1 = r_imag(&c1);
16266     foor_(&r__1);
16267 // FFEINTRIN_impAINT //
16268     r__1 = r_int(&r1);
16269     foor_(&r__1);
16270 // FFEINTRIN_impALOG //
16271     r__1 = log(r1);
16272     foor_(&r__1);
16273 // FFEINTRIN_impALOG10 //
16274     r__1 = r_lg10(&r1);
16275     foor_(&r__1);
16276 // FFEINTRIN_impAMAX0 //
16277     r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16278     foor_(&r__1);
16279 // FFEINTRIN_impAMAX1 //
16280     r__1 = (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16281     foor_(&r__1);
16282 // FFEINTRIN_impAMIN0 //
16283     r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16284     foor_(&r__1);
16285 // FFEINTRIN_impAMIN1 //
16286     r__1 = (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16287     foor_(&r__1);
16288 // FFEINTRIN_impAMOD //
16289     r__1 = r_mod(&r1, &r2);
16290     foor_(&r__1);
16291 // FFEINTRIN_impANINT //
16292     r__1 = r_nint(&r1);
16293     foor_(&r__1);
16294 // FFEINTRIN_impASIN //
16295     r__1 = asin(r1);
16296     foor_(&r__1);
16297 // FFEINTRIN_impATAN //
16298     r__1 = atan(r1);
16299     foor_(&r__1);
16300 // FFEINTRIN_impATAN2 //
16301     r__1 = atan2(r1, r2);
16302     foor_(&r__1);
16303 // FFEINTRIN_impCABS //
16304     r__1 = c_abs(&c1);
16305     foor_(&r__1);
16306 // FFEINTRIN_impCCOS //
16307     c_cos(&q__1, &c1);
16308     fooc_(&q__1);
16309 // FFEINTRIN_impCEXP //
16310     c_exp(&q__1, &c1);
16311     fooc_(&q__1);
16312 // FFEINTRIN_impCHAR //
16313     *(unsigned char *)&ch__1[0] = i1;
16314     fooa_(ch__1, 1L);
16315 // FFEINTRIN_impCLOG //
16316     c_log(&q__1, &c1);
16317     fooc_(&q__1);
16318 // FFEINTRIN_impCONJG //
16319     r_cnjg(&q__1, &c1);
16320     fooc_(&q__1);
16321 // FFEINTRIN_impCOS //
16322     r__1 = cos(r1);
16323     foor_(&r__1);
16324 // FFEINTRIN_impCOSH //
16325     r__1 = cosh(r1);
16326     foor_(&r__1);
16327 // FFEINTRIN_impCSIN //
16328     c_sin(&q__1, &c1);
16329     fooc_(&q__1);
16330 // FFEINTRIN_impCSQRT //
16331     c_sqrt(&q__1, &c1);
16332     fooc_(&q__1);
16333 // FFEINTRIN_impDABS //
16334     d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ;
16335     food_(&d__1);
16336 // FFEINTRIN_impDACOS //
16337     d__1 = acos(d1);
16338     food_(&d__1);
16339 // FFEINTRIN_impDASIN //
16340     d__1 = asin(d1);
16341     food_(&d__1);
16342 // FFEINTRIN_impDATAN //
16343     d__1 = atan(d1);
16344     food_(&d__1);
16345 // FFEINTRIN_impDATAN2 //
16346     d__1 = atan2(d1, d2);
16347     food_(&d__1);
16348 // FFEINTRIN_impDCOS //
16349     d__1 = cos(d1);
16350     food_(&d__1);
16351 // FFEINTRIN_impDCOSH //
16352     d__1 = cosh(d1);
16353     food_(&d__1);
16354 // FFEINTRIN_impDDIM //
16355     d__1 = d_dim(&d1, &d2);
16356     food_(&d__1);
16357 // FFEINTRIN_impDEXP //
16358     d__1 = exp(d1);
16359     food_(&d__1);
16360 // FFEINTRIN_impDIM //
16361     r__1 = r_dim(&r1, &r2);
16362     foor_(&r__1);
16363 // FFEINTRIN_impDINT //
16364     d__1 = d_int(&d1);
16365     food_(&d__1);
16366 // FFEINTRIN_impDLOG //
16367     d__1 = log(d1);
16368     food_(&d__1);
16369 // FFEINTRIN_impDLOG10 //
16370     d__1 = d_lg10(&d1);
16371     food_(&d__1);
16372 // FFEINTRIN_impDMAX1 //
16373     d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ;
16374     food_(&d__1);
16375 // FFEINTRIN_impDMIN1 //
16376     d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ;
16377     food_(&d__1);
16378 // FFEINTRIN_impDMOD //
16379     d__1 = d_mod(&d1, &d2);
16380     food_(&d__1);
16381 // FFEINTRIN_impDNINT //
16382     d__1 = d_nint(&d1);
16383     food_(&d__1);
16384 // FFEINTRIN_impDPROD //
16385     d__1 = (doublereal) r1 * r2;
16386     food_(&d__1);
16387 // FFEINTRIN_impDSIGN //
16388     d__1 = d_sign(&d1, &d2);
16389     food_(&d__1);
16390 // FFEINTRIN_impDSIN //
16391     d__1 = sin(d1);
16392     food_(&d__1);
16393 // FFEINTRIN_impDSINH //
16394     d__1 = sinh(d1);
16395     food_(&d__1);
16396 // FFEINTRIN_impDSQRT //
16397     d__1 = sqrt(d1);
16398     food_(&d__1);
16399 // FFEINTRIN_impDTAN //
16400     d__1 = tan(d1);
16401     food_(&d__1);
16402 // FFEINTRIN_impDTANH //
16403     d__1 = tanh(d1);
16404     food_(&d__1);
16405 // FFEINTRIN_impEXP //
16406     r__1 = exp(r1);
16407     foor_(&r__1);
16408 // FFEINTRIN_impIABS //
16409     i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ;
16410     fooi_(&i__1);
16411 // FFEINTRIN_impICHAR //
16412     i__1 = *(unsigned char *)a1;
16413     fooi_(&i__1);
16414 // FFEINTRIN_impIDIM //
16415     i__1 = i_dim(&i1, &i2);
16416     fooi_(&i__1);
16417 // FFEINTRIN_impIDNINT //
16418     i__1 = i_dnnt(&d1);
16419     fooi_(&i__1);
16420 // FFEINTRIN_impINDEX //
16421     i__1 = i_indx(a1, a2, 10L, 10L);
16422     fooi_(&i__1);
16423 // FFEINTRIN_impISIGN //
16424     i__1 = i_sign(&i1, &i2);
16425     fooi_(&i__1);
16426 // FFEINTRIN_impLEN //
16427     i__1 = i_len(a1, 10L);
16428     fooi_(&i__1);
16429 // FFEINTRIN_impLGE //
16430     L__1 = l_ge(a1, a2, 10L, 10L);
16431     fool_(&L__1);
16432 // FFEINTRIN_impLGT //
16433     L__1 = l_gt(a1, a2, 10L, 10L);
16434     fool_(&L__1);
16435 // FFEINTRIN_impLLE //
16436     L__1 = l_le(a1, a2, 10L, 10L);
16437     fool_(&L__1);
16438 // FFEINTRIN_impLLT //
16439     L__1 = l_lt(a1, a2, 10L, 10L);
16440     fool_(&L__1);
16441 // FFEINTRIN_impMAX0 //
16442     i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16443     fooi_(&i__1);
16444 // FFEINTRIN_impMAX1 //
16445     i__1 = (integer) (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16446     fooi_(&i__1);
16447 // FFEINTRIN_impMIN0 //
16448     i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16449     fooi_(&i__1);
16450 // FFEINTRIN_impMIN1 //
16451     i__1 = (integer) (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16452     fooi_(&i__1);
16453 // FFEINTRIN_impMOD //
16454     i__1 = i1 % i2;
16455     fooi_(&i__1);
16456 // FFEINTRIN_impNINT //
16457     i__1 = i_nint(&r1);
16458     fooi_(&i__1);
16459 // FFEINTRIN_impSIGN //
16460     r__1 = r_sign(&r1, &r2);
16461     foor_(&r__1);
16462 // FFEINTRIN_impSIN //
16463     r__1 = sin(r1);
16464     foor_(&r__1);
16465 // FFEINTRIN_impSINH //
16466     r__1 = sinh(r1);
16467     foor_(&r__1);
16468 // FFEINTRIN_impSQRT //
16469     r__1 = sqrt(r1);
16470     foor_(&r__1);
16471 // FFEINTRIN_impTAN //
16472     r__1 = tan(r1);
16473     foor_(&r__1);
16474 // FFEINTRIN_impTANH //
16475     r__1 = tanh(r1);
16476     foor_(&r__1);
16477 // FFEINTRIN_imp_CMPLX_C //
16478     r__1 = c1.r;
16479     r__2 = c2.r;
16480     q__1.r = r__1, q__1.i = r__2;
16481     fooc_(&q__1);
16482 // FFEINTRIN_imp_CMPLX_D //
16483     z__1.r = d1, z__1.i = d2;
16484     fooz_(&z__1);
16485 // FFEINTRIN_imp_CMPLX_I //
16486     r__1 = (real) i1;
16487     r__2 = (real) i2;
16488     q__1.r = r__1, q__1.i = r__2;
16489     fooc_(&q__1);
16490 // FFEINTRIN_imp_CMPLX_R //
16491     q__1.r = r1, q__1.i = r2;
16492     fooc_(&q__1);
16493 // FFEINTRIN_imp_DBLE_C //
16494     d__1 = (doublereal) c1.r;
16495     food_(&d__1);
16496 // FFEINTRIN_imp_DBLE_D //
16497     d__1 = d1;
16498     food_(&d__1);
16499 // FFEINTRIN_imp_DBLE_I //
16500     d__1 = (doublereal) i1;
16501     food_(&d__1);
16502 // FFEINTRIN_imp_DBLE_R //
16503     d__1 = (doublereal) r1;
16504     food_(&d__1);
16505 // FFEINTRIN_imp_INT_C //
16506     i__1 = (integer) c1.r;
16507     fooi_(&i__1);
16508 // FFEINTRIN_imp_INT_D //
16509     i__1 = (integer) d1;
16510     fooi_(&i__1);
16511 // FFEINTRIN_imp_INT_I //
16512     i__1 = i1;
16513     fooi_(&i__1);
16514 // FFEINTRIN_imp_INT_R //
16515     i__1 = (integer) r1;
16516     fooi_(&i__1);
16517 // FFEINTRIN_imp_REAL_C //
16518     r__1 = c1.r;
16519     foor_(&r__1);
16520 // FFEINTRIN_imp_REAL_D //
16521     r__1 = (real) d1;
16522     foor_(&r__1);
16523 // FFEINTRIN_imp_REAL_I //
16524     r__1 = (real) i1;
16525     foor_(&r__1);
16526 // FFEINTRIN_imp_REAL_R //
16527     r__1 = r1;
16528     foor_(&r__1);
16529
16530 // FFEINTRIN_imp_INT_D: //
16531
16532 // FFEINTRIN_specIDINT //
16533     i__1 = (integer) d1;
16534     fooi_(&i__1);
16535
16536 // FFEINTRIN_imp_INT_R: //
16537
16538 // FFEINTRIN_specIFIX //
16539     i__1 = (integer) r1;
16540     fooi_(&i__1);
16541 // FFEINTRIN_specINT //
16542     i__1 = (integer) r1;
16543     fooi_(&i__1);
16544
16545 // FFEINTRIN_imp_REAL_D: //
16546
16547 // FFEINTRIN_specSNGL //
16548     r__1 = (real) d1;
16549     foor_(&r__1);
16550
16551 // FFEINTRIN_imp_REAL_I: //
16552
16553 // FFEINTRIN_specFLOAT //
16554     r__1 = (real) i1;
16555     foor_(&r__1);
16556 // FFEINTRIN_specREAL //
16557     r__1 = (real) i1;
16558     foor_(&r__1);
16559
16560 } // MAIN__ //
16561
16562 -------- (end output file from f2c)
16563
16564 */
16565
16566 #include "gt-f-com.h"
16567 #include "gtype-f.h"