gcc/f/com.c

   1 /* com.c -- Implementation File (module.c template V1.0)
   2    Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001
   3    Free Software Foundation, Inc.
   4    Contributed by James Craig Burley.
   5
   6 This file is part of GNU Fortran.
   7
   8 GNU Fortran is free software; you can redistribute it and/or modify
   9 it under the terms of the GNU General Public License as published by
  10 the Free Software Foundation; either version 2, or (at your option)
  11 any later version.
  12
  13 GNU Fortran is distributed in the hope that it will be useful,
  14 but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 GNU General Public License for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with GNU Fortran; see the file COPYING.  If not, write to
  20 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
  21 02111-1307, USA.
  22
  23    Related Modules:
  24       None
  25
  26    Description:
  27       Contains compiler-specific functions.
  28
  29    Modifications:
  30 */
  31
  32 /* Understanding this module means understanding the interface between
  33    the g77 front end and the gcc back end (or, perhaps, some other
  34    back end).  In here are the functions called by the front end proper
  35    to notify whatever back end is in place about certain things, and
  36    also the back-end-specific functions.  It's a bear to deal with, so
  37    lately I've been trying to simplify things, especially with regard
  38    to the gcc-back-end-specific stuff.
  39
  40    Building expressions generally seems quite easy, but building decls
  41    has been challenging and is undergoing revision.  gcc has several
  42    kinds of decls:
  43
  44    TYPE_DECL -- a type (int, float, struct, function, etc.)
  45    CONST_DECL -- a constant of some type other than function
  46    LABEL_DECL -- a variable or a constant?
  47    PARM_DECL -- an argument to a function (a variable that is a dummy)
  48    RESULT_DECL -- the return value of a function (a variable)
  49    VAR_DECL -- other variable (can hold a ptr-to-function, struct, int, etc.)
  50    FUNCTION_DECL -- a function (either the actual function or an extern ref)
  51    FIELD_DECL -- a field in a struct or union (goes into types)
  52
  53    g77 has a set of functions that somewhat parallels the gcc front end
  54    when it comes to building decls:
  55
  56    Internal Function (one we define, not just declare as extern):
  57    if (is_nested) push_f_function_context ();
  58    start_function (get_identifier ("function_name"), function_type,
  59                    is_nested, is_public);
  60    // for each arg, build PARM_DECL and call push_parm_decl (decl) with it;
  61    store_parm_decls (is_main_program);
  62    ffecom_start_compstmt ();
  63    // for stmts and decls inside function, do appropriate things;
  64    ffecom_end_compstmt ();
  65    finish_function (is_nested);
  66    if (is_nested) pop_f_function_context ();
  67
  68    Everything Else:
  69    tree d;
  70    tree init;
  71    // fill in external, public, static, &c for decl, and
  72    // set DECL_INITIAL to error_mark_node if going to initialize
  73    // set is_top_level TRUE only if not at top level and decl
  74    // must go in top level (i.e. not within current function decl context)
  75    d = start_decl (decl, is_top_level);
  76    init = ...;  // if have initializer
  77    finish_decl (d, init, is_top_level);
  78
  79 */
  80
  81 /* Include files. */
  82
  83 #include "proj.h"
  84 #include "flags.h"
  85 #include "rtl.h"
  86 #include "toplev.h"
  87 #include "tree.h"
  88 #include "output.h"  /* Must follow tree.h so TREE_CODE is defined! */
  89 #include "convert.h"
  90 #include "ggc.h"
  91 #include "diagnostic.h"
  92 #include "langhooks.h"
  93 #include "langhooks-def.h"
  94
  95 /* VMS-specific definitions */
  96 #ifdef VMS
  97 #include <descrip.h>
  98 #define O_RDONLY        0       /* Open arg for Read/Only  */
  99 #define O_WRONLY        1       /* Open arg for Write/Only */
 100 #define read(fd,buf,size)       VMS_read (fd,buf,size)
 101 #define write(fd,buf,size)      VMS_write (fd,buf,size)
 102 #define open(fname,mode,prot)   VMS_open (fname,mode,prot)
 103 #define fopen(fname,mode)       VMS_fopen (fname,mode)
 104 #define freopen(fname,mode,ofile) VMS_freopen (fname,mode,ofile)
 105 #define strncat(dst,src,cnt) VMS_strncat (dst,src,cnt)
 106 #define fstat(fd,stbuf)         VMS_fstat (fd,stbuf)
 107 static int VMS_fstat (), VMS_stat ();
 108 static char * VMS_strncat ();
 109 static int VMS_read ();
 110 static int VMS_write ();
 111 static int VMS_open ();
 112 static FILE * VMS_fopen ();
 113 static FILE * VMS_freopen ();
 114 static void hack_vms_include_specification ();
 115 typedef struct { unsigned :16, :16, :16; } vms_ino_t;
 116 #define ino_t vms_ino_t
 117 #define INCLUDE_LEN_FUDGE 10    /* leave room for VMS syntax conversion */
 118 #endif /* VMS */
 119
 120 #define FFECOM_DETERMINE_TYPES 1 /* for com.h */
 121 #include "com.h"
 122 #include "bad.h"
 123 #include "bld.h"
 124 #include "equiv.h"
 125 #include "expr.h"
 126 #include "implic.h"
 127 #include "info.h"
 128 #include "malloc.h"
 129 #include "src.h"
 130 #include "st.h"
 131 #include "storag.h"
 132 #include "symbol.h"
 133 #include "target.h"
 134 #include "top.h"
 135 #include "type.h"
 136
 137 /* Externals defined here.  */
 138
 139 /* Stream for reading from the input file.  */
 140 FILE *finput;
 141
 142 /* These definitions parallel those in c-decl.c so that code from that
 143    module can be used pretty much as is.  Much of these defs aren't
 144    otherwise used, i.e. by g77 code per se, except some of them are used
 145    to build some of them that are.  The ones that are global (i.e. not
 146    "static") are those that ste.c and such might use (directly
 147    or by using com macros that reference them in their definitions).  */
 148
 149 tree string_type_node;
 150
 151 /* The rest of these are inventions for g77, though there might be
 152    similar things in the C front end.  As they are found, these
 153    inventions should be renamed to be canonical.  Note that only
 154    the ones currently required to be global are so.  */
 155
 156 static tree ffecom_tree_fun_type_void;
 157
 158 tree ffecom_integer_type_node;  /* Abbrev for _tree_type[blah][blah]. */
 159 tree ffecom_integer_zero_node;  /* Like *_*_* with g77's integer type. */
 160 tree ffecom_integer_one_node;   /* " */
 161 tree ffecom_tree_type[FFEINFO_basictype][FFEINFO_kindtype];
 162
 163 /* _fun_type things are the f2c-specific versions.  For -fno-f2c,
 164    just use build_function_type and build_pointer_type on the
 165    appropriate _tree_type array element.  */
 166
 167 static tree ffecom_tree_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
 168 static tree ffecom_tree_ptr_to_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
 169 static tree ffecom_tree_subr_type;
 170 static tree ffecom_tree_ptr_to_subr_type;
 171 static tree ffecom_tree_blockdata_type;
 172
 173 static tree ffecom_tree_xargc_;
 174
 175 ffecomSymbol ffecom_symbol_null_
 176 =
 177 {
 178   NULL_TREE,
 179   NULL_TREE,
 180   NULL_TREE,
 181   NULL_TREE,
 182   false
 183 };
 184 ffeinfoKindtype ffecom_pointer_kind_ = FFEINFO_basictypeNONE;
 185 ffeinfoKindtype ffecom_label_kind_ = FFEINFO_basictypeNONE;
 186
 187 int ffecom_f2c_typecode_[FFEINFO_basictype][FFEINFO_kindtype];
 188 tree ffecom_f2c_integer_type_node;
 189 tree ffecom_f2c_ptr_to_integer_type_node;
 190 tree ffecom_f2c_address_type_node;
 191 tree ffecom_f2c_real_type_node;
 192 tree ffecom_f2c_ptr_to_real_type_node;
 193 tree ffecom_f2c_doublereal_type_node;
 194 tree ffecom_f2c_complex_type_node;
 195 tree ffecom_f2c_doublecomplex_type_node;
 196 tree ffecom_f2c_longint_type_node;
 197 tree ffecom_f2c_logical_type_node;
 198 tree ffecom_f2c_flag_type_node;
 199 tree ffecom_f2c_ftnlen_type_node;
 200 tree ffecom_f2c_ftnlen_zero_node;
 201 tree ffecom_f2c_ftnlen_one_node;
 202 tree ffecom_f2c_ftnlen_two_node;
 203 tree ffecom_f2c_ptr_to_ftnlen_type_node;
 204 tree ffecom_f2c_ftnint_type_node;
 205 tree ffecom_f2c_ptr_to_ftnint_type_node;
 206
 207 /* Simple definitions and enumerations. */
 208
 209 #ifndef FFECOM_sizeMAXSTACKITEM
 210 #define FFECOM_sizeMAXSTACKITEM 32*1024 /* Keep user-declared things
 211                                            larger than this # bytes
 212                                            off stack if possible. */
 213 #endif
 214
 215 /* For systems that have large enough stacks, they should define
 216    this to 0, and here, for ease of use later on, we just undefine
 217    it if it is 0.  */
 218
 219 #if FFECOM_sizeMAXSTACKITEM == 0
 220 #undef FFECOM_sizeMAXSTACKITEM
 221 #endif
 222
 223 typedef enum
 224   {
 225     FFECOM_rttypeVOID_,
 226     FFECOM_rttypeVOIDSTAR_,     /* C's `void *' type. */
 227     FFECOM_rttypeFTNINT_,       /* f2c's `ftnint' type. */
 228     FFECOM_rttypeINTEGER_,      /* f2c's `integer' type. */
 229     FFECOM_rttypeLONGINT_,      /* f2c's `longint' type. */
 230     FFECOM_rttypeLOGICAL_,      /* f2c's `logical' type. */
 231     FFECOM_rttypeREAL_F2C_,     /* f2c's `real' returned as `double'. */
 232     FFECOM_rttypeREAL_GNU_,     /* `real' returned as such. */
 233     FFECOM_rttypeCOMPLEX_F2C_,  /* f2c's `complex' returned via 1st arg. */
 234     FFECOM_rttypeCOMPLEX_GNU_,  /* f2c's `complex' returned directly. */
 235     FFECOM_rttypeDOUBLE_,       /* C's `double' type. */
 236     FFECOM_rttypeDOUBLEREAL_,   /* f2c's `doublereal' type. */
 237     FFECOM_rttypeDBLCMPLX_F2C_, /* f2c's `doublecomplex' returned via 1st arg. */
 238     FFECOM_rttypeDBLCMPLX_GNU_, /* f2c's `doublecomplex' returned directly. */
 239     FFECOM_rttypeCHARACTER_,    /* f2c `char *'/`ftnlen' pair. */
 240     FFECOM_rttype_
 241   } ffecomRttype_;
 242
 243 /* Internal typedefs. */
 244
 245 typedef struct _ffecom_concat_list_ ffecomConcatList_;
 246
 247 /* Private include files. */
 248
 249
 250 /* Internal structure definitions. */
 251
 252 struct _ffecom_concat_list_
 253   {
 254     ffebld *exprs;
 255     int count;
 256     int max;
 257     ffetargetCharacterSize minlen;
 258     ffetargetCharacterSize maxlen;
 259   };
 260
 261 /* Static functions (internal). */
 262
 263 static tree ffecom_arglist_expr_ (const char *argstring, ffebld args);
 264 static tree ffecom_widest_expr_type_ (ffebld list);
 265 static bool ffecom_overlap_ (tree dest_decl, tree dest_offset,
 266                              tree dest_size, tree source_tree,
 267                              ffebld source, bool scalar_arg);
 268 static bool ffecom_args_overlapping_ (tree dest_tree, ffebld dest,
 269                                       tree args, tree callee_commons,
 270                                       bool scalar_args);
 271 static tree ffecom_build_f2c_string_ (int i, const char *s);
 272 static tree ffecom_call_ (tree fn, ffeinfoKindtype kt,
 273                           bool is_f2c_complex, tree type,
 274                           tree args, tree dest_tree,
 275                           ffebld dest, bool *dest_used,
 276                           tree callee_commons, bool scalar_args, tree hook);
 277 static tree ffecom_call_binop_ (tree fn, ffeinfoKindtype kt,
 278                                 bool is_f2c_complex, tree type,
 279                                 ffebld left, ffebld right,
 280                                 tree dest_tree, ffebld dest,
 281                                 bool *dest_used, tree callee_commons,
 282                                 bool scalar_args, bool ref, tree hook);
 283 static void ffecom_char_args_x_ (tree *xitem, tree *length,
 284                                  ffebld expr, bool with_null);
 285 static tree ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy);
 286 static tree ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s);
 287 static ffecomConcatList_
 288   ffecom_concat_list_gather_ (ffecomConcatList_ catlist,
 289                               ffebld expr,
 290                               ffetargetCharacterSize max);
 291 static void ffecom_concat_list_kill_ (ffecomConcatList_ catlist);
 292 static ffecomConcatList_ ffecom_concat_list_new_ (ffebld expr,
 293                                                 ffetargetCharacterSize max);
 294 static void ffecom_debug_kludge_ (tree aggr, const char *aggr_type,
 295                                   ffesymbol member, tree member_type,
 296                                   ffetargetOffset offset);
 297 static void ffecom_do_entry_ (ffesymbol fn, int entrynum);
 298 static tree ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
 299                           bool *dest_used, bool assignp, bool widenp);
 300 static tree ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
 301                                     ffebld dest, bool *dest_used);
 302 static tree ffecom_expr_power_integer_ (ffebld expr);
 303 static void ffecom_expr_transform_ (ffebld expr);
 304 static void ffecom_f2c_make_type_ (tree *type, int tcode, const char *name);
 305 static void ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
 306                                       int code);
 307 static ffeglobal ffecom_finish_global_ (ffeglobal global);
 308 static ffesymbol ffecom_finish_symbol_transform_ (ffesymbol s);
 309 static tree ffecom_get_appended_identifier_ (char us, const char *text);
 310 static tree ffecom_get_external_identifier_ (ffesymbol s);
 311 static tree ffecom_get_identifier_ (const char *text);
 312 static tree ffecom_gen_sfuncdef_ (ffesymbol s,
 313                                   ffeinfoBasictype bt,
 314                                   ffeinfoKindtype kt);
 315 static const char *ffecom_gfrt_args_ (ffecomGfrt ix);
 316 static tree ffecom_gfrt_tree_ (ffecomGfrt ix);
 317 static tree ffecom_init_zero_ (tree decl);
 318 static tree ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
 319                                      tree *maybe_tree);
 320 static tree ffecom_intrinsic_len_ (ffebld expr);
 321 static void ffecom_let_char_ (tree dest_tree,
 322                               tree dest_length,
 323                               ffetargetCharacterSize dest_size,
 324                               ffebld source);
 325 static void ffecom_make_gfrt_ (ffecomGfrt ix);
 326 static void ffecom_member_phase1_ (ffestorag mst, ffestorag st);
 327 static void ffecom_member_phase2_ (ffestorag mst, ffestorag st);
 328 static void ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size,
 329                                       ffebld source);
 330 static void ffecom_push_dummy_decls_ (ffebld dumlist,
 331                                       bool stmtfunc);
 332 static void ffecom_start_progunit_ (void);
 333 static ffesymbol ffecom_sym_transform_ (ffesymbol s);
 334 static ffesymbol ffecom_sym_transform_assign_ (ffesymbol s);
 335 static void ffecom_transform_common_ (ffesymbol s);
 336 static void ffecom_transform_equiv_ (ffestorag st);
 337 static tree ffecom_transform_namelist_ (ffesymbol s);
 338 static void ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
 339                                        tree t);
 340 static void ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
 341                                        tree *size, tree tree);
 342 static tree ffecom_tree_divide_ (tree tree_type, tree left, tree right,
 343                                  tree dest_tree, ffebld dest,
 344                                  bool *dest_used, tree hook);
 345 static tree ffecom_type_localvar_ (ffesymbol s,
 346                                    ffeinfoBasictype bt,
 347                                    ffeinfoKindtype kt);
 348 static tree ffecom_type_namelist_ (void);
 349 static tree ffecom_type_vardesc_ (void);
 350 static tree ffecom_vardesc_ (ffebld expr);
 351 static tree ffecom_vardesc_array_ (ffesymbol s);
 352 static tree ffecom_vardesc_dims_ (ffesymbol s);
 353 static tree ffecom_convert_narrow_ (tree type, tree expr);
 354 static tree ffecom_convert_widen_ (tree type, tree expr);
 355
 356 /* These are static functions that parallel those found in the C front
 357    end and thus have the same names.  */
 358
 359 static tree bison_rule_compstmt_ (void);
 360 static void bison_rule_pushlevel_ (void);
 361 static void delete_block (tree block);
 362 static int duplicate_decls (tree newdecl, tree olddecl);
 363 static void finish_decl (tree decl, tree init, bool is_top_level);
 364 static void finish_function (int nested);
 365 static const char *lang_printable_name (tree decl, int v);
 366 static tree lookup_name_current_level (tree name);
 367 static struct binding_level *make_binding_level (void);
 368 static void pop_f_function_context (void);
 369 static void push_f_function_context (void);
 370 static void push_parm_decl (tree parm);
 371 static tree pushdecl_top_level (tree decl);
 372 static int kept_level_p (void);
 373 static tree storedecls (tree decls);
 374 static void store_parm_decls (int is_main_program);
 375 static tree start_decl (tree decl, bool is_top_level);
 376 static void start_function (tree name, tree type, int nested, int public);
 377 static void ffecom_file_ (const char *name);
 378 static void ffecom_close_include_ (FILE *f);
 379 static int ffecom_decode_include_option_ (char *spec);
 380 static FILE *ffecom_open_include_ (char *name, ffewhereLine l,
 381                                    ffewhereColumn c);
 382
 383 /* Static objects accessed by functions in this module. */
 384
 385 static ffesymbol ffecom_primary_entry_ = NULL;
 386 static ffesymbol ffecom_nested_entry_ = NULL;
 387 static ffeinfoKind ffecom_primary_entry_kind_;
 388 static bool ffecom_primary_entry_is_proc_;
 389 static tree ffecom_outer_function_decl_;
 390 static tree ffecom_previous_function_decl_;
 391 static tree ffecom_which_entrypoint_decl_;
 392 static tree ffecom_float_zero_ = NULL_TREE;
 393 static tree ffecom_float_half_ = NULL_TREE;
 394 static tree ffecom_double_zero_ = NULL_TREE;
 395 static tree ffecom_double_half_ = NULL_TREE;
 396 static tree ffecom_func_result_;/* For functions. */
 397 static tree ffecom_func_length_;/* For CHARACTER fns. */
 398 static ffebld ffecom_list_blockdata_;
 399 static ffebld ffecom_list_common_;
 400 static ffebld ffecom_master_arglist_;
 401 static ffeinfoBasictype ffecom_master_bt_;
 402 static ffeinfoKindtype ffecom_master_kt_;
 403 static ffetargetCharacterSize ffecom_master_size_;
 404 static int ffecom_num_fns_ = 0;
 405 static int ffecom_num_entrypoints_ = 0;
 406 static bool ffecom_is_altreturning_ = FALSE;
 407 static tree ffecom_multi_type_node_;
 408 static tree ffecom_multi_retval_;
 409 static tree
 410   ffecom_multi_fields_[FFEINFO_basictype][FFEINFO_kindtype];
 411 static bool ffecom_member_namelisted_;  /* _member_phase1_ namelisted? */
 412 static bool ffecom_doing_entry_ = FALSE;
 413 static bool ffecom_transform_only_dummies_ = FALSE;
 414 static int ffecom_typesize_pointer_;
 415 static int ffecom_typesize_integer1_;
 416
 417 /* Holds pointer-to-function expressions.  */
 418
 419 static tree ffecom_gfrt_[FFECOM_gfrt]
 420 =
 421 {
 422 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NULL_TREE,
 423 #include "com-rt.def"
 424 #undef DEFGFRT
 425 };
 426
 427 /* Holds the external names of the functions.  */
 428
 429 static const char *const ffecom_gfrt_name_[FFECOM_gfrt]
 430 =
 431 {
 432 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NAME,
 433 #include "com-rt.def"
 434 #undef DEFGFRT
 435 };
 436
 437 /* Whether the function returns.  */
 438
 439 static bool ffecom_gfrt_volatile_[FFECOM_gfrt]
 440 =
 441 {
 442 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) VOLATILE,
 443 #include "com-rt.def"
 444 #undef DEFGFRT
 445 };
 446
 447 /* Whether the function returns type complex.  */
 448
 449 static bool ffecom_gfrt_complex_[FFECOM_gfrt]
 450 =
 451 {
 452 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) COMPLEX,
 453 #include "com-rt.def"
 454 #undef DEFGFRT
 455 };
 456
 457 /* Whether the function is const
 458    (i.e., has no side effects and only depends on its arguments).  */
 459
 460 static bool ffecom_gfrt_const_[FFECOM_gfrt]
 461 =
 462 {
 463 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) CONST,
 464 #include "com-rt.def"
 465 #undef DEFGFRT
 466 };
 467
 468 /* Type code for the function return value.  */
 469
 470 static ffecomRttype_ ffecom_gfrt_type_[FFECOM_gfrt]
 471 =
 472 {
 473 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) TYPE,
 474 #include "com-rt.def"
 475 #undef DEFGFRT
 476 };
 477
 478 /* String of codes for the function's arguments.  */
 479
 480 static const char *const ffecom_gfrt_argstring_[FFECOM_gfrt]
 481 =
 482 {
 483 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) ARGS,
 484 #include "com-rt.def"
 485 #undef DEFGFRT
 486 };
 487
 488 /* Internal macros. */
 489
 490 /* We let tm.h override the types used here, to handle trivial differences
 491    such as the choice of unsigned int or long unsigned int for size_t.
 492    When machines start needing nontrivial differences in the size type,
 493    it would be best to do something here to figure out automatically
 494    from other information what type to use.  */
 495
 496 #ifndef SIZE_TYPE
 497 #define SIZE_TYPE "long unsigned int"
 498 #endif
 499
 500 #define ffecom_concat_list_count_(catlist) ((catlist).count)
 501 #define ffecom_concat_list_expr_(catlist,i) ((catlist).exprs[(i)])
 502 #define ffecom_concat_list_maxlen_(catlist) ((catlist).maxlen)
 503 #define ffecom_concat_list_minlen_(catlist) ((catlist).minlen)
 504
 505 #define ffecom_char_args_(i,l,e) ffecom_char_args_x_((i),(l),(e),FALSE)
 506 #define ffecom_char_args_with_null_(i,l,e) ffecom_char_args_x_((i),(l),(e),TRUE)
 507
 508 /* For each binding contour we allocate a binding_level structure
 509  * which records the names defined in that contour.
 510  * Contours include:
 511  *  0) the global one
 512  *  1) one for each function definition,
 513  *     where internal declarations of the parameters appear.
 514  *
 515  * The current meaning of a name can be found by searching the levels from
 516  * the current one out to the global one.
 517  */
 518
 519 /* Note that the information in the `names' component of the global contour
 520    is duplicated in the IDENTIFIER_GLOBAL_VALUEs of all identifiers.  */
 521
 522 struct binding_level
 523   {
 524     /* A chain of _DECL nodes for all variables, constants, functions,
 525        and typedef types.  These are in the reverse of the order supplied.
 526      */
 527     tree names;
 528
 529     /* For each level (except not the global one),
 530        a chain of BLOCK nodes for all the levels
 531        that were entered and exited one level down.  */
 532     tree blocks;
 533
 534     /* The BLOCK node for this level, if one has been preallocated.
 535        If 0, the BLOCK is allocated (if needed) when the level is popped.  */
 536     tree this_block;
 537
 538     /* The binding level which this one is contained in (inherits from).  */
 539     struct binding_level *level_chain;
 540
 541     /* 0: no ffecom_prepare_* functions called at this level yet;
 542        1: ffecom_prepare* functions called, except not ffecom_prepare_end;
 543        2: ffecom_prepare_end called.  */
 544     int prep_state;
 545   };
 546
 547 #define NULL_BINDING_LEVEL (struct binding_level *) NULL
 548
 549 /* The binding level currently in effect.  */
 550
 551 static struct binding_level *current_binding_level;
 552
 553 /* A chain of binding_level structures awaiting reuse.  */
 554
 555 static struct binding_level *free_binding_level;
 556
 557 /* The outermost binding level, for names of file scope.
 558    This is created when the compiler is started and exists
 559    through the entire run.  */
 560
 561 static struct binding_level *global_binding_level;
 562
 563 /* Binding level structures are initialized by copying this one.  */
 564
 565 static struct binding_level clear_binding_level
 566 =
 567 {NULL, NULL, NULL, NULL_BINDING_LEVEL, 0};
 568
 569 /* Language-dependent contents of an identifier.  */
 570
 571 struct lang_identifier
 572   {
 573     struct tree_identifier ignore;
 574     tree global_value, local_value, label_value;
 575     bool invented;
 576   };
 577
 578 /* Macros for access to language-specific slots in an identifier.  */
 579 /* Each of these slots contains a DECL node or null.  */
 580
 581 /* This represents the value which the identifier has in the
 582    file-scope namespace.  */
 583 #define IDENTIFIER_GLOBAL_VALUE(NODE)   \
 584   (((struct lang_identifier *)(NODE))->global_value)
 585 /* This represents the value which the identifier has in the current
 586    scope.  */
 587 #define IDENTIFIER_LOCAL_VALUE(NODE)    \
 588   (((struct lang_identifier *)(NODE))->local_value)
 589 /* This represents the value which the identifier has as a label in
 590    the current label scope.  */
 591 #define IDENTIFIER_LABEL_VALUE(NODE)    \
 592   (((struct lang_identifier *)(NODE))->label_value)
 593 /* This is nonzero if the identifier was "made up" by g77 code.  */
 594 #define IDENTIFIER_INVENTED(NODE)       \
 595   (((struct lang_identifier *)(NODE))->invented)
 596
 597 /* In identifiers, C uses the following fields in a special way:
 598    TREE_PUBLIC        to record that there was a previous local extern decl.
 599    TREE_USED          to record that such a decl was used.
 600    TREE_ADDRESSABLE   to record that the address of such a decl was used.  */
 601
 602 /* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function
 603    that have names.  Here so we can clear out their names' definitions
 604    at the end of the function.  */
 605
 606 static tree named_labels;
 607
 608 /* A list of LABEL_DECLs from outer contexts that are currently shadowed.  */
 609
 610 static tree shadowed_labels;
 611 \f
 612 /* Return the subscript expression, modified to do range-checking.
 613
 614    `array' is the array to be checked against.
 615    `element' is the subscript expression to check.
 616    `dim' is the dimension number (starting at 0).
 617    `total_dims' is the total number of dimensions (0 for CHARACTER substring).
 618 */
 619
 620 static tree
 621 ffecom_subscript_check_ (tree array, tree element, int dim, int total_dims,
 622                          const char *array_name)
 623 {
 624   tree low = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
 625   tree high = TYPE_MAX_VALUE (TYPE_DOMAIN (array));
 626   tree cond;
 627   tree die;
 628   tree args;
 629
 630   if (element == error_mark_node)
 631     return element;
 632
 633   if (TREE_TYPE (low) != TREE_TYPE (element))
 634     {
 635       if (TYPE_PRECISION (TREE_TYPE (low))
 636           > TYPE_PRECISION (TREE_TYPE (element)))
 637         element = convert (TREE_TYPE (low), element);
 638       else
 639         {
 640           low = convert (TREE_TYPE (element), low);
 641           if (high)
 642             high = convert (TREE_TYPE (element), high);
 643         }
 644     }
 645
 646   element = ffecom_save_tree (element);
 647   if (total_dims == 0)
 648     {
 649       /* Special handling for substring range checks.  Fortran allows the
 650          end subscript < begin subscript, which means that expressions like
 651        string(1:0) are valid (and yield a null string).  In view of this,
 652        enforce two simpler conditions:
 653           1) element<=high for end-substring;
 654           2) element>=low for start-substring.
 655        Run-time character movement will enforce remaining conditions.
 656
 657        More complicated checks would be better, but present structure only
 658        provides one index element at a time, so it is not possible to
 659        enforce a check of both i and j in string(i:j).  If it were, the
 660        complete set of rules would read,
 661          if ( ((j<i) && ((low<=i<=high) || (low<=j<=high))) ||
 662               ((low<=i<=high) && (low<=j<=high)) )
 663            ok ;
 664          else
 665            range error ;
 666       */
 667       if (dim)
 668         cond = ffecom_2 (LE_EXPR, integer_type_node, element, high);
 669       else
 670         cond = ffecom_2 (LE_EXPR, integer_type_node, low, element);
 671     }
 672   else
 673     {
 674       /* Array reference substring range checking.  */
 675
 676       cond = ffecom_2 (LE_EXPR, integer_type_node,
 677                      low,
 678                      element);
 679       if (high)
 680         {
 681           cond = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
 682                          cond,
 683                          ffecom_2 (LE_EXPR, integer_type_node,
 684                                    element,
 685                                    high));
 686         }
 687     }
 688
 689   {
 690     int len;
 691     char *proc;
 692     char *var;
 693     tree arg3;
 694     tree arg2;
 695     tree arg1;
 696     tree arg4;
 697
 698     switch (total_dims)
 699       {
 700       case 0:
 701         var = concat (array_name, "[", (dim ? "end" : "start"),
 702                       "-substring]", NULL);
 703         len = strlen (var) + 1;
 704         arg1 = build_string (len, var);
 705         free (var);
 706         break;
 707
 708       case 1:
 709         len = strlen (array_name) + 1;
 710         arg1 = build_string (len, array_name);
 711         break;
 712
 713       default:
 714         var = xmalloc (strlen (array_name) + 40);
 715         sprintf (var, "%s[subscript-%d-of-%d]",
 716                  array_name,
 717                  dim + 1, total_dims);
 718         len = strlen (var) + 1;
 719         arg1 = build_string (len, var);
 720         free (var);
 721         break;
 722       }
 723
 724     TREE_TYPE (arg1)
 725       = build_type_variant (build_array_type (char_type_node,
 726                                               build_range_type
 727                                               (integer_type_node,
 728                                                integer_one_node,
 729                                                build_int_2 (len, 0))),
 730                             1, 0);
 731     TREE_CONSTANT (arg1) = 1;
 732     TREE_STATIC (arg1) = 1;
 733     arg1 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg1)),
 734                      arg1);
 735
 736     /* s_rnge adds one to the element to print it, so bias against
 737        that -- want to print a faithful *subscript* value.  */
 738     arg2 = convert (ffecom_f2c_ftnint_type_node,
 739                     ffecom_2 (MINUS_EXPR,
 740                               TREE_TYPE (element),
 741                               element,
 742                               convert (TREE_TYPE (element),
 743                                        integer_one_node)));
 744
 745     proc = concat (input_filename, "/",
 746                    IDENTIFIER_POINTER (DECL_NAME (current_function_decl)),
 747                    NULL);
 748     len = strlen (proc) + 1;
 749     arg3 = build_string (len, proc);
 750
 751     free (proc);
 752
 753     TREE_TYPE (arg3)
 754       = build_type_variant (build_array_type (char_type_node,
 755                                               build_range_type
 756                                               (integer_type_node,
 757                                                integer_one_node,
 758                                                build_int_2 (len, 0))),
 759                             1, 0);
 760     TREE_CONSTANT (arg3) = 1;
 761     TREE_STATIC (arg3) = 1;
 762     arg3 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg3)),
 763                      arg3);
 764
 765     arg4 = convert (ffecom_f2c_ftnint_type_node,
 766                     build_int_2 (lineno, 0));
 767
 768     arg1 = build_tree_list (NULL_TREE, arg1);
 769     arg2 = build_tree_list (NULL_TREE, arg2);
 770     arg3 = build_tree_list (NULL_TREE, arg3);
 771     arg4 = build_tree_list (NULL_TREE, arg4);
 772     TREE_CHAIN (arg3) = arg4;
 773     TREE_CHAIN (arg2) = arg3;
 774     TREE_CHAIN (arg1) = arg2;
 775
 776     args = arg1;
 777   }
 778   die = ffecom_call_gfrt (FFECOM_gfrtRANGE,
 779                           args, NULL_TREE);
 780   TREE_SIDE_EFFECTS (die) = 1;
 781
 782   element = ffecom_3 (COND_EXPR,
 783                       TREE_TYPE (element),
 784                       cond,
 785                       element,
 786                       die);
 787
 788   return element;
 789 }
 790
 791 /* Return the computed element of an array reference.
 792
 793    `item' is NULL_TREE, or the transformed pointer to the array.
 794    `expr' is the original opARRAYREF expression, which is transformed
 795      if `item' is NULL_TREE.
 796    `want_ptr' is non-zero if a pointer to the element, instead of
 797      the element itself, is to be returned.  */
 798
 799 static tree
 800 ffecom_arrayref_ (tree item, ffebld expr, int want_ptr)
 801 {
 802   ffebld dims[FFECOM_dimensionsMAX];
 803   int i;
 804   int total_dims;
 805   int flatten = ffe_is_flatten_arrays ();
 806   int need_ptr;
 807   tree array;
 808   tree element;
 809   tree tree_type;
 810   tree tree_type_x;
 811   const char *array_name;
 812   ffetype type;
 813   ffebld list;
 814
 815   if (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER)
 816     array_name = ffesymbol_text (ffebld_symter (ffebld_left (expr)));
 817   else
 818     array_name = "[expr?]";
 819
 820   /* Build up ARRAY_REFs in reverse order (since we're column major
 821      here in Fortran land). */
 822
 823   for (i = 0, list = ffebld_right (expr);
 824        list != NULL;
 825        ++i, list = ffebld_trail (list))
 826     {
 827       dims[i] = ffebld_head (list);
 828       type = ffeinfo_type (ffebld_basictype (dims[i]),
 829                            ffebld_kindtype (dims[i]));
 830       if (! flatten
 831           && ffecom_typesize_pointer_ > ffecom_typesize_integer1_
 832           && ffetype_size (type) > ffecom_typesize_integer1_)
 833         /* E.g. ARRAY(INDEX), given INTEGER*8 INDEX, on a system with 64-bit
 834            pointers and 32-bit integers.  Do the full 64-bit pointer
 835            arithmetic, for codes using arrays for nonstandard heap-like
 836            work.  */
 837         flatten = 1;
 838     }
 839
 840   total_dims = i;
 841
 842   need_ptr = want_ptr || flatten;
 843
 844   if (! item)
 845     {
 846       if (need_ptr)
 847         item = ffecom_ptr_to_expr (ffebld_left (expr));
 848       else
 849         item = ffecom_expr (ffebld_left (expr));
 850
 851       if (item == error_mark_node)
 852         return item;
 853
 854       if (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereFLEETING
 855           && ! mark_addressable (item))
 856         return error_mark_node;
 857     }
 858
 859   if (item == error_mark_node)
 860     return item;
 861
 862   if (need_ptr)
 863     {
 864       tree min;
 865
 866       for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
 867            i >= 0;
 868            --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array)))
 869         {
 870           min = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
 871           element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
 872           if (flag_bounds_check)
 873             element = ffecom_subscript_check_ (array, element, i, total_dims,
 874                                                array_name);
 875           if (element == error_mark_node)
 876             return element;
 877
 878           /* Widen integral arithmetic as desired while preserving
 879              signedness.  */
 880           tree_type = TREE_TYPE (element);
 881           tree_type_x = tree_type;
 882           if (tree_type
 883               && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
 884               && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
 885             tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
 886
 887           if (TREE_TYPE (min) != tree_type_x)
 888             min = convert (tree_type_x, min);
 889           if (TREE_TYPE (element) != tree_type_x)
 890             element = convert (tree_type_x, element);
 891
 892           item = ffecom_2 (PLUS_EXPR,
 893                            build_pointer_type (TREE_TYPE (array)),
 894                            item,
 895                            size_binop (MULT_EXPR,
 896                                        size_in_bytes (TREE_TYPE (array)),
 897                                        convert (sizetype,
 898                                                 fold (build (MINUS_EXPR,
 899                                                              tree_type_x,
 900                                                              element, min)))));
 901         }
 902       if (! want_ptr)
 903         {
 904           item = ffecom_1 (INDIRECT_REF,
 905                            TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
 906                            item);
 907         }
 908     }
 909   else
 910     {
 911       for (--i;
 912            i >= 0;
 913            --i)
 914         {
 915           array = TYPE_MAIN_VARIANT (TREE_TYPE (item));
 916
 917           element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
 918           if (flag_bounds_check)
 919             element = ffecom_subscript_check_ (array, element, i, total_dims,
 920                                                array_name);
 921           if (element == error_mark_node)
 922             return element;
 923
 924           /* Widen integral arithmetic as desired while preserving
 925              signedness.  */
 926           tree_type = TREE_TYPE (element);
 927           tree_type_x = tree_type;
 928           if (tree_type
 929               && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
 930               && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
 931             tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
 932
 933           element = convert (tree_type_x, element);
 934
 935           item = ffecom_2 (ARRAY_REF,
 936                            TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
 937                            item,
 938                            element);
 939         }
 940     }
 941
 942   return item;
 943 }
 944
 945 /* This is like gcc's stabilize_reference -- in fact, most of the code
 946    comes from that -- but it handles the situation where the reference
 947    is going to have its subparts picked at, and it shouldn't change
 948    (or trigger extra invocations of functions in the subtrees) due to
 949    this.  save_expr is a bit overzealous, because we don't need the
 950    entire thing calculated and saved like a temp.  So, for DECLs, no
 951    change is needed, because these are stable aggregates, and ARRAY_REF
 952    and such might well be stable too, but for things like calculations,
 953    we do need to calculate a snapshot of a value before picking at it.  */
 954
 955 static tree
 956 ffecom_stabilize_aggregate_ (tree ref)
 957 {
 958   tree result;
 959   enum tree_code code = TREE_CODE (ref);
 960
 961   switch (code)
 962     {
 963     case VAR_DECL:
 964     case PARM_DECL:
 965     case RESULT_DECL:
 966       /* No action is needed in this case.  */
 967       return ref;
 968
 969     case NOP_EXPR:
 970     case CONVERT_EXPR:
 971     case FLOAT_EXPR:
 972     case FIX_TRUNC_EXPR:
 973     case FIX_FLOOR_EXPR:
 974     case FIX_ROUND_EXPR:
 975     case FIX_CEIL_EXPR:
 976       result = build_nt (code, stabilize_reference (TREE_OPERAND (ref, 0)));
 977       break;
 978
 979     case INDIRECT_REF:
 980       result = build_nt (INDIRECT_REF,
 981                          stabilize_reference_1 (TREE_OPERAND (ref, 0)));
 982       break;
 983
 984     case COMPONENT_REF:
 985       result = build_nt (COMPONENT_REF,
 986                          stabilize_reference (TREE_OPERAND (ref, 0)),
 987                          TREE_OPERAND (ref, 1));
 988       break;
 989
 990     case BIT_FIELD_REF:
 991       result = build_nt (BIT_FIELD_REF,
 992                          stabilize_reference (TREE_OPERAND (ref, 0)),
 993                          stabilize_reference_1 (TREE_OPERAND (ref, 1)),
 994                          stabilize_reference_1 (TREE_OPERAND (ref, 2)));
 995       break;
 996
 997     case ARRAY_REF:
 998       result = build_nt (ARRAY_REF,
 999                          stabilize_reference (TREE_OPERAND (ref, 0)),
1000                          stabilize_reference_1 (TREE_OPERAND (ref, 1)));
1001       break;
1002
1003     case COMPOUND_EXPR:
1004       result = build_nt (COMPOUND_EXPR,
1005                          stabilize_reference_1 (TREE_OPERAND (ref, 0)),
1006                          stabilize_reference (TREE_OPERAND (ref, 1)));
1007       break;
1008
1009     case RTL_EXPR:
1010       abort ();
1011
1012
1013     default:
1014       return save_expr (ref);
1015
1016     case ERROR_MARK:
1017       return error_mark_node;
1018     }
1019
1020   TREE_TYPE (result) = TREE_TYPE (ref);
1021   TREE_READONLY (result) = TREE_READONLY (ref);
1022   TREE_SIDE_EFFECTS (result) = TREE_SIDE_EFFECTS (ref);
1023   TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref);
1024
1025   return result;
1026 }
1027
1028 /* A rip-off of gcc's convert.c convert_to_complex function,
1029    reworked to handle complex implemented as C structures
1030    (RECORD_TYPE with two fields, real and imaginary `r' and `i').  */
1031
1032 static tree
1033 ffecom_convert_to_complex_ (tree type, tree expr)
1034 {
1035   register enum tree_code form = TREE_CODE (TREE_TYPE (expr));
1036   tree subtype;
1037
1038   assert (TREE_CODE (type) == RECORD_TYPE);
1039
1040   subtype = TREE_TYPE (TYPE_FIELDS (type));
1041
1042   if (form == REAL_TYPE || form == INTEGER_TYPE || form == ENUMERAL_TYPE)
1043     {
1044       expr = convert (subtype, expr);
1045       return ffecom_2 (COMPLEX_EXPR, type, expr,
1046                        convert (subtype, integer_zero_node));
1047     }
1048
1049   if (form == RECORD_TYPE)
1050     {
1051       tree elt_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr)));
1052       if (TYPE_MAIN_VARIANT (elt_type) == TYPE_MAIN_VARIANT (subtype))
1053         return expr;
1054       else
1055         {
1056           expr = save_expr (expr);
1057           return ffecom_2 (COMPLEX_EXPR,
1058                            type,
1059                            convert (subtype,
1060                                     ffecom_1 (REALPART_EXPR,
1061                                               TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1062                                               expr)),
1063                            convert (subtype,
1064                                     ffecom_1 (IMAGPART_EXPR,
1065                                               TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1066                                               expr)));
1067         }
1068     }
1069
1070   if (form == POINTER_TYPE || form == REFERENCE_TYPE)
1071     error ("pointer value used where a complex was expected");
1072   else
1073     error ("aggregate value used where a complex was expected");
1074
1075   return ffecom_2 (COMPLEX_EXPR, type,
1076                    convert (subtype, integer_zero_node),
1077                    convert (subtype, integer_zero_node));
1078 }
1079
1080 /* Like gcc's convert(), but crashes if widening might happen.  */
1081
1082 static tree
1083 ffecom_convert_narrow_ (type, expr)
1084      tree type, expr;
1085 {
1086   register tree e = expr;
1087   register enum tree_code code = TREE_CODE (type);
1088
1089   if (type == TREE_TYPE (e)
1090       || TREE_CODE (e) == ERROR_MARK)
1091     return e;
1092   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1093     return fold (build1 (NOP_EXPR, type, e));
1094   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1095       || code == ERROR_MARK)
1096     return error_mark_node;
1097   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1098     {
1099       assert ("void value not ignored as it ought to be" == NULL);
1100       return error_mark_node;
1101     }
1102   assert (code != VOID_TYPE);
1103   if ((code != RECORD_TYPE)
1104       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1105     assert ("converting COMPLEX to REAL" == NULL);
1106   assert (code != ENUMERAL_TYPE);
1107   if (code == INTEGER_TYPE)
1108     {
1109       assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1110                && TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)))
1111               || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1112                   && (TYPE_PRECISION (type)
1113                       == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1114       return fold (convert_to_integer (type, e));
1115     }
1116   if (code == POINTER_TYPE)
1117     {
1118       assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1119       return fold (convert_to_pointer (type, e));
1120     }
1121   if (code == REAL_TYPE)
1122     {
1123       assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1124       assert (TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)));
1125       return fold (convert_to_real (type, e));
1126     }
1127   if (code == COMPLEX_TYPE)
1128     {
1129       assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1130       assert (TYPE_PRECISION (TREE_TYPE (type)) <= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1131       return fold (convert_to_complex (type, e));
1132     }
1133   if (code == RECORD_TYPE)
1134     {
1135       assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1136       /* Check that at least the first field name agrees.  */
1137       assert (DECL_NAME (TYPE_FIELDS (type))
1138               == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1139       assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1140               <= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1141       if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1142           == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1143         return e;
1144       return fold (ffecom_convert_to_complex_ (type, e));
1145     }
1146
1147   assert ("conversion to non-scalar type requested" == NULL);
1148   return error_mark_node;
1149 }
1150
1151 /* Like gcc's convert(), but crashes if narrowing might happen.  */
1152
1153 static tree
1154 ffecom_convert_widen_ (type, expr)
1155      tree type, expr;
1156 {
1157   register tree e = expr;
1158   register enum tree_code code = TREE_CODE (type);
1159
1160   if (type == TREE_TYPE (e)
1161       || TREE_CODE (e) == ERROR_MARK)
1162     return e;
1163   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1164     return fold (build1 (NOP_EXPR, type, e));
1165   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1166       || code == ERROR_MARK)
1167     return error_mark_node;
1168   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1169     {
1170       assert ("void value not ignored as it ought to be" == NULL);
1171       return error_mark_node;
1172     }
1173   assert (code != VOID_TYPE);
1174   if ((code != RECORD_TYPE)
1175       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1176     assert ("narrowing COMPLEX to REAL" == NULL);
1177   assert (code != ENUMERAL_TYPE);
1178   if (code == INTEGER_TYPE)
1179     {
1180       assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1181                && TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)))
1182               || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1183                   && (TYPE_PRECISION (type)
1184                       == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1185       return fold (convert_to_integer (type, e));
1186     }
1187   if (code == POINTER_TYPE)
1188     {
1189       assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1190       return fold (convert_to_pointer (type, e));
1191     }
1192   if (code == REAL_TYPE)
1193     {
1194       assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1195       assert (TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)));
1196       return fold (convert_to_real (type, e));
1197     }
1198   if (code == COMPLEX_TYPE)
1199     {
1200       assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1201       assert (TYPE_PRECISION (TREE_TYPE (type)) >= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1202       return fold (convert_to_complex (type, e));
1203     }
1204   if (code == RECORD_TYPE)
1205     {
1206       assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1207       /* Check that at least the first field name agrees.  */
1208       assert (DECL_NAME (TYPE_FIELDS (type))
1209               == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1210       assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1211               >= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1212       if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1213           == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1214         return e;
1215       return fold (ffecom_convert_to_complex_ (type, e));
1216     }
1217
1218   assert ("conversion to non-scalar type requested" == NULL);
1219   return error_mark_node;
1220 }
1221
1222 /* Handles making a COMPLEX type, either the standard
1223    (but buggy?) gbe way, or the safer (but less elegant?)
1224    f2c way.  */
1225
1226 static tree
1227 ffecom_make_complex_type_ (tree subtype)
1228 {
1229   tree type;
1230   tree realfield;
1231   tree imagfield;
1232
1233   if (ffe_is_emulate_complex ())
1234     {
1235       type = make_node (RECORD_TYPE);
1236       realfield = ffecom_decl_field (type, NULL_TREE, "r", subtype);
1237       imagfield = ffecom_decl_field (type, realfield, "i", subtype);
1238       TYPE_FIELDS (type) = realfield;
1239       layout_type (type);
1240     }
1241   else
1242     {
1243       type = make_node (COMPLEX_TYPE);
1244       TREE_TYPE (type) = subtype;
1245       layout_type (type);
1246     }
1247
1248   return type;
1249 }
1250
1251 /* Chooses either the gbe or the f2c way to build a
1252    complex constant.  */
1253
1254 static tree
1255 ffecom_build_complex_constant_ (tree type, tree realpart, tree imagpart)
1256 {
1257   tree bothparts;
1258
1259   if (ffe_is_emulate_complex ())
1260     {
1261       bothparts = build_tree_list (TYPE_FIELDS (type), realpart);
1262       TREE_CHAIN (bothparts) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), imagpart);
1263       bothparts = build (CONSTRUCTOR, type, NULL_TREE, bothparts);
1264     }
1265   else
1266     {
1267       bothparts = build_complex (type, realpart, imagpart);
1268     }
1269
1270   return bothparts;
1271 }
1272
1273 static tree
1274 ffecom_arglist_expr_ (const char *c, ffebld expr)
1275 {
1276   tree list;
1277   tree *plist = &list;
1278   tree trail = NULL_TREE;       /* Append char length args here. */
1279   tree *ptrail = &trail;
1280   tree length;
1281   ffebld exprh;
1282   tree item;
1283   bool ptr = FALSE;
1284   tree wanted = NULL_TREE;
1285   static char zed[] = "0";
1286
1287   if (c == NULL)
1288     c = &zed[0];
1289
1290   while (expr != NULL)
1291     {
1292       if (*c != '\0')
1293         {
1294           ptr = FALSE;
1295           if (*c == '&')
1296             {
1297               ptr = TRUE;
1298               ++c;
1299             }
1300           switch (*(c++))
1301             {
1302             case '\0':
1303               ptr = TRUE;
1304               wanted = NULL_TREE;
1305               break;
1306
1307             case 'a':
1308               assert (ptr);
1309               wanted = NULL_TREE;
1310               break;
1311
1312             case 'c':
1313               wanted = ffecom_f2c_complex_type_node;
1314               break;
1315
1316             case 'd':
1317               wanted = ffecom_f2c_doublereal_type_node;
1318               break;
1319
1320             case 'e':
1321               wanted = ffecom_f2c_doublecomplex_type_node;
1322               break;
1323
1324             case 'f':
1325               wanted = ffecom_f2c_real_type_node;
1326               break;
1327
1328             case 'i':
1329               wanted = ffecom_f2c_integer_type_node;
1330               break;
1331
1332             case 'j':
1333               wanted = ffecom_f2c_longint_type_node;
1334               break;
1335
1336             default:
1337               assert ("bad argstring code" == NULL);
1338               wanted = NULL_TREE;
1339               break;
1340             }
1341         }
1342
1343       exprh = ffebld_head (expr);
1344       if (exprh == NULL)
1345         wanted = NULL_TREE;
1346
1347       if ((wanted == NULL_TREE)
1348           || (ptr
1349               && (TYPE_MODE
1350                   (ffecom_tree_type[ffeinfo_basictype (ffebld_info (exprh))]
1351                    [ffeinfo_kindtype (ffebld_info (exprh))])
1352                    == TYPE_MODE (wanted))))
1353         *plist
1354           = build_tree_list (NULL_TREE,
1355                              ffecom_arg_ptr_to_expr (exprh,
1356                                                      &length));
1357       else
1358         {
1359           item = ffecom_arg_expr (exprh, &length);
1360           item = ffecom_convert_widen_ (wanted, item);
1361           if (ptr)
1362             {
1363               item = ffecom_1 (ADDR_EXPR,
1364                                build_pointer_type (TREE_TYPE (item)),
1365                                item);
1366             }
1367           *plist
1368             = build_tree_list (NULL_TREE,
1369                                item);
1370         }
1371
1372       plist = &TREE_CHAIN (*plist);
1373       expr = ffebld_trail (expr);
1374       if (length != NULL_TREE)
1375         {
1376           *ptrail = build_tree_list (NULL_TREE, length);
1377           ptrail = &TREE_CHAIN (*ptrail);
1378         }
1379     }
1380
1381   /* We've run out of args in the call; if the implementation expects
1382      more, supply null pointers for them, which the implementation can
1383      check to see if an arg was omitted. */
1384
1385   while (*c != '\0' && *c != '0')
1386     {
1387       if (*c == '&')
1388         ++c;
1389       else
1390         assert ("missing arg to run-time routine!" == NULL);
1391
1392       switch (*(c++))
1393         {
1394         case '\0':
1395         case 'a':
1396         case 'c':
1397         case 'd':
1398         case 'e':
1399         case 'f':
1400         case 'i':
1401         case 'j':
1402           break;
1403
1404         default:
1405           assert ("bad arg string code" == NULL);
1406           break;
1407         }
1408       *plist
1409         = build_tree_list (NULL_TREE,
1410                            null_pointer_node);
1411       plist = &TREE_CHAIN (*plist);
1412     }
1413
1414   *plist = trail;
1415
1416   return list;
1417 }
1418
1419 static tree
1420 ffecom_widest_expr_type_ (ffebld list)
1421 {
1422   ffebld item;
1423   ffebld widest = NULL;
1424   ffetype type;
1425   ffetype widest_type = NULL;
1426   tree t;
1427
1428   for (; list != NULL; list = ffebld_trail (list))
1429     {
1430       item = ffebld_head (list);
1431       if (item == NULL)
1432         continue;
1433       if ((widest != NULL)
1434           && (ffeinfo_basictype (ffebld_info (item))
1435               != ffeinfo_basictype (ffebld_info (widest))))
1436         continue;
1437       type = ffeinfo_type (ffeinfo_basictype (ffebld_info (item)),
1438                            ffeinfo_kindtype (ffebld_info (item)));
1439       if ((widest == FFEINFO_kindtypeNONE)
1440           || (ffetype_size (type)
1441               > ffetype_size (widest_type)))
1442         {
1443           widest = item;
1444           widest_type = type;
1445         }
1446     }
1447
1448   assert (widest != NULL);
1449   t = ffecom_tree_type[ffeinfo_basictype (ffebld_info (widest))]
1450     [ffeinfo_kindtype (ffebld_info (widest))];
1451   assert (t != NULL_TREE);
1452   return t;
1453 }
1454
1455 /* Check whether a partial overlap between two expressions is possible.
1456
1457    Can *starting* to write a portion of expr1 change the value
1458    computed (perhaps already, *partially*) by expr2?
1459
1460    Currently, this is a concern only for a COMPLEX expr1.  But if it
1461    isn't in COMMON or local EQUIVALENCE, since we don't support
1462    aliasing of arguments, it isn't a concern.  */
1463
1464 static bool
1465 ffecom_possible_partial_overlap_ (ffebld expr1, ffebld expr2 ATTRIBUTE_UNUSED)
1466 {
1467   ffesymbol sym;
1468   ffestorag st;
1469
1470   switch (ffebld_op (expr1))
1471     {
1472     case FFEBLD_opSYMTER:
1473       sym = ffebld_symter (expr1);
1474       break;
1475
1476     case FFEBLD_opARRAYREF:
1477       if (ffebld_op (ffebld_left (expr1)) != FFEBLD_opSYMTER)
1478         return FALSE;
1479       sym = ffebld_symter (ffebld_left (expr1));
1480       break;
1481
1482     default:
1483       return FALSE;
1484     }
1485
1486   if (ffesymbol_where (sym) != FFEINFO_whereCOMMON
1487       && (ffesymbol_where (sym) != FFEINFO_whereLOCAL
1488           || ! (st = ffesymbol_storage (sym))
1489           || ! ffestorag_parent (st)))
1490     return FALSE;
1491
1492   /* It's in COMMON or local EQUIVALENCE.  */
1493
1494   return TRUE;
1495 }
1496
1497 /* Check whether dest and source might overlap.  ffebld versions of these
1498    might or might not be passed, will be NULL if not.
1499
1500    The test is really whether source_tree is modifiable and, if modified,
1501    might overlap destination such that the value(s) in the destination might
1502    change before it is finally modified.  dest_* are the canonized
1503    destination itself.  */
1504
1505 static bool
1506 ffecom_overlap_ (tree dest_decl, tree dest_offset, tree dest_size,
1507                  tree source_tree, ffebld source UNUSED,
1508                  bool scalar_arg)
1509 {
1510   tree source_decl;
1511   tree source_offset;
1512   tree source_size;
1513   tree t;
1514
1515   if (source_tree == NULL_TREE)
1516     return FALSE;
1517
1518   switch (TREE_CODE (source_tree))
1519     {
1520     case ERROR_MARK:
1521     case IDENTIFIER_NODE:
1522     case INTEGER_CST:
1523     case REAL_CST:
1524     case COMPLEX_CST:
1525     case STRING_CST:
1526     case CONST_DECL:
1527     case VAR_DECL:
1528     case RESULT_DECL:
1529     case FIELD_DECL:
1530     case MINUS_EXPR:
1531     case MULT_EXPR:
1532     case TRUNC_DIV_EXPR:
1533     case CEIL_DIV_EXPR:
1534     case FLOOR_DIV_EXPR:
1535     case ROUND_DIV_EXPR:
1536     case TRUNC_MOD_EXPR:
1537     case CEIL_MOD_EXPR:
1538     case FLOOR_MOD_EXPR:
1539     case ROUND_MOD_EXPR:
1540     case RDIV_EXPR:
1541     case EXACT_DIV_EXPR:
1542     case FIX_TRUNC_EXPR:
1543     case FIX_CEIL_EXPR:
1544     case FIX_FLOOR_EXPR:
1545     case FIX_ROUND_EXPR:
1546     case FLOAT_EXPR:
1547     case NEGATE_EXPR:
1548     case MIN_EXPR:
1549     case MAX_EXPR:
1550     case ABS_EXPR:
1551     case FFS_EXPR:
1552     case LSHIFT_EXPR:
1553     case RSHIFT_EXPR:
1554     case LROTATE_EXPR:
1555     case RROTATE_EXPR:
1556     case BIT_IOR_EXPR:
1557     case BIT_XOR_EXPR:
1558     case BIT_AND_EXPR:
1559     case BIT_ANDTC_EXPR:
1560     case BIT_NOT_EXPR:
1561     case TRUTH_ANDIF_EXPR:
1562     case TRUTH_ORIF_EXPR:
1563     case TRUTH_AND_EXPR:
1564     case TRUTH_OR_EXPR:
1565     case TRUTH_XOR_EXPR:
1566     case TRUTH_NOT_EXPR:
1567     case LT_EXPR:
1568     case LE_EXPR:
1569     case GT_EXPR:
1570     case GE_EXPR:
1571     case EQ_EXPR:
1572     case NE_EXPR:
1573     case COMPLEX_EXPR:
1574     case CONJ_EXPR:
1575     case REALPART_EXPR:
1576     case IMAGPART_EXPR:
1577     case LABEL_EXPR:
1578     case COMPONENT_REF:
1579       return FALSE;
1580
1581     case COMPOUND_EXPR:
1582       return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1583                               TREE_OPERAND (source_tree, 1), NULL,
1584                               scalar_arg);
1585
1586     case MODIFY_EXPR:
1587       return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1588                               TREE_OPERAND (source_tree, 0), NULL,
1589                               scalar_arg);
1590
1591     case CONVERT_EXPR:
1592     case NOP_EXPR:
1593     case NON_LVALUE_EXPR:
1594     case PLUS_EXPR:
1595       if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1596         return TRUE;
1597
1598       ffecom_tree_canonize_ptr_ (&source_decl, &source_offset,
1599                                  source_tree);
1600       source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1601       break;
1602
1603     case COND_EXPR:
1604       return
1605         ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1606                          TREE_OPERAND (source_tree, 1), NULL,
1607                          scalar_arg)
1608           || ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1609                               TREE_OPERAND (source_tree, 2), NULL,
1610                               scalar_arg);
1611
1612
1613     case ADDR_EXPR:
1614       ffecom_tree_canonize_ref_ (&source_decl, &source_offset,
1615                                  &source_size,
1616                                  TREE_OPERAND (source_tree, 0));
1617       break;
1618
1619     case PARM_DECL:
1620       if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1621         return TRUE;
1622
1623       source_decl = source_tree;
1624       source_offset = bitsize_zero_node;
1625       source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1626       break;
1627
1628     case SAVE_EXPR:
1629     case REFERENCE_EXPR:
1630     case PREDECREMENT_EXPR:
1631     case PREINCREMENT_EXPR:
1632     case POSTDECREMENT_EXPR:
1633     case POSTINCREMENT_EXPR:
1634     case INDIRECT_REF:
1635     case ARRAY_REF:
1636     case CALL_EXPR:
1637     default:
1638       return TRUE;
1639     }
1640
1641   /* Come here when source_decl, source_offset, and source_size filled
1642      in appropriately.  */
1643
1644   if (source_decl == NULL_TREE)
1645     return FALSE;               /* No decl involved, so no overlap. */
1646
1647   if (source_decl != dest_decl)
1648     return FALSE;               /* Different decl, no overlap. */
1649
1650   if (TREE_CODE (dest_size) == ERROR_MARK)
1651     return TRUE;                /* Assignment into entire assumed-size
1652                                    array?  Shouldn't happen.... */
1653
1654   t = ffecom_2 (LE_EXPR, integer_type_node,
1655                 ffecom_2 (PLUS_EXPR, TREE_TYPE (dest_offset),
1656                           dest_offset,
1657                           convert (TREE_TYPE (dest_offset),
1658                                    dest_size)),
1659                 convert (TREE_TYPE (dest_offset),
1660                          source_offset));
1661
1662   if (integer_onep (t))
1663     return FALSE;               /* Destination precedes source. */
1664
1665   if (!scalar_arg
1666       || (source_size == NULL_TREE)
1667       || (TREE_CODE (source_size) == ERROR_MARK)
1668       || integer_zerop (source_size))
1669     return TRUE;                /* No way to tell if dest follows source. */
1670
1671   t = ffecom_2 (LE_EXPR, integer_type_node,
1672                 ffecom_2 (PLUS_EXPR, TREE_TYPE (source_offset),
1673                           source_offset,
1674                           convert (TREE_TYPE (source_offset),
1675                                    source_size)),
1676                 convert (TREE_TYPE (source_offset),
1677                          dest_offset));
1678
1679   if (integer_onep (t))
1680     return FALSE;               /* Destination follows source. */
1681
1682   return TRUE;          /* Destination and source overlap. */
1683 }
1684
1685 /* Check whether dest might overlap any of a list of arguments or is
1686    in a COMMON area the callee might know about (and thus modify).  */
1687
1688 static bool
1689 ffecom_args_overlapping_ (tree dest_tree, ffebld dest UNUSED,
1690                           tree args, tree callee_commons,
1691                           bool scalar_args)
1692 {
1693   tree arg;
1694   tree dest_decl;
1695   tree dest_offset;
1696   tree dest_size;
1697
1698   ffecom_tree_canonize_ref_ (&dest_decl, &dest_offset, &dest_size,
1699                              dest_tree);
1700
1701   if (dest_decl == NULL_TREE)
1702     return FALSE;               /* Seems unlikely! */
1703
1704   /* If the decl cannot be determined reliably, or if its in COMMON
1705      and the callee isn't known to not futz with COMMON via other
1706      means, overlap might happen.  */
1707
1708   if ((TREE_CODE (dest_decl) == ERROR_MARK)
1709       || ((callee_commons != NULL_TREE)
1710           && TREE_PUBLIC (dest_decl)))
1711     return TRUE;
1712
1713   for (; args != NULL_TREE; args = TREE_CHAIN (args))
1714     {
1715       if (((arg = TREE_VALUE (args)) != NULL_TREE)
1716           && ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1717                               arg, NULL, scalar_args))
1718         return TRUE;
1719     }
1720
1721   return FALSE;
1722 }
1723
1724 /* Build a string for a variable name as used by NAMELIST.  This means that
1725    if we're using the f2c library, we build an uppercase string, since
1726    f2c does this.  */
1727
1728 static tree
1729 ffecom_build_f2c_string_ (int i, const char *s)
1730 {
1731   if (!ffe_is_f2c_library ())
1732     return build_string (i, s);
1733
1734   {
1735     char *tmp;
1736     const char *p;
1737     char *q;
1738     char space[34];
1739     tree t;
1740
1741     if (((size_t) i) > ARRAY_SIZE (space))
1742       tmp = malloc_new_ks (malloc_pool_image (), "f2c_string", i);
1743     else
1744       tmp = &space[0];
1745
1746     for (p = s, q = tmp; *p != '\0'; ++p, ++q)
1747       *q = TOUPPER (*p);
1748     *q = '\0';
1749
1750     t = build_string (i, tmp);
1751
1752     if (((size_t) i) > ARRAY_SIZE (space))
1753       malloc_kill_ks (malloc_pool_image (), tmp, i);
1754
1755     return t;
1756   }
1757 }
1758
1759 /* Returns CALL_EXPR or equivalent with given type (pass NULL_TREE for
1760    type to just get whatever the function returns), handling the
1761    f2c value-returning convention, if required, by prepending
1762    to the arglist a pointer to a temporary to receive the return value.  */
1763
1764 static tree
1765 ffecom_call_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1766               tree type, tree args, tree dest_tree,
1767               ffebld dest, bool *dest_used, tree callee_commons,
1768               bool scalar_args, tree hook)
1769 {
1770   tree item;
1771   tree tempvar;
1772
1773   if (dest_used != NULL)
1774     *dest_used = FALSE;
1775
1776   if (is_f2c_complex)
1777     {
1778       if ((dest_used == NULL)
1779           || (dest == NULL)
1780           || (ffeinfo_basictype (ffebld_info (dest))
1781               != FFEINFO_basictypeCOMPLEX)
1782           || (ffeinfo_kindtype (ffebld_info (dest)) != kt)
1783           || ((type != NULL_TREE) && (TREE_TYPE (dest_tree) != type))
1784           || ffecom_args_overlapping_ (dest_tree, dest, args,
1785                                        callee_commons,
1786                                        scalar_args))
1787         {
1788 #ifdef HOHO
1789           tempvar = ffecom_make_tempvar (ffecom_tree_type
1790                                          [FFEINFO_basictypeCOMPLEX][kt],
1791                                          FFETARGET_charactersizeNONE,
1792                                          -1);
1793 #else
1794           tempvar = hook;
1795           assert (tempvar);
1796 #endif
1797         }
1798       else
1799         {
1800           *dest_used = TRUE;
1801           tempvar = dest_tree;
1802           type = NULL_TREE;
1803         }
1804
1805       item
1806         = build_tree_list (NULL_TREE,
1807                            ffecom_1 (ADDR_EXPR,
1808                                      build_pointer_type (TREE_TYPE (tempvar)),
1809                                      tempvar));
1810       TREE_CHAIN (item) = args;
1811
1812       item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1813                         item, NULL_TREE);
1814
1815       if (tempvar != dest_tree)
1816         item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item, tempvar);
1817     }
1818   else
1819     item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1820                       args, NULL_TREE);
1821
1822   if ((type != NULL_TREE) && (TREE_TYPE (item) != type))
1823     item = ffecom_convert_narrow_ (type, item);
1824
1825   return item;
1826 }
1827
1828 /* Given two arguments, transform them and make a call to the given
1829    function via ffecom_call_.  */
1830
1831 static tree
1832 ffecom_call_binop_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1833                     tree type, ffebld left, ffebld right,
1834                     tree dest_tree, ffebld dest, bool *dest_used,
1835                     tree callee_commons, bool scalar_args, bool ref, tree hook)
1836 {
1837   tree left_tree;
1838   tree right_tree;
1839   tree left_length;
1840   tree right_length;
1841
1842   if (ref)
1843     {
1844       /* Pass arguments by reference.  */
1845       left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
1846       right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
1847     }
1848   else
1849     {
1850       /* Pass arguments by value.  */
1851       left_tree = ffecom_arg_expr (left, &left_length);
1852       right_tree = ffecom_arg_expr (right, &right_length);
1853     }
1854
1855
1856   left_tree = build_tree_list (NULL_TREE, left_tree);
1857   right_tree = build_tree_list (NULL_TREE, right_tree);
1858   TREE_CHAIN (left_tree) = right_tree;
1859
1860   if (left_length != NULL_TREE)
1861     {
1862       left_length = build_tree_list (NULL_TREE, left_length);
1863       TREE_CHAIN (right_tree) = left_length;
1864     }
1865
1866   if (right_length != NULL_TREE)
1867     {
1868       right_length = build_tree_list (NULL_TREE, right_length);
1869       if (left_length != NULL_TREE)
1870         TREE_CHAIN (left_length) = right_length;
1871       else
1872         TREE_CHAIN (right_tree) = right_length;
1873     }
1874
1875   return ffecom_call_ (fn, kt, is_f2c_complex, type, left_tree,
1876                        dest_tree, dest, dest_used, callee_commons,
1877                        scalar_args, hook);
1878 }
1879
1880 /* Return ptr/length args for char subexpression
1881
1882    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
1883    subexpressions by constructing the appropriate trees for the ptr-to-
1884    character-text and length-of-character-text arguments in a calling
1885    sequence.
1886
1887    Note that if with_null is TRUE, and the expression is an opCONTER,
1888    a null byte is appended to the string.  */
1889
1890 static void
1891 ffecom_char_args_x_ (tree *xitem, tree *length, ffebld expr, bool with_null)
1892 {
1893   tree item;
1894   tree high;
1895   ffetargetCharacter1 val;
1896   ffetargetCharacterSize newlen;
1897
1898   switch (ffebld_op (expr))
1899     {
1900     case FFEBLD_opCONTER:
1901       val = ffebld_constant_character1 (ffebld_conter (expr));
1902       newlen = ffetarget_length_character1 (val);
1903       if (with_null)
1904         {
1905           /* Begin FFETARGET-NULL-KLUDGE.  */
1906           if (newlen != 0)
1907             ++newlen;
1908         }
1909       *length = build_int_2 (newlen, 0);
1910       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
1911       high = build_int_2 (newlen, 0);
1912       TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
1913       item = build_string (newlen,
1914                            ffetarget_text_character1 (val));
1915       /* End FFETARGET-NULL-KLUDGE.  */
1916       TREE_TYPE (item)
1917         = build_type_variant
1918           (build_array_type
1919            (char_type_node,
1920             build_range_type
1921             (ffecom_f2c_ftnlen_type_node,
1922              ffecom_f2c_ftnlen_one_node,
1923              high)),
1924            1, 0);
1925       TREE_CONSTANT (item) = 1;
1926       TREE_STATIC (item) = 1;
1927       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
1928                        item);
1929       break;
1930
1931     case FFEBLD_opSYMTER:
1932       {
1933         ffesymbol s = ffebld_symter (expr);
1934
1935         item = ffesymbol_hook (s).decl_tree;
1936         if (item == NULL_TREE)
1937           {
1938             s = ffecom_sym_transform_ (s);
1939             item = ffesymbol_hook (s).decl_tree;
1940           }
1941         if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
1942           {
1943             if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
1944               *length = ffesymbol_hook (s).length_tree;
1945             else
1946               {
1947                 *length = build_int_2 (ffesymbol_size (s), 0);
1948                 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
1949               }
1950           }
1951         else if (item == error_mark_node)
1952           *length = error_mark_node;
1953         else
1954           /* FFEINFO_kindFUNCTION.  */
1955           *length = NULL_TREE;
1956         if (!ffesymbol_hook (s).addr
1957             && (item != error_mark_node))
1958           item = ffecom_1 (ADDR_EXPR,
1959                            build_pointer_type (TREE_TYPE (item)),
1960                            item);
1961       }
1962       break;
1963
1964     case FFEBLD_opARRAYREF:
1965       {
1966         ffecom_char_args_ (&item, length, ffebld_left (expr));
1967
1968         if (item == error_mark_node || *length == error_mark_node)
1969           {
1970             item = *length = error_mark_node;
1971             break;
1972           }
1973
1974         item = ffecom_arrayref_ (item, expr, 1);
1975       }
1976       break;
1977
1978     case FFEBLD_opSUBSTR:
1979       {
1980         ffebld start;
1981         ffebld end;
1982         ffebld thing = ffebld_right (expr);
1983         tree start_tree;
1984         tree end_tree;
1985         const char *char_name;
1986         ffebld left_symter;
1987         tree array;
1988
1989         assert (ffebld_op (thing) == FFEBLD_opITEM);
1990         start = ffebld_head (thing);
1991         thing = ffebld_trail (thing);
1992         assert (ffebld_trail (thing) == NULL);
1993         end = ffebld_head (thing);
1994
1995         /* Determine name for pretty-printing range-check errors.  */
1996         for (left_symter = ffebld_left (expr);
1997              left_symter && ffebld_op (left_symter) == FFEBLD_opARRAYREF;
1998              left_symter = ffebld_left (left_symter))
1999           ;
2000         if (ffebld_op (left_symter) == FFEBLD_opSYMTER)
2001           char_name = ffesymbol_text (ffebld_symter (left_symter));
2002         else
2003           char_name = "[expr?]";
2004
2005         ffecom_char_args_ (&item, length, ffebld_left (expr));
2006
2007         if (item == error_mark_node || *length == error_mark_node)
2008           {
2009             item = *length = error_mark_node;
2010             break;
2011           }
2012
2013         array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
2014
2015         /* ~~~~Handle INTEGER*8 start/end, a la FFEBLD_opARRAYREF.  */
2016
2017         if (start == NULL)
2018           {
2019             if (end == NULL)
2020               ;
2021             else
2022               {
2023                 end_tree = ffecom_expr (end);
2024                 if (flag_bounds_check)
2025                   end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2026                                                       char_name);
2027                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2028                                     end_tree);
2029
2030                 if (end_tree == error_mark_node)
2031                   {
2032                     item = *length = error_mark_node;
2033                     break;
2034                   }
2035
2036                 *length = end_tree;
2037               }
2038           }
2039         else
2040           {
2041             start_tree = ffecom_expr (start);
2042             if (flag_bounds_check)
2043               start_tree = ffecom_subscript_check_ (array, start_tree, 0, 0,
2044                                                     char_name);
2045             start_tree = convert (ffecom_f2c_ftnlen_type_node,
2046                                   start_tree);
2047
2048             if (start_tree == error_mark_node)
2049               {
2050                 item = *length = error_mark_node;
2051                 break;
2052               }
2053
2054             start_tree = ffecom_save_tree (start_tree);
2055
2056             item = ffecom_2 (PLUS_EXPR, TREE_TYPE (item),
2057                              item,
2058                              ffecom_2 (MINUS_EXPR,
2059                                        TREE_TYPE (start_tree),
2060                                        start_tree,
2061                                        ffecom_f2c_ftnlen_one_node));
2062
2063             if (end == NULL)
2064               {
2065                 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2066                                     ffecom_f2c_ftnlen_one_node,
2067                                     ffecom_2 (MINUS_EXPR,
2068                                               ffecom_f2c_ftnlen_type_node,
2069                                               *length,
2070                                               start_tree));
2071               }
2072             else
2073               {
2074                 end_tree = ffecom_expr (end);
2075                 if (flag_bounds_check)
2076                   end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2077                                                       char_name);
2078                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2079                                     end_tree);
2080
2081                 if (end_tree == error_mark_node)
2082                   {
2083                     item = *length = error_mark_node;
2084                     break;
2085                   }
2086
2087                 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2088                                     ffecom_f2c_ftnlen_one_node,
2089                                     ffecom_2 (MINUS_EXPR,
2090                                               ffecom_f2c_ftnlen_type_node,
2091                                               end_tree, start_tree));
2092               }
2093           }
2094       }
2095       break;
2096
2097     case FFEBLD_opFUNCREF:
2098       {
2099         ffesymbol s = ffebld_symter (ffebld_left (expr));
2100         tree tempvar;
2101         tree args;
2102         ffetargetCharacterSize size = ffeinfo_size (ffebld_info (expr));
2103         ffecomGfrt ix;
2104
2105         if (size == FFETARGET_charactersizeNONE)
2106           /* ~~Kludge alert!  This should someday be fixed. */
2107           size = 24;
2108
2109         *length = build_int_2 (size, 0);
2110         TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2111
2112         if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
2113             == FFEINFO_whereINTRINSIC)
2114           {
2115             if (size == 1)
2116               {
2117                 /* Invocation of an intrinsic returning CHARACTER*1.  */
2118                 item = ffecom_expr_intrinsic_ (expr, NULL_TREE,
2119                                                NULL, NULL);
2120                 break;
2121               }
2122             ix = ffeintrin_gfrt_direct (ffebld_symter_implementation (ffebld_left (expr)));
2123             assert (ix != FFECOM_gfrt);
2124             item = ffecom_gfrt_tree_ (ix);
2125           }
2126         else
2127           {
2128             ix = FFECOM_gfrt;
2129             item = ffesymbol_hook (s).decl_tree;
2130             if (item == NULL_TREE)
2131               {
2132                 s = ffecom_sym_transform_ (s);
2133                 item = ffesymbol_hook (s).decl_tree;
2134               }
2135             if (item == error_mark_node)
2136               {
2137                 item = *length = error_mark_node;
2138                 break;
2139               }
2140
2141             if (!ffesymbol_hook (s).addr)
2142               item = ffecom_1_fn (item);
2143           }
2144
2145 #ifdef HOHO
2146         tempvar = ffecom_push_tempvar (char_type_node, size, -1, TRUE);
2147 #else
2148         tempvar = ffebld_nonter_hook (expr);
2149         assert (tempvar);
2150 #endif
2151         tempvar = ffecom_1 (ADDR_EXPR,
2152                             build_pointer_type (TREE_TYPE (tempvar)),
2153                             tempvar);
2154
2155         args = build_tree_list (NULL_TREE, tempvar);
2156
2157         if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)       /* Sfunc args by value. */
2158           TREE_CHAIN (args) = ffecom_list_expr (ffebld_right (expr));
2159         else
2160           {
2161             TREE_CHAIN (args) = build_tree_list (NULL_TREE, *length);
2162             if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
2163               {
2164                 TREE_CHAIN (TREE_CHAIN (args))
2165                   = ffecom_arglist_expr_ (ffecom_gfrt_args_ (ix),
2166                                           ffebld_right (expr));
2167               }
2168             else
2169               {
2170                 TREE_CHAIN (TREE_CHAIN (args))
2171                   = ffecom_list_ptr_to_expr (ffebld_right (expr));
2172               }
2173           }
2174
2175         item = ffecom_3s (CALL_EXPR,
2176                           TREE_TYPE (TREE_TYPE (TREE_TYPE (item))),
2177                           item, args, NULL_TREE);
2178         item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item,
2179                          tempvar);
2180       }
2181       break;
2182
2183     case FFEBLD_opCONVERT:
2184
2185       ffecom_char_args_ (&item, length, ffebld_left (expr));
2186
2187       if (item == error_mark_node || *length == error_mark_node)
2188         {
2189           item = *length = error_mark_node;
2190           break;
2191         }
2192
2193       if ((ffebld_size_known (ffebld_left (expr))
2194            == FFETARGET_charactersizeNONE)
2195           || (ffebld_size_known (ffebld_left (expr)) < (ffebld_size (expr))))
2196         {                       /* Possible blank-padding needed, copy into
2197                                    temporary. */
2198           tree tempvar;
2199           tree args;
2200           tree newlen;
2201
2202 #ifdef HOHO
2203           tempvar = ffecom_make_tempvar (char_type_node,
2204                                          ffebld_size (expr), -1);
2205 #else
2206           tempvar = ffebld_nonter_hook (expr);
2207           assert (tempvar);
2208 #endif
2209           tempvar = ffecom_1 (ADDR_EXPR,
2210                               build_pointer_type (TREE_TYPE (tempvar)),
2211                               tempvar);
2212
2213           newlen = build_int_2 (ffebld_size (expr), 0);
2214           TREE_TYPE (newlen) = ffecom_f2c_ftnlen_type_node;
2215
2216           args = build_tree_list (NULL_TREE, tempvar);
2217           TREE_CHAIN (args) = build_tree_list (NULL_TREE, item);
2218           TREE_CHAIN (TREE_CHAIN (args)) = build_tree_list (NULL_TREE, newlen);
2219           TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (args)))
2220             = build_tree_list (NULL_TREE, *length);
2221
2222           item = ffecom_call_gfrt (FFECOM_gfrtCOPY, args, NULL_TREE);
2223           TREE_SIDE_EFFECTS (item) = 1;
2224           item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), fold (item),
2225                            tempvar);
2226           *length = newlen;
2227         }
2228       else
2229         {                       /* Just truncate the length. */
2230           *length = build_int_2 (ffebld_size (expr), 0);
2231           TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2232         }
2233       break;
2234
2235     default:
2236       assert ("bad op for single char arg expr" == NULL);
2237       item = NULL_TREE;
2238       break;
2239     }
2240
2241   *xitem = item;
2242 }
2243
2244 /* Check the size of the type to be sure it doesn't overflow the
2245    "portable" capacities of the compiler back end.  `dummy' types
2246    can generally overflow the normal sizes as long as the computations
2247    themselves don't overflow.  A particular target of the back end
2248    must still enforce its size requirements, though, and the back
2249    end takes care of this in stor-layout.c.  */
2250
2251 static tree
2252 ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy)
2253 {
2254   if (TREE_CODE (type) == ERROR_MARK)
2255     return type;
2256
2257   if (TYPE_SIZE (type) == NULL_TREE)
2258     return type;
2259
2260   if (TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST)
2261     return type;
2262
2263   if ((tree_int_cst_sgn (TYPE_SIZE (type)) < 0)
2264       || (!dummy && TREE_OVERFLOW (TYPE_SIZE (type))))
2265     {
2266       ffebad_start (FFEBAD_ARRAY_LARGE);
2267       ffebad_string (ffesymbol_text (s));
2268       ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s));
2269       ffebad_finish ();
2270
2271       return error_mark_node;
2272     }
2273
2274   return type;
2275 }
2276
2277 /* Builds a length argument (PARM_DECL).  Also wraps type in an array type
2278    where the dimension info is (1:size) where <size> is ffesymbol_size(s) if
2279    known, length_arg if not known (FFETARGET_charactersizeNONE).  */
2280
2281 static tree
2282 ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s)
2283 {
2284   ffetargetCharacterSize sz = ffesymbol_size (s);
2285   tree highval;
2286   tree tlen;
2287   tree type = *xtype;
2288
2289   if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
2290     tlen = NULL_TREE;           /* A statement function, no length passed. */
2291   else
2292     {
2293       if (ffesymbol_where (s) == FFEINFO_whereDUMMY)
2294         tlen = ffecom_get_invented_identifier ("__g77_length_%s",
2295                                                ffesymbol_text (s));
2296       else
2297         tlen = ffecom_get_invented_identifier ("__g77_%s", "length");
2298       tlen = build_decl (PARM_DECL, tlen, ffecom_f2c_ftnlen_type_node);
2299       DECL_ARTIFICIAL (tlen) = 1;
2300     }
2301
2302   if (sz == FFETARGET_charactersizeNONE)
2303     {
2304       assert (tlen != NULL_TREE);
2305       highval = variable_size (tlen);
2306     }
2307   else
2308     {
2309       highval = build_int_2 (sz, 0);
2310       TREE_TYPE (highval) = ffecom_f2c_ftnlen_type_node;
2311     }
2312
2313   type = build_array_type (type,
2314                            build_range_type (ffecom_f2c_ftnlen_type_node,
2315                                              ffecom_f2c_ftnlen_one_node,
2316                                              highval));
2317
2318   *xtype = type;
2319   return tlen;
2320 }
2321
2322 /* ffecom_concat_list_gather_ -- Gather list of concatenated string exprs
2323
2324    ffecomConcatList_ catlist;
2325    ffebld expr;  // expr of CHARACTER basictype.
2326    ffetargetCharacterSize max;  // max chars to gather or _...NONE if no max
2327    catlist = ffecom_concat_list_gather_(catlist,expr,max);
2328
2329    Scans expr for character subexpressions, updates and returns catlist
2330    accordingly.  */
2331
2332 static ffecomConcatList_
2333 ffecom_concat_list_gather_ (ffecomConcatList_ catlist, ffebld expr,
2334                             ffetargetCharacterSize max)
2335 {
2336   ffetargetCharacterSize sz;
2337
2338  recurse:
2339
2340   if (expr == NULL)
2341     return catlist;
2342
2343   if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen >= max))
2344     return catlist;             /* Don't append any more items. */
2345
2346   switch (ffebld_op (expr))
2347     {
2348     case FFEBLD_opCONTER:
2349     case FFEBLD_opSYMTER:
2350     case FFEBLD_opARRAYREF:
2351     case FFEBLD_opFUNCREF:
2352     case FFEBLD_opSUBSTR:
2353     case FFEBLD_opCONVERT:      /* Callers should strip this off beforehand
2354                                    if they don't need to preserve it. */
2355       if (catlist.count == catlist.max)
2356         {                       /* Make a (larger) list. */
2357           ffebld *newx;
2358           int newmax;
2359
2360           newmax = (catlist.max == 0) ? 8 : catlist.max * 2;
2361           newx = malloc_new_ks (malloc_pool_image (), "catlist",
2362                                 newmax * sizeof (newx[0]));
2363           if (catlist.max != 0)
2364             {
2365               memcpy (newx, catlist.exprs, catlist.max * sizeof (newx[0]));
2366               malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2367                               catlist.max * sizeof (newx[0]));
2368             }
2369           catlist.max = newmax;
2370           catlist.exprs = newx;
2371         }
2372       if ((sz = ffebld_size_known (expr)) != FFETARGET_charactersizeNONE)
2373         catlist.minlen += sz;
2374       else
2375         ++catlist.minlen;       /* Not true for F90; can be 0 length. */
2376       if ((sz = ffebld_size_max (expr)) == FFETARGET_charactersizeNONE)
2377         catlist.maxlen = sz;
2378       else
2379         catlist.maxlen += sz;
2380       if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen > max))
2381         {                       /* This item overlaps (or is beyond) the end
2382                                    of the destination. */
2383           switch (ffebld_op (expr))
2384             {
2385             case FFEBLD_opCONTER:
2386             case FFEBLD_opSYMTER:
2387             case FFEBLD_opARRAYREF:
2388             case FFEBLD_opFUNCREF:
2389             case FFEBLD_opSUBSTR:
2390               /* ~~Do useful truncations here. */
2391               break;
2392
2393             default:
2394               assert ("op changed or inconsistent switches!" == NULL);
2395               break;
2396             }
2397         }
2398       catlist.exprs[catlist.count++] = expr;
2399       return catlist;
2400
2401     case FFEBLD_opPAREN:
2402       expr = ffebld_left (expr);
2403       goto recurse;             /* :::::::::::::::::::: */
2404
2405     case FFEBLD_opCONCATENATE:
2406       catlist = ffecom_concat_list_gather_ (catlist, ffebld_left (expr), max);
2407       expr = ffebld_right (expr);
2408       goto recurse;             /* :::::::::::::::::::: */
2409
2410 #if 0                           /* Breaks passing small actual arg to larger
2411                                    dummy arg of sfunc */
2412     case FFEBLD_opCONVERT:
2413       expr = ffebld_left (expr);
2414       {
2415         ffetargetCharacterSize cmax;
2416
2417         cmax = catlist.len + ffebld_size_known (expr);
2418
2419         if ((max == FFETARGET_charactersizeNONE) || (max > cmax))
2420           max = cmax;
2421       }
2422       goto recurse;             /* :::::::::::::::::::: */
2423 #endif
2424
2425     case FFEBLD_opANY:
2426       return catlist;
2427
2428     default:
2429       assert ("bad op in _gather_" == NULL);
2430       return catlist;
2431     }
2432 }
2433
2434 /* ffecom_concat_list_kill_ -- Kill list of concatenated string exprs
2435
2436    ffecomConcatList_ catlist;
2437    ffecom_concat_list_kill_(catlist);
2438
2439    Anything allocated within the list info is deallocated.  */
2440
2441 static void
2442 ffecom_concat_list_kill_ (ffecomConcatList_ catlist)
2443 {
2444   if (catlist.max != 0)
2445     malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2446                     catlist.max * sizeof (catlist.exprs[0]));
2447 }
2448
2449 /* Make list of concatenated string exprs.
2450
2451    Returns a flattened list of concatenated subexpressions given a
2452    tree of such expressions.  */
2453
2454 static ffecomConcatList_
2455 ffecom_concat_list_new_ (ffebld expr, ffetargetCharacterSize max)
2456 {
2457   ffecomConcatList_ catlist;
2458
2459   catlist.maxlen = catlist.minlen = catlist.max = catlist.count = 0;
2460   return ffecom_concat_list_gather_ (catlist, expr, max);
2461 }
2462
2463 /* Provide some kind of useful info on member of aggregate area,
2464    since current g77/gcc technology does not provide debug info
2465    on these members.  */
2466
2467 static void
2468 ffecom_debug_kludge_ (tree aggr, const char *aggr_type, ffesymbol member,
2469                       tree member_type UNUSED, ffetargetOffset offset)
2470 {
2471   tree value;
2472   tree decl;
2473   int len;
2474   char *buff;
2475   char space[120];
2476 #if 0
2477   tree type_id;
2478
2479   for (type_id = member_type;
2480        TREE_CODE (type_id) != IDENTIFIER_NODE;
2481        )
2482     {
2483       switch (TREE_CODE (type_id))
2484         {
2485         case INTEGER_TYPE:
2486         case REAL_TYPE:
2487           type_id = TYPE_NAME (type_id);
2488           break;
2489
2490         case ARRAY_TYPE:
2491         case COMPLEX_TYPE:
2492           type_id = TREE_TYPE (type_id);
2493           break;
2494
2495         default:
2496           assert ("no IDENTIFIER_NODE for type!" == NULL);
2497           type_id = error_mark_node;
2498           break;
2499         }
2500     }
2501 #endif
2502
2503   if (ffecom_transform_only_dummies_
2504       || !ffe_is_debug_kludge ())
2505     return;     /* Can't do this yet, maybe later. */
2506
2507   len = 60
2508     + strlen (aggr_type)
2509     + IDENTIFIER_LENGTH (DECL_NAME (aggr));
2510 #if 0
2511     + IDENTIFIER_LENGTH (type_id);
2512 #endif
2513
2514   if (((size_t) len) >= ARRAY_SIZE (space))
2515     buff = malloc_new_ks (malloc_pool_image (), "debug_kludge", len + 1);
2516   else
2517     buff = &space[0];
2518
2519   sprintf (&buff[0], "At (%s) `%s' plus %ld bytes",
2520            aggr_type,
2521            IDENTIFIER_POINTER (DECL_NAME (aggr)),
2522            (long int) offset);
2523
2524   value = build_string (len, buff);
2525   TREE_TYPE (value)
2526     = build_type_variant (build_array_type (char_type_node,
2527                                             build_range_type
2528                                             (integer_type_node,
2529                                              integer_one_node,
2530                                              build_int_2 (strlen (buff), 0))),
2531                           1, 0);
2532   decl = build_decl (VAR_DECL,
2533                      ffecom_get_identifier_ (ffesymbol_text (member)),
2534                      TREE_TYPE (value));
2535   TREE_CONSTANT (decl) = 1;
2536   TREE_STATIC (decl) = 1;
2537   DECL_INITIAL (decl) = error_mark_node;
2538   DECL_IN_SYSTEM_HEADER (decl) = 1;     /* Don't let -Wunused complain. */
2539   decl = start_decl (decl, FALSE);
2540   finish_decl (decl, value, FALSE);
2541
2542   if (buff != &space[0])
2543     malloc_kill_ks (malloc_pool_image (), buff, len + 1);
2544 }
2545
2546 /* ffecom_do_entry_ -- Do compilation of a particular entrypoint
2547
2548    ffesymbol fn;  // the SUBROUTINE, FUNCTION, or ENTRY symbol itself
2549    int i;  // entry# for this entrypoint (used by master fn)
2550    ffecom_do_entrypoint_(s,i);
2551
2552    Makes a public entry point that calls our private master fn (already
2553    compiled).  */
2554
2555 static void
2556 ffecom_do_entry_ (ffesymbol fn, int entrynum)
2557 {
2558   ffebld item;
2559   tree type;                    /* Type of function. */
2560   tree multi_retval;            /* Var holding return value (union). */
2561   tree result;                  /* Var holding result. */
2562   ffeinfoBasictype bt;
2563   ffeinfoKindtype kt;
2564   ffeglobal g;
2565   ffeglobalType gt;
2566   bool charfunc;                /* All entry points return same type
2567                                    CHARACTER. */
2568   bool cmplxfunc;               /* Use f2c way of returning COMPLEX. */
2569   bool multi;                   /* Master fn has multiple return types. */
2570   bool altreturning = FALSE;    /* This entry point has alternate returns. */
2571   int old_lineno = lineno;
2572   const char *old_input_filename = input_filename;
2573
2574   input_filename = ffesymbol_where_filename (fn);
2575   lineno = ffesymbol_where_filelinenum (fn);
2576
2577   ffecom_doing_entry_ = TRUE;   /* Don't bother with array dimensions. */
2578
2579   switch (ffecom_primary_entry_kind_)
2580     {
2581     case FFEINFO_kindFUNCTION:
2582
2583       /* Determine actual return type for function. */
2584
2585       gt = FFEGLOBAL_typeFUNC;
2586       bt = ffesymbol_basictype (fn);
2587       kt = ffesymbol_kindtype (fn);
2588       if (bt == FFEINFO_basictypeNONE)
2589         {
2590           ffeimplic_establish_symbol (fn);
2591           if (ffesymbol_funcresult (fn) != NULL)
2592             ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
2593           bt = ffesymbol_basictype (fn);
2594           kt = ffesymbol_kindtype (fn);
2595         }
2596
2597       if (bt == FFEINFO_basictypeCHARACTER)
2598         charfunc = TRUE, cmplxfunc = FALSE;
2599       else if ((bt == FFEINFO_basictypeCOMPLEX)
2600                && ffesymbol_is_f2c (fn))
2601         charfunc = FALSE, cmplxfunc = TRUE;
2602       else
2603         charfunc = cmplxfunc = FALSE;
2604
2605       if (charfunc)
2606         type = ffecom_tree_fun_type_void;
2607       else if (ffesymbol_is_f2c (fn))
2608         type = ffecom_tree_fun_type[bt][kt];
2609       else
2610         type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
2611
2612       if ((type == NULL_TREE)
2613           || (TREE_TYPE (type) == NULL_TREE))
2614         type = ffecom_tree_fun_type_void;       /* _sym_exec_transition. */
2615
2616       multi = (ffecom_master_bt_ == FFEINFO_basictypeNONE);
2617       break;
2618
2619     case FFEINFO_kindSUBROUTINE:
2620       gt = FFEGLOBAL_typeSUBR;
2621       bt = FFEINFO_basictypeNONE;
2622       kt = FFEINFO_kindtypeNONE;
2623       if (ffecom_is_altreturning_)
2624         {                       /* Am _I_ altreturning? */
2625           for (item = ffesymbol_dummyargs (fn);
2626                item != NULL;
2627                item = ffebld_trail (item))
2628             {
2629               if (ffebld_op (ffebld_head (item)) == FFEBLD_opSTAR)
2630                 {
2631                   altreturning = TRUE;
2632                   break;
2633                 }
2634             }
2635           if (altreturning)
2636             type = ffecom_tree_subr_type;
2637           else
2638             type = ffecom_tree_fun_type_void;
2639         }
2640       else
2641         type = ffecom_tree_fun_type_void;
2642       charfunc = FALSE;
2643       cmplxfunc = FALSE;
2644       multi = FALSE;
2645       break;
2646
2647     default:
2648       assert ("say what??" == NULL);
2649       /* Fall through. */
2650     case FFEINFO_kindANY:
2651       gt = FFEGLOBAL_typeANY;
2652       bt = FFEINFO_basictypeNONE;
2653       kt = FFEINFO_kindtypeNONE;
2654       type = error_mark_node;
2655       charfunc = FALSE;
2656       cmplxfunc = FALSE;
2657       multi = FALSE;
2658       break;
2659     }
2660
2661   /* build_decl uses the current lineno and input_filename to set the decl
2662      source info.  So, I've putzed with ffestd and ffeste code to update that
2663      source info to point to the appropriate statement just before calling
2664      ffecom_do_entrypoint (which calls this fn).  */
2665
2666   start_function (ffecom_get_external_identifier_ (fn),
2667                   type,
2668                   0,            /* nested/inline */
2669                   1);           /* TREE_PUBLIC */
2670
2671   if (((g = ffesymbol_global (fn)) != NULL)
2672       && ((ffeglobal_type (g) == gt)
2673           || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
2674     {
2675       ffeglobal_set_hook (g, current_function_decl);
2676     }
2677
2678   /* Reset args in master arg list so they get retransitioned. */
2679
2680   for (item = ffecom_master_arglist_;
2681        item != NULL;
2682        item = ffebld_trail (item))
2683     {
2684       ffebld arg;
2685       ffesymbol s;
2686
2687       arg = ffebld_head (item);
2688       if (ffebld_op (arg) != FFEBLD_opSYMTER)
2689         continue;               /* Alternate return or some such thing. */
2690       s = ffebld_symter (arg);
2691       ffesymbol_hook (s).decl_tree = NULL_TREE;
2692       ffesymbol_hook (s).length_tree = NULL_TREE;
2693     }
2694
2695   /* Build dummy arg list for this entry point. */
2696
2697   if (charfunc || cmplxfunc)
2698     {                           /* Prepend arg for where result goes. */
2699       tree type;
2700       tree length;
2701
2702       if (charfunc)
2703         type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
2704       else
2705         type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
2706
2707       result = ffecom_get_invented_identifier ("__g77_%s", "result");
2708
2709       /* Make length arg _and_ enhance type info for CHAR arg itself.  */
2710
2711       if (charfunc)
2712         length = ffecom_char_enhance_arg_ (&type, fn);
2713       else
2714         length = NULL_TREE;     /* Not ref'd if !charfunc. */
2715
2716       type = build_pointer_type (type);
2717       result = build_decl (PARM_DECL, result, type);
2718
2719       push_parm_decl (result);
2720       ffecom_func_result_ = result;
2721
2722       if (charfunc)
2723         {
2724           push_parm_decl (length);
2725           ffecom_func_length_ = length;
2726         }
2727     }
2728   else
2729     result = DECL_RESULT (current_function_decl);
2730
2731   ffecom_push_dummy_decls_ (ffesymbol_dummyargs (fn), FALSE);
2732
2733   store_parm_decls (0);
2734
2735   ffecom_start_compstmt ();
2736   /* Disallow temp vars at this level.  */
2737   current_binding_level->prep_state = 2;
2738
2739   /* Make local var to hold return type for multi-type master fn. */
2740
2741   if (multi)
2742     {
2743       multi_retval = ffecom_get_invented_identifier ("__g77_%s",
2744                                                      "multi_retval");
2745       multi_retval = build_decl (VAR_DECL, multi_retval,
2746                                  ffecom_multi_type_node_);
2747       multi_retval = start_decl (multi_retval, FALSE);
2748       finish_decl (multi_retval, NULL_TREE, FALSE);
2749     }
2750   else
2751     multi_retval = NULL_TREE;   /* Not actually ref'd if !multi. */
2752
2753   /* Here we emit the actual code for the entry point. */
2754
2755   {
2756     ffebld list;
2757     ffebld arg;
2758     ffesymbol s;
2759     tree arglist = NULL_TREE;
2760     tree *plist = &arglist;
2761     tree prepend;
2762     tree call;
2763     tree actarg;
2764     tree master_fn;
2765
2766     /* Prepare actual arg list based on master arg list. */
2767
2768     for (list = ffecom_master_arglist_;
2769          list != NULL;
2770          list = ffebld_trail (list))
2771       {
2772         arg = ffebld_head (list);
2773         if (ffebld_op (arg) != FFEBLD_opSYMTER)
2774           continue;
2775         s = ffebld_symter (arg);
2776         if (ffesymbol_hook (s).decl_tree == NULL_TREE
2777             || ffesymbol_hook (s).decl_tree == error_mark_node)
2778           actarg = null_pointer_node;   /* We don't have this arg. */
2779         else
2780           actarg = ffesymbol_hook (s).decl_tree;
2781         *plist = build_tree_list (NULL_TREE, actarg);
2782         plist = &TREE_CHAIN (*plist);
2783       }
2784
2785     /* This code appends the length arguments for character
2786        variables/arrays.  */
2787
2788     for (list = ffecom_master_arglist_;
2789          list != NULL;
2790          list = ffebld_trail (list))
2791       {
2792         arg = ffebld_head (list);
2793         if (ffebld_op (arg) != FFEBLD_opSYMTER)
2794           continue;
2795         s = ffebld_symter (arg);
2796         if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
2797           continue;             /* Only looking for CHARACTER arguments. */
2798         if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
2799           continue;             /* Only looking for variables and arrays. */
2800         if (ffesymbol_hook (s).length_tree == NULL_TREE
2801             || ffesymbol_hook (s).length_tree == error_mark_node)
2802           actarg = ffecom_f2c_ftnlen_zero_node; /* We don't have this arg. */
2803         else
2804           actarg = ffesymbol_hook (s).length_tree;
2805         *plist = build_tree_list (NULL_TREE, actarg);
2806         plist = &TREE_CHAIN (*plist);
2807       }
2808
2809     /* Prepend character-value return info to actual arg list. */
2810
2811     if (charfunc)
2812       {
2813         prepend = build_tree_list (NULL_TREE, ffecom_func_result_);
2814         TREE_CHAIN (prepend)
2815           = build_tree_list (NULL_TREE, ffecom_func_length_);
2816         TREE_CHAIN (TREE_CHAIN (prepend)) = arglist;
2817         arglist = prepend;
2818       }
2819
2820     /* Prepend multi-type return value to actual arg list. */
2821
2822     if (multi)
2823       {
2824         prepend
2825           = build_tree_list (NULL_TREE,
2826                              ffecom_1 (ADDR_EXPR,
2827                               build_pointer_type (TREE_TYPE (multi_retval)),
2828                                        multi_retval));
2829         TREE_CHAIN (prepend) = arglist;
2830         arglist = prepend;
2831       }
2832
2833     /* Prepend my entry-point number to the actual arg list. */
2834
2835     prepend = build_tree_list (NULL_TREE, build_int_2 (entrynum, 0));
2836     TREE_CHAIN (prepend) = arglist;
2837     arglist = prepend;
2838
2839     /* Build the call to the master function. */
2840
2841     master_fn = ffecom_1_fn (ffecom_previous_function_decl_);
2842     call = ffecom_3s (CALL_EXPR,
2843                       TREE_TYPE (TREE_TYPE (TREE_TYPE (master_fn))),
2844                       master_fn, arglist, NULL_TREE);
2845
2846     /* Decide whether the master function is a function or subroutine, and
2847        handle the return value for my entry point. */
2848
2849     if (charfunc || ((ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
2850                      && !altreturning))
2851       {
2852         expand_expr_stmt (call);
2853         expand_null_return ();
2854       }
2855     else if (multi && cmplxfunc)
2856       {
2857         expand_expr_stmt (call);
2858         result
2859           = ffecom_1 (INDIRECT_REF,
2860                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
2861                       result);
2862         result = ffecom_modify (NULL_TREE, result,
2863                                 ffecom_2 (COMPONENT_REF, TREE_TYPE (result),
2864                                           multi_retval,
2865                                           ffecom_multi_fields_[bt][kt]));
2866         expand_expr_stmt (result);
2867         expand_null_return ();
2868       }
2869     else if (multi)
2870       {
2871         expand_expr_stmt (call);
2872         result
2873           = ffecom_modify (NULL_TREE, result,
2874                            convert (TREE_TYPE (result),
2875                                     ffecom_2 (COMPONENT_REF,
2876                                               ffecom_tree_type[bt][kt],
2877                                               multi_retval,
2878                                               ffecom_multi_fields_[bt][kt])));
2879         expand_return (result);
2880       }
2881     else if (cmplxfunc)
2882       {
2883         result
2884           = ffecom_1 (INDIRECT_REF,
2885                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
2886                       result);
2887         result = ffecom_modify (NULL_TREE, result, call);
2888         expand_expr_stmt (result);
2889         expand_null_return ();
2890       }
2891     else
2892       {
2893         result = ffecom_modify (NULL_TREE,
2894                                 result,
2895                                 convert (TREE_TYPE (result),
2896                                          call));
2897         expand_return (result);
2898       }
2899   }
2900
2901   ffecom_end_compstmt ();
2902
2903   finish_function (0);
2904
2905   lineno = old_lineno;
2906   input_filename = old_input_filename;
2907
2908   ffecom_doing_entry_ = FALSE;
2909 }
2910
2911 /* Transform expr into gcc tree with possible destination
2912
2913    Recursive descent on expr while making corresponding tree nodes and
2914    attaching type info and such.  If destination supplied and compatible
2915    with temporary that would be made in certain cases, temporary isn't
2916    made, destination used instead, and dest_used flag set TRUE.  */
2917
2918 static tree
2919 ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
2920               bool *dest_used, bool assignp, bool widenp)
2921 {
2922   tree item;
2923   tree list;
2924   tree args;
2925   ffeinfoBasictype bt;
2926   ffeinfoKindtype kt;
2927   tree t;
2928   tree dt;                      /* decl_tree for an ffesymbol. */
2929   tree tree_type, tree_type_x;
2930   tree left, right;
2931   ffesymbol s;
2932   enum tree_code code;
2933
2934   assert (expr != NULL);
2935
2936   if (dest_used != NULL)
2937     *dest_used = FALSE;
2938
2939   bt = ffeinfo_basictype (ffebld_info (expr));
2940   kt = ffeinfo_kindtype (ffebld_info (expr));
2941   tree_type = ffecom_tree_type[bt][kt];
2942
2943   /* Widen integral arithmetic as desired while preserving signedness.  */
2944   tree_type_x = NULL_TREE;
2945   if (widenp && tree_type
2946       && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
2947       && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
2948     tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
2949
2950   switch (ffebld_op (expr))
2951     {
2952     case FFEBLD_opACCTER:
2953       {
2954         ffebitCount i;
2955         ffebit bits = ffebld_accter_bits (expr);
2956         ffetargetOffset source_offset = 0;
2957         ffetargetOffset dest_offset = ffebld_accter_pad (expr);
2958         tree purpose;
2959
2960         assert (dest_offset == 0
2961                 || (bt == FFEINFO_basictypeCHARACTER
2962                     && kt == FFEINFO_kindtypeCHARACTER1));
2963
2964         list = item = NULL;
2965         for (;;)
2966           {
2967             ffebldConstantUnion cu;
2968             ffebitCount length;
2969             bool value;
2970             ffebldConstantArray ca = ffebld_accter (expr);
2971
2972             ffebit_test (bits, source_offset, &value, &length);
2973             if (length == 0)
2974               break;
2975
2976             if (value)
2977               {
2978                 for (i = 0; i < length; ++i)
2979                   {
2980                     cu = ffebld_constantarray_get (ca, bt, kt,
2981                                                    source_offset + i);
2982
2983                     t = ffecom_constantunion (&cu, bt, kt, tree_type);
2984
2985                     if (i == 0
2986                         && dest_offset != 0)
2987                       purpose = build_int_2 (dest_offset, 0);
2988                     else
2989                       purpose = NULL_TREE;
2990
2991                     if (list == NULL_TREE)
2992                       list = item = build_tree_list (purpose, t);
2993                     else
2994                       {
2995                         TREE_CHAIN (item) = build_tree_list (purpose, t);
2996                         item = TREE_CHAIN (item);
2997                       }
2998                   }
2999               }
3000             source_offset += length;
3001             dest_offset += length;
3002           }
3003       }
3004
3005       item = build_int_2 ((ffebld_accter_size (expr)
3006                            + ffebld_accter_pad (expr)) - 1, 0);
3007       ffebit_kill (ffebld_accter_bits (expr));
3008       TREE_TYPE (item) = ffecom_integer_type_node;
3009       item
3010         = build_array_type
3011           (tree_type,
3012            build_range_type (ffecom_integer_type_node,
3013                              ffecom_integer_zero_node,
3014                              item));
3015       list = build (CONSTRUCTOR, item, NULL_TREE, list);
3016       TREE_CONSTANT (list) = 1;
3017       TREE_STATIC (list) = 1;
3018       return list;
3019
3020     case FFEBLD_opARRTER:
3021       {
3022         ffetargetOffset i;
3023
3024         list = NULL_TREE;
3025         if (ffebld_arrter_pad (expr) == 0)
3026           item = NULL_TREE;
3027         else
3028           {
3029             assert (bt == FFEINFO_basictypeCHARACTER
3030                     && kt == FFEINFO_kindtypeCHARACTER1);
3031
3032             /* Becomes PURPOSE first time through loop.  */
3033             item = build_int_2 (ffebld_arrter_pad (expr), 0);
3034           }
3035
3036         for (i = 0; i < ffebld_arrter_size (expr); ++i)
3037           {
3038             ffebldConstantUnion cu
3039             = ffebld_constantarray_get (ffebld_arrter (expr), bt, kt, i);
3040
3041             t = ffecom_constantunion (&cu, bt, kt, tree_type);
3042
3043             if (list == NULL_TREE)
3044               /* Assume item is PURPOSE first time through loop.  */
3045               list = item = build_tree_list (item, t);
3046             else
3047               {
3048                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
3049                 item = TREE_CHAIN (item);
3050               }
3051           }
3052       }
3053
3054       item = build_int_2 ((ffebld_arrter_size (expr)
3055                           + ffebld_arrter_pad (expr)) - 1, 0);
3056       TREE_TYPE (item) = ffecom_integer_type_node;
3057       item
3058         = build_array_type
3059           (tree_type,
3060            build_range_type (ffecom_integer_type_node,
3061                              ffecom_integer_zero_node,
3062                              item));
3063       list = build (CONSTRUCTOR, item, NULL_TREE, list);
3064       TREE_CONSTANT (list) = 1;
3065       TREE_STATIC (list) = 1;
3066       return list;
3067
3068     case FFEBLD_opCONTER:
3069       assert (ffebld_conter_pad (expr) == 0);
3070       item
3071         = ffecom_constantunion (&ffebld_constant_union (ffebld_conter (expr)),
3072                                 bt, kt, tree_type);
3073       return item;
3074
3075     case FFEBLD_opSYMTER:
3076       if ((ffebld_symter_generic (expr) != FFEINTRIN_genNONE)
3077           || (ffebld_symter_specific (expr) != FFEINTRIN_specNONE))
3078         return ffecom_ptr_to_expr (expr);       /* Same as %REF(intrinsic). */
3079       s = ffebld_symter (expr);
3080       t = ffesymbol_hook (s).decl_tree;
3081
3082       if (assignp)
3083         {                       /* ASSIGN'ed-label expr. */
3084           if (ffe_is_ugly_assign ())
3085             {
3086               /* User explicitly wants ASSIGN'ed variables to be at the same
3087                  memory address as the variables when used in non-ASSIGN
3088                  contexts.  That can make old, arcane, non-standard code
3089                  work, but don't try to do it when a pointer wouldn't fit
3090                  in the normal variable (take other approach, and warn,
3091                  instead).  */
3092
3093               if (t == NULL_TREE)
3094                 {
3095                   s = ffecom_sym_transform_ (s);
3096                   t = ffesymbol_hook (s).decl_tree;
3097                   assert (t != NULL_TREE);
3098                 }
3099
3100               if (t == error_mark_node)
3101                 return t;
3102
3103               if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t)))
3104                   >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
3105                 {
3106                   if (ffesymbol_hook (s).addr)
3107                     t = ffecom_1 (INDIRECT_REF,
3108                                   TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3109                   return t;
3110                 }
3111
3112               if (ffesymbol_hook (s).assign_tree == NULL_TREE)
3113                 {
3114                   ffebad_start_msg ("ASSIGN'ed label cannot fit into `%A' at %0 -- using wider sibling",
3115                                     FFEBAD_severityWARNING);
3116                   ffebad_string (ffesymbol_text (s));
3117                   ffebad_here (0, ffesymbol_where_line (s),
3118                                ffesymbol_where_column (s));
3119                   ffebad_finish ();
3120                 }
3121             }
3122
3123           /* Don't use the normal variable's tree for ASSIGN, though mark
3124              it as in the system header (housekeeping).  Use an explicit,
3125              specially created sibling that is known to be wide enough
3126              to hold pointers to labels.  */
3127
3128           if (t != NULL_TREE
3129               && TREE_CODE (t) == VAR_DECL)
3130             DECL_IN_SYSTEM_HEADER (t) = 1;      /* Don't let -Wunused complain. */
3131
3132           t = ffesymbol_hook (s).assign_tree;
3133           if (t == NULL_TREE)
3134             {
3135               s = ffecom_sym_transform_assign_ (s);
3136               t = ffesymbol_hook (s).assign_tree;
3137               assert (t != NULL_TREE);
3138             }
3139         }
3140       else
3141         {
3142           if (t == NULL_TREE)
3143             {
3144               s = ffecom_sym_transform_ (s);
3145               t = ffesymbol_hook (s).decl_tree;
3146               assert (t != NULL_TREE);
3147             }
3148           if (ffesymbol_hook (s).addr)
3149             t = ffecom_1 (INDIRECT_REF,
3150                           TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3151         }
3152       return t;
3153
3154     case FFEBLD_opARRAYREF:
3155       return ffecom_arrayref_ (NULL_TREE, expr, 0);
3156
3157     case FFEBLD_opUPLUS:
3158       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3159       return ffecom_1 (NOP_EXPR, tree_type, left);
3160
3161     case FFEBLD_opPAREN:
3162       /* ~~~Make sure Fortran rules respected here */
3163       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3164       return ffecom_1 (NOP_EXPR, tree_type, left);
3165
3166     case FFEBLD_opUMINUS:
3167       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3168       if (tree_type_x)
3169         {
3170           tree_type = tree_type_x;
3171           left = convert (tree_type, left);
3172         }
3173       return ffecom_1 (NEGATE_EXPR, tree_type, left);
3174
3175     case FFEBLD_opADD:
3176       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3177       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3178       if (tree_type_x)
3179         {
3180           tree_type = tree_type_x;
3181           left = convert (tree_type, left);
3182           right = convert (tree_type, right);
3183         }
3184       return ffecom_2 (PLUS_EXPR, tree_type, left, right);
3185
3186     case FFEBLD_opSUBTRACT:
3187       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3188       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3189       if (tree_type_x)
3190         {
3191           tree_type = tree_type_x;
3192           left = convert (tree_type, left);
3193           right = convert (tree_type, right);
3194         }
3195       return ffecom_2 (MINUS_EXPR, tree_type, left, right);
3196
3197     case FFEBLD_opMULTIPLY:
3198       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3199       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3200       if (tree_type_x)
3201         {
3202           tree_type = tree_type_x;
3203           left = convert (tree_type, left);
3204           right = convert (tree_type, right);
3205         }
3206       return ffecom_2 (MULT_EXPR, tree_type, left, right);
3207
3208     case FFEBLD_opDIVIDE:
3209       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3210       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3211       if (tree_type_x)
3212         {
3213           tree_type = tree_type_x;
3214           left = convert (tree_type, left);
3215           right = convert (tree_type, right);
3216         }
3217       return ffecom_tree_divide_ (tree_type, left, right,
3218                                   dest_tree, dest, dest_used,
3219                                   ffebld_nonter_hook (expr));
3220
3221     case FFEBLD_opPOWER:
3222       {
3223         ffebld left = ffebld_left (expr);
3224         ffebld right = ffebld_right (expr);
3225         ffecomGfrt code;
3226         ffeinfoKindtype rtkt;
3227         ffeinfoKindtype ltkt;
3228         bool ref = TRUE;
3229
3230         switch (ffeinfo_basictype (ffebld_info (right)))
3231           {
3232
3233           case FFEINFO_basictypeINTEGER:
3234             if (1 || optimize)
3235               {
3236                 item = ffecom_expr_power_integer_ (expr);
3237                 if (item != NULL_TREE)
3238                   return item;
3239               }
3240
3241             rtkt = FFEINFO_kindtypeINTEGER1;
3242             switch (ffeinfo_basictype (ffebld_info (left)))
3243               {
3244               case FFEINFO_basictypeINTEGER:
3245                 if ((ffeinfo_kindtype (ffebld_info (left))
3246                     == FFEINFO_kindtypeINTEGER4)
3247                     || (ffeinfo_kindtype (ffebld_info (right))
3248                         == FFEINFO_kindtypeINTEGER4))
3249                   {
3250                     code = FFECOM_gfrtPOW_QQ;
3251                     ltkt = FFEINFO_kindtypeINTEGER4;
3252                     rtkt = FFEINFO_kindtypeINTEGER4;
3253                   }
3254                 else
3255                   {
3256                     code = FFECOM_gfrtPOW_II;
3257                     ltkt = FFEINFO_kindtypeINTEGER1;
3258                   }
3259                 break;
3260
3261               case FFEINFO_basictypeREAL:
3262                 if (ffeinfo_kindtype (ffebld_info (left))
3263                     == FFEINFO_kindtypeREAL1)
3264                   {
3265                     code = FFECOM_gfrtPOW_RI;
3266                     ltkt = FFEINFO_kindtypeREAL1;
3267                   }
3268                 else
3269                   {
3270                     code = FFECOM_gfrtPOW_DI;
3271                     ltkt = FFEINFO_kindtypeREAL2;
3272                   }
3273                 break;
3274
3275               case FFEINFO_basictypeCOMPLEX:
3276                 if (ffeinfo_kindtype (ffebld_info (left))
3277                     == FFEINFO_kindtypeREAL1)
3278                   {
3279                     code = FFECOM_gfrtPOW_CI;   /* Overlapping result okay. */
3280                     ltkt = FFEINFO_kindtypeREAL1;
3281                   }
3282                 else
3283                   {
3284                     code = FFECOM_gfrtPOW_ZI;   /* Overlapping result okay. */
3285                     ltkt = FFEINFO_kindtypeREAL2;
3286                   }
3287                 break;
3288
3289               default:
3290                 assert ("bad pow_*i" == NULL);
3291                 code = FFECOM_gfrtPOW_CI;       /* Overlapping result okay. */
3292                 ltkt = FFEINFO_kindtypeREAL1;
3293                 break;
3294               }
3295             if (ffeinfo_kindtype (ffebld_info (left)) != ltkt)
3296               left = ffeexpr_convert (left, NULL, NULL,
3297                                       ffeinfo_basictype (ffebld_info (left)),
3298                                       ltkt, 0,
3299                                       FFETARGET_charactersizeNONE,
3300                                       FFEEXPR_contextLET);
3301             if (ffeinfo_kindtype (ffebld_info (right)) != rtkt)
3302               right = ffeexpr_convert (right, NULL, NULL,
3303                                        FFEINFO_basictypeINTEGER,
3304                                        rtkt, 0,
3305                                        FFETARGET_charactersizeNONE,
3306                                        FFEEXPR_contextLET);
3307             break;
3308
3309           case FFEINFO_basictypeREAL:
3310             if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3311               left = ffeexpr_convert (left, NULL, NULL, FFEINFO_basictypeREAL,
3312                                       FFEINFO_kindtypeREALDOUBLE, 0,
3313                                       FFETARGET_charactersizeNONE,
3314                                       FFEEXPR_contextLET);
3315             if (ffeinfo_kindtype (ffebld_info (right))
3316                 == FFEINFO_kindtypeREAL1)
3317               right = ffeexpr_convert (right, NULL, NULL,
3318                                        FFEINFO_basictypeREAL,
3319                                        FFEINFO_kindtypeREALDOUBLE, 0,
3320                                        FFETARGET_charactersizeNONE,
3321                                        FFEEXPR_contextLET);
3322             /* We used to call FFECOM_gfrtPOW_DD here,
3323                which passes arguments by reference.  */
3324             code = FFECOM_gfrtL_POW;
3325             /* Pass arguments by value. */
3326             ref  = FALSE;
3327             break;
3328
3329           case FFEINFO_basictypeCOMPLEX:
3330             if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3331               left = ffeexpr_convert (left, NULL, NULL,
3332                                       FFEINFO_basictypeCOMPLEX,
3333                                       FFEINFO_kindtypeREALDOUBLE, 0,
3334                                       FFETARGET_charactersizeNONE,
3335                                       FFEEXPR_contextLET);
3336             if (ffeinfo_kindtype (ffebld_info (right))
3337                 == FFEINFO_kindtypeREAL1)
3338               right = ffeexpr_convert (right, NULL, NULL,
3339                                        FFEINFO_basictypeCOMPLEX,
3340                                        FFEINFO_kindtypeREALDOUBLE, 0,
3341                                        FFETARGET_charactersizeNONE,
3342                                        FFEEXPR_contextLET);
3343             code = FFECOM_gfrtPOW_ZZ;   /* Overlapping result okay. */
3344             ref = TRUE;                 /* Pass arguments by reference. */
3345             break;
3346
3347           default:
3348             assert ("bad pow_x*" == NULL);
3349             code = FFECOM_gfrtPOW_II;
3350             break;
3351           }
3352         return ffecom_call_binop_ (ffecom_gfrt_tree_ (code),
3353                                    ffecom_gfrt_kindtype (code),
3354                                    (ffe_is_f2c_library ()
3355                                     && ffecom_gfrt_complex_[code]),
3356                                    tree_type, left, right,
3357                                    dest_tree, dest, dest_used,
3358                                    NULL_TREE, FALSE, ref,
3359                                    ffebld_nonter_hook (expr));
3360       }
3361
3362     case FFEBLD_opNOT:
3363       switch (bt)
3364         {
3365         case FFEINFO_basictypeLOGICAL:
3366           item = ffecom_truth_value_invert (ffecom_expr (ffebld_left (expr)));
3367           return convert (tree_type, item);
3368
3369         case FFEINFO_basictypeINTEGER:
3370           return ffecom_1 (BIT_NOT_EXPR, tree_type,
3371                            ffecom_expr (ffebld_left (expr)));
3372
3373         default:
3374           assert ("NOT bad basictype" == NULL);
3375           /* Fall through. */
3376         case FFEINFO_basictypeANY:
3377           return error_mark_node;
3378         }
3379       break;
3380
3381     case FFEBLD_opFUNCREF:
3382       assert (ffeinfo_basictype (ffebld_info (expr))
3383               != FFEINFO_basictypeCHARACTER);
3384       /* Fall through.   */
3385     case FFEBLD_opSUBRREF:
3386       if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
3387           == FFEINFO_whereINTRINSIC)
3388         {                       /* Invocation of an intrinsic. */
3389           item = ffecom_expr_intrinsic_ (expr, dest_tree, dest,
3390                                          dest_used);
3391           return item;
3392         }
3393       s = ffebld_symter (ffebld_left (expr));
3394       dt = ffesymbol_hook (s).decl_tree;
3395       if (dt == NULL_TREE)
3396         {
3397           s = ffecom_sym_transform_ (s);
3398           dt = ffesymbol_hook (s).decl_tree;
3399         }
3400       if (dt == error_mark_node)
3401         return dt;
3402
3403       if (ffesymbol_hook (s).addr)
3404         item = dt;
3405       else
3406         item = ffecom_1_fn (dt);
3407
3408       if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
3409         args = ffecom_list_expr (ffebld_right (expr));
3410       else
3411         args = ffecom_list_ptr_to_expr (ffebld_right (expr));
3412
3413       if (args == error_mark_node)
3414         return error_mark_node;
3415
3416       item = ffecom_call_ (item, kt,
3417                            ffesymbol_is_f2c (s)
3418                            && (bt == FFEINFO_basictypeCOMPLEX)
3419                            && (ffesymbol_where (s)
3420                                != FFEINFO_whereCONSTANT),
3421                            tree_type,
3422                            args,
3423                            dest_tree, dest, dest_used,
3424                            error_mark_node, FALSE,
3425                            ffebld_nonter_hook (expr));
3426       TREE_SIDE_EFFECTS (item) = 1;
3427       return item;
3428
3429     case FFEBLD_opAND:
3430       switch (bt)
3431         {
3432         case FFEINFO_basictypeLOGICAL:
3433           item
3434             = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3435                        ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3436                      ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3437           return convert (tree_type, item);
3438
3439         case FFEINFO_basictypeINTEGER:
3440           return ffecom_2 (BIT_AND_EXPR, tree_type,
3441                            ffecom_expr (ffebld_left (expr)),
3442                            ffecom_expr (ffebld_right (expr)));
3443
3444         default:
3445           assert ("AND bad basictype" == NULL);
3446           /* Fall through. */
3447         case FFEINFO_basictypeANY:
3448           return error_mark_node;
3449         }
3450       break;
3451
3452     case FFEBLD_opOR:
3453       switch (bt)
3454         {
3455         case FFEINFO_basictypeLOGICAL:
3456           item
3457             = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
3458                        ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3459                      ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3460           return convert (tree_type, item);
3461
3462         case FFEINFO_basictypeINTEGER:
3463           return ffecom_2 (BIT_IOR_EXPR, tree_type,
3464                            ffecom_expr (ffebld_left (expr)),
3465                            ffecom_expr (ffebld_right (expr)));
3466
3467         default:
3468           assert ("OR bad basictype" == NULL);
3469           /* Fall through. */
3470         case FFEINFO_basictypeANY:
3471           return error_mark_node;
3472         }
3473       break;
3474
3475     case FFEBLD_opXOR:
3476     case FFEBLD_opNEQV:
3477       switch (bt)
3478         {
3479         case FFEINFO_basictypeLOGICAL:
3480           item
3481             = ffecom_2 (NE_EXPR, integer_type_node,
3482                         ffecom_expr (ffebld_left (expr)),
3483                         ffecom_expr (ffebld_right (expr)));
3484           return convert (tree_type, ffecom_truth_value (item));
3485
3486         case FFEINFO_basictypeINTEGER:
3487           return ffecom_2 (BIT_XOR_EXPR, tree_type,
3488                            ffecom_expr (ffebld_left (expr)),
3489                            ffecom_expr (ffebld_right (expr)));
3490
3491         default:
3492           assert ("XOR/NEQV bad basictype" == NULL);
3493           /* Fall through. */
3494         case FFEINFO_basictypeANY:
3495           return error_mark_node;
3496         }
3497       break;
3498
3499     case FFEBLD_opEQV:
3500       switch (bt)
3501         {
3502         case FFEINFO_basictypeLOGICAL:
3503           item
3504             = ffecom_2 (EQ_EXPR, integer_type_node,
3505                         ffecom_expr (ffebld_left (expr)),
3506                         ffecom_expr (ffebld_right (expr)));
3507           return convert (tree_type, ffecom_truth_value (item));
3508
3509         case FFEINFO_basictypeINTEGER:
3510           return
3511             ffecom_1 (BIT_NOT_EXPR, tree_type,
3512                       ffecom_2 (BIT_XOR_EXPR, tree_type,
3513                                 ffecom_expr (ffebld_left (expr)),
3514                                 ffecom_expr (ffebld_right (expr))));
3515
3516         default:
3517           assert ("EQV bad basictype" == NULL);
3518           /* Fall through. */
3519         case FFEINFO_basictypeANY:
3520           return error_mark_node;
3521         }
3522       break;
3523
3524     case FFEBLD_opCONVERT:
3525       if (ffebld_op (ffebld_left (expr)) == FFEBLD_opANY)
3526         return error_mark_node;
3527
3528       switch (bt)
3529         {
3530         case FFEINFO_basictypeLOGICAL:
3531         case FFEINFO_basictypeINTEGER:
3532         case FFEINFO_basictypeREAL:
3533           return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3534
3535         case FFEINFO_basictypeCOMPLEX:
3536           switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3537             {
3538             case FFEINFO_basictypeINTEGER:
3539             case FFEINFO_basictypeLOGICAL:
3540             case FFEINFO_basictypeREAL:
3541               item = ffecom_expr (ffebld_left (expr));
3542               if (item == error_mark_node)
3543                 return error_mark_node;
3544               /* convert() takes care of converting to the subtype first,
3545                  at least in gcc-2.7.2. */
3546               item = convert (tree_type, item);
3547               return item;
3548
3549             case FFEINFO_basictypeCOMPLEX:
3550               return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3551
3552             default:
3553               assert ("CONVERT COMPLEX bad basictype" == NULL);
3554               /* Fall through. */
3555             case FFEINFO_basictypeANY:
3556               return error_mark_node;
3557             }
3558           break;
3559
3560         default:
3561           assert ("CONVERT bad basictype" == NULL);
3562           /* Fall through. */
3563         case FFEINFO_basictypeANY:
3564           return error_mark_node;
3565         }
3566       break;
3567
3568     case FFEBLD_opLT:
3569       code = LT_EXPR;
3570       goto relational;          /* :::::::::::::::::::: */
3571
3572     case FFEBLD_opLE:
3573       code = LE_EXPR;
3574       goto relational;          /* :::::::::::::::::::: */
3575
3576     case FFEBLD_opEQ:
3577       code = EQ_EXPR;
3578       goto relational;          /* :::::::::::::::::::: */
3579
3580     case FFEBLD_opNE:
3581       code = NE_EXPR;
3582       goto relational;          /* :::::::::::::::::::: */
3583
3584     case FFEBLD_opGT:
3585       code = GT_EXPR;
3586       goto relational;          /* :::::::::::::::::::: */
3587
3588     case FFEBLD_opGE:
3589       code = GE_EXPR;
3590
3591     relational:         /* :::::::::::::::::::: */
3592       switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3593         {
3594         case FFEINFO_basictypeLOGICAL:
3595         case FFEINFO_basictypeINTEGER:
3596         case FFEINFO_basictypeREAL:
3597           item = ffecom_2 (code, integer_type_node,
3598                            ffecom_expr (ffebld_left (expr)),
3599                            ffecom_expr (ffebld_right (expr)));
3600           return convert (tree_type, item);
3601
3602         case FFEINFO_basictypeCOMPLEX:
3603           assert (code == EQ_EXPR || code == NE_EXPR);
3604           {
3605             tree real_type;
3606             tree arg1 = ffecom_expr (ffebld_left (expr));
3607             tree arg2 = ffecom_expr (ffebld_right (expr));
3608
3609             if (arg1 == error_mark_node || arg2 == error_mark_node)
3610               return error_mark_node;
3611
3612             arg1 = ffecom_save_tree (arg1);
3613             arg2 = ffecom_save_tree (arg2);
3614
3615             if (TREE_CODE (TREE_TYPE (arg1)) == COMPLEX_TYPE)
3616               {
3617                 real_type = TREE_TYPE (TREE_TYPE (arg1));
3618                 assert (real_type == TREE_TYPE (TREE_TYPE (arg2)));
3619               }
3620             else
3621               {
3622                 real_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg1)));
3623                 assert (real_type == TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg2))));
3624               }
3625
3626             item
3627               = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3628                           ffecom_2 (EQ_EXPR, integer_type_node,
3629                                   ffecom_1 (REALPART_EXPR, real_type, arg1),
3630                                  ffecom_1 (REALPART_EXPR, real_type, arg2)),
3631                           ffecom_2 (EQ_EXPR, integer_type_node,
3632                                   ffecom_1 (IMAGPART_EXPR, real_type, arg1),
3633                                     ffecom_1 (IMAGPART_EXPR, real_type,
3634                                               arg2)));
3635             if (code == EQ_EXPR)
3636               item = ffecom_truth_value (item);
3637             else
3638               item = ffecom_truth_value_invert (item);
3639             return convert (tree_type, item);
3640           }
3641
3642         case FFEINFO_basictypeCHARACTER:
3643           {
3644             ffebld left = ffebld_left (expr);
3645             ffebld right = ffebld_right (expr);
3646             tree left_tree;
3647             tree right_tree;
3648             tree left_length;
3649             tree right_length;
3650
3651             /* f2c run-time functions do the implicit blank-padding for us,
3652                so we don't usually have to implement blank-padding ourselves.
3653                (The exception is when we pass an argument to a separately
3654                compiled statement function -- if we know the arg is not the
3655                same length as the dummy, we must truncate or extend it.  If
3656                we "inline" statement functions, that necessity goes away as
3657                well.)
3658
3659                Strip off the CONVERT operators that blank-pad.  (Truncation by
3660                CONVERT shouldn't happen here, but it can happen in
3661                assignments.) */
3662
3663             while (ffebld_op (left) == FFEBLD_opCONVERT)
3664               left = ffebld_left (left);
3665             while (ffebld_op (right) == FFEBLD_opCONVERT)
3666               right = ffebld_left (right);
3667
3668             left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
3669             right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
3670
3671             if (left_tree == error_mark_node || left_length == error_mark_node
3672                 || right_tree == error_mark_node
3673                 || right_length == error_mark_node)
3674               return error_mark_node;
3675
3676             if ((ffebld_size_known (left) == 1)
3677                 && (ffebld_size_known (right) == 1))
3678               {
3679                 left_tree
3680                   = ffecom_1 (INDIRECT_REF,
3681                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3682                               left_tree);
3683                 right_tree
3684                   = ffecom_1 (INDIRECT_REF,
3685                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3686                               right_tree);
3687
3688                 item
3689                   = ffecom_2 (code, integer_type_node,
3690                               ffecom_2 (ARRAY_REF,
3691                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3692                                         left_tree,
3693                                         integer_one_node),
3694                               ffecom_2 (ARRAY_REF,
3695                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3696                                         right_tree,
3697                                         integer_one_node));
3698               }
3699             else
3700               {
3701                 item = build_tree_list (NULL_TREE, left_tree);
3702                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, right_tree);
3703                 TREE_CHAIN (TREE_CHAIN (item)) = build_tree_list (NULL_TREE,
3704                                                                left_length);
3705                 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
3706                   = build_tree_list (NULL_TREE, right_length);
3707                 item = ffecom_call_gfrt (FFECOM_gfrtCMP, item, NULL_TREE);
3708                 item = ffecom_2 (code, integer_type_node,
3709                                  item,
3710                                  convert (TREE_TYPE (item),
3711                                           integer_zero_node));
3712               }
3713             item = convert (tree_type, item);
3714           }
3715
3716           return item;
3717
3718         default:
3719           assert ("relational bad basictype" == NULL);
3720           /* Fall through. */
3721         case FFEINFO_basictypeANY:
3722           return error_mark_node;
3723         }
3724       break;
3725
3726     case FFEBLD_opPERCENT_LOC:
3727       item = ffecom_arg_ptr_to_expr (ffebld_left (expr), &list);
3728       return convert (tree_type, item);
3729
3730     case FFEBLD_opITEM:
3731     case FFEBLD_opSTAR:
3732     case FFEBLD_opBOUNDS:
3733     case FFEBLD_opREPEAT:
3734     case FFEBLD_opLABTER:
3735     case FFEBLD_opLABTOK:
3736     case FFEBLD_opIMPDO:
3737     case FFEBLD_opCONCATENATE:
3738     case FFEBLD_opSUBSTR:
3739     default:
3740       assert ("bad op" == NULL);
3741       /* Fall through. */
3742     case FFEBLD_opANY:
3743       return error_mark_node;
3744     }
3745
3746 #if 1
3747   assert ("didn't think anything got here anymore!!" == NULL);
3748 #else
3749   switch (ffebld_arity (expr))
3750     {
3751     case 2:
3752       TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3753       TREE_OPERAND (item, 1) = ffecom_expr (ffebld_right (expr));
3754       if (TREE_OPERAND (item, 0) == error_mark_node
3755           || TREE_OPERAND (item, 1) == error_mark_node)
3756         return error_mark_node;
3757       break;
3758
3759     case 1:
3760       TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3761       if (TREE_OPERAND (item, 0) == error_mark_node)
3762         return error_mark_node;
3763       break;
3764
3765     default:
3766       break;
3767     }
3768
3769   return fold (item);
3770 #endif
3771 }
3772
3773 /* Returns the tree that does the intrinsic invocation.
3774
3775    Note: this function applies only to intrinsics returning
3776    CHARACTER*1 or non-CHARACTER results, and to intrinsic
3777    subroutines.  */
3778
3779 static tree
3780 ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
3781                         ffebld dest, bool *dest_used)
3782 {
3783   tree expr_tree;
3784   tree saved_expr1;             /* For those who need it. */
3785   tree saved_expr2;             /* For those who need it. */
3786   ffeinfoBasictype bt;
3787   ffeinfoKindtype kt;
3788   tree tree_type;
3789   tree arg1_type;
3790   tree real_type;               /* REAL type corresponding to COMPLEX. */
3791   tree tempvar;
3792   ffebld list = ffebld_right (expr);    /* List of (some) args. */
3793   ffebld arg1;                  /* For handy reference. */
3794   ffebld arg2;
3795   ffebld arg3;
3796   ffeintrinImp codegen_imp;
3797   ffecomGfrt gfrt;
3798
3799   assert (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER);
3800
3801   if (dest_used != NULL)
3802     *dest_used = FALSE;
3803
3804   bt = ffeinfo_basictype (ffebld_info (expr));
3805   kt = ffeinfo_kindtype (ffebld_info (expr));
3806   tree_type = ffecom_tree_type[bt][kt];
3807
3808   if (list != NULL)
3809     {
3810       arg1 = ffebld_head (list);
3811       if (arg1 != NULL && ffebld_op (arg1) == FFEBLD_opANY)
3812         return error_mark_node;
3813       if ((list = ffebld_trail (list)) != NULL)
3814         {
3815           arg2 = ffebld_head (list);
3816           if (arg2 != NULL && ffebld_op (arg2) == FFEBLD_opANY)
3817             return error_mark_node;
3818           if ((list = ffebld_trail (list)) != NULL)
3819             {
3820               arg3 = ffebld_head (list);
3821               if (arg3 != NULL && ffebld_op (arg3) == FFEBLD_opANY)
3822                 return error_mark_node;
3823             }
3824           else
3825             arg3 = NULL;
3826         }
3827       else
3828         arg2 = arg3 = NULL;
3829     }
3830   else
3831     arg1 = arg2 = arg3 = NULL;
3832
3833   /* <list> ends up at the opITEM of the 3rd arg, or NULL if there are < 3
3834      args.  This is used by the MAX/MIN expansions. */
3835
3836   if (arg1 != NULL)
3837     arg1_type = ffecom_tree_type
3838       [ffeinfo_basictype (ffebld_info (arg1))]
3839       [ffeinfo_kindtype (ffebld_info (arg1))];
3840   else
3841     arg1_type = NULL_TREE;      /* Really not needed, but might catch bugs
3842                                    here. */
3843
3844   /* There are several ways for each of the cases in the following switch
3845      statements to exit (from simplest to use to most complicated):
3846
3847      break;  (when expr_tree == NULL)
3848
3849      A standard call is made to the specific intrinsic just as if it had been
3850      passed in as a dummy procedure and called as any old procedure.  This
3851      method can produce slower code but in some cases it's the easiest way for
3852      now.  However, if a (presumably faster) direct call is available,
3853      that is used, so this is the easiest way in many more cases now.
3854
3855      gfrt = FFECOM_gfrtWHATEVER;
3856      break;
3857
3858      gfrt contains the gfrt index of a library function to call, passing the
3859      argument(s) by value rather than by reference.  Used when a more
3860      careful choice of library function is needed than that provided
3861      by the vanilla `break;'.
3862
3863      return expr_tree;
3864
3865      The expr_tree has been completely set up and is ready to be returned
3866      as is.  No further actions are taken.  Use this when the tree is not
3867      in the simple form for one of the arity_n labels.   */
3868
3869   /* For info on how the switch statement cases were written, see the files
3870      enclosed in comments below the switch statement. */
3871
3872   codegen_imp = ffebld_symter_implementation (ffebld_left (expr));
3873   gfrt = ffeintrin_gfrt_direct (codegen_imp);
3874   if (gfrt == FFECOM_gfrt)
3875     gfrt = ffeintrin_gfrt_indirect (codegen_imp);
3876
3877   switch (codegen_imp)
3878     {
3879     case FFEINTRIN_impABS:
3880     case FFEINTRIN_impCABS:
3881     case FFEINTRIN_impCDABS:
3882     case FFEINTRIN_impDABS:
3883     case FFEINTRIN_impIABS:
3884       if (ffeinfo_basictype (ffebld_info (arg1))
3885           == FFEINFO_basictypeCOMPLEX)
3886         {
3887           if (kt == FFEINFO_kindtypeREAL1)
3888             gfrt = FFECOM_gfrtCABS;
3889           else if (kt == FFEINFO_kindtypeREAL2)
3890             gfrt = FFECOM_gfrtCDABS;
3891           break;
3892         }
3893       return ffecom_1 (ABS_EXPR, tree_type,
3894                        convert (tree_type, ffecom_expr (arg1)));
3895
3896     case FFEINTRIN_impACOS:
3897     case FFEINTRIN_impDACOS:
3898       break;
3899
3900     case FFEINTRIN_impAIMAG:
3901     case FFEINTRIN_impDIMAG:
3902     case FFEINTRIN_impIMAGPART:
3903       if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
3904         arg1_type = TREE_TYPE (arg1_type);
3905       else
3906         arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
3907
3908       return
3909         convert (tree_type,
3910                  ffecom_1 (IMAGPART_EXPR, arg1_type,
3911                            ffecom_expr (arg1)));
3912
3913     case FFEINTRIN_impAINT:
3914     case FFEINTRIN_impDINT:
3915 #if 0
3916       /* ~~Someday implement FIX_TRUNC_EXPR yielding same type as arg.  */
3917       return ffecom_1 (FIX_TRUNC_EXPR, tree_type, ffecom_expr (arg1));
3918 #else /* in the meantime, must use floor to avoid range problems with ints */
3919       /* r__1 = r1 >= 0 ? floor(r1) : -floor(-r1); */
3920       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
3921       return
3922         convert (tree_type,
3923                  ffecom_3 (COND_EXPR, double_type_node,
3924                            ffecom_truth_value
3925                            (ffecom_2 (GE_EXPR, integer_type_node,
3926                                       saved_expr1,
3927                                       convert (arg1_type,
3928                                                ffecom_float_zero_))),
3929                            ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
3930                                              build_tree_list (NULL_TREE,
3931                                                   convert (double_type_node,
3932                                                            saved_expr1)),
3933                                              NULL_TREE),
3934                            ffecom_1 (NEGATE_EXPR, double_type_node,
3935                                      ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
3936                                                  build_tree_list (NULL_TREE,
3937                                                   convert (double_type_node,
3938                                                       ffecom_1 (NEGATE_EXPR,
3939                                                                 arg1_type,
3940                                                                saved_expr1))),
3941                                                        NULL_TREE)
3942                                      ))
3943                  );
3944 #endif
3945
3946     case FFEINTRIN_impANINT:
3947     case FFEINTRIN_impDNINT:
3948 #if 0                           /* This way of doing it won't handle real
3949                                    numbers of large magnitudes. */
3950       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
3951       expr_tree = convert (tree_type,
3952                            convert (integer_type_node,
3953                                     ffecom_3 (COND_EXPR, tree_type,
3954                                               ffecom_truth_value
3955                                               (ffecom_2 (GE_EXPR,
3956                                                          integer_type_node,
3957                                                          saved_expr1,
3958                                                        ffecom_float_zero_)),
3959                                               ffecom_2 (PLUS_EXPR,
3960                                                         tree_type,
3961                                                         saved_expr1,
3962                                                         ffecom_float_half_),
3963                                               ffecom_2 (MINUS_EXPR,
3964                                                         tree_type,
3965                                                         saved_expr1,
3966                                                      ffecom_float_half_))));
3967       return expr_tree;
3968 #else /* So we instead call floor. */
3969       /* r__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1) */
3970       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
3971       return
3972         convert (tree_type,
3973                  ffecom_3 (COND_EXPR, double_type_node,
3974                            ffecom_truth_value
3975                            (ffecom_2 (GE_EXPR, integer_type_node,
3976                                       saved_expr1,
3977                                       convert (arg1_type,
3978                                                ffecom_float_zero_))),
3979                            ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
3980                                              build_tree_list (NULL_TREE,
3981                                                   convert (double_type_node,
3982                                                            ffecom_2 (PLUS_EXPR,
3983                                                                      arg1_type,
3984                                                                      saved_expr1,
3985                                                                      convert (arg1_type,
3986                                                                               ffecom_float_half_)))),
3987                                              NULL_TREE),
3988                            ffecom_1 (NEGATE_EXPR, double_type_node,
3989                                      ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
3990                                                        build_tree_list (NULL_TREE,
3991                                                                         convert (double_type_node,
3992                                                                                  ffecom_2 (MINUS_EXPR,
3993                                                                                            arg1_type,
3994                                                                                            convert (arg1_type,
3995                                                                                                     ffecom_float_half_),
3996                                                                                            saved_expr1))),
3997                                                        NULL_TREE))
3998                            )
3999                  );
4000 #endif
4001
4002     case FFEINTRIN_impASIN:
4003     case FFEINTRIN_impDASIN:
4004     case FFEINTRIN_impATAN:
4005     case FFEINTRIN_impDATAN:
4006     case FFEINTRIN_impATAN2:
4007     case FFEINTRIN_impDATAN2:
4008       break;
4009
4010     case FFEINTRIN_impCHAR:
4011     case FFEINTRIN_impACHAR:
4012 #ifdef HOHO
4013       tempvar = ffecom_make_tempvar (char_type_node, 1, -1);
4014 #else
4015       tempvar = ffebld_nonter_hook (expr);
4016       assert (tempvar);
4017 #endif
4018       {
4019         tree tmv = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (tempvar)));
4020
4021         expr_tree = ffecom_modify (tmv,
4022                                    ffecom_2 (ARRAY_REF, tmv, tempvar,
4023                                              integer_one_node),
4024                                    convert (tmv, ffecom_expr (arg1)));
4025       }
4026       expr_tree = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar),
4027                             expr_tree,
4028                             tempvar);
4029       expr_tree = ffecom_1 (ADDR_EXPR,
4030                             build_pointer_type (TREE_TYPE (expr_tree)),
4031                             expr_tree);
4032       return expr_tree;
4033
4034     case FFEINTRIN_impCMPLX:
4035     case FFEINTRIN_impDCMPLX:
4036       if (arg2 == NULL)
4037         return
4038           convert (tree_type, ffecom_expr (arg1));
4039
4040       real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4041       return
4042         ffecom_2 (COMPLEX_EXPR, tree_type,
4043                   convert (real_type, ffecom_expr (arg1)),
4044                   convert (real_type,
4045                            ffecom_expr (arg2)));
4046
4047     case FFEINTRIN_impCOMPLEX:
4048       return
4049         ffecom_2 (COMPLEX_EXPR, tree_type,
4050                   ffecom_expr (arg1),
4051                   ffecom_expr (arg2));
4052
4053     case FFEINTRIN_impCONJG:
4054     case FFEINTRIN_impDCONJG:
4055       {
4056         tree arg1_tree;
4057
4058         real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4059         arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4060         return
4061           ffecom_2 (COMPLEX_EXPR, tree_type,
4062                     ffecom_1 (REALPART_EXPR, real_type, arg1_tree),
4063                     ffecom_1 (NEGATE_EXPR, real_type,
4064                               ffecom_1 (IMAGPART_EXPR, real_type, arg1_tree)));
4065       }
4066
4067     case FFEINTRIN_impCOS:
4068     case FFEINTRIN_impCCOS:
4069     case FFEINTRIN_impCDCOS:
4070     case FFEINTRIN_impDCOS:
4071       if (bt == FFEINFO_basictypeCOMPLEX)
4072         {
4073           if (kt == FFEINFO_kindtypeREAL1)
4074             gfrt = FFECOM_gfrtCCOS;     /* Overlapping result okay. */
4075           else if (kt == FFEINFO_kindtypeREAL2)
4076             gfrt = FFECOM_gfrtCDCOS;    /* Overlapping result okay. */
4077         }
4078       break;
4079
4080     case FFEINTRIN_impCOSH:
4081     case FFEINTRIN_impDCOSH:
4082       break;
4083
4084     case FFEINTRIN_impDBLE:
4085     case FFEINTRIN_impDFLOAT:
4086     case FFEINTRIN_impDREAL:
4087     case FFEINTRIN_impFLOAT:
4088     case FFEINTRIN_impIDINT:
4089     case FFEINTRIN_impIFIX:
4090     case FFEINTRIN_impINT2:
4091     case FFEINTRIN_impINT8:
4092     case FFEINTRIN_impINT:
4093     case FFEINTRIN_impLONG:
4094     case FFEINTRIN_impREAL:
4095     case FFEINTRIN_impSHORT:
4096     case FFEINTRIN_impSNGL:
4097       return convert (tree_type, ffecom_expr (arg1));
4098
4099     case FFEINTRIN_impDIM:
4100     case FFEINTRIN_impDDIM:
4101     case FFEINTRIN_impIDIM:
4102       saved_expr1 = ffecom_save_tree (convert (tree_type,
4103                                                ffecom_expr (arg1)));
4104       saved_expr2 = ffecom_save_tree (convert (tree_type,
4105                                                ffecom_expr (arg2)));
4106       return
4107         ffecom_3 (COND_EXPR, tree_type,
4108                   ffecom_truth_value
4109                   (ffecom_2 (GT_EXPR, integer_type_node,
4110                              saved_expr1,
4111                              saved_expr2)),
4112                   ffecom_2 (MINUS_EXPR, tree_type,
4113                             saved_expr1,
4114                             saved_expr2),
4115                   convert (tree_type, ffecom_float_zero_));
4116
4117     case FFEINTRIN_impDPROD:
4118       return
4119         ffecom_2 (MULT_EXPR, tree_type,
4120                   convert (tree_type, ffecom_expr (arg1)),
4121                   convert (tree_type, ffecom_expr (arg2)));
4122
4123     case FFEINTRIN_impEXP:
4124     case FFEINTRIN_impCDEXP:
4125     case FFEINTRIN_impCEXP:
4126     case FFEINTRIN_impDEXP:
4127       if (bt == FFEINFO_basictypeCOMPLEX)
4128         {
4129           if (kt == FFEINFO_kindtypeREAL1)
4130             gfrt = FFECOM_gfrtCEXP;     /* Overlapping result okay. */
4131           else if (kt == FFEINFO_kindtypeREAL2)
4132             gfrt = FFECOM_gfrtCDEXP;    /* Overlapping result okay. */
4133         }
4134       break;
4135
4136     case FFEINTRIN_impICHAR:
4137     case FFEINTRIN_impIACHAR:
4138 #if 0                           /* The simple approach. */
4139       ffecom_char_args_ (&expr_tree, &saved_expr1 /* Ignored */ , arg1);
4140       expr_tree
4141         = ffecom_1 (INDIRECT_REF,
4142                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4143                     expr_tree);
4144       expr_tree
4145         = ffecom_2 (ARRAY_REF,
4146                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4147                     expr_tree,
4148                     integer_one_node);
4149       return convert (tree_type, expr_tree);
4150 #else /* The more interesting (and more optimal) approach. */
4151       expr_tree = ffecom_intrinsic_ichar_ (tree_type, arg1, &saved_expr1);
4152       expr_tree = ffecom_3 (COND_EXPR, tree_type,
4153                             saved_expr1,
4154                             expr_tree,
4155                             convert (tree_type, integer_zero_node));
4156       return expr_tree;
4157 #endif
4158
4159     case FFEINTRIN_impINDEX:
4160       break;
4161
4162     case FFEINTRIN_impLEN:
4163 #if 0
4164       break;                                    /* The simple approach. */
4165 #else
4166       return ffecom_intrinsic_len_ (arg1);      /* The more optimal approach. */
4167 #endif
4168
4169     case FFEINTRIN_impLGE:
4170     case FFEINTRIN_impLGT:
4171     case FFEINTRIN_impLLE:
4172     case FFEINTRIN_impLLT:
4173       break;
4174
4175     case FFEINTRIN_impLOG:
4176     case FFEINTRIN_impALOG:
4177     case FFEINTRIN_impCDLOG:
4178     case FFEINTRIN_impCLOG:
4179     case FFEINTRIN_impDLOG:
4180       if (bt == FFEINFO_basictypeCOMPLEX)
4181         {
4182           if (kt == FFEINFO_kindtypeREAL1)
4183             gfrt = FFECOM_gfrtCLOG;     /* Overlapping result okay. */
4184           else if (kt == FFEINFO_kindtypeREAL2)
4185             gfrt = FFECOM_gfrtCDLOG;    /* Overlapping result okay. */
4186         }
4187       break;
4188
4189     case FFEINTRIN_impLOG10:
4190     case FFEINTRIN_impALOG10:
4191     case FFEINTRIN_impDLOG10:
4192       if (gfrt != FFECOM_gfrt)
4193         break;  /* Already picked one, stick with it. */
4194
4195       if (kt == FFEINFO_kindtypeREAL1)
4196         /* We used to call FFECOM_gfrtALOG10 here.  */
4197         gfrt = FFECOM_gfrtL_LOG10;
4198       else if (kt == FFEINFO_kindtypeREAL2)
4199         /* We used to call FFECOM_gfrtDLOG10 here.  */
4200         gfrt = FFECOM_gfrtL_LOG10;
4201       break;
4202
4203     case FFEINTRIN_impMAX:
4204     case FFEINTRIN_impAMAX0:
4205     case FFEINTRIN_impAMAX1:
4206     case FFEINTRIN_impDMAX1:
4207     case FFEINTRIN_impMAX0:
4208     case FFEINTRIN_impMAX1:
4209       if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4210         arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4211       else
4212         arg1_type = tree_type;
4213       expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4214                             convert (arg1_type, ffecom_expr (arg1)),
4215                             convert (arg1_type, ffecom_expr (arg2)));
4216       for (; list != NULL; list = ffebld_trail (list))
4217         {
4218           if ((ffebld_head (list) == NULL)
4219               || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4220             continue;
4221           expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4222                                 expr_tree,
4223                                 convert (arg1_type,
4224                                          ffecom_expr (ffebld_head (list))));
4225         }
4226       return convert (tree_type, expr_tree);
4227
4228     case FFEINTRIN_impMIN:
4229     case FFEINTRIN_impAMIN0:
4230     case FFEINTRIN_impAMIN1:
4231     case FFEINTRIN_impDMIN1:
4232     case FFEINTRIN_impMIN0:
4233     case FFEINTRIN_impMIN1:
4234       if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4235         arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4236       else
4237         arg1_type = tree_type;
4238       expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4239                             convert (arg1_type, ffecom_expr (arg1)),
4240                             convert (arg1_type, ffecom_expr (arg2)));
4241       for (; list != NULL; list = ffebld_trail (list))
4242         {
4243           if ((ffebld_head (list) == NULL)
4244               || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4245             continue;
4246           expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4247                                 expr_tree,
4248                                 convert (arg1_type,
4249                                          ffecom_expr (ffebld_head (list))));
4250         }
4251       return convert (tree_type, expr_tree);
4252
4253     case FFEINTRIN_impMOD:
4254     case FFEINTRIN_impAMOD:
4255     case FFEINTRIN_impDMOD:
4256       if (bt != FFEINFO_basictypeREAL)
4257         return ffecom_2 (TRUNC_MOD_EXPR, tree_type,
4258                          convert (tree_type, ffecom_expr (arg1)),
4259                          convert (tree_type, ffecom_expr (arg2)));
4260
4261       if (kt == FFEINFO_kindtypeREAL1)
4262         /* We used to call FFECOM_gfrtAMOD here.  */
4263         gfrt = FFECOM_gfrtL_FMOD;
4264       else if (kt == FFEINFO_kindtypeREAL2)
4265         /* We used to call FFECOM_gfrtDMOD here.  */
4266         gfrt = FFECOM_gfrtL_FMOD;
4267       break;
4268
4269     case FFEINTRIN_impNINT:
4270     case FFEINTRIN_impIDNINT:
4271 #if 0
4272       /* ~~Ideally FIX_ROUND_EXPR would be implemented, but it ain't yet.  */
4273       return ffecom_1 (FIX_ROUND_EXPR, tree_type, ffecom_expr (arg1));
4274 #else
4275       /* i__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1); */
4276       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4277       return
4278         convert (ffecom_integer_type_node,
4279                  ffecom_3 (COND_EXPR, arg1_type,
4280                            ffecom_truth_value
4281                            (ffecom_2 (GE_EXPR, integer_type_node,
4282                                       saved_expr1,
4283                                       convert (arg1_type,
4284                                                ffecom_float_zero_))),
4285                            ffecom_2 (PLUS_EXPR, arg1_type,
4286                                      saved_expr1,
4287                                      convert (arg1_type,
4288                                               ffecom_float_half_)),
4289                            ffecom_2 (MINUS_EXPR, arg1_type,
4290                                      saved_expr1,
4291                                      convert (arg1_type,
4292                                               ffecom_float_half_))));
4293 #endif
4294
4295     case FFEINTRIN_impSIGN:
4296     case FFEINTRIN_impDSIGN:
4297     case FFEINTRIN_impISIGN:
4298       {
4299         tree arg2_tree = ffecom_expr (arg2);
4300
4301         saved_expr1
4302           = ffecom_save_tree
4303           (ffecom_1 (ABS_EXPR, tree_type,
4304                      convert (tree_type,
4305                               ffecom_expr (arg1))));
4306         expr_tree
4307           = ffecom_3 (COND_EXPR, tree_type,
4308                       ffecom_truth_value
4309                       (ffecom_2 (GE_EXPR, integer_type_node,
4310                                  arg2_tree,
4311                                  convert (TREE_TYPE (arg2_tree),
4312                                           integer_zero_node))),
4313                       saved_expr1,
4314                       ffecom_1 (NEGATE_EXPR, tree_type, saved_expr1));
4315         /* Make sure SAVE_EXPRs get referenced early enough. */
4316         expr_tree
4317           = ffecom_2 (COMPOUND_EXPR, tree_type,
4318                       convert (void_type_node, saved_expr1),
4319                       expr_tree);
4320       }
4321       return expr_tree;
4322
4323     case FFEINTRIN_impSIN:
4324     case FFEINTRIN_impCDSIN:
4325     case FFEINTRIN_impCSIN:
4326     case FFEINTRIN_impDSIN:
4327       if (bt == FFEINFO_basictypeCOMPLEX)
4328         {
4329           if (kt == FFEINFO_kindtypeREAL1)
4330             gfrt = FFECOM_gfrtCSIN;     /* Overlapping result okay. */
4331           else if (kt == FFEINFO_kindtypeREAL2)
4332             gfrt = FFECOM_gfrtCDSIN;    /* Overlapping result okay. */
4333         }
4334       break;
4335
4336     case FFEINTRIN_impSINH:
4337     case FFEINTRIN_impDSINH:
4338       break;
4339
4340     case FFEINTRIN_impSQRT:
4341     case FFEINTRIN_impCDSQRT:
4342     case FFEINTRIN_impCSQRT:
4343     case FFEINTRIN_impDSQRT:
4344       if (bt == FFEINFO_basictypeCOMPLEX)
4345         {
4346           if (kt == FFEINFO_kindtypeREAL1)
4347             gfrt = FFECOM_gfrtCSQRT;    /* Overlapping result okay. */
4348           else if (kt == FFEINFO_kindtypeREAL2)
4349             gfrt = FFECOM_gfrtCDSQRT;   /* Overlapping result okay. */
4350         }
4351       break;
4352
4353     case FFEINTRIN_impTAN:
4354     case FFEINTRIN_impDTAN:
4355     case FFEINTRIN_impTANH:
4356     case FFEINTRIN_impDTANH:
4357       break;
4358
4359     case FFEINTRIN_impREALPART:
4360       if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
4361         arg1_type = TREE_TYPE (arg1_type);
4362       else
4363         arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
4364
4365       return
4366         convert (tree_type,
4367                  ffecom_1 (REALPART_EXPR, arg1_type,
4368                            ffecom_expr (arg1)));
4369
4370     case FFEINTRIN_impIAND:
4371     case FFEINTRIN_impAND:
4372       return ffecom_2 (BIT_AND_EXPR, tree_type,
4373                        convert (tree_type,
4374                                 ffecom_expr (arg1)),
4375                        convert (tree_type,
4376                                 ffecom_expr (arg2)));
4377
4378     case FFEINTRIN_impIOR:
4379     case FFEINTRIN_impOR:
4380       return ffecom_2 (BIT_IOR_EXPR, tree_type,
4381                        convert (tree_type,
4382                                 ffecom_expr (arg1)),
4383                        convert (tree_type,
4384                                 ffecom_expr (arg2)));
4385
4386     case FFEINTRIN_impIEOR:
4387     case FFEINTRIN_impXOR:
4388       return ffecom_2 (BIT_XOR_EXPR, tree_type,
4389                        convert (tree_type,
4390                                 ffecom_expr (arg1)),
4391                        convert (tree_type,
4392                                 ffecom_expr (arg2)));
4393
4394     case FFEINTRIN_impLSHIFT:
4395       return ffecom_2 (LSHIFT_EXPR, tree_type,
4396                        ffecom_expr (arg1),
4397                        convert (integer_type_node,
4398                                 ffecom_expr (arg2)));
4399
4400     case FFEINTRIN_impRSHIFT:
4401       return ffecom_2 (RSHIFT_EXPR, tree_type,
4402                        ffecom_expr (arg1),
4403                        convert (integer_type_node,
4404                                 ffecom_expr (arg2)));
4405
4406     case FFEINTRIN_impNOT:
4407       return ffecom_1 (BIT_NOT_EXPR, tree_type, ffecom_expr (arg1));
4408
4409     case FFEINTRIN_impBIT_SIZE:
4410       return convert (tree_type, TYPE_SIZE (arg1_type));
4411
4412     case FFEINTRIN_impBTEST:
4413       {
4414         ffetargetLogical1 target_true;
4415         ffetargetLogical1 target_false;
4416         tree true_tree;
4417         tree false_tree;
4418
4419         ffetarget_logical1 (&target_true, TRUE);
4420         ffetarget_logical1 (&target_false, FALSE);
4421         if (target_true == 1)
4422           true_tree = convert (tree_type, integer_one_node);
4423         else
4424           true_tree = convert (tree_type, build_int_2 (target_true, 0));
4425         if (target_false == 0)
4426           false_tree = convert (tree_type, integer_zero_node);
4427         else
4428           false_tree = convert (tree_type, build_int_2 (target_false, 0));
4429
4430         return
4431           ffecom_3 (COND_EXPR, tree_type,
4432                     ffecom_truth_value
4433                     (ffecom_2 (EQ_EXPR, integer_type_node,
4434                                ffecom_2 (BIT_AND_EXPR, arg1_type,
4435                                          ffecom_expr (arg1),
4436                                          ffecom_2 (LSHIFT_EXPR, arg1_type,
4437                                                    convert (arg1_type,
4438                                                           integer_one_node),
4439                                                    convert (integer_type_node,
4440                                                             ffecom_expr (arg2)))),
4441                                convert (arg1_type,
4442                                         integer_zero_node))),
4443                     false_tree,
4444                     true_tree);
4445       }
4446
4447     case FFEINTRIN_impIBCLR:
4448       return
4449         ffecom_2 (BIT_AND_EXPR, tree_type,
4450                   ffecom_expr (arg1),
4451                   ffecom_1 (BIT_NOT_EXPR, tree_type,
4452                             ffecom_2 (LSHIFT_EXPR, tree_type,
4453                                       convert (tree_type,
4454                                                integer_one_node),
4455                                       convert (integer_type_node,
4456                                                ffecom_expr (arg2)))));
4457
4458     case FFEINTRIN_impIBITS:
4459       {
4460         tree arg3_tree = ffecom_save_tree (convert (integer_type_node,
4461                                                     ffecom_expr (arg3)));
4462         tree uns_type
4463         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4464
4465         expr_tree
4466           = ffecom_2 (BIT_AND_EXPR, tree_type,
4467                       ffecom_2 (RSHIFT_EXPR, tree_type,
4468                                 ffecom_expr (arg1),
4469                                 convert (integer_type_node,
4470                                          ffecom_expr (arg2))),
4471                       convert (tree_type,
4472                                ffecom_2 (RSHIFT_EXPR, uns_type,
4473                                          ffecom_1 (BIT_NOT_EXPR,
4474                                                    uns_type,
4475                                                    convert (uns_type,
4476                                                         integer_zero_node)),
4477                                          ffecom_2 (MINUS_EXPR,
4478                                                    integer_type_node,
4479                                                    TYPE_SIZE (uns_type),
4480                                                    arg3_tree))));
4481         /* Fix up, because the RSHIFT_EXPR above can't shift over TYPE_SIZE.  */
4482         expr_tree
4483           = ffecom_3 (COND_EXPR, tree_type,
4484                       ffecom_truth_value
4485                       (ffecom_2 (NE_EXPR, integer_type_node,
4486                                  arg3_tree,
4487                                  integer_zero_node)),
4488                       expr_tree,
4489                       convert (tree_type, integer_zero_node));
4490       }
4491       return expr_tree;
4492
4493     case FFEINTRIN_impIBSET:
4494       return
4495         ffecom_2 (BIT_IOR_EXPR, tree_type,
4496                   ffecom_expr (arg1),
4497                   ffecom_2 (LSHIFT_EXPR, tree_type,
4498                             convert (tree_type, integer_one_node),
4499                             convert (integer_type_node,
4500                                      ffecom_expr (arg2))));
4501
4502     case FFEINTRIN_impISHFT:
4503       {
4504         tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4505         tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4506                                                     ffecom_expr (arg2)));
4507         tree uns_type
4508         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4509
4510         expr_tree
4511           = ffecom_3 (COND_EXPR, tree_type,
4512                       ffecom_truth_value
4513                       (ffecom_2 (GE_EXPR, integer_type_node,
4514                                  arg2_tree,
4515                                  integer_zero_node)),
4516                       ffecom_2 (LSHIFT_EXPR, tree_type,
4517                                 arg1_tree,
4518                                 arg2_tree),
4519                       convert (tree_type,
4520                                ffecom_2 (RSHIFT_EXPR, uns_type,
4521                                          convert (uns_type, arg1_tree),
4522                                          ffecom_1 (NEGATE_EXPR,
4523                                                    integer_type_node,
4524                                                    arg2_tree))));
4525         /* Fix up, because {L|R}SHIFT_EXPR don't go over TYPE_SIZE bounds.  */
4526         expr_tree
4527           = ffecom_3 (COND_EXPR, tree_type,
4528                       ffecom_truth_value
4529                       (ffecom_2 (NE_EXPR, integer_type_node,
4530                                  ffecom_1 (ABS_EXPR,
4531                                            integer_type_node,
4532                                            arg2_tree),
4533                                  TYPE_SIZE (uns_type))),
4534                       expr_tree,
4535                       convert (tree_type, integer_zero_node));
4536         /* Make sure SAVE_EXPRs get referenced early enough. */
4537         expr_tree
4538           = ffecom_2 (COMPOUND_EXPR, tree_type,
4539                       convert (void_type_node, arg1_tree),
4540                       ffecom_2 (COMPOUND_EXPR, tree_type,
4541                                 convert (void_type_node, arg2_tree),
4542                                 expr_tree));
4543       }
4544       return expr_tree;
4545
4546     case FFEINTRIN_impISHFTC:
4547       {
4548         tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4549         tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4550                                                     ffecom_expr (arg2)));
4551         tree arg3_tree = (arg3 == NULL) ? TYPE_SIZE (tree_type)
4552         : ffecom_save_tree (convert (integer_type_node, ffecom_expr (arg3)));
4553         tree shift_neg;
4554         tree shift_pos;
4555         tree mask_arg1;
4556         tree masked_arg1;
4557         tree uns_type
4558         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4559
4560         mask_arg1
4561           = ffecom_2 (LSHIFT_EXPR, tree_type,
4562                       ffecom_1 (BIT_NOT_EXPR, tree_type,
4563                                 convert (tree_type, integer_zero_node)),
4564                       arg3_tree);
4565         /* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE.  */
4566         mask_arg1
4567           = ffecom_3 (COND_EXPR, tree_type,
4568                       ffecom_truth_value
4569                       (ffecom_2 (NE_EXPR, integer_type_node,
4570                                  arg3_tree,
4571                                  TYPE_SIZE (uns_type))),
4572                       mask_arg1,
4573                       convert (tree_type, integer_zero_node));
4574         mask_arg1 = ffecom_save_tree (mask_arg1);
4575         masked_arg1
4576           = ffecom_2 (BIT_AND_EXPR, tree_type,
4577                       arg1_tree,
4578                       ffecom_1 (BIT_NOT_EXPR, tree_type,
4579                                 mask_arg1));
4580         masked_arg1 = ffecom_save_tree (masked_arg1);
4581         shift_neg
4582           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4583                       convert (tree_type,
4584                                ffecom_2 (RSHIFT_EXPR, uns_type,
4585                                          convert (uns_type, masked_arg1),
4586                                          ffecom_1 (NEGATE_EXPR,
4587                                                    integer_type_node,
4588                                                    arg2_tree))),
4589                       ffecom_2 (LSHIFT_EXPR, tree_type,
4590                                 arg1_tree,
4591                                 ffecom_2 (PLUS_EXPR, integer_type_node,
4592                                           arg2_tree,
4593                                           arg3_tree)));
4594         shift_pos
4595           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4596                       ffecom_2 (LSHIFT_EXPR, tree_type,
4597                                 arg1_tree,
4598                                 arg2_tree),
4599                       convert (tree_type,
4600                                ffecom_2 (RSHIFT_EXPR, uns_type,
4601                                          convert (uns_type, masked_arg1),
4602                                          ffecom_2 (MINUS_EXPR,
4603                                                    integer_type_node,
4604                                                    arg3_tree,
4605                                                    arg2_tree))));
4606         expr_tree
4607           = ffecom_3 (COND_EXPR, tree_type,
4608                       ffecom_truth_value
4609                       (ffecom_2 (LT_EXPR, integer_type_node,
4610                                  arg2_tree,
4611                                  integer_zero_node)),
4612                       shift_neg,
4613                       shift_pos);
4614         expr_tree
4615           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4616                       ffecom_2 (BIT_AND_EXPR, tree_type,
4617                                 mask_arg1,
4618                                 arg1_tree),
4619                       ffecom_2 (BIT_AND_EXPR, tree_type,
4620                                 ffecom_1 (BIT_NOT_EXPR, tree_type,
4621                                           mask_arg1),
4622                                 expr_tree));
4623         expr_tree
4624           = ffecom_3 (COND_EXPR, tree_type,
4625                       ffecom_truth_value
4626                       (ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
4627                                  ffecom_2 (EQ_EXPR, integer_type_node,
4628                                            ffecom_1 (ABS_EXPR,
4629                                                      integer_type_node,
4630                                                      arg2_tree),
4631                                            arg3_tree),
4632                                  ffecom_2 (EQ_EXPR, integer_type_node,
4633                                            arg2_tree,
4634                                            integer_zero_node))),
4635                       arg1_tree,
4636                       expr_tree);
4637         /* Make sure SAVE_EXPRs get referenced early enough. */
4638         expr_tree
4639           = ffecom_2 (COMPOUND_EXPR, tree_type,
4640                       convert (void_type_node, arg1_tree),
4641                       ffecom_2 (COMPOUND_EXPR, tree_type,
4642                                 convert (void_type_node, arg2_tree),
4643                                 ffecom_2 (COMPOUND_EXPR, tree_type,
4644                                           convert (void_type_node,
4645                                                    mask_arg1),
4646                                           ffecom_2 (COMPOUND_EXPR, tree_type,
4647                                                     convert (void_type_node,
4648                                                              masked_arg1),
4649                                                     expr_tree))));
4650         expr_tree
4651           = ffecom_2 (COMPOUND_EXPR, tree_type,
4652                       convert (void_type_node,
4653                                arg3_tree),
4654                       expr_tree);
4655       }
4656       return expr_tree;
4657
4658     case FFEINTRIN_impLOC:
4659       {
4660         tree arg1_tree = ffecom_expr (arg1);
4661
4662         expr_tree
4663           = convert (tree_type,
4664                      ffecom_1 (ADDR_EXPR,
4665                                build_pointer_type (TREE_TYPE (arg1_tree)),
4666                                arg1_tree));
4667       }
4668       return expr_tree;
4669
4670     case FFEINTRIN_impMVBITS:
4671       {
4672         tree arg1_tree;
4673         tree arg2_tree;
4674         tree arg3_tree;
4675         ffebld arg4 = ffebld_head (ffebld_trail (list));
4676         tree arg4_tree;
4677         tree arg4_type;
4678         ffebld arg5 = ffebld_head (ffebld_trail (ffebld_trail (list)));
4679         tree arg5_tree;
4680         tree prep_arg1;
4681         tree prep_arg4;
4682         tree arg5_plus_arg3;
4683
4684         arg2_tree = convert (integer_type_node,
4685                              ffecom_expr (arg2));
4686         arg3_tree = ffecom_save_tree (convert (integer_type_node,
4687                                                ffecom_expr (arg3)));
4688         arg4_tree = ffecom_expr_rw (NULL_TREE, arg4);
4689         arg4_type = TREE_TYPE (arg4_tree);
4690
4691         arg1_tree = ffecom_save_tree (convert (arg4_type,
4692                                                ffecom_expr (arg1)));
4693
4694         arg5_tree = ffecom_save_tree (convert (integer_type_node,
4695                                                ffecom_expr (arg5)));
4696
4697         prep_arg1
4698           = ffecom_2 (LSHIFT_EXPR, arg4_type,
4699                       ffecom_2 (BIT_AND_EXPR, arg4_type,
4700                                 ffecom_2 (RSHIFT_EXPR, arg4_type,
4701                                           arg1_tree,
4702                                           arg2_tree),
4703                                 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4704                                           ffecom_2 (LSHIFT_EXPR, arg4_type,
4705                                                     ffecom_1 (BIT_NOT_EXPR,
4706                                                               arg4_type,
4707                                                               convert
4708                                                               (arg4_type,
4709                                                         integer_zero_node)),
4710                                                     arg3_tree))),
4711                       arg5_tree);
4712         arg5_plus_arg3
4713           = ffecom_save_tree (ffecom_2 (PLUS_EXPR, arg4_type,
4714                                         arg5_tree,
4715                                         arg3_tree));
4716         prep_arg4
4717           = ffecom_2 (LSHIFT_EXPR, arg4_type,
4718                       ffecom_1 (BIT_NOT_EXPR, arg4_type,
4719                                 convert (arg4_type,
4720                                          integer_zero_node)),
4721                       arg5_plus_arg3);
4722         /* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE.  */
4723         prep_arg4
4724           = ffecom_3 (COND_EXPR, arg4_type,
4725                       ffecom_truth_value
4726                       (ffecom_2 (NE_EXPR, integer_type_node,
4727                                  arg5_plus_arg3,
4728                                  convert (TREE_TYPE (arg5_plus_arg3),
4729                                           TYPE_SIZE (arg4_type)))),
4730                       prep_arg4,
4731                       convert (arg4_type, integer_zero_node));
4732         prep_arg4
4733           = ffecom_2 (BIT_AND_EXPR, arg4_type,
4734                       arg4_tree,
4735                       ffecom_2 (BIT_IOR_EXPR, arg4_type,
4736                                 prep_arg4,
4737                                 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4738                                           ffecom_2 (LSHIFT_EXPR, arg4_type,
4739                                                     ffecom_1 (BIT_NOT_EXPR,
4740                                                               arg4_type,
4741                                                               convert
4742                                                               (arg4_type,
4743                                                         integer_zero_node)),
4744                                                     arg5_tree))));
4745         prep_arg1
4746           = ffecom_2 (BIT_IOR_EXPR, arg4_type,
4747                       prep_arg1,
4748                       prep_arg4);
4749         /* Fix up (twice), because LSHIFT_EXPR above
4750            can't shift over TYPE_SIZE.  */
4751         prep_arg1
4752           = ffecom_3 (COND_EXPR, arg4_type,
4753                       ffecom_truth_value
4754                       (ffecom_2 (NE_EXPR, integer_type_node,
4755                                  arg3_tree,
4756                                  convert (TREE_TYPE (arg3_tree),
4757                                           integer_zero_node))),
4758                       prep_arg1,
4759                       arg4_tree);
4760         prep_arg1
4761           = ffecom_3 (COND_EXPR, arg4_type,
4762                       ffecom_truth_value
4763                       (ffecom_2 (NE_EXPR, integer_type_node,
4764                                  arg3_tree,
4765                                  convert (TREE_TYPE (arg3_tree),
4766                                           TYPE_SIZE (arg4_type)))),
4767                       prep_arg1,
4768                       arg1_tree);
4769         expr_tree
4770           = ffecom_2s (MODIFY_EXPR, void_type_node,
4771                        arg4_tree,
4772                        prep_arg1);
4773         /* Make sure SAVE_EXPRs get referenced early enough. */
4774         expr_tree
4775           = ffecom_2 (COMPOUND_EXPR, void_type_node,
4776                       arg1_tree,
4777                       ffecom_2 (COMPOUND_EXPR, void_type_node,
4778                                 arg3_tree,
4779                                 ffecom_2 (COMPOUND_EXPR, void_type_node,
4780                                           arg5_tree,
4781                                           ffecom_2 (COMPOUND_EXPR, void_type_node,
4782                                                     arg5_plus_arg3,
4783                                                     expr_tree))));
4784         expr_tree
4785           = ffecom_2 (COMPOUND_EXPR, void_type_node,
4786                       arg4_tree,
4787                       expr_tree);
4788
4789       }
4790       return expr_tree;
4791
4792     case FFEINTRIN_impDERF:
4793     case FFEINTRIN_impERF:
4794     case FFEINTRIN_impDERFC:
4795     case FFEINTRIN_impERFC:
4796       break;
4797
4798     case FFEINTRIN_impIARGC:
4799       /* extern int xargc; i__1 = xargc - 1; */
4800       expr_tree = ffecom_2 (MINUS_EXPR, TREE_TYPE (ffecom_tree_xargc_),
4801                             ffecom_tree_xargc_,
4802                             convert (TREE_TYPE (ffecom_tree_xargc_),
4803                                      integer_one_node));
4804       return expr_tree;
4805
4806     case FFEINTRIN_impSIGNAL_func:
4807     case FFEINTRIN_impSIGNAL_subr:
4808       {
4809         tree arg1_tree;
4810         tree arg2_tree;
4811         tree arg3_tree;
4812
4813         arg1_tree = convert (ffecom_f2c_integer_type_node,
4814                              ffecom_expr (arg1));
4815         arg1_tree = ffecom_1 (ADDR_EXPR,
4816                               build_pointer_type (TREE_TYPE (arg1_tree)),
4817                               arg1_tree);
4818
4819         /* Pass procedure as a pointer to it, anything else by value.  */
4820         if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
4821           arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
4822         else
4823           arg2_tree = ffecom_ptr_to_expr (arg2);
4824         arg2_tree = convert (TREE_TYPE (null_pointer_node),
4825                              arg2_tree);
4826
4827         if (arg3 != NULL)
4828           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
4829         else
4830           arg3_tree = NULL_TREE;
4831
4832         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4833         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4834         TREE_CHAIN (arg1_tree) = arg2_tree;
4835
4836         expr_tree
4837           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4838                           ffecom_gfrt_kindtype (gfrt),
4839                           FALSE,
4840                           ((codegen_imp == FFEINTRIN_impSIGNAL_subr) ?
4841                            NULL_TREE :
4842                            tree_type),
4843                           arg1_tree,
4844                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4845                           ffebld_nonter_hook (expr));
4846
4847         if (arg3_tree != NULL_TREE)
4848           expr_tree
4849             = ffecom_modify (NULL_TREE, arg3_tree,
4850                              convert (TREE_TYPE (arg3_tree),
4851                                       expr_tree));
4852       }
4853       return expr_tree;
4854
4855     case FFEINTRIN_impALARM:
4856       {
4857         tree arg1_tree;
4858         tree arg2_tree;
4859         tree arg3_tree;
4860
4861         arg1_tree = convert (ffecom_f2c_integer_type_node,
4862                              ffecom_expr (arg1));
4863         arg1_tree = ffecom_1 (ADDR_EXPR,
4864                               build_pointer_type (TREE_TYPE (arg1_tree)),
4865                               arg1_tree);
4866
4867         /* Pass procedure as a pointer to it, anything else by value.  */
4868         if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
4869           arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
4870         else
4871           arg2_tree = ffecom_ptr_to_expr (arg2);
4872         arg2_tree = convert (TREE_TYPE (null_pointer_node),
4873                              arg2_tree);
4874
4875         if (arg3 != NULL)
4876           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
4877         else
4878           arg3_tree = NULL_TREE;
4879
4880         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4881         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4882         TREE_CHAIN (arg1_tree) = arg2_tree;
4883
4884         expr_tree
4885           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4886                           ffecom_gfrt_kindtype (gfrt),
4887                           FALSE,
4888                           NULL_TREE,
4889                           arg1_tree,
4890                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4891                           ffebld_nonter_hook (expr));
4892
4893         if (arg3_tree != NULL_TREE)
4894           expr_tree
4895             = ffecom_modify (NULL_TREE, arg3_tree,
4896                              convert (TREE_TYPE (arg3_tree),
4897                                       expr_tree));
4898       }
4899       return expr_tree;
4900
4901     case FFEINTRIN_impCHDIR_subr:
4902     case FFEINTRIN_impFDATE_subr:
4903     case FFEINTRIN_impFGET_subr:
4904     case FFEINTRIN_impFPUT_subr:
4905     case FFEINTRIN_impGETCWD_subr:
4906     case FFEINTRIN_impHOSTNM_subr:
4907     case FFEINTRIN_impSYSTEM_subr:
4908     case FFEINTRIN_impUNLINK_subr:
4909       {
4910         tree arg1_len = integer_zero_node;
4911         tree arg1_tree;
4912         tree arg2_tree;
4913
4914         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
4915
4916         if (arg2 != NULL)
4917           arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
4918         else
4919           arg2_tree = NULL_TREE;
4920
4921         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4922         arg1_len = build_tree_list (NULL_TREE, arg1_len);
4923         TREE_CHAIN (arg1_tree) = arg1_len;
4924
4925         expr_tree
4926           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4927                           ffecom_gfrt_kindtype (gfrt),
4928                           FALSE,
4929                           NULL_TREE,
4930                           arg1_tree,
4931                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4932                           ffebld_nonter_hook (expr));
4933
4934         if (arg2_tree != NULL_TREE)
4935           expr_tree
4936             = ffecom_modify (NULL_TREE, arg2_tree,
4937                              convert (TREE_TYPE (arg2_tree),
4938                                       expr_tree));
4939       }
4940       return expr_tree;
4941
4942     case FFEINTRIN_impEXIT:
4943       if (arg1 != NULL)
4944         break;
4945
4946       expr_tree = build_tree_list (NULL_TREE,
4947                                    ffecom_1 (ADDR_EXPR,
4948                                              build_pointer_type
4949                                              (ffecom_integer_type_node),
4950                                              integer_zero_node));
4951
4952       return
4953         ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4954                       ffecom_gfrt_kindtype (gfrt),
4955                       FALSE,
4956                       void_type_node,
4957                       expr_tree,
4958                       NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4959                       ffebld_nonter_hook (expr));
4960
4961     case FFEINTRIN_impFLUSH:
4962       if (arg1 == NULL)
4963         gfrt = FFECOM_gfrtFLUSH;
4964       else
4965         gfrt = FFECOM_gfrtFLUSH1;
4966       break;
4967
4968     case FFEINTRIN_impCHMOD_subr:
4969     case FFEINTRIN_impLINK_subr:
4970     case FFEINTRIN_impRENAME_subr:
4971     case FFEINTRIN_impSYMLNK_subr:
4972       {
4973         tree arg1_len = integer_zero_node;
4974         tree arg1_tree;
4975         tree arg2_len = integer_zero_node;
4976         tree arg2_tree;
4977         tree arg3_tree;
4978
4979         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
4980         arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
4981         if (arg3 != NULL)
4982           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
4983         else
4984           arg3_tree = NULL_TREE;
4985
4986         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4987         arg1_len = build_tree_list (NULL_TREE, arg1_len);
4988         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4989         arg2_len = build_tree_list (NULL_TREE, arg2_len);
4990         TREE_CHAIN (arg1_tree) = arg2_tree;
4991         TREE_CHAIN (arg2_tree) = arg1_len;
4992         TREE_CHAIN (arg1_len) = arg2_len;
4993         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4994                                   ffecom_gfrt_kindtype (gfrt),
4995                                   FALSE,
4996                                   NULL_TREE,
4997                                   arg1_tree,
4998                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4999                                   ffebld_nonter_hook (expr));
5000         if (arg3_tree != NULL_TREE)
5001           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5002                                      convert (TREE_TYPE (arg3_tree),
5003                                               expr_tree));
5004       }
5005       return expr_tree;
5006
5007     case FFEINTRIN_impLSTAT_subr:
5008     case FFEINTRIN_impSTAT_subr:
5009       {
5010         tree arg1_len = integer_zero_node;
5011         tree arg1_tree;
5012         tree arg2_tree;
5013         tree arg3_tree;
5014
5015         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5016
5017         arg2_tree = ffecom_ptr_to_expr (arg2);
5018
5019         if (arg3 != NULL)
5020           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5021         else
5022           arg3_tree = NULL_TREE;
5023
5024         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5025         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5026         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5027         TREE_CHAIN (arg1_tree) = arg2_tree;
5028         TREE_CHAIN (arg2_tree) = arg1_len;
5029         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5030                                   ffecom_gfrt_kindtype (gfrt),
5031                                   FALSE,
5032                                   NULL_TREE,
5033                                   arg1_tree,
5034                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5035                                   ffebld_nonter_hook (expr));
5036         if (arg3_tree != NULL_TREE)
5037           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5038                                      convert (TREE_TYPE (arg3_tree),
5039                                               expr_tree));
5040       }
5041       return expr_tree;
5042
5043     case FFEINTRIN_impFGETC_subr:
5044     case FFEINTRIN_impFPUTC_subr:
5045       {
5046         tree arg1_tree;
5047         tree arg2_tree;
5048         tree arg2_len = integer_zero_node;
5049         tree arg3_tree;
5050
5051         arg1_tree = convert (ffecom_f2c_integer_type_node,
5052                              ffecom_expr (arg1));
5053         arg1_tree = ffecom_1 (ADDR_EXPR,
5054                               build_pointer_type (TREE_TYPE (arg1_tree)),
5055                               arg1_tree);
5056
5057         arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
5058         if (arg3 != NULL)
5059           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5060         else
5061           arg3_tree = NULL_TREE;
5062
5063         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5064         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5065         arg2_len = build_tree_list (NULL_TREE, arg2_len);
5066         TREE_CHAIN (arg1_tree) = arg2_tree;
5067         TREE_CHAIN (arg2_tree) = arg2_len;
5068
5069         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5070                                   ffecom_gfrt_kindtype (gfrt),
5071                                   FALSE,
5072                                   NULL_TREE,
5073                                   arg1_tree,
5074                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5075                                   ffebld_nonter_hook (expr));
5076         if (arg3_tree != NULL_TREE)
5077           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5078                                      convert (TREE_TYPE (arg3_tree),
5079                                               expr_tree));
5080       }
5081       return expr_tree;
5082
5083     case FFEINTRIN_impFSTAT_subr:
5084       {
5085         tree arg1_tree;
5086         tree arg2_tree;
5087         tree arg3_tree;
5088
5089         arg1_tree = convert (ffecom_f2c_integer_type_node,
5090                              ffecom_expr (arg1));
5091         arg1_tree = ffecom_1 (ADDR_EXPR,
5092                               build_pointer_type (TREE_TYPE (arg1_tree)),
5093                               arg1_tree);
5094
5095         arg2_tree = convert (ffecom_f2c_ptr_to_integer_type_node,
5096                              ffecom_ptr_to_expr (arg2));
5097
5098         if (arg3 == NULL)
5099           arg3_tree = NULL_TREE;
5100         else
5101           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5102
5103         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5104         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5105         TREE_CHAIN (arg1_tree) = arg2_tree;
5106         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5107                                   ffecom_gfrt_kindtype (gfrt),
5108                                   FALSE,
5109                                   NULL_TREE,
5110                                   arg1_tree,
5111                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5112                                   ffebld_nonter_hook (expr));
5113         if (arg3_tree != NULL_TREE) {
5114           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5115                                      convert (TREE_TYPE (arg3_tree),
5116                                               expr_tree));
5117         }
5118       }
5119       return expr_tree;
5120
5121     case FFEINTRIN_impKILL_subr:
5122       {
5123         tree arg1_tree;
5124         tree arg2_tree;
5125         tree arg3_tree;
5126
5127         arg1_tree = convert (ffecom_f2c_integer_type_node,
5128                              ffecom_expr (arg1));
5129         arg1_tree = ffecom_1 (ADDR_EXPR,
5130                               build_pointer_type (TREE_TYPE (arg1_tree)),
5131                               arg1_tree);
5132
5133         arg2_tree = convert (ffecom_f2c_integer_type_node,
5134                              ffecom_expr (arg2));
5135         arg2_tree = ffecom_1 (ADDR_EXPR,
5136                               build_pointer_type (TREE_TYPE (arg2_tree)),
5137                               arg2_tree);
5138
5139         if (arg3 == NULL)
5140           arg3_tree = NULL_TREE;
5141         else
5142           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5143
5144         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5145         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5146         TREE_CHAIN (arg1_tree) = arg2_tree;
5147         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5148                                   ffecom_gfrt_kindtype (gfrt),
5149                                   FALSE,
5150                                   NULL_TREE,
5151                                   arg1_tree,
5152                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5153                                   ffebld_nonter_hook (expr));
5154         if (arg3_tree != NULL_TREE) {
5155           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5156                                      convert (TREE_TYPE (arg3_tree),
5157                                               expr_tree));
5158         }
5159       }
5160       return expr_tree;
5161
5162     case FFEINTRIN_impCTIME_subr:
5163     case FFEINTRIN_impTTYNAM_subr:
5164       {
5165         tree arg1_len = integer_zero_node;
5166         tree arg1_tree;
5167         tree arg2_tree;
5168
5169         arg1_tree = ffecom_arg_ptr_to_expr (arg2, &arg1_len);
5170
5171         arg2_tree = convert (((codegen_imp == FFEINTRIN_impCTIME_subr) ?
5172                               ffecom_f2c_longint_type_node :
5173                               ffecom_f2c_integer_type_node),
5174                              ffecom_expr (arg1));
5175         arg2_tree = ffecom_1 (ADDR_EXPR,
5176                               build_pointer_type (TREE_TYPE (arg2_tree)),
5177                               arg2_tree);
5178
5179         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5180         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5181         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5182         TREE_CHAIN (arg1_len) = arg2_tree;
5183         TREE_CHAIN (arg1_tree) = arg1_len;
5184
5185         expr_tree
5186           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5187                           ffecom_gfrt_kindtype (gfrt),
5188                           FALSE,
5189                           NULL_TREE,
5190                           arg1_tree,
5191                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5192                           ffebld_nonter_hook (expr));
5193         TREE_SIDE_EFFECTS (expr_tree) = 1;
5194       }
5195       return expr_tree;
5196
5197     case FFEINTRIN_impIRAND:
5198     case FFEINTRIN_impRAND:
5199       /* Arg defaults to 0 (normal random case) */
5200       {
5201         tree arg1_tree;
5202
5203         if (arg1 == NULL)
5204           arg1_tree = ffecom_integer_zero_node;
5205         else
5206           arg1_tree = ffecom_expr (arg1);
5207         arg1_tree = convert (ffecom_f2c_integer_type_node,
5208                              arg1_tree);
5209         arg1_tree = ffecom_1 (ADDR_EXPR,
5210                               build_pointer_type (TREE_TYPE (arg1_tree)),
5211                               arg1_tree);
5212         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5213
5214         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5215                                   ffecom_gfrt_kindtype (gfrt),
5216                                   FALSE,
5217                                   ((codegen_imp == FFEINTRIN_impIRAND) ?
5218                                    ffecom_f2c_integer_type_node :
5219                                    ffecom_f2c_real_type_node),
5220                                   arg1_tree,
5221                                   dest_tree, dest, dest_used,
5222                                   NULL_TREE, TRUE,
5223                                   ffebld_nonter_hook (expr));
5224       }
5225       return expr_tree;
5226
5227     case FFEINTRIN_impFTELL_subr:
5228     case FFEINTRIN_impUMASK_subr:
5229       {
5230         tree arg1_tree;
5231         tree arg2_tree;
5232
5233         arg1_tree = convert (ffecom_f2c_integer_type_node,
5234                              ffecom_expr (arg1));
5235         arg1_tree = ffecom_1 (ADDR_EXPR,
5236                               build_pointer_type (TREE_TYPE (arg1_tree)),
5237                               arg1_tree);
5238
5239         if (arg2 == NULL)
5240           arg2_tree = NULL_TREE;
5241         else
5242           arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
5243
5244         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5245                                   ffecom_gfrt_kindtype (gfrt),
5246                                   FALSE,
5247                                   NULL_TREE,
5248                                   build_tree_list (NULL_TREE, arg1_tree),
5249                                   NULL_TREE, NULL, NULL, NULL_TREE,
5250                                   TRUE,
5251                                   ffebld_nonter_hook (expr));
5252         if (arg2_tree != NULL_TREE) {
5253           expr_tree = ffecom_modify (NULL_TREE, arg2_tree,
5254                                      convert (TREE_TYPE (arg2_tree),
5255                                               expr_tree));
5256         }
5257       }
5258       return expr_tree;
5259
5260     case FFEINTRIN_impCPU_TIME:
5261     case FFEINTRIN_impSECOND_subr:
5262       {
5263         tree arg1_tree;
5264
5265         arg1_tree = ffecom_expr_w (NULL_TREE, arg1);
5266
5267         expr_tree
5268           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5269                           ffecom_gfrt_kindtype (gfrt),
5270                           FALSE,
5271                           NULL_TREE,
5272                           NULL_TREE,
5273                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5274                           ffebld_nonter_hook (expr));
5275
5276         expr_tree
5277           = ffecom_modify (NULL_TREE, arg1_tree,
5278                            convert (TREE_TYPE (arg1_tree),
5279                                     expr_tree));
5280       }
5281       return expr_tree;
5282
5283     case FFEINTRIN_impDTIME_subr:
5284     case FFEINTRIN_impETIME_subr:
5285       {
5286         tree arg1_tree;
5287         tree result_tree;
5288
5289         result_tree = ffecom_expr_w (NULL_TREE, arg2);
5290
5291         arg1_tree = ffecom_ptr_to_expr (arg1);
5292
5293         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5294                                   ffecom_gfrt_kindtype (gfrt),
5295                                   FALSE,
5296                                   NULL_TREE,
5297                                   build_tree_list (NULL_TREE, arg1_tree),
5298                                   NULL_TREE, NULL, NULL, NULL_TREE,
5299                                   TRUE,
5300                                   ffebld_nonter_hook (expr));
5301         expr_tree = ffecom_modify (NULL_TREE, result_tree,
5302                                    convert (TREE_TYPE (result_tree),
5303                                             expr_tree));
5304       }
5305       return expr_tree;
5306
5307       /* Straightforward calls of libf2c routines: */
5308     case FFEINTRIN_impABORT:
5309     case FFEINTRIN_impACCESS:
5310     case FFEINTRIN_impBESJ0:
5311     case FFEINTRIN_impBESJ1:
5312     case FFEINTRIN_impBESJN:
5313     case FFEINTRIN_impBESY0:
5314     case FFEINTRIN_impBESY1:
5315     case FFEINTRIN_impBESYN:
5316     case FFEINTRIN_impCHDIR_func:
5317     case FFEINTRIN_impCHMOD_func:
5318     case FFEINTRIN_impDATE:
5319     case FFEINTRIN_impDATE_AND_TIME:
5320     case FFEINTRIN_impDBESJ0:
5321     case FFEINTRIN_impDBESJ1:
5322     case FFEINTRIN_impDBESJN:
5323     case FFEINTRIN_impDBESY0:
5324     case FFEINTRIN_impDBESY1:
5325     case FFEINTRIN_impDBESYN:
5326     case FFEINTRIN_impDTIME_func:
5327     case FFEINTRIN_impETIME_func:
5328     case FFEINTRIN_impFGETC_func:
5329     case FFEINTRIN_impFGET_func:
5330     case FFEINTRIN_impFNUM:
5331     case FFEINTRIN_impFPUTC_func:
5332     case FFEINTRIN_impFPUT_func:
5333     case FFEINTRIN_impFSEEK:
5334     case FFEINTRIN_impFSTAT_func:
5335     case FFEINTRIN_impFTELL_func:
5336     case FFEINTRIN_impGERROR:
5337     case FFEINTRIN_impGETARG:
5338     case FFEINTRIN_impGETCWD_func:
5339     case FFEINTRIN_impGETENV:
5340     case FFEINTRIN_impGETGID:
5341     case FFEINTRIN_impGETLOG:
5342     case FFEINTRIN_impGETPID:
5343     case FFEINTRIN_impGETUID:
5344     case FFEINTRIN_impGMTIME:
5345     case FFEINTRIN_impHOSTNM_func:
5346     case FFEINTRIN_impIDATE_unix:
5347     case FFEINTRIN_impIDATE_vxt:
5348     case FFEINTRIN_impIERRNO:
5349     case FFEINTRIN_impISATTY:
5350     case FFEINTRIN_impITIME:
5351     case FFEINTRIN_impKILL_func:
5352     case FFEINTRIN_impLINK_func:
5353     case FFEINTRIN_impLNBLNK:
5354     case FFEINTRIN_impLSTAT_func:
5355     case FFEINTRIN_impLTIME:
5356     case FFEINTRIN_impMCLOCK8:
5357     case FFEINTRIN_impMCLOCK:
5358     case FFEINTRIN_impPERROR:
5359     case FFEINTRIN_impRENAME_func:
5360     case FFEINTRIN_impSECNDS:
5361     case FFEINTRIN_impSECOND_func:
5362     case FFEINTRIN_impSLEEP:
5363     case FFEINTRIN_impSRAND:
5364     case FFEINTRIN_impSTAT_func:
5365     case FFEINTRIN_impSYMLNK_func:
5366     case FFEINTRIN_impSYSTEM_CLOCK:
5367     case FFEINTRIN_impSYSTEM_func:
5368     case FFEINTRIN_impTIME8:
5369     case FFEINTRIN_impTIME_unix:
5370     case FFEINTRIN_impTIME_vxt:
5371     case FFEINTRIN_impUMASK_func:
5372     case FFEINTRIN_impUNLINK_func:
5373       break;
5374
5375     case FFEINTRIN_impCTIME_func:       /* CHARACTER functions not handled here. */
5376     case FFEINTRIN_impFDATE_func:       /* CHARACTER functions not handled here. */
5377     case FFEINTRIN_impTTYNAM_func:      /* CHARACTER functions not handled here. */
5378     case FFEINTRIN_impNONE:
5379     case FFEINTRIN_imp:         /* Hush up gcc warning. */
5380       fprintf (stderr, "No %s implementation.\n",
5381                ffeintrin_name_implementation (ffebld_symter_implementation (ffebld_left (expr))));
5382       assert ("unimplemented intrinsic" == NULL);
5383       return error_mark_node;
5384     }
5385
5386   assert (gfrt != FFECOM_gfrt); /* Must have an implementation! */
5387
5388   expr_tree = ffecom_arglist_expr_ (ffecom_gfrt_args_ (gfrt),
5389                                     ffebld_right (expr));
5390
5391   return ffecom_call_ (ffecom_gfrt_tree_ (gfrt), ffecom_gfrt_kindtype (gfrt),
5392                        (ffe_is_f2c_library () && ffecom_gfrt_complex_[gfrt]),
5393                        tree_type,
5394                        expr_tree, dest_tree, dest, dest_used,
5395                        NULL_TREE, TRUE,
5396                        ffebld_nonter_hook (expr));
5397
5398   /* See bottom of this file for f2c transforms used to determine
5399      many of the above implementations.  The info seems to confuse
5400      Emacs's C mode indentation, which is why it's been moved to
5401      the bottom of this source file.  */
5402 }
5403
5404 /* For power (exponentiation) where right-hand operand is type INTEGER,
5405    generate in-line code to do it the fast way (which, if the operand
5406    is a constant, might just mean a series of multiplies).  */
5407
5408 static tree
5409 ffecom_expr_power_integer_ (ffebld expr)
5410 {
5411   tree l = ffecom_expr (ffebld_left (expr));
5412   tree r = ffecom_expr (ffebld_right (expr));
5413   tree ltype = TREE_TYPE (l);
5414   tree rtype = TREE_TYPE (r);
5415   tree result = NULL_TREE;
5416
5417   if (l == error_mark_node
5418       || r == error_mark_node)
5419     return error_mark_node;
5420
5421   if (TREE_CODE (r) == INTEGER_CST)
5422     {
5423       int sgn = tree_int_cst_sgn (r);
5424
5425       if (sgn == 0)
5426         return convert (ltype, integer_one_node);
5427
5428       if ((TREE_CODE (ltype) == INTEGER_TYPE)
5429           && (sgn < 0))
5430         {
5431           /* Reciprocal of integer is either 0, -1, or 1, so after
5432              calculating that (which we leave to the back end to do
5433              or not do optimally), don't bother with any multiplying.  */
5434
5435           result = ffecom_tree_divide_ (ltype,
5436                                         convert (ltype, integer_one_node),
5437                                         l,
5438                                         NULL_TREE, NULL, NULL, NULL_TREE);
5439           r = ffecom_1 (NEGATE_EXPR,
5440                         rtype,
5441                         r);
5442           if ((TREE_INT_CST_LOW (r) & 1) == 0)
5443             result = ffecom_1 (ABS_EXPR, rtype,
5444                                result);
5445         }
5446
5447       /* Generate appropriate series of multiplies, preceded
5448          by divide if the exponent is negative.  */
5449
5450       l = save_expr (l);
5451
5452       if (sgn < 0)
5453         {
5454           l = ffecom_tree_divide_ (ltype,
5455                                    convert (ltype, integer_one_node),
5456                                    l,
5457                                    NULL_TREE, NULL, NULL,
5458                                    ffebld_nonter_hook (expr));
5459           r = ffecom_1 (NEGATE_EXPR, rtype, r);
5460           assert (TREE_CODE (r) == INTEGER_CST);
5461
5462           if (tree_int_cst_sgn (r) < 0)
5463             {                   /* The "most negative" number.  */
5464               r = ffecom_1 (NEGATE_EXPR, rtype,
5465                             ffecom_2 (RSHIFT_EXPR, rtype,
5466                                       r,
5467                                       integer_one_node));
5468               l = save_expr (l);
5469               l = ffecom_2 (MULT_EXPR, ltype,
5470                             l,
5471                             l);
5472             }
5473         }
5474
5475       for (;;)
5476         {
5477           if (TREE_INT_CST_LOW (r) & 1)
5478             {
5479               if (result == NULL_TREE)
5480                 result = l;
5481               else
5482                 result = ffecom_2 (MULT_EXPR, ltype,
5483                                    result,
5484                                    l);
5485             }
5486
5487           r = ffecom_2 (RSHIFT_EXPR, rtype,
5488                         r,
5489                         integer_one_node);
5490           if (integer_zerop (r))
5491             break;
5492           assert (TREE_CODE (r) == INTEGER_CST);
5493
5494           l = save_expr (l);
5495           l = ffecom_2 (MULT_EXPR, ltype,
5496                         l,
5497                         l);
5498         }
5499       return result;
5500     }
5501
5502   /* Though rhs isn't a constant, in-line code cannot be expanded
5503      while transforming dummies
5504      because the back end cannot be easily convinced to generate
5505      stores (MODIFY_EXPR), handle temporaries, and so on before
5506      all the appropriate rtx's have been generated for things like
5507      dummy args referenced in rhs -- which doesn't happen until
5508      store_parm_decls() is called (expand_function_start, I believe,
5509      does the actual rtx-stuffing of PARM_DECLs).
5510
5511      So, in this case, let the caller generate the call to the
5512      run-time-library function to evaluate the power for us.  */
5513
5514   if (ffecom_transform_only_dummies_)
5515     return NULL_TREE;
5516
5517   /* Right-hand operand not a constant, expand in-line code to figure
5518      out how to do the multiplies, &c.
5519
5520      The returned expression is expressed this way in GNU C, where l and
5521      r are the "inputs":
5522
5523      ({ typeof (r) rtmp = r;
5524         typeof (l) ltmp = l;
5525         typeof (l) result;
5526
5527         if (rtmp == 0)
5528           result = 1;
5529         else
5530           {
5531             if ((basetypeof (l) == basetypeof (int))
5532                 && (rtmp < 0))
5533               {
5534                 result = ((typeof (l)) 1) / ltmp;
5535                 if ((ltmp < 0) && (((-rtmp) & 1) == 0))
5536                   result = -result;
5537               }
5538             else
5539               {
5540                 result = 1;
5541                 if ((basetypeof (l) != basetypeof (int))
5542                     && (rtmp < 0))
5543                   {
5544                     ltmp = ((typeof (l)) 1) / ltmp;
5545                     rtmp = -rtmp;
5546                     if (rtmp < 0)
5547                       {
5548                         rtmp = -(rtmp >> 1);
5549                         ltmp *= ltmp;
5550                       }
5551                   }
5552                 for (;;)
5553                   {
5554                     if (rtmp & 1)
5555                       result *= ltmp;
5556                     if ((rtmp >>= 1) == 0)
5557                       break;
5558                     ltmp *= ltmp;
5559                   }
5560               }
5561           }
5562         result;
5563      })
5564
5565      Note that some of the above is compile-time collapsable, such as
5566      the first part of the if statements that checks the base type of
5567      l against int.  The if statements are phrased that way to suggest
5568      an easy way to generate the if/else constructs here, knowing that
5569      the back end should (and probably does) eliminate the resulting
5570      dead code (either the int case or the non-int case), something
5571      it couldn't do without the redundant phrasing, requiring explicit
5572      dead-code elimination here, which would be kind of difficult to
5573      read.  */
5574
5575   {
5576     tree rtmp;
5577     tree ltmp;
5578     tree divide;
5579     tree basetypeof_l_is_int;
5580     tree se;
5581     tree t;
5582
5583     basetypeof_l_is_int
5584       = build_int_2 ((TREE_CODE (ltype) == INTEGER_TYPE), 0);
5585
5586     se = expand_start_stmt_expr ();
5587
5588     ffecom_start_compstmt ();
5589
5590 #ifndef HAHA
5591     rtmp = ffecom_make_tempvar ("power_r", rtype,
5592                                 FFETARGET_charactersizeNONE, -1);
5593     ltmp = ffecom_make_tempvar ("power_l", ltype,
5594                                 FFETARGET_charactersizeNONE, -1);
5595     result = ffecom_make_tempvar ("power_res", ltype,
5596                                   FFETARGET_charactersizeNONE, -1);
5597     if (TREE_CODE (ltype) == COMPLEX_TYPE
5598         || TREE_CODE (ltype) == RECORD_TYPE)
5599       divide = ffecom_make_tempvar ("power_div", ltype,
5600                                     FFETARGET_charactersizeNONE, -1);
5601     else
5602       divide = NULL_TREE;
5603 #else  /* HAHA */
5604     {
5605       tree hook;
5606
5607       hook = ffebld_nonter_hook (expr);
5608       assert (hook);
5609       assert (TREE_CODE (hook) == TREE_VEC);
5610       assert (TREE_VEC_LENGTH (hook) == 4);
5611       rtmp = TREE_VEC_ELT (hook, 0);
5612       ltmp = TREE_VEC_ELT (hook, 1);
5613       result = TREE_VEC_ELT (hook, 2);
5614       divide = TREE_VEC_ELT (hook, 3);
5615       if (TREE_CODE (ltype) == COMPLEX_TYPE
5616           || TREE_CODE (ltype) == RECORD_TYPE)
5617         assert (divide);
5618       else
5619         assert (! divide);
5620     }
5621 #endif  /* HAHA */
5622
5623     expand_expr_stmt (ffecom_modify (void_type_node,
5624                                      rtmp,
5625                                      r));
5626     expand_expr_stmt (ffecom_modify (void_type_node,
5627                                      ltmp,
5628                                      l));
5629     expand_start_cond (ffecom_truth_value
5630                        (ffecom_2 (EQ_EXPR, integer_type_node,
5631                                   rtmp,
5632                                   convert (rtype, integer_zero_node))),
5633                        0);
5634     expand_expr_stmt (ffecom_modify (void_type_node,
5635                                      result,
5636                                      convert (ltype, integer_one_node)));
5637     expand_start_else ();
5638     if (! integer_zerop (basetypeof_l_is_int))
5639       {
5640         expand_start_cond (ffecom_2 (LT_EXPR, integer_type_node,
5641                                      rtmp,
5642                                      convert (rtype,
5643                                               integer_zero_node)),
5644                            0);
5645         expand_expr_stmt (ffecom_modify (void_type_node,
5646                                          result,
5647                                          ffecom_tree_divide_
5648                                          (ltype,
5649                                           convert (ltype, integer_one_node),
5650                                           ltmp,
5651                                           NULL_TREE, NULL, NULL,
5652                                           divide)));
5653         expand_start_cond (ffecom_truth_value
5654                            (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5655                                       ffecom_2 (LT_EXPR, integer_type_node,
5656                                                 ltmp,
5657                                                 convert (ltype,
5658                                                          integer_zero_node)),
5659                                       ffecom_2 (EQ_EXPR, integer_type_node,
5660                                                 ffecom_2 (BIT_AND_EXPR,
5661                                                           rtype,
5662                                                           ffecom_1 (NEGATE_EXPR,
5663                                                                     rtype,
5664                                                                     rtmp),
5665                                                           convert (rtype,
5666                                                                    integer_one_node)),
5667                                                 convert (rtype,
5668                                                          integer_zero_node)))),
5669                            0);
5670         expand_expr_stmt (ffecom_modify (void_type_node,
5671                                          result,
5672                                          ffecom_1 (NEGATE_EXPR,
5673                                                    ltype,
5674                                                    result)));
5675         expand_end_cond ();
5676         expand_start_else ();
5677       }
5678     expand_expr_stmt (ffecom_modify (void_type_node,
5679                                      result,
5680                                      convert (ltype, integer_one_node)));
5681     expand_start_cond (ffecom_truth_value
5682                        (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5683                                   ffecom_truth_value_invert
5684                                   (basetypeof_l_is_int),
5685                                   ffecom_2 (LT_EXPR, integer_type_node,
5686                                             rtmp,
5687                                             convert (rtype,
5688                                                      integer_zero_node)))),
5689                        0);
5690     expand_expr_stmt (ffecom_modify (void_type_node,
5691                                      ltmp,
5692                                      ffecom_tree_divide_
5693                                      (ltype,
5694                                       convert (ltype, integer_one_node),
5695                                       ltmp,
5696                                       NULL_TREE, NULL, NULL,
5697                                       divide)));
5698     expand_expr_stmt (ffecom_modify (void_type_node,
5699                                      rtmp,
5700                                      ffecom_1 (NEGATE_EXPR, rtype,
5701                                                rtmp)));
5702     expand_start_cond (ffecom_truth_value
5703                        (ffecom_2 (LT_EXPR, integer_type_node,
5704                                   rtmp,
5705                                   convert (rtype, integer_zero_node))),
5706                        0);
5707     expand_expr_stmt (ffecom_modify (void_type_node,
5708                                      rtmp,
5709                                      ffecom_1 (NEGATE_EXPR, rtype,
5710                                                ffecom_2 (RSHIFT_EXPR,
5711                                                          rtype,
5712                                                          rtmp,
5713                                                          integer_one_node))));
5714     expand_expr_stmt (ffecom_modify (void_type_node,
5715                                      ltmp,
5716                                      ffecom_2 (MULT_EXPR, ltype,
5717                                                ltmp,
5718                                                ltmp)));
5719     expand_end_cond ();
5720     expand_end_cond ();
5721     expand_start_loop (1);
5722     expand_start_cond (ffecom_truth_value
5723                        (ffecom_2 (BIT_AND_EXPR, rtype,
5724                                   rtmp,
5725                                   convert (rtype, integer_one_node))),
5726                        0);
5727     expand_expr_stmt (ffecom_modify (void_type_node,
5728                                      result,
5729                                      ffecom_2 (MULT_EXPR, ltype,
5730                                                result,
5731                                                ltmp)));
5732     expand_end_cond ();
5733     expand_exit_loop_if_false (NULL,
5734                                ffecom_truth_value
5735                                (ffecom_modify (rtype,
5736                                                rtmp,
5737                                                ffecom_2 (RSHIFT_EXPR,
5738                                                          rtype,
5739                                                          rtmp,
5740                                                          integer_one_node))));
5741     expand_expr_stmt (ffecom_modify (void_type_node,
5742                                      ltmp,
5743                                      ffecom_2 (MULT_EXPR, ltype,
5744                                                ltmp,
5745                                                ltmp)));
5746     expand_end_loop ();
5747     expand_end_cond ();
5748     if (!integer_zerop (basetypeof_l_is_int))
5749       expand_end_cond ();
5750     expand_expr_stmt (result);
5751
5752     t = ffecom_end_compstmt ();
5753
5754     result = expand_end_stmt_expr (se);
5755
5756     /* This code comes from c-parse.in, after its expand_end_stmt_expr.  */
5757
5758     if (TREE_CODE (t) == BLOCK)
5759       {
5760         /* Make a BIND_EXPR for the BLOCK already made.  */
5761         result = build (BIND_EXPR, TREE_TYPE (result),
5762                         NULL_TREE, result, t);
5763         /* Remove the block from the tree at this point.
5764            It gets put back at the proper place
5765            when the BIND_EXPR is expanded.  */
5766         delete_block (t);
5767       }
5768     else
5769       result = t;
5770   }
5771
5772   return result;
5773 }
5774
5775 /* ffecom_expr_transform_ -- Transform symbols in expr
5776
5777    ffebld expr;  // FFE expression.
5778    ffecom_expr_transform_ (expr);
5779
5780    Recursive descent on expr while transforming any untransformed SYMTERs.  */
5781
5782 static void
5783 ffecom_expr_transform_ (ffebld expr)
5784 {
5785   tree t;
5786   ffesymbol s;
5787
5788  tail_recurse:
5789
5790   if (expr == NULL)
5791     return;
5792
5793   switch (ffebld_op (expr))
5794     {
5795     case FFEBLD_opSYMTER:
5796       s = ffebld_symter (expr);
5797       t = ffesymbol_hook (s).decl_tree;
5798       if ((t == NULL_TREE)
5799           && ((ffesymbol_kind (s) != FFEINFO_kindNONE)
5800               || ((ffesymbol_where (s) != FFEINFO_whereNONE)
5801                   && (ffesymbol_where (s) != FFEINFO_whereINTRINSIC))))
5802         {
5803           s = ffecom_sym_transform_ (s);
5804           t = ffesymbol_hook (s).decl_tree;     /* Sfunc expr non-dummy,
5805                                                    DIMENSION expr? */
5806         }
5807       break;                    /* Ok if (t == NULL) here. */
5808
5809     case FFEBLD_opITEM:
5810       ffecom_expr_transform_ (ffebld_head (expr));
5811       expr = ffebld_trail (expr);
5812       goto tail_recurse;        /* :::::::::::::::::::: */
5813
5814     default:
5815       break;
5816     }
5817
5818   switch (ffebld_arity (expr))
5819     {
5820     case 2:
5821       ffecom_expr_transform_ (ffebld_left (expr));
5822       expr = ffebld_right (expr);
5823       goto tail_recurse;        /* :::::::::::::::::::: */
5824
5825     case 1:
5826       expr = ffebld_left (expr);
5827       goto tail_recurse;        /* :::::::::::::::::::: */
5828
5829     default:
5830       break;
5831     }
5832
5833   return;
5834 }
5835
5836 /* Make a type based on info in live f2c.h file.  */
5837
5838 static void
5839 ffecom_f2c_make_type_ (tree *type, int tcode, const char *name)
5840 {
5841   switch (tcode)
5842     {
5843     case FFECOM_f2ccodeCHAR:
5844       *type = make_signed_type (CHAR_TYPE_SIZE);
5845       break;
5846
5847     case FFECOM_f2ccodeSHORT:
5848       *type = make_signed_type (SHORT_TYPE_SIZE);
5849       break;
5850
5851     case FFECOM_f2ccodeINT:
5852       *type = make_signed_type (INT_TYPE_SIZE);
5853       break;
5854
5855     case FFECOM_f2ccodeLONG:
5856       *type = make_signed_type (LONG_TYPE_SIZE);
5857       break;
5858
5859     case FFECOM_f2ccodeLONGLONG:
5860       *type = make_signed_type (LONG_LONG_TYPE_SIZE);
5861       break;
5862
5863     case FFECOM_f2ccodeCHARPTR:
5864       *type = build_pointer_type (DEFAULT_SIGNED_CHAR
5865                                   ? signed_char_type_node
5866                                   : unsigned_char_type_node);
5867       break;
5868
5869     case FFECOM_f2ccodeFLOAT:
5870       *type = make_node (REAL_TYPE);
5871       TYPE_PRECISION (*type) = FLOAT_TYPE_SIZE;
5872       layout_type (*type);
5873       break;
5874
5875     case FFECOM_f2ccodeDOUBLE:
5876       *type = make_node (REAL_TYPE);
5877       TYPE_PRECISION (*type) = DOUBLE_TYPE_SIZE;
5878       layout_type (*type);
5879       break;
5880
5881     case FFECOM_f2ccodeLONGDOUBLE:
5882       *type = make_node (REAL_TYPE);
5883       TYPE_PRECISION (*type) = LONG_DOUBLE_TYPE_SIZE;
5884       layout_type (*type);
5885       break;
5886
5887     case FFECOM_f2ccodeTWOREALS:
5888       *type = ffecom_make_complex_type_ (ffecom_f2c_real_type_node);
5889       break;
5890
5891     case FFECOM_f2ccodeTWODOUBLEREALS:
5892       *type = ffecom_make_complex_type_ (ffecom_f2c_doublereal_type_node);
5893       break;
5894
5895     default:
5896       assert ("unexpected FFECOM_f2ccodeXYZZY!" == NULL);
5897       *type = error_mark_node;
5898       return;
5899     }
5900
5901   pushdecl (build_decl (TYPE_DECL,
5902                         ffecom_get_invented_identifier ("__g77_f2c_%s", name),
5903                         *type));
5904 }
5905
5906 /* Set the f2c list-directed-I/O code for whatever (integral) type has the
5907    given size.  */
5908
5909 static void
5910 ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
5911                           int code)
5912 {
5913   int j;
5914   tree t;
5915
5916   for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
5917     if ((t = ffecom_tree_type[bt][j]) != NULL_TREE
5918         && compare_tree_int (TYPE_SIZE (t), size) == 0)
5919       {
5920         assert (code != -1);
5921         ffecom_f2c_typecode_[bt][j] = code;
5922         code = -1;
5923       }
5924 }
5925
5926 /* Finish up globals after doing all program units in file
5927
5928    Need to handle only uninitialized COMMON areas.  */
5929
5930 static ffeglobal
5931 ffecom_finish_global_ (ffeglobal global)
5932 {
5933   tree cbtype;
5934   tree cbt;
5935   tree size;
5936
5937   if (ffeglobal_type (global) != FFEGLOBAL_typeCOMMON)
5938       return global;
5939
5940   if (ffeglobal_common_init (global))
5941       return global;
5942
5943   cbt = ffeglobal_hook (global);
5944   if ((cbt == NULL_TREE)
5945       || !ffeglobal_common_have_size (global))
5946     return global;              /* No need to make common, never ref'd. */
5947
5948   DECL_EXTERNAL (cbt) = 0;
5949
5950   /* Give the array a size now.  */
5951
5952   size = build_int_2 ((ffeglobal_common_size (global)
5953                       + ffeglobal_common_pad (global)) - 1,
5954                       0);
5955
5956   cbtype = TREE_TYPE (cbt);
5957   TYPE_DOMAIN (cbtype) = build_range_type (integer_type_node,
5958                                            integer_zero_node,
5959                                            size);
5960   if (!TREE_TYPE (size))
5961     TREE_TYPE (size) = TYPE_DOMAIN (cbtype);
5962   layout_type (cbtype);
5963
5964   cbt = start_decl (cbt, FALSE);
5965   assert (cbt == ffeglobal_hook (global));
5966
5967   finish_decl (cbt, NULL_TREE, FALSE);
5968
5969   return global;
5970 }
5971
5972 /* Finish up any untransformed symbols.  */
5973
5974 static ffesymbol
5975 ffecom_finish_symbol_transform_ (ffesymbol s)
5976 {
5977   if ((s == NULL) || (TREE_CODE (current_function_decl) == ERROR_MARK))
5978     return s;
5979
5980   /* It's easy to know to transform an untransformed symbol, to make sure
5981      we put out debugging info for it.  But COMMON variables, unlike
5982      EQUIVALENCE ones, aren't given declarations in addition to the
5983      tree expressions that specify offsets, because COMMON variables
5984      can be referenced in the outer scope where only dummy arguments
5985      (PARM_DECLs) should really be seen.  To be safe, just don't do any
5986      VAR_DECLs for COMMON variables when we transform them for real
5987      use, and therefore we do all the VAR_DECL creating here.  */
5988
5989   if (ffesymbol_hook (s).decl_tree == NULL_TREE)
5990     {
5991       if (ffesymbol_kind (s) != FFEINFO_kindNONE
5992           || (ffesymbol_where (s) != FFEINFO_whereNONE
5993               && ffesymbol_where (s) != FFEINFO_whereINTRINSIC
5994               && ffesymbol_where (s) != FFEINFO_whereDUMMY))
5995         /* Not transformed, and not CHARACTER*(*), and not a dummy
5996            argument, which can happen only if the entry point names
5997            it "rides in on" are all invalidated for other reasons.  */
5998         s = ffecom_sym_transform_ (s);
5999     }
6000
6001   if ((ffesymbol_where (s) == FFEINFO_whereCOMMON)
6002       && (ffesymbol_hook (s).decl_tree != error_mark_node))
6003     {
6004       /* This isn't working, at least for dbxout.  The .s file looks
6005          okay to me (burley), but in gdb 4.9 at least, the variables
6006          appear to reside somewhere outside of the common area, so
6007          it doesn't make sense to mislead anyone by generating the info
6008          on those variables until this is fixed.  NOTE: Same problem
6009          with EQUIVALENCE, sadly...see similar #if later.  */
6010       ffecom_member_phase2_ (ffesymbol_storage (ffesymbol_common (s)),
6011                              ffesymbol_storage (s));
6012     }
6013
6014   return s;
6015 }
6016
6017 /* Append underscore(s) to name before calling get_identifier.  "us"
6018    is nonzero if the name already contains an underscore and thus
6019    needs two underscores appended.  */
6020
6021 static tree
6022 ffecom_get_appended_identifier_ (char us, const char *name)
6023 {
6024   int i;
6025   char *newname;
6026   tree id;
6027
6028   newname = xmalloc ((i = strlen (name)) + 1
6029                      + ffe_is_underscoring ()
6030                      + us);
6031   memcpy (newname, name, i);
6032   newname[i] = '_';
6033   newname[i + us] = '_';
6034   newname[i + 1 + us] = '\0';
6035   id = get_identifier (newname);
6036
6037   free (newname);
6038
6039   return id;
6040 }
6041
6042 /* Decide whether to append underscore to name before calling
6043    get_identifier.  */
6044
6045 static tree
6046 ffecom_get_external_identifier_ (ffesymbol s)
6047 {
6048   char us;
6049   const char *name = ffesymbol_text (s);
6050
6051   /* If name is a built-in name, just return it as is.  */
6052
6053   if (!ffe_is_underscoring ()
6054       || (strcmp (name, FFETARGET_nameBLANK_COMMON) == 0)
6055 #if FFETARGET_isENFORCED_MAIN_NAME
6056       || (strcmp (name, FFETARGET_nameENFORCED_NAME) == 0)
6057 #else
6058       || (strcmp (name, FFETARGET_nameUNNAMED_MAIN) == 0)
6059 #endif
6060       || (strcmp (name, FFETARGET_nameUNNAMED_BLOCK_DATA) == 0))
6061     return get_identifier (name);
6062
6063   us = ffe_is_second_underscore ()
6064     ? (strchr (name, '_') != NULL)
6065       : 0;
6066
6067   return ffecom_get_appended_identifier_ (us, name);
6068 }
6069
6070 /* Decide whether to append underscore to internal name before calling
6071    get_identifier.
6072
6073    This is for non-external, top-function-context names only.  Transform
6074    identifier so it doesn't conflict with the transformed result
6075    of using a _different_ external name.  E.g. if "CALL FOO" is
6076    transformed into "FOO_();", then the variable in "FOO_ = 3"
6077    must be transformed into something that does not conflict, since
6078    these two things should be independent.
6079
6080    The transformation is as follows.  If the name does not contain
6081    an underscore, there is no possible conflict, so just return.
6082    If the name does contain an underscore, then transform it just
6083    like we transform an external identifier.  */
6084
6085 static tree
6086 ffecom_get_identifier_ (const char *name)
6087 {
6088   /* If name does not contain an underscore, just return it as is.  */
6089
6090   if (!ffe_is_underscoring ()
6091       || (strchr (name, '_') == NULL))
6092     return get_identifier (name);
6093
6094   return ffecom_get_appended_identifier_ (ffe_is_second_underscore (),
6095                                           name);
6096 }
6097
6098 /* ffecom_gen_sfuncdef_ -- Generate definition of statement function
6099
6100    tree t;
6101    ffesymbol s;  // kindFUNCTION, whereIMMEDIATE.
6102    t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s),
6103          ffesymbol_kindtype(s));
6104
6105    Call after setting up containing function and getting trees for all
6106    other symbols.  */
6107
6108 static tree
6109 ffecom_gen_sfuncdef_ (ffesymbol s, ffeinfoBasictype bt, ffeinfoKindtype kt)
6110 {
6111   ffebld expr = ffesymbol_sfexpr (s);
6112   tree type;
6113   tree func;
6114   tree result;
6115   bool charfunc = (bt == FFEINFO_basictypeCHARACTER);
6116   static bool recurse = FALSE;
6117   int old_lineno = lineno;
6118   const char *old_input_filename = input_filename;
6119
6120   ffecom_nested_entry_ = s;
6121
6122   /* For now, we don't have a handy pointer to where the sfunc is actually
6123      defined, though that should be easy to add to an ffesymbol. (The
6124      token/where info available might well point to the place where the type
6125      of the sfunc is declared, especially if that precedes the place where
6126      the sfunc itself is defined, which is typically the case.)  We should
6127      put out a null pointer rather than point somewhere wrong, but I want to
6128      see how it works at this point.  */
6129
6130   input_filename = ffesymbol_where_filename (s);
6131   lineno = ffesymbol_where_filelinenum (s);
6132
6133   /* Pretransform the expression so any newly discovered things belong to the
6134      outer program unit, not to the statement function. */
6135
6136   ffecom_expr_transform_ (expr);
6137
6138   /* Make sure no recursive invocation of this fn (a specific case of failing
6139      to pretransform an sfunc's expression, i.e. where its expression
6140      references another untransformed sfunc) happens. */
6141
6142   assert (!recurse);
6143   recurse = TRUE;
6144
6145   push_f_function_context ();
6146
6147   if (charfunc)
6148     type = void_type_node;
6149   else
6150     {
6151       type = ffecom_tree_type[bt][kt];
6152       if (type == NULL_TREE)
6153         type = integer_type_node;       /* _sym_exec_transition reports
6154                                            error. */
6155     }
6156
6157   start_function (ffecom_get_identifier_ (ffesymbol_text (s)),
6158                   build_function_type (type, NULL_TREE),
6159                   1,            /* nested/inline */
6160                   0);           /* TREE_PUBLIC */
6161
6162   /* We don't worry about COMPLEX return values here, because this is
6163      entirely internal to our code, and gcc has the ability to return COMPLEX
6164      directly as a value.  */
6165
6166   if (charfunc)
6167     {                           /* Prepend arg for where result goes. */
6168       tree type;
6169
6170       type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
6171
6172       result = ffecom_get_invented_identifier ("__g77_%s", "result");
6173
6174       ffecom_char_enhance_arg_ (&type, s);      /* Ignore returned length. */
6175
6176       type = build_pointer_type (type);
6177       result = build_decl (PARM_DECL, result, type);
6178
6179       push_parm_decl (result);
6180     }
6181   else
6182     result = NULL_TREE;         /* Not ref'd if !charfunc. */
6183
6184   ffecom_push_dummy_decls_ (ffesymbol_dummyargs (s), TRUE);
6185
6186   store_parm_decls (0);
6187
6188   ffecom_start_compstmt ();
6189
6190   if (expr != NULL)
6191     {
6192       if (charfunc)
6193         {
6194           ffetargetCharacterSize sz = ffesymbol_size (s);
6195           tree result_length;
6196
6197           result_length = build_int_2 (sz, 0);
6198           TREE_TYPE (result_length) = ffecom_f2c_ftnlen_type_node;
6199
6200           ffecom_prepare_let_char_ (sz, expr);
6201
6202           ffecom_prepare_end ();
6203
6204           ffecom_let_char_ (result, result_length, sz, expr);
6205           expand_null_return ();
6206         }
6207       else
6208         {
6209           ffecom_prepare_expr (expr);
6210
6211           ffecom_prepare_end ();
6212
6213           expand_return (ffecom_modify (NULL_TREE,
6214                                         DECL_RESULT (current_function_decl),
6215                                         ffecom_expr (expr)));
6216         }
6217     }
6218
6219   ffecom_end_compstmt ();
6220
6221   func = current_function_decl;
6222   finish_function (1);
6223
6224   pop_f_function_context ();
6225
6226   recurse = FALSE;
6227
6228   lineno = old_lineno;
6229   input_filename = old_input_filename;
6230
6231   ffecom_nested_entry_ = NULL;
6232
6233   return func;
6234 }
6235
6236 static const char *
6237 ffecom_gfrt_args_ (ffecomGfrt ix)
6238 {
6239   return ffecom_gfrt_argstring_[ix];
6240 }
6241
6242 static tree
6243 ffecom_gfrt_tree_ (ffecomGfrt ix)
6244 {
6245   if (ffecom_gfrt_[ix] == NULL_TREE)
6246     ffecom_make_gfrt_ (ix);
6247
6248   return ffecom_1 (ADDR_EXPR,
6249                    build_pointer_type (TREE_TYPE (ffecom_gfrt_[ix])),
6250                    ffecom_gfrt_[ix]);
6251 }
6252
6253 /* Return initialize-to-zero expression for this VAR_DECL.  */
6254
6255 /* A somewhat evil way to prevent the garbage collector
6256    from collecting 'tree' structures.  */
6257 #define NUM_TRACKED_CHUNK 63
6258 static struct tree_ggc_tracker
6259 {
6260   struct tree_ggc_tracker *next;
6261   tree trees[NUM_TRACKED_CHUNK];
6262 } *tracker_head = NULL;
6263
6264 static void
6265 mark_tracker_head (void *arg)
6266 {
6267   struct tree_ggc_tracker *head;
6268   int i;
6269
6270   for (head = * (struct tree_ggc_tracker **) arg;
6271        head != NULL;
6272        head = head->next)
6273   {
6274     ggc_mark (head);
6275     for (i = 0; i < NUM_TRACKED_CHUNK; i++)
6276       ggc_mark_tree (head->trees[i]);
6277   }
6278 }
6279
6280 void
6281 ffecom_save_tree_forever (tree t)
6282 {
6283   int i;
6284   if (tracker_head != NULL)
6285     for (i = 0; i < NUM_TRACKED_CHUNK; i++)
6286       if (tracker_head->trees[i] == NULL)
6287         {
6288           tracker_head->trees[i] = t;
6289           return;
6290         }
6291
6292   {
6293     /* Need to allocate a new block.  */
6294     struct tree_ggc_tracker *old_head = tracker_head;
6295
6296     tracker_head = ggc_alloc (sizeof (*tracker_head));
6297     tracker_head->next = old_head;
6298     tracker_head->trees[0] = t;
6299     for (i = 1; i < NUM_TRACKED_CHUNK; i++)
6300       tracker_head->trees[i] = NULL;
6301   }
6302 }
6303
6304 static tree
6305 ffecom_init_zero_ (tree decl)
6306 {
6307   tree init;
6308   int incremental = TREE_STATIC (decl);
6309   tree type = TREE_TYPE (decl);
6310
6311   if (incremental)
6312     {
6313       make_decl_rtl (decl, NULL);
6314       assemble_variable (decl, TREE_PUBLIC (decl) ? 1 : 0, 0, 1);
6315     }
6316
6317   if ((TREE_CODE (type) != ARRAY_TYPE)
6318       && (TREE_CODE (type) != RECORD_TYPE)
6319       && (TREE_CODE (type) != UNION_TYPE)
6320       && !incremental)
6321     init = convert (type, integer_zero_node);
6322   else if (!incremental)
6323     {
6324       init = build (CONSTRUCTOR, type, NULL_TREE, NULL_TREE);
6325       TREE_CONSTANT (init) = 1;
6326       TREE_STATIC (init) = 1;
6327     }
6328   else
6329     {
6330       assemble_zeros (int_size_in_bytes (type));
6331       init = error_mark_node;
6332     }
6333
6334   return init;
6335 }
6336
6337 static tree
6338 ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
6339                          tree *maybe_tree)
6340 {
6341   tree expr_tree;
6342   tree length_tree;
6343
6344   switch (ffebld_op (arg))
6345     {
6346     case FFEBLD_opCONTER:       /* For F90, check 0-length. */
6347       if (ffetarget_length_character1
6348           (ffebld_constant_character1
6349            (ffebld_conter (arg))) == 0)
6350         {
6351           *maybe_tree = integer_zero_node;
6352           return convert (tree_type, integer_zero_node);
6353         }
6354
6355       *maybe_tree = integer_one_node;
6356       expr_tree = build_int_2 (*ffetarget_text_character1
6357                                (ffebld_constant_character1
6358                                 (ffebld_conter (arg))),
6359                                0);
6360       TREE_TYPE (expr_tree) = tree_type;
6361       return expr_tree;
6362
6363     case FFEBLD_opSYMTER:
6364     case FFEBLD_opARRAYREF:
6365     case FFEBLD_opFUNCREF:
6366     case FFEBLD_opSUBSTR:
6367       ffecom_char_args_ (&expr_tree, &length_tree, arg);
6368
6369       if ((expr_tree == error_mark_node)
6370           || (length_tree == error_mark_node))
6371         {
6372           *maybe_tree = error_mark_node;
6373           return error_mark_node;
6374         }
6375
6376       if (integer_zerop (length_tree))
6377         {
6378           *maybe_tree = integer_zero_node;
6379           return convert (tree_type, integer_zero_node);
6380         }
6381
6382       expr_tree
6383         = ffecom_1 (INDIRECT_REF,
6384                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6385                     expr_tree);
6386       expr_tree
6387         = ffecom_2 (ARRAY_REF,
6388                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6389                     expr_tree,
6390                     integer_one_node);
6391       expr_tree = convert (tree_type, expr_tree);
6392
6393       if (TREE_CODE (length_tree) == INTEGER_CST)
6394         *maybe_tree = integer_one_node;
6395       else                      /* Must check length at run time.  */
6396         *maybe_tree
6397           = ffecom_truth_value
6398             (ffecom_2 (GT_EXPR, integer_type_node,
6399                        length_tree,
6400                        ffecom_f2c_ftnlen_zero_node));
6401       return expr_tree;
6402
6403     case FFEBLD_opPAREN:
6404     case FFEBLD_opCONVERT:
6405       if (ffeinfo_size (ffebld_info (arg)) == 0)
6406         {
6407           *maybe_tree = integer_zero_node;
6408           return convert (tree_type, integer_zero_node);
6409         }
6410       return ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6411                                       maybe_tree);
6412
6413     case FFEBLD_opCONCATENATE:
6414       {
6415         tree maybe_left;
6416         tree maybe_right;
6417         tree expr_left;
6418         tree expr_right;
6419
6420         expr_left = ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6421                                              &maybe_left);
6422         expr_right = ffecom_intrinsic_ichar_ (tree_type, ffebld_right (arg),
6423                                               &maybe_right);
6424         *maybe_tree = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
6425                                 maybe_left,
6426                                 maybe_right);
6427         expr_tree = ffecom_3 (COND_EXPR, tree_type,
6428                               maybe_left,
6429                               expr_left,
6430                               expr_right);
6431         return expr_tree;
6432       }
6433
6434     default:
6435       assert ("bad op in ICHAR" == NULL);
6436       return error_mark_node;
6437     }
6438 }
6439
6440 /* ffecom_intrinsic_len_ -- Return length info for char arg (LEN())
6441
6442    tree length_arg;
6443    ffebld expr;
6444    length_arg = ffecom_intrinsic_len_ (expr);
6445
6446    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
6447    subexpressions by constructing the appropriate tree for the
6448    length-of-character-text argument in a calling sequence.  */
6449
6450 static tree
6451 ffecom_intrinsic_len_ (ffebld expr)
6452 {
6453   ffetargetCharacter1 val;
6454   tree length;
6455
6456   switch (ffebld_op (expr))
6457     {
6458     case FFEBLD_opCONTER:
6459       val = ffebld_constant_character1 (ffebld_conter (expr));
6460       length = build_int_2 (ffetarget_length_character1 (val), 0);
6461       TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6462       break;
6463
6464     case FFEBLD_opSYMTER:
6465       {
6466         ffesymbol s = ffebld_symter (expr);
6467         tree item;
6468
6469         item = ffesymbol_hook (s).decl_tree;
6470         if (item == NULL_TREE)
6471           {
6472             s = ffecom_sym_transform_ (s);
6473             item = ffesymbol_hook (s).decl_tree;
6474           }
6475         if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
6476           {
6477             if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
6478               length = ffesymbol_hook (s).length_tree;
6479             else
6480               {
6481                 length = build_int_2 (ffesymbol_size (s), 0);
6482                 TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6483               }
6484           }
6485         else if (item == error_mark_node)
6486           length = error_mark_node;
6487         else                    /* FFEINFO_kindFUNCTION: */
6488           length = NULL_TREE;
6489       }
6490       break;
6491
6492     case FFEBLD_opARRAYREF:
6493       length = ffecom_intrinsic_len_ (ffebld_left (expr));
6494       break;
6495
6496     case FFEBLD_opSUBSTR:
6497       {
6498         ffebld start;
6499         ffebld end;
6500         ffebld thing = ffebld_right (expr);
6501         tree start_tree;
6502         tree end_tree;
6503
6504         assert (ffebld_op (thing) == FFEBLD_opITEM);
6505         start = ffebld_head (thing);
6506         thing = ffebld_trail (thing);
6507         assert (ffebld_trail (thing) == NULL);
6508         end = ffebld_head (thing);
6509
6510         length = ffecom_intrinsic_len_ (ffebld_left (expr));
6511
6512         if (length == error_mark_node)
6513           break;
6514
6515         if (start == NULL)
6516           {
6517             if (end == NULL)
6518               ;
6519             else
6520               {
6521                 length = convert (ffecom_f2c_ftnlen_type_node,
6522                                   ffecom_expr (end));
6523               }
6524           }
6525         else
6526           {
6527             start_tree = convert (ffecom_f2c_ftnlen_type_node,
6528                                   ffecom_expr (start));
6529
6530             if (start_tree == error_mark_node)
6531               {
6532                 length = error_mark_node;
6533                 break;
6534               }
6535
6536             if (end == NULL)
6537               {
6538                 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6539                                    ffecom_f2c_ftnlen_one_node,
6540                                    ffecom_2 (MINUS_EXPR,
6541                                              ffecom_f2c_ftnlen_type_node,
6542                                              length,
6543                                              start_tree));
6544               }
6545             else
6546               {
6547                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
6548                                     ffecom_expr (end));
6549
6550                 if (end_tree == error_mark_node)
6551                   {
6552                     length = error_mark_node;
6553                     break;
6554                   }
6555
6556                 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6557                                    ffecom_f2c_ftnlen_one_node,
6558                                    ffecom_2 (MINUS_EXPR,
6559                                              ffecom_f2c_ftnlen_type_node,
6560                                              end_tree, start_tree));
6561               }
6562           }
6563       }
6564       break;
6565
6566     case FFEBLD_opCONCATENATE:
6567       length
6568         = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6569                     ffecom_intrinsic_len_ (ffebld_left (expr)),
6570                     ffecom_intrinsic_len_ (ffebld_right (expr)));
6571       break;
6572
6573     case FFEBLD_opFUNCREF:
6574     case FFEBLD_opCONVERT:
6575       length = build_int_2 (ffebld_size (expr), 0);
6576       TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6577       break;
6578
6579     default:
6580       assert ("bad op for single char arg expr" == NULL);
6581       length = ffecom_f2c_ftnlen_zero_node;
6582       break;
6583     }
6584
6585   assert (length != NULL_TREE);
6586
6587   return length;
6588 }
6589
6590 /* Handle CHARACTER assignments.
6591
6592    Generates code to do the assignment.  Used by ordinary assignment
6593    statement handler ffecom_let_stmt and by statement-function
6594    handler to generate code for a statement function.  */
6595
6596 static void
6597 ffecom_let_char_ (tree dest_tree, tree dest_length,
6598                   ffetargetCharacterSize dest_size, ffebld source)
6599 {
6600   ffecomConcatList_ catlist;
6601   tree source_length;
6602   tree source_tree;
6603   tree expr_tree;
6604
6605   if ((dest_tree == error_mark_node)
6606       || (dest_length == error_mark_node))
6607     return;
6608
6609   assert (dest_tree != NULL_TREE);
6610   assert (dest_length != NULL_TREE);
6611
6612   /* Source might be an opCONVERT, which just means it is a different size
6613      than the destination.  Since the underlying implementation here handles
6614      that (directly or via the s_copy or s_cat run-time-library functions),
6615      we don't need the "convenience" of an opCONVERT that tells us to
6616      truncate or blank-pad, particularly since the resulting implementation
6617      would probably be slower than otherwise. */
6618
6619   while (ffebld_op (source) == FFEBLD_opCONVERT)
6620     source = ffebld_left (source);
6621
6622   catlist = ffecom_concat_list_new_ (source, dest_size);
6623   switch (ffecom_concat_list_count_ (catlist))
6624     {
6625     case 0:                     /* Shouldn't happen, but in case it does... */
6626       ffecom_concat_list_kill_ (catlist);
6627       source_tree = null_pointer_node;
6628       source_length = ffecom_f2c_ftnlen_zero_node;
6629       expr_tree = build_tree_list (NULL_TREE, dest_tree);
6630       TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6631       TREE_CHAIN (TREE_CHAIN (expr_tree))
6632         = build_tree_list (NULL_TREE, dest_length);
6633       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6634         = build_tree_list (NULL_TREE, source_length);
6635
6636       expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6637       TREE_SIDE_EFFECTS (expr_tree) = 1;
6638
6639       expand_expr_stmt (expr_tree);
6640
6641       return;
6642
6643     case 1:                     /* The (fairly) easy case. */
6644       ffecom_char_args_ (&source_tree, &source_length,
6645                          ffecom_concat_list_expr_ (catlist, 0));
6646       ffecom_concat_list_kill_ (catlist);
6647       assert (source_tree != NULL_TREE);
6648       assert (source_length != NULL_TREE);
6649
6650       if ((source_tree == error_mark_node)
6651           || (source_length == error_mark_node))
6652         return;
6653
6654       if (dest_size == 1)
6655         {
6656           dest_tree
6657             = ffecom_1 (INDIRECT_REF,
6658                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6659                                                       (dest_tree))),
6660                         dest_tree);
6661           dest_tree
6662             = ffecom_2 (ARRAY_REF,
6663                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6664                                                       (dest_tree))),
6665                         dest_tree,
6666                         integer_one_node);
6667           source_tree
6668             = ffecom_1 (INDIRECT_REF,
6669                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6670                                                       (source_tree))),
6671                         source_tree);
6672           source_tree
6673             = ffecom_2 (ARRAY_REF,
6674                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6675                                                       (source_tree))),
6676                         source_tree,
6677                         integer_one_node);
6678
6679           expr_tree = ffecom_modify (void_type_node, dest_tree, source_tree);
6680
6681           expand_expr_stmt (expr_tree);
6682
6683           return;
6684         }
6685
6686       expr_tree = build_tree_list (NULL_TREE, dest_tree);
6687       TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6688       TREE_CHAIN (TREE_CHAIN (expr_tree))
6689         = build_tree_list (NULL_TREE, dest_length);
6690       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6691         = build_tree_list (NULL_TREE, source_length);
6692
6693       expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6694       TREE_SIDE_EFFECTS (expr_tree) = 1;
6695
6696       expand_expr_stmt (expr_tree);
6697
6698       return;
6699
6700     default:                    /* Must actually concatenate things. */
6701       break;
6702     }
6703
6704   /* Heavy-duty concatenation. */
6705
6706   {
6707     int count = ffecom_concat_list_count_ (catlist);
6708     int i;
6709     tree lengths;
6710     tree items;
6711     tree length_array;
6712     tree item_array;
6713     tree citem;
6714     tree clength;
6715
6716 #ifdef HOHO
6717     length_array
6718       = lengths
6719       = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
6720                              FFETARGET_charactersizeNONE, count, TRUE);
6721     item_array = items = ffecom_push_tempvar (ffecom_f2c_address_type_node,
6722                                               FFETARGET_charactersizeNONE,
6723                                               count, TRUE);
6724 #else
6725     {
6726       tree hook;
6727
6728       hook = ffebld_nonter_hook (source);
6729       assert (hook);
6730       assert (TREE_CODE (hook) == TREE_VEC);
6731       assert (TREE_VEC_LENGTH (hook) == 2);
6732       length_array = lengths = TREE_VEC_ELT (hook, 0);
6733       item_array = items = TREE_VEC_ELT (hook, 1);
6734     }
6735 #endif
6736
6737     for (i = 0; i < count; ++i)
6738       {
6739         ffecom_char_args_ (&citem, &clength,
6740                            ffecom_concat_list_expr_ (catlist, i));
6741         if ((citem == error_mark_node)
6742             || (clength == error_mark_node))
6743           {
6744             ffecom_concat_list_kill_ (catlist);
6745             return;
6746           }
6747
6748         items
6749           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
6750                       ffecom_modify (void_type_node,
6751                                      ffecom_2 (ARRAY_REF,
6752                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
6753                                                item_array,
6754                                                build_int_2 (i, 0)),
6755                                      citem),
6756                       items);
6757         lengths
6758           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
6759                       ffecom_modify (void_type_node,
6760                                      ffecom_2 (ARRAY_REF,
6761                    TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
6762                                                length_array,
6763                                                build_int_2 (i, 0)),
6764                                      clength),
6765                       lengths);
6766       }
6767
6768     expr_tree = build_tree_list (NULL_TREE, dest_tree);
6769     TREE_CHAIN (expr_tree)
6770       = build_tree_list (NULL_TREE,
6771                          ffecom_1 (ADDR_EXPR,
6772                                    build_pointer_type (TREE_TYPE (items)),
6773                                    items));
6774     TREE_CHAIN (TREE_CHAIN (expr_tree))
6775       = build_tree_list (NULL_TREE,
6776                          ffecom_1 (ADDR_EXPR,
6777                                    build_pointer_type (TREE_TYPE (lengths)),
6778                                    lengths));
6779     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6780       = build_tree_list
6781         (NULL_TREE,
6782          ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
6783                    convert (ffecom_f2c_ftnlen_type_node,
6784                             build_int_2 (count, 0))));
6785     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree))))
6786       = build_tree_list (NULL_TREE, dest_length);
6787
6788     expr_tree = ffecom_call_gfrt (FFECOM_gfrtCAT, expr_tree, NULL_TREE);
6789     TREE_SIDE_EFFECTS (expr_tree) = 1;
6790
6791     expand_expr_stmt (expr_tree);
6792   }
6793
6794   ffecom_concat_list_kill_ (catlist);
6795 }
6796
6797 /* ffecom_make_gfrt_ -- Make initial info for run-time routine
6798
6799    ffecomGfrt ix;
6800    ffecom_make_gfrt_(ix);
6801
6802    Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL
6803    for the indicated run-time routine (ix).  */
6804
6805 static void
6806 ffecom_make_gfrt_ (ffecomGfrt ix)
6807 {
6808   tree t;
6809   tree ttype;
6810
6811   switch (ffecom_gfrt_type_[ix])
6812     {
6813     case FFECOM_rttypeVOID_:
6814       ttype = void_type_node;
6815       break;
6816
6817     case FFECOM_rttypeVOIDSTAR_:
6818       ttype = TREE_TYPE (null_pointer_node);    /* `void *'. */
6819       break;
6820
6821     case FFECOM_rttypeFTNINT_:
6822       ttype = ffecom_f2c_ftnint_type_node;
6823       break;
6824
6825     case FFECOM_rttypeINTEGER_:
6826       ttype = ffecom_f2c_integer_type_node;
6827       break;
6828
6829     case FFECOM_rttypeLONGINT_:
6830       ttype = ffecom_f2c_longint_type_node;
6831       break;
6832
6833     case FFECOM_rttypeLOGICAL_:
6834       ttype = ffecom_f2c_logical_type_node;
6835       break;
6836
6837     case FFECOM_rttypeREAL_F2C_:
6838       ttype = double_type_node;
6839       break;
6840
6841     case FFECOM_rttypeREAL_GNU_:
6842       ttype = float_type_node;
6843       break;
6844
6845     case FFECOM_rttypeCOMPLEX_F2C_:
6846       ttype = void_type_node;
6847       break;
6848
6849     case FFECOM_rttypeCOMPLEX_GNU_:
6850       ttype = ffecom_f2c_complex_type_node;
6851       break;
6852
6853     case FFECOM_rttypeDOUBLE_:
6854       ttype = double_type_node;
6855       break;
6856
6857     case FFECOM_rttypeDOUBLEREAL_:
6858       ttype = ffecom_f2c_doublereal_type_node;
6859       break;
6860
6861     case FFECOM_rttypeDBLCMPLX_F2C_:
6862       ttype = void_type_node;
6863       break;
6864
6865     case FFECOM_rttypeDBLCMPLX_GNU_:
6866       ttype = ffecom_f2c_doublecomplex_type_node;
6867       break;
6868
6869     case FFECOM_rttypeCHARACTER_:
6870       ttype = void_type_node;
6871       break;
6872
6873     default:
6874       ttype = NULL;
6875       assert ("bad rttype" == NULL);
6876       break;
6877     }
6878
6879   ttype = build_function_type (ttype, NULL_TREE);
6880   t = build_decl (FUNCTION_DECL,
6881                   get_identifier (ffecom_gfrt_name_[ix]),
6882                   ttype);
6883   DECL_EXTERNAL (t) = 1;
6884   TREE_READONLY (t) = ffecom_gfrt_const_[ix] ? 1 : 0;
6885   TREE_PUBLIC (t) = 1;
6886   TREE_THIS_VOLATILE (t) = ffecom_gfrt_volatile_[ix] ? 1 : 0;
6887
6888   /* Sanity check:  A function that's const cannot be volatile.  */
6889
6890   assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_volatile_[ix] : 1);
6891
6892   /* Sanity check: A function that's const cannot return complex.  */
6893
6894   assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_complex_[ix] : 1);
6895
6896   t = start_decl (t, TRUE);
6897
6898   finish_decl (t, NULL_TREE, TRUE);
6899
6900   ffecom_gfrt_[ix] = t;
6901 }
6902
6903 /* Phase 1 pass over each member of a COMMON/EQUIVALENCE group.  */
6904
6905 static void
6906 ffecom_member_phase1_ (ffestorag mst UNUSED, ffestorag st)
6907 {
6908   ffesymbol s = ffestorag_symbol (st);
6909
6910   if (ffesymbol_namelisted (s))
6911     ffecom_member_namelisted_ = TRUE;
6912 }
6913
6914 /* Phase 2 pass over each member of a COMMON/EQUIVALENCE group.  Declare
6915    the member so debugger will see it.  Otherwise nobody should be
6916    referencing the member.  */
6917
6918 static void
6919 ffecom_member_phase2_ (ffestorag mst, ffestorag st)
6920 {
6921   ffesymbol s;
6922   tree t;
6923   tree mt;
6924   tree type;
6925
6926   if ((mst == NULL)
6927       || ((mt = ffestorag_hook (mst)) == NULL)
6928       || (mt == error_mark_node))
6929     return;
6930
6931   if ((st == NULL)
6932       || ((s = ffestorag_symbol (st)) == NULL))
6933     return;
6934
6935   type = ffecom_type_localvar_ (s,
6936                                 ffesymbol_basictype (s),
6937                                 ffesymbol_kindtype (s));
6938   if (type == error_mark_node)
6939     return;
6940
6941   t = build_decl (VAR_DECL,
6942                   ffecom_get_identifier_ (ffesymbol_text (s)),
6943                   type);
6944
6945   TREE_STATIC (t) = TREE_STATIC (mt);
6946   DECL_INITIAL (t) = NULL_TREE;
6947   TREE_ASM_WRITTEN (t) = 1;
6948   TREE_USED (t) = 1;
6949
6950   SET_DECL_RTL (t,
6951                 gen_rtx (MEM, TYPE_MODE (type),
6952                          plus_constant (XEXP (DECL_RTL (mt), 0),
6953                                         ffestorag_modulo (mst)
6954                                         + ffestorag_offset (st)
6955                                         - ffestorag_offset (mst))));
6956
6957   t = start_decl (t, FALSE);
6958
6959   finish_decl (t, NULL_TREE, FALSE);
6960 }
6961
6962 /* Prepare source expression for assignment into a destination perhaps known
6963    to be of a specific size.  */
6964
6965 static void
6966 ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size, ffebld source)
6967 {
6968   ffecomConcatList_ catlist;
6969   int count;
6970   int i;
6971   tree ltmp;
6972   tree itmp;
6973   tree tempvar = NULL_TREE;
6974
6975   while (ffebld_op (source) == FFEBLD_opCONVERT)
6976     source = ffebld_left (source);
6977
6978   catlist = ffecom_concat_list_new_ (source, dest_size);
6979   count = ffecom_concat_list_count_ (catlist);
6980
6981   if (count >= 2)
6982     {
6983       ltmp
6984         = ffecom_make_tempvar ("let_char_len", ffecom_f2c_ftnlen_type_node,
6985                                FFETARGET_charactersizeNONE, count);
6986       itmp
6987         = ffecom_make_tempvar ("let_char_item", ffecom_f2c_address_type_node,
6988                                FFETARGET_charactersizeNONE, count);
6989
6990       tempvar = make_tree_vec (2);
6991       TREE_VEC_ELT (tempvar, 0) = ltmp;
6992       TREE_VEC_ELT (tempvar, 1) = itmp;
6993     }
6994
6995   for (i = 0; i < count; ++i)
6996     ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist, i));
6997
6998   ffecom_concat_list_kill_ (catlist);
6999
7000   if (tempvar)
7001     {
7002       ffebld_nonter_set_hook (source, tempvar);
7003       current_binding_level->prep_state = 1;
7004     }
7005 }
7006
7007 /* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order
7008
7009    Ignores STAR (alternate-return) dummies.  All other get exec-transitioned
7010    (which generates their trees) and then their trees get push_parm_decl'd.
7011
7012    The second arg is TRUE if the dummies are for a statement function, in
7013    which case lengths are not pushed for character arguments (since they are
7014    always known by both the caller and the callee, though the code allows
7015    for someday permitting CHAR*(*) stmtfunc dummies).  */
7016
7017 static void
7018 ffecom_push_dummy_decls_ (ffebld dummy_list, bool stmtfunc)
7019 {
7020   ffebld dummy;
7021   ffebld dumlist;
7022   ffesymbol s;
7023   tree parm;
7024
7025   ffecom_transform_only_dummies_ = TRUE;
7026
7027   /* First push the parms corresponding to actual dummy "contents".  */
7028
7029   for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7030     {
7031       dummy = ffebld_head (dumlist);
7032       switch (ffebld_op (dummy))
7033         {
7034         case FFEBLD_opSTAR:
7035         case FFEBLD_opANY:
7036           continue;             /* Forget alternate returns. */
7037
7038         default:
7039           break;
7040         }
7041       assert (ffebld_op (dummy) == FFEBLD_opSYMTER);
7042       s = ffebld_symter (dummy);
7043       parm = ffesymbol_hook (s).decl_tree;
7044       if (parm == NULL_TREE)
7045         {
7046           s = ffecom_sym_transform_ (s);
7047           parm = ffesymbol_hook (s).decl_tree;
7048           assert (parm != NULL_TREE);
7049         }
7050       if (parm != error_mark_node)
7051         push_parm_decl (parm);
7052     }
7053
7054   /* Then, for CHARACTER dummies, push the parms giving their lengths.  */
7055
7056   for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7057     {
7058       dummy = ffebld_head (dumlist);
7059       switch (ffebld_op (dummy))
7060         {
7061         case FFEBLD_opSTAR:
7062         case FFEBLD_opANY:
7063           continue;             /* Forget alternate returns, they mean
7064                                    NOTHING! */
7065
7066         default:
7067           break;
7068         }
7069       s = ffebld_symter (dummy);
7070       if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
7071         continue;               /* Only looking for CHARACTER arguments. */
7072       if (stmtfunc && (ffesymbol_size (s) != FFETARGET_charactersizeNONE))
7073         continue;               /* Stmtfunc arg with known size needs no
7074                                    length param. */
7075       if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
7076         continue;               /* Only looking for variables and arrays. */
7077       parm = ffesymbol_hook (s).length_tree;
7078       assert (parm != NULL_TREE);
7079       if (parm != error_mark_node)
7080         push_parm_decl (parm);
7081     }
7082
7083   ffecom_transform_only_dummies_ = FALSE;
7084 }
7085
7086 /* ffecom_start_progunit_ -- Beginning of program unit
7087
7088    Does GNU back end stuff necessary to teach it about the start of its
7089    equivalent of a Fortran program unit.  */
7090
7091 static void
7092 ffecom_start_progunit_ ()
7093 {
7094   ffesymbol fn = ffecom_primary_entry_;
7095   ffebld arglist;
7096   tree id;                      /* Identifier (name) of function. */
7097   tree type;                    /* Type of function. */
7098   tree result;                  /* Result of function. */
7099   ffeinfoBasictype bt;
7100   ffeinfoKindtype kt;
7101   ffeglobal g;
7102   ffeglobalType gt;
7103   ffeglobalType egt = FFEGLOBAL_type;
7104   bool charfunc;
7105   bool cmplxfunc;
7106   bool altentries = (ffecom_num_entrypoints_ != 0);
7107   bool multi
7108   = altentries
7109   && (ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
7110   && (ffecom_master_bt_ == FFEINFO_basictypeNONE);
7111   bool main_program = FALSE;
7112   int old_lineno = lineno;
7113   const char *old_input_filename = input_filename;
7114
7115   assert (fn != NULL);
7116   assert (ffesymbol_hook (fn).decl_tree == NULL_TREE);
7117
7118   input_filename = ffesymbol_where_filename (fn);
7119   lineno = ffesymbol_where_filelinenum (fn);
7120
7121   switch (ffecom_primary_entry_kind_)
7122     {
7123     case FFEINFO_kindPROGRAM:
7124       main_program = TRUE;
7125       gt = FFEGLOBAL_typeMAIN;
7126       bt = FFEINFO_basictypeNONE;
7127       kt = FFEINFO_kindtypeNONE;
7128       type = ffecom_tree_fun_type_void;
7129       charfunc = FALSE;
7130       cmplxfunc = FALSE;
7131       break;
7132
7133     case FFEINFO_kindBLOCKDATA:
7134       gt = FFEGLOBAL_typeBDATA;
7135       bt = FFEINFO_basictypeNONE;
7136       kt = FFEINFO_kindtypeNONE;
7137       type = ffecom_tree_fun_type_void;
7138       charfunc = FALSE;
7139       cmplxfunc = FALSE;
7140       break;
7141
7142     case FFEINFO_kindFUNCTION:
7143       gt = FFEGLOBAL_typeFUNC;
7144       egt = FFEGLOBAL_typeEXT;
7145       bt = ffesymbol_basictype (fn);
7146       kt = ffesymbol_kindtype (fn);
7147       if (bt == FFEINFO_basictypeNONE)
7148         {
7149           ffeimplic_establish_symbol (fn);
7150           if (ffesymbol_funcresult (fn) != NULL)
7151             ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
7152           bt = ffesymbol_basictype (fn);
7153           kt = ffesymbol_kindtype (fn);
7154         }
7155
7156       if (multi)
7157         charfunc = cmplxfunc = FALSE;
7158       else if (bt == FFEINFO_basictypeCHARACTER)
7159         charfunc = TRUE, cmplxfunc = FALSE;
7160       else if ((bt == FFEINFO_basictypeCOMPLEX)
7161                && ffesymbol_is_f2c (fn)
7162                && !altentries)
7163         charfunc = FALSE, cmplxfunc = TRUE;
7164       else
7165         charfunc = cmplxfunc = FALSE;
7166
7167       if (multi || charfunc)
7168         type = ffecom_tree_fun_type_void;
7169       else if (ffesymbol_is_f2c (fn) && !altentries)
7170         type = ffecom_tree_fun_type[bt][kt];
7171       else
7172         type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
7173
7174       if ((type == NULL_TREE)
7175           || (TREE_TYPE (type) == NULL_TREE))
7176         type = ffecom_tree_fun_type_void;       /* _sym_exec_transition. */
7177       break;
7178
7179     case FFEINFO_kindSUBROUTINE:
7180       gt = FFEGLOBAL_typeSUBR;
7181       egt = FFEGLOBAL_typeEXT;
7182       bt = FFEINFO_basictypeNONE;
7183       kt = FFEINFO_kindtypeNONE;
7184       if (ffecom_is_altreturning_)
7185         type = ffecom_tree_subr_type;
7186       else
7187         type = ffecom_tree_fun_type_void;
7188       charfunc = FALSE;
7189       cmplxfunc = FALSE;
7190       break;
7191
7192     default:
7193       assert ("say what??" == NULL);
7194       /* Fall through. */
7195     case FFEINFO_kindANY:
7196       gt = FFEGLOBAL_typeANY;
7197       bt = FFEINFO_basictypeNONE;
7198       kt = FFEINFO_kindtypeNONE;
7199       type = error_mark_node;
7200       charfunc = FALSE;
7201       cmplxfunc = FALSE;
7202       break;
7203     }
7204
7205   if (altentries)
7206     {
7207       id = ffecom_get_invented_identifier ("__g77_masterfun_%s",
7208                                            ffesymbol_text (fn));
7209     }
7210 #if FFETARGET_isENFORCED_MAIN
7211   else if (main_program)
7212     id = get_identifier (FFETARGET_nameENFORCED_MAIN_NAME);
7213 #endif
7214   else
7215     id = ffecom_get_external_identifier_ (fn);
7216
7217   start_function (id,
7218                   type,
7219                   0,            /* nested/inline */
7220                   !altentries); /* TREE_PUBLIC */
7221
7222   TREE_USED (current_function_decl) = 1;        /* Avoid spurious warning if altentries. */
7223
7224   if (!altentries
7225       && ((g = ffesymbol_global (fn)) != NULL)
7226       && ((ffeglobal_type (g) == gt)
7227           || (ffeglobal_type (g) == egt)))
7228     {
7229       ffeglobal_set_hook (g, current_function_decl);
7230     }
7231
7232   /* Arg handling needs exec-transitioned ffesymbols to work with.  But
7233      exec-transitioning needs current_function_decl to be filled in.  So we
7234      do these things in two phases. */
7235
7236   if (altentries)
7237     {                           /* 1st arg identifies which entrypoint. */
7238       ffecom_which_entrypoint_decl_
7239         = build_decl (PARM_DECL,
7240                       ffecom_get_invented_identifier ("__g77_%s",
7241                                                       "which_entrypoint"),
7242                       integer_type_node);
7243       push_parm_decl (ffecom_which_entrypoint_decl_);
7244     }
7245
7246   if (charfunc
7247       || cmplxfunc
7248       || multi)
7249     {                           /* Arg for result (return value). */
7250       tree type;
7251       tree length;
7252
7253       if (charfunc)
7254         type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
7255       else if (cmplxfunc)
7256         type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
7257       else
7258         type = ffecom_multi_type_node_;
7259
7260       result = ffecom_get_invented_identifier ("__g77_%s", "result");
7261
7262       /* Make length arg _and_ enhance type info for CHAR arg itself.  */
7263
7264       if (charfunc)
7265         length = ffecom_char_enhance_arg_ (&type, fn);
7266       else
7267         length = NULL_TREE;     /* Not ref'd if !charfunc. */
7268
7269       type = build_pointer_type (type);
7270       result = build_decl (PARM_DECL, result, type);
7271
7272       push_parm_decl (result);
7273       if (multi)
7274         ffecom_multi_retval_ = result;
7275       else
7276         ffecom_func_result_ = result;
7277
7278       if (charfunc)
7279         {
7280           push_parm_decl (length);
7281           ffecom_func_length_ = length;
7282         }
7283     }
7284
7285   if (ffecom_primary_entry_is_proc_)
7286     {
7287       if (altentries)
7288         arglist = ffecom_master_arglist_;
7289       else
7290         arglist = ffesymbol_dummyargs (fn);
7291       ffecom_push_dummy_decls_ (arglist, FALSE);
7292     }
7293
7294   if (TREE_CODE (current_function_decl) != ERROR_MARK)
7295     store_parm_decls (main_program ? 1 : 0);
7296
7297   ffecom_start_compstmt ();
7298   /* Disallow temp vars at this level.  */
7299   current_binding_level->prep_state = 2;
7300
7301   lineno = old_lineno;
7302   input_filename = old_input_filename;
7303
7304   /* This handles any symbols still untransformed, in case -g specified.
7305      This used to be done in ffecom_finish_progunit, but it turns out to
7306      be necessary to do it here so that statement functions are
7307      expanded before code.  But don't bother for BLOCK DATA.  */
7308
7309   if (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
7310     ffesymbol_drive (ffecom_finish_symbol_transform_);
7311 }
7312
7313 /* ffecom_sym_transform_ -- Transform FFE sym into backend sym
7314
7315    ffesymbol s;
7316    ffecom_sym_transform_(s);
7317
7318    The ffesymbol_hook info for s is updated with appropriate backend info
7319    on the symbol.  */
7320
7321 static ffesymbol
7322 ffecom_sym_transform_ (ffesymbol s)
7323 {
7324   tree t;                       /* Transformed thingy. */
7325   tree tlen;                    /* Length if CHAR*(*). */
7326   bool addr;                    /* Is t the address of the thingy? */
7327   ffeinfoBasictype bt;
7328   ffeinfoKindtype kt;
7329   ffeglobal g;
7330   int old_lineno = lineno;
7331   const char *old_input_filename = input_filename;
7332
7333   /* Must ensure special ASSIGN variables are declared at top of outermost
7334      block, else they'll end up in the innermost block when their first
7335      ASSIGN is seen, which leaves them out of scope when they're the
7336      subject of a GOTO or I/O statement.
7337
7338      We make this variable even if -fugly-assign.  Just let it go unused,
7339      in case it turns out there are cases where we really want to use this
7340      variable anyway (e.g. ASSIGN to INTEGER*2 variable).  */
7341
7342   if (! ffecom_transform_only_dummies_
7343       && ffesymbol_assigned (s)
7344       && ! ffesymbol_hook (s).assign_tree)
7345     s = ffecom_sym_transform_assign_ (s);
7346
7347   if (ffesymbol_sfdummyparent (s) == NULL)
7348     {
7349       input_filename = ffesymbol_where_filename (s);
7350       lineno = ffesymbol_where_filelinenum (s);
7351     }
7352   else
7353     {
7354       ffesymbol sf = ffesymbol_sfdummyparent (s);
7355
7356       input_filename = ffesymbol_where_filename (sf);
7357       lineno = ffesymbol_where_filelinenum (sf);
7358     }
7359
7360   bt = ffeinfo_basictype (ffebld_info (s));
7361   kt = ffeinfo_kindtype (ffebld_info (s));
7362
7363   t = NULL_TREE;
7364   tlen = NULL_TREE;
7365   addr = FALSE;
7366
7367   switch (ffesymbol_kind (s))
7368     {
7369     case FFEINFO_kindNONE:
7370       switch (ffesymbol_where (s))
7371         {
7372         case FFEINFO_whereDUMMY:        /* Subroutine or function. */
7373           assert (ffecom_transform_only_dummies_);
7374
7375           /* Before 0.4, this could be ENTITY/DUMMY, but see
7376              ffestu_sym_end_transition -- no longer true (in particular, if
7377              it could be an ENTITY, it _will_ be made one, so that
7378              possibility won't come through here).  So we never make length
7379              arg for CHARACTER type.  */
7380
7381           t = build_decl (PARM_DECL,
7382                           ffecom_get_identifier_ (ffesymbol_text (s)),
7383                           ffecom_tree_ptr_to_subr_type);
7384           DECL_ARTIFICIAL (t) = 1;
7385           addr = TRUE;
7386           break;
7387
7388         case FFEINFO_whereGLOBAL:       /* Subroutine or function. */
7389           assert (!ffecom_transform_only_dummies_);
7390
7391           if (((g = ffesymbol_global (s)) != NULL)
7392               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7393                   || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7394                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
7395               && (ffeglobal_hook (g) != NULL_TREE)
7396               && ffe_is_globals ())
7397             {
7398               t = ffeglobal_hook (g);
7399               break;
7400             }
7401
7402           t = build_decl (FUNCTION_DECL,
7403                           ffecom_get_external_identifier_ (s),
7404                           ffecom_tree_subr_type);       /* Assume subr. */
7405           DECL_EXTERNAL (t) = 1;
7406           TREE_PUBLIC (t) = 1;
7407
7408           t = start_decl (t, FALSE);
7409           finish_decl (t, NULL_TREE, FALSE);
7410
7411           if ((g != NULL)
7412               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7413                   || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7414                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
7415             ffeglobal_set_hook (g, t);
7416
7417           ffecom_save_tree_forever (t);
7418
7419           break;
7420
7421         default:
7422           assert ("NONE where unexpected" == NULL);
7423           /* Fall through. */
7424         case FFEINFO_whereANY:
7425           break;
7426         }
7427       break;
7428
7429     case FFEINFO_kindENTITY:
7430       switch (ffeinfo_where (ffesymbol_info (s)))
7431         {
7432
7433         case FFEINFO_whereCONSTANT:
7434           /* ~~Debugging info needed? */
7435           assert (!ffecom_transform_only_dummies_);
7436           t = error_mark_node;  /* Shouldn't ever see this in expr. */
7437           break;
7438
7439         case FFEINFO_whereLOCAL:
7440           assert (!ffecom_transform_only_dummies_);
7441
7442           {
7443             ffestorag st = ffesymbol_storage (s);
7444             tree type;
7445
7446             if ((st != NULL)
7447                 && (ffestorag_size (st) == 0))
7448               {
7449                 t = error_mark_node;
7450                 break;
7451               }
7452
7453             type = ffecom_type_localvar_ (s, bt, kt);
7454
7455             if (type == error_mark_node)
7456               {
7457                 t = error_mark_node;
7458                 break;
7459               }
7460
7461             if ((st != NULL)
7462                 && (ffestorag_parent (st) != NULL))
7463               {                 /* Child of EQUIVALENCE parent. */
7464                 ffestorag est;
7465                 tree et;
7466                 ffetargetOffset offset;
7467
7468                 est = ffestorag_parent (st);
7469                 ffecom_transform_equiv_ (est);
7470
7471                 et = ffestorag_hook (est);
7472                 assert (et != NULL_TREE);
7473
7474                 if (! TREE_STATIC (et))
7475                   put_var_into_stack (et);
7476
7477                 offset = ffestorag_modulo (est)
7478                   + ffestorag_offset (ffesymbol_storage (s))
7479                   - ffestorag_offset (est);
7480
7481                 ffecom_debug_kludge_ (et, "EQUIVALENCE", s, type, offset);
7482
7483                 /* (t_type *) (((char *) &et) + offset) */
7484
7485                 t = convert (string_type_node,  /* (char *) */
7486                              ffecom_1 (ADDR_EXPR,
7487                                        build_pointer_type (TREE_TYPE (et)),
7488                                        et));
7489                 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
7490                               t,
7491                               build_int_2 (offset, 0));
7492                 t = convert (build_pointer_type (type),
7493                              t);
7494                 TREE_CONSTANT (t) = staticp (et);
7495
7496                 addr = TRUE;
7497               }
7498             else
7499               {
7500                 tree initexpr;
7501                 bool init = ffesymbol_is_init (s);
7502
7503                 t = build_decl (VAR_DECL,
7504                                 ffecom_get_identifier_ (ffesymbol_text (s)),
7505                                 type);
7506
7507                 if (init
7508                     || ffesymbol_namelisted (s)
7509 #ifdef FFECOM_sizeMAXSTACKITEM
7510                     || ((st != NULL)
7511                         && (ffestorag_size (st) > FFECOM_sizeMAXSTACKITEM))
7512 #endif
7513                     || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
7514                         && (ffecom_primary_entry_kind_
7515                             != FFEINFO_kindBLOCKDATA)
7516                         && (ffesymbol_is_save (s) || ffe_is_saveall ())))
7517                   TREE_STATIC (t) = !ffesymbol_attr (s, FFESYMBOL_attrADJUSTABLE);
7518                 else
7519                   TREE_STATIC (t) = 0;  /* No need to make static. */
7520
7521                 if (init || ffe_is_init_local_zero ())
7522                   DECL_INITIAL (t) = error_mark_node;
7523
7524                 /* Keep -Wunused from complaining about var if it
7525                    is used as sfunc arg or DATA implied-DO.  */
7526                 if (ffesymbol_attrs (s) & FFESYMBOL_attrsSFARG)
7527                   DECL_IN_SYSTEM_HEADER (t) = 1;
7528
7529                 t = start_decl (t, FALSE);
7530
7531                 if (init)
7532                   {
7533                     if (ffesymbol_init (s) != NULL)
7534                       initexpr = ffecom_expr (ffesymbol_init (s));
7535                     else
7536                       initexpr = ffecom_init_zero_ (t);
7537                   }
7538                 else if (ffe_is_init_local_zero ())
7539                   initexpr = ffecom_init_zero_ (t);
7540                 else
7541                   initexpr = NULL_TREE; /* Not ref'd if !init. */
7542
7543                 finish_decl (t, initexpr, FALSE);
7544
7545                 if (st != NULL && DECL_SIZE (t) != error_mark_node)
7546                   {
7547                     assert (TREE_CODE (DECL_SIZE_UNIT (t)) == INTEGER_CST);
7548                     assert (0 == compare_tree_int (DECL_SIZE_UNIT (t),
7549                                                    ffestorag_size (st)));
7550                   }
7551               }
7552           }
7553           break;
7554
7555         case FFEINFO_whereRESULT:
7556           assert (!ffecom_transform_only_dummies_);
7557
7558           if (bt == FFEINFO_basictypeCHARACTER)
7559             {                   /* Result is already in list of dummies, use
7560                                    it (& length). */
7561               t = ffecom_func_result_;
7562               tlen = ffecom_func_length_;
7563               addr = TRUE;
7564               break;
7565             }
7566           if ((ffecom_num_entrypoints_ == 0)
7567               && (bt == FFEINFO_basictypeCOMPLEX)
7568               && (ffesymbol_is_f2c (ffecom_primary_entry_)))
7569             {                   /* Result is already in list of dummies, use
7570                                    it. */
7571               t = ffecom_func_result_;
7572               addr = TRUE;
7573               break;
7574             }
7575           if (ffecom_func_result_ != NULL_TREE)
7576             {
7577               t = ffecom_func_result_;
7578               break;
7579             }
7580           if ((ffecom_num_entrypoints_ != 0)
7581               && (ffecom_master_bt_ == FFEINFO_basictypeNONE))
7582             {
7583               assert (ffecom_multi_retval_ != NULL_TREE);
7584               t = ffecom_1 (INDIRECT_REF, ffecom_multi_type_node_,
7585                             ffecom_multi_retval_);
7586               t = ffecom_2 (COMPONENT_REF, ffecom_tree_type[bt][kt],
7587                             t, ffecom_multi_fields_[bt][kt]);
7588
7589               break;
7590             }
7591
7592           t = build_decl (VAR_DECL,
7593                           ffecom_get_identifier_ (ffesymbol_text (s)),
7594                           ffecom_tree_type[bt][kt]);
7595           TREE_STATIC (t) = 0;  /* Put result on stack. */
7596           t = start_decl (t, FALSE);
7597           finish_decl (t, NULL_TREE, FALSE);
7598
7599           ffecom_func_result_ = t;
7600
7601           break;
7602
7603         case FFEINFO_whereDUMMY:
7604           {
7605             tree type;
7606             ffebld dl;
7607             ffebld dim;
7608             tree low;
7609             tree high;
7610             tree old_sizes;
7611             bool adjustable = FALSE;    /* Conditionally adjustable? */
7612
7613             type = ffecom_tree_type[bt][kt];
7614             if (ffesymbol_sfdummyparent (s) != NULL)
7615               {
7616                 if (current_function_decl == ffecom_outer_function_decl_)
7617                   {                     /* Exec transition before sfunc
7618                                            context; get it later. */
7619                     break;
7620                   }
7621                 t = ffecom_get_identifier_ (ffesymbol_text
7622                                             (ffesymbol_sfdummyparent (s)));
7623               }
7624             else
7625               t = ffecom_get_identifier_ (ffesymbol_text (s));
7626
7627             assert (ffecom_transform_only_dummies_);
7628
7629             old_sizes = get_pending_sizes ();
7630             put_pending_sizes (old_sizes);
7631
7632             if (bt == FFEINFO_basictypeCHARACTER)
7633               tlen = ffecom_char_enhance_arg_ (&type, s);
7634             type = ffecom_check_size_overflow_ (s, type, TRUE);
7635
7636             for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
7637               {
7638                 if (type == error_mark_node)
7639                   break;
7640
7641                 dim = ffebld_head (dl);
7642                 assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
7643                 if ((ffebld_left (dim) == NULL) || ffecom_doing_entry_)
7644                   low = ffecom_integer_one_node;
7645                 else
7646                   low = ffecom_expr (ffebld_left (dim));
7647                 assert (ffebld_right (dim) != NULL);
7648                 if ((ffebld_op (ffebld_right (dim)) == FFEBLD_opSTAR)
7649                     || ffecom_doing_entry_)
7650                   {
7651                     /* Used to just do high=low.  But for ffecom_tree_
7652                        canonize_ref_, it probably is important to correctly
7653                        assess the size.  E.g. given COMPLEX C(*),CFUNC and
7654                        C(2)=CFUNC(C), overlap can happen, while it can't
7655                        for, say, C(1)=CFUNC(C(2)).  */
7656                     /* Even more recently used to set to INT_MAX, but that
7657                        broke when some overflow checking went into the back
7658                        end.  Now we just leave the upper bound unspecified.  */
7659                     high = NULL;
7660                   }
7661                 else
7662                   high = ffecom_expr (ffebld_right (dim));
7663
7664                 /* Determine whether array is conditionally adjustable,
7665                    to decide whether back-end magic is needed.
7666
7667                    Normally the front end uses the back-end function
7668                    variable_size to wrap SAVE_EXPR's around expressions
7669                    affecting the size/shape of an array so that the
7670                    size/shape info doesn't change during execution
7671                    of the compiled code even though variables and
7672                    functions referenced in those expressions might.
7673
7674                    variable_size also makes sure those saved expressions
7675                    get evaluated immediately upon entry to the
7676                    compiled procedure -- the front end normally doesn't
7677                    have to worry about that.
7678
7679                    However, there is a problem with this that affects
7680                    g77's implementation of entry points, and that is
7681                    that it is _not_ true that each invocation of the
7682                    compiled procedure is permitted to evaluate
7683                    array size/shape info -- because it is possible
7684                    that, for some invocations, that info is invalid (in
7685                    which case it is "promised" -- i.e. a violation of
7686                    the Fortran standard -- that the compiled code
7687                    won't reference the array or its size/shape
7688                    during that particular invocation).
7689
7690                    To phrase this in C terms, consider this gcc function:
7691
7692                      void foo (int *n, float (*a)[*n])
7693                      {
7694                        // a is "pointer to array ...", fyi.
7695                      }
7696
7697                    Suppose that, for some invocations, it is permitted
7698                    for a caller of foo to do this:
7699
7700                        foo (NULL, NULL);
7701
7702                    Now the _written_ code for foo can take such a call
7703                    into account by either testing explicitly for whether
7704                    (a == NULL) || (n == NULL) -- presumably it is
7705                    not permitted to reference *a in various fashions
7706                    if (n == NULL) I suppose -- or it can avoid it by
7707                    looking at other info (other arguments, static/global
7708                    data, etc.).
7709
7710                    However, this won't work in gcc 2.5.8 because it'll
7711                    automatically emit the code to save the "*n"
7712                    expression, which'll yield a NULL dereference for
7713                    the "foo (NULL, NULL)" call, something the code
7714                    for foo cannot prevent.
7715
7716                    g77 definitely needs to avoid executing such
7717                    code anytime the pointer to the adjustable array
7718                    is NULL, because even if its bounds expressions
7719                    don't have any references to possible "absent"
7720                    variables like "*n" -- say all variable references
7721                    are to COMMON variables, i.e. global (though in C,
7722                    local static could actually make sense) -- the
7723                    expressions could yield other run-time problems
7724                    for allowably "dead" values in those variables.
7725
7726                    For example, let's consider a more complicated
7727                    version of foo:
7728
7729                      extern int i;
7730                      extern int j;
7731
7732                      void foo (float (*a)[i/j])
7733                      {
7734                        ...
7735                      }
7736
7737                    The above is (essentially) quite valid for Fortran
7738                    but, again, for a call like "foo (NULL);", it is
7739                    permitted for i and j to be undefined when the
7740                    call is made.  If j happened to be zero, for
7741                    example, emitting the code to evaluate "i/j"
7742                    could result in a run-time error.
7743
7744                    Offhand, though I don't have my F77 or F90
7745                    standards handy, it might even be valid for a
7746                    bounds expression to contain a function reference,
7747                    in which case I doubt it is permitted for an
7748                    implementation to invoke that function in the
7749                    Fortran case involved here (invocation of an
7750                    alternate ENTRY point that doesn't have the adjustable
7751                    array as one of its arguments).
7752
7753                    So, the code that the compiler would normally emit
7754                    to preevaluate the size/shape info for an
7755                    adjustable array _must not_ be executed at run time
7756                    in certain cases.  Specifically, for Fortran,
7757                    the case is when the pointer to the adjustable
7758                    array == NULL.  (For gnu-ish C, it might be nice
7759                    for the source code itself to specify an expression
7760                    that, if TRUE, inhibits execution of the code.  Or
7761                    reverse the sense for elegance.)
7762
7763                    (Note that g77 could use a different test than NULL,
7764                    actually, since it happens to always pass an
7765                    integer to the called function that specifies which
7766                    entry point is being invoked.  Hmm, this might
7767                    solve the next problem.)
7768
7769                    One way a user could, I suppose, write "foo" so
7770                    it works is to insert COND_EXPR's for the
7771                    size/shape info so the dangerous stuff isn't
7772                    actually done, as in:
7773
7774                      void foo (int *n, float (*a)[(a == NULL) ? 0 : *n])
7775                      {
7776                        ...
7777                      }
7778
7779                    The next problem is that the front end needs to
7780                    be able to tell the back end about the array's
7781                    decl _before_ it tells it about the conditional
7782                    expression to inhibit evaluation of size/shape info,
7783                    as shown above.
7784
7785                    To solve this, the front end needs to be able
7786                    to give the back end the expression to inhibit
7787                    generation of the preevaluation code _after_
7788                    it makes the decl for the adjustable array.
7789
7790                    Until then, the above example using the COND_EXPR
7791                    doesn't pass muster with gcc because the "(a == NULL)"
7792                    part has a reference to "a", which is still
7793                    undefined at that point.
7794
7795                    g77 will therefore use a different mechanism in the
7796                    meantime.  */
7797
7798                 if (!adjustable
7799                     && ((TREE_CODE (low) != INTEGER_CST)
7800                         || (high && TREE_CODE (high) != INTEGER_CST)))
7801                   adjustable = TRUE;
7802
7803 #if 0                           /* Old approach -- see below. */
7804                 if (TREE_CODE (low) != INTEGER_CST)
7805                   low = ffecom_3 (COND_EXPR, integer_type_node,
7806                                   ffecom_adjarray_passed_ (s),
7807                                   low,
7808                                   ffecom_integer_zero_node);
7809
7810                 if (high && TREE_CODE (high) != INTEGER_CST)
7811                   high = ffecom_3 (COND_EXPR, integer_type_node,
7812                                    ffecom_adjarray_passed_ (s),
7813                                    high,
7814                                    ffecom_integer_zero_node);
7815 #endif
7816
7817                 /* ~~~gcc/stor-layout.c (layout_type) should do this,
7818                    probably.  Fixes 950302-1.f.  */
7819
7820                 if (TREE_CODE (low) != INTEGER_CST)
7821                   low = variable_size (low);
7822
7823                 /* ~~~Similarly, this fixes dumb0.f.  The C front end
7824                    does this, which is why dumb0.c would work.  */
7825
7826                 if (high && TREE_CODE (high) != INTEGER_CST)
7827                   high = variable_size (high);
7828
7829                 type
7830                   = build_array_type
7831                     (type,
7832                      build_range_type (ffecom_integer_type_node,
7833                                        low, high));
7834                 type = ffecom_check_size_overflow_ (s, type, TRUE);
7835               }
7836
7837             if (type == error_mark_node)
7838               {
7839                 t = error_mark_node;
7840                 break;
7841               }
7842
7843             if ((ffesymbol_sfdummyparent (s) == NULL)
7844                  || (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER))
7845               {
7846                 type = build_pointer_type (type);
7847                 addr = TRUE;
7848               }
7849
7850             t = build_decl (PARM_DECL, t, type);
7851             DECL_ARTIFICIAL (t) = 1;
7852
7853             /* If this arg is present in every entry point's list of
7854                dummy args, then we're done.  */
7855
7856             if (ffesymbol_numentries (s)
7857                 == (ffecom_num_entrypoints_ + 1))
7858               break;
7859
7860 #if 1
7861
7862             /* If variable_size in stor-layout has been called during
7863                the above, then get_pending_sizes should have the
7864                yet-to-be-evaluated saved expressions pending.
7865                Make the whole lot of them get emitted, conditionally
7866                on whether the array decl ("t" above) is not NULL.  */
7867
7868             {
7869               tree sizes = get_pending_sizes ();
7870               tree tem;
7871
7872               for (tem = sizes;
7873                    tem != old_sizes;
7874                    tem = TREE_CHAIN (tem))
7875                 {
7876                   tree temv = TREE_VALUE (tem);
7877
7878                   if (sizes == tem)
7879                     sizes = temv;
7880                   else
7881                     sizes
7882                       = ffecom_2 (COMPOUND_EXPR,
7883                                   TREE_TYPE (sizes),
7884                                   temv,
7885                                   sizes);
7886                 }
7887
7888               if (sizes != tem)
7889                 {
7890                   sizes
7891                     = ffecom_3 (COND_EXPR,
7892                                 TREE_TYPE (sizes),
7893                                 ffecom_2 (NE_EXPR,
7894                                           integer_type_node,
7895                                           t,
7896                                           null_pointer_node),
7897                                 sizes,
7898                                 convert (TREE_TYPE (sizes),
7899                                          integer_zero_node));
7900                   sizes = ffecom_save_tree (sizes);
7901
7902                   sizes
7903                     = tree_cons (NULL_TREE, sizes, tem);
7904                 }
7905
7906               if (sizes)
7907                 put_pending_sizes (sizes);
7908             }
7909
7910 #else
7911 #if 0
7912             if (adjustable
7913                 && (ffesymbol_numentries (s)
7914                     != ffecom_num_entrypoints_ + 1))
7915               DECL_SOMETHING (t)
7916                 = ffecom_2 (NE_EXPR, integer_type_node,
7917                             t,
7918                             null_pointer_node);
7919 #else
7920 #if 0
7921             if (adjustable
7922                 && (ffesymbol_numentries (s)
7923                     != ffecom_num_entrypoints_ + 1))
7924               {
7925                 ffebad_start (FFEBAD_MISSING_ADJARRAY_UNSUPPORTED);
7926                 ffebad_here (0, ffesymbol_where_line (s),
7927                              ffesymbol_where_column (s));
7928                 ffebad_string (ffesymbol_text (s));
7929                 ffebad_finish ();
7930               }
7931 #endif
7932 #endif
7933 #endif
7934           }
7935           break;
7936
7937         case FFEINFO_whereCOMMON:
7938           {
7939             ffesymbol cs;
7940             ffeglobal cg;
7941             tree ct;
7942             ffestorag st = ffesymbol_storage (s);
7943             tree type;
7944
7945             cs = ffesymbol_common (s);  /* The COMMON area itself.  */
7946             if (st != NULL)     /* Else not laid out. */
7947               {
7948                 ffecom_transform_common_ (cs);
7949                 st = ffesymbol_storage (s);
7950               }
7951
7952             type = ffecom_type_localvar_ (s, bt, kt);
7953
7954             cg = ffesymbol_global (cs); /* The global COMMON info.  */
7955             if ((cg == NULL)
7956                 || (ffeglobal_type (cg) != FFEGLOBAL_typeCOMMON))
7957               ct = NULL_TREE;
7958             else
7959               ct = ffeglobal_hook (cg); /* The common area's tree.  */
7960
7961             if ((ct == NULL_TREE)
7962                 || (st == NULL)
7963                 || (type == error_mark_node))
7964               t = error_mark_node;
7965             else
7966               {
7967                 ffetargetOffset offset;
7968                 ffestorag cst;
7969
7970                 cst = ffestorag_parent (st);
7971                 assert (cst == ffesymbol_storage (cs));
7972
7973                 offset = ffestorag_modulo (cst)
7974                   + ffestorag_offset (st)
7975                   - ffestorag_offset (cst);
7976
7977                 ffecom_debug_kludge_ (ct, "COMMON", s, type, offset);
7978
7979                 /* (t_type *) (((char *) &ct) + offset) */
7980
7981                 t = convert (string_type_node,  /* (char *) */
7982                              ffecom_1 (ADDR_EXPR,
7983                                        build_pointer_type (TREE_TYPE (ct)),
7984                                        ct));
7985                 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
7986                               t,
7987                               build_int_2 (offset, 0));
7988                 t = convert (build_pointer_type (type),
7989                              t);
7990                 TREE_CONSTANT (t) = 1;
7991
7992                 addr = TRUE;
7993               }
7994           }
7995           break;
7996
7997         case FFEINFO_whereIMMEDIATE:
7998         case FFEINFO_whereGLOBAL:
7999         case FFEINFO_whereFLEETING:
8000         case FFEINFO_whereFLEETING_CADDR:
8001         case FFEINFO_whereFLEETING_IADDR:
8002         case FFEINFO_whereINTRINSIC:
8003         case FFEINFO_whereCONSTANT_SUBOBJECT:
8004         default:
8005           assert ("ENTITY where unheard of" == NULL);
8006           /* Fall through. */
8007         case FFEINFO_whereANY:
8008           t = error_mark_node;
8009           break;
8010         }
8011       break;
8012
8013     case FFEINFO_kindFUNCTION:
8014       switch (ffeinfo_where (ffesymbol_info (s)))
8015         {
8016         case FFEINFO_whereLOCAL:        /* Me. */
8017           assert (!ffecom_transform_only_dummies_);
8018           t = current_function_decl;
8019           break;
8020
8021         case FFEINFO_whereGLOBAL:
8022           assert (!ffecom_transform_only_dummies_);
8023
8024           if (((g = ffesymbol_global (s)) != NULL)
8025               && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8026                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8027               && (ffeglobal_hook (g) != NULL_TREE)
8028               && ffe_is_globals ())
8029             {
8030               t = ffeglobal_hook (g);
8031               break;
8032             }
8033
8034           if (ffesymbol_is_f2c (s)
8035               && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8036             t = ffecom_tree_fun_type[bt][kt];
8037           else
8038             t = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
8039
8040           t = build_decl (FUNCTION_DECL,
8041                           ffecom_get_external_identifier_ (s),
8042                           t);
8043           DECL_EXTERNAL (t) = 1;
8044           TREE_PUBLIC (t) = 1;
8045
8046           t = start_decl (t, FALSE);
8047           finish_decl (t, NULL_TREE, FALSE);
8048
8049           if ((g != NULL)
8050               && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8051                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8052             ffeglobal_set_hook (g, t);
8053
8054           ffecom_save_tree_forever (t);
8055
8056           break;
8057
8058         case FFEINFO_whereDUMMY:
8059           assert (ffecom_transform_only_dummies_);
8060
8061           if (ffesymbol_is_f2c (s)
8062               && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8063             t = ffecom_tree_ptr_to_fun_type[bt][kt];
8064           else
8065             t = build_pointer_type
8066               (build_function_type (ffecom_tree_type[bt][kt], NULL_TREE));
8067
8068           t = build_decl (PARM_DECL,
8069                           ffecom_get_identifier_ (ffesymbol_text (s)),
8070                           t);
8071           DECL_ARTIFICIAL (t) = 1;
8072           addr = TRUE;
8073           break;
8074
8075         case FFEINFO_whereCONSTANT:     /* Statement function. */
8076           assert (!ffecom_transform_only_dummies_);
8077           t = ffecom_gen_sfuncdef_ (s, bt, kt);
8078           break;
8079
8080         case FFEINFO_whereINTRINSIC:
8081           assert (!ffecom_transform_only_dummies_);
8082           break;                /* Let actual references generate their
8083                                    decls. */
8084
8085         default:
8086           assert ("FUNCTION where unheard of" == NULL);
8087           /* Fall through. */
8088         case FFEINFO_whereANY:
8089           t = error_mark_node;
8090           break;
8091         }
8092       break;
8093
8094     case FFEINFO_kindSUBROUTINE:
8095       switch (ffeinfo_where (ffesymbol_info (s)))
8096         {
8097         case FFEINFO_whereLOCAL:        /* Me. */
8098           assert (!ffecom_transform_only_dummies_);
8099           t = current_function_decl;
8100           break;
8101
8102         case FFEINFO_whereGLOBAL:
8103           assert (!ffecom_transform_only_dummies_);
8104
8105           if (((g = ffesymbol_global (s)) != NULL)
8106               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8107                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8108               && (ffeglobal_hook (g) != NULL_TREE)
8109               && ffe_is_globals ())
8110             {
8111               t = ffeglobal_hook (g);
8112               break;
8113             }
8114
8115           t = build_decl (FUNCTION_DECL,
8116                           ffecom_get_external_identifier_ (s),
8117                           ffecom_tree_subr_type);
8118           DECL_EXTERNAL (t) = 1;
8119           TREE_PUBLIC (t) = 1;
8120
8121           t = start_decl (t, FALSE);
8122           finish_decl (t, NULL_TREE, FALSE);
8123
8124           if ((g != NULL)
8125               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8126                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8127             ffeglobal_set_hook (g, t);
8128
8129           ffecom_save_tree_forever (t);
8130
8131           break;
8132
8133         case FFEINFO_whereDUMMY:
8134           assert (ffecom_transform_only_dummies_);
8135
8136           t = build_decl (PARM_DECL,
8137                           ffecom_get_identifier_ (ffesymbol_text (s)),
8138                           ffecom_tree_ptr_to_subr_type);
8139           DECL_ARTIFICIAL (t) = 1;
8140           addr = TRUE;
8141           break;
8142
8143         case FFEINFO_whereINTRINSIC:
8144           assert (!ffecom_transform_only_dummies_);
8145           break;                /* Let actual references generate their
8146                                    decls. */
8147
8148         default:
8149           assert ("SUBROUTINE where unheard of" == NULL);
8150           /* Fall through. */
8151         case FFEINFO_whereANY:
8152           t = error_mark_node;
8153           break;
8154         }
8155       break;
8156
8157     case FFEINFO_kindPROGRAM:
8158       switch (ffeinfo_where (ffesymbol_info (s)))
8159         {
8160         case FFEINFO_whereLOCAL:        /* Me. */
8161           assert (!ffecom_transform_only_dummies_);
8162           t = current_function_decl;
8163           break;
8164
8165         case FFEINFO_whereCOMMON:
8166         case FFEINFO_whereDUMMY:
8167         case FFEINFO_whereGLOBAL:
8168         case FFEINFO_whereRESULT:
8169         case FFEINFO_whereFLEETING:
8170         case FFEINFO_whereFLEETING_CADDR:
8171         case FFEINFO_whereFLEETING_IADDR:
8172         case FFEINFO_whereIMMEDIATE:
8173         case FFEINFO_whereINTRINSIC:
8174         case FFEINFO_whereCONSTANT:
8175         case FFEINFO_whereCONSTANT_SUBOBJECT:
8176         default:
8177           assert ("PROGRAM where unheard of" == NULL);
8178           /* Fall through. */
8179         case FFEINFO_whereANY:
8180           t = error_mark_node;
8181           break;
8182         }
8183       break;
8184
8185     case FFEINFO_kindBLOCKDATA:
8186       switch (ffeinfo_where (ffesymbol_info (s)))
8187         {
8188         case FFEINFO_whereLOCAL:        /* Me. */
8189           assert (!ffecom_transform_only_dummies_);
8190           t = current_function_decl;
8191           break;
8192
8193         case FFEINFO_whereGLOBAL:
8194           assert (!ffecom_transform_only_dummies_);
8195
8196           t = build_decl (FUNCTION_DECL,
8197                           ffecom_get_external_identifier_ (s),
8198                           ffecom_tree_blockdata_type);
8199           DECL_EXTERNAL (t) = 1;
8200           TREE_PUBLIC (t) = 1;
8201
8202           t = start_decl (t, FALSE);
8203           finish_decl (t, NULL_TREE, FALSE);
8204
8205           ffecom_save_tree_forever (t);
8206
8207           break;
8208
8209         case FFEINFO_whereCOMMON:
8210         case FFEINFO_whereDUMMY:
8211         case FFEINFO_whereRESULT:
8212         case FFEINFO_whereFLEETING:
8213         case FFEINFO_whereFLEETING_CADDR:
8214         case FFEINFO_whereFLEETING_IADDR:
8215         case FFEINFO_whereIMMEDIATE:
8216         case FFEINFO_whereINTRINSIC:
8217         case FFEINFO_whereCONSTANT:
8218         case FFEINFO_whereCONSTANT_SUBOBJECT:
8219         default:
8220           assert ("BLOCKDATA where unheard of" == NULL);
8221           /* Fall through. */
8222         case FFEINFO_whereANY:
8223           t = error_mark_node;
8224           break;
8225         }
8226       break;
8227
8228     case FFEINFO_kindCOMMON:
8229       switch (ffeinfo_where (ffesymbol_info (s)))
8230         {
8231         case FFEINFO_whereLOCAL:
8232           assert (!ffecom_transform_only_dummies_);
8233           ffecom_transform_common_ (s);
8234           break;
8235
8236         case FFEINFO_whereNONE:
8237         case FFEINFO_whereCOMMON:
8238         case FFEINFO_whereDUMMY:
8239         case FFEINFO_whereGLOBAL:
8240         case FFEINFO_whereRESULT:
8241         case FFEINFO_whereFLEETING:
8242         case FFEINFO_whereFLEETING_CADDR:
8243         case FFEINFO_whereFLEETING_IADDR:
8244         case FFEINFO_whereIMMEDIATE:
8245         case FFEINFO_whereINTRINSIC:
8246         case FFEINFO_whereCONSTANT:
8247         case FFEINFO_whereCONSTANT_SUBOBJECT:
8248         default:
8249           assert ("COMMON where unheard of" == NULL);
8250           /* Fall through. */
8251         case FFEINFO_whereANY:
8252           t = error_mark_node;
8253           break;
8254         }
8255       break;
8256
8257     case FFEINFO_kindCONSTRUCT:
8258       switch (ffeinfo_where (ffesymbol_info (s)))
8259         {
8260         case FFEINFO_whereLOCAL:
8261           assert (!ffecom_transform_only_dummies_);
8262           break;
8263
8264         case FFEINFO_whereNONE:
8265         case FFEINFO_whereCOMMON:
8266         case FFEINFO_whereDUMMY:
8267         case FFEINFO_whereGLOBAL:
8268         case FFEINFO_whereRESULT:
8269         case FFEINFO_whereFLEETING:
8270         case FFEINFO_whereFLEETING_CADDR:
8271         case FFEINFO_whereFLEETING_IADDR:
8272         case FFEINFO_whereIMMEDIATE:
8273         case FFEINFO_whereINTRINSIC:
8274         case FFEINFO_whereCONSTANT:
8275         case FFEINFO_whereCONSTANT_SUBOBJECT:
8276         default:
8277           assert ("CONSTRUCT where unheard of" == NULL);
8278           /* Fall through. */
8279         case FFEINFO_whereANY:
8280           t = error_mark_node;
8281           break;
8282         }
8283       break;
8284
8285     case FFEINFO_kindNAMELIST:
8286       switch (ffeinfo_where (ffesymbol_info (s)))
8287         {
8288         case FFEINFO_whereLOCAL:
8289           assert (!ffecom_transform_only_dummies_);
8290           t = ffecom_transform_namelist_ (s);
8291           break;
8292
8293         case FFEINFO_whereNONE:
8294         case FFEINFO_whereCOMMON:
8295         case FFEINFO_whereDUMMY:
8296         case FFEINFO_whereGLOBAL:
8297         case FFEINFO_whereRESULT:
8298         case FFEINFO_whereFLEETING:
8299         case FFEINFO_whereFLEETING_CADDR:
8300         case FFEINFO_whereFLEETING_IADDR:
8301         case FFEINFO_whereIMMEDIATE:
8302         case FFEINFO_whereINTRINSIC:
8303         case FFEINFO_whereCONSTANT:
8304         case FFEINFO_whereCONSTANT_SUBOBJECT:
8305         default:
8306           assert ("NAMELIST where unheard of" == NULL);
8307           /* Fall through. */
8308         case FFEINFO_whereANY:
8309           t = error_mark_node;
8310           break;
8311         }
8312       break;
8313
8314     default:
8315       assert ("kind unheard of" == NULL);
8316       /* Fall through. */
8317     case FFEINFO_kindANY:
8318       t = error_mark_node;
8319       break;
8320     }
8321
8322   ffesymbol_hook (s).decl_tree = t;
8323   ffesymbol_hook (s).length_tree = tlen;
8324   ffesymbol_hook (s).addr = addr;
8325
8326   lineno = old_lineno;
8327   input_filename = old_input_filename;
8328
8329   return s;
8330 }
8331
8332 /* Transform into ASSIGNable symbol.
8333
8334    Symbol has already been transformed, but for whatever reason, the
8335    resulting decl_tree has been deemed not usable for an ASSIGN target.
8336    (E.g. it isn't wide enough to hold a pointer.)  So, here we invent
8337    another local symbol of type void * and stuff that in the assign_tree
8338    argument.  The F77/F90 standards allow this implementation.  */
8339
8340 static ffesymbol
8341 ffecom_sym_transform_assign_ (ffesymbol s)
8342 {
8343   tree t;                       /* Transformed thingy. */
8344   int old_lineno = lineno;
8345   const char *old_input_filename = input_filename;
8346
8347   if (ffesymbol_sfdummyparent (s) == NULL)
8348     {
8349       input_filename = ffesymbol_where_filename (s);
8350       lineno = ffesymbol_where_filelinenum (s);
8351     }
8352   else
8353     {
8354       ffesymbol sf = ffesymbol_sfdummyparent (s);
8355
8356       input_filename = ffesymbol_where_filename (sf);
8357       lineno = ffesymbol_where_filelinenum (sf);
8358     }
8359
8360   assert (!ffecom_transform_only_dummies_);
8361
8362   t = build_decl (VAR_DECL,
8363                   ffecom_get_invented_identifier ("__g77_ASSIGN_%s",
8364                                                    ffesymbol_text (s)),
8365                   TREE_TYPE (null_pointer_node));
8366
8367   switch (ffesymbol_where (s))
8368     {
8369     case FFEINFO_whereLOCAL:
8370       /* Unlike for regular vars, SAVE status is easy to determine for
8371          ASSIGNed vars, since there's no initialization, there's no
8372          effective storage association (so "SAVE J" does not apply to
8373          K even given "EQUIVALENCE (J,K)"), there's no size issue
8374          to worry about, etc.  */
8375       if ((ffesymbol_is_save (s) || ffe_is_saveall ())
8376           && (ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8377           && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA))
8378         TREE_STATIC (t) = 1;    /* SAVEd in proc, make static. */
8379       else
8380         TREE_STATIC (t) = 0;    /* No need to make static. */
8381       break;
8382
8383     case FFEINFO_whereCOMMON:
8384       TREE_STATIC (t) = 1;      /* Assume COMMONs always SAVEd. */
8385       break;
8386
8387     case FFEINFO_whereDUMMY:
8388       /* Note that twinning a DUMMY means the caller won't see
8389          the ASSIGNed value.  But both F77 and F90 allow implementations
8390          to do this, i.e. disallow Fortran code that would try and
8391          take advantage of actually putting a label into a variable
8392          via a dummy argument (or any other storage association, for
8393          that matter).  */
8394       TREE_STATIC (t) = 0;
8395       break;
8396
8397     default:
8398       TREE_STATIC (t) = 0;
8399       break;
8400     }
8401
8402   t = start_decl (t, FALSE);
8403   finish_decl (t, NULL_TREE, FALSE);
8404
8405   ffesymbol_hook (s).assign_tree = t;
8406
8407   lineno = old_lineno;
8408   input_filename = old_input_filename;
8409
8410   return s;
8411 }
8412
8413 /* Implement COMMON area in back end.
8414
8415    Because COMMON-based variables can be referenced in the dimension
8416    expressions of dummy (adjustable) arrays, and because dummies
8417    (in the gcc back end) need to be put in the outer binding level
8418    of a function (which has two binding levels, the outer holding
8419    the dummies and the inner holding the other vars), special care
8420    must be taken to handle COMMON areas.
8421
8422    The current strategy is basically to always tell the back end about
8423    the COMMON area as a top-level external reference to just a block
8424    of storage of the master type of that area (e.g. integer, real,
8425    character, whatever -- not a structure).  As a distinct action,
8426    if initial values are provided, tell the back end about the area
8427    as a top-level non-external (initialized) area and remember not to
8428    allow further initialization or expansion of the area.  Meanwhile,
8429    if no initialization happens at all, tell the back end about
8430    the largest size we've seen declared so the space does get reserved.
8431    (This function doesn't handle all that stuff, but it does some
8432    of the important things.)
8433
8434    Meanwhile, for COMMON variables themselves, just keep creating
8435    references like *((float *) (&common_area + offset)) each time
8436    we reference the variable.  In other words, don't make a VAR_DECL
8437    or any kind of component reference (like we used to do before 0.4),
8438    though we might do that as well just for debugging purposes (and
8439    stuff the rtl with the appropriate offset expression).  */
8440
8441 static void
8442 ffecom_transform_common_ (ffesymbol s)
8443 {
8444   ffestorag st = ffesymbol_storage (s);
8445   ffeglobal g = ffesymbol_global (s);
8446   tree cbt;
8447   tree cbtype;
8448   tree init;
8449   tree high;
8450   bool is_init = ffestorag_is_init (st);
8451
8452   assert (st != NULL);
8453
8454   if ((g == NULL)
8455       || (ffeglobal_type (g) != FFEGLOBAL_typeCOMMON))
8456     return;
8457
8458   /* First update the size of the area in global terms.  */
8459
8460   ffeglobal_size_common (s, ffestorag_size (st));
8461
8462   if (!ffeglobal_common_init (g))
8463     is_init = FALSE;    /* No explicit init, don't let erroneous joins init. */
8464
8465   cbt = ffeglobal_hook (g);
8466
8467   /* If we already have declared this common block for a previous program
8468      unit, and either we already initialized it or we don't have new
8469      initialization for it, just return what we have without changing it.  */
8470
8471   if ((cbt != NULL_TREE)
8472       && (!is_init
8473           || !DECL_EXTERNAL (cbt)))
8474     {
8475       if (st->hook == NULL) ffestorag_set_hook (st, cbt);
8476       return;
8477     }
8478
8479   /* Process inits.  */
8480
8481   if (is_init)
8482     {
8483       if (ffestorag_init (st) != NULL)
8484         {
8485           ffebld sexp;
8486
8487           /* Set the padding for the expression, so ffecom_expr
8488              knows to insert that many zeros.  */
8489           switch (ffebld_op (sexp = ffestorag_init (st)))
8490             {
8491             case FFEBLD_opCONTER:
8492               ffebld_conter_set_pad (sexp, ffestorag_modulo (st));
8493               break;
8494
8495             case FFEBLD_opARRTER:
8496               ffebld_arrter_set_pad (sexp, ffestorag_modulo (st));
8497               break;
8498
8499             case FFEBLD_opACCTER:
8500               ffebld_accter_set_pad (sexp, ffestorag_modulo (st));
8501               break;
8502
8503             default:
8504               assert ("bad op for cmn init (pad)" == NULL);
8505               break;
8506             }
8507
8508           init = ffecom_expr (sexp);
8509           if (init == error_mark_node)
8510             {                   /* Hopefully the back end complained! */
8511               init = NULL_TREE;
8512               if (cbt != NULL_TREE)
8513                 return;
8514             }
8515         }
8516       else
8517         init = error_mark_node;
8518     }
8519   else
8520     init = NULL_TREE;
8521
8522   /* cbtype must be permanently allocated!  */
8523
8524   /* Allocate the MAX of the areas so far, seen filewide.  */
8525   high = build_int_2 ((ffeglobal_common_size (g)
8526                        + ffeglobal_common_pad (g)) - 1, 0);
8527   TREE_TYPE (high) = ffecom_integer_type_node;
8528
8529   if (init)
8530     cbtype = build_array_type (char_type_node,
8531                                build_range_type (integer_type_node,
8532                                                  integer_zero_node,
8533                                                  high));
8534   else
8535     cbtype = build_array_type (char_type_node, NULL_TREE);
8536
8537   if (cbt == NULL_TREE)
8538     {
8539       cbt
8540         = build_decl (VAR_DECL,
8541                       ffecom_get_external_identifier_ (s),
8542                       cbtype);
8543       TREE_STATIC (cbt) = 1;
8544       TREE_PUBLIC (cbt) = 1;
8545     }
8546   else
8547     {
8548       assert (is_init);
8549       TREE_TYPE (cbt) = cbtype;
8550     }
8551   DECL_EXTERNAL (cbt) = init ? 0 : 1;
8552   DECL_INITIAL (cbt) = init ? error_mark_node : NULL_TREE;
8553
8554   cbt = start_decl (cbt, TRUE);
8555   if (ffeglobal_hook (g) != NULL)
8556     assert (cbt == ffeglobal_hook (g));
8557
8558   assert (!init || !DECL_EXTERNAL (cbt));
8559
8560   /* Make sure that any type can live in COMMON and be referenced
8561      without getting a bus error.  We could pick the most restrictive
8562      alignment of all entities actually placed in the COMMON, but
8563      this seems easy enough.  */
8564
8565   DECL_ALIGN (cbt) = BIGGEST_ALIGNMENT;
8566   DECL_USER_ALIGN (cbt) = 0;
8567
8568   if (is_init && (ffestorag_init (st) == NULL))
8569     init = ffecom_init_zero_ (cbt);
8570
8571   finish_decl (cbt, init, TRUE);
8572
8573   if (is_init)
8574     ffestorag_set_init (st, ffebld_new_any ());
8575
8576   if (init)
8577     {
8578       assert (DECL_SIZE_UNIT (cbt) != NULL_TREE);
8579       assert (TREE_CODE (DECL_SIZE_UNIT (cbt)) == INTEGER_CST);
8580       assert (0 == compare_tree_int (DECL_SIZE_UNIT (cbt),
8581                                      (ffeglobal_common_size (g)
8582                                       + ffeglobal_common_pad (g))));
8583     }
8584
8585   ffeglobal_set_hook (g, cbt);
8586
8587   ffestorag_set_hook (st, cbt);
8588
8589   ffecom_save_tree_forever (cbt);
8590 }
8591
8592 /* Make master area for local EQUIVALENCE.  */
8593
8594 static void
8595 ffecom_transform_equiv_ (ffestorag eqst)
8596 {
8597   tree eqt;
8598   tree eqtype;
8599   tree init;
8600   tree high;
8601   bool is_init = ffestorag_is_init (eqst);
8602
8603   assert (eqst != NULL);
8604
8605   eqt = ffestorag_hook (eqst);
8606
8607   if (eqt != NULL_TREE)
8608     return;
8609
8610   /* Process inits.  */
8611
8612   if (is_init)
8613     {
8614       if (ffestorag_init (eqst) != NULL)
8615         {
8616           ffebld sexp;
8617
8618           /* Set the padding for the expression, so ffecom_expr
8619              knows to insert that many zeros.  */
8620           switch (ffebld_op (sexp = ffestorag_init (eqst)))
8621             {
8622             case FFEBLD_opCONTER:
8623               ffebld_conter_set_pad (sexp, ffestorag_modulo (eqst));
8624               break;
8625
8626             case FFEBLD_opARRTER:
8627               ffebld_arrter_set_pad (sexp, ffestorag_modulo (eqst));
8628               break;
8629
8630             case FFEBLD_opACCTER:
8631               ffebld_accter_set_pad (sexp, ffestorag_modulo (eqst));
8632               break;
8633
8634             default:
8635               assert ("bad op for eqv init (pad)" == NULL);
8636               break;
8637             }
8638
8639           init = ffecom_expr (sexp);
8640           if (init == error_mark_node)
8641             init = NULL_TREE;   /* Hopefully the back end complained! */
8642         }
8643       else
8644         init = error_mark_node;
8645     }
8646   else if (ffe_is_init_local_zero ())
8647     init = error_mark_node;
8648   else
8649     init = NULL_TREE;
8650
8651   ffecom_member_namelisted_ = FALSE;
8652   ffestorag_drive (ffestorag_list_equivs (eqst),
8653                    &ffecom_member_phase1_,
8654                    eqst);
8655
8656   high = build_int_2 ((ffestorag_size (eqst)
8657                        + ffestorag_modulo (eqst)) - 1, 0);
8658   TREE_TYPE (high) = ffecom_integer_type_node;
8659
8660   eqtype = build_array_type (char_type_node,
8661                              build_range_type (ffecom_integer_type_node,
8662                                                ffecom_integer_zero_node,
8663                                                high));
8664
8665   eqt = build_decl (VAR_DECL,
8666                     ffecom_get_invented_identifier ("__g77_equiv_%s",
8667                                                     ffesymbol_text
8668                                                     (ffestorag_symbol (eqst))),
8669                     eqtype);
8670   DECL_EXTERNAL (eqt) = 0;
8671   if (is_init
8672       || ffecom_member_namelisted_
8673 #ifdef FFECOM_sizeMAXSTACKITEM
8674       || (ffestorag_size (eqst) > FFECOM_sizeMAXSTACKITEM)
8675 #endif
8676       || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8677           && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
8678           && (ffestorag_is_save (eqst) || ffe_is_saveall ())))
8679     TREE_STATIC (eqt) = 1;
8680   else
8681     TREE_STATIC (eqt) = 0;
8682   TREE_PUBLIC (eqt) = 0;
8683   TREE_ADDRESSABLE (eqt) = 1;  /* Ensure non-register allocation */
8684   DECL_CONTEXT (eqt) = current_function_decl;
8685   if (init)
8686     DECL_INITIAL (eqt) = error_mark_node;
8687   else
8688     DECL_INITIAL (eqt) = NULL_TREE;
8689
8690   eqt = start_decl (eqt, FALSE);
8691
8692   /* Make sure that any type can live in EQUIVALENCE and be referenced
8693      without getting a bus error.  We could pick the most restrictive
8694      alignment of all entities actually placed in the EQUIVALENCE, but
8695      this seems easy enough.  */
8696
8697   DECL_ALIGN (eqt) = BIGGEST_ALIGNMENT;
8698   DECL_USER_ALIGN (eqt) = 0;
8699
8700   if ((!is_init && ffe_is_init_local_zero ())
8701       || (is_init && (ffestorag_init (eqst) == NULL)))
8702     init = ffecom_init_zero_ (eqt);
8703
8704   finish_decl (eqt, init, FALSE);
8705
8706   if (is_init)
8707     ffestorag_set_init (eqst, ffebld_new_any ());
8708
8709   {
8710     assert (TREE_CODE (DECL_SIZE_UNIT (eqt)) == INTEGER_CST);
8711     assert (0 == compare_tree_int (DECL_SIZE_UNIT (eqt),
8712                                    (ffestorag_size (eqst)
8713                                     + ffestorag_modulo (eqst))));
8714   }
8715
8716   ffestorag_set_hook (eqst, eqt);
8717
8718   ffestorag_drive (ffestorag_list_equivs (eqst),
8719                    &ffecom_member_phase2_,
8720                    eqst);
8721 }
8722
8723 /* Implement NAMELIST in back end.  See f2c/format.c for more info.  */
8724
8725 static tree
8726 ffecom_transform_namelist_ (ffesymbol s)
8727 {
8728   tree nmlt;
8729   tree nmltype = ffecom_type_namelist_ ();
8730   tree nmlinits;
8731   tree nameinit;
8732   tree varsinit;
8733   tree nvarsinit;
8734   tree field;
8735   tree high;
8736   int i;
8737   static int mynumber = 0;
8738
8739   nmlt = build_decl (VAR_DECL,
8740                      ffecom_get_invented_identifier ("__g77_namelist_%d",
8741                                                      mynumber++),
8742                      nmltype);
8743   TREE_STATIC (nmlt) = 1;
8744   DECL_INITIAL (nmlt) = error_mark_node;
8745
8746   nmlt = start_decl (nmlt, FALSE);
8747
8748   /* Process inits.  */
8749
8750   i = strlen (ffesymbol_text (s));
8751
8752   high = build_int_2 (i, 0);
8753   TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
8754
8755   nameinit = ffecom_build_f2c_string_ (i + 1,
8756                                        ffesymbol_text (s));
8757   TREE_TYPE (nameinit)
8758     = build_type_variant
8759     (build_array_type
8760      (char_type_node,
8761       build_range_type (ffecom_f2c_ftnlen_type_node,
8762                         ffecom_f2c_ftnlen_one_node,
8763                         high)),
8764      1, 0);
8765   TREE_CONSTANT (nameinit) = 1;
8766   TREE_STATIC (nameinit) = 1;
8767   nameinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (nameinit)),
8768                        nameinit);
8769
8770   varsinit = ffecom_vardesc_array_ (s);
8771   varsinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (varsinit)),
8772                        varsinit);
8773   TREE_CONSTANT (varsinit) = 1;
8774   TREE_STATIC (varsinit) = 1;
8775
8776   {
8777     ffebld b;
8778
8779     for (i = 0, b = ffesymbol_namelist (s); b != NULL; b = ffebld_trail (b))
8780       ++i;
8781   }
8782   nvarsinit = build_int_2 (i, 0);
8783   TREE_TYPE (nvarsinit) = integer_type_node;
8784   TREE_CONSTANT (nvarsinit) = 1;
8785   TREE_STATIC (nvarsinit) = 1;
8786
8787   nmlinits = build_tree_list ((field = TYPE_FIELDS (nmltype)), nameinit);
8788   TREE_CHAIN (nmlinits) = build_tree_list ((field = TREE_CHAIN (field)),
8789                                            varsinit);
8790   TREE_CHAIN (TREE_CHAIN (nmlinits))
8791     = build_tree_list ((field = TREE_CHAIN (field)), nvarsinit);
8792
8793   nmlinits = build (CONSTRUCTOR, nmltype, NULL_TREE, nmlinits);
8794   TREE_CONSTANT (nmlinits) = 1;
8795   TREE_STATIC (nmlinits) = 1;
8796
8797   finish_decl (nmlt, nmlinits, FALSE);
8798
8799   nmlt = ffecom_1 (ADDR_EXPR, build_pointer_type (nmltype), nmlt);
8800
8801   return nmlt;
8802 }
8803
8804 /* A subroutine of ffecom_tree_canonize_ref_.  The incoming tree is
8805    analyzed on the assumption it is calculating a pointer to be
8806    indirected through.  It must return the proper decl and offset,
8807    taking into account different units of measurements for offsets.  */
8808
8809 static void
8810 ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
8811                            tree t)
8812 {
8813   switch (TREE_CODE (t))
8814     {
8815     case NOP_EXPR:
8816     case CONVERT_EXPR:
8817     case NON_LVALUE_EXPR:
8818       ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
8819       break;
8820
8821     case PLUS_EXPR:
8822       ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
8823       if ((*decl == NULL_TREE)
8824           || (*decl == error_mark_node))
8825         break;
8826
8827       if (TREE_CODE (TREE_OPERAND (t, 1)) == INTEGER_CST)
8828         {
8829           /* An offset into COMMON.  */
8830           *offset = fold (build (PLUS_EXPR, TREE_TYPE (*offset),
8831                                  *offset, TREE_OPERAND (t, 1)));
8832           /* Convert offset (presumably in bytes) into canonical units
8833              (presumably bits).  */
8834           *offset = size_binop (MULT_EXPR,
8835                                 convert (bitsizetype, *offset),
8836                                 TYPE_SIZE (TREE_TYPE (TREE_TYPE (t))));
8837           break;
8838         }
8839       /* Not a COMMON reference, so an unrecognized pattern.  */
8840       *decl = error_mark_node;
8841       break;
8842
8843     case PARM_DECL:
8844       *decl = t;
8845       *offset = bitsize_zero_node;
8846       break;
8847
8848     case ADDR_EXPR:
8849       if (TREE_CODE (TREE_OPERAND (t, 0)) == VAR_DECL)
8850         {
8851           /* A reference to COMMON.  */
8852           *decl = TREE_OPERAND (t, 0);
8853           *offset = bitsize_zero_node;
8854           break;
8855         }
8856       /* Fall through.  */
8857     default:
8858       /* Not a COMMON reference, so an unrecognized pattern.  */
8859       *decl = error_mark_node;
8860       break;
8861     }
8862 }
8863
8864 /* Given a tree that is possibly intended for use as an lvalue, return
8865    information representing a canonical view of that tree as a decl, an
8866    offset into that decl, and a size for the lvalue.
8867
8868    If there's no applicable decl, NULL_TREE is returned for the decl,
8869    and the other fields are left undefined.
8870
8871    If the tree doesn't fit the recognizable forms, an ERROR_MARK node
8872    is returned for the decl, and the other fields are left undefined.
8873
8874    Otherwise, the decl returned currently is either a VAR_DECL or a
8875    PARM_DECL.
8876
8877    The offset returned is always valid, but of course not necessarily
8878    a constant, and not necessarily converted into the appropriate
8879    type, leaving that up to the caller (so as to avoid that overhead
8880    if the decls being looked at are different anyway).
8881
8882    If the size cannot be determined (e.g. an adjustable array),
8883    an ERROR_MARK node is returned for the size.  Otherwise, the
8884    size returned is valid, not necessarily a constant, and not
8885    necessarily converted into the appropriate type as with the
8886    offset.
8887
8888    Note that the offset and size expressions are expressed in the
8889    base storage units (usually bits) rather than in the units of
8890    the type of the decl, because two decls with different types
8891    might overlap but with apparently non-overlapping array offsets,
8892    whereas converting the array offsets to consistant offsets will
8893    reveal the overlap.  */
8894
8895 static void
8896 ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
8897                            tree *size, tree t)
8898 {
8899   /* The default path is to report a nonexistant decl.  */
8900   *decl = NULL_TREE;
8901
8902   if (t == NULL_TREE)
8903     return;
8904
8905   switch (TREE_CODE (t))
8906     {
8907     case ERROR_MARK:
8908     case IDENTIFIER_NODE:
8909     case INTEGER_CST:
8910     case REAL_CST:
8911     case COMPLEX_CST:
8912     case STRING_CST:
8913     case CONST_DECL:
8914     case PLUS_EXPR:
8915     case MINUS_EXPR:
8916     case MULT_EXPR:
8917     case TRUNC_DIV_EXPR:
8918     case CEIL_DIV_EXPR:
8919     case FLOOR_DIV_EXPR:
8920     case ROUND_DIV_EXPR:
8921     case TRUNC_MOD_EXPR:
8922     case CEIL_MOD_EXPR:
8923     case FLOOR_MOD_EXPR:
8924     case ROUND_MOD_EXPR:
8925     case RDIV_EXPR:
8926     case EXACT_DIV_EXPR:
8927     case FIX_TRUNC_EXPR:
8928     case FIX_CEIL_EXPR:
8929     case FIX_FLOOR_EXPR:
8930     case FIX_ROUND_EXPR:
8931     case FLOAT_EXPR:
8932     case NEGATE_EXPR:
8933     case MIN_EXPR:
8934     case MAX_EXPR:
8935     case ABS_EXPR:
8936     case FFS_EXPR:
8937     case LSHIFT_EXPR:
8938     case RSHIFT_EXPR:
8939     case LROTATE_EXPR:
8940     case RROTATE_EXPR:
8941     case BIT_IOR_EXPR:
8942     case BIT_XOR_EXPR:
8943     case BIT_AND_EXPR:
8944     case BIT_ANDTC_EXPR:
8945     case BIT_NOT_EXPR:
8946     case TRUTH_ANDIF_EXPR:
8947     case TRUTH_ORIF_EXPR:
8948     case TRUTH_AND_EXPR:
8949     case TRUTH_OR_EXPR:
8950     case TRUTH_XOR_EXPR:
8951     case TRUTH_NOT_EXPR:
8952     case LT_EXPR:
8953     case LE_EXPR:
8954     case GT_EXPR:
8955     case GE_EXPR:
8956     case EQ_EXPR:
8957     case NE_EXPR:
8958     case COMPLEX_EXPR:
8959     case CONJ_EXPR:
8960     case REALPART_EXPR:
8961     case IMAGPART_EXPR:
8962     case LABEL_EXPR:
8963     case COMPONENT_REF:
8964     case COMPOUND_EXPR:
8965     case ADDR_EXPR:
8966       return;
8967
8968     case VAR_DECL:
8969     case PARM_DECL:
8970       *decl = t;
8971       *offset = bitsize_zero_node;
8972       *size = TYPE_SIZE (TREE_TYPE (t));
8973       return;
8974
8975     case ARRAY_REF:
8976       {
8977         tree array = TREE_OPERAND (t, 0);
8978         tree element = TREE_OPERAND (t, 1);
8979         tree init_offset;
8980
8981         if ((array == NULL_TREE)
8982             || (element == NULL_TREE))
8983           {
8984             *decl = error_mark_node;
8985             return;
8986           }
8987
8988         ffecom_tree_canonize_ref_ (decl, &init_offset, size,
8989                                    array);
8990         if ((*decl == NULL_TREE)
8991             || (*decl == error_mark_node))
8992           return;
8993
8994         /* Calculate ((element - base) * NBBY) + init_offset.  */
8995         *offset = fold (build (MINUS_EXPR, TREE_TYPE (element),
8996                                element,
8997                                TYPE_MIN_VALUE (TYPE_DOMAIN
8998                                                (TREE_TYPE (array)))));
8999
9000         *offset = size_binop (MULT_EXPR,
9001                               convert (bitsizetype, *offset),
9002                               TYPE_SIZE (TREE_TYPE (TREE_TYPE (array))));
9003
9004         *offset = size_binop (PLUS_EXPR, init_offset, *offset);
9005
9006         *size = TYPE_SIZE (TREE_TYPE (t));
9007         return;
9008       }
9009
9010     case INDIRECT_REF:
9011
9012       /* Most of this code is to handle references to COMMON.  And so
9013          far that is useful only for calling library functions, since
9014          external (user) functions might reference common areas.  But
9015          even calling an external function, it's worthwhile to decode
9016          COMMON references because if not storing into COMMON, we don't
9017          want COMMON-based arguments to gratuitously force use of a
9018          temporary.  */
9019
9020       *size = TYPE_SIZE (TREE_TYPE (t));
9021
9022       ffecom_tree_canonize_ptr_ (decl, offset,
9023                                  TREE_OPERAND (t, 0));
9024
9025       return;
9026
9027     case CONVERT_EXPR:
9028     case NOP_EXPR:
9029     case MODIFY_EXPR:
9030     case NON_LVALUE_EXPR:
9031     case RESULT_DECL:
9032     case FIELD_DECL:
9033     case COND_EXPR:             /* More cases than we can handle. */
9034     case SAVE_EXPR:
9035     case REFERENCE_EXPR:
9036     case PREDECREMENT_EXPR:
9037     case PREINCREMENT_EXPR:
9038     case POSTDECREMENT_EXPR:
9039     case POSTINCREMENT_EXPR:
9040     case CALL_EXPR:
9041     default:
9042       *decl = error_mark_node;
9043       return;
9044     }
9045 }
9046
9047 /* Do divide operation appropriate to type of operands.  */
9048
9049 static tree
9050 ffecom_tree_divide_ (tree tree_type, tree left, tree right,
9051                      tree dest_tree, ffebld dest, bool *dest_used,
9052                      tree hook)
9053 {
9054   if ((left == error_mark_node)
9055       || (right == error_mark_node))
9056     return error_mark_node;
9057
9058   switch (TREE_CODE (tree_type))
9059     {
9060     case INTEGER_TYPE:
9061       return ffecom_2 (TRUNC_DIV_EXPR, tree_type,
9062                        left,
9063                        right);
9064
9065     case COMPLEX_TYPE:
9066       if (! optimize_size)
9067         return ffecom_2 (RDIV_EXPR, tree_type,
9068                          left,
9069                          right);
9070       {
9071         ffecomGfrt ix;
9072
9073         if (TREE_TYPE (tree_type)
9074             == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9075           ix = FFECOM_gfrtDIV_CC;       /* Overlapping result okay. */
9076         else
9077           ix = FFECOM_gfrtDIV_ZZ;       /* Overlapping result okay. */
9078
9079         left = ffecom_1 (ADDR_EXPR,
9080                          build_pointer_type (TREE_TYPE (left)),
9081                          left);
9082         left = build_tree_list (NULL_TREE, left);
9083         right = ffecom_1 (ADDR_EXPR,
9084                           build_pointer_type (TREE_TYPE (right)),
9085                           right);
9086         right = build_tree_list (NULL_TREE, right);
9087         TREE_CHAIN (left) = right;
9088
9089         return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9090                              ffecom_gfrt_kindtype (ix),
9091                              ffe_is_f2c_library (),
9092                              tree_type,
9093                              left,
9094                              dest_tree, dest, dest_used,
9095                              NULL_TREE, TRUE, hook);
9096       }
9097       break;
9098
9099     case RECORD_TYPE:
9100       {
9101         ffecomGfrt ix;
9102
9103         if (TREE_TYPE (TYPE_FIELDS (tree_type))
9104             == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9105           ix = FFECOM_gfrtDIV_CC;       /* Overlapping result okay. */
9106         else
9107           ix = FFECOM_gfrtDIV_ZZ;       /* Overlapping result okay. */
9108
9109         left = ffecom_1 (ADDR_EXPR,
9110                          build_pointer_type (TREE_TYPE (left)),
9111                          left);
9112         left = build_tree_list (NULL_TREE, left);
9113         right = ffecom_1 (ADDR_EXPR,
9114                           build_pointer_type (TREE_TYPE (right)),
9115                           right);
9116         right = build_tree_list (NULL_TREE, right);
9117         TREE_CHAIN (left) = right;
9118
9119         return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9120                              ffecom_gfrt_kindtype (ix),
9121                              ffe_is_f2c_library (),
9122                              tree_type,
9123                              left,
9124                              dest_tree, dest, dest_used,
9125                              NULL_TREE, TRUE, hook);
9126       }
9127       break;
9128
9129     default:
9130       return ffecom_2 (RDIV_EXPR, tree_type,
9131                        left,
9132                        right);
9133     }
9134 }
9135
9136 /* Build type info for non-dummy variable.  */
9137
9138 static tree
9139 ffecom_type_localvar_ (ffesymbol s, ffeinfoBasictype bt,
9140                        ffeinfoKindtype kt)
9141 {
9142   tree type;
9143   ffebld dl;
9144   ffebld dim;
9145   tree lowt;
9146   tree hight;
9147
9148   type = ffecom_tree_type[bt][kt];
9149   if (bt == FFEINFO_basictypeCHARACTER)
9150     {
9151       hight = build_int_2 (ffesymbol_size (s), 0);
9152       TREE_TYPE (hight) = ffecom_f2c_ftnlen_type_node;
9153
9154       type
9155         = build_array_type
9156           (type,
9157            build_range_type (ffecom_f2c_ftnlen_type_node,
9158                              ffecom_f2c_ftnlen_one_node,
9159                              hight));
9160       type = ffecom_check_size_overflow_ (s, type, FALSE);
9161     }
9162
9163   for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
9164     {
9165       if (type == error_mark_node)
9166         break;
9167
9168       dim = ffebld_head (dl);
9169       assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
9170
9171       if (ffebld_left (dim) == NULL)
9172         lowt = integer_one_node;
9173       else
9174         lowt = ffecom_expr (ffebld_left (dim));
9175
9176       if (TREE_CODE (lowt) != INTEGER_CST)
9177         lowt = variable_size (lowt);
9178
9179       assert (ffebld_right (dim) != NULL);
9180       hight = ffecom_expr (ffebld_right (dim));
9181
9182       if (TREE_CODE (hight) != INTEGER_CST)
9183         hight = variable_size (hight);
9184
9185       type = build_array_type (type,
9186                                build_range_type (ffecom_integer_type_node,
9187                                                  lowt, hight));
9188       type = ffecom_check_size_overflow_ (s, type, FALSE);
9189     }
9190
9191   return type;
9192 }
9193
9194 /* Build Namelist type.  */
9195
9196 static tree
9197 ffecom_type_namelist_ ()
9198 {
9199   static tree type = NULL_TREE;
9200
9201   if (type == NULL_TREE)
9202     {
9203       static tree namefield, varsfield, nvarsfield;
9204       tree vardesctype;
9205
9206       vardesctype = ffecom_type_vardesc_ ();
9207
9208       type = make_node (RECORD_TYPE);
9209
9210       vardesctype = build_pointer_type (build_pointer_type (vardesctype));
9211
9212       namefield = ffecom_decl_field (type, NULL_TREE, "name",
9213                                      string_type_node);
9214       varsfield = ffecom_decl_field (type, namefield, "vars", vardesctype);
9215       nvarsfield = ffecom_decl_field (type, varsfield, "nvars",
9216                                       integer_type_node);
9217
9218       TYPE_FIELDS (type) = namefield;
9219       layout_type (type);
9220
9221       ggc_add_tree_root (&type, 1);
9222     }
9223
9224   return type;
9225 }
9226
9227 /* Build Vardesc type.  */
9228
9229 static tree
9230 ffecom_type_vardesc_ ()
9231 {
9232   static tree type = NULL_TREE;
9233   static tree namefield, addrfield, dimsfield, typefield;
9234
9235   if (type == NULL_TREE)
9236     {
9237       type = make_node (RECORD_TYPE);
9238
9239       namefield = ffecom_decl_field (type, NULL_TREE, "name",
9240                                      string_type_node);
9241       addrfield = ffecom_decl_field (type, namefield, "addr",
9242                                      string_type_node);
9243       dimsfield = ffecom_decl_field (type, addrfield, "dims",
9244                                      ffecom_f2c_ptr_to_ftnlen_type_node);
9245       typefield = ffecom_decl_field (type, dimsfield, "type",
9246                                      integer_type_node);
9247
9248       TYPE_FIELDS (type) = namefield;
9249       layout_type (type);
9250
9251       ggc_add_tree_root (&type, 1);
9252     }
9253
9254   return type;
9255 }
9256
9257 static tree
9258 ffecom_vardesc_ (ffebld expr)
9259 {
9260   ffesymbol s;
9261
9262   assert (ffebld_op (expr) == FFEBLD_opSYMTER);
9263   s = ffebld_symter (expr);
9264
9265   if (ffesymbol_hook (s).vardesc_tree == NULL_TREE)
9266     {
9267       int i;
9268       tree vardesctype = ffecom_type_vardesc_ ();
9269       tree var;
9270       tree nameinit;
9271       tree dimsinit;
9272       tree addrinit;
9273       tree typeinit;
9274       tree field;
9275       tree varinits;
9276       static int mynumber = 0;
9277
9278       var = build_decl (VAR_DECL,
9279                         ffecom_get_invented_identifier ("__g77_vardesc_%d",
9280                                                         mynumber++),
9281                         vardesctype);
9282       TREE_STATIC (var) = 1;
9283       DECL_INITIAL (var) = error_mark_node;
9284
9285       var = start_decl (var, FALSE);
9286
9287       /* Process inits.  */
9288
9289       nameinit = ffecom_build_f2c_string_ ((i = strlen (ffesymbol_text (s)))
9290                                            + 1,
9291                                            ffesymbol_text (s));
9292       TREE_TYPE (nameinit)
9293         = build_type_variant
9294         (build_array_type
9295          (char_type_node,
9296           build_range_type (integer_type_node,
9297                             integer_one_node,
9298                             build_int_2 (i, 0))),
9299          1, 0);
9300       TREE_CONSTANT (nameinit) = 1;
9301       TREE_STATIC (nameinit) = 1;
9302       nameinit = ffecom_1 (ADDR_EXPR,
9303                            build_pointer_type (TREE_TYPE (nameinit)),
9304                            nameinit);
9305
9306       addrinit = ffecom_arg_ptr_to_expr (expr, &typeinit);
9307
9308       dimsinit = ffecom_vardesc_dims_ (s);
9309
9310       if (typeinit == NULL_TREE)
9311         {
9312           ffeinfoBasictype bt = ffesymbol_basictype (s);
9313           ffeinfoKindtype kt = ffesymbol_kindtype (s);
9314           int tc = ffecom_f2c_typecode (bt, kt);
9315
9316           assert (tc != -1);
9317           typeinit = build_int_2 (tc, (tc < 0) ? -1 : 0);
9318         }
9319       else
9320         typeinit = ffecom_1 (NEGATE_EXPR, TREE_TYPE (typeinit), typeinit);
9321
9322       varinits = build_tree_list ((field = TYPE_FIELDS (vardesctype)),
9323                                   nameinit);
9324       TREE_CHAIN (varinits) = build_tree_list ((field = TREE_CHAIN (field)),
9325                                                addrinit);
9326       TREE_CHAIN (TREE_CHAIN (varinits))
9327         = build_tree_list ((field = TREE_CHAIN (field)), dimsinit);
9328       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (varinits)))
9329         = build_tree_list ((field = TREE_CHAIN (field)), typeinit);
9330
9331       varinits = build (CONSTRUCTOR, vardesctype, NULL_TREE, varinits);
9332       TREE_CONSTANT (varinits) = 1;
9333       TREE_STATIC (varinits) = 1;
9334
9335       finish_decl (var, varinits, FALSE);
9336
9337       var = ffecom_1 (ADDR_EXPR, build_pointer_type (vardesctype), var);
9338
9339       ffesymbol_hook (s).vardesc_tree = var;
9340     }
9341
9342   return ffesymbol_hook (s).vardesc_tree;
9343 }
9344
9345 static tree
9346 ffecom_vardesc_array_ (ffesymbol s)
9347 {
9348   ffebld b;
9349   tree list;
9350   tree item = NULL_TREE;
9351   tree var;
9352   int i;
9353   static int mynumber = 0;
9354
9355   for (i = 0, list = NULL_TREE, b = ffesymbol_namelist (s);
9356        b != NULL;
9357        b = ffebld_trail (b), ++i)
9358     {
9359       tree t;
9360
9361       t = ffecom_vardesc_ (ffebld_head (b));
9362
9363       if (list == NULL_TREE)
9364         list = item = build_tree_list (NULL_TREE, t);
9365       else
9366         {
9367           TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9368           item = TREE_CHAIN (item);
9369         }
9370     }
9371
9372   item = build_array_type (build_pointer_type (ffecom_type_vardesc_ ()),
9373                            build_range_type (integer_type_node,
9374                                              integer_one_node,
9375                                              build_int_2 (i, 0)));
9376   list = build (CONSTRUCTOR, item, NULL_TREE, list);
9377   TREE_CONSTANT (list) = 1;
9378   TREE_STATIC (list) = 1;
9379
9380   var = ffecom_get_invented_identifier ("__g77_vardesc_array_%d", mynumber++);
9381   var = build_decl (VAR_DECL, var, item);
9382   TREE_STATIC (var) = 1;
9383   DECL_INITIAL (var) = error_mark_node;
9384   var = start_decl (var, FALSE);
9385   finish_decl (var, list, FALSE);
9386
9387   return var;
9388 }
9389
9390 static tree
9391 ffecom_vardesc_dims_ (ffesymbol s)
9392 {
9393   if (ffesymbol_dims (s) == NULL)
9394     return convert (ffecom_f2c_ptr_to_ftnlen_type_node,
9395                     integer_zero_node);
9396
9397   {
9398     ffebld b;
9399     ffebld e;
9400     tree list;
9401     tree backlist;
9402     tree item = NULL_TREE;
9403     tree var;
9404     tree numdim;
9405     tree numelem;
9406     tree baseoff = NULL_TREE;
9407     static int mynumber = 0;
9408
9409     numdim = build_int_2 ((int) ffesymbol_rank (s), 0);
9410     TREE_TYPE (numdim) = ffecom_f2c_ftnlen_type_node;
9411
9412     numelem = ffecom_expr (ffesymbol_arraysize (s));
9413     TREE_TYPE (numelem) = ffecom_f2c_ftnlen_type_node;
9414
9415     list = NULL_TREE;
9416     backlist = NULL_TREE;
9417     for (b = ffesymbol_dims (s), e = ffesymbol_extents (s);
9418          b != NULL;
9419          b = ffebld_trail (b), e = ffebld_trail (e))
9420       {
9421         tree t;
9422         tree low;
9423         tree back;
9424
9425         if (ffebld_trail (b) == NULL)
9426           t = NULL_TREE;
9427         else
9428           {
9429             t = convert (ffecom_f2c_ftnlen_type_node,
9430                          ffecom_expr (ffebld_head (e)));
9431
9432             if (list == NULL_TREE)
9433               list = item = build_tree_list (NULL_TREE, t);
9434             else
9435               {
9436                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9437                 item = TREE_CHAIN (item);
9438               }
9439           }
9440
9441         if (ffebld_left (ffebld_head (b)) == NULL)
9442           low = ffecom_integer_one_node;
9443         else
9444           low = ffecom_expr (ffebld_left (ffebld_head (b)));
9445         low = convert (ffecom_f2c_ftnlen_type_node, low);
9446
9447         back = build_tree_list (low, t);
9448         TREE_CHAIN (back) = backlist;
9449         backlist = back;
9450       }
9451
9452     for (item = backlist; item != NULL_TREE; item = TREE_CHAIN (item))
9453       {
9454         if (TREE_VALUE (item) == NULL_TREE)
9455           baseoff = TREE_PURPOSE (item);
9456         else
9457           baseoff = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
9458                               TREE_PURPOSE (item),
9459                               ffecom_2 (MULT_EXPR,
9460                                         ffecom_f2c_ftnlen_type_node,
9461                                         TREE_VALUE (item),
9462                                         baseoff));
9463       }
9464
9465     /* backlist now dead, along with all TREE_PURPOSEs on it.  */
9466
9467     baseoff = build_tree_list (NULL_TREE, baseoff);
9468     TREE_CHAIN (baseoff) = list;
9469
9470     numelem = build_tree_list (NULL_TREE, numelem);
9471     TREE_CHAIN (numelem) = baseoff;
9472
9473     numdim = build_tree_list (NULL_TREE, numdim);
9474     TREE_CHAIN (numdim) = numelem;
9475
9476     item = build_array_type (ffecom_f2c_ftnlen_type_node,
9477                              build_range_type (integer_type_node,
9478                                                integer_zero_node,
9479                                                build_int_2
9480                                                ((int) ffesymbol_rank (s)
9481                                                 + 2, 0)));
9482     list = build (CONSTRUCTOR, item, NULL_TREE, numdim);
9483     TREE_CONSTANT (list) = 1;
9484     TREE_STATIC (list) = 1;
9485
9486     var = ffecom_get_invented_identifier ("__g77_dims_%d", mynumber++);
9487     var = build_decl (VAR_DECL, var, item);
9488     TREE_STATIC (var) = 1;
9489     DECL_INITIAL (var) = error_mark_node;
9490     var = start_decl (var, FALSE);
9491     finish_decl (var, list, FALSE);
9492
9493     var = ffecom_1 (ADDR_EXPR, build_pointer_type (item), var);
9494
9495     return var;
9496   }
9497 }
9498
9499 /* Essentially does a "fold (build1 (code, type, node))" while checking
9500    for certain housekeeping things.
9501
9502    NOTE: for building an ADDR_EXPR around a FUNCTION_DECL, use
9503    ffecom_1_fn instead.  */
9504
9505 tree
9506 ffecom_1 (enum tree_code code, tree type, tree node)
9507 {
9508   tree item;
9509
9510   if ((node == error_mark_node)
9511       || (type == error_mark_node))
9512     return error_mark_node;
9513
9514   if (code == ADDR_EXPR)
9515     {
9516       if (!mark_addressable (node))
9517         assert ("can't mark_addressable this node!" == NULL);
9518     }
9519
9520   switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9521     {
9522       tree realtype;
9523
9524     case REALPART_EXPR:
9525       item = build (COMPONENT_REF, type, node, TYPE_FIELDS (TREE_TYPE (node)));
9526       break;
9527
9528     case IMAGPART_EXPR:
9529       item = build (COMPONENT_REF, type, node, TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (node))));
9530       break;
9531
9532
9533     case NEGATE_EXPR:
9534       if (TREE_CODE (type) != RECORD_TYPE)
9535         {
9536           item = build1 (code, type, node);
9537           break;
9538         }
9539       node = ffecom_stabilize_aggregate_ (node);
9540       realtype = TREE_TYPE (TYPE_FIELDS (type));
9541       item =
9542         ffecom_2 (COMPLEX_EXPR, type,
9543                   ffecom_1 (NEGATE_EXPR, realtype,
9544                             ffecom_1 (REALPART_EXPR, realtype,
9545                                       node)),
9546                   ffecom_1 (NEGATE_EXPR, realtype,
9547                             ffecom_1 (IMAGPART_EXPR, realtype,
9548                                       node)));
9549       break;
9550
9551     default:
9552       item = build1 (code, type, node);
9553       break;
9554     }
9555
9556   if (TREE_SIDE_EFFECTS (node))
9557     TREE_SIDE_EFFECTS (item) = 1;
9558   if ((code == ADDR_EXPR) && staticp (node))
9559     TREE_CONSTANT (item) = 1;
9560   return fold (item);
9561 }
9562
9563 /* Like ffecom_1 (ADDR_EXPR, TREE_TYPE (node), node), except
9564    handles TREE_CODE (node) == FUNCTION_DECL.  In particular,
9565    does not set TREE_ADDRESSABLE (because calling an inline
9566    function does not mean the function needs to be separately
9567    compiled).  */
9568
9569 tree
9570 ffecom_1_fn (tree node)
9571 {
9572   tree item;
9573   tree type;
9574
9575   if (node == error_mark_node)
9576     return error_mark_node;
9577
9578   type = build_type_variant (TREE_TYPE (node),
9579                              TREE_READONLY (node),
9580                              TREE_THIS_VOLATILE (node));
9581   item = build1 (ADDR_EXPR,
9582                  build_pointer_type (type), node);
9583   if (TREE_SIDE_EFFECTS (node))
9584     TREE_SIDE_EFFECTS (item) = 1;
9585   if (staticp (node))
9586     TREE_CONSTANT (item) = 1;
9587   return fold (item);
9588 }
9589
9590 /* Essentially does a "fold (build (code, type, node1, node2))" while
9591    checking for certain housekeeping things.  */
9592
9593 tree
9594 ffecom_2 (enum tree_code code, tree type, tree node1,
9595           tree node2)
9596 {
9597   tree item;
9598
9599   if ((node1 == error_mark_node)
9600       || (node2 == error_mark_node)
9601       || (type == error_mark_node))
9602     return error_mark_node;
9603
9604   switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9605     {
9606       tree a, b, c, d, realtype;
9607
9608     case CONJ_EXPR:
9609       assert ("no CONJ_EXPR support yet" == NULL);
9610       return error_mark_node;
9611
9612     case COMPLEX_EXPR:
9613       item = build_tree_list (TYPE_FIELDS (type), node1);
9614       TREE_CHAIN (item) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), node2);
9615       item = build (CONSTRUCTOR, type, NULL_TREE, item);
9616       break;
9617
9618     case PLUS_EXPR:
9619       if (TREE_CODE (type) != RECORD_TYPE)
9620         {
9621           item = build (code, type, node1, node2);
9622           break;
9623         }
9624       node1 = ffecom_stabilize_aggregate_ (node1);
9625       node2 = ffecom_stabilize_aggregate_ (node2);
9626       realtype = TREE_TYPE (TYPE_FIELDS (type));
9627       item =
9628         ffecom_2 (COMPLEX_EXPR, type,
9629                   ffecom_2 (PLUS_EXPR, realtype,
9630                             ffecom_1 (REALPART_EXPR, realtype,
9631                                       node1),
9632                             ffecom_1 (REALPART_EXPR, realtype,
9633                                       node2)),
9634                   ffecom_2 (PLUS_EXPR, realtype,
9635                             ffecom_1 (IMAGPART_EXPR, realtype,
9636                                       node1),
9637                             ffecom_1 (IMAGPART_EXPR, realtype,
9638                                       node2)));
9639       break;
9640
9641     case MINUS_EXPR:
9642       if (TREE_CODE (type) != RECORD_TYPE)
9643         {
9644           item = build (code, type, node1, node2);
9645           break;
9646         }
9647       node1 = ffecom_stabilize_aggregate_ (node1);
9648       node2 = ffecom_stabilize_aggregate_ (node2);
9649       realtype = TREE_TYPE (TYPE_FIELDS (type));
9650       item =
9651         ffecom_2 (COMPLEX_EXPR, type,
9652                   ffecom_2 (MINUS_EXPR, realtype,
9653                             ffecom_1 (REALPART_EXPR, realtype,
9654                                       node1),
9655                             ffecom_1 (REALPART_EXPR, realtype,
9656                                       node2)),
9657                   ffecom_2 (MINUS_EXPR, realtype,
9658                             ffecom_1 (IMAGPART_EXPR, realtype,
9659                                       node1),
9660                             ffecom_1 (IMAGPART_EXPR, realtype,
9661                                       node2)));
9662       break;
9663
9664     case MULT_EXPR:
9665       if (TREE_CODE (type) != RECORD_TYPE)
9666         {
9667           item = build (code, type, node1, node2);
9668           break;
9669         }
9670       node1 = ffecom_stabilize_aggregate_ (node1);
9671       node2 = ffecom_stabilize_aggregate_ (node2);
9672       realtype = TREE_TYPE (TYPE_FIELDS (type));
9673       a = save_expr (ffecom_1 (REALPART_EXPR, realtype,
9674                                node1));
9675       b = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
9676                                node1));
9677       c = save_expr (ffecom_1 (REALPART_EXPR, realtype,
9678                                node2));
9679       d = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
9680                                node2));
9681       item =
9682         ffecom_2 (COMPLEX_EXPR, type,
9683                   ffecom_2 (MINUS_EXPR, realtype,
9684                             ffecom_2 (MULT_EXPR, realtype,
9685                                       a,
9686                                       c),
9687                             ffecom_2 (MULT_EXPR, realtype,
9688                                       b,
9689                                       d)),
9690                   ffecom_2 (PLUS_EXPR, realtype,
9691                             ffecom_2 (MULT_EXPR, realtype,
9692                                       a,
9693                                       d),
9694                             ffecom_2 (MULT_EXPR, realtype,
9695                                       c,
9696                                       b)));
9697       break;
9698
9699     case EQ_EXPR:
9700       if ((TREE_CODE (node1) != RECORD_TYPE)
9701           && (TREE_CODE (node2) != RECORD_TYPE))
9702         {
9703           item = build (code, type, node1, node2);
9704           break;
9705         }
9706       assert (TREE_CODE (node1) == RECORD_TYPE);
9707       assert (TREE_CODE (node2) == RECORD_TYPE);
9708       node1 = ffecom_stabilize_aggregate_ (node1);
9709       node2 = ffecom_stabilize_aggregate_ (node2);
9710       realtype = TREE_TYPE (TYPE_FIELDS (type));
9711       item =
9712         ffecom_2 (TRUTH_ANDIF_EXPR, type,
9713                   ffecom_2 (code, type,
9714                             ffecom_1 (REALPART_EXPR, realtype,
9715                                       node1),
9716                             ffecom_1 (REALPART_EXPR, realtype,
9717                                       node2)),
9718                   ffecom_2 (code, type,
9719                             ffecom_1 (IMAGPART_EXPR, realtype,
9720                                       node1),
9721                             ffecom_1 (IMAGPART_EXPR, realtype,
9722                                       node2)));
9723       break;
9724
9725     case NE_EXPR:
9726       if ((TREE_CODE (node1) != RECORD_TYPE)
9727           && (TREE_CODE (node2) != RECORD_TYPE))
9728         {
9729           item = build (code, type, node1, node2);
9730           break;
9731         }
9732       assert (TREE_CODE (node1) == RECORD_TYPE);
9733       assert (TREE_CODE (node2) == RECORD_TYPE);
9734       node1 = ffecom_stabilize_aggregate_ (node1);
9735       node2 = ffecom_stabilize_aggregate_ (node2);
9736       realtype = TREE_TYPE (TYPE_FIELDS (type));
9737       item =
9738         ffecom_2 (TRUTH_ORIF_EXPR, type,
9739                   ffecom_2 (code, type,
9740                             ffecom_1 (REALPART_EXPR, realtype,
9741                                       node1),
9742                             ffecom_1 (REALPART_EXPR, realtype,
9743                                       node2)),
9744                   ffecom_2 (code, type,
9745                             ffecom_1 (IMAGPART_EXPR, realtype,
9746                                       node1),
9747                             ffecom_1 (IMAGPART_EXPR, realtype,
9748                                       node2)));
9749       break;
9750
9751     default:
9752       item = build (code, type, node1, node2);
9753       break;
9754     }
9755
9756   if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2))
9757     TREE_SIDE_EFFECTS (item) = 1;
9758   return fold (item);
9759 }
9760
9761 /* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint
9762
9763    ffesymbol s;  // the ENTRY point itself
9764    if (ffecom_2pass_advise_entrypoint(s))
9765        // the ENTRY point has been accepted
9766
9767    Does whatever compiler needs to do when it learns about the entrypoint,
9768    like determine the return type of the master function, count the
9769    number of entrypoints, etc.  Returns FALSE if the return type is
9770    not compatible with the return type(s) of other entrypoint(s).
9771
9772    NOTE: for every call to this fn that returns TRUE, _do_entrypoint must
9773    later (after _finish_progunit) be called with the same entrypoint(s)
9774    as passed to this fn for which TRUE was returned.
9775
9776    03-Jan-92  JCB  2.0
9777       Return FALSE if the return type conflicts with previous entrypoints.  */
9778
9779 bool
9780 ffecom_2pass_advise_entrypoint (ffesymbol entry)
9781 {
9782   ffebld list;                  /* opITEM. */
9783   ffebld mlist;                 /* opITEM. */
9784   ffebld plist;                 /* opITEM. */
9785   ffebld arg;                   /* ffebld_head(opITEM). */
9786   ffebld item;                  /* opITEM. */
9787   ffesymbol s;                  /* ffebld_symter(arg). */
9788   ffeinfoBasictype bt = ffesymbol_basictype (entry);
9789   ffeinfoKindtype kt = ffesymbol_kindtype (entry);
9790   ffetargetCharacterSize size = ffesymbol_size (entry);
9791   bool ok;
9792
9793   if (ffecom_num_entrypoints_ == 0)
9794     {                           /* First entrypoint, make list of main
9795                                    arglist's dummies. */
9796       assert (ffecom_primary_entry_ != NULL);
9797
9798       ffecom_master_bt_ = ffesymbol_basictype (ffecom_primary_entry_);
9799       ffecom_master_kt_ = ffesymbol_kindtype (ffecom_primary_entry_);
9800       ffecom_master_size_ = ffesymbol_size (ffecom_primary_entry_);
9801
9802       for (plist = NULL, list = ffesymbol_dummyargs (ffecom_primary_entry_);
9803            list != NULL;
9804            list = ffebld_trail (list))
9805         {
9806           arg = ffebld_head (list);
9807           if (ffebld_op (arg) != FFEBLD_opSYMTER)
9808             continue;           /* Alternate return or some such thing. */
9809           item = ffebld_new_item (arg, NULL);
9810           if (plist == NULL)
9811             ffecom_master_arglist_ = item;
9812           else
9813             ffebld_set_trail (plist, item);
9814           plist = item;
9815         }
9816     }
9817
9818   /* If necessary, scan entry arglist for alternate returns.  Do this scan
9819      apparently redundantly (it's done below to UNIONize the arglists) so
9820      that we don't complain about RETURN 1 if an offending ENTRY is the only
9821      one with an alternate return.  */
9822
9823   if (!ffecom_is_altreturning_)
9824     {
9825       for (list = ffesymbol_dummyargs (entry);
9826            list != NULL;
9827            list = ffebld_trail (list))
9828         {
9829           arg = ffebld_head (list);
9830           if (ffebld_op (arg) == FFEBLD_opSTAR)
9831             {
9832               ffecom_is_altreturning_ = TRUE;
9833               break;
9834             }
9835         }
9836     }
9837
9838   /* Now check type compatibility. */
9839
9840   switch (ffecom_master_bt_)
9841     {
9842     case FFEINFO_basictypeNONE:
9843       ok = (bt != FFEINFO_basictypeCHARACTER);
9844       break;
9845
9846     case FFEINFO_basictypeCHARACTER:
9847       ok
9848         = (bt == FFEINFO_basictypeCHARACTER)
9849         && (kt == ffecom_master_kt_)
9850         && (size == ffecom_master_size_);
9851       break;
9852
9853     case FFEINFO_basictypeANY:
9854       return FALSE;             /* Just don't bother. */
9855
9856     default:
9857       if (bt == FFEINFO_basictypeCHARACTER)
9858         {
9859           ok = FALSE;
9860           break;
9861         }
9862       ok = TRUE;
9863       if ((bt != ffecom_master_bt_) || (kt != ffecom_master_kt_))
9864         {
9865           ffecom_master_bt_ = FFEINFO_basictypeNONE;
9866           ffecom_master_kt_ = FFEINFO_kindtypeNONE;
9867         }
9868       break;
9869     }
9870
9871   if (!ok)
9872     {
9873       ffebad_start (FFEBAD_ENTRY_CONFLICTS);
9874       ffest_ffebad_here_current_stmt (0);
9875       ffebad_finish ();
9876       return FALSE;             /* Can't handle entrypoint. */
9877     }
9878
9879   /* Entrypoint type compatible with previous types. */
9880
9881   ++ffecom_num_entrypoints_;
9882
9883   /* Master-arg-list = UNION(Master-arg-list,entry-arg-list). */
9884
9885   for (list = ffesymbol_dummyargs (entry);
9886        list != NULL;
9887        list = ffebld_trail (list))
9888     {
9889       arg = ffebld_head (list);
9890       if (ffebld_op (arg) != FFEBLD_opSYMTER)
9891         continue;               /* Alternate return or some such thing. */
9892       s = ffebld_symter (arg);
9893       for (plist = NULL, mlist = ffecom_master_arglist_;
9894            mlist != NULL;
9895            plist = mlist, mlist = ffebld_trail (mlist))
9896         {                       /* plist points to previous item for easy
9897                                    appending of arg. */
9898           if (ffebld_symter (ffebld_head (mlist)) == s)
9899             break;              /* Already have this arg in the master list. */
9900         }
9901       if (mlist != NULL)
9902         continue;               /* Already have this arg in the master list. */
9903
9904       /* Append this arg to the master list. */
9905
9906       item = ffebld_new_item (arg, NULL);
9907       if (plist == NULL)
9908         ffecom_master_arglist_ = item;
9909       else
9910         ffebld_set_trail (plist, item);
9911     }
9912
9913   return TRUE;
9914 }
9915
9916 /* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint
9917
9918    ffesymbol s;  // the ENTRY point itself
9919    ffecom_2pass_do_entrypoint(s);
9920
9921    Does whatever compiler needs to do to make the entrypoint actually
9922    happen.  Must be called for each entrypoint after
9923    ffecom_finish_progunit is called.  */
9924
9925 void
9926 ffecom_2pass_do_entrypoint (ffesymbol entry)
9927 {
9928   static int mfn_num = 0;
9929   static int ent_num;
9930
9931   if (mfn_num != ffecom_num_fns_)
9932     {                           /* First entrypoint for this program unit. */
9933       ent_num = 1;
9934       mfn_num = ffecom_num_fns_;
9935       ffecom_do_entry_ (ffecom_primary_entry_, 0);
9936     }
9937   else
9938     ++ent_num;
9939
9940   --ffecom_num_entrypoints_;
9941
9942   ffecom_do_entry_ (entry, ent_num);
9943 }
9944
9945 /* Essentially does a "fold (build (code, type, node1, node2))" while
9946    checking for certain housekeeping things.  Always sets
9947    TREE_SIDE_EFFECTS.  */
9948
9949 tree
9950 ffecom_2s (enum tree_code code, tree type, tree node1,
9951            tree node2)
9952 {
9953   tree item;
9954
9955   if ((node1 == error_mark_node)
9956       || (node2 == error_mark_node)
9957       || (type == error_mark_node))
9958     return error_mark_node;
9959
9960   item = build (code, type, node1, node2);
9961   TREE_SIDE_EFFECTS (item) = 1;
9962   return fold (item);
9963 }
9964
9965 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
9966    checking for certain housekeeping things.  */
9967
9968 tree
9969 ffecom_3 (enum tree_code code, tree type, tree node1,
9970           tree node2, tree node3)
9971 {
9972   tree item;
9973
9974   if ((node1 == error_mark_node)
9975       || (node2 == error_mark_node)
9976       || (node3 == error_mark_node)
9977       || (type == error_mark_node))
9978     return error_mark_node;
9979
9980   item = build (code, type, node1, node2, node3);
9981   if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2)
9982       || (node3 != NULL_TREE && TREE_SIDE_EFFECTS (node3)))
9983     TREE_SIDE_EFFECTS (item) = 1;
9984   return fold (item);
9985 }
9986
9987 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
9988    checking for certain housekeeping things.  Always sets
9989    TREE_SIDE_EFFECTS.  */
9990
9991 tree
9992 ffecom_3s (enum tree_code code, tree type, tree node1,
9993            tree node2, tree node3)
9994 {
9995   tree item;
9996
9997   if ((node1 == error_mark_node)
9998       || (node2 == error_mark_node)
9999       || (node3 == error_mark_node)
10000       || (type == error_mark_node))
10001     return error_mark_node;
10002
10003   item = build (code, type, node1, node2, node3);
10004   TREE_SIDE_EFFECTS (item) = 1;
10005   return fold (item);
10006 }
10007
10008 /* ffecom_arg_expr -- Transform argument expr into gcc tree
10009
10010    See use by ffecom_list_expr.
10011
10012    If expression is NULL, returns an integer zero tree.  If it is not
10013    a CHARACTER expression, returns whatever ffecom_expr
10014    returns and sets the length return value to NULL_TREE.  Otherwise
10015    generates code to evaluate the character expression, returns the proper
10016    pointer to the result, but does NOT set the length return value to a tree
10017    that specifies the length of the result.  (In other words, the length
10018    variable is always set to NULL_TREE, because a length is never passed.)
10019
10020    21-Dec-91  JCB  1.1
10021       Don't set returned length, since nobody needs it (yet; someday if
10022       we allow CHARACTER*(*) dummies to statement functions, we'll need
10023       it).  */
10024
10025 tree
10026 ffecom_arg_expr (ffebld expr, tree *length)
10027 {
10028   tree ign;
10029
10030   *length = NULL_TREE;
10031
10032   if (expr == NULL)
10033     return integer_zero_node;
10034
10035   if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10036     return ffecom_expr (expr);
10037
10038   return ffecom_arg_ptr_to_expr (expr, &ign);
10039 }
10040
10041 /* Transform expression into constant argument-pointer-to-expression tree.
10042
10043    If the expression can be transformed into a argument-pointer-to-expression
10044    tree that is constant, that is done, and the tree returned.  Else
10045    NULL_TREE is returned.
10046
10047    That way, a caller can attempt to provide compile-time initialization
10048    of a variable and, if that fails, *then* choose to start a new block
10049    and resort to using temporaries, as appropriate.  */
10050
10051 tree
10052 ffecom_arg_ptr_to_const_expr (ffebld expr, tree *length)
10053 {
10054   if (! expr)
10055     return integer_zero_node;
10056
10057   if (ffebld_op (expr) == FFEBLD_opANY)
10058     {
10059       if (length)
10060         *length = error_mark_node;
10061       return error_mark_node;
10062     }
10063
10064   if (ffebld_arity (expr) == 0
10065       && (ffebld_op (expr) != FFEBLD_opSYMTER
10066           || ffebld_where (expr) == FFEINFO_whereCOMMON
10067           || ffebld_where (expr) == FFEINFO_whereGLOBAL
10068           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10069     {
10070       tree t;
10071
10072       t = ffecom_arg_ptr_to_expr (expr, length);
10073       assert (TREE_CONSTANT (t));
10074       assert (! length || TREE_CONSTANT (*length));
10075       return t;
10076     }
10077
10078   if (length
10079       && ffebld_size (expr) != FFETARGET_charactersizeNONE)
10080     *length = build_int_2 (ffebld_size (expr), 0);
10081   else if (length)
10082     *length = NULL_TREE;
10083   return NULL_TREE;
10084 }
10085
10086 /* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree
10087
10088    See use by ffecom_list_ptr_to_expr.
10089
10090    If expression is NULL, returns an integer zero tree.  If it is not
10091    a CHARACTER expression, returns whatever ffecom_ptr_to_expr
10092    returns and sets the length return value to NULL_TREE.  Otherwise
10093    generates code to evaluate the character expression, returns the proper
10094    pointer to the result, AND sets the length return value to a tree that
10095    specifies the length of the result.
10096
10097    If the length argument is NULL, this is a slightly special
10098    case of building a FORMAT expression, that is, an expression that
10099    will be used at run time without regard to length.  For the current
10100    implementation, which uses the libf2c library, this means it is nice
10101    to append a null byte to the end of the expression, where feasible,
10102    to make sure any diagnostic about the FORMAT string terminates at
10103    some useful point.
10104
10105    For now, treat %REF(char-expr) as the same as char-expr with a NULL
10106    length argument.  This might even be seen as a feature, if a null
10107    byte can always be appended.  */
10108
10109 tree
10110 ffecom_arg_ptr_to_expr (ffebld expr, tree *length)
10111 {
10112   tree item;
10113   tree ign_length;
10114   ffecomConcatList_ catlist;
10115
10116   if (length != NULL)
10117     *length = NULL_TREE;
10118
10119   if (expr == NULL)
10120     return integer_zero_node;
10121
10122   switch (ffebld_op (expr))
10123     {
10124     case FFEBLD_opPERCENT_VAL:
10125       if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10126         return ffecom_expr (ffebld_left (expr));
10127       {
10128         tree temp_exp;
10129         tree temp_length;
10130
10131         temp_exp = ffecom_arg_ptr_to_expr (ffebld_left (expr), &temp_length);
10132         if (temp_exp == error_mark_node)
10133           return error_mark_node;
10134
10135         return ffecom_1 (INDIRECT_REF, TREE_TYPE (TREE_TYPE (temp_exp)),
10136                          temp_exp);
10137       }
10138
10139     case FFEBLD_opPERCENT_REF:
10140       if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10141         return ffecom_ptr_to_expr (ffebld_left (expr));
10142       if (length != NULL)
10143         {
10144           ign_length = NULL_TREE;
10145           length = &ign_length;
10146         }
10147       expr = ffebld_left (expr);
10148       break;
10149
10150     case FFEBLD_opPERCENT_DESCR:
10151       switch (ffeinfo_basictype (ffebld_info (expr)))
10152         {
10153 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10154         case FFEINFO_basictypeHOLLERITH:
10155 #endif
10156         case FFEINFO_basictypeCHARACTER:
10157           break;                /* Passed by descriptor anyway. */
10158
10159         default:
10160           item = ffecom_ptr_to_expr (expr);
10161           if (item != error_mark_node)
10162             *length = TYPE_SIZE (TREE_TYPE (TREE_TYPE (item)));
10163           break;
10164         }
10165       break;
10166
10167     default:
10168       break;
10169     }
10170
10171 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10172   if ((ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeHOLLERITH)
10173       && (length != NULL))
10174     {                           /* Pass Hollerith by descriptor. */
10175       ffetargetHollerith h;
10176
10177       assert (ffebld_op (expr) == FFEBLD_opCONTER);
10178       h = ffebld_cu_val_hollerith (ffebld_constant_union
10179                                    (ffebld_conter (expr)));
10180       *length
10181         = build_int_2 (h.length, 0);
10182       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10183     }
10184 #endif
10185
10186   if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10187     return ffecom_ptr_to_expr (expr);
10188
10189   assert (ffeinfo_kindtype (ffebld_info (expr))
10190           == FFEINFO_kindtypeCHARACTER1);
10191
10192   while (ffebld_op (expr) == FFEBLD_opPAREN)
10193     expr = ffebld_left (expr);
10194
10195   catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
10196   switch (ffecom_concat_list_count_ (catlist))
10197     {
10198     case 0:                     /* Shouldn't happen, but in case it does... */
10199       if (length != NULL)
10200         {
10201           *length = ffecom_f2c_ftnlen_zero_node;
10202           TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10203         }
10204       ffecom_concat_list_kill_ (catlist);
10205       return null_pointer_node;
10206
10207     case 1:                     /* The (fairly) easy case. */
10208       if (length == NULL)
10209         ffecom_char_args_with_null_ (&item, &ign_length,
10210                                      ffecom_concat_list_expr_ (catlist, 0));
10211       else
10212         ffecom_char_args_ (&item, length,
10213                            ffecom_concat_list_expr_ (catlist, 0));
10214       ffecom_concat_list_kill_ (catlist);
10215       assert (item != NULL_TREE);
10216       return item;
10217
10218     default:                    /* Must actually concatenate things. */
10219       break;
10220     }
10221
10222   {
10223     int count = ffecom_concat_list_count_ (catlist);
10224     int i;
10225     tree lengths;
10226     tree items;
10227     tree length_array;
10228     tree item_array;
10229     tree citem;
10230     tree clength;
10231     tree temporary;
10232     tree num;
10233     tree known_length;
10234     ffetargetCharacterSize sz;
10235
10236     sz = ffecom_concat_list_maxlen_ (catlist);
10237     /* ~~Kludge! */
10238     assert (sz != FFETARGET_charactersizeNONE);
10239
10240 #ifdef HOHO
10241     length_array
10242       = lengths
10243       = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
10244                              FFETARGET_charactersizeNONE, count, TRUE);
10245     item_array
10246       = items
10247       = ffecom_push_tempvar (ffecom_f2c_address_type_node,
10248                              FFETARGET_charactersizeNONE, count, TRUE);
10249     temporary = ffecom_push_tempvar (char_type_node,
10250                                      sz, -1, TRUE);
10251 #else
10252     {
10253       tree hook;
10254
10255       hook = ffebld_nonter_hook (expr);
10256       assert (hook);
10257       assert (TREE_CODE (hook) == TREE_VEC);
10258       assert (TREE_VEC_LENGTH (hook) == 3);
10259       length_array = lengths = TREE_VEC_ELT (hook, 0);
10260       item_array = items = TREE_VEC_ELT (hook, 1);
10261       temporary = TREE_VEC_ELT (hook, 2);
10262     }
10263 #endif
10264
10265     known_length = ffecom_f2c_ftnlen_zero_node;
10266
10267     for (i = 0; i < count; ++i)
10268       {
10269         if ((i == count)
10270             && (length == NULL))
10271           ffecom_char_args_with_null_ (&citem, &clength,
10272                                        ffecom_concat_list_expr_ (catlist, i));
10273         else
10274           ffecom_char_args_ (&citem, &clength,
10275                              ffecom_concat_list_expr_ (catlist, i));
10276         if ((citem == error_mark_node)
10277             || (clength == error_mark_node))
10278           {
10279             ffecom_concat_list_kill_ (catlist);
10280             *length = error_mark_node;
10281             return error_mark_node;
10282           }
10283
10284         items
10285           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
10286                       ffecom_modify (void_type_node,
10287                                      ffecom_2 (ARRAY_REF,
10288                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
10289                                                item_array,
10290                                                build_int_2 (i, 0)),
10291                                      citem),
10292                       items);
10293         clength = ffecom_save_tree (clength);
10294         if (length != NULL)
10295           known_length
10296             = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
10297                         known_length,
10298                         clength);
10299         lengths
10300           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
10301                       ffecom_modify (void_type_node,
10302                                      ffecom_2 (ARRAY_REF,
10303                    TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
10304                                                length_array,
10305                                                build_int_2 (i, 0)),
10306                                      clength),
10307                       lengths);
10308       }
10309
10310     temporary = ffecom_1 (ADDR_EXPR,
10311                           build_pointer_type (TREE_TYPE (temporary)),
10312                           temporary);
10313
10314     item = build_tree_list (NULL_TREE, temporary);
10315     TREE_CHAIN (item)
10316       = build_tree_list (NULL_TREE,
10317                          ffecom_1 (ADDR_EXPR,
10318                                    build_pointer_type (TREE_TYPE (items)),
10319                                    items));
10320     TREE_CHAIN (TREE_CHAIN (item))
10321       = build_tree_list (NULL_TREE,
10322                          ffecom_1 (ADDR_EXPR,
10323                                    build_pointer_type (TREE_TYPE (lengths)),
10324                                    lengths));
10325     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
10326       = build_tree_list
10327         (NULL_TREE,
10328          ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
10329                    convert (ffecom_f2c_ftnlen_type_node,
10330                             build_int_2 (count, 0))));
10331     num = build_int_2 (sz, 0);
10332     TREE_TYPE (num) = ffecom_f2c_ftnlen_type_node;
10333     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item))))
10334       = build_tree_list (NULL_TREE, num);
10335
10336     item = ffecom_call_gfrt (FFECOM_gfrtCAT, item, NULL_TREE);
10337     TREE_SIDE_EFFECTS (item) = 1;
10338     item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (temporary),
10339                      item,
10340                      temporary);
10341
10342     if (length != NULL)
10343       *length = known_length;
10344   }
10345
10346   ffecom_concat_list_kill_ (catlist);
10347   assert (item != NULL_TREE);
10348   return item;
10349 }
10350
10351 /* Generate call to run-time function.
10352
10353    The first arg is the GNU Fortran Run-Time function index, the second
10354    arg is the list of arguments to pass to it.  Returned is the expression
10355    (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the
10356    result (which may be void).  */
10357
10358 tree
10359 ffecom_call_gfrt (ffecomGfrt ix, tree args, tree hook)
10360 {
10361   return ffecom_call_ (ffecom_gfrt_tree_ (ix),
10362                        ffecom_gfrt_kindtype (ix),
10363                        ffe_is_f2c_library () && ffecom_gfrt_complex_[ix],
10364                        NULL_TREE, args, NULL_TREE, NULL,
10365                        NULL, NULL_TREE, TRUE, hook);
10366 }
10367
10368 /* Transform constant-union to tree.  */
10369
10370 tree
10371 ffecom_constantunion (ffebldConstantUnion *cu, ffeinfoBasictype bt,
10372                       ffeinfoKindtype kt, tree tree_type)
10373 {
10374   tree item;
10375
10376   switch (bt)
10377     {
10378     case FFEINFO_basictypeINTEGER:
10379       {
10380         int val;
10381
10382         switch (kt)
10383           {
10384 #if FFETARGET_okINTEGER1
10385           case FFEINFO_kindtypeINTEGER1:
10386             val = ffebld_cu_val_integer1 (*cu);
10387             break;
10388 #endif
10389
10390 #if FFETARGET_okINTEGER2
10391           case FFEINFO_kindtypeINTEGER2:
10392             val = ffebld_cu_val_integer2 (*cu);
10393             break;
10394 #endif
10395
10396 #if FFETARGET_okINTEGER3
10397           case FFEINFO_kindtypeINTEGER3:
10398             val = ffebld_cu_val_integer3 (*cu);
10399             break;
10400 #endif
10401
10402 #if FFETARGET_okINTEGER4
10403           case FFEINFO_kindtypeINTEGER4:
10404             val = ffebld_cu_val_integer4 (*cu);
10405             break;
10406 #endif
10407
10408           default:
10409             assert ("bad INTEGER constant kind type" == NULL);
10410             /* Fall through. */
10411           case FFEINFO_kindtypeANY:
10412             return error_mark_node;
10413           }
10414         item = build_int_2 (val, (val < 0) ? -1 : 0);
10415         TREE_TYPE (item) = tree_type;
10416       }
10417       break;
10418
10419     case FFEINFO_basictypeLOGICAL:
10420       {
10421         int val;
10422
10423         switch (kt)
10424           {
10425 #if FFETARGET_okLOGICAL1
10426           case FFEINFO_kindtypeLOGICAL1:
10427             val = ffebld_cu_val_logical1 (*cu);
10428             break;
10429 #endif
10430
10431 #if FFETARGET_okLOGICAL2
10432           case FFEINFO_kindtypeLOGICAL2:
10433             val = ffebld_cu_val_logical2 (*cu);
10434             break;
10435 #endif
10436
10437 #if FFETARGET_okLOGICAL3
10438           case FFEINFO_kindtypeLOGICAL3:
10439             val = ffebld_cu_val_logical3 (*cu);
10440             break;
10441 #endif
10442
10443 #if FFETARGET_okLOGICAL4
10444           case FFEINFO_kindtypeLOGICAL4:
10445             val = ffebld_cu_val_logical4 (*cu);
10446             break;
10447 #endif
10448
10449           default:
10450             assert ("bad LOGICAL constant kind type" == NULL);
10451             /* Fall through. */
10452           case FFEINFO_kindtypeANY:
10453             return error_mark_node;
10454           }
10455         item = build_int_2 (val, (val < 0) ? -1 : 0);
10456         TREE_TYPE (item) = tree_type;
10457       }
10458       break;
10459
10460     case FFEINFO_basictypeREAL:
10461       {
10462         REAL_VALUE_TYPE val;
10463
10464         switch (kt)
10465           {
10466 #if FFETARGET_okREAL1
10467           case FFEINFO_kindtypeREAL1:
10468             val = ffetarget_value_real1 (ffebld_cu_val_real1 (*cu));
10469             break;
10470 #endif
10471
10472 #if FFETARGET_okREAL2
10473           case FFEINFO_kindtypeREAL2:
10474             val = ffetarget_value_real2 (ffebld_cu_val_real2 (*cu));
10475             break;
10476 #endif
10477
10478 #if FFETARGET_okREAL3
10479           case FFEINFO_kindtypeREAL3:
10480             val = ffetarget_value_real3 (ffebld_cu_val_real3 (*cu));
10481             break;
10482 #endif
10483
10484 #if FFETARGET_okREAL4
10485           case FFEINFO_kindtypeREAL4:
10486             val = ffetarget_value_real4 (ffebld_cu_val_real4 (*cu));
10487             break;
10488 #endif
10489
10490           default:
10491             assert ("bad REAL constant kind type" == NULL);
10492             /* Fall through. */
10493           case FFEINFO_kindtypeANY:
10494             return error_mark_node;
10495           }
10496         item = build_real (tree_type, val);
10497       }
10498       break;
10499
10500     case FFEINFO_basictypeCOMPLEX:
10501       {
10502         REAL_VALUE_TYPE real;
10503         REAL_VALUE_TYPE imag;
10504         tree el_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
10505
10506         switch (kt)
10507           {
10508 #if FFETARGET_okCOMPLEX1
10509           case FFEINFO_kindtypeREAL1:
10510             real = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).real);
10511             imag = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).imaginary);
10512             break;
10513 #endif
10514
10515 #if FFETARGET_okCOMPLEX2
10516           case FFEINFO_kindtypeREAL2:
10517             real = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).real);
10518             imag = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).imaginary);
10519             break;
10520 #endif
10521
10522 #if FFETARGET_okCOMPLEX3
10523           case FFEINFO_kindtypeREAL3:
10524             real = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).real);
10525             imag = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).imaginary);
10526             break;
10527 #endif
10528
10529 #if FFETARGET_okCOMPLEX4
10530           case FFEINFO_kindtypeREAL4:
10531             real = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).real);
10532             imag = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).imaginary);
10533             break;
10534 #endif
10535
10536           default:
10537             assert ("bad REAL constant kind type" == NULL);
10538             /* Fall through. */
10539           case FFEINFO_kindtypeANY:
10540             return error_mark_node;
10541           }
10542         item = ffecom_build_complex_constant_ (tree_type,
10543                                                build_real (el_type, real),
10544                                                build_real (el_type, imag));
10545       }
10546       break;
10547
10548     case FFEINFO_basictypeCHARACTER:
10549       {                         /* Happens only in DATA and similar contexts. */
10550         ffetargetCharacter1 val;
10551
10552         switch (kt)
10553           {
10554 #if FFETARGET_okCHARACTER1
10555           case FFEINFO_kindtypeLOGICAL1:
10556             val = ffebld_cu_val_character1 (*cu);
10557             break;
10558 #endif
10559
10560           default:
10561             assert ("bad CHARACTER constant kind type" == NULL);
10562             /* Fall through. */
10563           case FFEINFO_kindtypeANY:
10564             return error_mark_node;
10565           }
10566         item = build_string (ffetarget_length_character1 (val),
10567                              ffetarget_text_character1 (val));
10568         TREE_TYPE (item)
10569           = build_type_variant (build_array_type (char_type_node,
10570                                                   build_range_type
10571                                                   (integer_type_node,
10572                                                    integer_one_node,
10573                                                    build_int_2
10574                                                 (ffetarget_length_character1
10575                                                  (val), 0))),
10576                                 1, 0);
10577       }
10578       break;
10579
10580     case FFEINFO_basictypeHOLLERITH:
10581       {
10582         ffetargetHollerith h;
10583
10584         h = ffebld_cu_val_hollerith (*cu);
10585
10586         /* If not at least as wide as default INTEGER, widen it.  */
10587         if (h.length >= FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE)
10588           item = build_string (h.length, h.text);
10589         else
10590           {
10591             char str[FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE];
10592
10593             memcpy (str, h.text, h.length);
10594             memset (&str[h.length], ' ',
10595                     FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE
10596                     - h.length);
10597             item = build_string (FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE,
10598                                  str);
10599           }
10600         TREE_TYPE (item)
10601           = build_type_variant (build_array_type (char_type_node,
10602                                                   build_range_type
10603                                                   (integer_type_node,
10604                                                    integer_one_node,
10605                                                    build_int_2
10606                                                    (h.length, 0))),
10607                                 1, 0);
10608       }
10609       break;
10610
10611     case FFEINFO_basictypeTYPELESS:
10612       {
10613         ffetargetInteger1 ival;
10614         ffetargetTypeless tless;
10615         ffebad error;
10616
10617         tless = ffebld_cu_val_typeless (*cu);
10618         error = ffetarget_convert_integer1_typeless (&ival, tless);
10619         assert (error == FFEBAD);
10620
10621         item = build_int_2 ((int) ival, 0);
10622       }
10623       break;
10624
10625     default:
10626       assert ("not yet on constant type" == NULL);
10627       /* Fall through. */
10628     case FFEINFO_basictypeANY:
10629       return error_mark_node;
10630     }
10631
10632   TREE_CONSTANT (item) = 1;
10633
10634   return item;
10635 }
10636
10637 /* Transform expression into constant tree.
10638
10639    If the expression can be transformed into a tree that is constant,
10640    that is done, and the tree returned.  Else NULL_TREE is returned.
10641
10642    That way, a caller can attempt to provide compile-time initialization
10643    of a variable and, if that fails, *then* choose to start a new block
10644    and resort to using temporaries, as appropriate.  */
10645
10646 tree
10647 ffecom_const_expr (ffebld expr)
10648 {
10649   if (! expr)
10650     return integer_zero_node;
10651
10652   if (ffebld_op (expr) == FFEBLD_opANY)
10653     return error_mark_node;
10654
10655   if (ffebld_arity (expr) == 0
10656       && (ffebld_op (expr) != FFEBLD_opSYMTER
10657 #if NEWCOMMON
10658           /* ~~Enable once common/equivalence is handled properly?  */
10659           || ffebld_where (expr) == FFEINFO_whereCOMMON
10660 #endif
10661           || ffebld_where (expr) == FFEINFO_whereGLOBAL
10662           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10663     {
10664       tree t;
10665
10666       t = ffecom_expr (expr);
10667       assert (TREE_CONSTANT (t));
10668       return t;
10669     }
10670
10671   return NULL_TREE;
10672 }
10673
10674 /* Handy way to make a field in a struct/union.  */
10675
10676 tree
10677 ffecom_decl_field (tree context, tree prevfield,
10678                    const char *name, tree type)
10679 {
10680   tree field;
10681
10682   field = build_decl (FIELD_DECL, get_identifier (name), type);
10683   DECL_CONTEXT (field) = context;
10684   DECL_ALIGN (field) = 0;
10685   DECL_USER_ALIGN (field) = 0;
10686   if (prevfield != NULL_TREE)
10687     TREE_CHAIN (prevfield) = field;
10688
10689   return field;
10690 }
10691
10692 void
10693 ffecom_close_include (FILE *f)
10694 {
10695   ffecom_close_include_ (f);
10696 }
10697
10698 int
10699 ffecom_decode_include_option (char *spec)
10700 {
10701   return ffecom_decode_include_option_ (spec);
10702 }
10703
10704 /* End a compound statement (block).  */
10705
10706 tree
10707 ffecom_end_compstmt (void)
10708 {
10709   return bison_rule_compstmt_ ();
10710 }
10711
10712 /* ffecom_end_transition -- Perform end transition on all symbols
10713
10714    ffecom_end_transition();
10715
10716    Calls ffecom_sym_end_transition for each global and local symbol.  */
10717
10718 void
10719 ffecom_end_transition ()
10720 {
10721   ffebld item;
10722
10723   if (ffe_is_ffedebug ())
10724     fprintf (dmpout, "; end_stmt_transition\n");
10725
10726   ffecom_list_blockdata_ = NULL;
10727   ffecom_list_common_ = NULL;
10728
10729   ffesymbol_drive (ffecom_sym_end_transition);
10730   if (ffe_is_ffedebug ())
10731     {
10732       ffestorag_report ();
10733     }
10734
10735   ffecom_start_progunit_ ();
10736
10737   for (item = ffecom_list_blockdata_;
10738        item != NULL;
10739        item = ffebld_trail (item))
10740     {
10741       ffebld callee;
10742       ffesymbol s;
10743       tree dt;
10744       tree t;
10745       tree var;
10746       static int number = 0;
10747
10748       callee = ffebld_head (item);
10749       s = ffebld_symter (callee);
10750       t = ffesymbol_hook (s).decl_tree;
10751       if (t == NULL_TREE)
10752         {
10753           s = ffecom_sym_transform_ (s);
10754           t = ffesymbol_hook (s).decl_tree;
10755         }
10756
10757       dt = build_pointer_type (TREE_TYPE (t));
10758
10759       var = build_decl (VAR_DECL,
10760                         ffecom_get_invented_identifier ("__g77_forceload_%d",
10761                                                         number++),
10762                         dt);
10763       DECL_EXTERNAL (var) = 0;
10764       TREE_STATIC (var) = 1;
10765       TREE_PUBLIC (var) = 0;
10766       DECL_INITIAL (var) = error_mark_node;
10767       TREE_USED (var) = 1;
10768
10769       var = start_decl (var, FALSE);
10770
10771       t = ffecom_1 (ADDR_EXPR, dt, t);
10772
10773       finish_decl (var, t, FALSE);
10774     }
10775
10776   /* This handles any COMMON areas that weren't referenced but have, for
10777      example, important initial data.  */
10778
10779   for (item = ffecom_list_common_;
10780        item != NULL;
10781        item = ffebld_trail (item))
10782     ffecom_transform_common_ (ffebld_symter (ffebld_head (item)));
10783
10784   ffecom_list_common_ = NULL;
10785 }
10786
10787 /* ffecom_exec_transition -- Perform exec transition on all symbols
10788
10789    ffecom_exec_transition();
10790
10791    Calls ffecom_sym_exec_transition for each global and local symbol.
10792    Make sure error updating not inhibited.  */
10793
10794 void
10795 ffecom_exec_transition ()
10796 {
10797   bool inhibited;
10798
10799   if (ffe_is_ffedebug ())
10800     fprintf (dmpout, "; exec_stmt_transition\n");
10801
10802   inhibited = ffebad_inhibit ();
10803   ffebad_set_inhibit (FALSE);
10804
10805   ffesymbol_drive (ffecom_sym_exec_transition); /* Don't retract! */
10806   ffeequiv_exec_transition ();  /* Handle all pending EQUIVALENCEs. */
10807   if (ffe_is_ffedebug ())
10808     {
10809       ffestorag_report ();
10810     }
10811
10812   if (inhibited)
10813     ffebad_set_inhibit (TRUE);
10814 }
10815
10816 /* Handle assignment statement.
10817
10818    Convert dest and source using ffecom_expr, then join them
10819    with an ASSIGN op and pass the whole thing to expand_expr_stmt.  */
10820
10821 void
10822 ffecom_expand_let_stmt (ffebld dest, ffebld source)
10823 {
10824   tree dest_tree;
10825   tree dest_length;
10826   tree source_tree;
10827   tree expr_tree;
10828
10829   if (ffeinfo_basictype (ffebld_info (dest)) != FFEINFO_basictypeCHARACTER)
10830     {
10831       bool dest_used;
10832       tree assign_temp;
10833
10834       /* This attempts to replicate the test below, but must not be
10835          true when the test below is false.  (Always err on the side
10836          of creating unused temporaries, to avoid ICEs.)  */
10837       if (ffebld_op (dest) != FFEBLD_opSYMTER
10838           || ((dest_tree = ffesymbol_hook (ffebld_symter (dest)).decl_tree)
10839               && (TREE_CODE (dest_tree) != VAR_DECL
10840                   || TREE_ADDRESSABLE (dest_tree))))
10841         {
10842           ffecom_prepare_expr_ (source, dest);
10843           dest_used = TRUE;
10844         }
10845       else
10846         {
10847           ffecom_prepare_expr_ (source, NULL);
10848           dest_used = FALSE;
10849         }
10850
10851       ffecom_prepare_expr_w (NULL_TREE, dest);
10852
10853       /* For COMPLEX assignment like C1=C2, if partial overlap is possible,
10854          create a temporary through which the assignment is to take place,
10855          since MODIFY_EXPR doesn't handle partial overlap properly.  */
10856       if (ffebld_basictype (dest) == FFEINFO_basictypeCOMPLEX
10857           && ffecom_possible_partial_overlap_ (dest, source))
10858         {
10859           assign_temp = ffecom_make_tempvar ("complex_let",
10860                                              ffecom_tree_type
10861                                              [ffebld_basictype (dest)]
10862                                              [ffebld_kindtype (dest)],
10863                                              FFETARGET_charactersizeNONE,
10864                                              -1);
10865         }
10866       else
10867         assign_temp = NULL_TREE;
10868
10869       ffecom_prepare_end ();
10870
10871       dest_tree = ffecom_expr_w (NULL_TREE, dest);
10872       if (dest_tree == error_mark_node)
10873         return;
10874
10875       if ((TREE_CODE (dest_tree) != VAR_DECL)
10876           || TREE_ADDRESSABLE (dest_tree))
10877         source_tree = ffecom_expr_ (source, dest_tree, dest, &dest_used,
10878                                     FALSE, FALSE);
10879       else
10880         {
10881           assert (! dest_used);
10882           dest_used = FALSE;
10883           source_tree = ffecom_expr (source);
10884         }
10885       if (source_tree == error_mark_node)
10886         return;
10887
10888       if (dest_used)
10889         expr_tree = source_tree;
10890       else if (assign_temp)
10891         {
10892 #ifdef MOVE_EXPR
10893           /* The back end understands a conceptual move (evaluate source;
10894              store into dest), so use that, in case it can determine
10895              that it is going to use, say, two registers as temporaries
10896              anyway.  So don't use the temp (and someday avoid generating
10897              it, once this code starts triggering regularly).  */
10898           expr_tree = ffecom_2s (MOVE_EXPR, void_type_node,
10899                                  dest_tree,
10900                                  source_tree);
10901 #else
10902           expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
10903                                  assign_temp,
10904                                  source_tree);
10905           expand_expr_stmt (expr_tree);
10906           expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
10907                                  dest_tree,
10908                                  assign_temp);
10909 #endif
10910         }
10911       else
10912         expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
10913                                dest_tree,
10914                                source_tree);
10915
10916       expand_expr_stmt (expr_tree);
10917       return;
10918     }
10919
10920   ffecom_prepare_let_char_ (ffebld_size_known (dest), source);
10921   ffecom_prepare_expr_w (NULL_TREE, dest);
10922
10923   ffecom_prepare_end ();
10924
10925   ffecom_char_args_ (&dest_tree, &dest_length, dest);
10926   ffecom_let_char_ (dest_tree, dest_length, ffebld_size_known (dest),
10927                     source);
10928 }
10929
10930 /* ffecom_expr -- Transform expr into gcc tree
10931
10932    tree t;
10933    ffebld expr;  // FFE expression.
10934    tree = ffecom_expr(expr);
10935
10936    Recursive descent on expr while making corresponding tree nodes and
10937    attaching type info and such.  */
10938
10939 tree
10940 ffecom_expr (ffebld expr)
10941 {
10942   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, FALSE, FALSE);
10943 }
10944
10945 /* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT.  */
10946
10947 tree
10948 ffecom_expr_assign (ffebld expr)
10949 {
10950   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
10951 }
10952
10953 /* Like ffecom_expr_rw, but return tree usable for ASSIGN.  */
10954
10955 tree
10956 ffecom_expr_assign_w (ffebld expr)
10957 {
10958   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
10959 }
10960
10961 /* Transform expr for use as into read/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_rw (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 /* Transform expr for use as into write tree and stabilize the
10978    reference.  Not for use on CHARACTER expressions.
10979
10980    Recursive descent on expr while making corresponding tree nodes and
10981    attaching type info and such.  */
10982
10983 tree
10984 ffecom_expr_w (tree type, ffebld expr)
10985 {
10986   assert (expr != NULL);
10987   /* Different target types not yet supported.  */
10988   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
10989
10990   return stabilize_reference (ffecom_expr (expr));
10991 }
10992
10993 /* Do global stuff.  */
10994
10995 void
10996 ffecom_finish_compile ()
10997 {
10998   assert (ffecom_outer_function_decl_ == NULL_TREE);
10999   assert (current_function_decl == NULL_TREE);
11000
11001   ffeglobal_drive (ffecom_finish_global_);
11002 }
11003
11004 /* Public entry point for front end to access finish_decl.  */
11005
11006 void
11007 ffecom_finish_decl (tree decl, tree init, bool is_top_level)
11008 {
11009   assert (!is_top_level);
11010   finish_decl (decl, init, FALSE);
11011 }
11012
11013 /* Finish a program unit.  */
11014
11015 void
11016 ffecom_finish_progunit ()
11017 {
11018   ffecom_end_compstmt ();
11019
11020   ffecom_previous_function_decl_ = current_function_decl;
11021   ffecom_which_entrypoint_decl_ = NULL_TREE;
11022
11023   finish_function (0);
11024 }
11025
11026 /* Wrapper for get_identifier.  pattern is sprintf-like.  */
11027
11028 tree
11029 ffecom_get_invented_identifier (const char *pattern, ...)
11030 {
11031   tree decl;
11032   char *nam;
11033   va_list ap;
11034
11035   va_start (ap, pattern);
11036   if (vasprintf (&nam, pattern, ap) == 0)
11037     abort ();
11038   va_end (ap);
11039   decl = get_identifier (nam);
11040   free (nam);
11041   IDENTIFIER_INVENTED (decl) = 1;
11042   return decl;
11043 }
11044
11045 ffeinfoBasictype
11046 ffecom_gfrt_basictype (ffecomGfrt gfrt)
11047 {
11048   assert (gfrt < FFECOM_gfrt);
11049
11050   switch (ffecom_gfrt_type_[gfrt])
11051     {
11052     case FFECOM_rttypeVOID_:
11053     case FFECOM_rttypeVOIDSTAR_:
11054       return FFEINFO_basictypeNONE;
11055
11056     case FFECOM_rttypeFTNINT_:
11057       return FFEINFO_basictypeINTEGER;
11058
11059     case FFECOM_rttypeINTEGER_:
11060       return FFEINFO_basictypeINTEGER;
11061
11062     case FFECOM_rttypeLONGINT_:
11063       return FFEINFO_basictypeINTEGER;
11064
11065     case FFECOM_rttypeLOGICAL_:
11066       return FFEINFO_basictypeLOGICAL;
11067
11068     case FFECOM_rttypeREAL_F2C_:
11069     case FFECOM_rttypeREAL_GNU_:
11070       return FFEINFO_basictypeREAL;
11071
11072     case FFECOM_rttypeCOMPLEX_F2C_:
11073     case FFECOM_rttypeCOMPLEX_GNU_:
11074       return FFEINFO_basictypeCOMPLEX;
11075
11076     case FFECOM_rttypeDOUBLE_:
11077     case FFECOM_rttypeDOUBLEREAL_:
11078       return FFEINFO_basictypeREAL;
11079
11080     case FFECOM_rttypeDBLCMPLX_F2C_:
11081     case FFECOM_rttypeDBLCMPLX_GNU_:
11082       return FFEINFO_basictypeCOMPLEX;
11083
11084     case FFECOM_rttypeCHARACTER_:
11085       return FFEINFO_basictypeCHARACTER;
11086
11087     default:
11088       return FFEINFO_basictypeANY;
11089     }
11090 }
11091
11092 ffeinfoKindtype
11093 ffecom_gfrt_kindtype (ffecomGfrt gfrt)
11094 {
11095   assert (gfrt < FFECOM_gfrt);
11096
11097   switch (ffecom_gfrt_type_[gfrt])
11098     {
11099     case FFECOM_rttypeVOID_:
11100     case FFECOM_rttypeVOIDSTAR_:
11101       return FFEINFO_kindtypeNONE;
11102
11103     case FFECOM_rttypeFTNINT_:
11104       return FFEINFO_kindtypeINTEGER1;
11105
11106     case FFECOM_rttypeINTEGER_:
11107       return FFEINFO_kindtypeINTEGER1;
11108
11109     case FFECOM_rttypeLONGINT_:
11110       return FFEINFO_kindtypeINTEGER4;
11111
11112     case FFECOM_rttypeLOGICAL_:
11113       return FFEINFO_kindtypeLOGICAL1;
11114
11115     case FFECOM_rttypeREAL_F2C_:
11116     case FFECOM_rttypeREAL_GNU_:
11117       return FFEINFO_kindtypeREAL1;
11118
11119     case FFECOM_rttypeCOMPLEX_F2C_:
11120     case FFECOM_rttypeCOMPLEX_GNU_:
11121       return FFEINFO_kindtypeREAL1;
11122
11123     case FFECOM_rttypeDOUBLE_:
11124     case FFECOM_rttypeDOUBLEREAL_:
11125       return FFEINFO_kindtypeREAL2;
11126
11127     case FFECOM_rttypeDBLCMPLX_F2C_:
11128     case FFECOM_rttypeDBLCMPLX_GNU_:
11129       return FFEINFO_kindtypeREAL2;
11130
11131     case FFECOM_rttypeCHARACTER_:
11132       return FFEINFO_kindtypeCHARACTER1;
11133
11134     default:
11135       return FFEINFO_kindtypeANY;
11136     }
11137 }
11138
11139 void
11140 ffecom_init_0 ()
11141 {
11142   tree endlink;
11143   int i;
11144   int j;
11145   tree t;
11146   tree field;
11147   ffetype type;
11148   ffetype base_type;
11149   tree double_ftype_double;
11150   tree float_ftype_float;
11151   tree ldouble_ftype_ldouble;
11152   tree ffecom_tree_ptr_to_fun_type_void;
11153
11154   /* This block of code comes from the now-obsolete cktyps.c.  It checks
11155      whether the compiler environment is buggy in known ways, some of which
11156      would, if not explicitly checked here, result in subtle bugs in g77.  */
11157
11158   if (ffe_is_do_internal_checks ())
11159     {
11160       static const char names[][12]
11161         =
11162       {"bar", "bletch", "foo", "foobar"};
11163       const char *name;
11164       unsigned long ul;
11165       double fl;
11166
11167       name = bsearch ("foo", &names[0], ARRAY_SIZE (names), sizeof (names[0]),
11168                       (int (*)(const void *, const void *)) strcmp);
11169       if (name != &names[0][2])
11170         {
11171           assert ("bsearch doesn't work, #define FFEPROJ_BSEARCH 0 in proj.h"
11172                   == NULL);
11173           abort ();
11174         }
11175
11176       ul = strtoul ("123456789", NULL, 10);
11177       if (ul != 123456789L)
11178         {
11179           assert ("strtoul doesn't have enough range, #define FFEPROJ_STRTOUL 0\
11180  in proj.h" == NULL);
11181           abort ();
11182         }
11183
11184       fl = atof ("56.789");
11185       if ((fl < 56.788) || (fl > 56.79))
11186         {
11187           assert ("atof not type double, fix your #include <stdio.h>"
11188                   == NULL);
11189           abort ();
11190         }
11191     }
11192
11193   ffecom_outer_function_decl_ = NULL_TREE;
11194   current_function_decl = NULL_TREE;
11195   named_labels = NULL_TREE;
11196   current_binding_level = NULL_BINDING_LEVEL;
11197   free_binding_level = NULL_BINDING_LEVEL;
11198   /* Make the binding_level structure for global names.  */
11199   pushlevel (0);
11200   global_binding_level = current_binding_level;
11201   current_binding_level->prep_state = 2;
11202
11203   build_common_tree_nodes (1);
11204
11205   /* Define `int' and `char' first so that dbx will output them first.  */
11206   pushdecl (build_decl (TYPE_DECL, get_identifier ("int"),
11207                         integer_type_node));
11208   /* CHARACTER*1 is unsigned in ICHAR contexts.  */
11209   char_type_node = make_unsigned_type (CHAR_TYPE_SIZE);
11210   pushdecl (build_decl (TYPE_DECL, get_identifier ("char"),
11211                         char_type_node));
11212   pushdecl (build_decl (TYPE_DECL, get_identifier ("long int"),
11213                         long_integer_type_node));
11214   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned int"),
11215                         unsigned_type_node));
11216   pushdecl (build_decl (TYPE_DECL, get_identifier ("long unsigned int"),
11217                         long_unsigned_type_node));
11218   pushdecl (build_decl (TYPE_DECL, get_identifier ("long long int"),
11219                         long_long_integer_type_node));
11220   pushdecl (build_decl (TYPE_DECL, get_identifier ("long long unsigned int"),
11221                         long_long_unsigned_type_node));
11222   pushdecl (build_decl (TYPE_DECL, get_identifier ("short int"),
11223                         short_integer_type_node));
11224   pushdecl (build_decl (TYPE_DECL, get_identifier ("short unsigned int"),
11225                         short_unsigned_type_node));
11226
11227   /* Set the sizetype before we make other types.  This *should* be the
11228      first type we create.  */
11229
11230   set_sizetype
11231     (TREE_TYPE (IDENTIFIER_GLOBAL_VALUE (get_identifier (SIZE_TYPE))));
11232   ffecom_typesize_pointer_
11233     = TREE_INT_CST_LOW (TYPE_SIZE (sizetype)) / BITS_PER_UNIT;
11234
11235   build_common_tree_nodes_2 (0);
11236
11237   /* Define both `signed char' and `unsigned char'.  */
11238   pushdecl (build_decl (TYPE_DECL, get_identifier ("signed char"),
11239                         signed_char_type_node));
11240
11241   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned char"),
11242                         unsigned_char_type_node));
11243
11244   pushdecl (build_decl (TYPE_DECL, get_identifier ("float"),
11245                         float_type_node));
11246   pushdecl (build_decl (TYPE_DECL, get_identifier ("double"),
11247                         double_type_node));
11248   pushdecl (build_decl (TYPE_DECL, get_identifier ("long double"),
11249                         long_double_type_node));
11250
11251   /* For now, override what build_common_tree_nodes has done.  */
11252   complex_integer_type_node = ffecom_make_complex_type_ (integer_type_node);
11253   complex_float_type_node = ffecom_make_complex_type_ (float_type_node);
11254   complex_double_type_node = ffecom_make_complex_type_ (double_type_node);
11255   complex_long_double_type_node
11256     = ffecom_make_complex_type_ (long_double_type_node);
11257
11258   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex int"),
11259                         complex_integer_type_node));
11260   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex float"),
11261                         complex_float_type_node));
11262   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex double"),
11263                         complex_double_type_node));
11264   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex long double"),
11265                         complex_long_double_type_node));
11266
11267   pushdecl (build_decl (TYPE_DECL, get_identifier ("void"),
11268                         void_type_node));
11269   /* We are not going to have real types in C with less than byte alignment,
11270      so we might as well not have any types that claim to have it.  */
11271   TYPE_ALIGN (void_type_node) = BITS_PER_UNIT;
11272   TYPE_USER_ALIGN (void_type_node) = 0;
11273
11274   string_type_node = build_pointer_type (char_type_node);
11275
11276   ffecom_tree_fun_type_void
11277     = build_function_type (void_type_node, NULL_TREE);
11278
11279   ffecom_tree_ptr_to_fun_type_void
11280     = build_pointer_type (ffecom_tree_fun_type_void);
11281
11282   endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE);
11283
11284   float_ftype_float
11285     = build_function_type (float_type_node,
11286                            tree_cons (NULL_TREE, float_type_node, endlink));
11287
11288   double_ftype_double
11289     = build_function_type (double_type_node,
11290                            tree_cons (NULL_TREE, double_type_node, endlink));
11291
11292   ldouble_ftype_ldouble
11293     = build_function_type (long_double_type_node,
11294                            tree_cons (NULL_TREE, long_double_type_node,
11295                                       endlink));
11296
11297   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11298     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11299       {
11300         ffecom_tree_type[i][j] = NULL_TREE;
11301         ffecom_tree_fun_type[i][j] = NULL_TREE;
11302         ffecom_tree_ptr_to_fun_type[i][j] = NULL_TREE;
11303         ffecom_f2c_typecode_[i][j] = -1;
11304       }
11305
11306   /* Set up standard g77 types.  Note that INTEGER and LOGICAL are set
11307      to size FLOAT_TYPE_SIZE because they have to be the same size as
11308      REAL, which also is FLOAT_TYPE_SIZE, according to the standard.
11309      Compiler options and other such stuff that change the ways these
11310      types are set should not affect this particular setup.  */
11311
11312   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1]
11313     = t = make_signed_type (FLOAT_TYPE_SIZE);
11314   pushdecl (build_decl (TYPE_DECL, get_identifier ("integer"),
11315                         t));
11316   type = ffetype_new ();
11317   base_type = type;
11318   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER1,
11319                     type);
11320   ffetype_set_ams (type,
11321                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11322                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11323   ffetype_set_star (base_type,
11324                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11325                     type);
11326   ffetype_set_kind (base_type, 1, type);
11327   ffecom_typesize_integer1_ = ffetype_size (type);
11328   assert (ffetype_size (type) == sizeof (ffetargetInteger1));
11329
11330   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER1]
11331     = t = make_unsigned_type (FLOAT_TYPE_SIZE); /* HOLLERITH means unsigned. */
11332   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned"),
11333                         t));
11334
11335   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER2]
11336     = t = make_signed_type (CHAR_TYPE_SIZE);
11337   pushdecl (build_decl (TYPE_DECL, get_identifier ("byte"),
11338                         t));
11339   type = ffetype_new ();
11340   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER2,
11341                     type);
11342   ffetype_set_ams (type,
11343                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11344                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11345   ffetype_set_star (base_type,
11346                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11347                     type);
11348   ffetype_set_kind (base_type, 3, type);
11349   assert (ffetype_size (type) == sizeof (ffetargetInteger2));
11350
11351   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER2]
11352     = t = make_unsigned_type (CHAR_TYPE_SIZE);
11353   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned byte"),
11354                         t));
11355
11356   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER3]
11357     = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11358   pushdecl (build_decl (TYPE_DECL, get_identifier ("word"),
11359                         t));
11360   type = ffetype_new ();
11361   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER3,
11362                     type);
11363   ffetype_set_ams (type,
11364                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11365                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11366   ffetype_set_star (base_type,
11367                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11368                     type);
11369   ffetype_set_kind (base_type, 6, type);
11370   assert (ffetype_size (type) == sizeof (ffetargetInteger3));
11371
11372   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER3]
11373     = t = make_unsigned_type (CHAR_TYPE_SIZE * 2);
11374   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned word"),
11375                         t));
11376
11377   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER4]
11378     = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11379   pushdecl (build_decl (TYPE_DECL, get_identifier ("integer4"),
11380                         t));
11381   type = ffetype_new ();
11382   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER4,
11383                     type);
11384   ffetype_set_ams (type,
11385                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11386                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11387   ffetype_set_star (base_type,
11388                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11389                     type);
11390   ffetype_set_kind (base_type, 2, type);
11391   assert (ffetype_size (type) == sizeof (ffetargetInteger4));
11392
11393   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER4]
11394     = t = make_unsigned_type (FLOAT_TYPE_SIZE * 2);
11395   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned4"),
11396                         t));
11397
11398 #if 0
11399   if (ffe_is_do_internal_checks ()
11400       && LONG_TYPE_SIZE != FLOAT_TYPE_SIZE
11401       && LONG_TYPE_SIZE != CHAR_TYPE_SIZE
11402       && LONG_TYPE_SIZE != SHORT_TYPE_SIZE
11403       && LONG_TYPE_SIZE != LONG_LONG_TYPE_SIZE)
11404     {
11405       fprintf (stderr, "Sorry, no g77 support for LONG_TYPE_SIZE (%d bits) yet.\n",
11406                LONG_TYPE_SIZE);
11407     }
11408 #endif
11409
11410   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL1]
11411     = t = make_signed_type (FLOAT_TYPE_SIZE);
11412   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical"),
11413                         t));
11414   type = ffetype_new ();
11415   base_type = type;
11416   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL1,
11417                     type);
11418   ffetype_set_ams (type,
11419                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11420                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11421   ffetype_set_star (base_type,
11422                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11423                     type);
11424   ffetype_set_kind (base_type, 1, type);
11425   assert (ffetype_size (type) == sizeof (ffetargetLogical1));
11426
11427   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL2]
11428     = t = make_signed_type (CHAR_TYPE_SIZE);
11429   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical2"),
11430                         t));
11431   type = ffetype_new ();
11432   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL2,
11433                     type);
11434   ffetype_set_ams (type,
11435                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11436                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11437   ffetype_set_star (base_type,
11438                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11439                     type);
11440   ffetype_set_kind (base_type, 3, type);
11441   assert (ffetype_size (type) == sizeof (ffetargetLogical2));
11442
11443   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL3]
11444     = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11445   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical3"),
11446                         t));
11447   type = ffetype_new ();
11448   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL3,
11449                     type);
11450   ffetype_set_ams (type,
11451                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11452                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11453   ffetype_set_star (base_type,
11454                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11455                     type);
11456   ffetype_set_kind (base_type, 6, type);
11457   assert (ffetype_size (type) == sizeof (ffetargetLogical3));
11458
11459   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL4]
11460     = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11461   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical4"),
11462                         t));
11463   type = ffetype_new ();
11464   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL4,
11465                     type);
11466   ffetype_set_ams (type,
11467                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11468                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11469   ffetype_set_star (base_type,
11470                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11471                     type);
11472   ffetype_set_kind (base_type, 2, type);
11473   assert (ffetype_size (type) == sizeof (ffetargetLogical4));
11474
11475   ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11476     = t = make_node (REAL_TYPE);
11477   TYPE_PRECISION (t) = FLOAT_TYPE_SIZE;
11478   pushdecl (build_decl (TYPE_DECL, get_identifier ("real"),
11479                         t));
11480   layout_type (t);
11481   type = ffetype_new ();
11482   base_type = type;
11483   ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL1,
11484                     type);
11485   ffetype_set_ams (type,
11486                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11487                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11488   ffetype_set_star (base_type,
11489                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11490                     type);
11491   ffetype_set_kind (base_type, 1, type);
11492   ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11493     = FFETARGET_f2cTYREAL;
11494   assert (ffetype_size (type) == sizeof (ffetargetReal1));
11495
11496   ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREALDOUBLE]
11497     = t = make_node (REAL_TYPE);
11498   TYPE_PRECISION (t) = FLOAT_TYPE_SIZE * 2;     /* Always twice REAL. */
11499   pushdecl (build_decl (TYPE_DECL, get_identifier ("double precision"),
11500                         t));
11501   layout_type (t);
11502   type = ffetype_new ();
11503   ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE,
11504                     type);
11505   ffetype_set_ams (type,
11506                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11507                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11508   ffetype_set_star (base_type,
11509                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11510                     type);
11511   ffetype_set_kind (base_type, 2, type);
11512   ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]
11513     = FFETARGET_f2cTYDREAL;
11514   assert (ffetype_size (type) == sizeof (ffetargetReal2));
11515
11516   ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11517     = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]);
11518   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex"),
11519                         t));
11520   type = ffetype_new ();
11521   base_type = type;
11522   ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL1,
11523                     type);
11524   ffetype_set_ams (type,
11525                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11526                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11527   ffetype_set_star (base_type,
11528                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11529                     type);
11530   ffetype_set_kind (base_type, 1, type);
11531   ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11532     = FFETARGET_f2cTYCOMPLEX;
11533   assert (ffetype_size (type) == sizeof (ffetargetComplex1));
11534
11535   ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREALDOUBLE]
11536     = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]);
11537   pushdecl (build_decl (TYPE_DECL, get_identifier ("double complex"),
11538                         t));
11539   type = ffetype_new ();
11540   ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREALDOUBLE,
11541                     type);
11542   ffetype_set_ams (type,
11543                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11544                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11545   ffetype_set_star (base_type,
11546                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11547                     type);
11548   ffetype_set_kind (base_type, 2,
11549                     type);
11550   ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL2]
11551     = FFETARGET_f2cTYDCOMPLEX;
11552   assert (ffetype_size (type) == sizeof (ffetargetComplex2));
11553
11554   /* Make function and ptr-to-function types for non-CHARACTER types. */
11555
11556   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11557     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11558       {
11559         if ((t = ffecom_tree_type[i][j]) != NULL_TREE)
11560           {
11561             if (i == FFEINFO_basictypeINTEGER)
11562               {
11563                 /* Figure out the smallest INTEGER type that can hold
11564                    a pointer on this machine. */
11565                 if (GET_MODE_SIZE (TYPE_MODE (t))
11566                     >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
11567                   {
11568                     if ((ffecom_pointer_kind_ == FFEINFO_kindtypeNONE)
11569                         || (GET_MODE_SIZE (TYPE_MODE (ffecom_tree_type[i][ffecom_pointer_kind_]))
11570                             > GET_MODE_SIZE (TYPE_MODE (t))))
11571                       ffecom_pointer_kind_ = j;
11572                   }
11573               }
11574             else if (i == FFEINFO_basictypeCOMPLEX)
11575               t = void_type_node;
11576             /* For f2c compatibility, REAL functions are really
11577                implemented as DOUBLE PRECISION.  */
11578             else if ((i == FFEINFO_basictypeREAL)
11579                      && (j == FFEINFO_kindtypeREAL1))
11580               t = ffecom_tree_type
11581                 [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2];
11582
11583             t = ffecom_tree_fun_type[i][j] = build_function_type (t,
11584                                                                   NULL_TREE);
11585             ffecom_tree_ptr_to_fun_type[i][j] = build_pointer_type (t);
11586           }
11587       }
11588
11589   /* Set up pointer types.  */
11590
11591   if (ffecom_pointer_kind_ == FFEINFO_basictypeNONE)
11592     fatal_error ("no INTEGER type can hold a pointer on this configuration");
11593   else if (0 && ffe_is_do_internal_checks ())
11594     fprintf (stderr, "Pointer type kt=%d\n", ffecom_pointer_kind_);
11595   ffetype_set_kind (ffeinfo_type (FFEINFO_basictypeINTEGER,
11596                                   FFEINFO_kindtypeINTEGERDEFAULT),
11597                     7,
11598                     ffeinfo_type (FFEINFO_basictypeINTEGER,
11599                                   ffecom_pointer_kind_));
11600
11601   if (ffe_is_ugly_assign ())
11602     ffecom_label_kind_ = ffecom_pointer_kind_;  /* Require ASSIGN etc to this. */
11603   else
11604     ffecom_label_kind_ = FFEINFO_kindtypeINTEGERDEFAULT;
11605   if (0 && ffe_is_do_internal_checks ())
11606     fprintf (stderr, "Label type kt=%d\n", ffecom_label_kind_);
11607
11608   ffecom_integer_type_node
11609     = ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1];
11610   ffecom_integer_zero_node = convert (ffecom_integer_type_node,
11611                                       integer_zero_node);
11612   ffecom_integer_one_node = convert (ffecom_integer_type_node,
11613                                      integer_one_node);
11614
11615   /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional.
11616      Turns out that by TYLONG, runtime/libI77/lio.h really means
11617      "whatever size an ftnint is".  For consistency and sanity,
11618      com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen
11619      all are INTEGER, which we also make out of whatever back-end
11620      integer type is FLOAT_TYPE_SIZE bits wide.  This change, from
11621      LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to
11622      accommodate machines like the Alpha.  Note that this suggests
11623      f2c and libf2c are missing a distinction perhaps needed on
11624      some machines between "int" and "long int".  -- burley 0.5.5 950215 */
11625
11626   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, FLOAT_TYPE_SIZE,
11627                             FFETARGET_f2cTYLONG);
11628   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, SHORT_TYPE_SIZE,
11629                             FFETARGET_f2cTYSHORT);
11630   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, CHAR_TYPE_SIZE,
11631                             FFETARGET_f2cTYINT1);
11632   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, LONG_LONG_TYPE_SIZE,
11633                             FFETARGET_f2cTYQUAD);
11634   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, FLOAT_TYPE_SIZE,
11635                             FFETARGET_f2cTYLOGICAL);
11636   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, SHORT_TYPE_SIZE,
11637                             FFETARGET_f2cTYLOGICAL2);
11638   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, CHAR_TYPE_SIZE,
11639                             FFETARGET_f2cTYLOGICAL1);
11640   /* ~~~Not really such a type in libf2c, e.g. I/O support?  */
11641   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, LONG_LONG_TYPE_SIZE,
11642                             FFETARGET_f2cTYQUAD);
11643
11644   /* CHARACTER stuff is all special-cased, so it is not handled in the above
11645      loop.  CHARACTER items are built as arrays of unsigned char.  */
11646
11647   ffecom_tree_type[FFEINFO_basictypeCHARACTER]
11648     [FFEINFO_kindtypeCHARACTER1] = t = char_type_node;
11649   type = ffetype_new ();
11650   base_type = type;
11651   ffeinfo_set_type (FFEINFO_basictypeCHARACTER,
11652                     FFEINFO_kindtypeCHARACTER1,
11653                     type);
11654   ffetype_set_ams (type,
11655                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11656                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11657   ffetype_set_kind (base_type, 1, type);
11658   assert (ffetype_size (type)
11659           == sizeof (((ffetargetCharacter1) { 0, NULL }).text[0]));
11660
11661   ffecom_tree_fun_type[FFEINFO_basictypeCHARACTER]
11662     [FFEINFO_kindtypeCHARACTER1] = ffecom_tree_fun_type_void;
11663   ffecom_tree_ptr_to_fun_type[FFEINFO_basictypeCHARACTER]
11664     [FFEINFO_kindtypeCHARACTER1]
11665     = ffecom_tree_ptr_to_fun_type_void;
11666   ffecom_f2c_typecode_[FFEINFO_basictypeCHARACTER][FFEINFO_kindtypeCHARACTER1]
11667     = FFETARGET_f2cTYCHAR;
11668
11669   ffecom_f2c_typecode_[FFEINFO_basictypeANY][FFEINFO_kindtypeANY]
11670     = 0;
11671
11672   /* Make multi-return-value type and fields. */
11673
11674   ffecom_multi_type_node_ = make_node (UNION_TYPE);
11675
11676   field = NULL_TREE;
11677
11678   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11679     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11680       {
11681         char name[30];
11682
11683         if (ffecom_tree_type[i][j] == NULL_TREE)
11684           continue;             /* Not supported. */
11685         sprintf (&name[0], "bt_%s_kt_%s",
11686                  ffeinfo_basictype_string ((ffeinfoBasictype) i),
11687                  ffeinfo_kindtype_string ((ffeinfoKindtype) j));
11688         ffecom_multi_fields_[i][j] = build_decl (FIELD_DECL,
11689                                                  get_identifier (name),
11690                                                  ffecom_tree_type[i][j]);
11691         DECL_CONTEXT (ffecom_multi_fields_[i][j])
11692           = ffecom_multi_type_node_;
11693         DECL_ALIGN (ffecom_multi_fields_[i][j]) = 0;
11694         DECL_USER_ALIGN (ffecom_multi_fields_[i][j]) = 0;
11695         TREE_CHAIN (ffecom_multi_fields_[i][j]) = field;
11696         field = ffecom_multi_fields_[i][j];
11697       }
11698
11699   TYPE_FIELDS (ffecom_multi_type_node_) = field;
11700   layout_type (ffecom_multi_type_node_);
11701
11702   /* Subroutines usually return integer because they might have alternate
11703      returns. */
11704
11705   ffecom_tree_subr_type
11706     = build_function_type (integer_type_node, NULL_TREE);
11707   ffecom_tree_ptr_to_subr_type
11708     = build_pointer_type (ffecom_tree_subr_type);
11709   ffecom_tree_blockdata_type
11710     = build_function_type (void_type_node, NULL_TREE);
11711
11712   builtin_function ("__builtin_sqrtf", float_ftype_float,
11713                     BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrtf");
11714   builtin_function ("__builtin_fsqrt", double_ftype_double,
11715                     BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrt");
11716   builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble,
11717                     BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrtl");
11718   builtin_function ("__builtin_sinf", float_ftype_float,
11719                     BUILT_IN_SIN, BUILT_IN_NORMAL, "sinf");
11720   builtin_function ("__builtin_sin", double_ftype_double,
11721                     BUILT_IN_SIN, BUILT_IN_NORMAL, "sin");
11722   builtin_function ("__builtin_sinl", ldouble_ftype_ldouble,
11723                     BUILT_IN_SIN, BUILT_IN_NORMAL, "sinl");
11724   builtin_function ("__builtin_cosf", float_ftype_float,
11725                     BUILT_IN_COS, BUILT_IN_NORMAL, "cosf");
11726   builtin_function ("__builtin_cos", double_ftype_double,
11727                     BUILT_IN_COS, BUILT_IN_NORMAL, "cos");
11728   builtin_function ("__builtin_cosl", ldouble_ftype_ldouble,
11729                     BUILT_IN_COS, BUILT_IN_NORMAL, "cosl");
11730
11731   pedantic_lvalues = FALSE;
11732
11733   ffecom_f2c_make_type_ (&ffecom_f2c_integer_type_node,
11734                          FFECOM_f2cINTEGER,
11735                          "integer");
11736   ffecom_f2c_make_type_ (&ffecom_f2c_address_type_node,
11737                          FFECOM_f2cADDRESS,
11738                          "address");
11739   ffecom_f2c_make_type_ (&ffecom_f2c_real_type_node,
11740                          FFECOM_f2cREAL,
11741                          "real");
11742   ffecom_f2c_make_type_ (&ffecom_f2c_doublereal_type_node,
11743                          FFECOM_f2cDOUBLEREAL,
11744                          "doublereal");
11745   ffecom_f2c_make_type_ (&ffecom_f2c_complex_type_node,
11746                          FFECOM_f2cCOMPLEX,
11747                          "complex");
11748   ffecom_f2c_make_type_ (&ffecom_f2c_doublecomplex_type_node,
11749                          FFECOM_f2cDOUBLECOMPLEX,
11750                          "doublecomplex");
11751   ffecom_f2c_make_type_ (&ffecom_f2c_longint_type_node,
11752                          FFECOM_f2cLONGINT,
11753                          "longint");
11754   ffecom_f2c_make_type_ (&ffecom_f2c_logical_type_node,
11755                          FFECOM_f2cLOGICAL,
11756                          "logical");
11757   ffecom_f2c_make_type_ (&ffecom_f2c_flag_type_node,
11758                          FFECOM_f2cFLAG,
11759                          "flag");
11760   ffecom_f2c_make_type_ (&ffecom_f2c_ftnlen_type_node,
11761                          FFECOM_f2cFTNLEN,
11762                          "ftnlen");
11763   ffecom_f2c_make_type_ (&ffecom_f2c_ftnint_type_node,
11764                          FFECOM_f2cFTNINT,
11765                          "ftnint");
11766
11767   ffecom_f2c_ftnlen_zero_node
11768     = convert (ffecom_f2c_ftnlen_type_node, integer_zero_node);
11769
11770   ffecom_f2c_ftnlen_one_node
11771     = convert (ffecom_f2c_ftnlen_type_node, integer_one_node);
11772
11773   ffecom_f2c_ftnlen_two_node = build_int_2 (2, 0);
11774   TREE_TYPE (ffecom_f2c_ftnlen_two_node) = ffecom_integer_type_node;
11775
11776   ffecom_f2c_ptr_to_ftnlen_type_node
11777     = build_pointer_type (ffecom_f2c_ftnlen_type_node);
11778
11779   ffecom_f2c_ptr_to_ftnint_type_node
11780     = build_pointer_type (ffecom_f2c_ftnint_type_node);
11781
11782   ffecom_f2c_ptr_to_integer_type_node
11783     = build_pointer_type (ffecom_f2c_integer_type_node);
11784
11785   ffecom_f2c_ptr_to_real_type_node
11786     = build_pointer_type (ffecom_f2c_real_type_node);
11787
11788   ffecom_float_zero_ = build_real (float_type_node, dconst0);
11789   ffecom_double_zero_ = build_real (double_type_node, dconst0);
11790   {
11791     REAL_VALUE_TYPE point_5;
11792
11793 #ifdef REAL_ARITHMETIC
11794     REAL_ARITHMETIC (point_5, RDIV_EXPR, dconst1, dconst2);
11795 #else
11796     point_5 = .5;
11797 #endif
11798     ffecom_float_half_ = build_real (float_type_node, point_5);
11799     ffecom_double_half_ = build_real (double_type_node, point_5);
11800   }
11801
11802   /* Do "extern int xargc;".  */
11803
11804   ffecom_tree_xargc_ = build_decl (VAR_DECL,
11805                                    get_identifier ("f__xargc"),
11806                                    integer_type_node);
11807   DECL_EXTERNAL (ffecom_tree_xargc_) = 1;
11808   TREE_STATIC (ffecom_tree_xargc_) = 1;
11809   TREE_PUBLIC (ffecom_tree_xargc_) = 1;
11810   ffecom_tree_xargc_ = start_decl (ffecom_tree_xargc_, FALSE);
11811   finish_decl (ffecom_tree_xargc_, NULL_TREE, FALSE);
11812
11813 #if 0   /* This is being fixed, and seems to be working now. */
11814   if ((FLOAT_TYPE_SIZE != 32)
11815       || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))) != 32))
11816     {
11817       warning ("configuration: REAL, INTEGER, and LOGICAL are %d bits wide,",
11818                (int) FLOAT_TYPE_SIZE);
11819       warning ("and pointers are %d bits wide, but g77 doesn't yet work",
11820           (int) TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))));
11821       warning ("properly unless they all are 32 bits wide.");
11822       warning ("Please keep this in mind before you report bugs.  g77 should");
11823       warning ("support non-32-bit machines better as of version 0.6.");
11824     }
11825 #endif
11826
11827 #if 0   /* Code in ste.c that would crash has been commented out. */
11828   if (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)
11829       < TYPE_PRECISION (string_type_node))
11830     /* I/O will probably crash.  */
11831     warning ("configuration: char * holds %d bits, but ftnlen only %d",
11832              TYPE_PRECISION (string_type_node),
11833              TYPE_PRECISION (ffecom_f2c_ftnlen_type_node));
11834 #endif
11835
11836 #if 0   /* ASSIGN-related stuff has been changed to accommodate this. */
11837   if (TYPE_PRECISION (ffecom_integer_type_node)
11838       < TYPE_PRECISION (string_type_node))
11839     /* ASSIGN 10 TO I will crash.  */
11840     warning ("configuration: char * holds %d bits, but INTEGER only %d --\n\
11841  ASSIGN statement might fail",
11842              TYPE_PRECISION (string_type_node),
11843              TYPE_PRECISION (ffecom_integer_type_node));
11844 #endif
11845 }
11846
11847 /* ffecom_init_2 -- Initialize
11848
11849    ffecom_init_2();  */
11850
11851 void
11852 ffecom_init_2 ()
11853 {
11854   assert (ffecom_outer_function_decl_ == NULL_TREE);
11855   assert (current_function_decl == NULL_TREE);
11856   assert (ffecom_which_entrypoint_decl_ == NULL_TREE);
11857
11858   ffecom_master_arglist_ = NULL;
11859   ++ffecom_num_fns_;
11860   ffecom_primary_entry_ = NULL;
11861   ffecom_is_altreturning_ = FALSE;
11862   ffecom_func_result_ = NULL_TREE;
11863   ffecom_multi_retval_ = NULL_TREE;
11864 }
11865
11866 /* ffecom_list_expr -- Transform list of exprs into gcc tree
11867
11868    tree t;
11869    ffebld expr;  // FFE opITEM list.
11870    tree = ffecom_list_expr(expr);
11871
11872    List of actual args is transformed into corresponding gcc backend list.  */
11873
11874 tree
11875 ffecom_list_expr (ffebld expr)
11876 {
11877   tree list;
11878   tree *plist = &list;
11879   tree trail = NULL_TREE;       /* Append char length args here. */
11880   tree *ptrail = &trail;
11881   tree length;
11882
11883   while (expr != NULL)
11884     {
11885       tree texpr = ffecom_arg_expr (ffebld_head (expr), &length);
11886
11887       if (texpr == error_mark_node)
11888         return error_mark_node;
11889
11890       *plist = build_tree_list (NULL_TREE, texpr);
11891       plist = &TREE_CHAIN (*plist);
11892       expr = ffebld_trail (expr);
11893       if (length != NULL_TREE)
11894         {
11895           *ptrail = build_tree_list (NULL_TREE, length);
11896           ptrail = &TREE_CHAIN (*ptrail);
11897         }
11898     }
11899
11900   *plist = trail;
11901
11902   return list;
11903 }
11904
11905 /* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree
11906
11907    tree t;
11908    ffebld expr;  // FFE opITEM list.
11909    tree = ffecom_list_ptr_to_expr(expr);
11910
11911    List of actual args is transformed into corresponding gcc backend list for
11912    use in calling an external procedure (vs. a statement function).  */
11913
11914 tree
11915 ffecom_list_ptr_to_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_ptr_to_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 /* Obtain gcc's LABEL_DECL tree for label.  */
11946
11947 tree
11948 ffecom_lookup_label (ffelab label)
11949 {
11950   tree glabel;
11951
11952   if (ffelab_hook (label) == NULL_TREE)
11953     {
11954       char labelname[16];
11955
11956       switch (ffelab_type (label))
11957         {
11958         case FFELAB_typeLOOPEND:
11959         case FFELAB_typeNOTLOOP:
11960         case FFELAB_typeENDIF:
11961           sprintf (labelname, "%" ffelabValue_f "u", ffelab_value (label));
11962           glabel = build_decl (LABEL_DECL, get_identifier (labelname),
11963                                void_type_node);
11964           DECL_CONTEXT (glabel) = current_function_decl;
11965           DECL_MODE (glabel) = VOIDmode;
11966           break;
11967
11968         case FFELAB_typeFORMAT:
11969           glabel = build_decl (VAR_DECL,
11970                                ffecom_get_invented_identifier
11971                                ("__g77_format_%d", (int) ffelab_value (label)),
11972                                build_type_variant (build_array_type
11973                                                    (char_type_node,
11974                                                     NULL_TREE),
11975                                                    1, 0));
11976           TREE_CONSTANT (glabel) = 1;
11977           TREE_STATIC (glabel) = 1;
11978           DECL_CONTEXT (glabel) = current_function_decl;
11979           DECL_INITIAL (glabel) = NULL;
11980           make_decl_rtl (glabel, NULL);
11981           expand_decl (glabel);
11982
11983           ffecom_save_tree_forever (glabel);
11984
11985           break;
11986
11987         case FFELAB_typeANY:
11988           glabel = error_mark_node;
11989           break;
11990
11991         default:
11992           assert ("bad label type" == NULL);
11993           glabel = NULL;
11994           break;
11995         }
11996       ffelab_set_hook (label, glabel);
11997     }
11998   else
11999     {
12000       glabel = ffelab_hook (label);
12001     }
12002
12003   return glabel;
12004 }
12005
12006 /* Stabilizes the arguments.  Don't use this if the lhs and rhs come from
12007    a single source specification (as in the fourth argument of MVBITS).
12008    If the type is NULL_TREE, the type of lhs is used to make the type of
12009    the MODIFY_EXPR.  */
12010
12011 tree
12012 ffecom_modify (tree newtype, tree lhs,
12013                tree rhs)
12014 {
12015   if (lhs == error_mark_node || rhs == error_mark_node)
12016     return error_mark_node;
12017
12018   if (newtype == NULL_TREE)
12019     newtype = TREE_TYPE (lhs);
12020
12021   if (TREE_SIDE_EFFECTS (lhs))
12022     lhs = stabilize_reference (lhs);
12023
12024   return ffecom_2s (MODIFY_EXPR, newtype, lhs, rhs);
12025 }
12026
12027 /* Register source file name.  */
12028
12029 void
12030 ffecom_file (const char *name)
12031 {
12032   ffecom_file_ (name);
12033 }
12034
12035 /* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed
12036
12037    ffestorag st;
12038    ffecom_notify_init_storage(st);
12039
12040    Gets called when all possible units in an aggregate storage area (a LOCAL
12041    with equivalences or a COMMON) have been initialized.  The initialization
12042    info either is in ffestorag_init or, if that is NULL,
12043    ffestorag_accretion:
12044
12045    ffestorag_init may contain an opCONTER or opARRTER.  opCONTER may occur
12046    even for an array if the array is one element in length!
12047
12048    ffestorag_accretion will contain an opACCTER.  It is much like an
12049    opARRTER except it has an ffebit object in it instead of just a size.
12050    The back end can use the info in the ffebit object, if it wants, to
12051    reduce the amount of actual initialization, but in any case it should
12052    kill the ffebit object when done.  Also, set accretion to NULL but
12053    init to a non-NULL value.
12054
12055    After performing initialization, DO NOT set init to NULL, because that'll
12056    tell the front end it is ok for more initialization to happen.  Instead,
12057    set init to an opANY expression or some such thing that you can use to
12058    tell that you've already initialized the object.
12059
12060    27-Oct-91  JCB  1.1
12061       Support two-pass FFE.  */
12062
12063 void
12064 ffecom_notify_init_storage (ffestorag st)
12065 {
12066   ffebld init;                  /* The initialization expression. */
12067
12068   if (ffestorag_init (st) == NULL)
12069     {
12070       init = ffestorag_accretion (st);
12071       assert (init != NULL);
12072       ffestorag_set_accretion (st, NULL);
12073       ffestorag_set_accretes (st, 0);
12074       ffestorag_set_init (st, init);
12075     }
12076 }
12077
12078 /* ffecom_notify_init_symbol -- A symbol is now fully init'ed
12079
12080    ffesymbol s;
12081    ffecom_notify_init_symbol(s);
12082
12083    Gets called when all possible units in a symbol (not placed in COMMON
12084    or involved in EQUIVALENCE, unless it as yet has no ffestorag object)
12085    have been initialized.  The initialization info either is in
12086    ffesymbol_init or, if that is NULL, ffesymbol_accretion:
12087
12088    ffesymbol_init may contain an opCONTER or opARRTER.  opCONTER may occur
12089    even for an array if the array is one element in length!
12090
12091    ffesymbol_accretion will contain an opACCTER.  It is much like an
12092    opARRTER except it has an ffebit object in it instead of just a size.
12093    The back end can use the info in the ffebit object, if it wants, to
12094    reduce the amount of actual initialization, but in any case it should
12095    kill the ffebit object when done.  Also, set accretion to NULL but
12096    init to a non-NULL value.
12097
12098    After performing initialization, DO NOT set init to NULL, because that'll
12099    tell the front end it is ok for more initialization to happen.  Instead,
12100    set init to an opANY expression or some such thing that you can use to
12101    tell that you've already initialized the object.
12102
12103    27-Oct-91  JCB  1.1
12104       Support two-pass FFE.  */
12105
12106 void
12107 ffecom_notify_init_symbol (ffesymbol s)
12108 {
12109   ffebld init;                  /* The initialization expression. */
12110
12111   if (ffesymbol_storage (s) == NULL)
12112     return;                     /* Do nothing until COMMON/EQUIVALENCE
12113                                    possibilities checked. */
12114
12115   if ((ffesymbol_init (s) == NULL)
12116       && ((init = ffesymbol_accretion (s)) != NULL))
12117     {
12118       ffesymbol_set_accretion (s, NULL);
12119       ffesymbol_set_accretes (s, 0);
12120       ffesymbol_set_init (s, init);
12121     }
12122 }
12123
12124 /* ffecom_notify_primary_entry -- Learn which is the primary entry point
12125
12126    ffesymbol s;
12127    ffecom_notify_primary_entry(s);
12128
12129    Gets called when implicit or explicit PROGRAM statement seen or when
12130    FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary
12131    global symbol that serves as the entry point.  */
12132
12133 void
12134 ffecom_notify_primary_entry (ffesymbol s)
12135 {
12136   ffecom_primary_entry_ = s;
12137   ffecom_primary_entry_kind_ = ffesymbol_kind (s);
12138
12139   if ((ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
12140       || (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE))
12141     ffecom_primary_entry_is_proc_ = TRUE;
12142   else
12143     ffecom_primary_entry_is_proc_ = FALSE;
12144
12145   if (!ffe_is_silent ())
12146     {
12147       if (ffecom_primary_entry_kind_ == FFEINFO_kindPROGRAM)
12148         fprintf (stderr, "%s:\n", ffesymbol_text (s));
12149       else
12150         fprintf (stderr, "  %s:\n", ffesymbol_text (s));
12151     }
12152
12153   if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
12154     {
12155       ffebld list;
12156       ffebld arg;
12157
12158       for (list = ffesymbol_dummyargs (s);
12159            list != NULL;
12160            list = ffebld_trail (list))
12161         {
12162           arg = ffebld_head (list);
12163           if (ffebld_op (arg) == FFEBLD_opSTAR)
12164             {
12165               ffecom_is_altreturning_ = TRUE;
12166               break;
12167             }
12168         }
12169     }
12170 }
12171
12172 FILE *
12173 ffecom_open_include (char *name, ffewhereLine l, ffewhereColumn c)
12174 {
12175   return ffecom_open_include_ (name, l, c);
12176 }
12177
12178 /* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front
12179
12180    tree t;
12181    ffebld expr;  // FFE expression.
12182    tree = ffecom_ptr_to_expr(expr);
12183
12184    Like ffecom_expr, but sticks address-of in front of most things.  */
12185
12186 tree
12187 ffecom_ptr_to_expr (ffebld expr)
12188 {
12189   tree item;
12190   ffeinfoBasictype bt;
12191   ffeinfoKindtype kt;
12192   ffesymbol s;
12193
12194   assert (expr != NULL);
12195
12196   switch (ffebld_op (expr))
12197     {
12198     case FFEBLD_opSYMTER:
12199       s = ffebld_symter (expr);
12200       if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
12201         {
12202           ffecomGfrt ix;
12203
12204           ix = ffeintrin_gfrt_indirect (ffebld_symter_implementation (expr));
12205           assert (ix != FFECOM_gfrt);
12206           if ((item = ffecom_gfrt_[ix]) == NULL_TREE)
12207             {
12208               ffecom_make_gfrt_ (ix);
12209               item = ffecom_gfrt_[ix];
12210             }
12211         }
12212       else
12213         {
12214           item = ffesymbol_hook (s).decl_tree;
12215           if (item == NULL_TREE)
12216             {
12217               s = ffecom_sym_transform_ (s);
12218               item = ffesymbol_hook (s).decl_tree;
12219             }
12220         }
12221       assert (item != NULL);
12222       if (item == error_mark_node)
12223         return item;
12224       if (!ffesymbol_hook (s).addr)
12225         item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12226                          item);
12227       return item;
12228
12229     case FFEBLD_opARRAYREF:
12230       return ffecom_arrayref_ (NULL_TREE, expr, 1);
12231
12232     case FFEBLD_opCONTER:
12233
12234       bt = ffeinfo_basictype (ffebld_info (expr));
12235       kt = ffeinfo_kindtype (ffebld_info (expr));
12236
12237       item = ffecom_constantunion (&ffebld_constant_union
12238                                    (ffebld_conter (expr)), bt, kt,
12239                                    ffecom_tree_type[bt][kt]);
12240       if (item == error_mark_node)
12241         return error_mark_node;
12242       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12243                        item);
12244       return item;
12245
12246     case FFEBLD_opANY:
12247       return error_mark_node;
12248
12249     default:
12250       bt = ffeinfo_basictype (ffebld_info (expr));
12251       kt = ffeinfo_kindtype (ffebld_info (expr));
12252
12253       item = ffecom_expr (expr);
12254       if (item == error_mark_node)
12255         return error_mark_node;
12256
12257       /* The back end currently optimizes a bit too zealously for us, in that
12258          we fail JCB001 if the following block of code is omitted.  It checks
12259          to see if the transformed expression is a symbol or array reference,
12260          and encloses it in a SAVE_EXPR if that is the case.  */
12261
12262       STRIP_NOPS (item);
12263       if ((TREE_CODE (item) == VAR_DECL)
12264           || (TREE_CODE (item) == PARM_DECL)
12265           || (TREE_CODE (item) == RESULT_DECL)
12266           || (TREE_CODE (item) == INDIRECT_REF)
12267           || (TREE_CODE (item) == ARRAY_REF)
12268           || (TREE_CODE (item) == COMPONENT_REF)
12269 #ifdef OFFSET_REF
12270           || (TREE_CODE (item) == OFFSET_REF)
12271 #endif
12272           || (TREE_CODE (item) == BUFFER_REF)
12273           || (TREE_CODE (item) == REALPART_EXPR)
12274           || (TREE_CODE (item) == IMAGPART_EXPR))
12275         {
12276           item = ffecom_save_tree (item);
12277         }
12278
12279       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12280                        item);
12281       return item;
12282     }
12283
12284   assert ("fall-through error" == NULL);
12285   return error_mark_node;
12286 }
12287
12288 /* Obtain a temp var with given data type.
12289
12290    size is FFETARGET_charactersizeNONE for a non-CHARACTER type
12291    or >= 0 for a CHARACTER type.
12292
12293    elements is -1 for a scalar or > 0 for an array of type.  */
12294
12295 tree
12296 ffecom_make_tempvar (const char *commentary, tree type,
12297                      ffetargetCharacterSize size, int elements)
12298 {
12299   tree t;
12300   static int mynumber;
12301
12302   assert (current_binding_level->prep_state < 2);
12303
12304   if (type == error_mark_node)
12305     return error_mark_node;
12306
12307   if (size != FFETARGET_charactersizeNONE)
12308     type = build_array_type (type,
12309                              build_range_type (ffecom_f2c_ftnlen_type_node,
12310                                                ffecom_f2c_ftnlen_one_node,
12311                                                build_int_2 (size, 0)));
12312   if (elements != -1)
12313     type = build_array_type (type,
12314                              build_range_type (integer_type_node,
12315                                                integer_zero_node,
12316                                                build_int_2 (elements - 1,
12317                                                             0)));
12318   t = build_decl (VAR_DECL,
12319                   ffecom_get_invented_identifier ("__g77_%s_%d",
12320                                                   commentary,
12321                                                   mynumber++),
12322                   type);
12323
12324   t = start_decl (t, FALSE);
12325   finish_decl (t, NULL_TREE, FALSE);
12326
12327   return t;
12328 }
12329
12330 /* Prepare argument pointer to expression.
12331
12332    Like ffecom_prepare_expr, except for expressions to be evaluated
12333    via ffecom_arg_ptr_to_expr.  */
12334
12335 void
12336 ffecom_prepare_arg_ptr_to_expr (ffebld expr)
12337 {
12338   /* ~~For now, it seems to be the same thing.  */
12339   ffecom_prepare_expr (expr);
12340   return;
12341 }
12342
12343 /* End of preparations.  */
12344
12345 bool
12346 ffecom_prepare_end (void)
12347 {
12348   int prep_state = current_binding_level->prep_state;
12349
12350   assert (prep_state < 2);
12351   current_binding_level->prep_state = 2;
12352
12353   return (prep_state == 1) ? TRUE : FALSE;
12354 }
12355
12356 /* Prepare expression.
12357
12358    This is called before any code is generated for the current block.
12359    It scans the expression, declares any temporaries that might be needed
12360    during evaluation of the expression, and stores those temporaries in
12361    the appropriate "hook" fields of the expression.  `dest', if not NULL,
12362    specifies the destination that ffecom_expr_ will see, in case that
12363    helps avoid generating unused temporaries.
12364
12365    ~~Improve to avoid allocating unused temporaries by taking `dest'
12366    into account vis-a-vis aliasing requirements of complex/character
12367    functions.  */
12368
12369 void
12370 ffecom_prepare_expr_ (ffebld expr, ffebld dest UNUSED)
12371 {
12372   ffeinfoBasictype bt;
12373   ffeinfoKindtype kt;
12374   ffetargetCharacterSize sz;
12375   tree tempvar = NULL_TREE;
12376
12377   assert (current_binding_level->prep_state < 2);
12378
12379   if (! expr)
12380     return;
12381
12382   bt = ffeinfo_basictype (ffebld_info (expr));
12383   kt = ffeinfo_kindtype (ffebld_info (expr));
12384   sz = ffeinfo_size (ffebld_info (expr));
12385
12386   /* Generate whatever temporaries are needed to represent the result
12387      of the expression.  */
12388
12389   if (bt == FFEINFO_basictypeCHARACTER)
12390     {
12391       while (ffebld_op (expr) == FFEBLD_opPAREN)
12392         expr = ffebld_left (expr);
12393     }
12394
12395   switch (ffebld_op (expr))
12396     {
12397     default:
12398       /* Don't make temps for SYMTER, CONTER, etc.  */
12399       if (ffebld_arity (expr) == 0)
12400         break;
12401
12402       switch (bt)
12403         {
12404         case FFEINFO_basictypeCOMPLEX:
12405           if (ffebld_op (expr) == FFEBLD_opFUNCREF)
12406             {
12407               ffesymbol s;
12408
12409               if (ffebld_op (ffebld_left (expr)) != FFEBLD_opSYMTER)
12410                 break;
12411
12412               s = ffebld_symter (ffebld_left (expr));
12413               if (ffesymbol_where (s) == FFEINFO_whereCONSTANT
12414                   || (ffesymbol_where (s) != FFEINFO_whereINTRINSIC
12415                       && ! ffesymbol_is_f2c (s))
12416                   || (ffesymbol_where (s) == FFEINFO_whereINTRINSIC
12417                       && ! ffe_is_f2c_library ()))
12418                 break;
12419             }
12420           else if (ffebld_op (expr) == FFEBLD_opPOWER)
12421             {
12422               /* Requires special treatment.  There's no POW_CC function
12423                  in libg2c, so POW_ZZ is used, which means we always
12424                  need a double-complex temp, not a single-complex.  */
12425               kt = FFEINFO_kindtypeREAL2;
12426             }
12427           else if (ffebld_op (expr) != FFEBLD_opDIVIDE)
12428             /* The other ops don't need temps for complex operands.  */
12429             break;
12430
12431           /* ~~~Avoid making temps for some intrinsics, such as AIMAG(C),
12432              REAL(C).  See 19990325-0.f, routine `check', for cases.  */
12433           tempvar = ffecom_make_tempvar ("complex",
12434                                          ffecom_tree_type
12435                                          [FFEINFO_basictypeCOMPLEX][kt],
12436                                          FFETARGET_charactersizeNONE,
12437                                          -1);
12438           break;
12439
12440         case FFEINFO_basictypeCHARACTER:
12441           if (ffebld_op (expr) != FFEBLD_opFUNCREF)
12442             break;
12443
12444           if (sz == FFETARGET_charactersizeNONE)
12445             /* ~~Kludge alert!  This should someday be fixed. */
12446             sz = 24;
12447
12448           tempvar = ffecom_make_tempvar ("char", char_type_node, sz, -1);
12449           break;
12450
12451         default:
12452           break;
12453         }
12454       break;
12455
12456 #ifdef HAHA
12457     case FFEBLD_opPOWER:
12458       {
12459         tree rtype, ltype;
12460         tree rtmp, ltmp, result;
12461
12462         ltype = ffecom_type_expr (ffebld_left (expr));
12463         rtype = ffecom_type_expr (ffebld_right (expr));
12464
12465         rtmp = ffecom_make_tempvar (rtype, FFETARGET_charactersizeNONE, -1);
12466         ltmp = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
12467         result = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
12468
12469         tempvar = make_tree_vec (3);
12470         TREE_VEC_ELT (tempvar, 0) = rtmp;
12471         TREE_VEC_ELT (tempvar, 1) = ltmp;
12472         TREE_VEC_ELT (tempvar, 2) = result;
12473       }
12474       break;
12475 #endif  /* HAHA */
12476
12477     case FFEBLD_opCONCATENATE:
12478       {
12479         /* This gets special handling, because only one set of temps
12480            is needed for a tree of these -- the tree is treated as
12481            a flattened list of concatenations when generating code.  */
12482
12483         ffecomConcatList_ catlist;
12484         tree ltmp, itmp, result;
12485         int count;
12486         int i;
12487
12488         catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
12489         count = ffecom_concat_list_count_ (catlist);
12490
12491         if (count >= 2)
12492           {
12493             ltmp
12494               = ffecom_make_tempvar ("concat_len",
12495                                      ffecom_f2c_ftnlen_type_node,
12496                                      FFETARGET_charactersizeNONE, count);
12497             itmp
12498               = ffecom_make_tempvar ("concat_item",
12499                                      ffecom_f2c_address_type_node,
12500                                      FFETARGET_charactersizeNONE, count);
12501             result
12502               = ffecom_make_tempvar ("concat_res",
12503                                      char_type_node,
12504                                      ffecom_concat_list_maxlen_ (catlist),
12505                                      -1);
12506
12507             tempvar = make_tree_vec (3);
12508             TREE_VEC_ELT (tempvar, 0) = ltmp;
12509             TREE_VEC_ELT (tempvar, 1) = itmp;
12510             TREE_VEC_ELT (tempvar, 2) = result;
12511           }
12512
12513         for (i = 0; i < count; ++i)
12514           ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist,
12515                                                                     i));
12516
12517         ffecom_concat_list_kill_ (catlist);
12518
12519         if (tempvar)
12520           {
12521             ffebld_nonter_set_hook (expr, tempvar);
12522             current_binding_level->prep_state = 1;
12523           }
12524       }
12525       return;
12526
12527     case FFEBLD_opCONVERT:
12528       if (bt == FFEINFO_basictypeCHARACTER
12529           && ((ffebld_size_known (ffebld_left (expr))
12530                == FFETARGET_charactersizeNONE)
12531               || (ffebld_size_known (ffebld_left (expr)) >= sz)))
12532         tempvar = ffecom_make_tempvar ("convert", char_type_node, sz, -1);
12533       break;
12534     }
12535
12536   if (tempvar)
12537     {
12538       ffebld_nonter_set_hook (expr, tempvar);
12539       current_binding_level->prep_state = 1;
12540     }
12541
12542   /* Prepare subexpressions for this expr.  */
12543
12544   switch (ffebld_op (expr))
12545     {
12546     case FFEBLD_opPERCENT_LOC:
12547       ffecom_prepare_ptr_to_expr (ffebld_left (expr));
12548       break;
12549
12550     case FFEBLD_opPERCENT_VAL:
12551     case FFEBLD_opPERCENT_REF:
12552       ffecom_prepare_expr (ffebld_left (expr));
12553       break;
12554
12555     case FFEBLD_opPERCENT_DESCR:
12556       ffecom_prepare_arg_ptr_to_expr (ffebld_left (expr));
12557       break;
12558
12559     case FFEBLD_opITEM:
12560       {
12561         ffebld item;
12562
12563         for (item = expr;
12564              item != NULL;
12565              item = ffebld_trail (item))
12566           if (ffebld_head (item) != NULL)
12567             ffecom_prepare_expr (ffebld_head (item));
12568       }
12569       break;
12570
12571     default:
12572       /* Need to handle character conversion specially.  */
12573       switch (ffebld_arity (expr))
12574         {
12575         case 2:
12576           ffecom_prepare_expr (ffebld_left (expr));
12577           ffecom_prepare_expr (ffebld_right (expr));
12578           break;
12579
12580         case 1:
12581           ffecom_prepare_expr (ffebld_left (expr));
12582           break;
12583
12584         default:
12585           break;
12586         }
12587     }
12588
12589   return;
12590 }
12591
12592 /* Prepare expression for reading and writing.
12593
12594    Like ffecom_prepare_expr, except for expressions to be evaluated
12595    via ffecom_expr_rw.  */
12596
12597 void
12598 ffecom_prepare_expr_rw (tree type, ffebld expr)
12599 {
12600   /* This is all we support for now.  */
12601   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
12602
12603   /* ~~For now, it seems to be the same thing.  */
12604   ffecom_prepare_expr (expr);
12605   return;
12606 }
12607
12608 /* Prepare expression for writing.
12609
12610    Like ffecom_prepare_expr, except for expressions to be evaluated
12611    via ffecom_expr_w.  */
12612
12613 void
12614 ffecom_prepare_expr_w (tree type, ffebld expr)
12615 {
12616   /* This is all we support for now.  */
12617   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
12618
12619   /* ~~For now, it seems to be the same thing.  */
12620   ffecom_prepare_expr (expr);
12621   return;
12622 }
12623
12624 /* Prepare expression for returning.
12625
12626    Like ffecom_prepare_expr, except for expressions to be evaluated
12627    via ffecom_return_expr.  */
12628
12629 void
12630 ffecom_prepare_return_expr (ffebld expr)
12631 {
12632   assert (current_binding_level->prep_state < 2);
12633
12634   if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE
12635       && ffecom_is_altreturning_
12636       && expr != NULL)
12637     ffecom_prepare_expr (expr);
12638 }
12639
12640 /* Prepare pointer to expression.
12641
12642    Like ffecom_prepare_expr, except for expressions to be evaluated
12643    via ffecom_ptr_to_expr.  */
12644
12645 void
12646 ffecom_prepare_ptr_to_expr (ffebld expr)
12647 {
12648   /* ~~For now, it seems to be the same thing.  */
12649   ffecom_prepare_expr (expr);
12650   return;
12651 }
12652
12653 /* Transform expression into constant pointer-to-expression tree.
12654
12655    If the expression can be transformed into a pointer-to-expression tree
12656    that is constant, that is done, and the tree returned.  Else NULL_TREE
12657    is returned.
12658
12659    That way, a caller can attempt to provide compile-time initialization
12660    of a variable and, if that fails, *then* choose to start a new block
12661    and resort to using temporaries, as appropriate.  */
12662
12663 tree
12664 ffecom_ptr_to_const_expr (ffebld expr)
12665 {
12666   if (! expr)
12667     return integer_zero_node;
12668
12669   if (ffebld_op (expr) == FFEBLD_opANY)
12670     return error_mark_node;
12671
12672   if (ffebld_arity (expr) == 0
12673       && (ffebld_op (expr) != FFEBLD_opSYMTER
12674           || ffebld_where (expr) == FFEINFO_whereCOMMON
12675           || ffebld_where (expr) == FFEINFO_whereGLOBAL
12676           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
12677     {
12678       tree t;
12679
12680       t = ffecom_ptr_to_expr (expr);
12681       assert (TREE_CONSTANT (t));
12682       return t;
12683     }
12684
12685   return NULL_TREE;
12686 }
12687
12688 /* ffecom_return_expr -- Returns return-value expr given alt return expr
12689
12690    tree rtn;  // NULL_TREE means use expand_null_return()
12691    ffebld expr;  // NULL if no alt return expr to RETURN stmt
12692    rtn = ffecom_return_expr(expr);
12693
12694    Based on the program unit type and other info (like return function
12695    type, return master function type when alternate ENTRY points,
12696    whether subroutine has any alternate RETURN points, etc), returns the
12697    appropriate expression to be returned to the caller, or NULL_TREE
12698    meaning no return value or the caller expects it to be returned somewhere
12699    else (which is handled by other parts of this module).  */
12700
12701 tree
12702 ffecom_return_expr (ffebld expr)
12703 {
12704   tree rtn;
12705
12706   switch (ffecom_primary_entry_kind_)
12707     {
12708     case FFEINFO_kindPROGRAM:
12709     case FFEINFO_kindBLOCKDATA:
12710       rtn = NULL_TREE;
12711       break;
12712
12713     case FFEINFO_kindSUBROUTINE:
12714       if (!ffecom_is_altreturning_)
12715         rtn = NULL_TREE;        /* No alt returns, never an expr. */
12716       else if (expr == NULL)
12717         rtn = integer_zero_node;
12718       else
12719         rtn = ffecom_expr (expr);
12720       break;
12721
12722     case FFEINFO_kindFUNCTION:
12723       if ((ffecom_multi_retval_ != NULL_TREE)
12724           || (ffesymbol_basictype (ffecom_primary_entry_)
12725               == FFEINFO_basictypeCHARACTER)
12726           || ((ffesymbol_basictype (ffecom_primary_entry_)
12727                == FFEINFO_basictypeCOMPLEX)
12728               && (ffecom_num_entrypoints_ == 0)
12729               && ffesymbol_is_f2c (ffecom_primary_entry_)))
12730         {                       /* Value is returned by direct assignment
12731                                    into (implicit) dummy. */
12732           rtn = NULL_TREE;
12733           break;
12734         }
12735       rtn = ffecom_func_result_;
12736 #if 0
12737       /* Spurious error if RETURN happens before first reference!  So elide
12738          this code.  In particular, for debugging registry, rtn should always
12739          be non-null after all, but TREE_USED won't be set until we encounter
12740          a reference in the code.  Perfectly okay (but weird) code that,
12741          e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in
12742          this diagnostic for no reason.  Have people use -O -Wuninitialized
12743          and leave it to the back end to find obviously weird cases.  */
12744
12745       /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid
12746          situation; if the return value has never been referenced, it won't
12747          have a tree under 2pass mode. */
12748       if ((rtn == NULL_TREE)
12749           || !TREE_USED (rtn))
12750         {
12751           ffebad_start (FFEBAD_RETURN_VALUE_UNSET);
12752           ffebad_here (0, ffesymbol_where_line (ffecom_primary_entry_),
12753                        ffesymbol_where_column (ffecom_primary_entry_));
12754           ffebad_string (ffesymbol_text (ffesymbol_funcresult
12755                                          (ffecom_primary_entry_)));
12756           ffebad_finish ();
12757         }
12758 #endif
12759       break;
12760
12761     default:
12762       assert ("bad unit kind" == NULL);
12763     case FFEINFO_kindANY:
12764       rtn = error_mark_node;
12765       break;
12766     }
12767
12768   return rtn;
12769 }
12770
12771 /* Do save_expr only if tree is not error_mark_node.  */
12772
12773 tree
12774 ffecom_save_tree (tree t)
12775 {
12776   return save_expr (t);
12777 }
12778
12779 /* Start a compound statement (block).  */
12780
12781 void
12782 ffecom_start_compstmt (void)
12783 {
12784   bison_rule_pushlevel_ ();
12785 }
12786
12787 /* Public entry point for front end to access start_decl.  */
12788
12789 tree
12790 ffecom_start_decl (tree decl, bool is_initialized)
12791 {
12792   DECL_INITIAL (decl) = is_initialized ? error_mark_node : NULL_TREE;
12793   return start_decl (decl, FALSE);
12794 }
12795
12796 /* ffecom_sym_commit -- Symbol's state being committed to reality
12797
12798    ffesymbol s;
12799    ffecom_sym_commit(s);
12800
12801    Does whatever the backend needs when a symbol is committed after having
12802    been backtrackable for a period of time.  */
12803
12804 void
12805 ffecom_sym_commit (ffesymbol s UNUSED)
12806 {
12807   assert (!ffesymbol_retractable ());
12808 }
12809
12810 /* ffecom_sym_end_transition -- Perform end transition on all symbols
12811
12812    ffecom_sym_end_transition();
12813
12814    Does backend-specific stuff and also calls ffest_sym_end_transition
12815    to do the necessary FFE stuff.
12816
12817    Backtracking is never enabled when this fn is called, so don't worry
12818    about it.  */
12819
12820 ffesymbol
12821 ffecom_sym_end_transition (ffesymbol s)
12822 {
12823   ffestorag st;
12824
12825   assert (!ffesymbol_retractable ());
12826
12827   s = ffest_sym_end_transition (s);
12828
12829   if ((ffesymbol_kind (s) == FFEINFO_kindBLOCKDATA)
12830       && (ffesymbol_where (s) == FFEINFO_whereGLOBAL))
12831     {
12832       ffecom_list_blockdata_
12833         = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
12834                                               FFEINTRIN_specNONE,
12835                                               FFEINTRIN_impNONE),
12836                            ffecom_list_blockdata_);
12837     }
12838
12839   /* This is where we finally notice that a symbol has partial initialization
12840      and finalize it. */
12841
12842   if (ffesymbol_accretion (s) != NULL)
12843     {
12844       assert (ffesymbol_init (s) == NULL);
12845       ffecom_notify_init_symbol (s);
12846     }
12847   else if (((st = ffesymbol_storage (s)) != NULL)
12848            && ((st = ffestorag_parent (st)) != NULL)
12849            && (ffestorag_accretion (st) != NULL))
12850     {
12851       assert (ffestorag_init (st) == NULL);
12852       ffecom_notify_init_storage (st);
12853     }
12854
12855   if ((ffesymbol_kind (s) == FFEINFO_kindCOMMON)
12856       && (ffesymbol_where (s) == FFEINFO_whereLOCAL)
12857       && (ffesymbol_storage (s) != NULL))
12858     {
12859       ffecom_list_common_
12860         = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
12861                                               FFEINTRIN_specNONE,
12862                                               FFEINTRIN_impNONE),
12863                            ffecom_list_common_);
12864     }
12865
12866   return s;
12867 }
12868
12869 /* ffecom_sym_exec_transition -- Perform exec transition on all symbols
12870
12871    ffecom_sym_exec_transition();
12872
12873    Does backend-specific stuff and also calls ffest_sym_exec_transition
12874    to do the necessary FFE stuff.
12875
12876    See the long-winded description in ffecom_sym_learned for info
12877    on handling the situation where backtracking is inhibited.  */
12878
12879 ffesymbol
12880 ffecom_sym_exec_transition (ffesymbol s)
12881 {
12882   s = ffest_sym_exec_transition (s);
12883
12884   return s;
12885 }
12886
12887 /* ffecom_sym_learned -- Initial or more info gained on symbol after exec
12888
12889    ffesymbol s;
12890    s = ffecom_sym_learned(s);
12891
12892    Called when a new symbol is seen after the exec transition or when more
12893    info (perhaps) is gained for an UNCERTAIN symbol.  The symbol state when
12894    it arrives here is that all its latest info is updated already, so its
12895    state may be UNCERTAIN or UNDERSTOOD, it might already have the hook
12896    field filled in if its gone through here or exec_transition first, and
12897    so on.
12898
12899    The backend probably wants to check ffesymbol_retractable() to see if
12900    backtracking is in effect.  If so, the FFE's changes to the symbol may
12901    be retracted (undone) or committed (ratified), at which time the
12902    appropriate ffecom_sym_retract or _commit function will be called
12903    for that function.
12904
12905    If the backend has its own backtracking mechanism, great, use it so that
12906    committal is a simple operation.  Though it doesn't make much difference,
12907    I suppose: the reason for tentative symbol evolution in the FFE is to
12908    enable error detection in weird incorrect statements early and to disable
12909    incorrect error detection on a correct statement.  The backend is not
12910    likely to introduce any information that'll get involved in these
12911    considerations, so it is probably just fine that the implementation
12912    model for this fn and for _exec_transition is to not do anything
12913    (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE
12914    and instead wait until ffecom_sym_commit is called (which it never
12915    will be as long as we're using ambiguity-detecting statement analysis in
12916    the FFE, which we are initially to shake out the code, but don't depend
12917    on this), otherwise go ahead and do whatever is needed.
12918
12919    In essence, then, when this fn and _exec_transition get called while
12920    backtracking is enabled, a general mechanism would be to flag which (or
12921    both) of these were called (and in what order? neat question as to what
12922    might happen that I'm too lame to think through right now) and then when
12923    _commit is called reproduce the original calling sequence, if any, for
12924    the two fns (at which point backtracking will, of course, be disabled).  */
12925
12926 ffesymbol
12927 ffecom_sym_learned (ffesymbol s)
12928 {
12929   ffestorag_exec_layout (s);
12930
12931   return s;
12932 }
12933
12934 /* ffecom_sym_retract -- Symbol's state being retracted from reality
12935
12936    ffesymbol s;
12937    ffecom_sym_retract(s);
12938
12939    Does whatever the backend needs when a symbol is retracted after having
12940    been backtrackable for a period of time.  */
12941
12942 void
12943 ffecom_sym_retract (ffesymbol s UNUSED)
12944 {
12945   assert (!ffesymbol_retractable ());
12946
12947 #if 0                           /* GCC doesn't commit any backtrackable sins,
12948                                    so nothing needed here. */
12949   switch (ffesymbol_hook (s).state)
12950     {
12951     case 0:                     /* nothing happened yet. */
12952       break;
12953
12954     case 1:                     /* exec transition happened. */
12955       break;
12956
12957     case 2:                     /* learned happened. */
12958       break;
12959
12960     case 3:                     /* learned then exec. */
12961       break;
12962
12963     case 4:                     /* exec then learned. */
12964       break;
12965
12966     default:
12967       assert ("bad hook state" == NULL);
12968       break;
12969     }
12970 #endif
12971 }
12972
12973 /* Create temporary gcc label.  */
12974
12975 tree
12976 ffecom_temp_label ()
12977 {
12978   tree glabel;
12979   static int mynumber = 0;
12980
12981   glabel = build_decl (LABEL_DECL,
12982                        ffecom_get_invented_identifier ("__g77_label_%d",
12983                                                        mynumber++),
12984                        void_type_node);
12985   DECL_CONTEXT (glabel) = current_function_decl;
12986   DECL_MODE (glabel) = VOIDmode;
12987
12988   return glabel;
12989 }
12990
12991 /* Return an expression that is usable as an arg in a conditional context
12992    (IF, DO WHILE, .NOT., and so on).
12993
12994    Use the one provided for the back end as of >2.6.0.  */
12995
12996 tree
12997 ffecom_truth_value (tree expr)
12998 {
12999   return truthvalue_conversion (expr);
13000 }
13001
13002 /* Return the inversion of a truth value (the inversion of what
13003    ffecom_truth_value builds).
13004
13005    Apparently invert_truthvalue, which is properly in the back end, is
13006    enough for now, so just use it.  */
13007
13008 tree
13009 ffecom_truth_value_invert (tree expr)
13010 {
13011   return invert_truthvalue (ffecom_truth_value (expr));
13012 }
13013
13014 /* Return the tree that is the type of the expression, as would be
13015    returned in TREE_TYPE(ffecom_expr(expr)), without otherwise
13016    transforming the expression, generating temporaries, etc.  */
13017
13018 tree
13019 ffecom_type_expr (ffebld expr)
13020 {
13021   ffeinfoBasictype bt;
13022   ffeinfoKindtype kt;
13023   tree tree_type;
13024
13025   assert (expr != NULL);
13026
13027   bt = ffeinfo_basictype (ffebld_info (expr));
13028   kt = ffeinfo_kindtype (ffebld_info (expr));
13029   tree_type = ffecom_tree_type[bt][kt];
13030
13031   switch (ffebld_op (expr))
13032     {
13033     case FFEBLD_opCONTER:
13034     case FFEBLD_opSYMTER:
13035     case FFEBLD_opARRAYREF:
13036     case FFEBLD_opUPLUS:
13037     case FFEBLD_opPAREN:
13038     case FFEBLD_opUMINUS:
13039     case FFEBLD_opADD:
13040     case FFEBLD_opSUBTRACT:
13041     case FFEBLD_opMULTIPLY:
13042     case FFEBLD_opDIVIDE:
13043     case FFEBLD_opPOWER:
13044     case FFEBLD_opNOT:
13045     case FFEBLD_opFUNCREF:
13046     case FFEBLD_opSUBRREF:
13047     case FFEBLD_opAND:
13048     case FFEBLD_opOR:
13049     case FFEBLD_opXOR:
13050     case FFEBLD_opNEQV:
13051     case FFEBLD_opEQV:
13052     case FFEBLD_opCONVERT:
13053     case FFEBLD_opLT:
13054     case FFEBLD_opLE:
13055     case FFEBLD_opEQ:
13056     case FFEBLD_opNE:
13057     case FFEBLD_opGT:
13058     case FFEBLD_opGE:
13059     case FFEBLD_opPERCENT_LOC:
13060       return tree_type;
13061
13062     case FFEBLD_opACCTER:
13063     case FFEBLD_opARRTER:
13064     case FFEBLD_opITEM:
13065     case FFEBLD_opSTAR:
13066     case FFEBLD_opBOUNDS:
13067     case FFEBLD_opREPEAT:
13068     case FFEBLD_opLABTER:
13069     case FFEBLD_opLABTOK:
13070     case FFEBLD_opIMPDO:
13071     case FFEBLD_opCONCATENATE:
13072     case FFEBLD_opSUBSTR:
13073     default:
13074       assert ("bad op for ffecom_type_expr" == NULL);
13075       /* Fall through. */
13076     case FFEBLD_opANY:
13077       return error_mark_node;
13078     }
13079 }
13080
13081 /* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points
13082
13083    If the PARM_DECL already exists, return it, else create it.  It's an
13084    integer_type_node argument for the master function that implements a
13085    subroutine or function with more than one entrypoint and is bound at
13086    run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for
13087    first ENTRY statement, and so on).  */
13088
13089 tree
13090 ffecom_which_entrypoint_decl ()
13091 {
13092   assert (ffecom_which_entrypoint_decl_ != NULL_TREE);
13093
13094   return ffecom_which_entrypoint_decl_;
13095 }
13096 \f
13097 /* The following sections consists of private and public functions
13098    that have the same names and perform roughly the same functions
13099    as counterparts in the C front end.  Changes in the C front end
13100    might affect how things should be done here.  Only functions
13101    needed by the back end should be public here; the rest should
13102    be private (static in the C sense).  Functions needed by other
13103    g77 front-end modules should be accessed by them via public
13104    ffecom_* names, which should themselves call private versions
13105    in this section so the private versions are easy to recognize
13106    when upgrading to a new gcc and finding interesting changes
13107    in the front end.
13108
13109    Functions named after rule "foo:" in c-parse.y are named
13110    "bison_rule_foo_" so they are easy to find.  */
13111
13112 static void
13113 bison_rule_pushlevel_ ()
13114 {
13115   emit_line_note (input_filename, lineno);
13116   pushlevel (0);
13117   clear_last_expr ();
13118   expand_start_bindings (0);
13119 }
13120
13121 static tree
13122 bison_rule_compstmt_ ()
13123 {
13124   tree t;
13125   int keep = kept_level_p ();
13126
13127   /* Make the temps go away.  */
13128   if (! keep)
13129     current_binding_level->names = NULL_TREE;
13130
13131   emit_line_note (input_filename, lineno);
13132   expand_end_bindings (getdecls (), keep, 0);
13133   t = poplevel (keep, 1, 0);
13134
13135   return t;
13136 }
13137
13138 /* Return a definition for a builtin function named NAME and whose data type
13139    is TYPE.  TYPE should be a function type with argument types.
13140    FUNCTION_CODE tells later passes how to compile calls to this function.
13141    See tree.h for its possible values.
13142
13143    If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
13144    the name to be called if we can't opencode the function.  */
13145
13146 tree
13147 builtin_function (const char *name, tree type, int function_code,
13148                   enum built_in_class class,
13149                   const char *library_name)
13150 {
13151   tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type);
13152   DECL_EXTERNAL (decl) = 1;
13153   TREE_PUBLIC (decl) = 1;
13154   if (library_name)
13155     SET_DECL_ASSEMBLER_NAME (decl, get_identifier (library_name));
13156   make_decl_rtl (decl, NULL);
13157   pushdecl (decl);
13158   DECL_BUILT_IN_CLASS (decl) = class;
13159   DECL_FUNCTION_CODE (decl) = function_code;
13160
13161   return decl;
13162 }
13163
13164 /* Handle when a new declaration NEWDECL
13165    has the same name as an old one OLDDECL
13166    in the same binding contour.
13167    Prints an error message if appropriate.
13168
13169    If safely possible, alter OLDDECL to look like NEWDECL, and return 1.
13170    Otherwise, return 0.  */
13171
13172 static int
13173 duplicate_decls (tree newdecl, tree olddecl)
13174 {
13175   int types_match = 1;
13176   int new_is_definition = (TREE_CODE (newdecl) == FUNCTION_DECL
13177                            && DECL_INITIAL (newdecl) != 0);
13178   tree oldtype = TREE_TYPE (olddecl);
13179   tree newtype = TREE_TYPE (newdecl);
13180
13181   if (olddecl == newdecl)
13182     return 1;
13183
13184   if (TREE_CODE (newtype) == ERROR_MARK
13185       || TREE_CODE (oldtype) == ERROR_MARK)
13186     types_match = 0;
13187
13188   /* New decl is completely inconsistent with the old one =>
13189      tell caller to replace the old one.
13190      This is always an error except in the case of shadowing a builtin.  */
13191   if (TREE_CODE (olddecl) != TREE_CODE (newdecl))
13192     return 0;
13193
13194   /* For real parm decl following a forward decl,
13195      return 1 so old decl will be reused.  */
13196   if (types_match && TREE_CODE (newdecl) == PARM_DECL
13197       && TREE_ASM_WRITTEN (olddecl) && ! TREE_ASM_WRITTEN (newdecl))
13198     return 1;
13199
13200   /* The new declaration is the same kind of object as the old one.
13201      The declarations may partially match.  Print warnings if they don't
13202      match enough.  Ultimately, copy most of the information from the new
13203      decl to the old one, and keep using the old one.  */
13204
13205   if (TREE_CODE (olddecl) == FUNCTION_DECL
13206       && DECL_BUILT_IN (olddecl))
13207     {
13208       /* A function declaration for a built-in function.  */
13209       if (!TREE_PUBLIC (newdecl))
13210         return 0;
13211       else if (!types_match)
13212         {
13213           /* Accept the return type of the new declaration if same modes.  */
13214           tree oldreturntype = TREE_TYPE (TREE_TYPE (olddecl));
13215           tree newreturntype = TREE_TYPE (TREE_TYPE (newdecl));
13216
13217           if (TYPE_MODE (oldreturntype) == TYPE_MODE (newreturntype))
13218             {
13219               /* Function types may be shared, so we can't just modify
13220                  the return type of olddecl's function type.  */
13221               tree newtype
13222                 = build_function_type (newreturntype,
13223                                        TYPE_ARG_TYPES (TREE_TYPE (olddecl)));
13224
13225               types_match = 1;
13226               if (types_match)
13227                 TREE_TYPE (olddecl) = newtype;
13228             }
13229         }
13230       if (!types_match)
13231         return 0;
13232     }
13233   else if (TREE_CODE (olddecl) == FUNCTION_DECL
13234            && DECL_SOURCE_LINE (olddecl) == 0)
13235     {
13236       /* A function declaration for a predeclared function
13237          that isn't actually built in.  */
13238       if (!TREE_PUBLIC (newdecl))
13239         return 0;
13240       else if (!types_match)
13241         {
13242           /* If the types don't match, preserve volatility indication.
13243              Later on, we will discard everything else about the
13244              default declaration.  */
13245           TREE_THIS_VOLATILE (newdecl) |= TREE_THIS_VOLATILE (olddecl);
13246         }
13247     }
13248
13249   /* Copy all the DECL_... slots specified in the new decl
13250      except for any that we copy here from the old type.
13251
13252      Past this point, we don't change OLDTYPE and NEWTYPE
13253      even if we change the types of NEWDECL and OLDDECL.  */
13254
13255   if (types_match)
13256     {
13257       /* Merge the data types specified in the two decls.  */
13258       if (TREE_CODE (newdecl) != FUNCTION_DECL || !DECL_BUILT_IN (olddecl))
13259         TREE_TYPE (newdecl)
13260           = TREE_TYPE (olddecl)
13261             = TREE_TYPE (newdecl);
13262
13263       /* Lay the type out, unless already done.  */
13264       if (oldtype != TREE_TYPE (newdecl))
13265         {
13266           if (TREE_TYPE (newdecl) != error_mark_node)
13267             layout_type (TREE_TYPE (newdecl));
13268           if (TREE_CODE (newdecl) != FUNCTION_DECL
13269               && TREE_CODE (newdecl) != TYPE_DECL
13270               && TREE_CODE (newdecl) != CONST_DECL)
13271             layout_decl (newdecl, 0);
13272         }
13273       else
13274         {
13275           /* Since the type is OLDDECL's, make OLDDECL's size go with.  */
13276           DECL_SIZE (newdecl) = DECL_SIZE (olddecl);
13277           DECL_SIZE_UNIT (newdecl) = DECL_SIZE_UNIT (olddecl);
13278           if (TREE_CODE (olddecl) != FUNCTION_DECL)
13279             if (DECL_ALIGN (olddecl) > DECL_ALIGN (newdecl))
13280               {
13281                 DECL_ALIGN (newdecl) = DECL_ALIGN (olddecl);
13282                 DECL_USER_ALIGN (newdecl) |= DECL_USER_ALIGN (olddecl);
13283               }
13284         }
13285
13286       /* Keep the old rtl since we can safely use it.  */
13287       COPY_DECL_RTL (olddecl, newdecl);
13288
13289       /* Merge the type qualifiers.  */
13290       if (DECL_BUILT_IN_NONANSI (olddecl) && TREE_THIS_VOLATILE (olddecl)
13291           && !TREE_THIS_VOLATILE (newdecl))
13292         TREE_THIS_VOLATILE (olddecl) = 0;
13293       if (TREE_READONLY (newdecl))
13294         TREE_READONLY (olddecl) = 1;
13295       if (TREE_THIS_VOLATILE (newdecl))
13296         {
13297           TREE_THIS_VOLATILE (olddecl) = 1;
13298           if (TREE_CODE (newdecl) == VAR_DECL)
13299             make_var_volatile (newdecl);
13300         }
13301
13302       /* Keep source location of definition rather than declaration.
13303          Likewise, keep decl at outer scope.  */
13304       if ((DECL_INITIAL (newdecl) == 0 && DECL_INITIAL (olddecl) != 0)
13305           || (DECL_CONTEXT (newdecl) != 0 && DECL_CONTEXT (olddecl) == 0))
13306         {
13307           DECL_SOURCE_LINE (newdecl) = DECL_SOURCE_LINE (olddecl);
13308           DECL_SOURCE_FILE (newdecl) = DECL_SOURCE_FILE (olddecl);
13309
13310           if (DECL_CONTEXT (olddecl) == 0
13311               && TREE_CODE (newdecl) != FUNCTION_DECL)
13312             DECL_CONTEXT (newdecl) = 0;
13313         }
13314
13315       /* Merge the unused-warning information.  */
13316       if (DECL_IN_SYSTEM_HEADER (olddecl))
13317         DECL_IN_SYSTEM_HEADER (newdecl) = 1;
13318       else if (DECL_IN_SYSTEM_HEADER (newdecl))
13319         DECL_IN_SYSTEM_HEADER (olddecl) = 1;
13320
13321       /* Merge the initialization information.  */
13322       if (DECL_INITIAL (newdecl) == 0)
13323         DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13324
13325       /* Merge the section attribute.
13326          We want to issue an error if the sections conflict but that must be
13327          done later in decl_attributes since we are called before attributes
13328          are assigned.  */
13329       if (DECL_SECTION_NAME (newdecl) == NULL_TREE)
13330         DECL_SECTION_NAME (newdecl) = DECL_SECTION_NAME (olddecl);
13331
13332       if (TREE_CODE (newdecl) == FUNCTION_DECL)
13333         {
13334           DECL_STATIC_CONSTRUCTOR(newdecl) |= DECL_STATIC_CONSTRUCTOR(olddecl);
13335           DECL_STATIC_DESTRUCTOR (newdecl) |= DECL_STATIC_DESTRUCTOR (olddecl);
13336         }
13337     }
13338   /* If cannot merge, then use the new type and qualifiers,
13339      and don't preserve the old rtl.  */
13340   else
13341     {
13342       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13343       TREE_READONLY (olddecl) = TREE_READONLY (newdecl);
13344       TREE_THIS_VOLATILE (olddecl) = TREE_THIS_VOLATILE (newdecl);
13345       TREE_SIDE_EFFECTS (olddecl) = TREE_SIDE_EFFECTS (newdecl);
13346     }
13347
13348   /* Merge the storage class information.  */
13349   /* For functions, static overrides non-static.  */
13350   if (TREE_CODE (newdecl) == FUNCTION_DECL)
13351     {
13352       TREE_PUBLIC (newdecl) &= TREE_PUBLIC (olddecl);
13353       /* This is since we don't automatically
13354          copy the attributes of NEWDECL into OLDDECL.  */
13355       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13356       /* If this clears `static', clear it in the identifier too.  */
13357       if (! TREE_PUBLIC (olddecl))
13358         TREE_PUBLIC (DECL_NAME (olddecl)) = 0;
13359     }
13360   if (DECL_EXTERNAL (newdecl))
13361     {
13362       TREE_STATIC (newdecl) = TREE_STATIC (olddecl);
13363       DECL_EXTERNAL (newdecl) = DECL_EXTERNAL (olddecl);
13364       /* An extern decl does not override previous storage class.  */
13365       TREE_PUBLIC (newdecl) = TREE_PUBLIC (olddecl);
13366     }
13367   else
13368     {
13369       TREE_STATIC (olddecl) = TREE_STATIC (newdecl);
13370       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13371     }
13372
13373   /* If either decl says `inline', this fn is inline,
13374      unless its definition was passed already.  */
13375   if (DECL_INLINE (newdecl) && DECL_INITIAL (olddecl) == 0)
13376     DECL_INLINE (olddecl) = 1;
13377   DECL_INLINE (newdecl) = DECL_INLINE (olddecl);
13378
13379   /* Get rid of any built-in function if new arg types don't match it
13380      or if we have a function definition.  */
13381   if (TREE_CODE (newdecl) == FUNCTION_DECL
13382       && DECL_BUILT_IN (olddecl)
13383       && (!types_match || new_is_definition))
13384     {
13385       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13386       DECL_BUILT_IN_CLASS (olddecl) = NOT_BUILT_IN;
13387     }
13388
13389   /* If redeclaring a builtin function, and not a definition,
13390      it stays built in.
13391      Also preserve various other info from the definition.  */
13392   if (TREE_CODE (newdecl) == FUNCTION_DECL && !new_is_definition)
13393     {
13394       if (DECL_BUILT_IN (olddecl))
13395         {
13396           DECL_BUILT_IN_CLASS (newdecl) = DECL_BUILT_IN_CLASS (olddecl);
13397           DECL_FUNCTION_CODE (newdecl) = DECL_FUNCTION_CODE (olddecl);
13398         }
13399
13400       DECL_RESULT (newdecl) = DECL_RESULT (olddecl);
13401       DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13402       DECL_SAVED_INSNS (newdecl) = DECL_SAVED_INSNS (olddecl);
13403       DECL_ARGUMENTS (newdecl) = DECL_ARGUMENTS (olddecl);
13404     }
13405
13406   /* Copy most of the decl-specific fields of NEWDECL into OLDDECL.
13407      But preserve olddecl's DECL_UID.  */
13408   {
13409     register unsigned olddecl_uid = DECL_UID (olddecl);
13410
13411     memcpy ((char *) olddecl + sizeof (struct tree_common),
13412             (char *) newdecl + sizeof (struct tree_common),
13413             sizeof (struct tree_decl) - sizeof (struct tree_common));
13414     DECL_UID (olddecl) = olddecl_uid;
13415   }
13416
13417   return 1;
13418 }
13419
13420 /* Finish processing of a declaration;
13421    install its initial value.
13422    If the length of an array type is not known before,
13423    it must be determined now, from the initial value, or it is an error.  */
13424
13425 static void
13426 finish_decl (tree decl, tree init, bool is_top_level)
13427 {
13428   register tree type = TREE_TYPE (decl);
13429   int was_incomplete = (DECL_SIZE (decl) == 0);
13430   bool at_top_level = (current_binding_level == global_binding_level);
13431   bool top_level = is_top_level || at_top_level;
13432
13433   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13434      level anyway.  */
13435   assert (!is_top_level || !at_top_level);
13436
13437   if (TREE_CODE (decl) == PARM_DECL)
13438     assert (init == NULL_TREE);
13439   /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it
13440      overlaps DECL_ARG_TYPE.  */
13441   else if (init == NULL_TREE)
13442     assert (DECL_INITIAL (decl) == NULL_TREE);
13443   else
13444     assert (DECL_INITIAL (decl) == error_mark_node);
13445
13446   if (init != NULL_TREE)
13447     {
13448       if (TREE_CODE (decl) != TYPE_DECL)
13449         DECL_INITIAL (decl) = init;
13450       else
13451         {
13452           /* typedef foo = bar; store the type of bar as the type of foo.  */
13453           TREE_TYPE (decl) = TREE_TYPE (init);
13454           DECL_INITIAL (decl) = init = 0;
13455         }
13456     }
13457
13458   /* Deduce size of array from initialization, if not already known */
13459
13460   if (TREE_CODE (type) == ARRAY_TYPE
13461       && TYPE_DOMAIN (type) == 0
13462       && TREE_CODE (decl) != TYPE_DECL)
13463     {
13464       assert (top_level);
13465       assert (was_incomplete);
13466
13467       layout_decl (decl, 0);
13468     }
13469
13470   if (TREE_CODE (decl) == VAR_DECL)
13471     {
13472       if (DECL_SIZE (decl) == NULL_TREE
13473           && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
13474         layout_decl (decl, 0);
13475
13476       if (DECL_SIZE (decl) == NULL_TREE
13477           && (TREE_STATIC (decl)
13478               ?
13479       /* A static variable with an incomplete type is an error if it is
13480          initialized. Also if it is not file scope. Otherwise, let it
13481          through, but if it is not `extern' then it may cause an error
13482          message later.  */
13483               (DECL_INITIAL (decl) != 0 || DECL_CONTEXT (decl) != 0)
13484               :
13485       /* An automatic variable with an incomplete type is an error.  */
13486               !DECL_EXTERNAL (decl)))
13487         {
13488           assert ("storage size not known" == NULL);
13489           abort ();
13490         }
13491
13492       if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl))
13493           && (DECL_SIZE (decl) != 0)
13494           && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST))
13495         {
13496           assert ("storage size not constant" == NULL);
13497           abort ();
13498         }
13499     }
13500
13501   /* Output the assembler code and/or RTL code for variables and functions,
13502      unless the type is an undefined structure or union. If not, it will get
13503      done when the type is completed.  */
13504
13505   if (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == FUNCTION_DECL)
13506     {
13507       rest_of_decl_compilation (decl, NULL,
13508                                 DECL_CONTEXT (decl) == 0,
13509                                 0);
13510
13511       if (DECL_CONTEXT (decl) != 0)
13512         {
13513           /* Recompute the RTL of a local array now if it used to be an
13514              incomplete type.  */
13515           if (was_incomplete
13516               && !TREE_STATIC (decl) && !DECL_EXTERNAL (decl))
13517             {
13518               /* If we used it already as memory, it must stay in memory.  */
13519               TREE_ADDRESSABLE (decl) = TREE_USED (decl);
13520               /* If it's still incomplete now, no init will save it.  */
13521               if (DECL_SIZE (decl) == 0)
13522                 DECL_INITIAL (decl) = 0;
13523               expand_decl (decl);
13524             }
13525           /* Compute and store the initial value.  */
13526           if (TREE_CODE (decl) != FUNCTION_DECL)
13527             expand_decl_init (decl);
13528         }
13529     }
13530   else if (TREE_CODE (decl) == TYPE_DECL)
13531     {
13532       rest_of_decl_compilation (decl, NULL,
13533                                 DECL_CONTEXT (decl) == 0,
13534                                 0);
13535     }
13536
13537   /* At the end of a declaration, throw away any variable type sizes of types
13538      defined inside that declaration.  There is no use computing them in the
13539      following function definition.  */
13540   if (current_binding_level == global_binding_level)
13541     get_pending_sizes ();
13542 }
13543
13544 /* Finish up a function declaration and compile that function
13545    all the way to assembler language output.  The free the storage
13546    for the function definition.
13547
13548    This is called after parsing the body of the function definition.
13549
13550    NESTED is nonzero if the function being finished is nested in another.  */
13551
13552 static void
13553 finish_function (int nested)
13554 {
13555   register tree fndecl = current_function_decl;
13556
13557   assert (fndecl != NULL_TREE);
13558   if (TREE_CODE (fndecl) != ERROR_MARK)
13559     {
13560       if (nested)
13561         assert (DECL_CONTEXT (fndecl) != NULL_TREE);
13562       else
13563         assert (DECL_CONTEXT (fndecl) == NULL_TREE);
13564     }
13565
13566 /*  TREE_READONLY (fndecl) = 1;
13567     This caused &foo to be of type ptr-to-const-function
13568     which then got a warning when stored in a ptr-to-function variable.  */
13569
13570   poplevel (1, 0, 1);
13571
13572   if (TREE_CODE (fndecl) != ERROR_MARK)
13573     {
13574       BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
13575
13576       /* Must mark the RESULT_DECL as being in this function.  */
13577
13578       DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl;
13579
13580       /* Obey `register' declarations if `setjmp' is called in this fn.  */
13581       /* Generate rtl for function exit.  */
13582       expand_function_end (input_filename, lineno, 0);
13583
13584       /* If this is a nested function, protect the local variables in the stack
13585          above us from being collected while we're compiling this function.  */
13586       if (nested)
13587         ggc_push_context ();
13588
13589       /* Run the optimizers and output the assembler code for this function.  */
13590       rest_of_compilation (fndecl);
13591
13592       /* Undo the GC context switch.  */
13593       if (nested)
13594         ggc_pop_context ();
13595     }
13596
13597   if (TREE_CODE (fndecl) != ERROR_MARK
13598       && !nested
13599       && DECL_SAVED_INSNS (fndecl) == 0)
13600     {
13601       /* Stop pointing to the local nodes about to be freed.  */
13602       /* But DECL_INITIAL must remain nonzero so we know this was an actual
13603          function definition.  */
13604       /* For a nested function, this is done in pop_f_function_context.  */
13605       /* If rest_of_compilation set this to 0, leave it 0.  */
13606       if (DECL_INITIAL (fndecl) != 0)
13607         DECL_INITIAL (fndecl) = error_mark_node;
13608       DECL_ARGUMENTS (fndecl) = 0;
13609     }
13610
13611   if (!nested)
13612     {
13613       /* Let the error reporting routines know that we're outside a function.
13614          For a nested function, this value is used in pop_c_function_context
13615          and then reset via pop_function_context.  */
13616       ffecom_outer_function_decl_ = current_function_decl = NULL;
13617     }
13618 }
13619
13620 /* Plug-in replacement for identifying the name of a decl and, for a
13621    function, what we call it in diagnostics.  For now, "program unit"
13622    should suffice, since it's a bit of a hassle to figure out which
13623    of several kinds of things it is.  Note that it could conceivably
13624    be a statement function, which probably isn't really a program unit
13625    per se, but if that comes up, it should be easy to check (being a
13626    nested function and all).  */
13627
13628 static const char *
13629 lang_printable_name (tree decl, int v)
13630 {
13631   /* Just to keep GCC quiet about the unused variable.
13632      In theory, differing values of V should produce different
13633      output.  */
13634   switch (v)
13635     {
13636     default:
13637       if (TREE_CODE (decl) == ERROR_MARK)
13638         return "erroneous code";
13639       return IDENTIFIER_POINTER (DECL_NAME (decl));
13640     }
13641 }
13642
13643 /* g77's function to print out name of current function that caused
13644    an error.  */
13645
13646 static void
13647 lang_print_error_function (diagnostic_context *context __attribute__((unused)),
13648                            const char *file)
13649 {
13650   static ffeglobal last_g = NULL;
13651   static ffesymbol last_s = NULL;
13652   ffeglobal g;
13653   ffesymbol s;
13654   const char *kind;
13655
13656   if ((ffecom_primary_entry_ == NULL)
13657       || (ffesymbol_global (ffecom_primary_entry_) == NULL))
13658     {
13659       g = NULL;
13660       s = NULL;
13661       kind = NULL;
13662     }
13663   else
13664     {
13665       g = ffesymbol_global (ffecom_primary_entry_);
13666       if (ffecom_nested_entry_ == NULL)
13667         {
13668           s = ffecom_primary_entry_;
13669           switch (ffesymbol_kind (s))
13670             {
13671             case FFEINFO_kindFUNCTION:
13672               kind = "function";
13673               break;
13674
13675             case FFEINFO_kindSUBROUTINE:
13676               kind = "subroutine";
13677               break;
13678
13679             case FFEINFO_kindPROGRAM:
13680               kind = "program";
13681               break;
13682
13683             case FFEINFO_kindBLOCKDATA:
13684               kind = "block-data";
13685               break;
13686
13687             default:
13688               kind = ffeinfo_kind_message (ffesymbol_kind (s));
13689               break;
13690             }
13691         }
13692       else
13693         {
13694           s = ffecom_nested_entry_;
13695           kind = "statement function";
13696         }
13697     }
13698
13699   if ((last_g != g) || (last_s != s))
13700     {
13701       if (file)
13702         fprintf (stderr, "%s: ", file);
13703
13704       if (s == NULL)
13705         fprintf (stderr, "Outside of any program unit:\n");
13706       else
13707         {
13708           const char *name = ffesymbol_text (s);
13709
13710           fprintf (stderr, "In %s `%s':\n", kind, name);
13711         }
13712
13713       last_g = g;
13714       last_s = s;
13715     }
13716 }
13717
13718 /* Similar to `lookup_name' but look only at current binding level.  */
13719
13720 static tree
13721 lookup_name_current_level (tree name)
13722 {
13723   register tree t;
13724
13725   if (current_binding_level == global_binding_level)
13726     return IDENTIFIER_GLOBAL_VALUE (name);
13727
13728   if (IDENTIFIER_LOCAL_VALUE (name) == 0)
13729     return 0;
13730
13731   for (t = current_binding_level->names; t; t = TREE_CHAIN (t))
13732     if (DECL_NAME (t) == name)
13733       break;
13734
13735   return t;
13736 }
13737
13738 /* Create a new `struct binding_level'.  */
13739
13740 static struct binding_level *
13741 make_binding_level ()
13742 {
13743   /* NOSTRICT */
13744   return (struct binding_level *) xmalloc (sizeof (struct binding_level));
13745 }
13746
13747 /* Save and restore the variables in this file and elsewhere
13748    that keep track of the progress of compilation of the current function.
13749    Used for nested functions.  */
13750
13751 struct f_function
13752 {
13753   struct f_function *next;
13754   tree named_labels;
13755   tree shadowed_labels;
13756   struct binding_level *binding_level;
13757 };
13758
13759 struct f_function *f_function_chain;
13760
13761 /* Restore the variables used during compilation of a C function.  */
13762
13763 static void
13764 pop_f_function_context ()
13765 {
13766   struct f_function *p = f_function_chain;
13767   tree link;
13768
13769   /* Bring back all the labels that were shadowed.  */
13770   for (link = shadowed_labels; link; link = TREE_CHAIN (link))
13771     if (DECL_NAME (TREE_VALUE (link)) != 0)
13772       IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link)))
13773         = TREE_VALUE (link);
13774
13775   if (current_function_decl != error_mark_node
13776       && DECL_SAVED_INSNS (current_function_decl) == 0)
13777     {
13778       /* Stop pointing to the local nodes about to be freed.  */
13779       /* But DECL_INITIAL must remain nonzero so we know this was an actual
13780          function definition.  */
13781       DECL_INITIAL (current_function_decl) = error_mark_node;
13782       DECL_ARGUMENTS (current_function_decl) = 0;
13783     }
13784
13785   pop_function_context ();
13786
13787   f_function_chain = p->next;
13788
13789   named_labels = p->named_labels;
13790   shadowed_labels = p->shadowed_labels;
13791   current_binding_level = p->binding_level;
13792
13793   free (p);
13794 }
13795
13796 /* Save and reinitialize the variables
13797    used during compilation of a C function.  */
13798
13799 static void
13800 push_f_function_context ()
13801 {
13802   struct f_function *p
13803   = (struct f_function *) xmalloc (sizeof (struct f_function));
13804
13805   push_function_context ();
13806
13807   p->next = f_function_chain;
13808   f_function_chain = p;
13809
13810   p->named_labels = named_labels;
13811   p->shadowed_labels = shadowed_labels;
13812   p->binding_level = current_binding_level;
13813 }
13814
13815 static void
13816 push_parm_decl (tree parm)
13817 {
13818   int old_immediate_size_expand = immediate_size_expand;
13819
13820   /* Don't try computing parm sizes now -- wait till fn is called.  */
13821
13822   immediate_size_expand = 0;
13823
13824   /* Fill in arg stuff.  */
13825
13826   DECL_ARG_TYPE (parm) = TREE_TYPE (parm);
13827   DECL_ARG_TYPE_AS_WRITTEN (parm) = TREE_TYPE (parm);
13828   TREE_READONLY (parm) = 1;     /* All implementation args are read-only. */
13829
13830   parm = pushdecl (parm);
13831
13832   immediate_size_expand = old_immediate_size_expand;
13833
13834   finish_decl (parm, NULL_TREE, FALSE);
13835 }
13836
13837 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate.  */
13838
13839 static tree
13840 pushdecl_top_level (x)
13841      tree x;
13842 {
13843   register tree t;
13844   register struct binding_level *b = current_binding_level;
13845   register tree f = current_function_decl;
13846
13847   current_binding_level = global_binding_level;
13848   current_function_decl = NULL_TREE;
13849   t = pushdecl (x);
13850   current_binding_level = b;
13851   current_function_decl = f;
13852   return t;
13853 }
13854
13855 /* Store the list of declarations of the current level.
13856    This is done for the parameter declarations of a function being defined,
13857    after they are modified in the light of any missing parameters.  */
13858
13859 static tree
13860 storedecls (decls)
13861      tree decls;
13862 {
13863   return current_binding_level->names = decls;
13864 }
13865
13866 /* Store the parameter declarations into the current function declaration.
13867    This is called after parsing the parameter declarations, before
13868    digesting the body of the function.
13869
13870    For an old-style definition, modify the function's type
13871    to specify at least the number of arguments.  */
13872
13873 static void
13874 store_parm_decls (int is_main_program UNUSED)
13875 {
13876   register tree fndecl = current_function_decl;
13877
13878   if (fndecl == error_mark_node)
13879     return;
13880
13881   /* This is a chain of PARM_DECLs from old-style parm declarations.  */
13882   DECL_ARGUMENTS (fndecl) = storedecls (nreverse (getdecls ()));
13883
13884   /* Initialize the RTL code for the function.  */
13885
13886   init_function_start (fndecl, input_filename, lineno);
13887
13888   /* Set up parameters and prepare for return, for the function.  */
13889
13890   expand_function_start (fndecl, 0);
13891 }
13892
13893 static tree
13894 start_decl (tree decl, bool is_top_level)
13895 {
13896   register tree tem;
13897   bool at_top_level = (current_binding_level == global_binding_level);
13898   bool top_level = is_top_level || at_top_level;
13899
13900   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13901      level anyway.  */
13902   assert (!is_top_level || !at_top_level);
13903
13904   if (DECL_INITIAL (decl) != NULL_TREE)
13905     {
13906       assert (DECL_INITIAL (decl) == error_mark_node);
13907       assert (!DECL_EXTERNAL (decl));
13908     }
13909   else if (top_level)
13910     assert ((TREE_STATIC (decl) == 1) || DECL_EXTERNAL (decl) == 1);
13911
13912   /* For Fortran, we by default put things in .common when possible.  */
13913   DECL_COMMON (decl) = 1;
13914
13915   /* Add this decl to the current binding level. TEM may equal DECL or it may
13916      be a previous decl of the same name.  */
13917   if (is_top_level)
13918     tem = pushdecl_top_level (decl);
13919   else
13920     tem = pushdecl (decl);
13921
13922   /* For a local variable, define the RTL now.  */
13923   if (!top_level
13924   /* But not if this is a duplicate decl and we preserved the rtl from the
13925      previous one (which may or may not happen).  */
13926       && !DECL_RTL_SET_P (tem))
13927     {
13928       if (TYPE_SIZE (TREE_TYPE (tem)) != 0)
13929         expand_decl (tem);
13930       else if (TREE_CODE (TREE_TYPE (tem)) == ARRAY_TYPE
13931                && DECL_INITIAL (tem) != 0)
13932         expand_decl (tem);
13933     }
13934
13935   return tem;
13936 }
13937
13938 /* Create the FUNCTION_DECL for a function definition.
13939    DECLSPECS and DECLARATOR are the parts of the declaration;
13940    they describe the function's name and the type it returns,
13941    but twisted together in a fashion that parallels the syntax of C.
13942
13943    This function creates a binding context for the function body
13944    as well as setting up the FUNCTION_DECL in current_function_decl.
13945
13946    Returns 1 on success.  If the DECLARATOR is not suitable for a function
13947    (it defines a datum instead), we return 0, which tells
13948    yyparse to report a parse error.
13949
13950    NESTED is nonzero for a function nested within another function.  */
13951
13952 static void
13953 start_function (tree name, tree type, int nested, int public)
13954 {
13955   tree decl1;
13956   tree restype;
13957   int old_immediate_size_expand = immediate_size_expand;
13958
13959   named_labels = 0;
13960   shadowed_labels = 0;
13961
13962   /* Don't expand any sizes in the return type of the function.  */
13963   immediate_size_expand = 0;
13964
13965   if (nested)
13966     {
13967       assert (!public);
13968       assert (current_function_decl != NULL_TREE);
13969       assert (DECL_CONTEXT (current_function_decl) == NULL_TREE);
13970     }
13971   else
13972     {
13973       assert (current_function_decl == NULL_TREE);
13974     }
13975
13976   if (TREE_CODE (type) == ERROR_MARK)
13977     decl1 = current_function_decl = error_mark_node;
13978   else
13979     {
13980       decl1 = build_decl (FUNCTION_DECL,
13981                           name,
13982                           type);
13983       TREE_PUBLIC (decl1) = public ? 1 : 0;
13984       if (nested)
13985         DECL_INLINE (decl1) = 1;
13986       TREE_STATIC (decl1) = 1;
13987       DECL_EXTERNAL (decl1) = 0;
13988
13989       announce_function (decl1);
13990
13991       /* Make the init_value nonzero so pushdecl knows this is not tentative.
13992          error_mark_node is replaced below (in poplevel) with the BLOCK.  */
13993       DECL_INITIAL (decl1) = error_mark_node;
13994
13995       /* Record the decl so that the function name is defined. If we already have
13996          a decl for this name, and it is a FUNCTION_DECL, use the old decl.  */
13997
13998       current_function_decl = pushdecl (decl1);
13999     }
14000
14001   if (!nested)
14002     ffecom_outer_function_decl_ = current_function_decl;
14003
14004   pushlevel (0);
14005   current_binding_level->prep_state = 2;
14006
14007   if (TREE_CODE (current_function_decl) != ERROR_MARK)
14008     {
14009       make_decl_rtl (current_function_decl, NULL);
14010
14011       restype = TREE_TYPE (TREE_TYPE (current_function_decl));
14012       DECL_RESULT (current_function_decl)
14013         = build_decl (RESULT_DECL, NULL_TREE, restype);
14014     }
14015
14016   if (!nested && (TREE_CODE (current_function_decl) != ERROR_MARK))
14017     TREE_ADDRESSABLE (current_function_decl) = 1;
14018
14019   immediate_size_expand = old_immediate_size_expand;
14020 }
14021 \f
14022 /* Here are the public functions the GNU back end needs.  */
14023
14024 tree
14025 convert (type, expr)
14026      tree type, expr;
14027 {
14028   register tree e = expr;
14029   register enum tree_code code = TREE_CODE (type);
14030
14031   if (type == TREE_TYPE (e)
14032       || TREE_CODE (e) == ERROR_MARK)
14033     return e;
14034   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
14035     return fold (build1 (NOP_EXPR, type, e));
14036   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
14037       || code == ERROR_MARK)
14038     return error_mark_node;
14039   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
14040     {
14041       assert ("void value not ignored as it ought to be" == NULL);
14042       return error_mark_node;
14043     }
14044   if (code == VOID_TYPE)
14045     return build1 (CONVERT_EXPR, type, e);
14046   if ((code != RECORD_TYPE)
14047       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
14048     e = ffecom_1 (REALPART_EXPR, TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e))),
14049                   e);
14050   if (code == INTEGER_TYPE || code == ENUMERAL_TYPE)
14051     return fold (convert_to_integer (type, e));
14052   if (code == POINTER_TYPE)
14053     return fold (convert_to_pointer (type, e));
14054   if (code == REAL_TYPE)
14055     return fold (convert_to_real (type, e));
14056   if (code == COMPLEX_TYPE)
14057     return fold (convert_to_complex (type, e));
14058   if (code == RECORD_TYPE)
14059     return fold (ffecom_convert_to_complex_ (type, e));
14060
14061   assert ("conversion to non-scalar type requested" == NULL);
14062   return error_mark_node;
14063 }
14064
14065 /* integrate_decl_tree calls this function, but since we don't use the
14066    DECL_LANG_SPECIFIC field, this is a no-op.  */
14067
14068 void
14069 copy_lang_decl (node)
14070      tree node UNUSED;
14071 {
14072 }
14073
14074 /* Return the list of declarations of the current level.
14075    Note that this list is in reverse order unless/until
14076    you nreverse it; and when you do nreverse it, you must
14077    store the result back using `storedecls' or you will lose.  */
14078
14079 tree
14080 getdecls ()
14081 {
14082   return current_binding_level->names;
14083 }
14084
14085 /* Nonzero if we are currently in the global binding level.  */
14086
14087 int
14088 global_bindings_p ()
14089 {
14090   return current_binding_level == global_binding_level;
14091 }
14092
14093 /* Print an error message for invalid use of an incomplete type.
14094    VALUE is the expression that was used (or 0 if that isn't known)
14095    and TYPE is the type that was invalid.  */
14096
14097 void
14098 incomplete_type_error (value, type)
14099      tree value UNUSED;
14100      tree type;
14101 {
14102   if (TREE_CODE (type) == ERROR_MARK)
14103     return;
14104
14105   assert ("incomplete type?!?" == NULL);
14106 }
14107
14108 /* Mark ARG for GC.  */
14109 static void
14110 mark_binding_level (void *arg)
14111 {
14112   struct binding_level *level = *(struct binding_level **) arg;
14113
14114   while (level)
14115     {
14116       ggc_mark_tree (level->names);
14117       ggc_mark_tree (level->blocks);
14118       ggc_mark_tree (level->this_block);
14119       level = level->level_chain;
14120     }
14121 }
14122
14123 void
14124 init_decl_processing ()
14125 {
14126   static tree *const tree_roots[] = {
14127     &current_function_decl,
14128     &string_type_node,
14129     &ffecom_tree_fun_type_void,
14130     &ffecom_integer_zero_node,
14131     &ffecom_integer_one_node,
14132     &ffecom_tree_subr_type,
14133     &ffecom_tree_ptr_to_subr_type,
14134     &ffecom_tree_blockdata_type,
14135     &ffecom_tree_xargc_,
14136     &ffecom_f2c_integer_type_node,
14137     &ffecom_f2c_ptr_to_integer_type_node,
14138     &ffecom_f2c_address_type_node,
14139     &ffecom_f2c_real_type_node,
14140     &ffecom_f2c_ptr_to_real_type_node,
14141     &ffecom_f2c_doublereal_type_node,
14142     &ffecom_f2c_complex_type_node,
14143     &ffecom_f2c_doublecomplex_type_node,
14144     &ffecom_f2c_longint_type_node,
14145     &ffecom_f2c_logical_type_node,
14146     &ffecom_f2c_flag_type_node,
14147     &ffecom_f2c_ftnlen_type_node,
14148     &ffecom_f2c_ftnlen_zero_node,
14149     &ffecom_f2c_ftnlen_one_node,
14150     &ffecom_f2c_ftnlen_two_node,
14151     &ffecom_f2c_ptr_to_ftnlen_type_node,
14152     &ffecom_f2c_ftnint_type_node,
14153     &ffecom_f2c_ptr_to_ftnint_type_node,
14154     &ffecom_outer_function_decl_,
14155     &ffecom_previous_function_decl_,
14156     &ffecom_which_entrypoint_decl_,
14157     &ffecom_float_zero_,
14158     &ffecom_float_half_,
14159     &ffecom_double_zero_,
14160     &ffecom_double_half_,
14161     &ffecom_func_result_,
14162     &ffecom_func_length_,
14163     &ffecom_multi_type_node_,
14164     &ffecom_multi_retval_,
14165     &named_labels,
14166     &shadowed_labels
14167   };
14168   size_t i;
14169
14170   malloc_init ();
14171
14172   /* Record our roots.  */
14173   for (i = 0; i < ARRAY_SIZE (tree_roots); i++)
14174     ggc_add_tree_root (tree_roots[i], 1);
14175   ggc_add_tree_root (&ffecom_tree_type[0][0],
14176                      FFEINFO_basictype*FFEINFO_kindtype);
14177   ggc_add_tree_root (&ffecom_tree_fun_type[0][0],
14178                      FFEINFO_basictype*FFEINFO_kindtype);
14179   ggc_add_tree_root (&ffecom_tree_ptr_to_fun_type[0][0],
14180                      FFEINFO_basictype*FFEINFO_kindtype);
14181   ggc_add_tree_root (ffecom_gfrt_, FFECOM_gfrt);
14182   ggc_add_root (&current_binding_level, 1, sizeof current_binding_level,
14183                 mark_binding_level);
14184   ggc_add_root (&free_binding_level, 1, sizeof current_binding_level,
14185                 mark_binding_level);
14186   ggc_add_root (&tracker_head, 1, sizeof tracker_head, mark_tracker_head);
14187
14188   ffe_init_0 ();
14189 }
14190
14191 const char *
14192 init_parse (filename)
14193      const char *filename;
14194 {
14195   /* Open input file.  */
14196   if (filename == 0 || !strcmp (filename, "-"))
14197     {
14198       finput = stdin;
14199       filename = "stdin";
14200     }
14201   else
14202     finput = fopen (filename, "r");
14203   if (finput == 0)
14204     fatal_io_error ("can't open %s", filename);
14205
14206 #ifdef IO_BUFFER_SIZE
14207   setvbuf (finput, (char *) xmalloc (IO_BUFFER_SIZE), _IOFBF, IO_BUFFER_SIZE);
14208 #endif
14209
14210   decl_printable_name = lang_printable_name;
14211   print_error_function = lang_print_error_function;
14212
14213   return filename;
14214 }
14215
14216 void
14217 finish_parse ()
14218 {
14219   fclose (finput);
14220 }
14221
14222 /* Delete the node BLOCK from the current binding level.
14223    This is used for the block inside a stmt expr ({...})
14224    so that the block can be reinserted where appropriate.  */
14225
14226 static void
14227 delete_block (block)
14228      tree block;
14229 {
14230   tree t;
14231   if (current_binding_level->blocks == block)
14232     current_binding_level->blocks = TREE_CHAIN (block);
14233   for (t = current_binding_level->blocks; t;)
14234     {
14235       if (TREE_CHAIN (t) == block)
14236         TREE_CHAIN (t) = TREE_CHAIN (block);
14237       else
14238         t = TREE_CHAIN (t);
14239     }
14240   TREE_CHAIN (block) = NULL;
14241   /* Clear TREE_USED which is always set by poplevel.
14242      The flag is set again if insert_block is called.  */
14243   TREE_USED (block) = 0;
14244 }
14245
14246 void
14247 insert_block (block)
14248      tree block;
14249 {
14250   TREE_USED (block) = 1;
14251   current_binding_level->blocks
14252     = chainon (current_binding_level->blocks, block);
14253 }
14254
14255 /* Each front end provides its own.  */
14256 static void ffe_init PARAMS ((void));
14257 static void ffe_finish PARAMS ((void));
14258 static void ffe_init_options PARAMS ((void));
14259
14260 #undef  LANG_HOOKS_NAME
14261 #define LANG_HOOKS_NAME                 "GNU F77"
14262 #undef  LANG_HOOKS_INIT
14263 #define LANG_HOOKS_INIT                 ffe_init
14264 #undef  LANG_HOOKS_FINISH
14265 #define LANG_HOOKS_FINISH               ffe_finish
14266 #undef  LANG_HOOKS_INIT_OPTIONS
14267 #define LANG_HOOKS_INIT_OPTIONS         ffe_init_options
14268 #undef  LANG_HOOKS_DECODE_OPTION
14269 #define LANG_HOOKS_DECODE_OPTION        ffe_decode_option
14270
14271 /* We do not wish to use alias-set based aliasing at all.  Used in the
14272    extreme (every object with its own set, with equivalences recorded) it
14273    might be helpful, but there are problems when it comes to inlining.  We
14274    get on ok with flag_argument_noalias, and alias-set aliasing does
14275    currently limit how stack slots can be reused, which is a lose.  */
14276 #undef LANG_HOOKS_GET_ALIAS_SET
14277 #define LANG_HOOKS_GET_ALIAS_SET hook_get_alias_set_0
14278
14279 const struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER;
14280
14281 /* used by print-tree.c */
14282
14283 void
14284 lang_print_xnode (file, node, indent)
14285      FILE *file UNUSED;
14286      tree node UNUSED;
14287      int indent UNUSED;
14288 {
14289 }
14290
14291 static void
14292 ffe_finish ()
14293 {
14294   ffe_terminate_0 ();
14295
14296   if (ffe_is_ffedebug ())
14297     malloc_pool_display (malloc_pool_image ());
14298 }
14299
14300 static void
14301 ffe_init_options ()
14302 {
14303   /* Set default options for Fortran.  */
14304   flag_move_all_movables = 1;
14305   flag_reduce_all_givs = 1;
14306   flag_argument_noalias = 2;
14307   flag_merge_constants = 2;
14308   flag_errno_math = 0;
14309   flag_complex_divide_method = 1;
14310 }
14311
14312 static void
14313 ffe_init ()
14314 {
14315   /* If the file is output from cpp, it should contain a first line
14316      `# 1 "real-filename"', and the current design of gcc (toplev.c
14317      in particular and the way it sets up information relied on by
14318      INCLUDE) requires that we read this now, and store the
14319      "real-filename" info in master_input_filename.  Ask the lexer
14320      to try doing this.  */
14321   ffelex_hash_kludge (finput);
14322 }
14323
14324 int
14325 mark_addressable (exp)
14326      tree exp;
14327 {
14328   register tree x = exp;
14329   while (1)
14330     switch (TREE_CODE (x))
14331       {
14332       case ADDR_EXPR:
14333       case COMPONENT_REF:
14334       case ARRAY_REF:
14335         x = TREE_OPERAND (x, 0);
14336         break;
14337
14338       case CONSTRUCTOR:
14339         TREE_ADDRESSABLE (x) = 1;
14340         return 1;
14341
14342       case VAR_DECL:
14343       case CONST_DECL:
14344       case PARM_DECL:
14345       case RESULT_DECL:
14346         if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x)
14347             && DECL_NONLOCAL (x))
14348           {
14349             if (TREE_PUBLIC (x))
14350               {
14351                 assert ("address of global register var requested" == NULL);
14352                 return 0;
14353               }
14354             assert ("address of register variable requested" == NULL);
14355           }
14356         else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x))
14357           {
14358             if (TREE_PUBLIC (x))
14359               {
14360                 assert ("address of global register var requested" == NULL);
14361                 return 0;
14362               }
14363             assert ("address of register var requested" == NULL);
14364           }
14365         put_var_into_stack (x);
14366
14367         /* drops in */
14368       case FUNCTION_DECL:
14369         TREE_ADDRESSABLE (x) = 1;
14370 #if 0                           /* poplevel deals with this now.  */
14371         if (DECL_CONTEXT (x) == 0)
14372           TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x)) = 1;
14373 #endif
14374
14375       default:
14376         return 1;
14377       }
14378 }
14379
14380 /* If DECL has a cleanup, build and return that cleanup here.
14381    This is a callback called by expand_expr.  */
14382
14383 tree
14384 maybe_build_cleanup (decl)
14385      tree decl UNUSED;
14386 {
14387   /* There are no cleanups in Fortran.  */
14388   return NULL_TREE;
14389 }
14390
14391 /* Exit a binding level.
14392    Pop the level off, and restore the state of the identifier-decl mappings
14393    that were in effect when this level was entered.
14394
14395    If KEEP is nonzero, this level had explicit declarations, so
14396    and create a "block" (a BLOCK node) for the level
14397    to record its declarations and subblocks for symbol table output.
14398
14399    If FUNCTIONBODY is nonzero, this level is the body of a function,
14400    so create a block as if KEEP were set and also clear out all
14401    label names.
14402
14403    If REVERSE is nonzero, reverse the order of decls before putting
14404    them into the BLOCK.  */
14405
14406 tree
14407 poplevel (keep, reverse, functionbody)
14408      int keep;
14409      int reverse;
14410      int functionbody;
14411 {
14412   register tree link;
14413   /* The chain of decls was accumulated in reverse order.
14414      Put it into forward order, just for cleanliness.  */
14415   tree decls;
14416   tree subblocks = current_binding_level->blocks;
14417   tree block = 0;
14418   tree decl;
14419   int block_previously_created;
14420
14421   /* Get the decls in the order they were written.
14422      Usually current_binding_level->names is in reverse order.
14423      But parameter decls were previously put in forward order.  */
14424
14425   if (reverse)
14426     current_binding_level->names
14427       = decls = nreverse (current_binding_level->names);
14428   else
14429     decls = current_binding_level->names;
14430
14431   /* Output any nested inline functions within this block
14432      if they weren't already output.  */
14433
14434   for (decl = decls; decl; decl = TREE_CHAIN (decl))
14435     if (TREE_CODE (decl) == FUNCTION_DECL
14436         && ! TREE_ASM_WRITTEN (decl)
14437         && DECL_INITIAL (decl) != 0
14438         && TREE_ADDRESSABLE (decl))
14439       {
14440         /* If this decl was copied from a file-scope decl
14441            on account of a block-scope extern decl,
14442            propagate TREE_ADDRESSABLE to the file-scope decl.
14443
14444            DECL_ABSTRACT_ORIGIN can be set to itself if warn_return_type is
14445            true, since then the decl goes through save_for_inline_copying.  */
14446         if (DECL_ABSTRACT_ORIGIN (decl) != 0
14447             && DECL_ABSTRACT_ORIGIN (decl) != decl)
14448           TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl)) = 1;
14449         else if (DECL_SAVED_INSNS (decl) != 0)
14450           {
14451             push_function_context ();
14452             output_inline_function (decl);
14453             pop_function_context ();
14454           }
14455       }
14456
14457   /* If there were any declarations or structure tags in that level,
14458      or if this level is a function body,
14459      create a BLOCK to record them for the life of this function.  */
14460
14461   block = 0;
14462   block_previously_created = (current_binding_level->this_block != 0);
14463   if (block_previously_created)
14464     block = current_binding_level->this_block;
14465   else if (keep || functionbody)
14466     block = make_node (BLOCK);
14467   if (block != 0)
14468     {
14469       BLOCK_VARS (block) = decls;
14470       BLOCK_SUBBLOCKS (block) = subblocks;
14471     }
14472
14473   /* In each subblock, record that this is its superior.  */
14474
14475   for (link = subblocks; link; link = TREE_CHAIN (link))
14476     BLOCK_SUPERCONTEXT (link) = block;
14477
14478   /* Clear out the meanings of the local variables of this level.  */
14479
14480   for (link = decls; link; link = TREE_CHAIN (link))
14481     {
14482       if (DECL_NAME (link) != 0)
14483         {
14484           /* If the ident. was used or addressed via a local extern decl,
14485              don't forget that fact.  */
14486           if (DECL_EXTERNAL (link))
14487             {
14488               if (TREE_USED (link))
14489                 TREE_USED (DECL_NAME (link)) = 1;
14490               if (TREE_ADDRESSABLE (link))
14491                 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (link)) = 1;
14492             }
14493           IDENTIFIER_LOCAL_VALUE (DECL_NAME (link)) = 0;
14494         }
14495     }
14496
14497   /* If the level being exited is the top level of a function,
14498      check over all the labels, and clear out the current
14499      (function local) meanings of their names.  */
14500
14501   if (functionbody)
14502     {
14503       /* If this is the top level block of a function,
14504          the vars are the function's parameters.
14505          Don't leave them in the BLOCK because they are
14506          found in the FUNCTION_DECL instead.  */
14507
14508       BLOCK_VARS (block) = 0;
14509     }
14510
14511   /* Pop the current level, and free the structure for reuse.  */
14512
14513   {
14514     register struct binding_level *level = current_binding_level;
14515     current_binding_level = current_binding_level->level_chain;
14516
14517     level->level_chain = free_binding_level;
14518     free_binding_level = level;
14519   }
14520
14521   /* Dispose of the block that we just made inside some higher level.  */
14522   if (functionbody
14523       && current_function_decl != error_mark_node)
14524     DECL_INITIAL (current_function_decl) = block;
14525   else if (block)
14526     {
14527       if (!block_previously_created)
14528         current_binding_level->blocks
14529           = chainon (current_binding_level->blocks, block);
14530     }
14531   /* If we did not make a block for the level just exited,
14532      any blocks made for inner levels
14533      (since they cannot be recorded as subblocks in that level)
14534      must be carried forward so they will later become subblocks
14535      of something else.  */
14536   else if (subblocks)
14537     current_binding_level->blocks
14538       = chainon (current_binding_level->blocks, subblocks);
14539
14540   if (block)
14541     TREE_USED (block) = 1;
14542   return block;
14543 }
14544
14545 void
14546 print_lang_decl (file, node, indent)
14547      FILE *file UNUSED;
14548      tree node UNUSED;
14549      int indent UNUSED;
14550 {
14551 }
14552
14553 void
14554 print_lang_identifier (file, node, indent)
14555      FILE *file;
14556      tree node;
14557      int indent;
14558 {
14559   print_node (file, "global", IDENTIFIER_GLOBAL_VALUE (node), indent + 4);
14560   print_node (file, "local", IDENTIFIER_LOCAL_VALUE (node), indent + 4);
14561 }
14562
14563 void
14564 print_lang_statistics ()
14565 {
14566 }
14567
14568 void
14569 print_lang_type (file, node, indent)
14570      FILE *file UNUSED;
14571      tree node UNUSED;
14572      int indent UNUSED;
14573 {
14574 }
14575
14576 /* Record a decl-node X as belonging to the current lexical scope.
14577    Check for errors (such as an incompatible declaration for the same
14578    name already seen in the same scope).
14579
14580    Returns either X or an old decl for the same name.
14581    If an old decl is returned, it may have been smashed
14582    to agree with what X says.  */
14583
14584 tree
14585 pushdecl (x)
14586      tree x;
14587 {
14588   register tree t;
14589   register tree name = DECL_NAME (x);
14590   register struct binding_level *b = current_binding_level;
14591
14592   if ((TREE_CODE (x) == FUNCTION_DECL)
14593       && (DECL_INITIAL (x) == 0)
14594       && DECL_EXTERNAL (x))
14595     DECL_CONTEXT (x) = NULL_TREE;
14596   else
14597     DECL_CONTEXT (x) = current_function_decl;
14598
14599   if (name)
14600     {
14601       if (IDENTIFIER_INVENTED (name))
14602         {
14603           DECL_ARTIFICIAL (x) = 1;
14604           DECL_IN_SYSTEM_HEADER (x) = 1;
14605         }
14606
14607       t = lookup_name_current_level (name);
14608
14609       assert ((t == NULL_TREE) || (DECL_CONTEXT (x) == NULL_TREE));
14610
14611       /* Don't push non-parms onto list for parms until we understand
14612          why we're doing this and whether it works.  */
14613
14614       assert ((b == global_binding_level)
14615               || !ffecom_transform_only_dummies_
14616               || TREE_CODE (x) == PARM_DECL);
14617
14618       if ((t != NULL_TREE) && duplicate_decls (x, t))
14619         return t;
14620
14621       /* If we are processing a typedef statement, generate a whole new
14622          ..._TYPE node (which will be just an variant of the existing
14623          ..._TYPE node with identical properties) and then install the
14624          TYPE_DECL node generated to represent the typedef name as the
14625          TYPE_NAME of this brand new (duplicate) ..._TYPE node.
14626
14627          The whole point here is to end up with a situation where each and every
14628          ..._TYPE node the compiler creates will be uniquely associated with
14629          AT MOST one node representing a typedef name. This way, even though
14630          the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL
14631          (i.e. "typedef name") nodes very early on, later parts of the
14632          compiler can always do the reverse translation and get back the
14633          corresponding typedef name.  For example, given:
14634
14635          typedef struct S MY_TYPE; MY_TYPE object;
14636
14637          Later parts of the compiler might only know that `object' was of type
14638          `struct S' if it were not for code just below.  With this code
14639          however, later parts of the compiler see something like:
14640
14641          struct S' == struct S typedef struct S' MY_TYPE; struct S' object;
14642
14643          And they can then deduce (from the node for type struct S') that the
14644          original object declaration was:
14645
14646          MY_TYPE object;
14647
14648          Being able to do this is important for proper support of protoize, and
14649          also for generating precise symbolic debugging information which
14650          takes full account of the programmer's (typedef) vocabulary.
14651
14652          Obviously, we don't want to generate a duplicate ..._TYPE node if the
14653          TYPE_DECL node that we are now processing really represents a
14654          standard built-in type.
14655
14656          Since all standard types are effectively declared at line zero in the
14657          source file, we can easily check to see if we are working on a
14658          standard type by checking the current value of lineno.  */
14659
14660       if (TREE_CODE (x) == TYPE_DECL)
14661         {
14662           if (DECL_SOURCE_LINE (x) == 0)
14663             {
14664               if (TYPE_NAME (TREE_TYPE (x)) == 0)
14665                 TYPE_NAME (TREE_TYPE (x)) = x;
14666             }
14667           else if (TREE_TYPE (x) != error_mark_node)
14668             {
14669               tree tt = TREE_TYPE (x);
14670
14671               tt = build_type_copy (tt);
14672               TYPE_NAME (tt) = x;
14673               TREE_TYPE (x) = tt;
14674             }
14675         }
14676
14677       /* This name is new in its binding level. Install the new declaration
14678          and return it.  */
14679       if (b == global_binding_level)
14680         IDENTIFIER_GLOBAL_VALUE (name) = x;
14681       else
14682         IDENTIFIER_LOCAL_VALUE (name) = x;
14683     }
14684
14685   /* Put decls on list in reverse order. We will reverse them later if
14686      necessary.  */
14687   TREE_CHAIN (x) = b->names;
14688   b->names = x;
14689
14690   return x;
14691 }
14692
14693 /* Nonzero if the current level needs to have a BLOCK made.  */
14694
14695 static int
14696 kept_level_p ()
14697 {
14698   tree decl;
14699
14700   for (decl = current_binding_level->names;
14701        decl;
14702        decl = TREE_CHAIN (decl))
14703     {
14704       if (TREE_USED (decl) || TREE_CODE (decl) != VAR_DECL
14705           || (DECL_NAME (decl) && ! DECL_ARTIFICIAL (decl)))
14706         /* Currently, there aren't supposed to be non-artificial names
14707            at other than the top block for a function -- they're
14708            believed to always be temps.  But it's wise to check anyway.  */
14709         return 1;
14710     }
14711   return 0;
14712 }
14713
14714 /* Enter a new binding level.
14715    If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
14716    not for that of tags.  */
14717
14718 void
14719 pushlevel (tag_transparent)
14720      int tag_transparent;
14721 {
14722   register struct binding_level *newlevel = NULL_BINDING_LEVEL;
14723
14724   assert (! tag_transparent);
14725
14726   if (current_binding_level == global_binding_level)
14727     {
14728       named_labels = 0;
14729     }
14730
14731   /* Reuse or create a struct for this binding level.  */
14732
14733   if (free_binding_level)
14734     {
14735       newlevel = free_binding_level;
14736       free_binding_level = free_binding_level->level_chain;
14737     }
14738   else
14739     {
14740       newlevel = make_binding_level ();
14741     }
14742
14743   /* Add this level to the front of the chain (stack) of levels that
14744      are active.  */
14745
14746   *newlevel = clear_binding_level;
14747   newlevel->level_chain = current_binding_level;
14748   current_binding_level = newlevel;
14749 }
14750
14751 /* Set the BLOCK node for the innermost scope
14752    (the one we are currently in).  */
14753
14754 void
14755 set_block (block)
14756      register tree block;
14757 {
14758   current_binding_level->this_block = block;
14759   current_binding_level->names = chainon (current_binding_level->names,
14760                                           BLOCK_VARS (block));
14761   current_binding_level->blocks = chainon (current_binding_level->blocks,
14762                                            BLOCK_SUBBLOCKS (block));
14763 }
14764
14765 /* ~~gcc/tree.h *should* declare this, because toplev.c references it.  */
14766
14767 /* Can't 'yydebug' a front end not generated by yacc/bison!  */
14768
14769 void
14770 set_yydebug (value)
14771      int value;
14772 {
14773   if (value)
14774     fprintf (stderr, "warning: no yacc/bison-generated output to debug!\n");
14775 }
14776
14777 tree
14778 signed_or_unsigned_type (unsignedp, type)
14779      int unsignedp;
14780      tree type;
14781 {
14782   tree type2;
14783
14784   if (! INTEGRAL_TYPE_P (type))
14785     return type;
14786   if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node))
14787     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
14788   if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node))
14789     return unsignedp ? unsigned_type_node : integer_type_node;
14790   if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node))
14791     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
14792   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node))
14793     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
14794   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node))
14795     return (unsignedp ? long_long_unsigned_type_node
14796             : long_long_integer_type_node);
14797
14798   type2 = type_for_size (TYPE_PRECISION (type), unsignedp);
14799   if (type2 == NULL_TREE)
14800     return type;
14801
14802   return type2;
14803 }
14804
14805 tree
14806 signed_type (type)
14807      tree type;
14808 {
14809   tree type1 = TYPE_MAIN_VARIANT (type);
14810   ffeinfoKindtype kt;
14811   tree type2;
14812
14813   if (type1 == unsigned_char_type_node || type1 == char_type_node)
14814     return signed_char_type_node;
14815   if (type1 == unsigned_type_node)
14816     return integer_type_node;
14817   if (type1 == short_unsigned_type_node)
14818     return short_integer_type_node;
14819   if (type1 == long_unsigned_type_node)
14820     return long_integer_type_node;
14821   if (type1 == long_long_unsigned_type_node)
14822     return long_long_integer_type_node;
14823 #if 0   /* gcc/c-* files only */
14824   if (type1 == unsigned_intDI_type_node)
14825     return intDI_type_node;
14826   if (type1 == unsigned_intSI_type_node)
14827     return intSI_type_node;
14828   if (type1 == unsigned_intHI_type_node)
14829     return intHI_type_node;
14830   if (type1 == unsigned_intQI_type_node)
14831     return intQI_type_node;
14832 #endif
14833
14834   type2 = type_for_size (TYPE_PRECISION (type1), 0);
14835   if (type2 != NULL_TREE)
14836     return type2;
14837
14838   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
14839     {
14840       type2 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
14841
14842       if (type1 == type2)
14843         return ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
14844     }
14845
14846   return type;
14847 }
14848
14849 /* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
14850    or validate its data type for an `if' or `while' statement or ?..: exp.
14851
14852    This preparation consists of taking the ordinary
14853    representation of an expression expr and producing a valid tree
14854    boolean expression describing whether expr is nonzero.  We could
14855    simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
14856    but we optimize comparisons, &&, ||, and !.
14857
14858    The resulting type should always be `integer_type_node'.  */
14859
14860 tree
14861 truthvalue_conversion (expr)
14862      tree expr;
14863 {
14864   if (TREE_CODE (expr) == ERROR_MARK)
14865     return expr;
14866
14867 #if 0 /* This appears to be wrong for C++.  */
14868   /* These really should return error_mark_node after 2.4 is stable.
14869      But not all callers handle ERROR_MARK properly.  */
14870   switch (TREE_CODE (TREE_TYPE (expr)))
14871     {
14872     case RECORD_TYPE:
14873       error ("struct type value used where scalar is required");
14874       return integer_zero_node;
14875
14876     case UNION_TYPE:
14877       error ("union type value used where scalar is required");
14878       return integer_zero_node;
14879
14880     case ARRAY_TYPE:
14881       error ("array type value used where scalar is required");
14882       return integer_zero_node;
14883
14884     default:
14885       break;
14886     }
14887 #endif /* 0 */
14888
14889   switch (TREE_CODE (expr))
14890     {
14891       /* It is simpler and generates better code to have only TRUTH_*_EXPR
14892          or comparison expressions as truth values at this level.  */
14893 #if 0
14894     case COMPONENT_REF:
14895       /* A one-bit unsigned bit-field is already acceptable.  */
14896       if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr, 1)))
14897           && TREE_UNSIGNED (TREE_OPERAND (expr, 1)))
14898         return expr;
14899       break;
14900 #endif
14901
14902     case EQ_EXPR:
14903       /* It is simpler and generates better code to have only TRUTH_*_EXPR
14904          or comparison expressions as truth values at this level.  */
14905 #if 0
14906       if (integer_zerop (TREE_OPERAND (expr, 1)))
14907         return build_unary_op (TRUTH_NOT_EXPR, TREE_OPERAND (expr, 0), 0);
14908 #endif
14909     case NE_EXPR: case LE_EXPR: case GE_EXPR: case LT_EXPR: case GT_EXPR:
14910     case TRUTH_ANDIF_EXPR:
14911     case TRUTH_ORIF_EXPR:
14912     case TRUTH_AND_EXPR:
14913     case TRUTH_OR_EXPR:
14914     case TRUTH_XOR_EXPR:
14915       TREE_TYPE (expr) = integer_type_node;
14916       return expr;
14917
14918     case ERROR_MARK:
14919       return expr;
14920
14921     case INTEGER_CST:
14922       return integer_zerop (expr) ? integer_zero_node : integer_one_node;
14923
14924     case REAL_CST:
14925       return real_zerop (expr) ? integer_zero_node : integer_one_node;
14926
14927     case ADDR_EXPR:
14928       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 0)))
14929         return build (COMPOUND_EXPR, integer_type_node,
14930                       TREE_OPERAND (expr, 0), integer_one_node);
14931       else
14932         return integer_one_node;
14933
14934     case COMPLEX_EXPR:
14935       return ffecom_2 ((TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1))
14936                         ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
14937                        integer_type_node,
14938                        truthvalue_conversion (TREE_OPERAND (expr, 0)),
14939                        truthvalue_conversion (TREE_OPERAND (expr, 1)));
14940
14941     case NEGATE_EXPR:
14942     case ABS_EXPR:
14943     case FLOAT_EXPR:
14944     case FFS_EXPR:
14945       /* These don't change whether an object is non-zero or zero.  */
14946       return truthvalue_conversion (TREE_OPERAND (expr, 0));
14947
14948     case LROTATE_EXPR:
14949     case RROTATE_EXPR:
14950       /* These don't change whether an object is zero or non-zero, but
14951          we can't ignore them if their second arg has side-effects.  */
14952       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1)))
14953         return build (COMPOUND_EXPR, integer_type_node, TREE_OPERAND (expr, 1),
14954                       truthvalue_conversion (TREE_OPERAND (expr, 0)));
14955       else
14956         return truthvalue_conversion (TREE_OPERAND (expr, 0));
14957
14958     case COND_EXPR:
14959       /* Distribute the conversion into the arms of a COND_EXPR.  */
14960       return fold (build (COND_EXPR, integer_type_node, TREE_OPERAND (expr, 0),
14961                           truthvalue_conversion (TREE_OPERAND (expr, 1)),
14962                           truthvalue_conversion (TREE_OPERAND (expr, 2))));
14963
14964     case CONVERT_EXPR:
14965       /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
14966          since that affects how `default_conversion' will behave.  */
14967       if (TREE_CODE (TREE_TYPE (expr)) == REFERENCE_TYPE
14968           || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) == REFERENCE_TYPE)
14969         break;
14970       /* fall through... */
14971     case NOP_EXPR:
14972       /* If this is widening the argument, we can ignore it.  */
14973       if (TYPE_PRECISION (TREE_TYPE (expr))
14974           >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr, 0))))
14975         return truthvalue_conversion (TREE_OPERAND (expr, 0));
14976       break;
14977
14978     case MINUS_EXPR:
14979       /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize
14980          this case.  */
14981       if (TARGET_FLOAT_FORMAT == IEEE_FLOAT_FORMAT
14982           && TREE_CODE (TREE_TYPE (expr)) == REAL_TYPE)
14983         break;
14984       /* fall through... */
14985     case BIT_XOR_EXPR:
14986       /* This and MINUS_EXPR can be changed into a comparison of the
14987          two objects.  */
14988       if (TREE_TYPE (TREE_OPERAND (expr, 0))
14989           == TREE_TYPE (TREE_OPERAND (expr, 1)))
14990         return ffecom_2 (NE_EXPR, integer_type_node,
14991                          TREE_OPERAND (expr, 0),
14992                          TREE_OPERAND (expr, 1));
14993       return ffecom_2 (NE_EXPR, integer_type_node,
14994                        TREE_OPERAND (expr, 0),
14995                        fold (build1 (NOP_EXPR,
14996                                      TREE_TYPE (TREE_OPERAND (expr, 0)),
14997                                      TREE_OPERAND (expr, 1))));
14998
14999     case BIT_AND_EXPR:
15000       if (integer_onep (TREE_OPERAND (expr, 1)))
15001         return expr;
15002       break;
15003
15004     case MODIFY_EXPR:
15005 #if 0                           /* No such thing in Fortran. */
15006       if (warn_parentheses && C_EXP_ORIGINAL_CODE (expr) == MODIFY_EXPR)
15007         warning ("suggest parentheses around assignment used as truth value");
15008 #endif
15009       break;
15010
15011     default:
15012       break;
15013     }
15014
15015   if (TREE_CODE (TREE_TYPE (expr)) == COMPLEX_TYPE)
15016     return (ffecom_2
15017             ((TREE_SIDE_EFFECTS (expr)
15018               ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
15019              integer_type_node,
15020              truthvalue_conversion (ffecom_1 (REALPART_EXPR,
15021                                               TREE_TYPE (TREE_TYPE (expr)),
15022                                               expr)),
15023              truthvalue_conversion (ffecom_1 (IMAGPART_EXPR,
15024                                               TREE_TYPE (TREE_TYPE (expr)),
15025                                               expr))));
15026
15027   return ffecom_2 (NE_EXPR, integer_type_node,
15028                    expr,
15029                    convert (TREE_TYPE (expr), integer_zero_node));
15030 }
15031
15032 tree
15033 type_for_mode (mode, unsignedp)
15034      enum machine_mode mode;
15035      int unsignedp;
15036 {
15037   int i;
15038   int j;
15039   tree t;
15040
15041   if (mode == TYPE_MODE (integer_type_node))
15042     return unsignedp ? unsigned_type_node : integer_type_node;
15043
15044   if (mode == TYPE_MODE (signed_char_type_node))
15045     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15046
15047   if (mode == TYPE_MODE (short_integer_type_node))
15048     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15049
15050   if (mode == TYPE_MODE (long_integer_type_node))
15051     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15052
15053   if (mode == TYPE_MODE (long_long_integer_type_node))
15054     return unsignedp ? long_long_unsigned_type_node : long_long_integer_type_node;
15055
15056 #if HOST_BITS_PER_WIDE_INT >= 64
15057   if (mode == TYPE_MODE (intTI_type_node))
15058     return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
15059 #endif
15060
15061   if (mode == TYPE_MODE (float_type_node))
15062     return float_type_node;
15063
15064   if (mode == TYPE_MODE (double_type_node))
15065     return double_type_node;
15066
15067   if (mode == TYPE_MODE (build_pointer_type (char_type_node)))
15068     return build_pointer_type (char_type_node);
15069
15070   if (mode == TYPE_MODE (build_pointer_type (integer_type_node)))
15071     return build_pointer_type (integer_type_node);
15072
15073   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
15074     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
15075       {
15076         if (((t = ffecom_tree_type[i][j]) != NULL_TREE)
15077             && (mode == TYPE_MODE (t)))
15078           {
15079             if ((i == FFEINFO_basictypeINTEGER) && unsignedp)
15080               return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][j];
15081             else
15082               return t;
15083           }
15084       }
15085
15086   return 0;
15087 }
15088
15089 tree
15090 type_for_size (bits, unsignedp)
15091      unsigned bits;
15092      int unsignedp;
15093 {
15094   ffeinfoKindtype kt;
15095   tree type_node;
15096
15097   if (bits == TYPE_PRECISION (integer_type_node))
15098     return unsignedp ? unsigned_type_node : integer_type_node;
15099
15100   if (bits == TYPE_PRECISION (signed_char_type_node))
15101     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15102
15103   if (bits == TYPE_PRECISION (short_integer_type_node))
15104     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15105
15106   if (bits == TYPE_PRECISION (long_integer_type_node))
15107     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15108
15109   if (bits == TYPE_PRECISION (long_long_integer_type_node))
15110     return (unsignedp ? long_long_unsigned_type_node
15111             : long_long_integer_type_node);
15112
15113   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15114     {
15115       type_node = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15116
15117       if ((type_node != NULL_TREE) && (bits == TYPE_PRECISION (type_node)))
15118         return unsignedp ? ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]
15119           : type_node;
15120     }
15121
15122   return 0;
15123 }
15124
15125 tree
15126 unsigned_type (type)
15127      tree type;
15128 {
15129   tree type1 = TYPE_MAIN_VARIANT (type);
15130   ffeinfoKindtype kt;
15131   tree type2;
15132
15133   if (type1 == signed_char_type_node || type1 == char_type_node)
15134     return unsigned_char_type_node;
15135   if (type1 == integer_type_node)
15136     return unsigned_type_node;
15137   if (type1 == short_integer_type_node)
15138     return short_unsigned_type_node;
15139   if (type1 == long_integer_type_node)
15140     return long_unsigned_type_node;
15141   if (type1 == long_long_integer_type_node)
15142     return long_long_unsigned_type_node;
15143 #if 0   /* gcc/c-* files only */
15144   if (type1 == intDI_type_node)
15145     return unsigned_intDI_type_node;
15146   if (type1 == intSI_type_node)
15147     return unsigned_intSI_type_node;
15148   if (type1 == intHI_type_node)
15149     return unsigned_intHI_type_node;
15150   if (type1 == intQI_type_node)
15151     return unsigned_intQI_type_node;
15152 #endif
15153
15154   type2 = type_for_size (TYPE_PRECISION (type1), 1);
15155   if (type2 != NULL_TREE)
15156     return type2;
15157
15158   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15159     {
15160       type2 = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15161
15162       if (type1 == type2)
15163         return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
15164     }
15165
15166   return type;
15167 }
15168
15169 void
15170 lang_mark_tree (t)
15171      union tree_node *t ATTRIBUTE_UNUSED;
15172 {
15173   if (TREE_CODE (t) == IDENTIFIER_NODE)
15174     {
15175       struct lang_identifier *i = (struct lang_identifier *) t;
15176       ggc_mark_tree (IDENTIFIER_GLOBAL_VALUE (i));
15177       ggc_mark_tree (IDENTIFIER_LOCAL_VALUE (i));
15178       ggc_mark_tree (IDENTIFIER_LABEL_VALUE (i));
15179     }
15180   else if (TYPE_P (t) && TYPE_LANG_SPECIFIC (t))
15181     ggc_mark (TYPE_LANG_SPECIFIC (t));
15182 }
15183 \f
15184 /* From gcc/cccp.c, the code to handle -I.  */
15185
15186 /* Skip leading "./" from a directory name.
15187    This may yield the empty string, which represents the current directory.  */
15188
15189 static const char *
15190 skip_redundant_dir_prefix (const char *dir)
15191 {
15192   while (dir[0] == '.' && dir[1] == '/')
15193     for (dir += 2; *dir == '/'; dir++)
15194       continue;
15195   if (dir[0] == '.' && !dir[1])
15196     dir++;
15197   return dir;
15198 }
15199
15200 /* The file_name_map structure holds a mapping of file names for a
15201    particular directory.  This mapping is read from the file named
15202    FILE_NAME_MAP_FILE in that directory.  Such a file can be used to
15203    map filenames on a file system with severe filename restrictions,
15204    such as DOS.  The format of the file name map file is just a series
15205    of lines with two tokens on each line.  The first token is the name
15206    to map, and the second token is the actual name to use.  */
15207
15208 struct file_name_map
15209 {
15210   struct file_name_map *map_next;
15211   char *map_from;
15212   char *map_to;
15213 };
15214
15215 #define FILE_NAME_MAP_FILE "header.gcc"
15216
15217 /* Current maximum length of directory names in the search path
15218    for include files.  (Altered as we get more of them.)  */
15219
15220 static int max_include_len = 0;
15221
15222 struct file_name_list
15223   {
15224     struct file_name_list *next;
15225     char *fname;
15226     /* Mapping of file names for this directory.  */
15227     struct file_name_map *name_map;
15228     /* Non-zero if name_map is valid.  */
15229     int got_name_map;
15230   };
15231
15232 static struct file_name_list *include = NULL;   /* First dir to search */
15233 static struct file_name_list *last_include = NULL;      /* Last in chain */
15234
15235 /* I/O buffer structure.
15236    The `fname' field is nonzero for source files and #include files
15237    and for the dummy text used for -D and -U.
15238    It is zero for rescanning results of macro expansion
15239    and for expanding macro arguments.  */
15240 #define INPUT_STACK_MAX 400
15241 static struct file_buf {
15242   const char *fname;
15243   /* Filename specified with #line command.  */
15244   const char *nominal_fname;
15245   /* Record where in the search path this file was found.
15246      For #include_next.  */
15247   struct file_name_list *dir;
15248   ffewhereLine line;
15249   ffewhereColumn column;
15250 } instack[INPUT_STACK_MAX];
15251
15252 static int last_error_tick = 0;    /* Incremented each time we print it.  */
15253 static int input_file_stack_tick = 0;  /* Incremented when status changes.  */
15254
15255 /* Current nesting level of input sources.
15256    `instack[indepth]' is the level currently being read.  */
15257 static int indepth = -1;
15258
15259 typedef struct file_buf FILE_BUF;
15260
15261 /* Nonzero means -I- has been seen,
15262    so don't look for #include "foo" the source-file directory.  */
15263 static int ignore_srcdir;
15264
15265 #ifndef INCLUDE_LEN_FUDGE
15266 #define INCLUDE_LEN_FUDGE 0
15267 #endif
15268
15269 static void append_include_chain (struct file_name_list *first,
15270                                   struct file_name_list *last);
15271 static FILE *open_include_file (char *filename,
15272                                 struct file_name_list *searchptr);
15273 static void print_containing_files (ffebadSeverity sev);
15274 static char *read_filename_string (int ch, FILE *f);
15275 static struct file_name_map *read_name_map (const char *dirname);
15276
15277 /* Append a chain of `struct file_name_list's
15278    to the end of the main include chain.
15279    FIRST is the beginning of the chain to append, and LAST is the end.  */
15280
15281 static void
15282 append_include_chain (first, last)
15283      struct file_name_list *first, *last;
15284 {
15285   struct file_name_list *dir;
15286
15287   if (!first || !last)
15288     return;
15289
15290   if (include == 0)
15291     include = first;
15292   else
15293     last_include->next = first;
15294
15295   for (dir = first; ; dir = dir->next) {
15296     int len = strlen (dir->fname) + INCLUDE_LEN_FUDGE;
15297     if (len > max_include_len)
15298       max_include_len = len;
15299     if (dir == last)
15300       break;
15301   }
15302
15303   last->next = NULL;
15304   last_include = last;
15305 }
15306
15307 /* Try to open include file FILENAME.  SEARCHPTR is the directory
15308    being tried from the include file search path.  This function maps
15309    filenames on file systems based on information read by
15310    read_name_map.  */
15311
15312 static FILE *
15313 open_include_file (filename, searchptr)
15314      char *filename;
15315      struct file_name_list *searchptr;
15316 {
15317   register struct file_name_map *map;
15318   register char *from;
15319   char *p, *dir;
15320
15321   if (searchptr && ! searchptr->got_name_map)
15322     {
15323       searchptr->name_map = read_name_map (searchptr->fname
15324                                            ? searchptr->fname : ".");
15325       searchptr->got_name_map = 1;
15326     }
15327
15328   /* First check the mapping for the directory we are using.  */
15329   if (searchptr && searchptr->name_map)
15330     {
15331       from = filename;
15332       if (searchptr->fname)
15333         from += strlen (searchptr->fname) + 1;
15334       for (map = searchptr->name_map; map; map = map->map_next)
15335         {
15336           if (! strcmp (map->map_from, from))
15337             {
15338               /* Found a match.  */
15339               return fopen (map->map_to, "r");
15340             }
15341         }
15342     }
15343
15344   /* Try to find a mapping file for the particular directory we are
15345      looking in.  Thus #include <sys/types.h> will look up sys/types.h
15346      in /usr/include/header.gcc and look up types.h in
15347      /usr/include/sys/header.gcc.  */
15348   p = strrchr (filename, '/');
15349 #ifdef DIR_SEPARATOR
15350   if (! p) p = strrchr (filename, DIR_SEPARATOR);
15351   else {
15352     char *tmp = strrchr (filename, DIR_SEPARATOR);
15353     if (tmp != NULL && tmp > p) p = tmp;
15354   }
15355 #endif
15356   if (! p)
15357     p = filename;
15358   if (searchptr
15359       && searchptr->fname
15360       && strlen (searchptr->fname) == (size_t) (p - filename)
15361       && ! strncmp (searchptr->fname, filename, (int) (p - filename)))
15362     {
15363       /* FILENAME is in SEARCHPTR, which we've already checked.  */
15364       return fopen (filename, "r");
15365     }
15366
15367   if (p == filename)
15368     {
15369       from = filename;
15370       map = read_name_map (".");
15371     }
15372   else
15373     {
15374       dir = (char *) xmalloc (p - filename + 1);
15375       memcpy (dir, filename, p - filename);
15376       dir[p - filename] = '\0';
15377       from = p + 1;
15378       map = read_name_map (dir);
15379       free (dir);
15380     }
15381   for (; map; map = map->map_next)
15382     if (! strcmp (map->map_from, from))
15383       return fopen (map->map_to, "r");
15384
15385   return fopen (filename, "r");
15386 }
15387
15388 /* Print the file names and line numbers of the #include
15389    commands which led to the current file.  */
15390
15391 static void
15392 print_containing_files (ffebadSeverity sev)
15393 {
15394   FILE_BUF *ip = NULL;
15395   int i;
15396   int first = 1;
15397   const char *str1;
15398   const char *str2;
15399
15400   /* If stack of files hasn't changed since we last printed
15401      this info, don't repeat it.  */
15402   if (last_error_tick == input_file_stack_tick)
15403     return;
15404
15405   for (i = indepth; i >= 0; i--)
15406     if (instack[i].fname != NULL) {
15407       ip = &instack[i];
15408       break;
15409     }
15410
15411   /* Give up if we don't find a source file.  */
15412   if (ip == NULL)
15413     return;
15414
15415   /* Find the other, outer source files.  */
15416   for (i--; i >= 0; i--)
15417     if (instack[i].fname != NULL)
15418       {
15419         ip = &instack[i];
15420         if (first)
15421           {
15422             first = 0;
15423             str1 = "In file included";
15424           }
15425         else
15426           {
15427             str1 = "...          ...";
15428           }
15429
15430         if (i == 1)
15431           str2 = ":";
15432         else
15433           str2 = "";
15434
15435         ffebad_start_msg ("%A from %B at %0%C", sev);
15436         ffebad_here (0, ip->line, ip->column);
15437         ffebad_string (str1);
15438         ffebad_string (ip->nominal_fname);
15439         ffebad_string (str2);
15440         ffebad_finish ();
15441       }
15442
15443   /* Record we have printed the status as of this time.  */
15444   last_error_tick = input_file_stack_tick;
15445 }
15446
15447 /* Read a space delimited string of unlimited length from a stdio
15448    file.  */
15449
15450 static char *
15451 read_filename_string (ch, f)
15452      int ch;
15453      FILE *f;
15454 {
15455   char *alloc, *set;
15456   int len;
15457
15458   len = 20;
15459   set = alloc = xmalloc (len + 1);
15460   if (! ISSPACE (ch))
15461     {
15462       *set++ = ch;
15463       while ((ch = getc (f)) != EOF && ! ISSPACE (ch))
15464         {
15465           if (set - alloc == len)
15466             {
15467               len *= 2;
15468               alloc = xrealloc (alloc, len + 1);
15469               set = alloc + len / 2;
15470             }
15471           *set++ = ch;
15472         }
15473     }
15474   *set = '\0';
15475   ungetc (ch, f);
15476   return alloc;
15477 }
15478
15479 /* Read the file name map file for DIRNAME.  */
15480
15481 static struct file_name_map *
15482 read_name_map (dirname)
15483      const char *dirname;
15484 {
15485   /* This structure holds a linked list of file name maps, one per
15486      directory.  */
15487   struct file_name_map_list
15488     {
15489       struct file_name_map_list *map_list_next;
15490       char *map_list_name;
15491       struct file_name_map *map_list_map;
15492     };
15493   static struct file_name_map_list *map_list;
15494   register struct file_name_map_list *map_list_ptr;
15495   char *name;
15496   FILE *f;
15497   size_t dirlen;
15498   int separator_needed;
15499
15500   dirname = skip_redundant_dir_prefix (dirname);
15501
15502   for (map_list_ptr = map_list; map_list_ptr;
15503        map_list_ptr = map_list_ptr->map_list_next)
15504     if (! strcmp (map_list_ptr->map_list_name, dirname))
15505       return map_list_ptr->map_list_map;
15506
15507   map_list_ptr = ((struct file_name_map_list *)
15508                   xmalloc (sizeof (struct file_name_map_list)));
15509   map_list_ptr->map_list_name = xstrdup (dirname);
15510   map_list_ptr->map_list_map = NULL;
15511
15512   dirlen = strlen (dirname);
15513   separator_needed = dirlen != 0 && dirname[dirlen - 1] != '/';
15514   name = (char *) xmalloc (dirlen + strlen (FILE_NAME_MAP_FILE) + 2);
15515   strcpy (name, dirname);
15516   name[dirlen] = '/';
15517   strcpy (name + dirlen + separator_needed, FILE_NAME_MAP_FILE);
15518   f = fopen (name, "r");
15519   free (name);
15520   if (!f)
15521     map_list_ptr->map_list_map = NULL;
15522   else
15523     {
15524       int ch;
15525
15526       while ((ch = getc (f)) != EOF)
15527         {
15528           char *from, *to;
15529           struct file_name_map *ptr;
15530
15531           if (ISSPACE (ch))
15532             continue;
15533           from = read_filename_string (ch, f);
15534           while ((ch = getc (f)) != EOF && ISSPACE (ch) && ch != '\n')
15535             ;
15536           to = read_filename_string (ch, f);
15537
15538           ptr = ((struct file_name_map *)
15539                  xmalloc (sizeof (struct file_name_map)));
15540           ptr->map_from = from;
15541
15542           /* Make the real filename absolute.  */
15543           if (*to == '/')
15544             ptr->map_to = to;
15545           else
15546             {
15547               ptr->map_to = xmalloc (dirlen + strlen (to) + 2);
15548               strcpy (ptr->map_to, dirname);
15549               ptr->map_to[dirlen] = '/';
15550               strcpy (ptr->map_to + dirlen + separator_needed, to);
15551               free (to);
15552             }
15553
15554           ptr->map_next = map_list_ptr->map_list_map;
15555           map_list_ptr->map_list_map = ptr;
15556
15557           while ((ch = getc (f)) != '\n')
15558             if (ch == EOF)
15559               break;
15560         }
15561       fclose (f);
15562     }
15563
15564   map_list_ptr->map_list_next = map_list;
15565   map_list = map_list_ptr;
15566
15567   return map_list_ptr->map_list_map;
15568 }
15569
15570 static void
15571 ffecom_file_ (const char *name)
15572 {
15573   FILE_BUF *fp;
15574
15575   /* Do partial setup of input buffer for the sake of generating
15576      early #line directives (when -g is in effect).  */
15577
15578   fp = &instack[++indepth];
15579   memset ((char *) fp, 0, sizeof (FILE_BUF));
15580   if (name == NULL)
15581     name = "";
15582   fp->nominal_fname = fp->fname = name;
15583 }
15584
15585 static void
15586 ffecom_close_include_ (FILE *f)
15587 {
15588   fclose (f);
15589
15590   indepth--;
15591   input_file_stack_tick++;
15592
15593   ffewhere_line_kill (instack[indepth].line);
15594   ffewhere_column_kill (instack[indepth].column);
15595 }
15596
15597 static int
15598 ffecom_decode_include_option_ (char *spec)
15599 {
15600   struct file_name_list *dirtmp;
15601
15602   if (! ignore_srcdir && !strcmp (spec, "-"))
15603     ignore_srcdir = 1;
15604   else
15605     {
15606       dirtmp = (struct file_name_list *)
15607         xmalloc (sizeof (struct file_name_list));
15608       dirtmp->next = 0;         /* New one goes on the end */
15609       dirtmp->fname = spec;
15610       dirtmp->got_name_map = 0;
15611       if (spec[0] == 0)
15612         error ("Directory name must immediately follow -I");
15613       else
15614         append_include_chain (dirtmp, dirtmp);
15615     }
15616   return 1;
15617 }
15618
15619 /* Open INCLUDEd file.  */
15620
15621 static FILE *
15622 ffecom_open_include_ (char *name, ffewhereLine l, ffewhereColumn c)
15623 {
15624   char *fbeg = name;
15625   size_t flen = strlen (fbeg);
15626   struct file_name_list *search_start = include; /* Chain of dirs to search */
15627   struct file_name_list dsp[1]; /* First in chain, if #include "..." */
15628   struct file_name_list *searchptr = 0;
15629   char *fname;          /* Dynamically allocated fname buffer */
15630   FILE *f;
15631   FILE_BUF *fp;
15632
15633   if (flen == 0)
15634     return NULL;
15635
15636   dsp[0].fname = NULL;
15637
15638   /* If -I- was specified, don't search current dir, only spec'd ones. */
15639   if (!ignore_srcdir)
15640     {
15641       for (fp = &instack[indepth]; fp >= instack; fp--)
15642         {
15643           int n;
15644           char *ep;
15645           const char *nam;
15646
15647           if ((nam = fp->nominal_fname) != NULL)
15648             {
15649               /* Found a named file.  Figure out dir of the file,
15650                  and put it in front of the search list.  */
15651               dsp[0].next = search_start;
15652               search_start = dsp;
15653 #ifndef VMS
15654               ep = strrchr (nam, '/');
15655 #ifdef DIR_SEPARATOR
15656             if (ep == NULL) ep = strrchr (nam, DIR_SEPARATOR);
15657             else {
15658               char *tmp = strrchr (nam, DIR_SEPARATOR);
15659               if (tmp != NULL && tmp > ep) ep = tmp;
15660             }
15661 #endif
15662 #else                           /* VMS */
15663               ep = strrchr (nam, ']');
15664               if (ep == NULL) ep = strrchr (nam, '>');
15665               if (ep == NULL) ep = strrchr (nam, ':');
15666               if (ep != NULL) ep++;
15667 #endif                          /* VMS */
15668               if (ep != NULL)
15669                 {
15670                   n = ep - nam;
15671                   dsp[0].fname = (char *) xmalloc (n + 1);
15672                   strncpy (dsp[0].fname, nam, n);
15673                   dsp[0].fname[n] = '\0';
15674                   if (n + INCLUDE_LEN_FUDGE > max_include_len)
15675                     max_include_len = n + INCLUDE_LEN_FUDGE;
15676                 }
15677               else
15678                 dsp[0].fname = NULL; /* Current directory */
15679               dsp[0].got_name_map = 0;
15680               break;
15681             }
15682         }
15683     }
15684
15685   /* Allocate this permanently, because it gets stored in the definitions
15686      of macros.  */
15687   fname = xmalloc (max_include_len + flen + 4);
15688   /* + 2 above for slash and terminating null.  */
15689   /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED
15690      for g77 yet).  */
15691
15692   /* If specified file name is absolute, just open it.  */
15693
15694   if (*fbeg == '/'
15695 #ifdef DIR_SEPARATOR
15696       || *fbeg == DIR_SEPARATOR
15697 #endif
15698       )
15699     {
15700       strncpy (fname, (char *) fbeg, flen);
15701       fname[flen] = 0;
15702       f = open_include_file (fname, NULL);
15703     }
15704   else
15705     {
15706       f = NULL;
15707
15708       /* Search directory path, trying to open the file.
15709          Copy each filename tried into FNAME.  */
15710
15711       for (searchptr = search_start; searchptr; searchptr = searchptr->next)
15712         {
15713           if (searchptr->fname)
15714             {
15715               /* The empty string in a search path is ignored.
15716                  This makes it possible to turn off entirely
15717                  a standard piece of the list.  */
15718               if (searchptr->fname[0] == 0)
15719                 continue;
15720               strcpy (fname, skip_redundant_dir_prefix (searchptr->fname));
15721               if (fname[0] && fname[strlen (fname) - 1] != '/')
15722                 strcat (fname, "/");
15723               fname[strlen (fname) + flen] = 0;
15724             }
15725           else
15726             fname[0] = 0;
15727
15728           strncat (fname, fbeg, flen);
15729 #ifdef VMS
15730           /* Change this 1/2 Unix 1/2 VMS file specification into a
15731              full VMS file specification */
15732           if (searchptr->fname && (searchptr->fname[0] != 0))
15733             {
15734               /* Fix up the filename */
15735               hack_vms_include_specification (fname);
15736             }
15737           else
15738             {
15739               /* This is a normal VMS filespec, so use it unchanged.  */
15740               strncpy (fname, (char *) fbeg, flen);
15741               fname[flen] = 0;
15742 #if 0   /* Not for g77.  */
15743               /* if it's '#include filename', add the missing .h */
15744               if (strchr (fname, '.') == NULL)
15745                 strcat (fname, ".h");
15746 #endif
15747             }
15748 #endif /* VMS */
15749           f = open_include_file (fname, searchptr);
15750 #ifdef EACCES
15751           if (f == NULL && errno == EACCES)
15752             {
15753               print_containing_files (FFEBAD_severityWARNING);
15754               ffebad_start_msg ("At %0, INCLUDE file %A exists, but is not readable",
15755                                 FFEBAD_severityWARNING);
15756               ffebad_string (fname);
15757               ffebad_here (0, l, c);
15758               ffebad_finish ();
15759             }
15760 #endif
15761           if (f != NULL)
15762             break;
15763         }
15764     }
15765
15766   if (f == NULL)
15767     {
15768       /* A file that was not found.  */
15769
15770       strncpy (fname, (char *) fbeg, flen);
15771       fname[flen] = 0;
15772       print_containing_files (ffebad_severity (FFEBAD_OPEN_INCLUDE));
15773       ffebad_start (FFEBAD_OPEN_INCLUDE);
15774       ffebad_here (0, l, c);
15775       ffebad_string (fname);
15776       ffebad_finish ();
15777     }
15778
15779   if (dsp[0].fname != NULL)
15780     free (dsp[0].fname);
15781
15782   if (f == NULL)
15783     return NULL;
15784
15785   if (indepth >= (INPUT_STACK_MAX - 1))
15786     {
15787       print_containing_files (FFEBAD_severityFATAL);
15788       ffebad_start_msg ("At %0, INCLUDE nesting too deep",
15789                         FFEBAD_severityFATAL);
15790       ffebad_string (fname);
15791       ffebad_here (0, l, c);
15792       ffebad_finish ();
15793       return NULL;
15794     }
15795
15796   instack[indepth].line = ffewhere_line_use (l);
15797   instack[indepth].column = ffewhere_column_use (c);
15798
15799   fp = &instack[indepth + 1];
15800   memset ((char *) fp, 0, sizeof (FILE_BUF));
15801   fp->nominal_fname = fp->fname = fname;
15802   fp->dir = searchptr;
15803
15804   indepth++;
15805   input_file_stack_tick++;
15806
15807   return f;
15808 }
15809
15810 /**INDENT* (Do not reformat this comment even with -fca option.)
15811    Data-gathering files: Given the source file listed below, compiled with
15812    f2c I obtained the output file listed after that, and from the output
15813    file I derived the above code.
15814
15815 -------- (begin input file to f2c)
15816         implicit none
15817         character*10 A1,A2
15818         complex C1,C2
15819         integer I1,I2
15820         real R1,R2
15821         double precision D1,D2
15822 C
15823         call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2)
15824 c /
15825         call fooI(I1/I2)
15826         call fooR(R1/I1)
15827         call fooD(D1/I1)
15828         call fooC(C1/I1)
15829         call fooR(R1/R2)
15830         call fooD(R1/D1)
15831         call fooD(D1/D2)
15832         call fooD(D1/R1)
15833         call fooC(C1/C2)
15834         call fooC(C1/R1)
15835         call fooZ(C1/D1)
15836 c **
15837         call fooI(I1**I2)
15838         call fooR(R1**I1)
15839         call fooD(D1**I1)
15840         call fooC(C1**I1)
15841         call fooR(R1**R2)
15842         call fooD(R1**D1)
15843         call fooD(D1**D2)
15844         call fooD(D1**R1)
15845         call fooC(C1**C2)
15846         call fooC(C1**R1)
15847         call fooZ(C1**D1)
15848 c FFEINTRIN_impABS
15849         call fooR(ABS(R1))
15850 c FFEINTRIN_impACOS
15851         call fooR(ACOS(R1))
15852 c FFEINTRIN_impAIMAG
15853         call fooR(AIMAG(C1))
15854 c FFEINTRIN_impAINT
15855         call fooR(AINT(R1))
15856 c FFEINTRIN_impALOG
15857         call fooR(ALOG(R1))
15858 c FFEINTRIN_impALOG10
15859         call fooR(ALOG10(R1))
15860 c FFEINTRIN_impAMAX0
15861         call fooR(AMAX0(I1,I2))
15862 c FFEINTRIN_impAMAX1
15863         call fooR(AMAX1(R1,R2))
15864 c FFEINTRIN_impAMIN0
15865         call fooR(AMIN0(I1,I2))
15866 c FFEINTRIN_impAMIN1
15867         call fooR(AMIN1(R1,R2))
15868 c FFEINTRIN_impAMOD
15869         call fooR(AMOD(R1,R2))
15870 c FFEINTRIN_impANINT
15871         call fooR(ANINT(R1))
15872 c FFEINTRIN_impASIN
15873         call fooR(ASIN(R1))
15874 c FFEINTRIN_impATAN
15875         call fooR(ATAN(R1))
15876 c FFEINTRIN_impATAN2
15877         call fooR(ATAN2(R1,R2))
15878 c FFEINTRIN_impCABS
15879         call fooR(CABS(C1))
15880 c FFEINTRIN_impCCOS
15881         call fooC(CCOS(C1))
15882 c FFEINTRIN_impCEXP
15883         call fooC(CEXP(C1))
15884 c FFEINTRIN_impCHAR
15885         call fooA(CHAR(I1))
15886 c FFEINTRIN_impCLOG
15887         call fooC(CLOG(C1))
15888 c FFEINTRIN_impCONJG
15889         call fooC(CONJG(C1))
15890 c FFEINTRIN_impCOS
15891         call fooR(COS(R1))
15892 c FFEINTRIN_impCOSH
15893         call fooR(COSH(R1))
15894 c FFEINTRIN_impCSIN
15895         call fooC(CSIN(C1))
15896 c FFEINTRIN_impCSQRT
15897         call fooC(CSQRT(C1))
15898 c FFEINTRIN_impDABS
15899         call fooD(DABS(D1))
15900 c FFEINTRIN_impDACOS
15901         call fooD(DACOS(D1))
15902 c FFEINTRIN_impDASIN
15903         call fooD(DASIN(D1))
15904 c FFEINTRIN_impDATAN
15905         call fooD(DATAN(D1))
15906 c FFEINTRIN_impDATAN2
15907         call fooD(DATAN2(D1,D2))
15908 c FFEINTRIN_impDCOS
15909         call fooD(DCOS(D1))
15910 c FFEINTRIN_impDCOSH
15911         call fooD(DCOSH(D1))
15912 c FFEINTRIN_impDDIM
15913         call fooD(DDIM(D1,D2))
15914 c FFEINTRIN_impDEXP
15915         call fooD(DEXP(D1))
15916 c FFEINTRIN_impDIM
15917         call fooR(DIM(R1,R2))
15918 c FFEINTRIN_impDINT
15919         call fooD(DINT(D1))
15920 c FFEINTRIN_impDLOG
15921         call fooD(DLOG(D1))
15922 c FFEINTRIN_impDLOG10
15923         call fooD(DLOG10(D1))
15924 c FFEINTRIN_impDMAX1
15925         call fooD(DMAX1(D1,D2))
15926 c FFEINTRIN_impDMIN1
15927         call fooD(DMIN1(D1,D2))
15928 c FFEINTRIN_impDMOD
15929         call fooD(DMOD(D1,D2))
15930 c FFEINTRIN_impDNINT
15931         call fooD(DNINT(D1))
15932 c FFEINTRIN_impDPROD
15933         call fooD(DPROD(R1,R2))
15934 c FFEINTRIN_impDSIGN
15935         call fooD(DSIGN(D1,D2))
15936 c FFEINTRIN_impDSIN
15937         call fooD(DSIN(D1))
15938 c FFEINTRIN_impDSINH
15939         call fooD(DSINH(D1))
15940 c FFEINTRIN_impDSQRT
15941         call fooD(DSQRT(D1))
15942 c FFEINTRIN_impDTAN
15943         call fooD(DTAN(D1))
15944 c FFEINTRIN_impDTANH
15945         call fooD(DTANH(D1))
15946 c FFEINTRIN_impEXP
15947         call fooR(EXP(R1))
15948 c FFEINTRIN_impIABS
15949         call fooI(IABS(I1))
15950 c FFEINTRIN_impICHAR
15951         call fooI(ICHAR(A1))
15952 c FFEINTRIN_impIDIM
15953         call fooI(IDIM(I1,I2))
15954 c FFEINTRIN_impIDNINT
15955         call fooI(IDNINT(D1))
15956 c FFEINTRIN_impINDEX
15957         call fooI(INDEX(A1,A2))
15958 c FFEINTRIN_impISIGN
15959         call fooI(ISIGN(I1,I2))
15960 c FFEINTRIN_impLEN
15961         call fooI(LEN(A1))
15962 c FFEINTRIN_impLGE
15963         call fooL(LGE(A1,A2))
15964 c FFEINTRIN_impLGT
15965         call fooL(LGT(A1,A2))
15966 c FFEINTRIN_impLLE
15967         call fooL(LLE(A1,A2))
15968 c FFEINTRIN_impLLT
15969         call fooL(LLT(A1,A2))
15970 c FFEINTRIN_impMAX0
15971         call fooI(MAX0(I1,I2))
15972 c FFEINTRIN_impMAX1
15973         call fooI(MAX1(R1,R2))
15974 c FFEINTRIN_impMIN0
15975         call fooI(MIN0(I1,I2))
15976 c FFEINTRIN_impMIN1
15977         call fooI(MIN1(R1,R2))
15978 c FFEINTRIN_impMOD
15979         call fooI(MOD(I1,I2))
15980 c FFEINTRIN_impNINT
15981         call fooI(NINT(R1))
15982 c FFEINTRIN_impSIGN
15983         call fooR(SIGN(R1,R2))
15984 c FFEINTRIN_impSIN
15985         call fooR(SIN(R1))
15986 c FFEINTRIN_impSINH
15987         call fooR(SINH(R1))
15988 c FFEINTRIN_impSQRT
15989         call fooR(SQRT(R1))
15990 c FFEINTRIN_impTAN
15991         call fooR(TAN(R1))
15992 c FFEINTRIN_impTANH
15993         call fooR(TANH(R1))
15994 c FFEINTRIN_imp_CMPLX_C
15995         call fooC(cmplx(C1,C2))
15996 c FFEINTRIN_imp_CMPLX_D
15997         call fooZ(cmplx(D1,D2))
15998 c FFEINTRIN_imp_CMPLX_I
15999         call fooC(cmplx(I1,I2))
16000 c FFEINTRIN_imp_CMPLX_R
16001         call fooC(cmplx(R1,R2))
16002 c FFEINTRIN_imp_DBLE_C
16003         call fooD(dble(C1))
16004 c FFEINTRIN_imp_DBLE_D
16005         call fooD(dble(D1))
16006 c FFEINTRIN_imp_DBLE_I
16007         call fooD(dble(I1))
16008 c FFEINTRIN_imp_DBLE_R
16009         call fooD(dble(R1))
16010 c FFEINTRIN_imp_INT_C
16011         call fooI(int(C1))
16012 c FFEINTRIN_imp_INT_D
16013         call fooI(int(D1))
16014 c FFEINTRIN_imp_INT_I
16015         call fooI(int(I1))
16016 c FFEINTRIN_imp_INT_R
16017         call fooI(int(R1))
16018 c FFEINTRIN_imp_REAL_C
16019         call fooR(real(C1))
16020 c FFEINTRIN_imp_REAL_D
16021         call fooR(real(D1))
16022 c FFEINTRIN_imp_REAL_I
16023         call fooR(real(I1))
16024 c FFEINTRIN_imp_REAL_R
16025         call fooR(real(R1))
16026 c
16027 c FFEINTRIN_imp_INT_D:
16028 c
16029 c FFEINTRIN_specIDINT
16030         call fooI(IDINT(D1))
16031 c
16032 c FFEINTRIN_imp_INT_R:
16033 c
16034 c FFEINTRIN_specIFIX
16035         call fooI(IFIX(R1))
16036 c FFEINTRIN_specINT
16037         call fooI(INT(R1))
16038 c
16039 c FFEINTRIN_imp_REAL_D:
16040 c
16041 c FFEINTRIN_specSNGL
16042         call fooR(SNGL(D1))
16043 c
16044 c FFEINTRIN_imp_REAL_I:
16045 c
16046 c FFEINTRIN_specFLOAT
16047         call fooR(FLOAT(I1))
16048 c FFEINTRIN_specREAL
16049         call fooR(REAL(I1))
16050 c
16051         end
16052 -------- (end input file to f2c)
16053
16054 -------- (begin output from providing above input file as input to:
16055 --------  `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
16056 --------     -e "s:^#.*$::g"')
16057
16058 //  -- translated by f2c (version 19950223).
16059    You must link the resulting object file with the libraries:
16060         -lf2c -lm   (in that order)
16061 //
16062
16063
16064 // f2c.h  --  Standard Fortran to C header file //
16065
16066 ///  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
16067
16068         - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
16069
16070
16071
16072
16073 // F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems //
16074 // we assume short, float are OK //
16075 typedef long int // long int // integer;
16076 typedef char *address;
16077 typedef short int shortint;
16078 typedef float real;
16079 typedef double doublereal;
16080 typedef struct { real r, i; } complex;
16081 typedef struct { doublereal r, i; } doublecomplex;
16082 typedef long int // long int // logical;
16083 typedef short int shortlogical;
16084 typedef char logical1;
16085 typedef char integer1;
16086 // typedef long long longint; // // system-dependent //
16087
16088
16089
16090
16091 // Extern is for use with -E //
16092
16093
16094
16095
16096 // I/O stuff //
16097
16098
16099
16100
16101
16102
16103
16104
16105 typedef long int // int or long int // flag;
16106 typedef long int // int or long int // ftnlen;
16107 typedef long int // int or long int // ftnint;
16108
16109
16110 //external read, write//
16111 typedef struct
16112 {       flag cierr;
16113         ftnint ciunit;
16114         flag ciend;
16115         char *cifmt;
16116         ftnint cirec;
16117 } cilist;
16118
16119 //internal read, write//
16120 typedef struct
16121 {       flag icierr;
16122         char *iciunit;
16123         flag iciend;
16124         char *icifmt;
16125         ftnint icirlen;
16126         ftnint icirnum;
16127 } icilist;
16128
16129 //open//
16130 typedef struct
16131 {       flag oerr;
16132         ftnint ounit;
16133         char *ofnm;
16134         ftnlen ofnmlen;
16135         char *osta;
16136         char *oacc;
16137         char *ofm;
16138         ftnint orl;
16139         char *oblnk;
16140 } olist;
16141
16142 //close//
16143 typedef struct
16144 {       flag cerr;
16145         ftnint cunit;
16146         char *csta;
16147 } cllist;
16148
16149 //rewind, backspace, endfile//
16150 typedef struct
16151 {       flag aerr;
16152         ftnint aunit;
16153 } alist;
16154
16155 // inquire //
16156 typedef struct
16157 {       flag inerr;
16158         ftnint inunit;
16159         char *infile;
16160         ftnlen infilen;
16161         ftnint  *inex;  //parameters in standard's order//
16162         ftnint  *inopen;
16163         ftnint  *innum;
16164         ftnint  *innamed;
16165         char    *inname;
16166         ftnlen  innamlen;
16167         char    *inacc;
16168         ftnlen  inacclen;
16169         char    *inseq;
16170         ftnlen  inseqlen;
16171         char    *indir;
16172         ftnlen  indirlen;
16173         char    *infmt;
16174         ftnlen  infmtlen;
16175         char    *inform;
16176         ftnint  informlen;
16177         char    *inunf;
16178         ftnlen  inunflen;
16179         ftnint  *inrecl;
16180         ftnint  *innrec;
16181         char    *inblank;
16182         ftnlen  inblanklen;
16183 } inlist;
16184
16185
16186
16187 union Multitype {       // for multiple entry points //
16188         integer1 g;
16189         shortint h;
16190         integer i;
16191         // longint j; //
16192         real r;
16193         doublereal d;
16194         complex c;
16195         doublecomplex z;
16196         };
16197
16198 typedef union Multitype Multitype;
16199
16200 typedef long Long;      // No longer used; formerly in Namelist //
16201
16202 struct Vardesc {        // for Namelist //
16203         char *name;
16204         char *addr;
16205         ftnlen *dims;
16206         int  type;
16207         };
16208 typedef struct Vardesc Vardesc;
16209
16210 struct Namelist {
16211         char *name;
16212         Vardesc **vars;
16213         int nvars;
16214         };
16215 typedef struct Namelist Namelist;
16216
16217
16218
16219
16220
16221
16222
16223
16224 // procedure parameter types for -A and -C++ //
16225
16226
16227
16228
16229 typedef int // Unknown procedure type // (*U_fp)();
16230 typedef shortint (*J_fp)();
16231 typedef integer (*I_fp)();
16232 typedef real (*R_fp)();
16233 typedef doublereal (*D_fp)(), (*E_fp)();
16234 typedef // Complex // void  (*C_fp)();
16235 typedef // Double Complex // void  (*Z_fp)();
16236 typedef logical (*L_fp)();
16237 typedef shortlogical (*K_fp)();
16238 typedef // Character // void  (*H_fp)();
16239 typedef // Subroutine // int (*S_fp)();
16240
16241 // E_fp is for real functions when -R is not specified //
16242 typedef void  C_f;      // complex function //
16243 typedef void  H_f;      // character function //
16244 typedef void  Z_f;      // double complex function //
16245 typedef doublereal E_f; // real function with -R not specified //
16246
16247 // undef any lower-case symbols that your C compiler predefines, e.g.: //
16248
16249
16250 // (No such symbols should be defined in a strict ANSI C compiler.
16251    We can avoid trouble with f2c-translated code by using
16252    gcc -ansi [-traditional].) //
16253
16254
16255
16256
16257
16258
16259
16260
16261
16262
16263
16264
16265
16266
16267
16268
16269
16270
16271
16272
16273
16274
16275
16276 // Main program // MAIN__()
16277 {
16278     // System generated locals //
16279     integer i__1;
16280     real r__1, r__2;
16281     doublereal d__1, d__2;
16282     complex q__1;
16283     doublecomplex z__1, z__2, z__3;
16284     logical L__1;
16285     char ch__1[1];
16286
16287     // Builtin functions //
16288     void c_div();
16289     integer pow_ii();
16290     double pow_ri(), pow_di();
16291     void pow_ci();
16292     double pow_dd();
16293     void pow_zz();
16294     double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
16295             asin(), atan(), atan2(), c_abs();
16296     void c_cos(), c_exp(), c_log(), r_cnjg();
16297     double cos(), cosh();
16298     void c_sin(), c_sqrt();
16299     double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
16300             d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
16301     integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
16302     logical l_ge(), l_gt(), l_le(), l_lt();
16303     integer i_nint();
16304     double r_sign();
16305
16306     // Local variables //
16307     extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
16308             fool_(), fooz_(), getem_();
16309     static char a1[10], a2[10];
16310     static complex c1, c2;
16311     static doublereal d1, d2;
16312     static integer i1, i2;
16313     static real r1, r2;
16314
16315
16316     getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L);
16317 // / //
16318     i__1 = i1 / i2;
16319     fooi_(&i__1);
16320     r__1 = r1 / i1;
16321     foor_(&r__1);
16322     d__1 = d1 / i1;
16323     food_(&d__1);
16324     d__1 = (doublereal) i1;
16325     q__1.r = c1.r / d__1, q__1.i = c1.i / d__1;
16326     fooc_(&q__1);
16327     r__1 = r1 / r2;
16328     foor_(&r__1);
16329     d__1 = r1 / d1;
16330     food_(&d__1);
16331     d__1 = d1 / d2;
16332     food_(&d__1);
16333     d__1 = d1 / r1;
16334     food_(&d__1);
16335     c_div(&q__1, &c1, &c2);
16336     fooc_(&q__1);
16337     q__1.r = c1.r / r1, q__1.i = c1.i / r1;
16338     fooc_(&q__1);
16339     z__1.r = c1.r / d1, z__1.i = c1.i / d1;
16340     fooz_(&z__1);
16341 // ** //
16342     i__1 = pow_ii(&i1, &i2);
16343     fooi_(&i__1);
16344     r__1 = pow_ri(&r1, &i1);
16345     foor_(&r__1);
16346     d__1 = pow_di(&d1, &i1);
16347     food_(&d__1);
16348     pow_ci(&q__1, &c1, &i1);
16349     fooc_(&q__1);
16350     d__1 = (doublereal) r1;
16351     d__2 = (doublereal) r2;
16352     r__1 = pow_dd(&d__1, &d__2);
16353     foor_(&r__1);
16354     d__2 = (doublereal) r1;
16355     d__1 = pow_dd(&d__2, &d1);
16356     food_(&d__1);
16357     d__1 = pow_dd(&d1, &d2);
16358     food_(&d__1);
16359     d__2 = (doublereal) r1;
16360     d__1 = pow_dd(&d1, &d__2);
16361     food_(&d__1);
16362     z__2.r = c1.r, z__2.i = c1.i;
16363     z__3.r = c2.r, z__3.i = c2.i;
16364     pow_zz(&z__1, &z__2, &z__3);
16365     q__1.r = z__1.r, q__1.i = z__1.i;
16366     fooc_(&q__1);
16367     z__2.r = c1.r, z__2.i = c1.i;
16368     z__3.r = r1, z__3.i = 0.;
16369     pow_zz(&z__1, &z__2, &z__3);
16370     q__1.r = z__1.r, q__1.i = z__1.i;
16371     fooc_(&q__1);
16372     z__2.r = c1.r, z__2.i = c1.i;
16373     z__3.r = d1, z__3.i = 0.;
16374     pow_zz(&z__1, &z__2, &z__3);
16375     fooz_(&z__1);
16376 // FFEINTRIN_impABS //
16377     r__1 = (doublereal)((  r1  ) >= 0 ? (  r1  ) : -(  r1  ))  ;
16378     foor_(&r__1);
16379 // FFEINTRIN_impACOS //
16380     r__1 = acos(r1);
16381     foor_(&r__1);
16382 // FFEINTRIN_impAIMAG //
16383     r__1 = r_imag(&c1);
16384     foor_(&r__1);
16385 // FFEINTRIN_impAINT //
16386     r__1 = r_int(&r1);
16387     foor_(&r__1);
16388 // FFEINTRIN_impALOG //
16389     r__1 = log(r1);
16390     foor_(&r__1);
16391 // FFEINTRIN_impALOG10 //
16392     r__1 = r_lg10(&r1);
16393     foor_(&r__1);
16394 // FFEINTRIN_impAMAX0 //
16395     r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16396     foor_(&r__1);
16397 // FFEINTRIN_impAMAX1 //
16398     r__1 = (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16399     foor_(&r__1);
16400 // FFEINTRIN_impAMIN0 //
16401     r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16402     foor_(&r__1);
16403 // FFEINTRIN_impAMIN1 //
16404     r__1 = (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16405     foor_(&r__1);
16406 // FFEINTRIN_impAMOD //
16407     r__1 = r_mod(&r1, &r2);
16408     foor_(&r__1);
16409 // FFEINTRIN_impANINT //
16410     r__1 = r_nint(&r1);
16411     foor_(&r__1);
16412 // FFEINTRIN_impASIN //
16413     r__1 = asin(r1);
16414     foor_(&r__1);
16415 // FFEINTRIN_impATAN //
16416     r__1 = atan(r1);
16417     foor_(&r__1);
16418 // FFEINTRIN_impATAN2 //
16419     r__1 = atan2(r1, r2);
16420     foor_(&r__1);
16421 // FFEINTRIN_impCABS //
16422     r__1 = c_abs(&c1);
16423     foor_(&r__1);
16424 // FFEINTRIN_impCCOS //
16425     c_cos(&q__1, &c1);
16426     fooc_(&q__1);
16427 // FFEINTRIN_impCEXP //
16428     c_exp(&q__1, &c1);
16429     fooc_(&q__1);
16430 // FFEINTRIN_impCHAR //
16431     *(unsigned char *)&ch__1[0] = i1;
16432     fooa_(ch__1, 1L);
16433 // FFEINTRIN_impCLOG //
16434     c_log(&q__1, &c1);
16435     fooc_(&q__1);
16436 // FFEINTRIN_impCONJG //
16437     r_cnjg(&q__1, &c1);
16438     fooc_(&q__1);
16439 // FFEINTRIN_impCOS //
16440     r__1 = cos(r1);
16441     foor_(&r__1);
16442 // FFEINTRIN_impCOSH //
16443     r__1 = cosh(r1);
16444     foor_(&r__1);
16445 // FFEINTRIN_impCSIN //
16446     c_sin(&q__1, &c1);
16447     fooc_(&q__1);
16448 // FFEINTRIN_impCSQRT //
16449     c_sqrt(&q__1, &c1);
16450     fooc_(&q__1);
16451 // FFEINTRIN_impDABS //
16452     d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ;
16453     food_(&d__1);
16454 // FFEINTRIN_impDACOS //
16455     d__1 = acos(d1);
16456     food_(&d__1);
16457 // FFEINTRIN_impDASIN //
16458     d__1 = asin(d1);
16459     food_(&d__1);
16460 // FFEINTRIN_impDATAN //
16461     d__1 = atan(d1);
16462     food_(&d__1);
16463 // FFEINTRIN_impDATAN2 //
16464     d__1 = atan2(d1, d2);
16465     food_(&d__1);
16466 // FFEINTRIN_impDCOS //
16467     d__1 = cos(d1);
16468     food_(&d__1);
16469 // FFEINTRIN_impDCOSH //
16470     d__1 = cosh(d1);
16471     food_(&d__1);
16472 // FFEINTRIN_impDDIM //
16473     d__1 = d_dim(&d1, &d2);
16474     food_(&d__1);
16475 // FFEINTRIN_impDEXP //
16476     d__1 = exp(d1);
16477     food_(&d__1);
16478 // FFEINTRIN_impDIM //
16479     r__1 = r_dim(&r1, &r2);
16480     foor_(&r__1);
16481 // FFEINTRIN_impDINT //
16482     d__1 = d_int(&d1);
16483     food_(&d__1);
16484 // FFEINTRIN_impDLOG //
16485     d__1 = log(d1);
16486     food_(&d__1);
16487 // FFEINTRIN_impDLOG10 //
16488     d__1 = d_lg10(&d1);
16489     food_(&d__1);
16490 // FFEINTRIN_impDMAX1 //
16491     d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ;
16492     food_(&d__1);
16493 // FFEINTRIN_impDMIN1 //
16494     d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ;
16495     food_(&d__1);
16496 // FFEINTRIN_impDMOD //
16497     d__1 = d_mod(&d1, &d2);
16498     food_(&d__1);
16499 // FFEINTRIN_impDNINT //
16500     d__1 = d_nint(&d1);
16501     food_(&d__1);
16502 // FFEINTRIN_impDPROD //
16503     d__1 = (doublereal) r1 * r2;
16504     food_(&d__1);
16505 // FFEINTRIN_impDSIGN //
16506     d__1 = d_sign(&d1, &d2);
16507     food_(&d__1);
16508 // FFEINTRIN_impDSIN //
16509     d__1 = sin(d1);
16510     food_(&d__1);
16511 // FFEINTRIN_impDSINH //
16512     d__1 = sinh(d1);
16513     food_(&d__1);
16514 // FFEINTRIN_impDSQRT //
16515     d__1 = sqrt(d1);
16516     food_(&d__1);
16517 // FFEINTRIN_impDTAN //
16518     d__1 = tan(d1);
16519     food_(&d__1);
16520 // FFEINTRIN_impDTANH //
16521     d__1 = tanh(d1);
16522     food_(&d__1);
16523 // FFEINTRIN_impEXP //
16524     r__1 = exp(r1);
16525     foor_(&r__1);
16526 // FFEINTRIN_impIABS //
16527     i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ;
16528     fooi_(&i__1);
16529 // FFEINTRIN_impICHAR //
16530     i__1 = *(unsigned char *)a1;
16531     fooi_(&i__1);
16532 // FFEINTRIN_impIDIM //
16533     i__1 = i_dim(&i1, &i2);
16534     fooi_(&i__1);
16535 // FFEINTRIN_impIDNINT //
16536     i__1 = i_dnnt(&d1);
16537     fooi_(&i__1);
16538 // FFEINTRIN_impINDEX //
16539     i__1 = i_indx(a1, a2, 10L, 10L);
16540     fooi_(&i__1);
16541 // FFEINTRIN_impISIGN //
16542     i__1 = i_sign(&i1, &i2);
16543     fooi_(&i__1);
16544 // FFEINTRIN_impLEN //
16545     i__1 = i_len(a1, 10L);
16546     fooi_(&i__1);
16547 // FFEINTRIN_impLGE //
16548     L__1 = l_ge(a1, a2, 10L, 10L);
16549     fool_(&L__1);
16550 // FFEINTRIN_impLGT //
16551     L__1 = l_gt(a1, a2, 10L, 10L);
16552     fool_(&L__1);
16553 // FFEINTRIN_impLLE //
16554     L__1 = l_le(a1, a2, 10L, 10L);
16555     fool_(&L__1);
16556 // FFEINTRIN_impLLT //
16557     L__1 = l_lt(a1, a2, 10L, 10L);
16558     fool_(&L__1);
16559 // FFEINTRIN_impMAX0 //
16560     i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16561     fooi_(&i__1);
16562 // FFEINTRIN_impMAX1 //
16563     i__1 = (integer) (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16564     fooi_(&i__1);
16565 // FFEINTRIN_impMIN0 //
16566     i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16567     fooi_(&i__1);
16568 // FFEINTRIN_impMIN1 //
16569     i__1 = (integer) (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16570     fooi_(&i__1);
16571 // FFEINTRIN_impMOD //
16572     i__1 = i1 % i2;
16573     fooi_(&i__1);
16574 // FFEINTRIN_impNINT //
16575     i__1 = i_nint(&r1);
16576     fooi_(&i__1);
16577 // FFEINTRIN_impSIGN //
16578     r__1 = r_sign(&r1, &r2);
16579     foor_(&r__1);
16580 // FFEINTRIN_impSIN //
16581     r__1 = sin(r1);
16582     foor_(&r__1);
16583 // FFEINTRIN_impSINH //
16584     r__1 = sinh(r1);
16585     foor_(&r__1);
16586 // FFEINTRIN_impSQRT //
16587     r__1 = sqrt(r1);
16588     foor_(&r__1);
16589 // FFEINTRIN_impTAN //
16590     r__1 = tan(r1);
16591     foor_(&r__1);
16592 // FFEINTRIN_impTANH //
16593     r__1 = tanh(r1);
16594     foor_(&r__1);
16595 // FFEINTRIN_imp_CMPLX_C //
16596     r__1 = c1.r;
16597     r__2 = c2.r;
16598     q__1.r = r__1, q__1.i = r__2;
16599     fooc_(&q__1);
16600 // FFEINTRIN_imp_CMPLX_D //
16601     z__1.r = d1, z__1.i = d2;
16602     fooz_(&z__1);
16603 // FFEINTRIN_imp_CMPLX_I //
16604     r__1 = (real) i1;
16605     r__2 = (real) i2;
16606     q__1.r = r__1, q__1.i = r__2;
16607     fooc_(&q__1);
16608 // FFEINTRIN_imp_CMPLX_R //
16609     q__1.r = r1, q__1.i = r2;
16610     fooc_(&q__1);
16611 // FFEINTRIN_imp_DBLE_C //
16612     d__1 = (doublereal) c1.r;
16613     food_(&d__1);
16614 // FFEINTRIN_imp_DBLE_D //
16615     d__1 = d1;
16616     food_(&d__1);
16617 // FFEINTRIN_imp_DBLE_I //
16618     d__1 = (doublereal) i1;
16619     food_(&d__1);
16620 // FFEINTRIN_imp_DBLE_R //
16621     d__1 = (doublereal) r1;
16622     food_(&d__1);
16623 // FFEINTRIN_imp_INT_C //
16624     i__1 = (integer) c1.r;
16625     fooi_(&i__1);
16626 // FFEINTRIN_imp_INT_D //
16627     i__1 = (integer) d1;
16628     fooi_(&i__1);
16629 // FFEINTRIN_imp_INT_I //
16630     i__1 = i1;
16631     fooi_(&i__1);
16632 // FFEINTRIN_imp_INT_R //
16633     i__1 = (integer) r1;
16634     fooi_(&i__1);
16635 // FFEINTRIN_imp_REAL_C //
16636     r__1 = c1.r;
16637     foor_(&r__1);
16638 // FFEINTRIN_imp_REAL_D //
16639     r__1 = (real) d1;
16640     foor_(&r__1);
16641 // FFEINTRIN_imp_REAL_I //
16642     r__1 = (real) i1;
16643     foor_(&r__1);
16644 // FFEINTRIN_imp_REAL_R //
16645     r__1 = r1;
16646     foor_(&r__1);
16647
16648 // FFEINTRIN_imp_INT_D: //
16649
16650 // FFEINTRIN_specIDINT //
16651     i__1 = (integer) d1;
16652     fooi_(&i__1);
16653
16654 // FFEINTRIN_imp_INT_R: //
16655
16656 // FFEINTRIN_specIFIX //
16657     i__1 = (integer) r1;
16658     fooi_(&i__1);
16659 // FFEINTRIN_specINT //
16660     i__1 = (integer) r1;
16661     fooi_(&i__1);
16662
16663 // FFEINTRIN_imp_REAL_D: //
16664
16665 // FFEINTRIN_specSNGL //
16666     r__1 = (real) d1;
16667     foor_(&r__1);
16668
16669 // FFEINTRIN_imp_REAL_I: //
16670
16671 // FFEINTRIN_specFLOAT //
16672     r__1 = (real) i1;
16673     foor_(&r__1);
16674 // FFEINTRIN_specREAL //
16675     r__1 = (real) i1;
16676     foor_(&r__1);
16677
16678 } // MAIN__ //
16679
16680 -------- (end output file from f2c)
16681
16682 */