gcc/f/com.c

   1 /* com.c -- Implementation File (module.c template V1.0)
   2    Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002
   3    Free Software Foundation, Inc.
   4    Contributed by James Craig Burley.
   5
   6 This file is part of GNU Fortran.
   7
   8 GNU Fortran is free software; you can redistribute it and/or modify
   9 it under the terms of the GNU General Public License as published by
  10 the Free Software Foundation; either version 2, or (at your option)
  11 any later version.
  12
  13 GNU Fortran is distributed in the hope that it will be useful,
  14 but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 GNU General Public License for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with GNU Fortran; see the file COPYING.  If not, write to
  20 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
  21 02111-1307, USA.
  22
  23    Related Modules:
  24       None
  25
  26    Description:
  27       Contains compiler-specific functions.
  28
  29    Modifications:
  30 */
  31
  32 /* Understanding this module means understanding the interface between
  33    the g77 front end and the gcc back end (or, perhaps, some other
  34    back end).  In here are the functions called by the front end proper
  35    to notify whatever back end is in place about certain things, and
  36    also the back-end-specific functions.  It's a bear to deal with, so
  37    lately I've been trying to simplify things, especially with regard
  38    to the gcc-back-end-specific stuff.
  39
  40    Building expressions generally seems quite easy, but building decls
  41    has been challenging and is undergoing revision.  gcc has several
  42    kinds of decls:
  43
  44    TYPE_DECL -- a type (int, float, struct, function, etc.)
  45    CONST_DECL -- a constant of some type other than function
  46    LABEL_DECL -- a variable or a constant?
  47    PARM_DECL -- an argument to a function (a variable that is a dummy)
  48    RESULT_DECL -- the return value of a function (a variable)
  49    VAR_DECL -- other variable (can hold a ptr-to-function, struct, int, etc.)
  50    FUNCTION_DECL -- a function (either the actual function or an extern ref)
  51    FIELD_DECL -- a field in a struct or union (goes into types)
  52
  53    g77 has a set of functions that somewhat parallels the gcc front end
  54    when it comes to building decls:
  55
  56    Internal Function (one we define, not just declare as extern):
  57    if (is_nested) push_f_function_context ();
  58    start_function (get_identifier ("function_name"), function_type,
  59                    is_nested, is_public);
  60    // for each arg, build PARM_DECL and call push_parm_decl (decl) with it;
  61    store_parm_decls (is_main_program);
  62    ffecom_start_compstmt ();
  63    // for stmts and decls inside function, do appropriate things;
  64    ffecom_end_compstmt ();
  65    finish_function (is_nested);
  66    if (is_nested) pop_f_function_context ();
  67
  68    Everything Else:
  69    tree d;
  70    tree init;
  71    // fill in external, public, static, &c for decl, and
  72    // set DECL_INITIAL to error_mark_node if going to initialize
  73    // set is_top_level TRUE only if not at top level and decl
  74    // must go in top level (i.e. not within current function decl context)
  75    d = start_decl (decl, is_top_level);
  76    init = ...;  // if have initializer
  77    finish_decl (d, init, is_top_level);
  78
  79 */
  80
  81 /* Include files. */
  82
  83 #include "proj.h"
  84 #include "flags.h"
  85 #include "rtl.h"
  86 #include "toplev.h"
  87 #include "tree.h"
  88 #include "output.h"  /* Must follow tree.h so TREE_CODE is defined! */
  89 #include "convert.h"
  90 #include "ggc.h"
  91 #include "diagnostic.h"
  92 #include "intl.h"
  93 #include "langhooks.h"
  94 #include "langhooks-def.h"
  95
  96 /* VMS-specific definitions */
  97 #ifdef VMS
  98 #include <descrip.h>
  99 #define O_RDONLY        0       /* Open arg for Read/Only  */
 100 #define O_WRONLY        1       /* Open arg for Write/Only */
 101 #define read(fd,buf,size)       VMS_read (fd,buf,size)
 102 #define write(fd,buf,size)      VMS_write (fd,buf,size)
 103 #define open(fname,mode,prot)   VMS_open (fname,mode,prot)
 104 #define fopen(fname,mode)       VMS_fopen (fname,mode)
 105 #define freopen(fname,mode,ofile) VMS_freopen (fname,mode,ofile)
 106 #define strncat(dst,src,cnt) VMS_strncat (dst,src,cnt)
 107 #define fstat(fd,stbuf)         VMS_fstat (fd,stbuf)
 108 static int VMS_fstat (), VMS_stat ();
 109 static char * VMS_strncat ();
 110 static int VMS_read ();
 111 static int VMS_write ();
 112 static int VMS_open ();
 113 static FILE * VMS_fopen ();
 114 static FILE * VMS_freopen ();
 115 static void hack_vms_include_specification ();
 116 typedef struct { unsigned :16, :16, :16; } vms_ino_t;
 117 #define ino_t vms_ino_t
 118 #define INCLUDE_LEN_FUDGE 10    /* leave room for VMS syntax conversion */
 119 #endif /* VMS */
 120
 121 #define FFECOM_DETERMINE_TYPES 1 /* for com.h */
 122 #include "com.h"
 123 #include "bad.h"
 124 #include "bld.h"
 125 #include "equiv.h"
 126 #include "expr.h"
 127 #include "implic.h"
 128 #include "info.h"
 129 #include "malloc.h"
 130 #include "src.h"
 131 #include "st.h"
 132 #include "storag.h"
 133 #include "symbol.h"
 134 #include "target.h"
 135 #include "top.h"
 136 #include "type.h"
 137
 138 /* Externals defined here.  */
 139
 140 /* Stream for reading from the input file.  */
 141 FILE *finput;
 142
 143 /* These definitions parallel those in c-decl.c so that code from that
 144    module can be used pretty much as is.  Much of these defs aren't
 145    otherwise used, i.e. by g77 code per se, except some of them are used
 146    to build some of them that are.  The ones that are global (i.e. not
 147    "static") are those that ste.c and such might use (directly
 148    or by using com macros that reference them in their definitions).  */
 149
 150 tree string_type_node;
 151
 152 /* The rest of these are inventions for g77, though there might be
 153    similar things in the C front end.  As they are found, these
 154    inventions should be renamed to be canonical.  Note that only
 155    the ones currently required to be global are so.  */
 156
 157 static tree ffecom_tree_fun_type_void;
 158
 159 tree ffecom_integer_type_node;  /* Abbrev for _tree_type[blah][blah]. */
 160 tree ffecom_integer_zero_node;  /* Like *_*_* with g77's integer type. */
 161 tree ffecom_integer_one_node;   /* " */
 162 tree ffecom_tree_type[FFEINFO_basictype][FFEINFO_kindtype];
 163
 164 /* _fun_type things are the f2c-specific versions.  For -fno-f2c,
 165    just use build_function_type and build_pointer_type on the
 166    appropriate _tree_type array element.  */
 167
 168 static tree ffecom_tree_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
 169 static tree ffecom_tree_ptr_to_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
 170 static tree ffecom_tree_subr_type;
 171 static tree ffecom_tree_ptr_to_subr_type;
 172 static tree ffecom_tree_blockdata_type;
 173
 174 static tree ffecom_tree_xargc_;
 175
 176 ffecomSymbol ffecom_symbol_null_
 177 =
 178 {
 179   NULL_TREE,
 180   NULL_TREE,
 181   NULL_TREE,
 182   NULL_TREE,
 183   false
 184 };
 185 ffeinfoKindtype ffecom_pointer_kind_ = FFEINFO_basictypeNONE;
 186 ffeinfoKindtype ffecom_label_kind_ = FFEINFO_basictypeNONE;
 187
 188 int ffecom_f2c_typecode_[FFEINFO_basictype][FFEINFO_kindtype];
 189 tree ffecom_f2c_integer_type_node;
 190 tree ffecom_f2c_ptr_to_integer_type_node;
 191 tree ffecom_f2c_address_type_node;
 192 tree ffecom_f2c_real_type_node;
 193 tree ffecom_f2c_ptr_to_real_type_node;
 194 tree ffecom_f2c_doublereal_type_node;
 195 tree ffecom_f2c_complex_type_node;
 196 tree ffecom_f2c_doublecomplex_type_node;
 197 tree ffecom_f2c_longint_type_node;
 198 tree ffecom_f2c_logical_type_node;
 199 tree ffecom_f2c_flag_type_node;
 200 tree ffecom_f2c_ftnlen_type_node;
 201 tree ffecom_f2c_ftnlen_zero_node;
 202 tree ffecom_f2c_ftnlen_one_node;
 203 tree ffecom_f2c_ftnlen_two_node;
 204 tree ffecom_f2c_ptr_to_ftnlen_type_node;
 205 tree ffecom_f2c_ftnint_type_node;
 206 tree ffecom_f2c_ptr_to_ftnint_type_node;
 207
 208 /* Simple definitions and enumerations. */
 209
 210 #ifndef FFECOM_sizeMAXSTACKITEM
 211 #define FFECOM_sizeMAXSTACKITEM 32*1024 /* Keep user-declared things
 212                                            larger than this # bytes
 213                                            off stack if possible. */
 214 #endif
 215
 216 /* For systems that have large enough stacks, they should define
 217    this to 0, and here, for ease of use later on, we just undefine
 218    it if it is 0.  */
 219
 220 #if FFECOM_sizeMAXSTACKITEM == 0
 221 #undef FFECOM_sizeMAXSTACKITEM
 222 #endif
 223
 224 typedef enum
 225   {
 226     FFECOM_rttypeVOID_,
 227     FFECOM_rttypeVOIDSTAR_,     /* C's `void *' type. */
 228     FFECOM_rttypeFTNINT_,       /* f2c's `ftnint' type. */
 229     FFECOM_rttypeINTEGER_,      /* f2c's `integer' type. */
 230     FFECOM_rttypeLONGINT_,      /* f2c's `longint' type. */
 231     FFECOM_rttypeLOGICAL_,      /* f2c's `logical' type. */
 232     FFECOM_rttypeREAL_F2C_,     /* f2c's `real' returned as `double'. */
 233     FFECOM_rttypeREAL_GNU_,     /* `real' returned as such. */
 234     FFECOM_rttypeCOMPLEX_F2C_,  /* f2c's `complex' returned via 1st arg. */
 235     FFECOM_rttypeCOMPLEX_GNU_,  /* f2c's `complex' returned directly. */
 236     FFECOM_rttypeDOUBLE_,       /* C's `double' type. */
 237     FFECOM_rttypeDOUBLEREAL_,   /* f2c's `doublereal' type. */
 238     FFECOM_rttypeDBLCMPLX_F2C_, /* f2c's `doublecomplex' returned via 1st arg. */
 239     FFECOM_rttypeDBLCMPLX_GNU_, /* f2c's `doublecomplex' returned directly. */
 240     FFECOM_rttypeCHARACTER_,    /* f2c `char *'/`ftnlen' pair. */
 241     FFECOM_rttype_
 242   } ffecomRttype_;
 243
 244 /* Internal typedefs. */
 245
 246 typedef struct _ffecom_concat_list_ ffecomConcatList_;
 247
 248 /* Private include files. */
 249
 250
 251 /* Internal structure definitions. */
 252
 253 struct _ffecom_concat_list_
 254   {
 255     ffebld *exprs;
 256     int count;
 257     int max;
 258     ffetargetCharacterSize minlen;
 259     ffetargetCharacterSize maxlen;
 260   };
 261
 262 /* Static functions (internal). */
 263
 264 static void ffecom_init_decl_processing PARAMS ((void));
 265 static tree ffecom_arglist_expr_ (const char *argstring, ffebld args);
 266 static tree ffecom_widest_expr_type_ (ffebld list);
 267 static bool ffecom_overlap_ (tree dest_decl, tree dest_offset,
 268                              tree dest_size, tree source_tree,
 269                              ffebld source, bool scalar_arg);
 270 static bool ffecom_args_overlapping_ (tree dest_tree, ffebld dest,
 271                                       tree args, tree callee_commons,
 272                                       bool scalar_args);
 273 static tree ffecom_build_f2c_string_ (int i, const char *s);
 274 static tree ffecom_call_ (tree fn, ffeinfoKindtype kt,
 275                           bool is_f2c_complex, tree type,
 276                           tree args, tree dest_tree,
 277                           ffebld dest, bool *dest_used,
 278                           tree callee_commons, bool scalar_args, tree hook);
 279 static tree ffecom_call_binop_ (tree fn, ffeinfoKindtype kt,
 280                                 bool is_f2c_complex, tree type,
 281                                 ffebld left, ffebld right,
 282                                 tree dest_tree, ffebld dest,
 283                                 bool *dest_used, tree callee_commons,
 284                                 bool scalar_args, bool ref, tree hook);
 285 static void ffecom_char_args_x_ (tree *xitem, tree *length,
 286                                  ffebld expr, bool with_null);
 287 static tree ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy);
 288 static tree ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s);
 289 static ffecomConcatList_
 290   ffecom_concat_list_gather_ (ffecomConcatList_ catlist,
 291                               ffebld expr,
 292                               ffetargetCharacterSize max);
 293 static void ffecom_concat_list_kill_ (ffecomConcatList_ catlist);
 294 static ffecomConcatList_ ffecom_concat_list_new_ (ffebld expr,
 295                                                 ffetargetCharacterSize max);
 296 static void ffecom_debug_kludge_ (tree aggr, const char *aggr_type,
 297                                   ffesymbol member, tree member_type,
 298                                   ffetargetOffset offset);
 299 static void ffecom_do_entry_ (ffesymbol fn, int entrynum);
 300 static tree ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
 301                           bool *dest_used, bool assignp, bool widenp);
 302 static tree ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
 303                                     ffebld dest, bool *dest_used);
 304 static tree ffecom_expr_power_integer_ (ffebld expr);
 305 static void ffecom_expr_transform_ (ffebld expr);
 306 static void ffecom_f2c_make_type_ (tree *type, int tcode, const char *name);
 307 static void ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
 308                                       int code);
 309 static ffeglobal ffecom_finish_global_ (ffeglobal global);
 310 static ffesymbol ffecom_finish_symbol_transform_ (ffesymbol s);
 311 static tree ffecom_get_appended_identifier_ (char us, const char *text);
 312 static tree ffecom_get_external_identifier_ (ffesymbol s);
 313 static tree ffecom_get_identifier_ (const char *text);
 314 static tree ffecom_gen_sfuncdef_ (ffesymbol s,
 315                                   ffeinfoBasictype bt,
 316                                   ffeinfoKindtype kt);
 317 static const char *ffecom_gfrt_args_ (ffecomGfrt ix);
 318 static tree ffecom_gfrt_tree_ (ffecomGfrt ix);
 319 static tree ffecom_init_zero_ (tree decl);
 320 static tree ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
 321                                      tree *maybe_tree);
 322 static tree ffecom_intrinsic_len_ (ffebld expr);
 323 static void ffecom_let_char_ (tree dest_tree,
 324                               tree dest_length,
 325                               ffetargetCharacterSize dest_size,
 326                               ffebld source);
 327 static void ffecom_make_gfrt_ (ffecomGfrt ix);
 328 static void ffecom_member_phase1_ (ffestorag mst, ffestorag st);
 329 static void ffecom_member_phase2_ (ffestorag mst, ffestorag st);
 330 static void ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size,
 331                                       ffebld source);
 332 static void ffecom_push_dummy_decls_ (ffebld dumlist,
 333                                       bool stmtfunc);
 334 static void ffecom_start_progunit_ (void);
 335 static ffesymbol ffecom_sym_transform_ (ffesymbol s);
 336 static ffesymbol ffecom_sym_transform_assign_ (ffesymbol s);
 337 static void ffecom_transform_common_ (ffesymbol s);
 338 static void ffecom_transform_equiv_ (ffestorag st);
 339 static tree ffecom_transform_namelist_ (ffesymbol s);
 340 static void ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
 341                                        tree t);
 342 static void ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
 343                                        tree *size, tree tree);
 344 static tree ffecom_tree_divide_ (tree tree_type, tree left, tree right,
 345                                  tree dest_tree, ffebld dest,
 346                                  bool *dest_used, tree hook);
 347 static tree ffecom_type_localvar_ (ffesymbol s,
 348                                    ffeinfoBasictype bt,
 349                                    ffeinfoKindtype kt);
 350 static tree ffecom_type_namelist_ (void);
 351 static tree ffecom_type_vardesc_ (void);
 352 static tree ffecom_vardesc_ (ffebld expr);
 353 static tree ffecom_vardesc_array_ (ffesymbol s);
 354 static tree ffecom_vardesc_dims_ (ffesymbol s);
 355 static tree ffecom_convert_narrow_ (tree type, tree expr);
 356 static tree ffecom_convert_widen_ (tree type, tree expr);
 357
 358 /* These are static functions that parallel those found in the C front
 359    end and thus have the same names.  */
 360
 361 static tree bison_rule_compstmt_ (void);
 362 static void bison_rule_pushlevel_ (void);
 363 static void delete_block (tree block);
 364 static int duplicate_decls (tree newdecl, tree olddecl);
 365 static void finish_decl (tree decl, tree init, bool is_top_level);
 366 static void finish_function (int nested);
 367 static const char *lang_printable_name (tree decl, int v);
 368 static tree lookup_name_current_level (tree name);
 369 static struct binding_level *make_binding_level (void);
 370 static void pop_f_function_context (void);
 371 static void push_f_function_context (void);
 372 static void push_parm_decl (tree parm);
 373 static tree pushdecl_top_level (tree decl);
 374 static int kept_level_p (void);
 375 static tree storedecls (tree decls);
 376 static void store_parm_decls (int is_main_program);
 377 static tree start_decl (tree decl, bool is_top_level);
 378 static void start_function (tree name, tree type, int nested, int public);
 379 static void ffecom_file_ (const char *name);
 380 static void ffecom_close_include_ (FILE *f);
 381 static int ffecom_decode_include_option_ (char *spec);
 382 static FILE *ffecom_open_include_ (char *name, ffewhereLine l,
 383                                    ffewhereColumn c);
 384
 385 /* Static objects accessed by functions in this module. */
 386
 387 static ffesymbol ffecom_primary_entry_ = NULL;
 388 static ffesymbol ffecom_nested_entry_ = NULL;
 389 static ffeinfoKind ffecom_primary_entry_kind_;
 390 static bool ffecom_primary_entry_is_proc_;
 391 static tree ffecom_outer_function_decl_;
 392 static tree ffecom_previous_function_decl_;
 393 static tree ffecom_which_entrypoint_decl_;
 394 static tree ffecom_float_zero_ = NULL_TREE;
 395 static tree ffecom_float_half_ = NULL_TREE;
 396 static tree ffecom_double_zero_ = NULL_TREE;
 397 static tree ffecom_double_half_ = NULL_TREE;
 398 static tree ffecom_func_result_;/* For functions. */
 399 static tree ffecom_func_length_;/* For CHARACTER fns. */
 400 static ffebld ffecom_list_blockdata_;
 401 static ffebld ffecom_list_common_;
 402 static ffebld ffecom_master_arglist_;
 403 static ffeinfoBasictype ffecom_master_bt_;
 404 static ffeinfoKindtype ffecom_master_kt_;
 405 static ffetargetCharacterSize ffecom_master_size_;
 406 static int ffecom_num_fns_ = 0;
 407 static int ffecom_num_entrypoints_ = 0;
 408 static bool ffecom_is_altreturning_ = FALSE;
 409 static tree ffecom_multi_type_node_;
 410 static tree ffecom_multi_retval_;
 411 static tree
 412   ffecom_multi_fields_[FFEINFO_basictype][FFEINFO_kindtype];
 413 static bool ffecom_member_namelisted_;  /* _member_phase1_ namelisted? */
 414 static bool ffecom_doing_entry_ = FALSE;
 415 static bool ffecom_transform_only_dummies_ = FALSE;
 416 static int ffecom_typesize_pointer_;
 417 static int ffecom_typesize_integer1_;
 418
 419 /* Holds pointer-to-function expressions.  */
 420
 421 static tree ffecom_gfrt_[FFECOM_gfrt]
 422 =
 423 {
 424 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NULL_TREE,
 425 #include "com-rt.def"
 426 #undef DEFGFRT
 427 };
 428
 429 /* Holds the external names of the functions.  */
 430
 431 static const char *const ffecom_gfrt_name_[FFECOM_gfrt]
 432 =
 433 {
 434 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NAME,
 435 #include "com-rt.def"
 436 #undef DEFGFRT
 437 };
 438
 439 /* Whether the function returns.  */
 440
 441 static const bool ffecom_gfrt_volatile_[FFECOM_gfrt]
 442 =
 443 {
 444 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) VOLATILE,
 445 #include "com-rt.def"
 446 #undef DEFGFRT
 447 };
 448
 449 /* Whether the function returns type complex.  */
 450
 451 static const bool ffecom_gfrt_complex_[FFECOM_gfrt]
 452 =
 453 {
 454 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) COMPLEX,
 455 #include "com-rt.def"
 456 #undef DEFGFRT
 457 };
 458
 459 /* Whether the function is const
 460    (i.e., has no side effects and only depends on its arguments).  */
 461
 462 static const bool ffecom_gfrt_const_[FFECOM_gfrt]
 463 =
 464 {
 465 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) CONST,
 466 #include "com-rt.def"
 467 #undef DEFGFRT
 468 };
 469
 470 /* Type code for the function return value.  */
 471
 472 static const ffecomRttype_ ffecom_gfrt_type_[FFECOM_gfrt]
 473 =
 474 {
 475 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) TYPE,
 476 #include "com-rt.def"
 477 #undef DEFGFRT
 478 };
 479
 480 /* String of codes for the function's arguments.  */
 481
 482 static const char *const ffecom_gfrt_argstring_[FFECOM_gfrt]
 483 =
 484 {
 485 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) ARGS,
 486 #include "com-rt.def"
 487 #undef DEFGFRT
 488 };
 489
 490 /* Internal macros. */
 491
 492 /* We let tm.h override the types used here, to handle trivial differences
 493    such as the choice of unsigned int or long unsigned int for size_t.
 494    When machines start needing nontrivial differences in the size type,
 495    it would be best to do something here to figure out automatically
 496    from other information what type to use.  */
 497
 498 #ifndef SIZE_TYPE
 499 #define SIZE_TYPE "long unsigned int"
 500 #endif
 501
 502 #define ffecom_concat_list_count_(catlist) ((catlist).count)
 503 #define ffecom_concat_list_expr_(catlist,i) ((catlist).exprs[(i)])
 504 #define ffecom_concat_list_maxlen_(catlist) ((catlist).maxlen)
 505 #define ffecom_concat_list_minlen_(catlist) ((catlist).minlen)
 506
 507 #define ffecom_char_args_(i,l,e) ffecom_char_args_x_((i),(l),(e),FALSE)
 508 #define ffecom_char_args_with_null_(i,l,e) ffecom_char_args_x_((i),(l),(e),TRUE)
 509
 510 /* For each binding contour we allocate a binding_level structure
 511  * which records the names defined in that contour.
 512  * Contours include:
 513  *  0) the global one
 514  *  1) one for each function definition,
 515  *     where internal declarations of the parameters appear.
 516  *
 517  * The current meaning of a name can be found by searching the levels from
 518  * the current one out to the global one.
 519  */
 520
 521 /* Note that the information in the `names' component of the global contour
 522    is duplicated in the IDENTIFIER_GLOBAL_VALUEs of all identifiers.  */
 523
 524 struct binding_level
 525   {
 526     /* A chain of _DECL nodes for all variables, constants, functions,
 527        and typedef types.  These are in the reverse of the order supplied.
 528      */
 529     tree names;
 530
 531     /* For each level (except not the global one),
 532        a chain of BLOCK nodes for all the levels
 533        that were entered and exited one level down.  */
 534     tree blocks;
 535
 536     /* The BLOCK node for this level, if one has been preallocated.
 537        If 0, the BLOCK is allocated (if needed) when the level is popped.  */
 538     tree this_block;
 539
 540     /* The binding level which this one is contained in (inherits from).  */
 541     struct binding_level *level_chain;
 542
 543     /* 0: no ffecom_prepare_* functions called at this level yet;
 544        1: ffecom_prepare* functions called, except not ffecom_prepare_end;
 545        2: ffecom_prepare_end called.  */
 546     int prep_state;
 547   };
 548
 549 #define NULL_BINDING_LEVEL (struct binding_level *) NULL
 550
 551 /* The binding level currently in effect.  */
 552
 553 static struct binding_level *current_binding_level;
 554
 555 /* A chain of binding_level structures awaiting reuse.  */
 556
 557 static struct binding_level *free_binding_level;
 558
 559 /* The outermost binding level, for names of file scope.
 560    This is created when the compiler is started and exists
 561    through the entire run.  */
 562
 563 static struct binding_level *global_binding_level;
 564
 565 /* Binding level structures are initialized by copying this one.  */
 566
 567 static const struct binding_level clear_binding_level
 568 =
 569 {NULL, NULL, NULL, NULL_BINDING_LEVEL, 0};
 570
 571 /* Language-dependent contents of an identifier.  */
 572
 573 struct lang_identifier
 574   {
 575     struct tree_identifier ignore;
 576     tree global_value, local_value, label_value;
 577     bool invented;
 578   };
 579
 580 /* Macros for access to language-specific slots in an identifier.  */
 581 /* Each of these slots contains a DECL node or null.  */
 582
 583 /* This represents the value which the identifier has in the
 584    file-scope namespace.  */
 585 #define IDENTIFIER_GLOBAL_VALUE(NODE)   \
 586   (((struct lang_identifier *)(NODE))->global_value)
 587 /* This represents the value which the identifier has in the current
 588    scope.  */
 589 #define IDENTIFIER_LOCAL_VALUE(NODE)    \
 590   (((struct lang_identifier *)(NODE))->local_value)
 591 /* This represents the value which the identifier has as a label in
 592    the current label scope.  */
 593 #define IDENTIFIER_LABEL_VALUE(NODE)    \
 594   (((struct lang_identifier *)(NODE))->label_value)
 595 /* This is nonzero if the identifier was "made up" by g77 code.  */
 596 #define IDENTIFIER_INVENTED(NODE)       \
 597   (((struct lang_identifier *)(NODE))->invented)
 598
 599 /* In identifiers, C uses the following fields in a special way:
 600    TREE_PUBLIC        to record that there was a previous local extern decl.
 601    TREE_USED          to record that such a decl was used.
 602    TREE_ADDRESSABLE   to record that the address of such a decl was used.  */
 603
 604 /* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function
 605    that have names.  Here so we can clear out their names' definitions
 606    at the end of the function.  */
 607
 608 static tree named_labels;
 609
 610 /* A list of LABEL_DECLs from outer contexts that are currently shadowed.  */
 611
 612 static tree shadowed_labels;
 613 \f
 614 /* Return the subscript expression, modified to do range-checking.
 615
 616    `array' is the array to be checked against.
 617    `element' is the subscript expression to check.
 618    `dim' is the dimension number (starting at 0).
 619    `total_dims' is the total number of dimensions (0 for CHARACTER substring).
 620 */
 621
 622 static tree
 623 ffecom_subscript_check_ (tree array, tree element, int dim, int total_dims,
 624                          const char *array_name)
 625 {
 626   tree low = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
 627   tree high = TYPE_MAX_VALUE (TYPE_DOMAIN (array));
 628   tree cond;
 629   tree die;
 630   tree args;
 631
 632   if (element == error_mark_node)
 633     return element;
 634
 635   if (TREE_TYPE (low) != TREE_TYPE (element))
 636     {
 637       if (TYPE_PRECISION (TREE_TYPE (low))
 638           > TYPE_PRECISION (TREE_TYPE (element)))
 639         element = convert (TREE_TYPE (low), element);
 640       else
 641         {
 642           low = convert (TREE_TYPE (element), low);
 643           if (high)
 644             high = convert (TREE_TYPE (element), high);
 645         }
 646     }
 647
 648   element = ffecom_save_tree (element);
 649   if (total_dims == 0)
 650     {
 651       /* Special handling for substring range checks.  Fortran allows the
 652          end subscript < begin subscript, which means that expressions like
 653        string(1:0) are valid (and yield a null string).  In view of this,
 654        enforce two simpler conditions:
 655           1) element<=high for end-substring;
 656           2) element>=low for start-substring.
 657        Run-time character movement will enforce remaining conditions.
 658
 659        More complicated checks would be better, but present structure only
 660        provides one index element at a time, so it is not possible to
 661        enforce a check of both i and j in string(i:j).  If it were, the
 662        complete set of rules would read,
 663          if ( ((j<i) && ((low<=i<=high) || (low<=j<=high))) ||
 664               ((low<=i<=high) && (low<=j<=high)) )
 665            ok ;
 666          else
 667            range error ;
 668       */
 669       if (dim)
 670         cond = ffecom_2 (LE_EXPR, integer_type_node, element, high);
 671       else
 672         cond = ffecom_2 (LE_EXPR, integer_type_node, low, element);
 673     }
 674   else
 675     {
 676       /* Array reference substring range checking.  */
 677
 678       cond = ffecom_2 (LE_EXPR, integer_type_node,
 679                      low,
 680                      element);
 681       if (high)
 682         {
 683           cond = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
 684                          cond,
 685                          ffecom_2 (LE_EXPR, integer_type_node,
 686                                    element,
 687                                    high));
 688         }
 689     }
 690
 691   {
 692     int len;
 693     char *proc;
 694     char *var;
 695     tree arg3;
 696     tree arg2;
 697     tree arg1;
 698     tree arg4;
 699
 700     switch (total_dims)
 701       {
 702       case 0:
 703         var = concat (array_name, "[", (dim ? "end" : "start"),
 704                       "-substring]", NULL);
 705         len = strlen (var) + 1;
 706         arg1 = build_string (len, var);
 707         free (var);
 708         break;
 709
 710       case 1:
 711         len = strlen (array_name) + 1;
 712         arg1 = build_string (len, array_name);
 713         break;
 714
 715       default:
 716         var = xmalloc (strlen (array_name) + 40);
 717         sprintf (var, "%s[subscript-%d-of-%d]",
 718                  array_name,
 719                  dim + 1, total_dims);
 720         len = strlen (var) + 1;
 721         arg1 = build_string (len, var);
 722         free (var);
 723         break;
 724       }
 725
 726     TREE_TYPE (arg1)
 727       = build_type_variant (build_array_type (char_type_node,
 728                                               build_range_type
 729                                               (integer_type_node,
 730                                                integer_one_node,
 731                                                build_int_2 (len, 0))),
 732                             1, 0);
 733     TREE_CONSTANT (arg1) = 1;
 734     TREE_STATIC (arg1) = 1;
 735     arg1 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg1)),
 736                      arg1);
 737
 738     /* s_rnge adds one to the element to print it, so bias against
 739        that -- want to print a faithful *subscript* value.  */
 740     arg2 = convert (ffecom_f2c_ftnint_type_node,
 741                     ffecom_2 (MINUS_EXPR,
 742                               TREE_TYPE (element),
 743                               element,
 744                               convert (TREE_TYPE (element),
 745                                        integer_one_node)));
 746
 747     proc = concat (input_filename, "/",
 748                    IDENTIFIER_POINTER (DECL_NAME (current_function_decl)),
 749                    NULL);
 750     len = strlen (proc) + 1;
 751     arg3 = build_string (len, proc);
 752
 753     free (proc);
 754
 755     TREE_TYPE (arg3)
 756       = build_type_variant (build_array_type (char_type_node,
 757                                               build_range_type
 758                                               (integer_type_node,
 759                                                integer_one_node,
 760                                                build_int_2 (len, 0))),
 761                             1, 0);
 762     TREE_CONSTANT (arg3) = 1;
 763     TREE_STATIC (arg3) = 1;
 764     arg3 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg3)),
 765                      arg3);
 766
 767     arg4 = convert (ffecom_f2c_ftnint_type_node,
 768                     build_int_2 (lineno, 0));
 769
 770     arg1 = build_tree_list (NULL_TREE, arg1);
 771     arg2 = build_tree_list (NULL_TREE, arg2);
 772     arg3 = build_tree_list (NULL_TREE, arg3);
 773     arg4 = build_tree_list (NULL_TREE, arg4);
 774     TREE_CHAIN (arg3) = arg4;
 775     TREE_CHAIN (arg2) = arg3;
 776     TREE_CHAIN (arg1) = arg2;
 777
 778     args = arg1;
 779   }
 780   die = ffecom_call_gfrt (FFECOM_gfrtRANGE,
 781                           args, NULL_TREE);
 782   TREE_SIDE_EFFECTS (die) = 1;
 783
 784   element = ffecom_3 (COND_EXPR,
 785                       TREE_TYPE (element),
 786                       cond,
 787                       element,
 788                       die);
 789
 790   return element;
 791 }
 792
 793 /* Return the computed element of an array reference.
 794
 795    `item' is NULL_TREE, or the transformed pointer to the array.
 796    `expr' is the original opARRAYREF expression, which is transformed
 797      if `item' is NULL_TREE.
 798    `want_ptr' is non-zero if a pointer to the element, instead of
 799      the element itself, is to be returned.  */
 800
 801 static tree
 802 ffecom_arrayref_ (tree item, ffebld expr, int want_ptr)
 803 {
 804   ffebld dims[FFECOM_dimensionsMAX];
 805   int i;
 806   int total_dims;
 807   int flatten = ffe_is_flatten_arrays ();
 808   int need_ptr;
 809   tree array;
 810   tree element;
 811   tree tree_type;
 812   tree tree_type_x;
 813   const char *array_name;
 814   ffetype type;
 815   ffebld list;
 816
 817   if (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER)
 818     array_name = ffesymbol_text (ffebld_symter (ffebld_left (expr)));
 819   else
 820     array_name = "[expr?]";
 821
 822   /* Build up ARRAY_REFs in reverse order (since we're column major
 823      here in Fortran land). */
 824
 825   for (i = 0, list = ffebld_right (expr);
 826        list != NULL;
 827        ++i, list = ffebld_trail (list))
 828     {
 829       dims[i] = ffebld_head (list);
 830       type = ffeinfo_type (ffebld_basictype (dims[i]),
 831                            ffebld_kindtype (dims[i]));
 832       if (! flatten
 833           && ffecom_typesize_pointer_ > ffecom_typesize_integer1_
 834           && ffetype_size (type) > ffecom_typesize_integer1_)
 835         /* E.g. ARRAY(INDEX), given INTEGER*8 INDEX, on a system with 64-bit
 836            pointers and 32-bit integers.  Do the full 64-bit pointer
 837            arithmetic, for codes using arrays for nonstandard heap-like
 838            work.  */
 839         flatten = 1;
 840     }
 841
 842   total_dims = i;
 843
 844   need_ptr = want_ptr || flatten;
 845
 846   if (! item)
 847     {
 848       if (need_ptr)
 849         item = ffecom_ptr_to_expr (ffebld_left (expr));
 850       else
 851         item = ffecom_expr (ffebld_left (expr));
 852
 853       if (item == error_mark_node)
 854         return item;
 855
 856       if (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereFLEETING
 857           && ! mark_addressable (item))
 858         return error_mark_node;
 859     }
 860
 861   if (item == error_mark_node)
 862     return item;
 863
 864   if (need_ptr)
 865     {
 866       tree min;
 867
 868       for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
 869            i >= 0;
 870            --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array)))
 871         {
 872           min = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
 873           element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
 874           if (flag_bounds_check)
 875             element = ffecom_subscript_check_ (array, element, i, total_dims,
 876                                                array_name);
 877           if (element == error_mark_node)
 878             return element;
 879
 880           /* Widen integral arithmetic as desired while preserving
 881              signedness.  */
 882           tree_type = TREE_TYPE (element);
 883           tree_type_x = tree_type;
 884           if (tree_type
 885               && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
 886               && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
 887             tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
 888
 889           if (TREE_TYPE (min) != tree_type_x)
 890             min = convert (tree_type_x, min);
 891           if (TREE_TYPE (element) != tree_type_x)
 892             element = convert (tree_type_x, element);
 893
 894           item = ffecom_2 (PLUS_EXPR,
 895                            build_pointer_type (TREE_TYPE (array)),
 896                            item,
 897                            size_binop (MULT_EXPR,
 898                                        size_in_bytes (TREE_TYPE (array)),
 899                                        convert (sizetype,
 900                                                 fold (build (MINUS_EXPR,
 901                                                              tree_type_x,
 902                                                              element, min)))));
 903         }
 904       if (! want_ptr)
 905         {
 906           item = ffecom_1 (INDIRECT_REF,
 907                            TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
 908                            item);
 909         }
 910     }
 911   else
 912     {
 913       for (--i;
 914            i >= 0;
 915            --i)
 916         {
 917           array = TYPE_MAIN_VARIANT (TREE_TYPE (item));
 918
 919           element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
 920           if (flag_bounds_check)
 921             element = ffecom_subscript_check_ (array, element, i, total_dims,
 922                                                array_name);
 923           if (element == error_mark_node)
 924             return element;
 925
 926           /* Widen integral arithmetic as desired while preserving
 927              signedness.  */
 928           tree_type = TREE_TYPE (element);
 929           tree_type_x = tree_type;
 930           if (tree_type
 931               && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
 932               && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
 933             tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
 934
 935           element = convert (tree_type_x, element);
 936
 937           item = ffecom_2 (ARRAY_REF,
 938                            TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
 939                            item,
 940                            element);
 941         }
 942     }
 943
 944   return item;
 945 }
 946
 947 /* This is like gcc's stabilize_reference -- in fact, most of the code
 948    comes from that -- but it handles the situation where the reference
 949    is going to have its subparts picked at, and it shouldn't change
 950    (or trigger extra invocations of functions in the subtrees) due to
 951    this.  save_expr is a bit overzealous, because we don't need the
 952    entire thing calculated and saved like a temp.  So, for DECLs, no
 953    change is needed, because these are stable aggregates, and ARRAY_REF
 954    and such might well be stable too, but for things like calculations,
 955    we do need to calculate a snapshot of a value before picking at it.  */
 956
 957 static tree
 958 ffecom_stabilize_aggregate_ (tree ref)
 959 {
 960   tree result;
 961   enum tree_code code = TREE_CODE (ref);
 962
 963   switch (code)
 964     {
 965     case VAR_DECL:
 966     case PARM_DECL:
 967     case RESULT_DECL:
 968       /* No action is needed in this case.  */
 969       return ref;
 970
 971     case NOP_EXPR:
 972     case CONVERT_EXPR:
 973     case FLOAT_EXPR:
 974     case FIX_TRUNC_EXPR:
 975     case FIX_FLOOR_EXPR:
 976     case FIX_ROUND_EXPR:
 977     case FIX_CEIL_EXPR:
 978       result = build_nt (code, stabilize_reference (TREE_OPERAND (ref, 0)));
 979       break;
 980
 981     case INDIRECT_REF:
 982       result = build_nt (INDIRECT_REF,
 983                          stabilize_reference_1 (TREE_OPERAND (ref, 0)));
 984       break;
 985
 986     case COMPONENT_REF:
 987       result = build_nt (COMPONENT_REF,
 988                          stabilize_reference (TREE_OPERAND (ref, 0)),
 989                          TREE_OPERAND (ref, 1));
 990       break;
 991
 992     case BIT_FIELD_REF:
 993       result = build_nt (BIT_FIELD_REF,
 994                          stabilize_reference (TREE_OPERAND (ref, 0)),
 995                          stabilize_reference_1 (TREE_OPERAND (ref, 1)),
 996                          stabilize_reference_1 (TREE_OPERAND (ref, 2)));
 997       break;
 998
 999     case ARRAY_REF:
1000       result = build_nt (ARRAY_REF,
1001                          stabilize_reference (TREE_OPERAND (ref, 0)),
1002                          stabilize_reference_1 (TREE_OPERAND (ref, 1)));
1003       break;
1004
1005     case COMPOUND_EXPR:
1006       result = build_nt (COMPOUND_EXPR,
1007                          stabilize_reference_1 (TREE_OPERAND (ref, 0)),
1008                          stabilize_reference (TREE_OPERAND (ref, 1)));
1009       break;
1010
1011     case RTL_EXPR:
1012       abort ();
1013
1014
1015     default:
1016       return save_expr (ref);
1017
1018     case ERROR_MARK:
1019       return error_mark_node;
1020     }
1021
1022   TREE_TYPE (result) = TREE_TYPE (ref);
1023   TREE_READONLY (result) = TREE_READONLY (ref);
1024   TREE_SIDE_EFFECTS (result) = TREE_SIDE_EFFECTS (ref);
1025   TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref);
1026
1027   return result;
1028 }
1029
1030 /* A rip-off of gcc's convert.c convert_to_complex function,
1031    reworked to handle complex implemented as C structures
1032    (RECORD_TYPE with two fields, real and imaginary `r' and `i').  */
1033
1034 static tree
1035 ffecom_convert_to_complex_ (tree type, tree expr)
1036 {
1037   register enum tree_code form = TREE_CODE (TREE_TYPE (expr));
1038   tree subtype;
1039
1040   assert (TREE_CODE (type) == RECORD_TYPE);
1041
1042   subtype = TREE_TYPE (TYPE_FIELDS (type));
1043
1044   if (form == REAL_TYPE || form == INTEGER_TYPE || form == ENUMERAL_TYPE)
1045     {
1046       expr = convert (subtype, expr);
1047       return ffecom_2 (COMPLEX_EXPR, type, expr,
1048                        convert (subtype, integer_zero_node));
1049     }
1050
1051   if (form == RECORD_TYPE)
1052     {
1053       tree elt_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr)));
1054       if (TYPE_MAIN_VARIANT (elt_type) == TYPE_MAIN_VARIANT (subtype))
1055         return expr;
1056       else
1057         {
1058           expr = save_expr (expr);
1059           return ffecom_2 (COMPLEX_EXPR,
1060                            type,
1061                            convert (subtype,
1062                                     ffecom_1 (REALPART_EXPR,
1063                                               TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1064                                               expr)),
1065                            convert (subtype,
1066                                     ffecom_1 (IMAGPART_EXPR,
1067                                               TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1068                                               expr)));
1069         }
1070     }
1071
1072   if (form == POINTER_TYPE || form == REFERENCE_TYPE)
1073     error ("pointer value used where a complex was expected");
1074   else
1075     error ("aggregate value used where a complex was expected");
1076
1077   return ffecom_2 (COMPLEX_EXPR, type,
1078                    convert (subtype, integer_zero_node),
1079                    convert (subtype, integer_zero_node));
1080 }
1081
1082 /* Like gcc's convert(), but crashes if widening might happen.  */
1083
1084 static tree
1085 ffecom_convert_narrow_ (type, expr)
1086      tree type, expr;
1087 {
1088   register tree e = expr;
1089   register enum tree_code code = TREE_CODE (type);
1090
1091   if (type == TREE_TYPE (e)
1092       || TREE_CODE (e) == ERROR_MARK)
1093     return e;
1094   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1095     return fold (build1 (NOP_EXPR, type, e));
1096   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1097       || code == ERROR_MARK)
1098     return error_mark_node;
1099   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1100     {
1101       assert ("void value not ignored as it ought to be" == NULL);
1102       return error_mark_node;
1103     }
1104   assert (code != VOID_TYPE);
1105   if ((code != RECORD_TYPE)
1106       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1107     assert ("converting COMPLEX to REAL" == NULL);
1108   assert (code != ENUMERAL_TYPE);
1109   if (code == INTEGER_TYPE)
1110     {
1111       assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1112                && TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)))
1113               || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1114                   && (TYPE_PRECISION (type)
1115                       == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1116       return fold (convert_to_integer (type, e));
1117     }
1118   if (code == POINTER_TYPE)
1119     {
1120       assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1121       return fold (convert_to_pointer (type, e));
1122     }
1123   if (code == REAL_TYPE)
1124     {
1125       assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1126       assert (TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)));
1127       return fold (convert_to_real (type, e));
1128     }
1129   if (code == COMPLEX_TYPE)
1130     {
1131       assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1132       assert (TYPE_PRECISION (TREE_TYPE (type)) <= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1133       return fold (convert_to_complex (type, e));
1134     }
1135   if (code == RECORD_TYPE)
1136     {
1137       assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1138       /* Check that at least the first field name agrees.  */
1139       assert (DECL_NAME (TYPE_FIELDS (type))
1140               == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1141       assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1142               <= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1143       if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1144           == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1145         return e;
1146       return fold (ffecom_convert_to_complex_ (type, e));
1147     }
1148
1149   assert ("conversion to non-scalar type requested" == NULL);
1150   return error_mark_node;
1151 }
1152
1153 /* Like gcc's convert(), but crashes if narrowing might happen.  */
1154
1155 static tree
1156 ffecom_convert_widen_ (type, expr)
1157      tree type, expr;
1158 {
1159   register tree e = expr;
1160   register enum tree_code code = TREE_CODE (type);
1161
1162   if (type == TREE_TYPE (e)
1163       || TREE_CODE (e) == ERROR_MARK)
1164     return e;
1165   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1166     return fold (build1 (NOP_EXPR, type, e));
1167   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1168       || code == ERROR_MARK)
1169     return error_mark_node;
1170   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1171     {
1172       assert ("void value not ignored as it ought to be" == NULL);
1173       return error_mark_node;
1174     }
1175   assert (code != VOID_TYPE);
1176   if ((code != RECORD_TYPE)
1177       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1178     assert ("narrowing COMPLEX to REAL" == NULL);
1179   assert (code != ENUMERAL_TYPE);
1180   if (code == INTEGER_TYPE)
1181     {
1182       assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1183                && TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)))
1184               || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1185                   && (TYPE_PRECISION (type)
1186                       == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1187       return fold (convert_to_integer (type, e));
1188     }
1189   if (code == POINTER_TYPE)
1190     {
1191       assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1192       return fold (convert_to_pointer (type, e));
1193     }
1194   if (code == REAL_TYPE)
1195     {
1196       assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1197       assert (TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)));
1198       return fold (convert_to_real (type, e));
1199     }
1200   if (code == COMPLEX_TYPE)
1201     {
1202       assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1203       assert (TYPE_PRECISION (TREE_TYPE (type)) >= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1204       return fold (convert_to_complex (type, e));
1205     }
1206   if (code == RECORD_TYPE)
1207     {
1208       assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1209       /* Check that at least the first field name agrees.  */
1210       assert (DECL_NAME (TYPE_FIELDS (type))
1211               == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1212       assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1213               >= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1214       if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1215           == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1216         return e;
1217       return fold (ffecom_convert_to_complex_ (type, e));
1218     }
1219
1220   assert ("conversion to non-scalar type requested" == NULL);
1221   return error_mark_node;
1222 }
1223
1224 /* Handles making a COMPLEX type, either the standard
1225    (but buggy?) gbe way, or the safer (but less elegant?)
1226    f2c way.  */
1227
1228 static tree
1229 ffecom_make_complex_type_ (tree subtype)
1230 {
1231   tree type;
1232   tree realfield;
1233   tree imagfield;
1234
1235   if (ffe_is_emulate_complex ())
1236     {
1237       type = make_node (RECORD_TYPE);
1238       realfield = ffecom_decl_field (type, NULL_TREE, "r", subtype);
1239       imagfield = ffecom_decl_field (type, realfield, "i", subtype);
1240       TYPE_FIELDS (type) = realfield;
1241       layout_type (type);
1242     }
1243   else
1244     {
1245       type = make_node (COMPLEX_TYPE);
1246       TREE_TYPE (type) = subtype;
1247       layout_type (type);
1248     }
1249
1250   return type;
1251 }
1252
1253 /* Chooses either the gbe or the f2c way to build a
1254    complex constant.  */
1255
1256 static tree
1257 ffecom_build_complex_constant_ (tree type, tree realpart, tree imagpart)
1258 {
1259   tree bothparts;
1260
1261   if (ffe_is_emulate_complex ())
1262     {
1263       bothparts = build_tree_list (TYPE_FIELDS (type), realpart);
1264       TREE_CHAIN (bothparts) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), imagpart);
1265       bothparts = build (CONSTRUCTOR, type, NULL_TREE, bothparts);
1266     }
1267   else
1268     {
1269       bothparts = build_complex (type, realpart, imagpart);
1270     }
1271
1272   return bothparts;
1273 }
1274
1275 static tree
1276 ffecom_arglist_expr_ (const char *c, ffebld expr)
1277 {
1278   tree list;
1279   tree *plist = &list;
1280   tree trail = NULL_TREE;       /* Append char length args here. */
1281   tree *ptrail = &trail;
1282   tree length;
1283   ffebld exprh;
1284   tree item;
1285   bool ptr = FALSE;
1286   tree wanted = NULL_TREE;
1287   static const char zed[] = "0";
1288
1289   if (c == NULL)
1290     c = &zed[0];
1291
1292   while (expr != NULL)
1293     {
1294       if (*c != '\0')
1295         {
1296           ptr = FALSE;
1297           if (*c == '&')
1298             {
1299               ptr = TRUE;
1300               ++c;
1301             }
1302           switch (*(c++))
1303             {
1304             case '\0':
1305               ptr = TRUE;
1306               wanted = NULL_TREE;
1307               break;
1308
1309             case 'a':
1310               assert (ptr);
1311               wanted = NULL_TREE;
1312               break;
1313
1314             case 'c':
1315               wanted = ffecom_f2c_complex_type_node;
1316               break;
1317
1318             case 'd':
1319               wanted = ffecom_f2c_doublereal_type_node;
1320               break;
1321
1322             case 'e':
1323               wanted = ffecom_f2c_doublecomplex_type_node;
1324               break;
1325
1326             case 'f':
1327               wanted = ffecom_f2c_real_type_node;
1328               break;
1329
1330             case 'i':
1331               wanted = ffecom_f2c_integer_type_node;
1332               break;
1333
1334             case 'j':
1335               wanted = ffecom_f2c_longint_type_node;
1336               break;
1337
1338             default:
1339               assert ("bad argstring code" == NULL);
1340               wanted = NULL_TREE;
1341               break;
1342             }
1343         }
1344
1345       exprh = ffebld_head (expr);
1346       if (exprh == NULL)
1347         wanted = NULL_TREE;
1348
1349       if ((wanted == NULL_TREE)
1350           || (ptr
1351               && (TYPE_MODE
1352                   (ffecom_tree_type[ffeinfo_basictype (ffebld_info (exprh))]
1353                    [ffeinfo_kindtype (ffebld_info (exprh))])
1354                    == TYPE_MODE (wanted))))
1355         *plist
1356           = build_tree_list (NULL_TREE,
1357                              ffecom_arg_ptr_to_expr (exprh,
1358                                                      &length));
1359       else
1360         {
1361           item = ffecom_arg_expr (exprh, &length);
1362           item = ffecom_convert_widen_ (wanted, item);
1363           if (ptr)
1364             {
1365               item = ffecom_1 (ADDR_EXPR,
1366                                build_pointer_type (TREE_TYPE (item)),
1367                                item);
1368             }
1369           *plist
1370             = build_tree_list (NULL_TREE,
1371                                item);
1372         }
1373
1374       plist = &TREE_CHAIN (*plist);
1375       expr = ffebld_trail (expr);
1376       if (length != NULL_TREE)
1377         {
1378           *ptrail = build_tree_list (NULL_TREE, length);
1379           ptrail = &TREE_CHAIN (*ptrail);
1380         }
1381     }
1382
1383   /* We've run out of args in the call; if the implementation expects
1384      more, supply null pointers for them, which the implementation can
1385      check to see if an arg was omitted. */
1386
1387   while (*c != '\0' && *c != '0')
1388     {
1389       if (*c == '&')
1390         ++c;
1391       else
1392         assert ("missing arg to run-time routine!" == NULL);
1393
1394       switch (*(c++))
1395         {
1396         case '\0':
1397         case 'a':
1398         case 'c':
1399         case 'd':
1400         case 'e':
1401         case 'f':
1402         case 'i':
1403         case 'j':
1404           break;
1405
1406         default:
1407           assert ("bad arg string code" == NULL);
1408           break;
1409         }
1410       *plist
1411         = build_tree_list (NULL_TREE,
1412                            null_pointer_node);
1413       plist = &TREE_CHAIN (*plist);
1414     }
1415
1416   *plist = trail;
1417
1418   return list;
1419 }
1420
1421 static tree
1422 ffecom_widest_expr_type_ (ffebld list)
1423 {
1424   ffebld item;
1425   ffebld widest = NULL;
1426   ffetype type;
1427   ffetype widest_type = NULL;
1428   tree t;
1429
1430   for (; list != NULL; list = ffebld_trail (list))
1431     {
1432       item = ffebld_head (list);
1433       if (item == NULL)
1434         continue;
1435       if ((widest != NULL)
1436           && (ffeinfo_basictype (ffebld_info (item))
1437               != ffeinfo_basictype (ffebld_info (widest))))
1438         continue;
1439       type = ffeinfo_type (ffeinfo_basictype (ffebld_info (item)),
1440                            ffeinfo_kindtype (ffebld_info (item)));
1441       if ((widest == FFEINFO_kindtypeNONE)
1442           || (ffetype_size (type)
1443               > ffetype_size (widest_type)))
1444         {
1445           widest = item;
1446           widest_type = type;
1447         }
1448     }
1449
1450   assert (widest != NULL);
1451   t = ffecom_tree_type[ffeinfo_basictype (ffebld_info (widest))]
1452     [ffeinfo_kindtype (ffebld_info (widest))];
1453   assert (t != NULL_TREE);
1454   return t;
1455 }
1456
1457 /* Check whether a partial overlap between two expressions is possible.
1458
1459    Can *starting* to write a portion of expr1 change the value
1460    computed (perhaps already, *partially*) by expr2?
1461
1462    Currently, this is a concern only for a COMPLEX expr1.  But if it
1463    isn't in COMMON or local EQUIVALENCE, since we don't support
1464    aliasing of arguments, it isn't a concern.  */
1465
1466 static bool
1467 ffecom_possible_partial_overlap_ (ffebld expr1, ffebld expr2 ATTRIBUTE_UNUSED)
1468 {
1469   ffesymbol sym;
1470   ffestorag st;
1471
1472   switch (ffebld_op (expr1))
1473     {
1474     case FFEBLD_opSYMTER:
1475       sym = ffebld_symter (expr1);
1476       break;
1477
1478     case FFEBLD_opARRAYREF:
1479       if (ffebld_op (ffebld_left (expr1)) != FFEBLD_opSYMTER)
1480         return FALSE;
1481       sym = ffebld_symter (ffebld_left (expr1));
1482       break;
1483
1484     default:
1485       return FALSE;
1486     }
1487
1488   if (ffesymbol_where (sym) != FFEINFO_whereCOMMON
1489       && (ffesymbol_where (sym) != FFEINFO_whereLOCAL
1490           || ! (st = ffesymbol_storage (sym))
1491           || ! ffestorag_parent (st)))
1492     return FALSE;
1493
1494   /* It's in COMMON or local EQUIVALENCE.  */
1495
1496   return TRUE;
1497 }
1498
1499 /* Check whether dest and source might overlap.  ffebld versions of these
1500    might or might not be passed, will be NULL if not.
1501
1502    The test is really whether source_tree is modifiable and, if modified,
1503    might overlap destination such that the value(s) in the destination might
1504    change before it is finally modified.  dest_* are the canonized
1505    destination itself.  */
1506
1507 static bool
1508 ffecom_overlap_ (tree dest_decl, tree dest_offset, tree dest_size,
1509                  tree source_tree, ffebld source UNUSED,
1510                  bool scalar_arg)
1511 {
1512   tree source_decl;
1513   tree source_offset;
1514   tree source_size;
1515   tree t;
1516
1517   if (source_tree == NULL_TREE)
1518     return FALSE;
1519
1520   switch (TREE_CODE (source_tree))
1521     {
1522     case ERROR_MARK:
1523     case IDENTIFIER_NODE:
1524     case INTEGER_CST:
1525     case REAL_CST:
1526     case COMPLEX_CST:
1527     case STRING_CST:
1528     case CONST_DECL:
1529     case VAR_DECL:
1530     case RESULT_DECL:
1531     case FIELD_DECL:
1532     case MINUS_EXPR:
1533     case MULT_EXPR:
1534     case TRUNC_DIV_EXPR:
1535     case CEIL_DIV_EXPR:
1536     case FLOOR_DIV_EXPR:
1537     case ROUND_DIV_EXPR:
1538     case TRUNC_MOD_EXPR:
1539     case CEIL_MOD_EXPR:
1540     case FLOOR_MOD_EXPR:
1541     case ROUND_MOD_EXPR:
1542     case RDIV_EXPR:
1543     case EXACT_DIV_EXPR:
1544     case FIX_TRUNC_EXPR:
1545     case FIX_CEIL_EXPR:
1546     case FIX_FLOOR_EXPR:
1547     case FIX_ROUND_EXPR:
1548     case FLOAT_EXPR:
1549     case NEGATE_EXPR:
1550     case MIN_EXPR:
1551     case MAX_EXPR:
1552     case ABS_EXPR:
1553     case FFS_EXPR:
1554     case LSHIFT_EXPR:
1555     case RSHIFT_EXPR:
1556     case LROTATE_EXPR:
1557     case RROTATE_EXPR:
1558     case BIT_IOR_EXPR:
1559     case BIT_XOR_EXPR:
1560     case BIT_AND_EXPR:
1561     case BIT_ANDTC_EXPR:
1562     case BIT_NOT_EXPR:
1563     case TRUTH_ANDIF_EXPR:
1564     case TRUTH_ORIF_EXPR:
1565     case TRUTH_AND_EXPR:
1566     case TRUTH_OR_EXPR:
1567     case TRUTH_XOR_EXPR:
1568     case TRUTH_NOT_EXPR:
1569     case LT_EXPR:
1570     case LE_EXPR:
1571     case GT_EXPR:
1572     case GE_EXPR:
1573     case EQ_EXPR:
1574     case NE_EXPR:
1575     case COMPLEX_EXPR:
1576     case CONJ_EXPR:
1577     case REALPART_EXPR:
1578     case IMAGPART_EXPR:
1579     case LABEL_EXPR:
1580     case COMPONENT_REF:
1581       return FALSE;
1582
1583     case COMPOUND_EXPR:
1584       return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1585                               TREE_OPERAND (source_tree, 1), NULL,
1586                               scalar_arg);
1587
1588     case MODIFY_EXPR:
1589       return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1590                               TREE_OPERAND (source_tree, 0), NULL,
1591                               scalar_arg);
1592
1593     case CONVERT_EXPR:
1594     case NOP_EXPR:
1595     case NON_LVALUE_EXPR:
1596     case PLUS_EXPR:
1597       if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1598         return TRUE;
1599
1600       ffecom_tree_canonize_ptr_ (&source_decl, &source_offset,
1601                                  source_tree);
1602       source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1603       break;
1604
1605     case COND_EXPR:
1606       return
1607         ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1608                          TREE_OPERAND (source_tree, 1), NULL,
1609                          scalar_arg)
1610           || ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1611                               TREE_OPERAND (source_tree, 2), NULL,
1612                               scalar_arg);
1613
1614
1615     case ADDR_EXPR:
1616       ffecom_tree_canonize_ref_ (&source_decl, &source_offset,
1617                                  &source_size,
1618                                  TREE_OPERAND (source_tree, 0));
1619       break;
1620
1621     case PARM_DECL:
1622       if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1623         return TRUE;
1624
1625       source_decl = source_tree;
1626       source_offset = bitsize_zero_node;
1627       source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1628       break;
1629
1630     case SAVE_EXPR:
1631     case REFERENCE_EXPR:
1632     case PREDECREMENT_EXPR:
1633     case PREINCREMENT_EXPR:
1634     case POSTDECREMENT_EXPR:
1635     case POSTINCREMENT_EXPR:
1636     case INDIRECT_REF:
1637     case ARRAY_REF:
1638     case CALL_EXPR:
1639     default:
1640       return TRUE;
1641     }
1642
1643   /* Come here when source_decl, source_offset, and source_size filled
1644      in appropriately.  */
1645
1646   if (source_decl == NULL_TREE)
1647     return FALSE;               /* No decl involved, so no overlap. */
1648
1649   if (source_decl != dest_decl)
1650     return FALSE;               /* Different decl, no overlap. */
1651
1652   if (TREE_CODE (dest_size) == ERROR_MARK)
1653     return TRUE;                /* Assignment into entire assumed-size
1654                                    array?  Shouldn't happen.... */
1655
1656   t = ffecom_2 (LE_EXPR, integer_type_node,
1657                 ffecom_2 (PLUS_EXPR, TREE_TYPE (dest_offset),
1658                           dest_offset,
1659                           convert (TREE_TYPE (dest_offset),
1660                                    dest_size)),
1661                 convert (TREE_TYPE (dest_offset),
1662                          source_offset));
1663
1664   if (integer_onep (t))
1665     return FALSE;               /* Destination precedes source. */
1666
1667   if (!scalar_arg
1668       || (source_size == NULL_TREE)
1669       || (TREE_CODE (source_size) == ERROR_MARK)
1670       || integer_zerop (source_size))
1671     return TRUE;                /* No way to tell if dest follows source. */
1672
1673   t = ffecom_2 (LE_EXPR, integer_type_node,
1674                 ffecom_2 (PLUS_EXPR, TREE_TYPE (source_offset),
1675                           source_offset,
1676                           convert (TREE_TYPE (source_offset),
1677                                    source_size)),
1678                 convert (TREE_TYPE (source_offset),
1679                          dest_offset));
1680
1681   if (integer_onep (t))
1682     return FALSE;               /* Destination follows source. */
1683
1684   return TRUE;          /* Destination and source overlap. */
1685 }
1686
1687 /* Check whether dest might overlap any of a list of arguments or is
1688    in a COMMON area the callee might know about (and thus modify).  */
1689
1690 static bool
1691 ffecom_args_overlapping_ (tree dest_tree, ffebld dest UNUSED,
1692                           tree args, tree callee_commons,
1693                           bool scalar_args)
1694 {
1695   tree arg;
1696   tree dest_decl;
1697   tree dest_offset;
1698   tree dest_size;
1699
1700   ffecom_tree_canonize_ref_ (&dest_decl, &dest_offset, &dest_size,
1701                              dest_tree);
1702
1703   if (dest_decl == NULL_TREE)
1704     return FALSE;               /* Seems unlikely! */
1705
1706   /* If the decl cannot be determined reliably, or if its in COMMON
1707      and the callee isn't known to not futz with COMMON via other
1708      means, overlap might happen.  */
1709
1710   if ((TREE_CODE (dest_decl) == ERROR_MARK)
1711       || ((callee_commons != NULL_TREE)
1712           && TREE_PUBLIC (dest_decl)))
1713     return TRUE;
1714
1715   for (; args != NULL_TREE; args = TREE_CHAIN (args))
1716     {
1717       if (((arg = TREE_VALUE (args)) != NULL_TREE)
1718           && ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1719                               arg, NULL, scalar_args))
1720         return TRUE;
1721     }
1722
1723   return FALSE;
1724 }
1725
1726 /* Build a string for a variable name as used by NAMELIST.  This means that
1727    if we're using the f2c library, we build an uppercase string, since
1728    f2c does this.  */
1729
1730 static tree
1731 ffecom_build_f2c_string_ (int i, const char *s)
1732 {
1733   if (!ffe_is_f2c_library ())
1734     return build_string (i, s);
1735
1736   {
1737     char *tmp;
1738     const char *p;
1739     char *q;
1740     char space[34];
1741     tree t;
1742
1743     if (((size_t) i) > ARRAY_SIZE (space))
1744       tmp = malloc_new_ks (malloc_pool_image (), "f2c_string", i);
1745     else
1746       tmp = &space[0];
1747
1748     for (p = s, q = tmp; *p != '\0'; ++p, ++q)
1749       *q = TOUPPER (*p);
1750     *q = '\0';
1751
1752     t = build_string (i, tmp);
1753
1754     if (((size_t) i) > ARRAY_SIZE (space))
1755       malloc_kill_ks (malloc_pool_image (), tmp, i);
1756
1757     return t;
1758   }
1759 }
1760
1761 /* Returns CALL_EXPR or equivalent with given type (pass NULL_TREE for
1762    type to just get whatever the function returns), handling the
1763    f2c value-returning convention, if required, by prepending
1764    to the arglist a pointer to a temporary to receive the return value.  */
1765
1766 static tree
1767 ffecom_call_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1768               tree type, tree args, tree dest_tree,
1769               ffebld dest, bool *dest_used, tree callee_commons,
1770               bool scalar_args, tree hook)
1771 {
1772   tree item;
1773   tree tempvar;
1774
1775   if (dest_used != NULL)
1776     *dest_used = FALSE;
1777
1778   if (is_f2c_complex)
1779     {
1780       if ((dest_used == NULL)
1781           || (dest == NULL)
1782           || (ffeinfo_basictype (ffebld_info (dest))
1783               != FFEINFO_basictypeCOMPLEX)
1784           || (ffeinfo_kindtype (ffebld_info (dest)) != kt)
1785           || ((type != NULL_TREE) && (TREE_TYPE (dest_tree) != type))
1786           || ffecom_args_overlapping_ (dest_tree, dest, args,
1787                                        callee_commons,
1788                                        scalar_args))
1789         {
1790 #ifdef HOHO
1791           tempvar = ffecom_make_tempvar (ffecom_tree_type
1792                                          [FFEINFO_basictypeCOMPLEX][kt],
1793                                          FFETARGET_charactersizeNONE,
1794                                          -1);
1795 #else
1796           tempvar = hook;
1797           assert (tempvar);
1798 #endif
1799         }
1800       else
1801         {
1802           *dest_used = TRUE;
1803           tempvar = dest_tree;
1804           type = NULL_TREE;
1805         }
1806
1807       item
1808         = build_tree_list (NULL_TREE,
1809                            ffecom_1 (ADDR_EXPR,
1810                                      build_pointer_type (TREE_TYPE (tempvar)),
1811                                      tempvar));
1812       TREE_CHAIN (item) = args;
1813
1814       item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1815                         item, NULL_TREE);
1816
1817       if (tempvar != dest_tree)
1818         item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item, tempvar);
1819     }
1820   else
1821     item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1822                       args, NULL_TREE);
1823
1824   if ((type != NULL_TREE) && (TREE_TYPE (item) != type))
1825     item = ffecom_convert_narrow_ (type, item);
1826
1827   return item;
1828 }
1829
1830 /* Given two arguments, transform them and make a call to the given
1831    function via ffecom_call_.  */
1832
1833 static tree
1834 ffecom_call_binop_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1835                     tree type, ffebld left, ffebld right,
1836                     tree dest_tree, ffebld dest, bool *dest_used,
1837                     tree callee_commons, bool scalar_args, bool ref, tree hook)
1838 {
1839   tree left_tree;
1840   tree right_tree;
1841   tree left_length;
1842   tree right_length;
1843
1844   if (ref)
1845     {
1846       /* Pass arguments by reference.  */
1847       left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
1848       right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
1849     }
1850   else
1851     {
1852       /* Pass arguments by value.  */
1853       left_tree = ffecom_arg_expr (left, &left_length);
1854       right_tree = ffecom_arg_expr (right, &right_length);
1855     }
1856
1857
1858   left_tree = build_tree_list (NULL_TREE, left_tree);
1859   right_tree = build_tree_list (NULL_TREE, right_tree);
1860   TREE_CHAIN (left_tree) = right_tree;
1861
1862   if (left_length != NULL_TREE)
1863     {
1864       left_length = build_tree_list (NULL_TREE, left_length);
1865       TREE_CHAIN (right_tree) = left_length;
1866     }
1867
1868   if (right_length != NULL_TREE)
1869     {
1870       right_length = build_tree_list (NULL_TREE, right_length);
1871       if (left_length != NULL_TREE)
1872         TREE_CHAIN (left_length) = right_length;
1873       else
1874         TREE_CHAIN (right_tree) = right_length;
1875     }
1876
1877   return ffecom_call_ (fn, kt, is_f2c_complex, type, left_tree,
1878                        dest_tree, dest, dest_used, callee_commons,
1879                        scalar_args, hook);
1880 }
1881
1882 /* Return ptr/length args for char subexpression
1883
1884    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
1885    subexpressions by constructing the appropriate trees for the ptr-to-
1886    character-text and length-of-character-text arguments in a calling
1887    sequence.
1888
1889    Note that if with_null is TRUE, and the expression is an opCONTER,
1890    a null byte is appended to the string.  */
1891
1892 static void
1893 ffecom_char_args_x_ (tree *xitem, tree *length, ffebld expr, bool with_null)
1894 {
1895   tree item;
1896   tree high;
1897   ffetargetCharacter1 val;
1898   ffetargetCharacterSize newlen;
1899
1900   switch (ffebld_op (expr))
1901     {
1902     case FFEBLD_opCONTER:
1903       val = ffebld_constant_character1 (ffebld_conter (expr));
1904       newlen = ffetarget_length_character1 (val);
1905       if (with_null)
1906         {
1907           /* Begin FFETARGET-NULL-KLUDGE.  */
1908           if (newlen != 0)
1909             ++newlen;
1910         }
1911       *length = build_int_2 (newlen, 0);
1912       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
1913       high = build_int_2 (newlen, 0);
1914       TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
1915       item = build_string (newlen,
1916                            ffetarget_text_character1 (val));
1917       /* End FFETARGET-NULL-KLUDGE.  */
1918       TREE_TYPE (item)
1919         = build_type_variant
1920           (build_array_type
1921            (char_type_node,
1922             build_range_type
1923             (ffecom_f2c_ftnlen_type_node,
1924              ffecom_f2c_ftnlen_one_node,
1925              high)),
1926            1, 0);
1927       TREE_CONSTANT (item) = 1;
1928       TREE_STATIC (item) = 1;
1929       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
1930                        item);
1931       break;
1932
1933     case FFEBLD_opSYMTER:
1934       {
1935         ffesymbol s = ffebld_symter (expr);
1936
1937         item = ffesymbol_hook (s).decl_tree;
1938         if (item == NULL_TREE)
1939           {
1940             s = ffecom_sym_transform_ (s);
1941             item = ffesymbol_hook (s).decl_tree;
1942           }
1943         if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
1944           {
1945             if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
1946               *length = ffesymbol_hook (s).length_tree;
1947             else
1948               {
1949                 *length = build_int_2 (ffesymbol_size (s), 0);
1950                 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
1951               }
1952           }
1953         else if (item == error_mark_node)
1954           *length = error_mark_node;
1955         else
1956           /* FFEINFO_kindFUNCTION.  */
1957           *length = NULL_TREE;
1958         if (!ffesymbol_hook (s).addr
1959             && (item != error_mark_node))
1960           item = ffecom_1 (ADDR_EXPR,
1961                            build_pointer_type (TREE_TYPE (item)),
1962                            item);
1963       }
1964       break;
1965
1966     case FFEBLD_opARRAYREF:
1967       {
1968         ffecom_char_args_ (&item, length, ffebld_left (expr));
1969
1970         if (item == error_mark_node || *length == error_mark_node)
1971           {
1972             item = *length = error_mark_node;
1973             break;
1974           }
1975
1976         item = ffecom_arrayref_ (item, expr, 1);
1977       }
1978       break;
1979
1980     case FFEBLD_opSUBSTR:
1981       {
1982         ffebld start;
1983         ffebld end;
1984         ffebld thing = ffebld_right (expr);
1985         tree start_tree;
1986         tree end_tree;
1987         const char *char_name;
1988         ffebld left_symter;
1989         tree array;
1990
1991         assert (ffebld_op (thing) == FFEBLD_opITEM);
1992         start = ffebld_head (thing);
1993         thing = ffebld_trail (thing);
1994         assert (ffebld_trail (thing) == NULL);
1995         end = ffebld_head (thing);
1996
1997         /* Determine name for pretty-printing range-check errors.  */
1998         for (left_symter = ffebld_left (expr);
1999              left_symter && ffebld_op (left_symter) == FFEBLD_opARRAYREF;
2000              left_symter = ffebld_left (left_symter))
2001           ;
2002         if (ffebld_op (left_symter) == FFEBLD_opSYMTER)
2003           char_name = ffesymbol_text (ffebld_symter (left_symter));
2004         else
2005           char_name = "[expr?]";
2006
2007         ffecom_char_args_ (&item, length, ffebld_left (expr));
2008
2009         if (item == error_mark_node || *length == error_mark_node)
2010           {
2011             item = *length = error_mark_node;
2012             break;
2013           }
2014
2015         array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
2016
2017         /* ~~~~Handle INTEGER*8 start/end, a la FFEBLD_opARRAYREF.  */
2018
2019         if (start == NULL)
2020           {
2021             if (end == NULL)
2022               ;
2023             else
2024               {
2025                 end_tree = ffecom_expr (end);
2026                 if (flag_bounds_check)
2027                   end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2028                                                       char_name);
2029                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2030                                     end_tree);
2031
2032                 if (end_tree == error_mark_node)
2033                   {
2034                     item = *length = error_mark_node;
2035                     break;
2036                   }
2037
2038                 *length = end_tree;
2039               }
2040           }
2041         else
2042           {
2043             start_tree = ffecom_expr (start);
2044             if (flag_bounds_check)
2045               start_tree = ffecom_subscript_check_ (array, start_tree, 0, 0,
2046                                                     char_name);
2047             start_tree = convert (ffecom_f2c_ftnlen_type_node,
2048                                   start_tree);
2049
2050             if (start_tree == error_mark_node)
2051               {
2052                 item = *length = error_mark_node;
2053                 break;
2054               }
2055
2056             start_tree = ffecom_save_tree (start_tree);
2057
2058             item = ffecom_2 (PLUS_EXPR, TREE_TYPE (item),
2059                              item,
2060                              ffecom_2 (MINUS_EXPR,
2061                                        TREE_TYPE (start_tree),
2062                                        start_tree,
2063                                        ffecom_f2c_ftnlen_one_node));
2064
2065             if (end == NULL)
2066               {
2067                 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2068                                     ffecom_f2c_ftnlen_one_node,
2069                                     ffecom_2 (MINUS_EXPR,
2070                                               ffecom_f2c_ftnlen_type_node,
2071                                               *length,
2072                                               start_tree));
2073               }
2074             else
2075               {
2076                 end_tree = ffecom_expr (end);
2077                 if (flag_bounds_check)
2078                   end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2079                                                       char_name);
2080                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2081                                     end_tree);
2082
2083                 if (end_tree == error_mark_node)
2084                   {
2085                     item = *length = error_mark_node;
2086                     break;
2087                   }
2088
2089                 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2090                                     ffecom_f2c_ftnlen_one_node,
2091                                     ffecom_2 (MINUS_EXPR,
2092                                               ffecom_f2c_ftnlen_type_node,
2093                                               end_tree, start_tree));
2094               }
2095           }
2096       }
2097       break;
2098
2099     case FFEBLD_opFUNCREF:
2100       {
2101         ffesymbol s = ffebld_symter (ffebld_left (expr));
2102         tree tempvar;
2103         tree args;
2104         ffetargetCharacterSize size = ffeinfo_size (ffebld_info (expr));
2105         ffecomGfrt ix;
2106
2107         if (size == FFETARGET_charactersizeNONE)
2108           /* ~~Kludge alert!  This should someday be fixed. */
2109           size = 24;
2110
2111         *length = build_int_2 (size, 0);
2112         TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2113
2114         if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
2115             == FFEINFO_whereINTRINSIC)
2116           {
2117             if (size == 1)
2118               {
2119                 /* Invocation of an intrinsic returning CHARACTER*1.  */
2120                 item = ffecom_expr_intrinsic_ (expr, NULL_TREE,
2121                                                NULL, NULL);
2122                 break;
2123               }
2124             ix = ffeintrin_gfrt_direct (ffebld_symter_implementation (ffebld_left (expr)));
2125             assert (ix != FFECOM_gfrt);
2126             item = ffecom_gfrt_tree_ (ix);
2127           }
2128         else
2129           {
2130             ix = FFECOM_gfrt;
2131             item = ffesymbol_hook (s).decl_tree;
2132             if (item == NULL_TREE)
2133               {
2134                 s = ffecom_sym_transform_ (s);
2135                 item = ffesymbol_hook (s).decl_tree;
2136               }
2137             if (item == error_mark_node)
2138               {
2139                 item = *length = error_mark_node;
2140                 break;
2141               }
2142
2143             if (!ffesymbol_hook (s).addr)
2144               item = ffecom_1_fn (item);
2145           }
2146
2147 #ifdef HOHO
2148         tempvar = ffecom_push_tempvar (char_type_node, size, -1, TRUE);
2149 #else
2150         tempvar = ffebld_nonter_hook (expr);
2151         assert (tempvar);
2152 #endif
2153         tempvar = ffecom_1 (ADDR_EXPR,
2154                             build_pointer_type (TREE_TYPE (tempvar)),
2155                             tempvar);
2156
2157         args = build_tree_list (NULL_TREE, tempvar);
2158
2159         if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)       /* Sfunc args by value. */
2160           TREE_CHAIN (args) = ffecom_list_expr (ffebld_right (expr));
2161         else
2162           {
2163             TREE_CHAIN (args) = build_tree_list (NULL_TREE, *length);
2164             if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
2165               {
2166                 TREE_CHAIN (TREE_CHAIN (args))
2167                   = ffecom_arglist_expr_ (ffecom_gfrt_args_ (ix),
2168                                           ffebld_right (expr));
2169               }
2170             else
2171               {
2172                 TREE_CHAIN (TREE_CHAIN (args))
2173                   = ffecom_list_ptr_to_expr (ffebld_right (expr));
2174               }
2175           }
2176
2177         item = ffecom_3s (CALL_EXPR,
2178                           TREE_TYPE (TREE_TYPE (TREE_TYPE (item))),
2179                           item, args, NULL_TREE);
2180         item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item,
2181                          tempvar);
2182       }
2183       break;
2184
2185     case FFEBLD_opCONVERT:
2186
2187       ffecom_char_args_ (&item, length, ffebld_left (expr));
2188
2189       if (item == error_mark_node || *length == error_mark_node)
2190         {
2191           item = *length = error_mark_node;
2192           break;
2193         }
2194
2195       if ((ffebld_size_known (ffebld_left (expr))
2196            == FFETARGET_charactersizeNONE)
2197           || (ffebld_size_known (ffebld_left (expr)) < (ffebld_size (expr))))
2198         {                       /* Possible blank-padding needed, copy into
2199                                    temporary. */
2200           tree tempvar;
2201           tree args;
2202           tree newlen;
2203
2204 #ifdef HOHO
2205           tempvar = ffecom_make_tempvar (char_type_node,
2206                                          ffebld_size (expr), -1);
2207 #else
2208           tempvar = ffebld_nonter_hook (expr);
2209           assert (tempvar);
2210 #endif
2211           tempvar = ffecom_1 (ADDR_EXPR,
2212                               build_pointer_type (TREE_TYPE (tempvar)),
2213                               tempvar);
2214
2215           newlen = build_int_2 (ffebld_size (expr), 0);
2216           TREE_TYPE (newlen) = ffecom_f2c_ftnlen_type_node;
2217
2218           args = build_tree_list (NULL_TREE, tempvar);
2219           TREE_CHAIN (args) = build_tree_list (NULL_TREE, item);
2220           TREE_CHAIN (TREE_CHAIN (args)) = build_tree_list (NULL_TREE, newlen);
2221           TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (args)))
2222             = build_tree_list (NULL_TREE, *length);
2223
2224           item = ffecom_call_gfrt (FFECOM_gfrtCOPY, args, NULL_TREE);
2225           TREE_SIDE_EFFECTS (item) = 1;
2226           item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), fold (item),
2227                            tempvar);
2228           *length = newlen;
2229         }
2230       else
2231         {                       /* Just truncate the length. */
2232           *length = build_int_2 (ffebld_size (expr), 0);
2233           TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2234         }
2235       break;
2236
2237     default:
2238       assert ("bad op for single char arg expr" == NULL);
2239       item = NULL_TREE;
2240       break;
2241     }
2242
2243   *xitem = item;
2244 }
2245
2246 /* Check the size of the type to be sure it doesn't overflow the
2247    "portable" capacities of the compiler back end.  `dummy' types
2248    can generally overflow the normal sizes as long as the computations
2249    themselves don't overflow.  A particular target of the back end
2250    must still enforce its size requirements, though, and the back
2251    end takes care of this in stor-layout.c.  */
2252
2253 static tree
2254 ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy)
2255 {
2256   if (TREE_CODE (type) == ERROR_MARK)
2257     return type;
2258
2259   if (TYPE_SIZE (type) == NULL_TREE)
2260     return type;
2261
2262   if (TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST)
2263     return type;
2264
2265   if ((tree_int_cst_sgn (TYPE_SIZE (type)) < 0)
2266       || (!dummy && TREE_OVERFLOW (TYPE_SIZE (type))))
2267     {
2268       ffebad_start (FFEBAD_ARRAY_LARGE);
2269       ffebad_string (ffesymbol_text (s));
2270       ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s));
2271       ffebad_finish ();
2272
2273       return error_mark_node;
2274     }
2275
2276   return type;
2277 }
2278
2279 /* Builds a length argument (PARM_DECL).  Also wraps type in an array type
2280    where the dimension info is (1:size) where <size> is ffesymbol_size(s) if
2281    known, length_arg if not known (FFETARGET_charactersizeNONE).  */
2282
2283 static tree
2284 ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s)
2285 {
2286   ffetargetCharacterSize sz = ffesymbol_size (s);
2287   tree highval;
2288   tree tlen;
2289   tree type = *xtype;
2290
2291   if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
2292     tlen = NULL_TREE;           /* A statement function, no length passed. */
2293   else
2294     {
2295       if (ffesymbol_where (s) == FFEINFO_whereDUMMY)
2296         tlen = ffecom_get_invented_identifier ("__g77_length_%s",
2297                                                ffesymbol_text (s));
2298       else
2299         tlen = ffecom_get_invented_identifier ("__g77_%s", "length");
2300       tlen = build_decl (PARM_DECL, tlen, ffecom_f2c_ftnlen_type_node);
2301       DECL_ARTIFICIAL (tlen) = 1;
2302     }
2303
2304   if (sz == FFETARGET_charactersizeNONE)
2305     {
2306       assert (tlen != NULL_TREE);
2307       highval = variable_size (tlen);
2308     }
2309   else
2310     {
2311       highval = build_int_2 (sz, 0);
2312       TREE_TYPE (highval) = ffecom_f2c_ftnlen_type_node;
2313     }
2314
2315   type = build_array_type (type,
2316                            build_range_type (ffecom_f2c_ftnlen_type_node,
2317                                              ffecom_f2c_ftnlen_one_node,
2318                                              highval));
2319
2320   *xtype = type;
2321   return tlen;
2322 }
2323
2324 /* ffecom_concat_list_gather_ -- Gather list of concatenated string exprs
2325
2326    ffecomConcatList_ catlist;
2327    ffebld expr;  // expr of CHARACTER basictype.
2328    ffetargetCharacterSize max;  // max chars to gather or _...NONE if no max
2329    catlist = ffecom_concat_list_gather_(catlist,expr,max);
2330
2331    Scans expr for character subexpressions, updates and returns catlist
2332    accordingly.  */
2333
2334 static ffecomConcatList_
2335 ffecom_concat_list_gather_ (ffecomConcatList_ catlist, ffebld expr,
2336                             ffetargetCharacterSize max)
2337 {
2338   ffetargetCharacterSize sz;
2339
2340  recurse:
2341
2342   if (expr == NULL)
2343     return catlist;
2344
2345   if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen >= max))
2346     return catlist;             /* Don't append any more items. */
2347
2348   switch (ffebld_op (expr))
2349     {
2350     case FFEBLD_opCONTER:
2351     case FFEBLD_opSYMTER:
2352     case FFEBLD_opARRAYREF:
2353     case FFEBLD_opFUNCREF:
2354     case FFEBLD_opSUBSTR:
2355     case FFEBLD_opCONVERT:      /* Callers should strip this off beforehand
2356                                    if they don't need to preserve it. */
2357       if (catlist.count == catlist.max)
2358         {                       /* Make a (larger) list. */
2359           ffebld *newx;
2360           int newmax;
2361
2362           newmax = (catlist.max == 0) ? 8 : catlist.max * 2;
2363           newx = malloc_new_ks (malloc_pool_image (), "catlist",
2364                                 newmax * sizeof (newx[0]));
2365           if (catlist.max != 0)
2366             {
2367               memcpy (newx, catlist.exprs, catlist.max * sizeof (newx[0]));
2368               malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2369                               catlist.max * sizeof (newx[0]));
2370             }
2371           catlist.max = newmax;
2372           catlist.exprs = newx;
2373         }
2374       if ((sz = ffebld_size_known (expr)) != FFETARGET_charactersizeNONE)
2375         catlist.minlen += sz;
2376       else
2377         ++catlist.minlen;       /* Not true for F90; can be 0 length. */
2378       if ((sz = ffebld_size_max (expr)) == FFETARGET_charactersizeNONE)
2379         catlist.maxlen = sz;
2380       else
2381         catlist.maxlen += sz;
2382       if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen > max))
2383         {                       /* This item overlaps (or is beyond) the end
2384                                    of the destination. */
2385           switch (ffebld_op (expr))
2386             {
2387             case FFEBLD_opCONTER:
2388             case FFEBLD_opSYMTER:
2389             case FFEBLD_opARRAYREF:
2390             case FFEBLD_opFUNCREF:
2391             case FFEBLD_opSUBSTR:
2392               /* ~~Do useful truncations here. */
2393               break;
2394
2395             default:
2396               assert ("op changed or inconsistent switches!" == NULL);
2397               break;
2398             }
2399         }
2400       catlist.exprs[catlist.count++] = expr;
2401       return catlist;
2402
2403     case FFEBLD_opPAREN:
2404       expr = ffebld_left (expr);
2405       goto recurse;             /* :::::::::::::::::::: */
2406
2407     case FFEBLD_opCONCATENATE:
2408       catlist = ffecom_concat_list_gather_ (catlist, ffebld_left (expr), max);
2409       expr = ffebld_right (expr);
2410       goto recurse;             /* :::::::::::::::::::: */
2411
2412 #if 0                           /* Breaks passing small actual arg to larger
2413                                    dummy arg of sfunc */
2414     case FFEBLD_opCONVERT:
2415       expr = ffebld_left (expr);
2416       {
2417         ffetargetCharacterSize cmax;
2418
2419         cmax = catlist.len + ffebld_size_known (expr);
2420
2421         if ((max == FFETARGET_charactersizeNONE) || (max > cmax))
2422           max = cmax;
2423       }
2424       goto recurse;             /* :::::::::::::::::::: */
2425 #endif
2426
2427     case FFEBLD_opANY:
2428       return catlist;
2429
2430     default:
2431       assert ("bad op in _gather_" == NULL);
2432       return catlist;
2433     }
2434 }
2435
2436 /* ffecom_concat_list_kill_ -- Kill list of concatenated string exprs
2437
2438    ffecomConcatList_ catlist;
2439    ffecom_concat_list_kill_(catlist);
2440
2441    Anything allocated within the list info is deallocated.  */
2442
2443 static void
2444 ffecom_concat_list_kill_ (ffecomConcatList_ catlist)
2445 {
2446   if (catlist.max != 0)
2447     malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2448                     catlist.max * sizeof (catlist.exprs[0]));
2449 }
2450
2451 /* Make list of concatenated string exprs.
2452
2453    Returns a flattened list of concatenated subexpressions given a
2454    tree of such expressions.  */
2455
2456 static ffecomConcatList_
2457 ffecom_concat_list_new_ (ffebld expr, ffetargetCharacterSize max)
2458 {
2459   ffecomConcatList_ catlist;
2460
2461   catlist.maxlen = catlist.minlen = catlist.max = catlist.count = 0;
2462   return ffecom_concat_list_gather_ (catlist, expr, max);
2463 }
2464
2465 /* Provide some kind of useful info on member of aggregate area,
2466    since current g77/gcc technology does not provide debug info
2467    on these members.  */
2468
2469 static void
2470 ffecom_debug_kludge_ (tree aggr, const char *aggr_type, ffesymbol member,
2471                       tree member_type UNUSED, ffetargetOffset offset)
2472 {
2473   tree value;
2474   tree decl;
2475   int len;
2476   char *buff;
2477   char space[120];
2478 #if 0
2479   tree type_id;
2480
2481   for (type_id = member_type;
2482        TREE_CODE (type_id) != IDENTIFIER_NODE;
2483        )
2484     {
2485       switch (TREE_CODE (type_id))
2486         {
2487         case INTEGER_TYPE:
2488         case REAL_TYPE:
2489           type_id = TYPE_NAME (type_id);
2490           break;
2491
2492         case ARRAY_TYPE:
2493         case COMPLEX_TYPE:
2494           type_id = TREE_TYPE (type_id);
2495           break;
2496
2497         default:
2498           assert ("no IDENTIFIER_NODE for type!" == NULL);
2499           type_id = error_mark_node;
2500           break;
2501         }
2502     }
2503 #endif
2504
2505   if (ffecom_transform_only_dummies_
2506       || !ffe_is_debug_kludge ())
2507     return;     /* Can't do this yet, maybe later. */
2508
2509   len = 60
2510     + strlen (aggr_type)
2511     + IDENTIFIER_LENGTH (DECL_NAME (aggr));
2512 #if 0
2513     + IDENTIFIER_LENGTH (type_id);
2514 #endif
2515
2516   if (((size_t) len) >= ARRAY_SIZE (space))
2517     buff = malloc_new_ks (malloc_pool_image (), "debug_kludge", len + 1);
2518   else
2519     buff = &space[0];
2520
2521   sprintf (&buff[0], "At (%s) `%s' plus %ld bytes",
2522            aggr_type,
2523            IDENTIFIER_POINTER (DECL_NAME (aggr)),
2524            (long int) offset);
2525
2526   value = build_string (len, buff);
2527   TREE_TYPE (value)
2528     = build_type_variant (build_array_type (char_type_node,
2529                                             build_range_type
2530                                             (integer_type_node,
2531                                              integer_one_node,
2532                                              build_int_2 (strlen (buff), 0))),
2533                           1, 0);
2534   decl = build_decl (VAR_DECL,
2535                      ffecom_get_identifier_ (ffesymbol_text (member)),
2536                      TREE_TYPE (value));
2537   TREE_CONSTANT (decl) = 1;
2538   TREE_STATIC (decl) = 1;
2539   DECL_INITIAL (decl) = error_mark_node;
2540   DECL_IN_SYSTEM_HEADER (decl) = 1;     /* Don't let -Wunused complain. */
2541   decl = start_decl (decl, FALSE);
2542   finish_decl (decl, value, FALSE);
2543
2544   if (buff != &space[0])
2545     malloc_kill_ks (malloc_pool_image (), buff, len + 1);
2546 }
2547
2548 /* ffecom_do_entry_ -- Do compilation of a particular entrypoint
2549
2550    ffesymbol fn;  // the SUBROUTINE, FUNCTION, or ENTRY symbol itself
2551    int i;  // entry# for this entrypoint (used by master fn)
2552    ffecom_do_entrypoint_(s,i);
2553
2554    Makes a public entry point that calls our private master fn (already
2555    compiled).  */
2556
2557 static void
2558 ffecom_do_entry_ (ffesymbol fn, int entrynum)
2559 {
2560   ffebld item;
2561   tree type;                    /* Type of function. */
2562   tree multi_retval;            /* Var holding return value (union). */
2563   tree result;                  /* Var holding result. */
2564   ffeinfoBasictype bt;
2565   ffeinfoKindtype kt;
2566   ffeglobal g;
2567   ffeglobalType gt;
2568   bool charfunc;                /* All entry points return same type
2569                                    CHARACTER. */
2570   bool cmplxfunc;               /* Use f2c way of returning COMPLEX. */
2571   bool multi;                   /* Master fn has multiple return types. */
2572   bool altreturning = FALSE;    /* This entry point has alternate returns. */
2573   int old_lineno = lineno;
2574   const char *old_input_filename = input_filename;
2575
2576   input_filename = ffesymbol_where_filename (fn);
2577   lineno = ffesymbol_where_filelinenum (fn);
2578
2579   ffecom_doing_entry_ = TRUE;   /* Don't bother with array dimensions. */
2580
2581   switch (ffecom_primary_entry_kind_)
2582     {
2583     case FFEINFO_kindFUNCTION:
2584
2585       /* Determine actual return type for function. */
2586
2587       gt = FFEGLOBAL_typeFUNC;
2588       bt = ffesymbol_basictype (fn);
2589       kt = ffesymbol_kindtype (fn);
2590       if (bt == FFEINFO_basictypeNONE)
2591         {
2592           ffeimplic_establish_symbol (fn);
2593           if (ffesymbol_funcresult (fn) != NULL)
2594             ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
2595           bt = ffesymbol_basictype (fn);
2596           kt = ffesymbol_kindtype (fn);
2597         }
2598
2599       if (bt == FFEINFO_basictypeCHARACTER)
2600         charfunc = TRUE, cmplxfunc = FALSE;
2601       else if ((bt == FFEINFO_basictypeCOMPLEX)
2602                && ffesymbol_is_f2c (fn))
2603         charfunc = FALSE, cmplxfunc = TRUE;
2604       else
2605         charfunc = cmplxfunc = FALSE;
2606
2607       if (charfunc)
2608         type = ffecom_tree_fun_type_void;
2609       else if (ffesymbol_is_f2c (fn))
2610         type = ffecom_tree_fun_type[bt][kt];
2611       else
2612         type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
2613
2614       if ((type == NULL_TREE)
2615           || (TREE_TYPE (type) == NULL_TREE))
2616         type = ffecom_tree_fun_type_void;       /* _sym_exec_transition. */
2617
2618       multi = (ffecom_master_bt_ == FFEINFO_basictypeNONE);
2619       break;
2620
2621     case FFEINFO_kindSUBROUTINE:
2622       gt = FFEGLOBAL_typeSUBR;
2623       bt = FFEINFO_basictypeNONE;
2624       kt = FFEINFO_kindtypeNONE;
2625       if (ffecom_is_altreturning_)
2626         {                       /* Am _I_ altreturning? */
2627           for (item = ffesymbol_dummyargs (fn);
2628                item != NULL;
2629                item = ffebld_trail (item))
2630             {
2631               if (ffebld_op (ffebld_head (item)) == FFEBLD_opSTAR)
2632                 {
2633                   altreturning = TRUE;
2634                   break;
2635                 }
2636             }
2637           if (altreturning)
2638             type = ffecom_tree_subr_type;
2639           else
2640             type = ffecom_tree_fun_type_void;
2641         }
2642       else
2643         type = ffecom_tree_fun_type_void;
2644       charfunc = FALSE;
2645       cmplxfunc = FALSE;
2646       multi = FALSE;
2647       break;
2648
2649     default:
2650       assert ("say what??" == NULL);
2651       /* Fall through. */
2652     case FFEINFO_kindANY:
2653       gt = FFEGLOBAL_typeANY;
2654       bt = FFEINFO_basictypeNONE;
2655       kt = FFEINFO_kindtypeNONE;
2656       type = error_mark_node;
2657       charfunc = FALSE;
2658       cmplxfunc = FALSE;
2659       multi = FALSE;
2660       break;
2661     }
2662
2663   /* build_decl uses the current lineno and input_filename to set the decl
2664      source info.  So, I've putzed with ffestd and ffeste code to update that
2665      source info to point to the appropriate statement just before calling
2666      ffecom_do_entrypoint (which calls this fn).  */
2667
2668   start_function (ffecom_get_external_identifier_ (fn),
2669                   type,
2670                   0,            /* nested/inline */
2671                   1);           /* TREE_PUBLIC */
2672
2673   if (((g = ffesymbol_global (fn)) != NULL)
2674       && ((ffeglobal_type (g) == gt)
2675           || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
2676     {
2677       ffeglobal_set_hook (g, current_function_decl);
2678     }
2679
2680   /* Reset args in master arg list so they get retransitioned. */
2681
2682   for (item = ffecom_master_arglist_;
2683        item != NULL;
2684        item = ffebld_trail (item))
2685     {
2686       ffebld arg;
2687       ffesymbol s;
2688
2689       arg = ffebld_head (item);
2690       if (ffebld_op (arg) != FFEBLD_opSYMTER)
2691         continue;               /* Alternate return or some such thing. */
2692       s = ffebld_symter (arg);
2693       ffesymbol_hook (s).decl_tree = NULL_TREE;
2694       ffesymbol_hook (s).length_tree = NULL_TREE;
2695     }
2696
2697   /* Build dummy arg list for this entry point. */
2698
2699   if (charfunc || cmplxfunc)
2700     {                           /* Prepend arg for where result goes. */
2701       tree type;
2702       tree length;
2703
2704       if (charfunc)
2705         type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
2706       else
2707         type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
2708
2709       result = ffecom_get_invented_identifier ("__g77_%s", "result");
2710
2711       /* Make length arg _and_ enhance type info for CHAR arg itself.  */
2712
2713       if (charfunc)
2714         length = ffecom_char_enhance_arg_ (&type, fn);
2715       else
2716         length = NULL_TREE;     /* Not ref'd if !charfunc. */
2717
2718       type = build_pointer_type (type);
2719       result = build_decl (PARM_DECL, result, type);
2720
2721       push_parm_decl (result);
2722       ffecom_func_result_ = result;
2723
2724       if (charfunc)
2725         {
2726           push_parm_decl (length);
2727           ffecom_func_length_ = length;
2728         }
2729     }
2730   else
2731     result = DECL_RESULT (current_function_decl);
2732
2733   ffecom_push_dummy_decls_ (ffesymbol_dummyargs (fn), FALSE);
2734
2735   store_parm_decls (0);
2736
2737   ffecom_start_compstmt ();
2738   /* Disallow temp vars at this level.  */
2739   current_binding_level->prep_state = 2;
2740
2741   /* Make local var to hold return type for multi-type master fn. */
2742
2743   if (multi)
2744     {
2745       multi_retval = ffecom_get_invented_identifier ("__g77_%s",
2746                                                      "multi_retval");
2747       multi_retval = build_decl (VAR_DECL, multi_retval,
2748                                  ffecom_multi_type_node_);
2749       multi_retval = start_decl (multi_retval, FALSE);
2750       finish_decl (multi_retval, NULL_TREE, FALSE);
2751     }
2752   else
2753     multi_retval = NULL_TREE;   /* Not actually ref'd if !multi. */
2754
2755   /* Here we emit the actual code for the entry point. */
2756
2757   {
2758     ffebld list;
2759     ffebld arg;
2760     ffesymbol s;
2761     tree arglist = NULL_TREE;
2762     tree *plist = &arglist;
2763     tree prepend;
2764     tree call;
2765     tree actarg;
2766     tree master_fn;
2767
2768     /* Prepare actual arg list based on master arg list. */
2769
2770     for (list = ffecom_master_arglist_;
2771          list != NULL;
2772          list = ffebld_trail (list))
2773       {
2774         arg = ffebld_head (list);
2775         if (ffebld_op (arg) != FFEBLD_opSYMTER)
2776           continue;
2777         s = ffebld_symter (arg);
2778         if (ffesymbol_hook (s).decl_tree == NULL_TREE
2779             || ffesymbol_hook (s).decl_tree == error_mark_node)
2780           actarg = null_pointer_node;   /* We don't have this arg. */
2781         else
2782           actarg = ffesymbol_hook (s).decl_tree;
2783         *plist = build_tree_list (NULL_TREE, actarg);
2784         plist = &TREE_CHAIN (*plist);
2785       }
2786
2787     /* This code appends the length arguments for character
2788        variables/arrays.  */
2789
2790     for (list = ffecom_master_arglist_;
2791          list != NULL;
2792          list = ffebld_trail (list))
2793       {
2794         arg = ffebld_head (list);
2795         if (ffebld_op (arg) != FFEBLD_opSYMTER)
2796           continue;
2797         s = ffebld_symter (arg);
2798         if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
2799           continue;             /* Only looking for CHARACTER arguments. */
2800         if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
2801           continue;             /* Only looking for variables and arrays. */
2802         if (ffesymbol_hook (s).length_tree == NULL_TREE
2803             || ffesymbol_hook (s).length_tree == error_mark_node)
2804           actarg = ffecom_f2c_ftnlen_zero_node; /* We don't have this arg. */
2805         else
2806           actarg = ffesymbol_hook (s).length_tree;
2807         *plist = build_tree_list (NULL_TREE, actarg);
2808         plist = &TREE_CHAIN (*plist);
2809       }
2810
2811     /* Prepend character-value return info to actual arg list. */
2812
2813     if (charfunc)
2814       {
2815         prepend = build_tree_list (NULL_TREE, ffecom_func_result_);
2816         TREE_CHAIN (prepend)
2817           = build_tree_list (NULL_TREE, ffecom_func_length_);
2818         TREE_CHAIN (TREE_CHAIN (prepend)) = arglist;
2819         arglist = prepend;
2820       }
2821
2822     /* Prepend multi-type return value to actual arg list. */
2823
2824     if (multi)
2825       {
2826         prepend
2827           = build_tree_list (NULL_TREE,
2828                              ffecom_1 (ADDR_EXPR,
2829                               build_pointer_type (TREE_TYPE (multi_retval)),
2830                                        multi_retval));
2831         TREE_CHAIN (prepend) = arglist;
2832         arglist = prepend;
2833       }
2834
2835     /* Prepend my entry-point number to the actual arg list. */
2836
2837     prepend = build_tree_list (NULL_TREE, build_int_2 (entrynum, 0));
2838     TREE_CHAIN (prepend) = arglist;
2839     arglist = prepend;
2840
2841     /* Build the call to the master function. */
2842
2843     master_fn = ffecom_1_fn (ffecom_previous_function_decl_);
2844     call = ffecom_3s (CALL_EXPR,
2845                       TREE_TYPE (TREE_TYPE (TREE_TYPE (master_fn))),
2846                       master_fn, arglist, NULL_TREE);
2847
2848     /* Decide whether the master function is a function or subroutine, and
2849        handle the return value for my entry point. */
2850
2851     if (charfunc || ((ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
2852                      && !altreturning))
2853       {
2854         expand_expr_stmt (call);
2855         expand_null_return ();
2856       }
2857     else if (multi && cmplxfunc)
2858       {
2859         expand_expr_stmt (call);
2860         result
2861           = ffecom_1 (INDIRECT_REF,
2862                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
2863                       result);
2864         result = ffecom_modify (NULL_TREE, result,
2865                                 ffecom_2 (COMPONENT_REF, TREE_TYPE (result),
2866                                           multi_retval,
2867                                           ffecom_multi_fields_[bt][kt]));
2868         expand_expr_stmt (result);
2869         expand_null_return ();
2870       }
2871     else if (multi)
2872       {
2873         expand_expr_stmt (call);
2874         result
2875           = ffecom_modify (NULL_TREE, result,
2876                            convert (TREE_TYPE (result),
2877                                     ffecom_2 (COMPONENT_REF,
2878                                               ffecom_tree_type[bt][kt],
2879                                               multi_retval,
2880                                               ffecom_multi_fields_[bt][kt])));
2881         expand_return (result);
2882       }
2883     else if (cmplxfunc)
2884       {
2885         result
2886           = ffecom_1 (INDIRECT_REF,
2887                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
2888                       result);
2889         result = ffecom_modify (NULL_TREE, result, call);
2890         expand_expr_stmt (result);
2891         expand_null_return ();
2892       }
2893     else
2894       {
2895         result = ffecom_modify (NULL_TREE,
2896                                 result,
2897                                 convert (TREE_TYPE (result),
2898                                          call));
2899         expand_return (result);
2900       }
2901   }
2902
2903   ffecom_end_compstmt ();
2904
2905   finish_function (0);
2906
2907   lineno = old_lineno;
2908   input_filename = old_input_filename;
2909
2910   ffecom_doing_entry_ = FALSE;
2911 }
2912
2913 /* Transform expr into gcc tree with possible destination
2914
2915    Recursive descent on expr while making corresponding tree nodes and
2916    attaching type info and such.  If destination supplied and compatible
2917    with temporary that would be made in certain cases, temporary isn't
2918    made, destination used instead, and dest_used flag set TRUE.  */
2919
2920 static tree
2921 ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
2922               bool *dest_used, bool assignp, bool widenp)
2923 {
2924   tree item;
2925   tree list;
2926   tree args;
2927   ffeinfoBasictype bt;
2928   ffeinfoKindtype kt;
2929   tree t;
2930   tree dt;                      /* decl_tree for an ffesymbol. */
2931   tree tree_type, tree_type_x;
2932   tree left, right;
2933   ffesymbol s;
2934   enum tree_code code;
2935
2936   assert (expr != NULL);
2937
2938   if (dest_used != NULL)
2939     *dest_used = FALSE;
2940
2941   bt = ffeinfo_basictype (ffebld_info (expr));
2942   kt = ffeinfo_kindtype (ffebld_info (expr));
2943   tree_type = ffecom_tree_type[bt][kt];
2944
2945   /* Widen integral arithmetic as desired while preserving signedness.  */
2946   tree_type_x = NULL_TREE;
2947   if (widenp && tree_type
2948       && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
2949       && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
2950     tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
2951
2952   switch (ffebld_op (expr))
2953     {
2954     case FFEBLD_opACCTER:
2955       {
2956         ffebitCount i;
2957         ffebit bits = ffebld_accter_bits (expr);
2958         ffetargetOffset source_offset = 0;
2959         ffetargetOffset dest_offset = ffebld_accter_pad (expr);
2960         tree purpose;
2961
2962         assert (dest_offset == 0
2963                 || (bt == FFEINFO_basictypeCHARACTER
2964                     && kt == FFEINFO_kindtypeCHARACTER1));
2965
2966         list = item = NULL;
2967         for (;;)
2968           {
2969             ffebldConstantUnion cu;
2970             ffebitCount length;
2971             bool value;
2972             ffebldConstantArray ca = ffebld_accter (expr);
2973
2974             ffebit_test (bits, source_offset, &value, &length);
2975             if (length == 0)
2976               break;
2977
2978             if (value)
2979               {
2980                 for (i = 0; i < length; ++i)
2981                   {
2982                     cu = ffebld_constantarray_get (ca, bt, kt,
2983                                                    source_offset + i);
2984
2985                     t = ffecom_constantunion (&cu, bt, kt, tree_type);
2986
2987                     if (i == 0
2988                         && dest_offset != 0)
2989                       purpose = build_int_2 (dest_offset, 0);
2990                     else
2991                       purpose = NULL_TREE;
2992
2993                     if (list == NULL_TREE)
2994                       list = item = build_tree_list (purpose, t);
2995                     else
2996                       {
2997                         TREE_CHAIN (item) = build_tree_list (purpose, t);
2998                         item = TREE_CHAIN (item);
2999                       }
3000                   }
3001               }
3002             source_offset += length;
3003             dest_offset += length;
3004           }
3005       }
3006
3007       item = build_int_2 ((ffebld_accter_size (expr)
3008                            + ffebld_accter_pad (expr)) - 1, 0);
3009       ffebit_kill (ffebld_accter_bits (expr));
3010       TREE_TYPE (item) = ffecom_integer_type_node;
3011       item
3012         = build_array_type
3013           (tree_type,
3014            build_range_type (ffecom_integer_type_node,
3015                              ffecom_integer_zero_node,
3016                              item));
3017       list = build (CONSTRUCTOR, item, NULL_TREE, list);
3018       TREE_CONSTANT (list) = 1;
3019       TREE_STATIC (list) = 1;
3020       return list;
3021
3022     case FFEBLD_opARRTER:
3023       {
3024         ffetargetOffset i;
3025
3026         list = NULL_TREE;
3027         if (ffebld_arrter_pad (expr) == 0)
3028           item = NULL_TREE;
3029         else
3030           {
3031             assert (bt == FFEINFO_basictypeCHARACTER
3032                     && kt == FFEINFO_kindtypeCHARACTER1);
3033
3034             /* Becomes PURPOSE first time through loop.  */
3035             item = build_int_2 (ffebld_arrter_pad (expr), 0);
3036           }
3037
3038         for (i = 0; i < ffebld_arrter_size (expr); ++i)
3039           {
3040             ffebldConstantUnion cu
3041             = ffebld_constantarray_get (ffebld_arrter (expr), bt, kt, i);
3042
3043             t = ffecom_constantunion (&cu, bt, kt, tree_type);
3044
3045             if (list == NULL_TREE)
3046               /* Assume item is PURPOSE first time through loop.  */
3047               list = item = build_tree_list (item, t);
3048             else
3049               {
3050                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
3051                 item = TREE_CHAIN (item);
3052               }
3053           }
3054       }
3055
3056       item = build_int_2 ((ffebld_arrter_size (expr)
3057                           + ffebld_arrter_pad (expr)) - 1, 0);
3058       TREE_TYPE (item) = ffecom_integer_type_node;
3059       item
3060         = build_array_type
3061           (tree_type,
3062            build_range_type (ffecom_integer_type_node,
3063                              ffecom_integer_zero_node,
3064                              item));
3065       list = build (CONSTRUCTOR, item, NULL_TREE, list);
3066       TREE_CONSTANT (list) = 1;
3067       TREE_STATIC (list) = 1;
3068       return list;
3069
3070     case FFEBLD_opCONTER:
3071       assert (ffebld_conter_pad (expr) == 0);
3072       item
3073         = ffecom_constantunion (&ffebld_constant_union (ffebld_conter (expr)),
3074                                 bt, kt, tree_type);
3075       return item;
3076
3077     case FFEBLD_opSYMTER:
3078       if ((ffebld_symter_generic (expr) != FFEINTRIN_genNONE)
3079           || (ffebld_symter_specific (expr) != FFEINTRIN_specNONE))
3080         return ffecom_ptr_to_expr (expr);       /* Same as %REF(intrinsic). */
3081       s = ffebld_symter (expr);
3082       t = ffesymbol_hook (s).decl_tree;
3083
3084       if (assignp)
3085         {                       /* ASSIGN'ed-label expr. */
3086           if (ffe_is_ugly_assign ())
3087             {
3088               /* User explicitly wants ASSIGN'ed variables to be at the same
3089                  memory address as the variables when used in non-ASSIGN
3090                  contexts.  That can make old, arcane, non-standard code
3091                  work, but don't try to do it when a pointer wouldn't fit
3092                  in the normal variable (take other approach, and warn,
3093                  instead).  */
3094
3095               if (t == NULL_TREE)
3096                 {
3097                   s = ffecom_sym_transform_ (s);
3098                   t = ffesymbol_hook (s).decl_tree;
3099                   assert (t != NULL_TREE);
3100                 }
3101
3102               if (t == error_mark_node)
3103                 return t;
3104
3105               if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t)))
3106                   >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
3107                 {
3108                   if (ffesymbol_hook (s).addr)
3109                     t = ffecom_1 (INDIRECT_REF,
3110                                   TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3111                   return t;
3112                 }
3113
3114               if (ffesymbol_hook (s).assign_tree == NULL_TREE)
3115                 {
3116                   /* xgettext:no-c-format */
3117                   ffebad_start_msg ("ASSIGN'ed label cannot fit into `%A' at %0 -- using wider sibling",
3118                                     FFEBAD_severityWARNING);
3119                   ffebad_string (ffesymbol_text (s));
3120                   ffebad_here (0, ffesymbol_where_line (s),
3121                                ffesymbol_where_column (s));
3122                   ffebad_finish ();
3123                 }
3124             }
3125
3126           /* Don't use the normal variable's tree for ASSIGN, though mark
3127              it as in the system header (housekeeping).  Use an explicit,
3128              specially created sibling that is known to be wide enough
3129              to hold pointers to labels.  */
3130
3131           if (t != NULL_TREE
3132               && TREE_CODE (t) == VAR_DECL)
3133             DECL_IN_SYSTEM_HEADER (t) = 1;      /* Don't let -Wunused complain. */
3134
3135           t = ffesymbol_hook (s).assign_tree;
3136           if (t == NULL_TREE)
3137             {
3138               s = ffecom_sym_transform_assign_ (s);
3139               t = ffesymbol_hook (s).assign_tree;
3140               assert (t != NULL_TREE);
3141             }
3142         }
3143       else
3144         {
3145           if (t == NULL_TREE)
3146             {
3147               s = ffecom_sym_transform_ (s);
3148               t = ffesymbol_hook (s).decl_tree;
3149               assert (t != NULL_TREE);
3150             }
3151           if (ffesymbol_hook (s).addr)
3152             t = ffecom_1 (INDIRECT_REF,
3153                           TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3154         }
3155       return t;
3156
3157     case FFEBLD_opARRAYREF:
3158       return ffecom_arrayref_ (NULL_TREE, expr, 0);
3159
3160     case FFEBLD_opUPLUS:
3161       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3162       return ffecom_1 (NOP_EXPR, tree_type, left);
3163
3164     case FFEBLD_opPAREN:
3165       /* ~~~Make sure Fortran rules respected here */
3166       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3167       return ffecom_1 (NOP_EXPR, tree_type, left);
3168
3169     case FFEBLD_opUMINUS:
3170       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3171       if (tree_type_x)
3172         {
3173           tree_type = tree_type_x;
3174           left = convert (tree_type, left);
3175         }
3176       return ffecom_1 (NEGATE_EXPR, tree_type, left);
3177
3178     case FFEBLD_opADD:
3179       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3180       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3181       if (tree_type_x)
3182         {
3183           tree_type = tree_type_x;
3184           left = convert (tree_type, left);
3185           right = convert (tree_type, right);
3186         }
3187       return ffecom_2 (PLUS_EXPR, tree_type, left, right);
3188
3189     case FFEBLD_opSUBTRACT:
3190       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3191       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3192       if (tree_type_x)
3193         {
3194           tree_type = tree_type_x;
3195           left = convert (tree_type, left);
3196           right = convert (tree_type, right);
3197         }
3198       return ffecom_2 (MINUS_EXPR, tree_type, left, right);
3199
3200     case FFEBLD_opMULTIPLY:
3201       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3202       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3203       if (tree_type_x)
3204         {
3205           tree_type = tree_type_x;
3206           left = convert (tree_type, left);
3207           right = convert (tree_type, right);
3208         }
3209       return ffecom_2 (MULT_EXPR, tree_type, left, right);
3210
3211     case FFEBLD_opDIVIDE:
3212       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3213       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3214       if (tree_type_x)
3215         {
3216           tree_type = tree_type_x;
3217           left = convert (tree_type, left);
3218           right = convert (tree_type, right);
3219         }
3220       return ffecom_tree_divide_ (tree_type, left, right,
3221                                   dest_tree, dest, dest_used,
3222                                   ffebld_nonter_hook (expr));
3223
3224     case FFEBLD_opPOWER:
3225       {
3226         ffebld left = ffebld_left (expr);
3227         ffebld right = ffebld_right (expr);
3228         ffecomGfrt code;
3229         ffeinfoKindtype rtkt;
3230         ffeinfoKindtype ltkt;
3231         bool ref = TRUE;
3232
3233         switch (ffeinfo_basictype (ffebld_info (right)))
3234           {
3235
3236           case FFEINFO_basictypeINTEGER:
3237             if (1 || optimize)
3238               {
3239                 item = ffecom_expr_power_integer_ (expr);
3240                 if (item != NULL_TREE)
3241                   return item;
3242               }
3243
3244             rtkt = FFEINFO_kindtypeINTEGER1;
3245             switch (ffeinfo_basictype (ffebld_info (left)))
3246               {
3247               case FFEINFO_basictypeINTEGER:
3248                 if ((ffeinfo_kindtype (ffebld_info (left))
3249                     == FFEINFO_kindtypeINTEGER4)
3250                     || (ffeinfo_kindtype (ffebld_info (right))
3251                         == FFEINFO_kindtypeINTEGER4))
3252                   {
3253                     code = FFECOM_gfrtPOW_QQ;
3254                     ltkt = FFEINFO_kindtypeINTEGER4;
3255                     rtkt = FFEINFO_kindtypeINTEGER4;
3256                   }
3257                 else
3258                   {
3259                     code = FFECOM_gfrtPOW_II;
3260                     ltkt = FFEINFO_kindtypeINTEGER1;
3261                   }
3262                 break;
3263
3264               case FFEINFO_basictypeREAL:
3265                 if (ffeinfo_kindtype (ffebld_info (left))
3266                     == FFEINFO_kindtypeREAL1)
3267                   {
3268                     code = FFECOM_gfrtPOW_RI;
3269                     ltkt = FFEINFO_kindtypeREAL1;
3270                   }
3271                 else
3272                   {
3273                     code = FFECOM_gfrtPOW_DI;
3274                     ltkt = FFEINFO_kindtypeREAL2;
3275                   }
3276                 break;
3277
3278               case FFEINFO_basictypeCOMPLEX:
3279                 if (ffeinfo_kindtype (ffebld_info (left))
3280                     == FFEINFO_kindtypeREAL1)
3281                   {
3282                     code = FFECOM_gfrtPOW_CI;   /* Overlapping result okay. */
3283                     ltkt = FFEINFO_kindtypeREAL1;
3284                   }
3285                 else
3286                   {
3287                     code = FFECOM_gfrtPOW_ZI;   /* Overlapping result okay. */
3288                     ltkt = FFEINFO_kindtypeREAL2;
3289                   }
3290                 break;
3291
3292               default:
3293                 assert ("bad pow_*i" == NULL);
3294                 code = FFECOM_gfrtPOW_CI;       /* Overlapping result okay. */
3295                 ltkt = FFEINFO_kindtypeREAL1;
3296                 break;
3297               }
3298             if (ffeinfo_kindtype (ffebld_info (left)) != ltkt)
3299               left = ffeexpr_convert (left, NULL, NULL,
3300                                       ffeinfo_basictype (ffebld_info (left)),
3301                                       ltkt, 0,
3302                                       FFETARGET_charactersizeNONE,
3303                                       FFEEXPR_contextLET);
3304             if (ffeinfo_kindtype (ffebld_info (right)) != rtkt)
3305               right = ffeexpr_convert (right, NULL, NULL,
3306                                        FFEINFO_basictypeINTEGER,
3307                                        rtkt, 0,
3308                                        FFETARGET_charactersizeNONE,
3309                                        FFEEXPR_contextLET);
3310             break;
3311
3312           case FFEINFO_basictypeREAL:
3313             if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3314               left = ffeexpr_convert (left, NULL, NULL, FFEINFO_basictypeREAL,
3315                                       FFEINFO_kindtypeREALDOUBLE, 0,
3316                                       FFETARGET_charactersizeNONE,
3317                                       FFEEXPR_contextLET);
3318             if (ffeinfo_kindtype (ffebld_info (right))
3319                 == FFEINFO_kindtypeREAL1)
3320               right = ffeexpr_convert (right, NULL, NULL,
3321                                        FFEINFO_basictypeREAL,
3322                                        FFEINFO_kindtypeREALDOUBLE, 0,
3323                                        FFETARGET_charactersizeNONE,
3324                                        FFEEXPR_contextLET);
3325             /* We used to call FFECOM_gfrtPOW_DD here,
3326                which passes arguments by reference.  */
3327             code = FFECOM_gfrtL_POW;
3328             /* Pass arguments by value. */
3329             ref  = FALSE;
3330             break;
3331
3332           case FFEINFO_basictypeCOMPLEX:
3333             if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3334               left = ffeexpr_convert (left, NULL, NULL,
3335                                       FFEINFO_basictypeCOMPLEX,
3336                                       FFEINFO_kindtypeREALDOUBLE, 0,
3337                                       FFETARGET_charactersizeNONE,
3338                                       FFEEXPR_contextLET);
3339             if (ffeinfo_kindtype (ffebld_info (right))
3340                 == FFEINFO_kindtypeREAL1)
3341               right = ffeexpr_convert (right, NULL, NULL,
3342                                        FFEINFO_basictypeCOMPLEX,
3343                                        FFEINFO_kindtypeREALDOUBLE, 0,
3344                                        FFETARGET_charactersizeNONE,
3345                                        FFEEXPR_contextLET);
3346             code = FFECOM_gfrtPOW_ZZ;   /* Overlapping result okay. */
3347             ref = TRUE;                 /* Pass arguments by reference. */
3348             break;
3349
3350           default:
3351             assert ("bad pow_x*" == NULL);
3352             code = FFECOM_gfrtPOW_II;
3353             break;
3354           }
3355         return ffecom_call_binop_ (ffecom_gfrt_tree_ (code),
3356                                    ffecom_gfrt_kindtype (code),
3357                                    (ffe_is_f2c_library ()
3358                                     && ffecom_gfrt_complex_[code]),
3359                                    tree_type, left, right,
3360                                    dest_tree, dest, dest_used,
3361                                    NULL_TREE, FALSE, ref,
3362                                    ffebld_nonter_hook (expr));
3363       }
3364
3365     case FFEBLD_opNOT:
3366       switch (bt)
3367         {
3368         case FFEINFO_basictypeLOGICAL:
3369           item = ffecom_truth_value_invert (ffecom_expr (ffebld_left (expr)));
3370           return convert (tree_type, item);
3371
3372         case FFEINFO_basictypeINTEGER:
3373           return ffecom_1 (BIT_NOT_EXPR, tree_type,
3374                            ffecom_expr (ffebld_left (expr)));
3375
3376         default:
3377           assert ("NOT bad basictype" == NULL);
3378           /* Fall through. */
3379         case FFEINFO_basictypeANY:
3380           return error_mark_node;
3381         }
3382       break;
3383
3384     case FFEBLD_opFUNCREF:
3385       assert (ffeinfo_basictype (ffebld_info (expr))
3386               != FFEINFO_basictypeCHARACTER);
3387       /* Fall through.   */
3388     case FFEBLD_opSUBRREF:
3389       if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
3390           == FFEINFO_whereINTRINSIC)
3391         {                       /* Invocation of an intrinsic. */
3392           item = ffecom_expr_intrinsic_ (expr, dest_tree, dest,
3393                                          dest_used);
3394           return item;
3395         }
3396       s = ffebld_symter (ffebld_left (expr));
3397       dt = ffesymbol_hook (s).decl_tree;
3398       if (dt == NULL_TREE)
3399         {
3400           s = ffecom_sym_transform_ (s);
3401           dt = ffesymbol_hook (s).decl_tree;
3402         }
3403       if (dt == error_mark_node)
3404         return dt;
3405
3406       if (ffesymbol_hook (s).addr)
3407         item = dt;
3408       else
3409         item = ffecom_1_fn (dt);
3410
3411       if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
3412         args = ffecom_list_expr (ffebld_right (expr));
3413       else
3414         args = ffecom_list_ptr_to_expr (ffebld_right (expr));
3415
3416       if (args == error_mark_node)
3417         return error_mark_node;
3418
3419       item = ffecom_call_ (item, kt,
3420                            ffesymbol_is_f2c (s)
3421                            && (bt == FFEINFO_basictypeCOMPLEX)
3422                            && (ffesymbol_where (s)
3423                                != FFEINFO_whereCONSTANT),
3424                            tree_type,
3425                            args,
3426                            dest_tree, dest, dest_used,
3427                            error_mark_node, FALSE,
3428                            ffebld_nonter_hook (expr));
3429       TREE_SIDE_EFFECTS (item) = 1;
3430       return item;
3431
3432     case FFEBLD_opAND:
3433       switch (bt)
3434         {
3435         case FFEINFO_basictypeLOGICAL:
3436           item
3437             = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3438                        ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3439                      ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3440           return convert (tree_type, item);
3441
3442         case FFEINFO_basictypeINTEGER:
3443           return ffecom_2 (BIT_AND_EXPR, tree_type,
3444                            ffecom_expr (ffebld_left (expr)),
3445                            ffecom_expr (ffebld_right (expr)));
3446
3447         default:
3448           assert ("AND bad basictype" == NULL);
3449           /* Fall through. */
3450         case FFEINFO_basictypeANY:
3451           return error_mark_node;
3452         }
3453       break;
3454
3455     case FFEBLD_opOR:
3456       switch (bt)
3457         {
3458         case FFEINFO_basictypeLOGICAL:
3459           item
3460             = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
3461                        ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3462                      ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3463           return convert (tree_type, item);
3464
3465         case FFEINFO_basictypeINTEGER:
3466           return ffecom_2 (BIT_IOR_EXPR, tree_type,
3467                            ffecom_expr (ffebld_left (expr)),
3468                            ffecom_expr (ffebld_right (expr)));
3469
3470         default:
3471           assert ("OR bad basictype" == NULL);
3472           /* Fall through. */
3473         case FFEINFO_basictypeANY:
3474           return error_mark_node;
3475         }
3476       break;
3477
3478     case FFEBLD_opXOR:
3479     case FFEBLD_opNEQV:
3480       switch (bt)
3481         {
3482         case FFEINFO_basictypeLOGICAL:
3483           item
3484             = ffecom_2 (NE_EXPR, integer_type_node,
3485                         ffecom_expr (ffebld_left (expr)),
3486                         ffecom_expr (ffebld_right (expr)));
3487           return convert (tree_type, ffecom_truth_value (item));
3488
3489         case FFEINFO_basictypeINTEGER:
3490           return ffecom_2 (BIT_XOR_EXPR, tree_type,
3491                            ffecom_expr (ffebld_left (expr)),
3492                            ffecom_expr (ffebld_right (expr)));
3493
3494         default:
3495           assert ("XOR/NEQV bad basictype" == NULL);
3496           /* Fall through. */
3497         case FFEINFO_basictypeANY:
3498           return error_mark_node;
3499         }
3500       break;
3501
3502     case FFEBLD_opEQV:
3503       switch (bt)
3504         {
3505         case FFEINFO_basictypeLOGICAL:
3506           item
3507             = ffecom_2 (EQ_EXPR, integer_type_node,
3508                         ffecom_expr (ffebld_left (expr)),
3509                         ffecom_expr (ffebld_right (expr)));
3510           return convert (tree_type, ffecom_truth_value (item));
3511
3512         case FFEINFO_basictypeINTEGER:
3513           return
3514             ffecom_1 (BIT_NOT_EXPR, tree_type,
3515                       ffecom_2 (BIT_XOR_EXPR, tree_type,
3516                                 ffecom_expr (ffebld_left (expr)),
3517                                 ffecom_expr (ffebld_right (expr))));
3518
3519         default:
3520           assert ("EQV bad basictype" == NULL);
3521           /* Fall through. */
3522         case FFEINFO_basictypeANY:
3523           return error_mark_node;
3524         }
3525       break;
3526
3527     case FFEBLD_opCONVERT:
3528       if (ffebld_op (ffebld_left (expr)) == FFEBLD_opANY)
3529         return error_mark_node;
3530
3531       switch (bt)
3532         {
3533         case FFEINFO_basictypeLOGICAL:
3534         case FFEINFO_basictypeINTEGER:
3535         case FFEINFO_basictypeREAL:
3536           return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3537
3538         case FFEINFO_basictypeCOMPLEX:
3539           switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3540             {
3541             case FFEINFO_basictypeINTEGER:
3542             case FFEINFO_basictypeLOGICAL:
3543             case FFEINFO_basictypeREAL:
3544               item = ffecom_expr (ffebld_left (expr));
3545               if (item == error_mark_node)
3546                 return error_mark_node;
3547               /* convert() takes care of converting to the subtype first,
3548                  at least in gcc-2.7.2. */
3549               item = convert (tree_type, item);
3550               return item;
3551
3552             case FFEINFO_basictypeCOMPLEX:
3553               return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3554
3555             default:
3556               assert ("CONVERT COMPLEX bad basictype" == NULL);
3557               /* Fall through. */
3558             case FFEINFO_basictypeANY:
3559               return error_mark_node;
3560             }
3561           break;
3562
3563         default:
3564           assert ("CONVERT bad basictype" == NULL);
3565           /* Fall through. */
3566         case FFEINFO_basictypeANY:
3567           return error_mark_node;
3568         }
3569       break;
3570
3571     case FFEBLD_opLT:
3572       code = LT_EXPR;
3573       goto relational;          /* :::::::::::::::::::: */
3574
3575     case FFEBLD_opLE:
3576       code = LE_EXPR;
3577       goto relational;          /* :::::::::::::::::::: */
3578
3579     case FFEBLD_opEQ:
3580       code = EQ_EXPR;
3581       goto relational;          /* :::::::::::::::::::: */
3582
3583     case FFEBLD_opNE:
3584       code = NE_EXPR;
3585       goto relational;          /* :::::::::::::::::::: */
3586
3587     case FFEBLD_opGT:
3588       code = GT_EXPR;
3589       goto relational;          /* :::::::::::::::::::: */
3590
3591     case FFEBLD_opGE:
3592       code = GE_EXPR;
3593
3594     relational:         /* :::::::::::::::::::: */
3595       switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3596         {
3597         case FFEINFO_basictypeLOGICAL:
3598         case FFEINFO_basictypeINTEGER:
3599         case FFEINFO_basictypeREAL:
3600           item = ffecom_2 (code, integer_type_node,
3601                            ffecom_expr (ffebld_left (expr)),
3602                            ffecom_expr (ffebld_right (expr)));
3603           return convert (tree_type, item);
3604
3605         case FFEINFO_basictypeCOMPLEX:
3606           assert (code == EQ_EXPR || code == NE_EXPR);
3607           {
3608             tree real_type;
3609             tree arg1 = ffecom_expr (ffebld_left (expr));
3610             tree arg2 = ffecom_expr (ffebld_right (expr));
3611
3612             if (arg1 == error_mark_node || arg2 == error_mark_node)
3613               return error_mark_node;
3614
3615             arg1 = ffecom_save_tree (arg1);
3616             arg2 = ffecom_save_tree (arg2);
3617
3618             if (TREE_CODE (TREE_TYPE (arg1)) == COMPLEX_TYPE)
3619               {
3620                 real_type = TREE_TYPE (TREE_TYPE (arg1));
3621                 assert (real_type == TREE_TYPE (TREE_TYPE (arg2)));
3622               }
3623             else
3624               {
3625                 real_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg1)));
3626                 assert (real_type == TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg2))));
3627               }
3628
3629             item
3630               = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3631                           ffecom_2 (EQ_EXPR, integer_type_node,
3632                                   ffecom_1 (REALPART_EXPR, real_type, arg1),
3633                                  ffecom_1 (REALPART_EXPR, real_type, arg2)),
3634                           ffecom_2 (EQ_EXPR, integer_type_node,
3635                                   ffecom_1 (IMAGPART_EXPR, real_type, arg1),
3636                                     ffecom_1 (IMAGPART_EXPR, real_type,
3637                                               arg2)));
3638             if (code == EQ_EXPR)
3639               item = ffecom_truth_value (item);
3640             else
3641               item = ffecom_truth_value_invert (item);
3642             return convert (tree_type, item);
3643           }
3644
3645         case FFEINFO_basictypeCHARACTER:
3646           {
3647             ffebld left = ffebld_left (expr);
3648             ffebld right = ffebld_right (expr);
3649             tree left_tree;
3650             tree right_tree;
3651             tree left_length;
3652             tree right_length;
3653
3654             /* f2c run-time functions do the implicit blank-padding for us,
3655                so we don't usually have to implement blank-padding ourselves.
3656                (The exception is when we pass an argument to a separately
3657                compiled statement function -- if we know the arg is not the
3658                same length as the dummy, we must truncate or extend it.  If
3659                we "inline" statement functions, that necessity goes away as
3660                well.)
3661
3662                Strip off the CONVERT operators that blank-pad.  (Truncation by
3663                CONVERT shouldn't happen here, but it can happen in
3664                assignments.) */
3665
3666             while (ffebld_op (left) == FFEBLD_opCONVERT)
3667               left = ffebld_left (left);
3668             while (ffebld_op (right) == FFEBLD_opCONVERT)
3669               right = ffebld_left (right);
3670
3671             left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
3672             right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
3673
3674             if (left_tree == error_mark_node || left_length == error_mark_node
3675                 || right_tree == error_mark_node
3676                 || right_length == error_mark_node)
3677               return error_mark_node;
3678
3679             if ((ffebld_size_known (left) == 1)
3680                 && (ffebld_size_known (right) == 1))
3681               {
3682                 left_tree
3683                   = ffecom_1 (INDIRECT_REF,
3684                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3685                               left_tree);
3686                 right_tree
3687                   = ffecom_1 (INDIRECT_REF,
3688                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3689                               right_tree);
3690
3691                 item
3692                   = ffecom_2 (code, integer_type_node,
3693                               ffecom_2 (ARRAY_REF,
3694                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3695                                         left_tree,
3696                                         integer_one_node),
3697                               ffecom_2 (ARRAY_REF,
3698                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3699                                         right_tree,
3700                                         integer_one_node));
3701               }
3702             else
3703               {
3704                 item = build_tree_list (NULL_TREE, left_tree);
3705                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, right_tree);
3706                 TREE_CHAIN (TREE_CHAIN (item)) = build_tree_list (NULL_TREE,
3707                                                                left_length);
3708                 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
3709                   = build_tree_list (NULL_TREE, right_length);
3710                 item = ffecom_call_gfrt (FFECOM_gfrtCMP, item, NULL_TREE);
3711                 item = ffecom_2 (code, integer_type_node,
3712                                  item,
3713                                  convert (TREE_TYPE (item),
3714                                           integer_zero_node));
3715               }
3716             item = convert (tree_type, item);
3717           }
3718
3719           return item;
3720
3721         default:
3722           assert ("relational bad basictype" == NULL);
3723           /* Fall through. */
3724         case FFEINFO_basictypeANY:
3725           return error_mark_node;
3726         }
3727       break;
3728
3729     case FFEBLD_opPERCENT_LOC:
3730       item = ffecom_arg_ptr_to_expr (ffebld_left (expr), &list);
3731       return convert (tree_type, item);
3732
3733     case FFEBLD_opPERCENT_VAL:
3734       item = ffecom_arg_expr (ffebld_left (expr), &list);
3735       return convert (tree_type, item);
3736
3737     case FFEBLD_opITEM:
3738     case FFEBLD_opSTAR:
3739     case FFEBLD_opBOUNDS:
3740     case FFEBLD_opREPEAT:
3741     case FFEBLD_opLABTER:
3742     case FFEBLD_opLABTOK:
3743     case FFEBLD_opIMPDO:
3744     case FFEBLD_opCONCATENATE:
3745     case FFEBLD_opSUBSTR:
3746     default:
3747       assert ("bad op" == NULL);
3748       /* Fall through. */
3749     case FFEBLD_opANY:
3750       return error_mark_node;
3751     }
3752
3753 #if 1
3754   assert ("didn't think anything got here anymore!!" == NULL);
3755 #else
3756   switch (ffebld_arity (expr))
3757     {
3758     case 2:
3759       TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3760       TREE_OPERAND (item, 1) = ffecom_expr (ffebld_right (expr));
3761       if (TREE_OPERAND (item, 0) == error_mark_node
3762           || TREE_OPERAND (item, 1) == error_mark_node)
3763         return error_mark_node;
3764       break;
3765
3766     case 1:
3767       TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3768       if (TREE_OPERAND (item, 0) == error_mark_node)
3769         return error_mark_node;
3770       break;
3771
3772     default:
3773       break;
3774     }
3775
3776   return fold (item);
3777 #endif
3778 }
3779
3780 /* Returns the tree that does the intrinsic invocation.
3781
3782    Note: this function applies only to intrinsics returning
3783    CHARACTER*1 or non-CHARACTER results, and to intrinsic
3784    subroutines.  */
3785
3786 static tree
3787 ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
3788                         ffebld dest, bool *dest_used)
3789 {
3790   tree expr_tree;
3791   tree saved_expr1;             /* For those who need it. */
3792   tree saved_expr2;             /* For those who need it. */
3793   ffeinfoBasictype bt;
3794   ffeinfoKindtype kt;
3795   tree tree_type;
3796   tree arg1_type;
3797   tree real_type;               /* REAL type corresponding to COMPLEX. */
3798   tree tempvar;
3799   ffebld list = ffebld_right (expr);    /* List of (some) args. */
3800   ffebld arg1;                  /* For handy reference. */
3801   ffebld arg2;
3802   ffebld arg3;
3803   ffeintrinImp codegen_imp;
3804   ffecomGfrt gfrt;
3805
3806   assert (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER);
3807
3808   if (dest_used != NULL)
3809     *dest_used = FALSE;
3810
3811   bt = ffeinfo_basictype (ffebld_info (expr));
3812   kt = ffeinfo_kindtype (ffebld_info (expr));
3813   tree_type = ffecom_tree_type[bt][kt];
3814
3815   if (list != NULL)
3816     {
3817       arg1 = ffebld_head (list);
3818       if (arg1 != NULL && ffebld_op (arg1) == FFEBLD_opANY)
3819         return error_mark_node;
3820       if ((list = ffebld_trail (list)) != NULL)
3821         {
3822           arg2 = ffebld_head (list);
3823           if (arg2 != NULL && ffebld_op (arg2) == FFEBLD_opANY)
3824             return error_mark_node;
3825           if ((list = ffebld_trail (list)) != NULL)
3826             {
3827               arg3 = ffebld_head (list);
3828               if (arg3 != NULL && ffebld_op (arg3) == FFEBLD_opANY)
3829                 return error_mark_node;
3830             }
3831           else
3832             arg3 = NULL;
3833         }
3834       else
3835         arg2 = arg3 = NULL;
3836     }
3837   else
3838     arg1 = arg2 = arg3 = NULL;
3839
3840   /* <list> ends up at the opITEM of the 3rd arg, or NULL if there are < 3
3841      args.  This is used by the MAX/MIN expansions. */
3842
3843   if (arg1 != NULL)
3844     arg1_type = ffecom_tree_type
3845       [ffeinfo_basictype (ffebld_info (arg1))]
3846       [ffeinfo_kindtype (ffebld_info (arg1))];
3847   else
3848     arg1_type = NULL_TREE;      /* Really not needed, but might catch bugs
3849                                    here. */
3850
3851   /* There are several ways for each of the cases in the following switch
3852      statements to exit (from simplest to use to most complicated):
3853
3854      break;  (when expr_tree == NULL)
3855
3856      A standard call is made to the specific intrinsic just as if it had been
3857      passed in as a dummy procedure and called as any old procedure.  This
3858      method can produce slower code but in some cases it's the easiest way for
3859      now.  However, if a (presumably faster) direct call is available,
3860      that is used, so this is the easiest way in many more cases now.
3861
3862      gfrt = FFECOM_gfrtWHATEVER;
3863      break;
3864
3865      gfrt contains the gfrt index of a library function to call, passing the
3866      argument(s) by value rather than by reference.  Used when a more
3867      careful choice of library function is needed than that provided
3868      by the vanilla `break;'.
3869
3870      return expr_tree;
3871
3872      The expr_tree has been completely set up and is ready to be returned
3873      as is.  No further actions are taken.  Use this when the tree is not
3874      in the simple form for one of the arity_n labels.   */
3875
3876   /* For info on how the switch statement cases were written, see the files
3877      enclosed in comments below the switch statement. */
3878
3879   codegen_imp = ffebld_symter_implementation (ffebld_left (expr));
3880   gfrt = ffeintrin_gfrt_direct (codegen_imp);
3881   if (gfrt == FFECOM_gfrt)
3882     gfrt = ffeintrin_gfrt_indirect (codegen_imp);
3883
3884   switch (codegen_imp)
3885     {
3886     case FFEINTRIN_impABS:
3887     case FFEINTRIN_impCABS:
3888     case FFEINTRIN_impCDABS:
3889     case FFEINTRIN_impDABS:
3890     case FFEINTRIN_impIABS:
3891       if (ffeinfo_basictype (ffebld_info (arg1))
3892           == FFEINFO_basictypeCOMPLEX)
3893         {
3894           if (kt == FFEINFO_kindtypeREAL1)
3895             gfrt = FFECOM_gfrtCABS;
3896           else if (kt == FFEINFO_kindtypeREAL2)
3897             gfrt = FFECOM_gfrtCDABS;
3898           break;
3899         }
3900       return ffecom_1 (ABS_EXPR, tree_type,
3901                        convert (tree_type, ffecom_expr (arg1)));
3902
3903     case FFEINTRIN_impACOS:
3904     case FFEINTRIN_impDACOS:
3905       break;
3906
3907     case FFEINTRIN_impAIMAG:
3908     case FFEINTRIN_impDIMAG:
3909     case FFEINTRIN_impIMAGPART:
3910       if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
3911         arg1_type = TREE_TYPE (arg1_type);
3912       else
3913         arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
3914
3915       return
3916         convert (tree_type,
3917                  ffecom_1 (IMAGPART_EXPR, arg1_type,
3918                            ffecom_expr (arg1)));
3919
3920     case FFEINTRIN_impAINT:
3921     case FFEINTRIN_impDINT:
3922 #if 0
3923       /* ~~Someday implement FIX_TRUNC_EXPR yielding same type as arg.  */
3924       return ffecom_1 (FIX_TRUNC_EXPR, tree_type, ffecom_expr (arg1));
3925 #else /* in the meantime, must use floor to avoid range problems with ints */
3926       /* r__1 = r1 >= 0 ? floor(r1) : -floor(-r1); */
3927       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
3928       return
3929         convert (tree_type,
3930                  ffecom_3 (COND_EXPR, double_type_node,
3931                            ffecom_truth_value
3932                            (ffecom_2 (GE_EXPR, integer_type_node,
3933                                       saved_expr1,
3934                                       convert (arg1_type,
3935                                                ffecom_float_zero_))),
3936                            ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
3937                                              build_tree_list (NULL_TREE,
3938                                                   convert (double_type_node,
3939                                                            saved_expr1)),
3940                                              NULL_TREE),
3941                            ffecom_1 (NEGATE_EXPR, double_type_node,
3942                                      ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
3943                                                  build_tree_list (NULL_TREE,
3944                                                   convert (double_type_node,
3945                                                       ffecom_1 (NEGATE_EXPR,
3946                                                                 arg1_type,
3947                                                                saved_expr1))),
3948                                                        NULL_TREE)
3949                                      ))
3950                  );
3951 #endif
3952
3953     case FFEINTRIN_impANINT:
3954     case FFEINTRIN_impDNINT:
3955 #if 0                           /* This way of doing it won't handle real
3956                                    numbers of large magnitudes. */
3957       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
3958       expr_tree = convert (tree_type,
3959                            convert (integer_type_node,
3960                                     ffecom_3 (COND_EXPR, tree_type,
3961                                               ffecom_truth_value
3962                                               (ffecom_2 (GE_EXPR,
3963                                                          integer_type_node,
3964                                                          saved_expr1,
3965                                                        ffecom_float_zero_)),
3966                                               ffecom_2 (PLUS_EXPR,
3967                                                         tree_type,
3968                                                         saved_expr1,
3969                                                         ffecom_float_half_),
3970                                               ffecom_2 (MINUS_EXPR,
3971                                                         tree_type,
3972                                                         saved_expr1,
3973                                                      ffecom_float_half_))));
3974       return expr_tree;
3975 #else /* So we instead call floor. */
3976       /* r__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1) */
3977       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
3978       return
3979         convert (tree_type,
3980                  ffecom_3 (COND_EXPR, double_type_node,
3981                            ffecom_truth_value
3982                            (ffecom_2 (GE_EXPR, integer_type_node,
3983                                       saved_expr1,
3984                                       convert (arg1_type,
3985                                                ffecom_float_zero_))),
3986                            ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
3987                                              build_tree_list (NULL_TREE,
3988                                                   convert (double_type_node,
3989                                                            ffecom_2 (PLUS_EXPR,
3990                                                                      arg1_type,
3991                                                                      saved_expr1,
3992                                                                      convert (arg1_type,
3993                                                                               ffecom_float_half_)))),
3994                                              NULL_TREE),
3995                            ffecom_1 (NEGATE_EXPR, double_type_node,
3996                                      ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
3997                                                        build_tree_list (NULL_TREE,
3998                                                                         convert (double_type_node,
3999                                                                                  ffecom_2 (MINUS_EXPR,
4000                                                                                            arg1_type,
4001                                                                                            convert (arg1_type,
4002                                                                                                     ffecom_float_half_),
4003                                                                                            saved_expr1))),
4004                                                        NULL_TREE))
4005                            )
4006                  );
4007 #endif
4008
4009     case FFEINTRIN_impASIN:
4010     case FFEINTRIN_impDASIN:
4011     case FFEINTRIN_impATAN:
4012     case FFEINTRIN_impDATAN:
4013     case FFEINTRIN_impATAN2:
4014     case FFEINTRIN_impDATAN2:
4015       break;
4016
4017     case FFEINTRIN_impCHAR:
4018     case FFEINTRIN_impACHAR:
4019 #ifdef HOHO
4020       tempvar = ffecom_make_tempvar (char_type_node, 1, -1);
4021 #else
4022       tempvar = ffebld_nonter_hook (expr);
4023       assert (tempvar);
4024 #endif
4025       {
4026         tree tmv = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (tempvar)));
4027
4028         expr_tree = ffecom_modify (tmv,
4029                                    ffecom_2 (ARRAY_REF, tmv, tempvar,
4030                                              integer_one_node),
4031                                    convert (tmv, ffecom_expr (arg1)));
4032       }
4033       expr_tree = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar),
4034                             expr_tree,
4035                             tempvar);
4036       expr_tree = ffecom_1 (ADDR_EXPR,
4037                             build_pointer_type (TREE_TYPE (expr_tree)),
4038                             expr_tree);
4039       return expr_tree;
4040
4041     case FFEINTRIN_impCMPLX:
4042     case FFEINTRIN_impDCMPLX:
4043       if (arg2 == NULL)
4044         return
4045           convert (tree_type, ffecom_expr (arg1));
4046
4047       real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4048       return
4049         ffecom_2 (COMPLEX_EXPR, tree_type,
4050                   convert (real_type, ffecom_expr (arg1)),
4051                   convert (real_type,
4052                            ffecom_expr (arg2)));
4053
4054     case FFEINTRIN_impCOMPLEX:
4055       return
4056         ffecom_2 (COMPLEX_EXPR, tree_type,
4057                   ffecom_expr (arg1),
4058                   ffecom_expr (arg2));
4059
4060     case FFEINTRIN_impCONJG:
4061     case FFEINTRIN_impDCONJG:
4062       {
4063         tree arg1_tree;
4064
4065         real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4066         arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4067         return
4068           ffecom_2 (COMPLEX_EXPR, tree_type,
4069                     ffecom_1 (REALPART_EXPR, real_type, arg1_tree),
4070                     ffecom_1 (NEGATE_EXPR, real_type,
4071                               ffecom_1 (IMAGPART_EXPR, real_type, arg1_tree)));
4072       }
4073
4074     case FFEINTRIN_impCOS:
4075     case FFEINTRIN_impCCOS:
4076     case FFEINTRIN_impCDCOS:
4077     case FFEINTRIN_impDCOS:
4078       if (bt == FFEINFO_basictypeCOMPLEX)
4079         {
4080           if (kt == FFEINFO_kindtypeREAL1)
4081             gfrt = FFECOM_gfrtCCOS;     /* Overlapping result okay. */
4082           else if (kt == FFEINFO_kindtypeREAL2)
4083             gfrt = FFECOM_gfrtCDCOS;    /* Overlapping result okay. */
4084         }
4085       break;
4086
4087     case FFEINTRIN_impCOSH:
4088     case FFEINTRIN_impDCOSH:
4089       break;
4090
4091     case FFEINTRIN_impDBLE:
4092     case FFEINTRIN_impDFLOAT:
4093     case FFEINTRIN_impDREAL:
4094     case FFEINTRIN_impFLOAT:
4095     case FFEINTRIN_impIDINT:
4096     case FFEINTRIN_impIFIX:
4097     case FFEINTRIN_impINT2:
4098     case FFEINTRIN_impINT8:
4099     case FFEINTRIN_impINT:
4100     case FFEINTRIN_impLONG:
4101     case FFEINTRIN_impREAL:
4102     case FFEINTRIN_impSHORT:
4103     case FFEINTRIN_impSNGL:
4104       return convert (tree_type, ffecom_expr (arg1));
4105
4106     case FFEINTRIN_impDIM:
4107     case FFEINTRIN_impDDIM:
4108     case FFEINTRIN_impIDIM:
4109       saved_expr1 = ffecom_save_tree (convert (tree_type,
4110                                                ffecom_expr (arg1)));
4111       saved_expr2 = ffecom_save_tree (convert (tree_type,
4112                                                ffecom_expr (arg2)));
4113       return
4114         ffecom_3 (COND_EXPR, tree_type,
4115                   ffecom_truth_value
4116                   (ffecom_2 (GT_EXPR, integer_type_node,
4117                              saved_expr1,
4118                              saved_expr2)),
4119                   ffecom_2 (MINUS_EXPR, tree_type,
4120                             saved_expr1,
4121                             saved_expr2),
4122                   convert (tree_type, ffecom_float_zero_));
4123
4124     case FFEINTRIN_impDPROD:
4125       return
4126         ffecom_2 (MULT_EXPR, tree_type,
4127                   convert (tree_type, ffecom_expr (arg1)),
4128                   convert (tree_type, ffecom_expr (arg2)));
4129
4130     case FFEINTRIN_impEXP:
4131     case FFEINTRIN_impCDEXP:
4132     case FFEINTRIN_impCEXP:
4133     case FFEINTRIN_impDEXP:
4134       if (bt == FFEINFO_basictypeCOMPLEX)
4135         {
4136           if (kt == FFEINFO_kindtypeREAL1)
4137             gfrt = FFECOM_gfrtCEXP;     /* Overlapping result okay. */
4138           else if (kt == FFEINFO_kindtypeREAL2)
4139             gfrt = FFECOM_gfrtCDEXP;    /* Overlapping result okay. */
4140         }
4141       break;
4142
4143     case FFEINTRIN_impICHAR:
4144     case FFEINTRIN_impIACHAR:
4145 #if 0                           /* The simple approach. */
4146       ffecom_char_args_ (&expr_tree, &saved_expr1 /* Ignored */ , arg1);
4147       expr_tree
4148         = ffecom_1 (INDIRECT_REF,
4149                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4150                     expr_tree);
4151       expr_tree
4152         = ffecom_2 (ARRAY_REF,
4153                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4154                     expr_tree,
4155                     integer_one_node);
4156       return convert (tree_type, expr_tree);
4157 #else /* The more interesting (and more optimal) approach. */
4158       expr_tree = ffecom_intrinsic_ichar_ (tree_type, arg1, &saved_expr1);
4159       expr_tree = ffecom_3 (COND_EXPR, tree_type,
4160                             saved_expr1,
4161                             expr_tree,
4162                             convert (tree_type, integer_zero_node));
4163       return expr_tree;
4164 #endif
4165
4166     case FFEINTRIN_impINDEX:
4167       break;
4168
4169     case FFEINTRIN_impLEN:
4170 #if 0
4171       break;                                    /* The simple approach. */
4172 #else
4173       return ffecom_intrinsic_len_ (arg1);      /* The more optimal approach. */
4174 #endif
4175
4176     case FFEINTRIN_impLGE:
4177     case FFEINTRIN_impLGT:
4178     case FFEINTRIN_impLLE:
4179     case FFEINTRIN_impLLT:
4180       break;
4181
4182     case FFEINTRIN_impLOG:
4183     case FFEINTRIN_impALOG:
4184     case FFEINTRIN_impCDLOG:
4185     case FFEINTRIN_impCLOG:
4186     case FFEINTRIN_impDLOG:
4187       if (bt == FFEINFO_basictypeCOMPLEX)
4188         {
4189           if (kt == FFEINFO_kindtypeREAL1)
4190             gfrt = FFECOM_gfrtCLOG;     /* Overlapping result okay. */
4191           else if (kt == FFEINFO_kindtypeREAL2)
4192             gfrt = FFECOM_gfrtCDLOG;    /* Overlapping result okay. */
4193         }
4194       break;
4195
4196     case FFEINTRIN_impLOG10:
4197     case FFEINTRIN_impALOG10:
4198     case FFEINTRIN_impDLOG10:
4199       if (gfrt != FFECOM_gfrt)
4200         break;  /* Already picked one, stick with it. */
4201
4202       if (kt == FFEINFO_kindtypeREAL1)
4203         /* We used to call FFECOM_gfrtALOG10 here.  */
4204         gfrt = FFECOM_gfrtL_LOG10;
4205       else if (kt == FFEINFO_kindtypeREAL2)
4206         /* We used to call FFECOM_gfrtDLOG10 here.  */
4207         gfrt = FFECOM_gfrtL_LOG10;
4208       break;
4209
4210     case FFEINTRIN_impMAX:
4211     case FFEINTRIN_impAMAX0:
4212     case FFEINTRIN_impAMAX1:
4213     case FFEINTRIN_impDMAX1:
4214     case FFEINTRIN_impMAX0:
4215     case FFEINTRIN_impMAX1:
4216       if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4217         arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4218       else
4219         arg1_type = tree_type;
4220       expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4221                             convert (arg1_type, ffecom_expr (arg1)),
4222                             convert (arg1_type, ffecom_expr (arg2)));
4223       for (; list != NULL; list = ffebld_trail (list))
4224         {
4225           if ((ffebld_head (list) == NULL)
4226               || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4227             continue;
4228           expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4229                                 expr_tree,
4230                                 convert (arg1_type,
4231                                          ffecom_expr (ffebld_head (list))));
4232         }
4233       return convert (tree_type, expr_tree);
4234
4235     case FFEINTRIN_impMIN:
4236     case FFEINTRIN_impAMIN0:
4237     case FFEINTRIN_impAMIN1:
4238     case FFEINTRIN_impDMIN1:
4239     case FFEINTRIN_impMIN0:
4240     case FFEINTRIN_impMIN1:
4241       if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4242         arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4243       else
4244         arg1_type = tree_type;
4245       expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4246                             convert (arg1_type, ffecom_expr (arg1)),
4247                             convert (arg1_type, ffecom_expr (arg2)));
4248       for (; list != NULL; list = ffebld_trail (list))
4249         {
4250           if ((ffebld_head (list) == NULL)
4251               || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4252             continue;
4253           expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4254                                 expr_tree,
4255                                 convert (arg1_type,
4256                                          ffecom_expr (ffebld_head (list))));
4257         }
4258       return convert (tree_type, expr_tree);
4259
4260     case FFEINTRIN_impMOD:
4261     case FFEINTRIN_impAMOD:
4262     case FFEINTRIN_impDMOD:
4263       if (bt != FFEINFO_basictypeREAL)
4264         return ffecom_2 (TRUNC_MOD_EXPR, tree_type,
4265                          convert (tree_type, ffecom_expr (arg1)),
4266                          convert (tree_type, ffecom_expr (arg2)));
4267
4268       if (kt == FFEINFO_kindtypeREAL1)
4269         /* We used to call FFECOM_gfrtAMOD here.  */
4270         gfrt = FFECOM_gfrtL_FMOD;
4271       else if (kt == FFEINFO_kindtypeREAL2)
4272         /* We used to call FFECOM_gfrtDMOD here.  */
4273         gfrt = FFECOM_gfrtL_FMOD;
4274       break;
4275
4276     case FFEINTRIN_impNINT:
4277     case FFEINTRIN_impIDNINT:
4278 #if 0
4279       /* ~~Ideally FIX_ROUND_EXPR would be implemented, but it ain't yet.  */
4280       return ffecom_1 (FIX_ROUND_EXPR, tree_type, ffecom_expr (arg1));
4281 #else
4282       /* i__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1); */
4283       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4284       return
4285         convert (ffecom_integer_type_node,
4286                  ffecom_3 (COND_EXPR, arg1_type,
4287                            ffecom_truth_value
4288                            (ffecom_2 (GE_EXPR, integer_type_node,
4289                                       saved_expr1,
4290                                       convert (arg1_type,
4291                                                ffecom_float_zero_))),
4292                            ffecom_2 (PLUS_EXPR, arg1_type,
4293                                      saved_expr1,
4294                                      convert (arg1_type,
4295                                               ffecom_float_half_)),
4296                            ffecom_2 (MINUS_EXPR, arg1_type,
4297                                      saved_expr1,
4298                                      convert (arg1_type,
4299                                               ffecom_float_half_))));
4300 #endif
4301
4302     case FFEINTRIN_impSIGN:
4303     case FFEINTRIN_impDSIGN:
4304     case FFEINTRIN_impISIGN:
4305       {
4306         tree arg2_tree = ffecom_expr (arg2);
4307
4308         saved_expr1
4309           = ffecom_save_tree
4310           (ffecom_1 (ABS_EXPR, tree_type,
4311                      convert (tree_type,
4312                               ffecom_expr (arg1))));
4313         expr_tree
4314           = ffecom_3 (COND_EXPR, tree_type,
4315                       ffecom_truth_value
4316                       (ffecom_2 (GE_EXPR, integer_type_node,
4317                                  arg2_tree,
4318                                  convert (TREE_TYPE (arg2_tree),
4319                                           integer_zero_node))),
4320                       saved_expr1,
4321                       ffecom_1 (NEGATE_EXPR, tree_type, saved_expr1));
4322         /* Make sure SAVE_EXPRs get referenced early enough. */
4323         expr_tree
4324           = ffecom_2 (COMPOUND_EXPR, tree_type,
4325                       convert (void_type_node, saved_expr1),
4326                       expr_tree);
4327       }
4328       return expr_tree;
4329
4330     case FFEINTRIN_impSIN:
4331     case FFEINTRIN_impCDSIN:
4332     case FFEINTRIN_impCSIN:
4333     case FFEINTRIN_impDSIN:
4334       if (bt == FFEINFO_basictypeCOMPLEX)
4335         {
4336           if (kt == FFEINFO_kindtypeREAL1)
4337             gfrt = FFECOM_gfrtCSIN;     /* Overlapping result okay. */
4338           else if (kt == FFEINFO_kindtypeREAL2)
4339             gfrt = FFECOM_gfrtCDSIN;    /* Overlapping result okay. */
4340         }
4341       break;
4342
4343     case FFEINTRIN_impSINH:
4344     case FFEINTRIN_impDSINH:
4345       break;
4346
4347     case FFEINTRIN_impSQRT:
4348     case FFEINTRIN_impCDSQRT:
4349     case FFEINTRIN_impCSQRT:
4350     case FFEINTRIN_impDSQRT:
4351       if (bt == FFEINFO_basictypeCOMPLEX)
4352         {
4353           if (kt == FFEINFO_kindtypeREAL1)
4354             gfrt = FFECOM_gfrtCSQRT;    /* Overlapping result okay. */
4355           else if (kt == FFEINFO_kindtypeREAL2)
4356             gfrt = FFECOM_gfrtCDSQRT;   /* Overlapping result okay. */
4357         }
4358       break;
4359
4360     case FFEINTRIN_impTAN:
4361     case FFEINTRIN_impDTAN:
4362     case FFEINTRIN_impTANH:
4363     case FFEINTRIN_impDTANH:
4364       break;
4365
4366     case FFEINTRIN_impREALPART:
4367       if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
4368         arg1_type = TREE_TYPE (arg1_type);
4369       else
4370         arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
4371
4372       return
4373         convert (tree_type,
4374                  ffecom_1 (REALPART_EXPR, arg1_type,
4375                            ffecom_expr (arg1)));
4376
4377     case FFEINTRIN_impIAND:
4378     case FFEINTRIN_impAND:
4379       return ffecom_2 (BIT_AND_EXPR, tree_type,
4380                        convert (tree_type,
4381                                 ffecom_expr (arg1)),
4382                        convert (tree_type,
4383                                 ffecom_expr (arg2)));
4384
4385     case FFEINTRIN_impIOR:
4386     case FFEINTRIN_impOR:
4387       return ffecom_2 (BIT_IOR_EXPR, tree_type,
4388                        convert (tree_type,
4389                                 ffecom_expr (arg1)),
4390                        convert (tree_type,
4391                                 ffecom_expr (arg2)));
4392
4393     case FFEINTRIN_impIEOR:
4394     case FFEINTRIN_impXOR:
4395       return ffecom_2 (BIT_XOR_EXPR, tree_type,
4396                        convert (tree_type,
4397                                 ffecom_expr (arg1)),
4398                        convert (tree_type,
4399                                 ffecom_expr (arg2)));
4400
4401     case FFEINTRIN_impLSHIFT:
4402       return ffecom_2 (LSHIFT_EXPR, tree_type,
4403                        ffecom_expr (arg1),
4404                        convert (integer_type_node,
4405                                 ffecom_expr (arg2)));
4406
4407     case FFEINTRIN_impRSHIFT:
4408       return ffecom_2 (RSHIFT_EXPR, tree_type,
4409                        ffecom_expr (arg1),
4410                        convert (integer_type_node,
4411                                 ffecom_expr (arg2)));
4412
4413     case FFEINTRIN_impNOT:
4414       return ffecom_1 (BIT_NOT_EXPR, tree_type, ffecom_expr (arg1));
4415
4416     case FFEINTRIN_impBIT_SIZE:
4417       return convert (tree_type, TYPE_SIZE (arg1_type));
4418
4419     case FFEINTRIN_impBTEST:
4420       {
4421         ffetargetLogical1 target_true;
4422         ffetargetLogical1 target_false;
4423         tree true_tree;
4424         tree false_tree;
4425
4426         ffetarget_logical1 (&target_true, TRUE);
4427         ffetarget_logical1 (&target_false, FALSE);
4428         if (target_true == 1)
4429           true_tree = convert (tree_type, integer_one_node);
4430         else
4431           true_tree = convert (tree_type, build_int_2 (target_true, 0));
4432         if (target_false == 0)
4433           false_tree = convert (tree_type, integer_zero_node);
4434         else
4435           false_tree = convert (tree_type, build_int_2 (target_false, 0));
4436
4437         return
4438           ffecom_3 (COND_EXPR, tree_type,
4439                     ffecom_truth_value
4440                     (ffecom_2 (EQ_EXPR, integer_type_node,
4441                                ffecom_2 (BIT_AND_EXPR, arg1_type,
4442                                          ffecom_expr (arg1),
4443                                          ffecom_2 (LSHIFT_EXPR, arg1_type,
4444                                                    convert (arg1_type,
4445                                                           integer_one_node),
4446                                                    convert (integer_type_node,
4447                                                             ffecom_expr (arg2)))),
4448                                convert (arg1_type,
4449                                         integer_zero_node))),
4450                     false_tree,
4451                     true_tree);
4452       }
4453
4454     case FFEINTRIN_impIBCLR:
4455       return
4456         ffecom_2 (BIT_AND_EXPR, tree_type,
4457                   ffecom_expr (arg1),
4458                   ffecom_1 (BIT_NOT_EXPR, tree_type,
4459                             ffecom_2 (LSHIFT_EXPR, tree_type,
4460                                       convert (tree_type,
4461                                                integer_one_node),
4462                                       convert (integer_type_node,
4463                                                ffecom_expr (arg2)))));
4464
4465     case FFEINTRIN_impIBITS:
4466       {
4467         tree arg3_tree = ffecom_save_tree (convert (integer_type_node,
4468                                                     ffecom_expr (arg3)));
4469         tree uns_type
4470         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4471
4472         expr_tree
4473           = ffecom_2 (BIT_AND_EXPR, tree_type,
4474                       ffecom_2 (RSHIFT_EXPR, tree_type,
4475                                 ffecom_expr (arg1),
4476                                 convert (integer_type_node,
4477                                          ffecom_expr (arg2))),
4478                       convert (tree_type,
4479                                ffecom_2 (RSHIFT_EXPR, uns_type,
4480                                          ffecom_1 (BIT_NOT_EXPR,
4481                                                    uns_type,
4482                                                    convert (uns_type,
4483                                                         integer_zero_node)),
4484                                          ffecom_2 (MINUS_EXPR,
4485                                                    integer_type_node,
4486                                                    TYPE_SIZE (uns_type),
4487                                                    arg3_tree))));
4488         /* Fix up, because the RSHIFT_EXPR above can't shift over TYPE_SIZE.  */
4489         expr_tree
4490           = ffecom_3 (COND_EXPR, tree_type,
4491                       ffecom_truth_value
4492                       (ffecom_2 (NE_EXPR, integer_type_node,
4493                                  arg3_tree,
4494                                  integer_zero_node)),
4495                       expr_tree,
4496                       convert (tree_type, integer_zero_node));
4497       }
4498       return expr_tree;
4499
4500     case FFEINTRIN_impIBSET:
4501       return
4502         ffecom_2 (BIT_IOR_EXPR, tree_type,
4503                   ffecom_expr (arg1),
4504                   ffecom_2 (LSHIFT_EXPR, tree_type,
4505                             convert (tree_type, integer_one_node),
4506                             convert (integer_type_node,
4507                                      ffecom_expr (arg2))));
4508
4509     case FFEINTRIN_impISHFT:
4510       {
4511         tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4512         tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4513                                                     ffecom_expr (arg2)));
4514         tree uns_type
4515         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4516
4517         expr_tree
4518           = ffecom_3 (COND_EXPR, tree_type,
4519                       ffecom_truth_value
4520                       (ffecom_2 (GE_EXPR, integer_type_node,
4521                                  arg2_tree,
4522                                  integer_zero_node)),
4523                       ffecom_2 (LSHIFT_EXPR, tree_type,
4524                                 arg1_tree,
4525                                 arg2_tree),
4526                       convert (tree_type,
4527                                ffecom_2 (RSHIFT_EXPR, uns_type,
4528                                          convert (uns_type, arg1_tree),
4529                                          ffecom_1 (NEGATE_EXPR,
4530                                                    integer_type_node,
4531                                                    arg2_tree))));
4532         /* Fix up, because {L|R}SHIFT_EXPR don't go over TYPE_SIZE bounds.  */
4533         expr_tree
4534           = ffecom_3 (COND_EXPR, tree_type,
4535                       ffecom_truth_value
4536                       (ffecom_2 (NE_EXPR, integer_type_node,
4537                                  ffecom_1 (ABS_EXPR,
4538                                            integer_type_node,
4539                                            arg2_tree),
4540                                  TYPE_SIZE (uns_type))),
4541                       expr_tree,
4542                       convert (tree_type, integer_zero_node));
4543         /* Make sure SAVE_EXPRs get referenced early enough. */
4544         expr_tree
4545           = ffecom_2 (COMPOUND_EXPR, tree_type,
4546                       convert (void_type_node, arg1_tree),
4547                       ffecom_2 (COMPOUND_EXPR, tree_type,
4548                                 convert (void_type_node, arg2_tree),
4549                                 expr_tree));
4550       }
4551       return expr_tree;
4552
4553     case FFEINTRIN_impISHFTC:
4554       {
4555         tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4556         tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4557                                                     ffecom_expr (arg2)));
4558         tree arg3_tree = (arg3 == NULL) ? TYPE_SIZE (tree_type)
4559         : ffecom_save_tree (convert (integer_type_node, ffecom_expr (arg3)));
4560         tree shift_neg;
4561         tree shift_pos;
4562         tree mask_arg1;
4563         tree masked_arg1;
4564         tree uns_type
4565         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4566
4567         mask_arg1
4568           = ffecom_2 (LSHIFT_EXPR, tree_type,
4569                       ffecom_1 (BIT_NOT_EXPR, tree_type,
4570                                 convert (tree_type, integer_zero_node)),
4571                       arg3_tree);
4572         /* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE.  */
4573         mask_arg1
4574           = ffecom_3 (COND_EXPR, tree_type,
4575                       ffecom_truth_value
4576                       (ffecom_2 (NE_EXPR, integer_type_node,
4577                                  arg3_tree,
4578                                  TYPE_SIZE (uns_type))),
4579                       mask_arg1,
4580                       convert (tree_type, integer_zero_node));
4581         mask_arg1 = ffecom_save_tree (mask_arg1);
4582         masked_arg1
4583           = ffecom_2 (BIT_AND_EXPR, tree_type,
4584                       arg1_tree,
4585                       ffecom_1 (BIT_NOT_EXPR, tree_type,
4586                                 mask_arg1));
4587         masked_arg1 = ffecom_save_tree (masked_arg1);
4588         shift_neg
4589           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4590                       convert (tree_type,
4591                                ffecom_2 (RSHIFT_EXPR, uns_type,
4592                                          convert (uns_type, masked_arg1),
4593                                          ffecom_1 (NEGATE_EXPR,
4594                                                    integer_type_node,
4595                                                    arg2_tree))),
4596                       ffecom_2 (LSHIFT_EXPR, tree_type,
4597                                 arg1_tree,
4598                                 ffecom_2 (PLUS_EXPR, integer_type_node,
4599                                           arg2_tree,
4600                                           arg3_tree)));
4601         shift_pos
4602           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4603                       ffecom_2 (LSHIFT_EXPR, tree_type,
4604                                 arg1_tree,
4605                                 arg2_tree),
4606                       convert (tree_type,
4607                                ffecom_2 (RSHIFT_EXPR, uns_type,
4608                                          convert (uns_type, masked_arg1),
4609                                          ffecom_2 (MINUS_EXPR,
4610                                                    integer_type_node,
4611                                                    arg3_tree,
4612                                                    arg2_tree))));
4613         expr_tree
4614           = ffecom_3 (COND_EXPR, tree_type,
4615                       ffecom_truth_value
4616                       (ffecom_2 (LT_EXPR, integer_type_node,
4617                                  arg2_tree,
4618                                  integer_zero_node)),
4619                       shift_neg,
4620                       shift_pos);
4621         expr_tree
4622           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4623                       ffecom_2 (BIT_AND_EXPR, tree_type,
4624                                 mask_arg1,
4625                                 arg1_tree),
4626                       ffecom_2 (BIT_AND_EXPR, tree_type,
4627                                 ffecom_1 (BIT_NOT_EXPR, tree_type,
4628                                           mask_arg1),
4629                                 expr_tree));
4630         expr_tree
4631           = ffecom_3 (COND_EXPR, tree_type,
4632                       ffecom_truth_value
4633                       (ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
4634                                  ffecom_2 (EQ_EXPR, integer_type_node,
4635                                            ffecom_1 (ABS_EXPR,
4636                                                      integer_type_node,
4637                                                      arg2_tree),
4638                                            arg3_tree),
4639                                  ffecom_2 (EQ_EXPR, integer_type_node,
4640                                            arg2_tree,
4641                                            integer_zero_node))),
4642                       arg1_tree,
4643                       expr_tree);
4644         /* Make sure SAVE_EXPRs get referenced early enough. */
4645         expr_tree
4646           = ffecom_2 (COMPOUND_EXPR, tree_type,
4647                       convert (void_type_node, arg1_tree),
4648                       ffecom_2 (COMPOUND_EXPR, tree_type,
4649                                 convert (void_type_node, arg2_tree),
4650                                 ffecom_2 (COMPOUND_EXPR, tree_type,
4651                                           convert (void_type_node,
4652                                                    mask_arg1),
4653                                           ffecom_2 (COMPOUND_EXPR, tree_type,
4654                                                     convert (void_type_node,
4655                                                              masked_arg1),
4656                                                     expr_tree))));
4657         expr_tree
4658           = ffecom_2 (COMPOUND_EXPR, tree_type,
4659                       convert (void_type_node,
4660                                arg3_tree),
4661                       expr_tree);
4662       }
4663       return expr_tree;
4664
4665     case FFEINTRIN_impLOC:
4666       {
4667         tree arg1_tree = ffecom_expr (arg1);
4668
4669         expr_tree
4670           = convert (tree_type,
4671                      ffecom_1 (ADDR_EXPR,
4672                                build_pointer_type (TREE_TYPE (arg1_tree)),
4673                                arg1_tree));
4674       }
4675       return expr_tree;
4676
4677     case FFEINTRIN_impMVBITS:
4678       {
4679         tree arg1_tree;
4680         tree arg2_tree;
4681         tree arg3_tree;
4682         ffebld arg4 = ffebld_head (ffebld_trail (list));
4683         tree arg4_tree;
4684         tree arg4_type;
4685         ffebld arg5 = ffebld_head (ffebld_trail (ffebld_trail (list)));
4686         tree arg5_tree;
4687         tree prep_arg1;
4688         tree prep_arg4;
4689         tree arg5_plus_arg3;
4690
4691         arg2_tree = convert (integer_type_node,
4692                              ffecom_expr (arg2));
4693         arg3_tree = ffecom_save_tree (convert (integer_type_node,
4694                                                ffecom_expr (arg3)));
4695         arg4_tree = ffecom_expr_rw (NULL_TREE, arg4);
4696         arg4_type = TREE_TYPE (arg4_tree);
4697
4698         arg1_tree = ffecom_save_tree (convert (arg4_type,
4699                                                ffecom_expr (arg1)));
4700
4701         arg5_tree = ffecom_save_tree (convert (integer_type_node,
4702                                                ffecom_expr (arg5)));
4703
4704         prep_arg1
4705           = ffecom_2 (LSHIFT_EXPR, arg4_type,
4706                       ffecom_2 (BIT_AND_EXPR, arg4_type,
4707                                 ffecom_2 (RSHIFT_EXPR, arg4_type,
4708                                           arg1_tree,
4709                                           arg2_tree),
4710                                 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4711                                           ffecom_2 (LSHIFT_EXPR, arg4_type,
4712                                                     ffecom_1 (BIT_NOT_EXPR,
4713                                                               arg4_type,
4714                                                               convert
4715                                                               (arg4_type,
4716                                                         integer_zero_node)),
4717                                                     arg3_tree))),
4718                       arg5_tree);
4719         arg5_plus_arg3
4720           = ffecom_save_tree (ffecom_2 (PLUS_EXPR, arg4_type,
4721                                         arg5_tree,
4722                                         arg3_tree));
4723         prep_arg4
4724           = ffecom_2 (LSHIFT_EXPR, arg4_type,
4725                       ffecom_1 (BIT_NOT_EXPR, arg4_type,
4726                                 convert (arg4_type,
4727                                          integer_zero_node)),
4728                       arg5_plus_arg3);
4729         /* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE.  */
4730         prep_arg4
4731           = ffecom_3 (COND_EXPR, arg4_type,
4732                       ffecom_truth_value
4733                       (ffecom_2 (NE_EXPR, integer_type_node,
4734                                  arg5_plus_arg3,
4735                                  convert (TREE_TYPE (arg5_plus_arg3),
4736                                           TYPE_SIZE (arg4_type)))),
4737                       prep_arg4,
4738                       convert (arg4_type, integer_zero_node));
4739         prep_arg4
4740           = ffecom_2 (BIT_AND_EXPR, arg4_type,
4741                       arg4_tree,
4742                       ffecom_2 (BIT_IOR_EXPR, arg4_type,
4743                                 prep_arg4,
4744                                 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4745                                           ffecom_2 (LSHIFT_EXPR, arg4_type,
4746                                                     ffecom_1 (BIT_NOT_EXPR,
4747                                                               arg4_type,
4748                                                               convert
4749                                                               (arg4_type,
4750                                                         integer_zero_node)),
4751                                                     arg5_tree))));
4752         prep_arg1
4753           = ffecom_2 (BIT_IOR_EXPR, arg4_type,
4754                       prep_arg1,
4755                       prep_arg4);
4756         /* Fix up (twice), because LSHIFT_EXPR above
4757            can't shift over TYPE_SIZE.  */
4758         prep_arg1
4759           = ffecom_3 (COND_EXPR, arg4_type,
4760                       ffecom_truth_value
4761                       (ffecom_2 (NE_EXPR, integer_type_node,
4762                                  arg3_tree,
4763                                  convert (TREE_TYPE (arg3_tree),
4764                                           integer_zero_node))),
4765                       prep_arg1,
4766                       arg4_tree);
4767         prep_arg1
4768           = ffecom_3 (COND_EXPR, arg4_type,
4769                       ffecom_truth_value
4770                       (ffecom_2 (NE_EXPR, integer_type_node,
4771                                  arg3_tree,
4772                                  convert (TREE_TYPE (arg3_tree),
4773                                           TYPE_SIZE (arg4_type)))),
4774                       prep_arg1,
4775                       arg1_tree);
4776         expr_tree
4777           = ffecom_2s (MODIFY_EXPR, void_type_node,
4778                        arg4_tree,
4779                        prep_arg1);
4780         /* Make sure SAVE_EXPRs get referenced early enough. */
4781         expr_tree
4782           = ffecom_2 (COMPOUND_EXPR, void_type_node,
4783                       arg1_tree,
4784                       ffecom_2 (COMPOUND_EXPR, void_type_node,
4785                                 arg3_tree,
4786                                 ffecom_2 (COMPOUND_EXPR, void_type_node,
4787                                           arg5_tree,
4788                                           ffecom_2 (COMPOUND_EXPR, void_type_node,
4789                                                     arg5_plus_arg3,
4790                                                     expr_tree))));
4791         expr_tree
4792           = ffecom_2 (COMPOUND_EXPR, void_type_node,
4793                       arg4_tree,
4794                       expr_tree);
4795
4796       }
4797       return expr_tree;
4798
4799     case FFEINTRIN_impDERF:
4800     case FFEINTRIN_impERF:
4801     case FFEINTRIN_impDERFC:
4802     case FFEINTRIN_impERFC:
4803       break;
4804
4805     case FFEINTRIN_impIARGC:
4806       /* extern int xargc; i__1 = xargc - 1; */
4807       expr_tree = ffecom_2 (MINUS_EXPR, TREE_TYPE (ffecom_tree_xargc_),
4808                             ffecom_tree_xargc_,
4809                             convert (TREE_TYPE (ffecom_tree_xargc_),
4810                                      integer_one_node));
4811       return expr_tree;
4812
4813     case FFEINTRIN_impSIGNAL_func:
4814     case FFEINTRIN_impSIGNAL_subr:
4815       {
4816         tree arg1_tree;
4817         tree arg2_tree;
4818         tree arg3_tree;
4819
4820         arg1_tree = convert (ffecom_f2c_integer_type_node,
4821                              ffecom_expr (arg1));
4822         arg1_tree = ffecom_1 (ADDR_EXPR,
4823                               build_pointer_type (TREE_TYPE (arg1_tree)),
4824                               arg1_tree);
4825
4826         /* Pass procedure as a pointer to it, anything else by value.  */
4827         if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
4828           arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
4829         else
4830           arg2_tree = ffecom_ptr_to_expr (arg2);
4831         arg2_tree = convert (TREE_TYPE (null_pointer_node),
4832                              arg2_tree);
4833
4834         if (arg3 != NULL)
4835           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
4836         else
4837           arg3_tree = NULL_TREE;
4838
4839         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4840         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4841         TREE_CHAIN (arg1_tree) = arg2_tree;
4842
4843         expr_tree
4844           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4845                           ffecom_gfrt_kindtype (gfrt),
4846                           FALSE,
4847                           ((codegen_imp == FFEINTRIN_impSIGNAL_subr) ?
4848                            NULL_TREE :
4849                            tree_type),
4850                           arg1_tree,
4851                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4852                           ffebld_nonter_hook (expr));
4853
4854         if (arg3_tree != NULL_TREE)
4855           expr_tree
4856             = ffecom_modify (NULL_TREE, arg3_tree,
4857                              convert (TREE_TYPE (arg3_tree),
4858                                       expr_tree));
4859       }
4860       return expr_tree;
4861
4862     case FFEINTRIN_impALARM:
4863       {
4864         tree arg1_tree;
4865         tree arg2_tree;
4866         tree arg3_tree;
4867
4868         arg1_tree = convert (ffecom_f2c_integer_type_node,
4869                              ffecom_expr (arg1));
4870         arg1_tree = ffecom_1 (ADDR_EXPR,
4871                               build_pointer_type (TREE_TYPE (arg1_tree)),
4872                               arg1_tree);
4873
4874         /* Pass procedure as a pointer to it, anything else by value.  */
4875         if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
4876           arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
4877         else
4878           arg2_tree = ffecom_ptr_to_expr (arg2);
4879         arg2_tree = convert (TREE_TYPE (null_pointer_node),
4880                              arg2_tree);
4881
4882         if (arg3 != NULL)
4883           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
4884         else
4885           arg3_tree = NULL_TREE;
4886
4887         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4888         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4889         TREE_CHAIN (arg1_tree) = arg2_tree;
4890
4891         expr_tree
4892           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4893                           ffecom_gfrt_kindtype (gfrt),
4894                           FALSE,
4895                           NULL_TREE,
4896                           arg1_tree,
4897                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4898                           ffebld_nonter_hook (expr));
4899
4900         if (arg3_tree != NULL_TREE)
4901           expr_tree
4902             = ffecom_modify (NULL_TREE, arg3_tree,
4903                              convert (TREE_TYPE (arg3_tree),
4904                                       expr_tree));
4905       }
4906       return expr_tree;
4907
4908     case FFEINTRIN_impCHDIR_subr:
4909     case FFEINTRIN_impFDATE_subr:
4910     case FFEINTRIN_impFGET_subr:
4911     case FFEINTRIN_impFPUT_subr:
4912     case FFEINTRIN_impGETCWD_subr:
4913     case FFEINTRIN_impHOSTNM_subr:
4914     case FFEINTRIN_impSYSTEM_subr:
4915     case FFEINTRIN_impUNLINK_subr:
4916       {
4917         tree arg1_len = integer_zero_node;
4918         tree arg1_tree;
4919         tree arg2_tree;
4920
4921         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
4922
4923         if (arg2 != NULL)
4924           arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
4925         else
4926           arg2_tree = NULL_TREE;
4927
4928         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4929         arg1_len = build_tree_list (NULL_TREE, arg1_len);
4930         TREE_CHAIN (arg1_tree) = arg1_len;
4931
4932         expr_tree
4933           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4934                           ffecom_gfrt_kindtype (gfrt),
4935                           FALSE,
4936                           NULL_TREE,
4937                           arg1_tree,
4938                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4939                           ffebld_nonter_hook (expr));
4940
4941         if (arg2_tree != NULL_TREE)
4942           expr_tree
4943             = ffecom_modify (NULL_TREE, arg2_tree,
4944                              convert (TREE_TYPE (arg2_tree),
4945                                       expr_tree));
4946       }
4947       return expr_tree;
4948
4949     case FFEINTRIN_impEXIT:
4950       if (arg1 != NULL)
4951         break;
4952
4953       expr_tree = build_tree_list (NULL_TREE,
4954                                    ffecom_1 (ADDR_EXPR,
4955                                              build_pointer_type
4956                                              (ffecom_integer_type_node),
4957                                              integer_zero_node));
4958
4959       return
4960         ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4961                       ffecom_gfrt_kindtype (gfrt),
4962                       FALSE,
4963                       void_type_node,
4964                       expr_tree,
4965                       NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4966                       ffebld_nonter_hook (expr));
4967
4968     case FFEINTRIN_impFLUSH:
4969       if (arg1 == NULL)
4970         gfrt = FFECOM_gfrtFLUSH;
4971       else
4972         gfrt = FFECOM_gfrtFLUSH1;
4973       break;
4974
4975     case FFEINTRIN_impCHMOD_subr:
4976     case FFEINTRIN_impLINK_subr:
4977     case FFEINTRIN_impRENAME_subr:
4978     case FFEINTRIN_impSYMLNK_subr:
4979       {
4980         tree arg1_len = integer_zero_node;
4981         tree arg1_tree;
4982         tree arg2_len = integer_zero_node;
4983         tree arg2_tree;
4984         tree arg3_tree;
4985
4986         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
4987         arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
4988         if (arg3 != NULL)
4989           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
4990         else
4991           arg3_tree = NULL_TREE;
4992
4993         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4994         arg1_len = build_tree_list (NULL_TREE, arg1_len);
4995         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4996         arg2_len = build_tree_list (NULL_TREE, arg2_len);
4997         TREE_CHAIN (arg1_tree) = arg2_tree;
4998         TREE_CHAIN (arg2_tree) = arg1_len;
4999         TREE_CHAIN (arg1_len) = arg2_len;
5000         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5001                                   ffecom_gfrt_kindtype (gfrt),
5002                                   FALSE,
5003                                   NULL_TREE,
5004                                   arg1_tree,
5005                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5006                                   ffebld_nonter_hook (expr));
5007         if (arg3_tree != NULL_TREE)
5008           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5009                                      convert (TREE_TYPE (arg3_tree),
5010                                               expr_tree));
5011       }
5012       return expr_tree;
5013
5014     case FFEINTRIN_impLSTAT_subr:
5015     case FFEINTRIN_impSTAT_subr:
5016       {
5017         tree arg1_len = integer_zero_node;
5018         tree arg1_tree;
5019         tree arg2_tree;
5020         tree arg3_tree;
5021
5022         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5023
5024         arg2_tree = ffecom_ptr_to_expr (arg2);
5025
5026         if (arg3 != NULL)
5027           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5028         else
5029           arg3_tree = NULL_TREE;
5030
5031         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5032         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5033         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5034         TREE_CHAIN (arg1_tree) = arg2_tree;
5035         TREE_CHAIN (arg2_tree) = arg1_len;
5036         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5037                                   ffecom_gfrt_kindtype (gfrt),
5038                                   FALSE,
5039                                   NULL_TREE,
5040                                   arg1_tree,
5041                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5042                                   ffebld_nonter_hook (expr));
5043         if (arg3_tree != NULL_TREE)
5044           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5045                                      convert (TREE_TYPE (arg3_tree),
5046                                               expr_tree));
5047       }
5048       return expr_tree;
5049
5050     case FFEINTRIN_impFGETC_subr:
5051     case FFEINTRIN_impFPUTC_subr:
5052       {
5053         tree arg1_tree;
5054         tree arg2_tree;
5055         tree arg2_len = integer_zero_node;
5056         tree arg3_tree;
5057
5058         arg1_tree = convert (ffecom_f2c_integer_type_node,
5059                              ffecom_expr (arg1));
5060         arg1_tree = ffecom_1 (ADDR_EXPR,
5061                               build_pointer_type (TREE_TYPE (arg1_tree)),
5062                               arg1_tree);
5063
5064         arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
5065         if (arg3 != NULL)
5066           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5067         else
5068           arg3_tree = NULL_TREE;
5069
5070         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5071         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5072         arg2_len = build_tree_list (NULL_TREE, arg2_len);
5073         TREE_CHAIN (arg1_tree) = arg2_tree;
5074         TREE_CHAIN (arg2_tree) = arg2_len;
5075
5076         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5077                                   ffecom_gfrt_kindtype (gfrt),
5078                                   FALSE,
5079                                   NULL_TREE,
5080                                   arg1_tree,
5081                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5082                                   ffebld_nonter_hook (expr));
5083         if (arg3_tree != NULL_TREE)
5084           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5085                                      convert (TREE_TYPE (arg3_tree),
5086                                               expr_tree));
5087       }
5088       return expr_tree;
5089
5090     case FFEINTRIN_impFSTAT_subr:
5091       {
5092         tree arg1_tree;
5093         tree arg2_tree;
5094         tree arg3_tree;
5095
5096         arg1_tree = convert (ffecom_f2c_integer_type_node,
5097                              ffecom_expr (arg1));
5098         arg1_tree = ffecom_1 (ADDR_EXPR,
5099                               build_pointer_type (TREE_TYPE (arg1_tree)),
5100                               arg1_tree);
5101
5102         arg2_tree = convert (ffecom_f2c_ptr_to_integer_type_node,
5103                              ffecom_ptr_to_expr (arg2));
5104
5105         if (arg3 == NULL)
5106           arg3_tree = NULL_TREE;
5107         else
5108           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5109
5110         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5111         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5112         TREE_CHAIN (arg1_tree) = arg2_tree;
5113         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5114                                   ffecom_gfrt_kindtype (gfrt),
5115                                   FALSE,
5116                                   NULL_TREE,
5117                                   arg1_tree,
5118                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5119                                   ffebld_nonter_hook (expr));
5120         if (arg3_tree != NULL_TREE) {
5121           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5122                                      convert (TREE_TYPE (arg3_tree),
5123                                               expr_tree));
5124         }
5125       }
5126       return expr_tree;
5127
5128     case FFEINTRIN_impKILL_subr:
5129       {
5130         tree arg1_tree;
5131         tree arg2_tree;
5132         tree arg3_tree;
5133
5134         arg1_tree = convert (ffecom_f2c_integer_type_node,
5135                              ffecom_expr (arg1));
5136         arg1_tree = ffecom_1 (ADDR_EXPR,
5137                               build_pointer_type (TREE_TYPE (arg1_tree)),
5138                               arg1_tree);
5139
5140         arg2_tree = convert (ffecom_f2c_integer_type_node,
5141                              ffecom_expr (arg2));
5142         arg2_tree = ffecom_1 (ADDR_EXPR,
5143                               build_pointer_type (TREE_TYPE (arg2_tree)),
5144                               arg2_tree);
5145
5146         if (arg3 == NULL)
5147           arg3_tree = NULL_TREE;
5148         else
5149           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5150
5151         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5152         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5153         TREE_CHAIN (arg1_tree) = arg2_tree;
5154         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5155                                   ffecom_gfrt_kindtype (gfrt),
5156                                   FALSE,
5157                                   NULL_TREE,
5158                                   arg1_tree,
5159                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5160                                   ffebld_nonter_hook (expr));
5161         if (arg3_tree != NULL_TREE) {
5162           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5163                                      convert (TREE_TYPE (arg3_tree),
5164                                               expr_tree));
5165         }
5166       }
5167       return expr_tree;
5168
5169     case FFEINTRIN_impCTIME_subr:
5170     case FFEINTRIN_impTTYNAM_subr:
5171       {
5172         tree arg1_len = integer_zero_node;
5173         tree arg1_tree;
5174         tree arg2_tree;
5175
5176         arg1_tree = ffecom_arg_ptr_to_expr (arg2, &arg1_len);
5177
5178         arg2_tree = convert (((codegen_imp == FFEINTRIN_impCTIME_subr) ?
5179                               ffecom_f2c_longint_type_node :
5180                               ffecom_f2c_integer_type_node),
5181                              ffecom_expr (arg1));
5182         arg2_tree = ffecom_1 (ADDR_EXPR,
5183                               build_pointer_type (TREE_TYPE (arg2_tree)),
5184                               arg2_tree);
5185
5186         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5187         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5188         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5189         TREE_CHAIN (arg1_len) = arg2_tree;
5190         TREE_CHAIN (arg1_tree) = arg1_len;
5191
5192         expr_tree
5193           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5194                           ffecom_gfrt_kindtype (gfrt),
5195                           FALSE,
5196                           NULL_TREE,
5197                           arg1_tree,
5198                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5199                           ffebld_nonter_hook (expr));
5200         TREE_SIDE_EFFECTS (expr_tree) = 1;
5201       }
5202       return expr_tree;
5203
5204     case FFEINTRIN_impIRAND:
5205     case FFEINTRIN_impRAND:
5206       /* Arg defaults to 0 (normal random case) */
5207       {
5208         tree arg1_tree;
5209
5210         if (arg1 == NULL)
5211           arg1_tree = ffecom_integer_zero_node;
5212         else
5213           arg1_tree = ffecom_expr (arg1);
5214         arg1_tree = convert (ffecom_f2c_integer_type_node,
5215                              arg1_tree);
5216         arg1_tree = ffecom_1 (ADDR_EXPR,
5217                               build_pointer_type (TREE_TYPE (arg1_tree)),
5218                               arg1_tree);
5219         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5220
5221         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5222                                   ffecom_gfrt_kindtype (gfrt),
5223                                   FALSE,
5224                                   ((codegen_imp == FFEINTRIN_impIRAND) ?
5225                                    ffecom_f2c_integer_type_node :
5226                                    ffecom_f2c_real_type_node),
5227                                   arg1_tree,
5228                                   dest_tree, dest, dest_used,
5229                                   NULL_TREE, TRUE,
5230                                   ffebld_nonter_hook (expr));
5231       }
5232       return expr_tree;
5233
5234     case FFEINTRIN_impFTELL_subr:
5235     case FFEINTRIN_impUMASK_subr:
5236       {
5237         tree arg1_tree;
5238         tree arg2_tree;
5239
5240         arg1_tree = convert (ffecom_f2c_integer_type_node,
5241                              ffecom_expr (arg1));
5242         arg1_tree = ffecom_1 (ADDR_EXPR,
5243                               build_pointer_type (TREE_TYPE (arg1_tree)),
5244                               arg1_tree);
5245
5246         if (arg2 == NULL)
5247           arg2_tree = NULL_TREE;
5248         else
5249           arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
5250
5251         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5252                                   ffecom_gfrt_kindtype (gfrt),
5253                                   FALSE,
5254                                   NULL_TREE,
5255                                   build_tree_list (NULL_TREE, arg1_tree),
5256                                   NULL_TREE, NULL, NULL, NULL_TREE,
5257                                   TRUE,
5258                                   ffebld_nonter_hook (expr));
5259         if (arg2_tree != NULL_TREE) {
5260           expr_tree = ffecom_modify (NULL_TREE, arg2_tree,
5261                                      convert (TREE_TYPE (arg2_tree),
5262                                               expr_tree));
5263         }
5264       }
5265       return expr_tree;
5266
5267     case FFEINTRIN_impCPU_TIME:
5268     case FFEINTRIN_impSECOND_subr:
5269       {
5270         tree arg1_tree;
5271
5272         arg1_tree = ffecom_expr_w (NULL_TREE, arg1);
5273
5274         expr_tree
5275           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5276                           ffecom_gfrt_kindtype (gfrt),
5277                           FALSE,
5278                           NULL_TREE,
5279                           NULL_TREE,
5280                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5281                           ffebld_nonter_hook (expr));
5282
5283         expr_tree
5284           = ffecom_modify (NULL_TREE, arg1_tree,
5285                            convert (TREE_TYPE (arg1_tree),
5286                                     expr_tree));
5287       }
5288       return expr_tree;
5289
5290     case FFEINTRIN_impDTIME_subr:
5291     case FFEINTRIN_impETIME_subr:
5292       {
5293         tree arg1_tree;
5294         tree result_tree;
5295
5296         result_tree = ffecom_expr_w (NULL_TREE, arg2);
5297
5298         arg1_tree = ffecom_ptr_to_expr (arg1);
5299
5300         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5301                                   ffecom_gfrt_kindtype (gfrt),
5302                                   FALSE,
5303                                   NULL_TREE,
5304                                   build_tree_list (NULL_TREE, arg1_tree),
5305                                   NULL_TREE, NULL, NULL, NULL_TREE,
5306                                   TRUE,
5307                                   ffebld_nonter_hook (expr));
5308         expr_tree = ffecom_modify (NULL_TREE, result_tree,
5309                                    convert (TREE_TYPE (result_tree),
5310                                             expr_tree));
5311       }
5312       return expr_tree;
5313
5314       /* Straightforward calls of libf2c routines: */
5315     case FFEINTRIN_impABORT:
5316     case FFEINTRIN_impACCESS:
5317     case FFEINTRIN_impBESJ0:
5318     case FFEINTRIN_impBESJ1:
5319     case FFEINTRIN_impBESJN:
5320     case FFEINTRIN_impBESY0:
5321     case FFEINTRIN_impBESY1:
5322     case FFEINTRIN_impBESYN:
5323     case FFEINTRIN_impCHDIR_func:
5324     case FFEINTRIN_impCHMOD_func:
5325     case FFEINTRIN_impDATE:
5326     case FFEINTRIN_impDATE_AND_TIME:
5327     case FFEINTRIN_impDBESJ0:
5328     case FFEINTRIN_impDBESJ1:
5329     case FFEINTRIN_impDBESJN:
5330     case FFEINTRIN_impDBESY0:
5331     case FFEINTRIN_impDBESY1:
5332     case FFEINTRIN_impDBESYN:
5333     case FFEINTRIN_impDTIME_func:
5334     case FFEINTRIN_impETIME_func:
5335     case FFEINTRIN_impFGETC_func:
5336     case FFEINTRIN_impFGET_func:
5337     case FFEINTRIN_impFNUM:
5338     case FFEINTRIN_impFPUTC_func:
5339     case FFEINTRIN_impFPUT_func:
5340     case FFEINTRIN_impFSEEK:
5341     case FFEINTRIN_impFSTAT_func:
5342     case FFEINTRIN_impFTELL_func:
5343     case FFEINTRIN_impGERROR:
5344     case FFEINTRIN_impGETARG:
5345     case FFEINTRIN_impGETCWD_func:
5346     case FFEINTRIN_impGETENV:
5347     case FFEINTRIN_impGETGID:
5348     case FFEINTRIN_impGETLOG:
5349     case FFEINTRIN_impGETPID:
5350     case FFEINTRIN_impGETUID:
5351     case FFEINTRIN_impGMTIME:
5352     case FFEINTRIN_impHOSTNM_func:
5353     case FFEINTRIN_impIDATE_unix:
5354     case FFEINTRIN_impIDATE_vxt:
5355     case FFEINTRIN_impIERRNO:
5356     case FFEINTRIN_impISATTY:
5357     case FFEINTRIN_impITIME:
5358     case FFEINTRIN_impKILL_func:
5359     case FFEINTRIN_impLINK_func:
5360     case FFEINTRIN_impLNBLNK:
5361     case FFEINTRIN_impLSTAT_func:
5362     case FFEINTRIN_impLTIME:
5363     case FFEINTRIN_impMCLOCK8:
5364     case FFEINTRIN_impMCLOCK:
5365     case FFEINTRIN_impPERROR:
5366     case FFEINTRIN_impRENAME_func:
5367     case FFEINTRIN_impSECNDS:
5368     case FFEINTRIN_impSECOND_func:
5369     case FFEINTRIN_impSLEEP:
5370     case FFEINTRIN_impSRAND:
5371     case FFEINTRIN_impSTAT_func:
5372     case FFEINTRIN_impSYMLNK_func:
5373     case FFEINTRIN_impSYSTEM_CLOCK:
5374     case FFEINTRIN_impSYSTEM_func:
5375     case FFEINTRIN_impTIME8:
5376     case FFEINTRIN_impTIME_unix:
5377     case FFEINTRIN_impTIME_vxt:
5378     case FFEINTRIN_impUMASK_func:
5379     case FFEINTRIN_impUNLINK_func:
5380       break;
5381
5382     case FFEINTRIN_impCTIME_func:       /* CHARACTER functions not handled here. */
5383     case FFEINTRIN_impFDATE_func:       /* CHARACTER functions not handled here. */
5384     case FFEINTRIN_impTTYNAM_func:      /* CHARACTER functions not handled here. */
5385     case FFEINTRIN_impNONE:
5386     case FFEINTRIN_imp:         /* Hush up gcc warning. */
5387       fprintf (stderr, "No %s implementation.\n",
5388                ffeintrin_name_implementation (ffebld_symter_implementation (ffebld_left (expr))));
5389       assert ("unimplemented intrinsic" == NULL);
5390       return error_mark_node;
5391     }
5392
5393   assert (gfrt != FFECOM_gfrt); /* Must have an implementation! */
5394
5395   expr_tree = ffecom_arglist_expr_ (ffecom_gfrt_args_ (gfrt),
5396                                     ffebld_right (expr));
5397
5398   return ffecom_call_ (ffecom_gfrt_tree_ (gfrt), ffecom_gfrt_kindtype (gfrt),
5399                        (ffe_is_f2c_library () && ffecom_gfrt_complex_[gfrt]),
5400                        tree_type,
5401                        expr_tree, dest_tree, dest, dest_used,
5402                        NULL_TREE, TRUE,
5403                        ffebld_nonter_hook (expr));
5404
5405   /* See bottom of this file for f2c transforms used to determine
5406      many of the above implementations.  The info seems to confuse
5407      Emacs's C mode indentation, which is why it's been moved to
5408      the bottom of this source file.  */
5409 }
5410
5411 /* For power (exponentiation) where right-hand operand is type INTEGER,
5412    generate in-line code to do it the fast way (which, if the operand
5413    is a constant, might just mean a series of multiplies).  */
5414
5415 static tree
5416 ffecom_expr_power_integer_ (ffebld expr)
5417 {
5418   tree l = ffecom_expr (ffebld_left (expr));
5419   tree r = ffecom_expr (ffebld_right (expr));
5420   tree ltype = TREE_TYPE (l);
5421   tree rtype = TREE_TYPE (r);
5422   tree result = NULL_TREE;
5423
5424   if (l == error_mark_node
5425       || r == error_mark_node)
5426     return error_mark_node;
5427
5428   if (TREE_CODE (r) == INTEGER_CST)
5429     {
5430       int sgn = tree_int_cst_sgn (r);
5431
5432       if (sgn == 0)
5433         return convert (ltype, integer_one_node);
5434
5435       if ((TREE_CODE (ltype) == INTEGER_TYPE)
5436           && (sgn < 0))
5437         {
5438           /* Reciprocal of integer is either 0, -1, or 1, so after
5439              calculating that (which we leave to the back end to do
5440              or not do optimally), don't bother with any multiplying.  */
5441
5442           result = ffecom_tree_divide_ (ltype,
5443                                         convert (ltype, integer_one_node),
5444                                         l,
5445                                         NULL_TREE, NULL, NULL, NULL_TREE);
5446           r = ffecom_1 (NEGATE_EXPR,
5447                         rtype,
5448                         r);
5449           if ((TREE_INT_CST_LOW (r) & 1) == 0)
5450             result = ffecom_1 (ABS_EXPR, rtype,
5451                                result);
5452         }
5453
5454       /* Generate appropriate series of multiplies, preceded
5455          by divide if the exponent is negative.  */
5456
5457       l = save_expr (l);
5458
5459       if (sgn < 0)
5460         {
5461           l = ffecom_tree_divide_ (ltype,
5462                                    convert (ltype, integer_one_node),
5463                                    l,
5464                                    NULL_TREE, NULL, NULL,
5465                                    ffebld_nonter_hook (expr));
5466           r = ffecom_1 (NEGATE_EXPR, rtype, r);
5467           assert (TREE_CODE (r) == INTEGER_CST);
5468
5469           if (tree_int_cst_sgn (r) < 0)
5470             {                   /* The "most negative" number.  */
5471               r = ffecom_1 (NEGATE_EXPR, rtype,
5472                             ffecom_2 (RSHIFT_EXPR, rtype,
5473                                       r,
5474                                       integer_one_node));
5475               l = save_expr (l);
5476               l = ffecom_2 (MULT_EXPR, ltype,
5477                             l,
5478                             l);
5479             }
5480         }
5481
5482       for (;;)
5483         {
5484           if (TREE_INT_CST_LOW (r) & 1)
5485             {
5486               if (result == NULL_TREE)
5487                 result = l;
5488               else
5489                 result = ffecom_2 (MULT_EXPR, ltype,
5490                                    result,
5491                                    l);
5492             }
5493
5494           r = ffecom_2 (RSHIFT_EXPR, rtype,
5495                         r,
5496                         integer_one_node);
5497           if (integer_zerop (r))
5498             break;
5499           assert (TREE_CODE (r) == INTEGER_CST);
5500
5501           l = save_expr (l);
5502           l = ffecom_2 (MULT_EXPR, ltype,
5503                         l,
5504                         l);
5505         }
5506       return result;
5507     }
5508
5509   /* Though rhs isn't a constant, in-line code cannot be expanded
5510      while transforming dummies
5511      because the back end cannot be easily convinced to generate
5512      stores (MODIFY_EXPR), handle temporaries, and so on before
5513      all the appropriate rtx's have been generated for things like
5514      dummy args referenced in rhs -- which doesn't happen until
5515      store_parm_decls() is called (expand_function_start, I believe,
5516      does the actual rtx-stuffing of PARM_DECLs).
5517
5518      So, in this case, let the caller generate the call to the
5519      run-time-library function to evaluate the power for us.  */
5520
5521   if (ffecom_transform_only_dummies_)
5522     return NULL_TREE;
5523
5524   /* Right-hand operand not a constant, expand in-line code to figure
5525      out how to do the multiplies, &c.
5526
5527      The returned expression is expressed this way in GNU C, where l and
5528      r are the "inputs":
5529
5530      ({ typeof (r) rtmp = r;
5531         typeof (l) ltmp = l;
5532         typeof (l) result;
5533
5534         if (rtmp == 0)
5535           result = 1;
5536         else
5537           {
5538             if ((basetypeof (l) == basetypeof (int))
5539                 && (rtmp < 0))
5540               {
5541                 result = ((typeof (l)) 1) / ltmp;
5542                 if ((ltmp < 0) && (((-rtmp) & 1) == 0))
5543                   result = -result;
5544               }
5545             else
5546               {
5547                 result = 1;
5548                 if ((basetypeof (l) != basetypeof (int))
5549                     && (rtmp < 0))
5550                   {
5551                     ltmp = ((typeof (l)) 1) / ltmp;
5552                     rtmp = -rtmp;
5553                     if (rtmp < 0)
5554                       {
5555                         rtmp = -(rtmp >> 1);
5556                         ltmp *= ltmp;
5557                       }
5558                   }
5559                 for (;;)
5560                   {
5561                     if (rtmp & 1)
5562                       result *= ltmp;
5563                     if ((rtmp >>= 1) == 0)
5564                       break;
5565                     ltmp *= ltmp;
5566                   }
5567               }
5568           }
5569         result;
5570      })
5571
5572      Note that some of the above is compile-time collapsable, such as
5573      the first part of the if statements that checks the base type of
5574      l against int.  The if statements are phrased that way to suggest
5575      an easy way to generate the if/else constructs here, knowing that
5576      the back end should (and probably does) eliminate the resulting
5577      dead code (either the int case or the non-int case), something
5578      it couldn't do without the redundant phrasing, requiring explicit
5579      dead-code elimination here, which would be kind of difficult to
5580      read.  */
5581
5582   {
5583     tree rtmp;
5584     tree ltmp;
5585     tree divide;
5586     tree basetypeof_l_is_int;
5587     tree se;
5588     tree t;
5589
5590     basetypeof_l_is_int
5591       = build_int_2 ((TREE_CODE (ltype) == INTEGER_TYPE), 0);
5592
5593     se = expand_start_stmt_expr ();
5594
5595     ffecom_start_compstmt ();
5596
5597 #ifndef HAHA
5598     rtmp = ffecom_make_tempvar ("power_r", rtype,
5599                                 FFETARGET_charactersizeNONE, -1);
5600     ltmp = ffecom_make_tempvar ("power_l", ltype,
5601                                 FFETARGET_charactersizeNONE, -1);
5602     result = ffecom_make_tempvar ("power_res", ltype,
5603                                   FFETARGET_charactersizeNONE, -1);
5604     if (TREE_CODE (ltype) == COMPLEX_TYPE
5605         || TREE_CODE (ltype) == RECORD_TYPE)
5606       divide = ffecom_make_tempvar ("power_div", ltype,
5607                                     FFETARGET_charactersizeNONE, -1);
5608     else
5609       divide = NULL_TREE;
5610 #else  /* HAHA */
5611     {
5612       tree hook;
5613
5614       hook = ffebld_nonter_hook (expr);
5615       assert (hook);
5616       assert (TREE_CODE (hook) == TREE_VEC);
5617       assert (TREE_VEC_LENGTH (hook) == 4);
5618       rtmp = TREE_VEC_ELT (hook, 0);
5619       ltmp = TREE_VEC_ELT (hook, 1);
5620       result = TREE_VEC_ELT (hook, 2);
5621       divide = TREE_VEC_ELT (hook, 3);
5622       if (TREE_CODE (ltype) == COMPLEX_TYPE
5623           || TREE_CODE (ltype) == RECORD_TYPE)
5624         assert (divide);
5625       else
5626         assert (! divide);
5627     }
5628 #endif  /* HAHA */
5629
5630     expand_expr_stmt (ffecom_modify (void_type_node,
5631                                      rtmp,
5632                                      r));
5633     expand_expr_stmt (ffecom_modify (void_type_node,
5634                                      ltmp,
5635                                      l));
5636     expand_start_cond (ffecom_truth_value
5637                        (ffecom_2 (EQ_EXPR, integer_type_node,
5638                                   rtmp,
5639                                   convert (rtype, integer_zero_node))),
5640                        0);
5641     expand_expr_stmt (ffecom_modify (void_type_node,
5642                                      result,
5643                                      convert (ltype, integer_one_node)));
5644     expand_start_else ();
5645     if (! integer_zerop (basetypeof_l_is_int))
5646       {
5647         expand_start_cond (ffecom_2 (LT_EXPR, integer_type_node,
5648                                      rtmp,
5649                                      convert (rtype,
5650                                               integer_zero_node)),
5651                            0);
5652         expand_expr_stmt (ffecom_modify (void_type_node,
5653                                          result,
5654                                          ffecom_tree_divide_
5655                                          (ltype,
5656                                           convert (ltype, integer_one_node),
5657                                           ltmp,
5658                                           NULL_TREE, NULL, NULL,
5659                                           divide)));
5660         expand_start_cond (ffecom_truth_value
5661                            (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5662                                       ffecom_2 (LT_EXPR, integer_type_node,
5663                                                 ltmp,
5664                                                 convert (ltype,
5665                                                          integer_zero_node)),
5666                                       ffecom_2 (EQ_EXPR, integer_type_node,
5667                                                 ffecom_2 (BIT_AND_EXPR,
5668                                                           rtype,
5669                                                           ffecom_1 (NEGATE_EXPR,
5670                                                                     rtype,
5671                                                                     rtmp),
5672                                                           convert (rtype,
5673                                                                    integer_one_node)),
5674                                                 convert (rtype,
5675                                                          integer_zero_node)))),
5676                            0);
5677         expand_expr_stmt (ffecom_modify (void_type_node,
5678                                          result,
5679                                          ffecom_1 (NEGATE_EXPR,
5680                                                    ltype,
5681                                                    result)));
5682         expand_end_cond ();
5683         expand_start_else ();
5684       }
5685     expand_expr_stmt (ffecom_modify (void_type_node,
5686                                      result,
5687                                      convert (ltype, integer_one_node)));
5688     expand_start_cond (ffecom_truth_value
5689                        (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5690                                   ffecom_truth_value_invert
5691                                   (basetypeof_l_is_int),
5692                                   ffecom_2 (LT_EXPR, integer_type_node,
5693                                             rtmp,
5694                                             convert (rtype,
5695                                                      integer_zero_node)))),
5696                        0);
5697     expand_expr_stmt (ffecom_modify (void_type_node,
5698                                      ltmp,
5699                                      ffecom_tree_divide_
5700                                      (ltype,
5701                                       convert (ltype, integer_one_node),
5702                                       ltmp,
5703                                       NULL_TREE, NULL, NULL,
5704                                       divide)));
5705     expand_expr_stmt (ffecom_modify (void_type_node,
5706                                      rtmp,
5707                                      ffecom_1 (NEGATE_EXPR, rtype,
5708                                                rtmp)));
5709     expand_start_cond (ffecom_truth_value
5710                        (ffecom_2 (LT_EXPR, integer_type_node,
5711                                   rtmp,
5712                                   convert (rtype, integer_zero_node))),
5713                        0);
5714     expand_expr_stmt (ffecom_modify (void_type_node,
5715                                      rtmp,
5716                                      ffecom_1 (NEGATE_EXPR, rtype,
5717                                                ffecom_2 (RSHIFT_EXPR,
5718                                                          rtype,
5719                                                          rtmp,
5720                                                          integer_one_node))));
5721     expand_expr_stmt (ffecom_modify (void_type_node,
5722                                      ltmp,
5723                                      ffecom_2 (MULT_EXPR, ltype,
5724                                                ltmp,
5725                                                ltmp)));
5726     expand_end_cond ();
5727     expand_end_cond ();
5728     expand_start_loop (1);
5729     expand_start_cond (ffecom_truth_value
5730                        (ffecom_2 (BIT_AND_EXPR, rtype,
5731                                   rtmp,
5732                                   convert (rtype, integer_one_node))),
5733                        0);
5734     expand_expr_stmt (ffecom_modify (void_type_node,
5735                                      result,
5736                                      ffecom_2 (MULT_EXPR, ltype,
5737                                                result,
5738                                                ltmp)));
5739     expand_end_cond ();
5740     expand_exit_loop_if_false (NULL,
5741                                ffecom_truth_value
5742                                (ffecom_modify (rtype,
5743                                                rtmp,
5744                                                ffecom_2 (RSHIFT_EXPR,
5745                                                          rtype,
5746                                                          rtmp,
5747                                                          integer_one_node))));
5748     expand_expr_stmt (ffecom_modify (void_type_node,
5749                                      ltmp,
5750                                      ffecom_2 (MULT_EXPR, ltype,
5751                                                ltmp,
5752                                                ltmp)));
5753     expand_end_loop ();
5754     expand_end_cond ();
5755     if (!integer_zerop (basetypeof_l_is_int))
5756       expand_end_cond ();
5757     expand_expr_stmt (result);
5758
5759     t = ffecom_end_compstmt ();
5760
5761     result = expand_end_stmt_expr (se);
5762
5763     /* This code comes from c-parse.in, after its expand_end_stmt_expr.  */
5764
5765     if (TREE_CODE (t) == BLOCK)
5766       {
5767         /* Make a BIND_EXPR for the BLOCK already made.  */
5768         result = build (BIND_EXPR, TREE_TYPE (result),
5769                         NULL_TREE, result, t);
5770         /* Remove the block from the tree at this point.
5771            It gets put back at the proper place
5772            when the BIND_EXPR is expanded.  */
5773         delete_block (t);
5774       }
5775     else
5776       result = t;
5777   }
5778
5779   return result;
5780 }
5781
5782 /* ffecom_expr_transform_ -- Transform symbols in expr
5783
5784    ffebld expr;  // FFE expression.
5785    ffecom_expr_transform_ (expr);
5786
5787    Recursive descent on expr while transforming any untransformed SYMTERs.  */
5788
5789 static void
5790 ffecom_expr_transform_ (ffebld expr)
5791 {
5792   tree t;
5793   ffesymbol s;
5794
5795  tail_recurse:
5796
5797   if (expr == NULL)
5798     return;
5799
5800   switch (ffebld_op (expr))
5801     {
5802     case FFEBLD_opSYMTER:
5803       s = ffebld_symter (expr);
5804       t = ffesymbol_hook (s).decl_tree;
5805       if ((t == NULL_TREE)
5806           && ((ffesymbol_kind (s) != FFEINFO_kindNONE)
5807               || ((ffesymbol_where (s) != FFEINFO_whereNONE)
5808                   && (ffesymbol_where (s) != FFEINFO_whereINTRINSIC))))
5809         {
5810           s = ffecom_sym_transform_ (s);
5811           t = ffesymbol_hook (s).decl_tree;     /* Sfunc expr non-dummy,
5812                                                    DIMENSION expr? */
5813         }
5814       break;                    /* Ok if (t == NULL) here. */
5815
5816     case FFEBLD_opITEM:
5817       ffecom_expr_transform_ (ffebld_head (expr));
5818       expr = ffebld_trail (expr);
5819       goto tail_recurse;        /* :::::::::::::::::::: */
5820
5821     default:
5822       break;
5823     }
5824
5825   switch (ffebld_arity (expr))
5826     {
5827     case 2:
5828       ffecom_expr_transform_ (ffebld_left (expr));
5829       expr = ffebld_right (expr);
5830       goto tail_recurse;        /* :::::::::::::::::::: */
5831
5832     case 1:
5833       expr = ffebld_left (expr);
5834       goto tail_recurse;        /* :::::::::::::::::::: */
5835
5836     default:
5837       break;
5838     }
5839
5840   return;
5841 }
5842
5843 /* Make a type based on info in live f2c.h file.  */
5844
5845 static void
5846 ffecom_f2c_make_type_ (tree *type, int tcode, const char *name)
5847 {
5848   switch (tcode)
5849     {
5850     case FFECOM_f2ccodeCHAR:
5851       *type = make_signed_type (CHAR_TYPE_SIZE);
5852       break;
5853
5854     case FFECOM_f2ccodeSHORT:
5855       *type = make_signed_type (SHORT_TYPE_SIZE);
5856       break;
5857
5858     case FFECOM_f2ccodeINT:
5859       *type = make_signed_type (INT_TYPE_SIZE);
5860       break;
5861
5862     case FFECOM_f2ccodeLONG:
5863       *type = make_signed_type (LONG_TYPE_SIZE);
5864       break;
5865
5866     case FFECOM_f2ccodeLONGLONG:
5867       *type = make_signed_type (LONG_LONG_TYPE_SIZE);
5868       break;
5869
5870     case FFECOM_f2ccodeCHARPTR:
5871       *type = build_pointer_type (DEFAULT_SIGNED_CHAR
5872                                   ? signed_char_type_node
5873                                   : unsigned_char_type_node);
5874       break;
5875
5876     case FFECOM_f2ccodeFLOAT:
5877       *type = make_node (REAL_TYPE);
5878       TYPE_PRECISION (*type) = FLOAT_TYPE_SIZE;
5879       layout_type (*type);
5880       break;
5881
5882     case FFECOM_f2ccodeDOUBLE:
5883       *type = make_node (REAL_TYPE);
5884       TYPE_PRECISION (*type) = DOUBLE_TYPE_SIZE;
5885       layout_type (*type);
5886       break;
5887
5888     case FFECOM_f2ccodeLONGDOUBLE:
5889       *type = make_node (REAL_TYPE);
5890       TYPE_PRECISION (*type) = LONG_DOUBLE_TYPE_SIZE;
5891       layout_type (*type);
5892       break;
5893
5894     case FFECOM_f2ccodeTWOREALS:
5895       *type = ffecom_make_complex_type_ (ffecom_f2c_real_type_node);
5896       break;
5897
5898     case FFECOM_f2ccodeTWODOUBLEREALS:
5899       *type = ffecom_make_complex_type_ (ffecom_f2c_doublereal_type_node);
5900       break;
5901
5902     default:
5903       assert ("unexpected FFECOM_f2ccodeXYZZY!" == NULL);
5904       *type = error_mark_node;
5905       return;
5906     }
5907
5908   pushdecl (build_decl (TYPE_DECL,
5909                         ffecom_get_invented_identifier ("__g77_f2c_%s", name),
5910                         *type));
5911 }
5912
5913 /* Set the f2c list-directed-I/O code for whatever (integral) type has the
5914    given size.  */
5915
5916 static void
5917 ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
5918                           int code)
5919 {
5920   int j;
5921   tree t;
5922
5923   for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
5924     if ((t = ffecom_tree_type[bt][j]) != NULL_TREE
5925         && compare_tree_int (TYPE_SIZE (t), size) == 0)
5926       {
5927         assert (code != -1);
5928         ffecom_f2c_typecode_[bt][j] = code;
5929         code = -1;
5930       }
5931 }
5932
5933 /* Finish up globals after doing all program units in file
5934
5935    Need to handle only uninitialized COMMON areas.  */
5936
5937 static ffeglobal
5938 ffecom_finish_global_ (ffeglobal global)
5939 {
5940   tree cbtype;
5941   tree cbt;
5942   tree size;
5943
5944   if (ffeglobal_type (global) != FFEGLOBAL_typeCOMMON)
5945       return global;
5946
5947   if (ffeglobal_common_init (global))
5948       return global;
5949
5950   cbt = ffeglobal_hook (global);
5951   if ((cbt == NULL_TREE)
5952       || !ffeglobal_common_have_size (global))
5953     return global;              /* No need to make common, never ref'd. */
5954
5955   DECL_EXTERNAL (cbt) = 0;
5956
5957   /* Give the array a size now.  */
5958
5959   size = build_int_2 ((ffeglobal_common_size (global)
5960                       + ffeglobal_common_pad (global)) - 1,
5961                       0);
5962
5963   cbtype = TREE_TYPE (cbt);
5964   TYPE_DOMAIN (cbtype) = build_range_type (integer_type_node,
5965                                            integer_zero_node,
5966                                            size);
5967   if (!TREE_TYPE (size))
5968     TREE_TYPE (size) = TYPE_DOMAIN (cbtype);
5969   layout_type (cbtype);
5970
5971   cbt = start_decl (cbt, FALSE);
5972   assert (cbt == ffeglobal_hook (global));
5973
5974   finish_decl (cbt, NULL_TREE, FALSE);
5975
5976   return global;
5977 }
5978
5979 /* Finish up any untransformed symbols.  */
5980
5981 static ffesymbol
5982 ffecom_finish_symbol_transform_ (ffesymbol s)
5983 {
5984   if ((s == NULL) || (TREE_CODE (current_function_decl) == ERROR_MARK))
5985     return s;
5986
5987   /* It's easy to know to transform an untransformed symbol, to make sure
5988      we put out debugging info for it.  But COMMON variables, unlike
5989      EQUIVALENCE ones, aren't given declarations in addition to the
5990      tree expressions that specify offsets, because COMMON variables
5991      can be referenced in the outer scope where only dummy arguments
5992      (PARM_DECLs) should really be seen.  To be safe, just don't do any
5993      VAR_DECLs for COMMON variables when we transform them for real
5994      use, and therefore we do all the VAR_DECL creating here.  */
5995
5996   if (ffesymbol_hook (s).decl_tree == NULL_TREE)
5997     {
5998       if (ffesymbol_kind (s) != FFEINFO_kindNONE
5999           || (ffesymbol_where (s) != FFEINFO_whereNONE
6000               && ffesymbol_where (s) != FFEINFO_whereINTRINSIC
6001               && ffesymbol_where (s) != FFEINFO_whereDUMMY))
6002         /* Not transformed, and not CHARACTER*(*), and not a dummy
6003            argument, which can happen only if the entry point names
6004            it "rides in on" are all invalidated for other reasons.  */
6005         s = ffecom_sym_transform_ (s);
6006     }
6007
6008   if ((ffesymbol_where (s) == FFEINFO_whereCOMMON)
6009       && (ffesymbol_hook (s).decl_tree != error_mark_node))
6010     {
6011       /* This isn't working, at least for dbxout.  The .s file looks
6012          okay to me (burley), but in gdb 4.9 at least, the variables
6013          appear to reside somewhere outside of the common area, so
6014          it doesn't make sense to mislead anyone by generating the info
6015          on those variables until this is fixed.  NOTE: Same problem
6016          with EQUIVALENCE, sadly...see similar #if later.  */
6017       ffecom_member_phase2_ (ffesymbol_storage (ffesymbol_common (s)),
6018                              ffesymbol_storage (s));
6019     }
6020
6021   return s;
6022 }
6023
6024 /* Append underscore(s) to name before calling get_identifier.  "us"
6025    is nonzero if the name already contains an underscore and thus
6026    needs two underscores appended.  */
6027
6028 static tree
6029 ffecom_get_appended_identifier_ (char us, const char *name)
6030 {
6031   int i;
6032   char *newname;
6033   tree id;
6034
6035   newname = xmalloc ((i = strlen (name)) + 1
6036                      + ffe_is_underscoring ()
6037                      + us);
6038   memcpy (newname, name, i);
6039   newname[i] = '_';
6040   newname[i + us] = '_';
6041   newname[i + 1 + us] = '\0';
6042   id = get_identifier (newname);
6043
6044   free (newname);
6045
6046   return id;
6047 }
6048
6049 /* Decide whether to append underscore to name before calling
6050    get_identifier.  */
6051
6052 static tree
6053 ffecom_get_external_identifier_ (ffesymbol s)
6054 {
6055   char us;
6056   const char *name = ffesymbol_text (s);
6057
6058   /* If name is a built-in name, just return it as is.  */
6059
6060   if (!ffe_is_underscoring ()
6061       || (strcmp (name, FFETARGET_nameBLANK_COMMON) == 0)
6062 #if FFETARGET_isENFORCED_MAIN_NAME
6063       || (strcmp (name, FFETARGET_nameENFORCED_NAME) == 0)
6064 #else
6065       || (strcmp (name, FFETARGET_nameUNNAMED_MAIN) == 0)
6066 #endif
6067       || (strcmp (name, FFETARGET_nameUNNAMED_BLOCK_DATA) == 0))
6068     return get_identifier (name);
6069
6070   us = ffe_is_second_underscore ()
6071     ? (strchr (name, '_') != NULL)
6072       : 0;
6073
6074   return ffecom_get_appended_identifier_ (us, name);
6075 }
6076
6077 /* Decide whether to append underscore to internal name before calling
6078    get_identifier.
6079
6080    This is for non-external, top-function-context names only.  Transform
6081    identifier so it doesn't conflict with the transformed result
6082    of using a _different_ external name.  E.g. if "CALL FOO" is
6083    transformed into "FOO_();", then the variable in "FOO_ = 3"
6084    must be transformed into something that does not conflict, since
6085    these two things should be independent.
6086
6087    The transformation is as follows.  If the name does not contain
6088    an underscore, there is no possible conflict, so just return.
6089    If the name does contain an underscore, then transform it just
6090    like we transform an external identifier.  */
6091
6092 static tree
6093 ffecom_get_identifier_ (const char *name)
6094 {
6095   /* If name does not contain an underscore, just return it as is.  */
6096
6097   if (!ffe_is_underscoring ()
6098       || (strchr (name, '_') == NULL))
6099     return get_identifier (name);
6100
6101   return ffecom_get_appended_identifier_ (ffe_is_second_underscore (),
6102                                           name);
6103 }
6104
6105 /* ffecom_gen_sfuncdef_ -- Generate definition of statement function
6106
6107    tree t;
6108    ffesymbol s;  // kindFUNCTION, whereIMMEDIATE.
6109    t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s),
6110          ffesymbol_kindtype(s));
6111
6112    Call after setting up containing function and getting trees for all
6113    other symbols.  */
6114
6115 static tree
6116 ffecom_gen_sfuncdef_ (ffesymbol s, ffeinfoBasictype bt, ffeinfoKindtype kt)
6117 {
6118   ffebld expr = ffesymbol_sfexpr (s);
6119   tree type;
6120   tree func;
6121   tree result;
6122   bool charfunc = (bt == FFEINFO_basictypeCHARACTER);
6123   static bool recurse = FALSE;
6124   int old_lineno = lineno;
6125   const char *old_input_filename = input_filename;
6126
6127   ffecom_nested_entry_ = s;
6128
6129   /* For now, we don't have a handy pointer to where the sfunc is actually
6130      defined, though that should be easy to add to an ffesymbol. (The
6131      token/where info available might well point to the place where the type
6132      of the sfunc is declared, especially if that precedes the place where
6133      the sfunc itself is defined, which is typically the case.)  We should
6134      put out a null pointer rather than point somewhere wrong, but I want to
6135      see how it works at this point.  */
6136
6137   input_filename = ffesymbol_where_filename (s);
6138   lineno = ffesymbol_where_filelinenum (s);
6139
6140   /* Pretransform the expression so any newly discovered things belong to the
6141      outer program unit, not to the statement function. */
6142
6143   ffecom_expr_transform_ (expr);
6144
6145   /* Make sure no recursive invocation of this fn (a specific case of failing
6146      to pretransform an sfunc's expression, i.e. where its expression
6147      references another untransformed sfunc) happens. */
6148
6149   assert (!recurse);
6150   recurse = TRUE;
6151
6152   push_f_function_context ();
6153
6154   if (charfunc)
6155     type = void_type_node;
6156   else
6157     {
6158       type = ffecom_tree_type[bt][kt];
6159       if (type == NULL_TREE)
6160         type = integer_type_node;       /* _sym_exec_transition reports
6161                                            error. */
6162     }
6163
6164   start_function (ffecom_get_identifier_ (ffesymbol_text (s)),
6165                   build_function_type (type, NULL_TREE),
6166                   1,            /* nested/inline */
6167                   0);           /* TREE_PUBLIC */
6168
6169   /* We don't worry about COMPLEX return values here, because this is
6170      entirely internal to our code, and gcc has the ability to return COMPLEX
6171      directly as a value.  */
6172
6173   if (charfunc)
6174     {                           /* Prepend arg for where result goes. */
6175       tree type;
6176
6177       type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
6178
6179       result = ffecom_get_invented_identifier ("__g77_%s", "result");
6180
6181       ffecom_char_enhance_arg_ (&type, s);      /* Ignore returned length. */
6182
6183       type = build_pointer_type (type);
6184       result = build_decl (PARM_DECL, result, type);
6185
6186       push_parm_decl (result);
6187     }
6188   else
6189     result = NULL_TREE;         /* Not ref'd if !charfunc. */
6190
6191   ffecom_push_dummy_decls_ (ffesymbol_dummyargs (s), TRUE);
6192
6193   store_parm_decls (0);
6194
6195   ffecom_start_compstmt ();
6196
6197   if (expr != NULL)
6198     {
6199       if (charfunc)
6200         {
6201           ffetargetCharacterSize sz = ffesymbol_size (s);
6202           tree result_length;
6203
6204           result_length = build_int_2 (sz, 0);
6205           TREE_TYPE (result_length) = ffecom_f2c_ftnlen_type_node;
6206
6207           ffecom_prepare_let_char_ (sz, expr);
6208
6209           ffecom_prepare_end ();
6210
6211           ffecom_let_char_ (result, result_length, sz, expr);
6212           expand_null_return ();
6213         }
6214       else
6215         {
6216           ffecom_prepare_expr (expr);
6217
6218           ffecom_prepare_end ();
6219
6220           expand_return (ffecom_modify (NULL_TREE,
6221                                         DECL_RESULT (current_function_decl),
6222                                         ffecom_expr (expr)));
6223         }
6224     }
6225
6226   ffecom_end_compstmt ();
6227
6228   func = current_function_decl;
6229   finish_function (1);
6230
6231   pop_f_function_context ();
6232
6233   recurse = FALSE;
6234
6235   lineno = old_lineno;
6236   input_filename = old_input_filename;
6237
6238   ffecom_nested_entry_ = NULL;
6239
6240   return func;
6241 }
6242
6243 static const char *
6244 ffecom_gfrt_args_ (ffecomGfrt ix)
6245 {
6246   return ffecom_gfrt_argstring_[ix];
6247 }
6248
6249 static tree
6250 ffecom_gfrt_tree_ (ffecomGfrt ix)
6251 {
6252   if (ffecom_gfrt_[ix] == NULL_TREE)
6253     ffecom_make_gfrt_ (ix);
6254
6255   return ffecom_1 (ADDR_EXPR,
6256                    build_pointer_type (TREE_TYPE (ffecom_gfrt_[ix])),
6257                    ffecom_gfrt_[ix]);
6258 }
6259
6260 /* Return initialize-to-zero expression for this VAR_DECL.  */
6261
6262 /* A somewhat evil way to prevent the garbage collector
6263    from collecting 'tree' structures.  */
6264 #define NUM_TRACKED_CHUNK 63
6265 static struct tree_ggc_tracker
6266 {
6267   struct tree_ggc_tracker *next;
6268   tree trees[NUM_TRACKED_CHUNK];
6269 } *tracker_head = NULL;
6270
6271 static void
6272 mark_tracker_head (void *arg)
6273 {
6274   struct tree_ggc_tracker *head;
6275   int i;
6276
6277   for (head = * (struct tree_ggc_tracker **) arg;
6278        head != NULL;
6279        head = head->next)
6280   {
6281     ggc_mark (head);
6282     for (i = 0; i < NUM_TRACKED_CHUNK; i++)
6283       ggc_mark_tree (head->trees[i]);
6284   }
6285 }
6286
6287 void
6288 ffecom_save_tree_forever (tree t)
6289 {
6290   int i;
6291   if (tracker_head != NULL)
6292     for (i = 0; i < NUM_TRACKED_CHUNK; i++)
6293       if (tracker_head->trees[i] == NULL)
6294         {
6295           tracker_head->trees[i] = t;
6296           return;
6297         }
6298
6299   {
6300     /* Need to allocate a new block.  */
6301     struct tree_ggc_tracker *old_head = tracker_head;
6302
6303     tracker_head = ggc_alloc (sizeof (*tracker_head));
6304     tracker_head->next = old_head;
6305     tracker_head->trees[0] = t;
6306     for (i = 1; i < NUM_TRACKED_CHUNK; i++)
6307       tracker_head->trees[i] = NULL;
6308   }
6309 }
6310
6311 static tree
6312 ffecom_init_zero_ (tree decl)
6313 {
6314   tree init;
6315   int incremental = TREE_STATIC (decl);
6316   tree type = TREE_TYPE (decl);
6317
6318   if (incremental)
6319     {
6320       make_decl_rtl (decl, NULL);
6321       assemble_variable (decl, TREE_PUBLIC (decl) ? 1 : 0, 0, 1);
6322     }
6323
6324   if ((TREE_CODE (type) != ARRAY_TYPE)
6325       && (TREE_CODE (type) != RECORD_TYPE)
6326       && (TREE_CODE (type) != UNION_TYPE)
6327       && !incremental)
6328     init = convert (type, integer_zero_node);
6329   else if (!incremental)
6330     {
6331       init = build (CONSTRUCTOR, type, NULL_TREE, NULL_TREE);
6332       TREE_CONSTANT (init) = 1;
6333       TREE_STATIC (init) = 1;
6334     }
6335   else
6336     {
6337       assemble_zeros (int_size_in_bytes (type));
6338       init = error_mark_node;
6339     }
6340
6341   return init;
6342 }
6343
6344 static tree
6345 ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
6346                          tree *maybe_tree)
6347 {
6348   tree expr_tree;
6349   tree length_tree;
6350
6351   switch (ffebld_op (arg))
6352     {
6353     case FFEBLD_opCONTER:       /* For F90, check 0-length. */
6354       if (ffetarget_length_character1
6355           (ffebld_constant_character1
6356            (ffebld_conter (arg))) == 0)
6357         {
6358           *maybe_tree = integer_zero_node;
6359           return convert (tree_type, integer_zero_node);
6360         }
6361
6362       *maybe_tree = integer_one_node;
6363       expr_tree = build_int_2 (*ffetarget_text_character1
6364                                (ffebld_constant_character1
6365                                 (ffebld_conter (arg))),
6366                                0);
6367       TREE_TYPE (expr_tree) = tree_type;
6368       return expr_tree;
6369
6370     case FFEBLD_opSYMTER:
6371     case FFEBLD_opARRAYREF:
6372     case FFEBLD_opFUNCREF:
6373     case FFEBLD_opSUBSTR:
6374       ffecom_char_args_ (&expr_tree, &length_tree, arg);
6375
6376       if ((expr_tree == error_mark_node)
6377           || (length_tree == error_mark_node))
6378         {
6379           *maybe_tree = error_mark_node;
6380           return error_mark_node;
6381         }
6382
6383       if (integer_zerop (length_tree))
6384         {
6385           *maybe_tree = integer_zero_node;
6386           return convert (tree_type, integer_zero_node);
6387         }
6388
6389       expr_tree
6390         = ffecom_1 (INDIRECT_REF,
6391                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6392                     expr_tree);
6393       expr_tree
6394         = ffecom_2 (ARRAY_REF,
6395                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6396                     expr_tree,
6397                     integer_one_node);
6398       expr_tree = convert (tree_type, expr_tree);
6399
6400       if (TREE_CODE (length_tree) == INTEGER_CST)
6401         *maybe_tree = integer_one_node;
6402       else                      /* Must check length at run time.  */
6403         *maybe_tree
6404           = ffecom_truth_value
6405             (ffecom_2 (GT_EXPR, integer_type_node,
6406                        length_tree,
6407                        ffecom_f2c_ftnlen_zero_node));
6408       return expr_tree;
6409
6410     case FFEBLD_opPAREN:
6411     case FFEBLD_opCONVERT:
6412       if (ffeinfo_size (ffebld_info (arg)) == 0)
6413         {
6414           *maybe_tree = integer_zero_node;
6415           return convert (tree_type, integer_zero_node);
6416         }
6417       return ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6418                                       maybe_tree);
6419
6420     case FFEBLD_opCONCATENATE:
6421       {
6422         tree maybe_left;
6423         tree maybe_right;
6424         tree expr_left;
6425         tree expr_right;
6426
6427         expr_left = ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6428                                              &maybe_left);
6429         expr_right = ffecom_intrinsic_ichar_ (tree_type, ffebld_right (arg),
6430                                               &maybe_right);
6431         *maybe_tree = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
6432                                 maybe_left,
6433                                 maybe_right);
6434         expr_tree = ffecom_3 (COND_EXPR, tree_type,
6435                               maybe_left,
6436                               expr_left,
6437                               expr_right);
6438         return expr_tree;
6439       }
6440
6441     default:
6442       assert ("bad op in ICHAR" == NULL);
6443       return error_mark_node;
6444     }
6445 }
6446
6447 /* ffecom_intrinsic_len_ -- Return length info for char arg (LEN())
6448
6449    tree length_arg;
6450    ffebld expr;
6451    length_arg = ffecom_intrinsic_len_ (expr);
6452
6453    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
6454    subexpressions by constructing the appropriate tree for the
6455    length-of-character-text argument in a calling sequence.  */
6456
6457 static tree
6458 ffecom_intrinsic_len_ (ffebld expr)
6459 {
6460   ffetargetCharacter1 val;
6461   tree length;
6462
6463   switch (ffebld_op (expr))
6464     {
6465     case FFEBLD_opCONTER:
6466       val = ffebld_constant_character1 (ffebld_conter (expr));
6467       length = build_int_2 (ffetarget_length_character1 (val), 0);
6468       TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6469       break;
6470
6471     case FFEBLD_opSYMTER:
6472       {
6473         ffesymbol s = ffebld_symter (expr);
6474         tree item;
6475
6476         item = ffesymbol_hook (s).decl_tree;
6477         if (item == NULL_TREE)
6478           {
6479             s = ffecom_sym_transform_ (s);
6480             item = ffesymbol_hook (s).decl_tree;
6481           }
6482         if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
6483           {
6484             if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
6485               length = ffesymbol_hook (s).length_tree;
6486             else
6487               {
6488                 length = build_int_2 (ffesymbol_size (s), 0);
6489                 TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6490               }
6491           }
6492         else if (item == error_mark_node)
6493           length = error_mark_node;
6494         else                    /* FFEINFO_kindFUNCTION: */
6495           length = NULL_TREE;
6496       }
6497       break;
6498
6499     case FFEBLD_opARRAYREF:
6500       length = ffecom_intrinsic_len_ (ffebld_left (expr));
6501       break;
6502
6503     case FFEBLD_opSUBSTR:
6504       {
6505         ffebld start;
6506         ffebld end;
6507         ffebld thing = ffebld_right (expr);
6508         tree start_tree;
6509         tree end_tree;
6510
6511         assert (ffebld_op (thing) == FFEBLD_opITEM);
6512         start = ffebld_head (thing);
6513         thing = ffebld_trail (thing);
6514         assert (ffebld_trail (thing) == NULL);
6515         end = ffebld_head (thing);
6516
6517         length = ffecom_intrinsic_len_ (ffebld_left (expr));
6518
6519         if (length == error_mark_node)
6520           break;
6521
6522         if (start == NULL)
6523           {
6524             if (end == NULL)
6525               ;
6526             else
6527               {
6528                 length = convert (ffecom_f2c_ftnlen_type_node,
6529                                   ffecom_expr (end));
6530               }
6531           }
6532         else
6533           {
6534             start_tree = convert (ffecom_f2c_ftnlen_type_node,
6535                                   ffecom_expr (start));
6536
6537             if (start_tree == error_mark_node)
6538               {
6539                 length = error_mark_node;
6540                 break;
6541               }
6542
6543             if (end == NULL)
6544               {
6545                 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6546                                    ffecom_f2c_ftnlen_one_node,
6547                                    ffecom_2 (MINUS_EXPR,
6548                                              ffecom_f2c_ftnlen_type_node,
6549                                              length,
6550                                              start_tree));
6551               }
6552             else
6553               {
6554                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
6555                                     ffecom_expr (end));
6556
6557                 if (end_tree == error_mark_node)
6558                   {
6559                     length = error_mark_node;
6560                     break;
6561                   }
6562
6563                 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6564                                    ffecom_f2c_ftnlen_one_node,
6565                                    ffecom_2 (MINUS_EXPR,
6566                                              ffecom_f2c_ftnlen_type_node,
6567                                              end_tree, start_tree));
6568               }
6569           }
6570       }
6571       break;
6572
6573     case FFEBLD_opCONCATENATE:
6574       length
6575         = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6576                     ffecom_intrinsic_len_ (ffebld_left (expr)),
6577                     ffecom_intrinsic_len_ (ffebld_right (expr)));
6578       break;
6579
6580     case FFEBLD_opFUNCREF:
6581     case FFEBLD_opCONVERT:
6582       length = build_int_2 (ffebld_size (expr), 0);
6583       TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6584       break;
6585
6586     default:
6587       assert ("bad op for single char arg expr" == NULL);
6588       length = ffecom_f2c_ftnlen_zero_node;
6589       break;
6590     }
6591
6592   assert (length != NULL_TREE);
6593
6594   return length;
6595 }
6596
6597 /* Handle CHARACTER assignments.
6598
6599    Generates code to do the assignment.  Used by ordinary assignment
6600    statement handler ffecom_let_stmt and by statement-function
6601    handler to generate code for a statement function.  */
6602
6603 static void
6604 ffecom_let_char_ (tree dest_tree, tree dest_length,
6605                   ffetargetCharacterSize dest_size, ffebld source)
6606 {
6607   ffecomConcatList_ catlist;
6608   tree source_length;
6609   tree source_tree;
6610   tree expr_tree;
6611
6612   if ((dest_tree == error_mark_node)
6613       || (dest_length == error_mark_node))
6614     return;
6615
6616   assert (dest_tree != NULL_TREE);
6617   assert (dest_length != NULL_TREE);
6618
6619   /* Source might be an opCONVERT, which just means it is a different size
6620      than the destination.  Since the underlying implementation here handles
6621      that (directly or via the s_copy or s_cat run-time-library functions),
6622      we don't need the "convenience" of an opCONVERT that tells us to
6623      truncate or blank-pad, particularly since the resulting implementation
6624      would probably be slower than otherwise. */
6625
6626   while (ffebld_op (source) == FFEBLD_opCONVERT)
6627     source = ffebld_left (source);
6628
6629   catlist = ffecom_concat_list_new_ (source, dest_size);
6630   switch (ffecom_concat_list_count_ (catlist))
6631     {
6632     case 0:                     /* Shouldn't happen, but in case it does... */
6633       ffecom_concat_list_kill_ (catlist);
6634       source_tree = null_pointer_node;
6635       source_length = ffecom_f2c_ftnlen_zero_node;
6636       expr_tree = build_tree_list (NULL_TREE, dest_tree);
6637       TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6638       TREE_CHAIN (TREE_CHAIN (expr_tree))
6639         = build_tree_list (NULL_TREE, dest_length);
6640       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6641         = build_tree_list (NULL_TREE, source_length);
6642
6643       expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6644       TREE_SIDE_EFFECTS (expr_tree) = 1;
6645
6646       expand_expr_stmt (expr_tree);
6647
6648       return;
6649
6650     case 1:                     /* The (fairly) easy case. */
6651       ffecom_char_args_ (&source_tree, &source_length,
6652                          ffecom_concat_list_expr_ (catlist, 0));
6653       ffecom_concat_list_kill_ (catlist);
6654       assert (source_tree != NULL_TREE);
6655       assert (source_length != NULL_TREE);
6656
6657       if ((source_tree == error_mark_node)
6658           || (source_length == error_mark_node))
6659         return;
6660
6661       if (dest_size == 1)
6662         {
6663           dest_tree
6664             = ffecom_1 (INDIRECT_REF,
6665                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6666                                                       (dest_tree))),
6667                         dest_tree);
6668           dest_tree
6669             = ffecom_2 (ARRAY_REF,
6670                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6671                                                       (dest_tree))),
6672                         dest_tree,
6673                         integer_one_node);
6674           source_tree
6675             = ffecom_1 (INDIRECT_REF,
6676                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6677                                                       (source_tree))),
6678                         source_tree);
6679           source_tree
6680             = ffecom_2 (ARRAY_REF,
6681                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6682                                                       (source_tree))),
6683                         source_tree,
6684                         integer_one_node);
6685
6686           expr_tree = ffecom_modify (void_type_node, dest_tree, source_tree);
6687
6688           expand_expr_stmt (expr_tree);
6689
6690           return;
6691         }
6692
6693       expr_tree = build_tree_list (NULL_TREE, dest_tree);
6694       TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6695       TREE_CHAIN (TREE_CHAIN (expr_tree))
6696         = build_tree_list (NULL_TREE, dest_length);
6697       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6698         = build_tree_list (NULL_TREE, source_length);
6699
6700       expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6701       TREE_SIDE_EFFECTS (expr_tree) = 1;
6702
6703       expand_expr_stmt (expr_tree);
6704
6705       return;
6706
6707     default:                    /* Must actually concatenate things. */
6708       break;
6709     }
6710
6711   /* Heavy-duty concatenation. */
6712
6713   {
6714     int count = ffecom_concat_list_count_ (catlist);
6715     int i;
6716     tree lengths;
6717     tree items;
6718     tree length_array;
6719     tree item_array;
6720     tree citem;
6721     tree clength;
6722
6723 #ifdef HOHO
6724     length_array
6725       = lengths
6726       = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
6727                              FFETARGET_charactersizeNONE, count, TRUE);
6728     item_array = items = ffecom_push_tempvar (ffecom_f2c_address_type_node,
6729                                               FFETARGET_charactersizeNONE,
6730                                               count, TRUE);
6731 #else
6732     {
6733       tree hook;
6734
6735       hook = ffebld_nonter_hook (source);
6736       assert (hook);
6737       assert (TREE_CODE (hook) == TREE_VEC);
6738       assert (TREE_VEC_LENGTH (hook) == 2);
6739       length_array = lengths = TREE_VEC_ELT (hook, 0);
6740       item_array = items = TREE_VEC_ELT (hook, 1);
6741     }
6742 #endif
6743
6744     for (i = 0; i < count; ++i)
6745       {
6746         ffecom_char_args_ (&citem, &clength,
6747                            ffecom_concat_list_expr_ (catlist, i));
6748         if ((citem == error_mark_node)
6749             || (clength == error_mark_node))
6750           {
6751             ffecom_concat_list_kill_ (catlist);
6752             return;
6753           }
6754
6755         items
6756           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
6757                       ffecom_modify (void_type_node,
6758                                      ffecom_2 (ARRAY_REF,
6759                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
6760                                                item_array,
6761                                                build_int_2 (i, 0)),
6762                                      citem),
6763                       items);
6764         lengths
6765           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
6766                       ffecom_modify (void_type_node,
6767                                      ffecom_2 (ARRAY_REF,
6768                    TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
6769                                                length_array,
6770                                                build_int_2 (i, 0)),
6771                                      clength),
6772                       lengths);
6773       }
6774
6775     expr_tree = build_tree_list (NULL_TREE, dest_tree);
6776     TREE_CHAIN (expr_tree)
6777       = build_tree_list (NULL_TREE,
6778                          ffecom_1 (ADDR_EXPR,
6779                                    build_pointer_type (TREE_TYPE (items)),
6780                                    items));
6781     TREE_CHAIN (TREE_CHAIN (expr_tree))
6782       = build_tree_list (NULL_TREE,
6783                          ffecom_1 (ADDR_EXPR,
6784                                    build_pointer_type (TREE_TYPE (lengths)),
6785                                    lengths));
6786     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6787       = build_tree_list
6788         (NULL_TREE,
6789          ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
6790                    convert (ffecom_f2c_ftnlen_type_node,
6791                             build_int_2 (count, 0))));
6792     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree))))
6793       = build_tree_list (NULL_TREE, dest_length);
6794
6795     expr_tree = ffecom_call_gfrt (FFECOM_gfrtCAT, expr_tree, NULL_TREE);
6796     TREE_SIDE_EFFECTS (expr_tree) = 1;
6797
6798     expand_expr_stmt (expr_tree);
6799   }
6800
6801   ffecom_concat_list_kill_ (catlist);
6802 }
6803
6804 /* ffecom_make_gfrt_ -- Make initial info for run-time routine
6805
6806    ffecomGfrt ix;
6807    ffecom_make_gfrt_(ix);
6808
6809    Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL
6810    for the indicated run-time routine (ix).  */
6811
6812 static void
6813 ffecom_make_gfrt_ (ffecomGfrt ix)
6814 {
6815   tree t;
6816   tree ttype;
6817
6818   switch (ffecom_gfrt_type_[ix])
6819     {
6820     case FFECOM_rttypeVOID_:
6821       ttype = void_type_node;
6822       break;
6823
6824     case FFECOM_rttypeVOIDSTAR_:
6825       ttype = TREE_TYPE (null_pointer_node);    /* `void *'. */
6826       break;
6827
6828     case FFECOM_rttypeFTNINT_:
6829       ttype = ffecom_f2c_ftnint_type_node;
6830       break;
6831
6832     case FFECOM_rttypeINTEGER_:
6833       ttype = ffecom_f2c_integer_type_node;
6834       break;
6835
6836     case FFECOM_rttypeLONGINT_:
6837       ttype = ffecom_f2c_longint_type_node;
6838       break;
6839
6840     case FFECOM_rttypeLOGICAL_:
6841       ttype = ffecom_f2c_logical_type_node;
6842       break;
6843
6844     case FFECOM_rttypeREAL_F2C_:
6845       ttype = double_type_node;
6846       break;
6847
6848     case FFECOM_rttypeREAL_GNU_:
6849       ttype = float_type_node;
6850       break;
6851
6852     case FFECOM_rttypeCOMPLEX_F2C_:
6853       ttype = void_type_node;
6854       break;
6855
6856     case FFECOM_rttypeCOMPLEX_GNU_:
6857       ttype = ffecom_f2c_complex_type_node;
6858       break;
6859
6860     case FFECOM_rttypeDOUBLE_:
6861       ttype = double_type_node;
6862       break;
6863
6864     case FFECOM_rttypeDOUBLEREAL_:
6865       ttype = ffecom_f2c_doublereal_type_node;
6866       break;
6867
6868     case FFECOM_rttypeDBLCMPLX_F2C_:
6869       ttype = void_type_node;
6870       break;
6871
6872     case FFECOM_rttypeDBLCMPLX_GNU_:
6873       ttype = ffecom_f2c_doublecomplex_type_node;
6874       break;
6875
6876     case FFECOM_rttypeCHARACTER_:
6877       ttype = void_type_node;
6878       break;
6879
6880     default:
6881       ttype = NULL;
6882       assert ("bad rttype" == NULL);
6883       break;
6884     }
6885
6886   ttype = build_function_type (ttype, NULL_TREE);
6887   t = build_decl (FUNCTION_DECL,
6888                   get_identifier (ffecom_gfrt_name_[ix]),
6889                   ttype);
6890   DECL_EXTERNAL (t) = 1;
6891   TREE_READONLY (t) = ffecom_gfrt_const_[ix] ? 1 : 0;
6892   TREE_PUBLIC (t) = 1;
6893   TREE_THIS_VOLATILE (t) = ffecom_gfrt_volatile_[ix] ? 1 : 0;
6894
6895   /* Sanity check:  A function that's const cannot be volatile.  */
6896
6897   assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_volatile_[ix] : 1);
6898
6899   /* Sanity check: A function that's const cannot return complex.  */
6900
6901   assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_complex_[ix] : 1);
6902
6903   t = start_decl (t, TRUE);
6904
6905   finish_decl (t, NULL_TREE, TRUE);
6906
6907   ffecom_gfrt_[ix] = t;
6908 }
6909
6910 /* Phase 1 pass over each member of a COMMON/EQUIVALENCE group.  */
6911
6912 static void
6913 ffecom_member_phase1_ (ffestorag mst UNUSED, ffestorag st)
6914 {
6915   ffesymbol s = ffestorag_symbol (st);
6916
6917   if (ffesymbol_namelisted (s))
6918     ffecom_member_namelisted_ = TRUE;
6919 }
6920
6921 /* Phase 2 pass over each member of a COMMON/EQUIVALENCE group.  Declare
6922    the member so debugger will see it.  Otherwise nobody should be
6923    referencing the member.  */
6924
6925 static void
6926 ffecom_member_phase2_ (ffestorag mst, ffestorag st)
6927 {
6928   ffesymbol s;
6929   tree t;
6930   tree mt;
6931   tree type;
6932
6933   if ((mst == NULL)
6934       || ((mt = ffestorag_hook (mst)) == NULL)
6935       || (mt == error_mark_node))
6936     return;
6937
6938   if ((st == NULL)
6939       || ((s = ffestorag_symbol (st)) == NULL))
6940     return;
6941
6942   type = ffecom_type_localvar_ (s,
6943                                 ffesymbol_basictype (s),
6944                                 ffesymbol_kindtype (s));
6945   if (type == error_mark_node)
6946     return;
6947
6948   t = build_decl (VAR_DECL,
6949                   ffecom_get_identifier_ (ffesymbol_text (s)),
6950                   type);
6951
6952   TREE_STATIC (t) = TREE_STATIC (mt);
6953   DECL_INITIAL (t) = NULL_TREE;
6954   TREE_ASM_WRITTEN (t) = 1;
6955   TREE_USED (t) = 1;
6956
6957   SET_DECL_RTL (t,
6958                 gen_rtx (MEM, TYPE_MODE (type),
6959                          plus_constant (XEXP (DECL_RTL (mt), 0),
6960                                         ffestorag_modulo (mst)
6961                                         + ffestorag_offset (st)
6962                                         - ffestorag_offset (mst))));
6963
6964   t = start_decl (t, FALSE);
6965
6966   finish_decl (t, NULL_TREE, FALSE);
6967 }
6968
6969 /* Prepare source expression for assignment into a destination perhaps known
6970    to be of a specific size.  */
6971
6972 static void
6973 ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size, ffebld source)
6974 {
6975   ffecomConcatList_ catlist;
6976   int count;
6977   int i;
6978   tree ltmp;
6979   tree itmp;
6980   tree tempvar = NULL_TREE;
6981
6982   while (ffebld_op (source) == FFEBLD_opCONVERT)
6983     source = ffebld_left (source);
6984
6985   catlist = ffecom_concat_list_new_ (source, dest_size);
6986   count = ffecom_concat_list_count_ (catlist);
6987
6988   if (count >= 2)
6989     {
6990       ltmp
6991         = ffecom_make_tempvar ("let_char_len", ffecom_f2c_ftnlen_type_node,
6992                                FFETARGET_charactersizeNONE, count);
6993       itmp
6994         = ffecom_make_tempvar ("let_char_item", ffecom_f2c_address_type_node,
6995                                FFETARGET_charactersizeNONE, count);
6996
6997       tempvar = make_tree_vec (2);
6998       TREE_VEC_ELT (tempvar, 0) = ltmp;
6999       TREE_VEC_ELT (tempvar, 1) = itmp;
7000     }
7001
7002   for (i = 0; i < count; ++i)
7003     ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist, i));
7004
7005   ffecom_concat_list_kill_ (catlist);
7006
7007   if (tempvar)
7008     {
7009       ffebld_nonter_set_hook (source, tempvar);
7010       current_binding_level->prep_state = 1;
7011     }
7012 }
7013
7014 /* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order
7015
7016    Ignores STAR (alternate-return) dummies.  All other get exec-transitioned
7017    (which generates their trees) and then their trees get push_parm_decl'd.
7018
7019    The second arg is TRUE if the dummies are for a statement function, in
7020    which case lengths are not pushed for character arguments (since they are
7021    always known by both the caller and the callee, though the code allows
7022    for someday permitting CHAR*(*) stmtfunc dummies).  */
7023
7024 static void
7025 ffecom_push_dummy_decls_ (ffebld dummy_list, bool stmtfunc)
7026 {
7027   ffebld dummy;
7028   ffebld dumlist;
7029   ffesymbol s;
7030   tree parm;
7031
7032   ffecom_transform_only_dummies_ = TRUE;
7033
7034   /* First push the parms corresponding to actual dummy "contents".  */
7035
7036   for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7037     {
7038       dummy = ffebld_head (dumlist);
7039       switch (ffebld_op (dummy))
7040         {
7041         case FFEBLD_opSTAR:
7042         case FFEBLD_opANY:
7043           continue;             /* Forget alternate returns. */
7044
7045         default:
7046           break;
7047         }
7048       assert (ffebld_op (dummy) == FFEBLD_opSYMTER);
7049       s = ffebld_symter (dummy);
7050       parm = ffesymbol_hook (s).decl_tree;
7051       if (parm == NULL_TREE)
7052         {
7053           s = ffecom_sym_transform_ (s);
7054           parm = ffesymbol_hook (s).decl_tree;
7055           assert (parm != NULL_TREE);
7056         }
7057       if (parm != error_mark_node)
7058         push_parm_decl (parm);
7059     }
7060
7061   /* Then, for CHARACTER dummies, push the parms giving their lengths.  */
7062
7063   for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7064     {
7065       dummy = ffebld_head (dumlist);
7066       switch (ffebld_op (dummy))
7067         {
7068         case FFEBLD_opSTAR:
7069         case FFEBLD_opANY:
7070           continue;             /* Forget alternate returns, they mean
7071                                    NOTHING! */
7072
7073         default:
7074           break;
7075         }
7076       s = ffebld_symter (dummy);
7077       if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
7078         continue;               /* Only looking for CHARACTER arguments. */
7079       if (stmtfunc && (ffesymbol_size (s) != FFETARGET_charactersizeNONE))
7080         continue;               /* Stmtfunc arg with known size needs no
7081                                    length param. */
7082       if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
7083         continue;               /* Only looking for variables and arrays. */
7084       parm = ffesymbol_hook (s).length_tree;
7085       assert (parm != NULL_TREE);
7086       if (parm != error_mark_node)
7087         push_parm_decl (parm);
7088     }
7089
7090   ffecom_transform_only_dummies_ = FALSE;
7091 }
7092
7093 /* ffecom_start_progunit_ -- Beginning of program unit
7094
7095    Does GNU back end stuff necessary to teach it about the start of its
7096    equivalent of a Fortran program unit.  */
7097
7098 static void
7099 ffecom_start_progunit_ ()
7100 {
7101   ffesymbol fn = ffecom_primary_entry_;
7102   ffebld arglist;
7103   tree id;                      /* Identifier (name) of function. */
7104   tree type;                    /* Type of function. */
7105   tree result;                  /* Result of function. */
7106   ffeinfoBasictype bt;
7107   ffeinfoKindtype kt;
7108   ffeglobal g;
7109   ffeglobalType gt;
7110   ffeglobalType egt = FFEGLOBAL_type;
7111   bool charfunc;
7112   bool cmplxfunc;
7113   bool altentries = (ffecom_num_entrypoints_ != 0);
7114   bool multi
7115   = altentries
7116   && (ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
7117   && (ffecom_master_bt_ == FFEINFO_basictypeNONE);
7118   bool main_program = FALSE;
7119   int old_lineno = lineno;
7120   const char *old_input_filename = input_filename;
7121
7122   assert (fn != NULL);
7123   assert (ffesymbol_hook (fn).decl_tree == NULL_TREE);
7124
7125   input_filename = ffesymbol_where_filename (fn);
7126   lineno = ffesymbol_where_filelinenum (fn);
7127
7128   switch (ffecom_primary_entry_kind_)
7129     {
7130     case FFEINFO_kindPROGRAM:
7131       main_program = TRUE;
7132       gt = FFEGLOBAL_typeMAIN;
7133       bt = FFEINFO_basictypeNONE;
7134       kt = FFEINFO_kindtypeNONE;
7135       type = ffecom_tree_fun_type_void;
7136       charfunc = FALSE;
7137       cmplxfunc = FALSE;
7138       break;
7139
7140     case FFEINFO_kindBLOCKDATA:
7141       gt = FFEGLOBAL_typeBDATA;
7142       bt = FFEINFO_basictypeNONE;
7143       kt = FFEINFO_kindtypeNONE;
7144       type = ffecom_tree_fun_type_void;
7145       charfunc = FALSE;
7146       cmplxfunc = FALSE;
7147       break;
7148
7149     case FFEINFO_kindFUNCTION:
7150       gt = FFEGLOBAL_typeFUNC;
7151       egt = FFEGLOBAL_typeEXT;
7152       bt = ffesymbol_basictype (fn);
7153       kt = ffesymbol_kindtype (fn);
7154       if (bt == FFEINFO_basictypeNONE)
7155         {
7156           ffeimplic_establish_symbol (fn);
7157           if (ffesymbol_funcresult (fn) != NULL)
7158             ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
7159           bt = ffesymbol_basictype (fn);
7160           kt = ffesymbol_kindtype (fn);
7161         }
7162
7163       if (multi)
7164         charfunc = cmplxfunc = FALSE;
7165       else if (bt == FFEINFO_basictypeCHARACTER)
7166         charfunc = TRUE, cmplxfunc = FALSE;
7167       else if ((bt == FFEINFO_basictypeCOMPLEX)
7168                && ffesymbol_is_f2c (fn)
7169                && !altentries)
7170         charfunc = FALSE, cmplxfunc = TRUE;
7171       else
7172         charfunc = cmplxfunc = FALSE;
7173
7174       if (multi || charfunc)
7175         type = ffecom_tree_fun_type_void;
7176       else if (ffesymbol_is_f2c (fn) && !altentries)
7177         type = ffecom_tree_fun_type[bt][kt];
7178       else
7179         type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
7180
7181       if ((type == NULL_TREE)
7182           || (TREE_TYPE (type) == NULL_TREE))
7183         type = ffecom_tree_fun_type_void;       /* _sym_exec_transition. */
7184       break;
7185
7186     case FFEINFO_kindSUBROUTINE:
7187       gt = FFEGLOBAL_typeSUBR;
7188       egt = FFEGLOBAL_typeEXT;
7189       bt = FFEINFO_basictypeNONE;
7190       kt = FFEINFO_kindtypeNONE;
7191       if (ffecom_is_altreturning_)
7192         type = ffecom_tree_subr_type;
7193       else
7194         type = ffecom_tree_fun_type_void;
7195       charfunc = FALSE;
7196       cmplxfunc = FALSE;
7197       break;
7198
7199     default:
7200       assert ("say what??" == NULL);
7201       /* Fall through. */
7202     case FFEINFO_kindANY:
7203       gt = FFEGLOBAL_typeANY;
7204       bt = FFEINFO_basictypeNONE;
7205       kt = FFEINFO_kindtypeNONE;
7206       type = error_mark_node;
7207       charfunc = FALSE;
7208       cmplxfunc = FALSE;
7209       break;
7210     }
7211
7212   if (altentries)
7213     {
7214       id = ffecom_get_invented_identifier ("__g77_masterfun_%s",
7215                                            ffesymbol_text (fn));
7216     }
7217 #if FFETARGET_isENFORCED_MAIN
7218   else if (main_program)
7219     id = get_identifier (FFETARGET_nameENFORCED_MAIN_NAME);
7220 #endif
7221   else
7222     id = ffecom_get_external_identifier_ (fn);
7223
7224   start_function (id,
7225                   type,
7226                   0,            /* nested/inline */
7227                   !altentries); /* TREE_PUBLIC */
7228
7229   TREE_USED (current_function_decl) = 1;        /* Avoid spurious warning if altentries. */
7230
7231   if (!altentries
7232       && ((g = ffesymbol_global (fn)) != NULL)
7233       && ((ffeglobal_type (g) == gt)
7234           || (ffeglobal_type (g) == egt)))
7235     {
7236       ffeglobal_set_hook (g, current_function_decl);
7237     }
7238
7239   /* Arg handling needs exec-transitioned ffesymbols to work with.  But
7240      exec-transitioning needs current_function_decl to be filled in.  So we
7241      do these things in two phases. */
7242
7243   if (altentries)
7244     {                           /* 1st arg identifies which entrypoint. */
7245       ffecom_which_entrypoint_decl_
7246         = build_decl (PARM_DECL,
7247                       ffecom_get_invented_identifier ("__g77_%s",
7248                                                       "which_entrypoint"),
7249                       integer_type_node);
7250       push_parm_decl (ffecom_which_entrypoint_decl_);
7251     }
7252
7253   if (charfunc
7254       || cmplxfunc
7255       || multi)
7256     {                           /* Arg for result (return value). */
7257       tree type;
7258       tree length;
7259
7260       if (charfunc)
7261         type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
7262       else if (cmplxfunc)
7263         type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
7264       else
7265         type = ffecom_multi_type_node_;
7266
7267       result = ffecom_get_invented_identifier ("__g77_%s", "result");
7268
7269       /* Make length arg _and_ enhance type info for CHAR arg itself.  */
7270
7271       if (charfunc)
7272         length = ffecom_char_enhance_arg_ (&type, fn);
7273       else
7274         length = NULL_TREE;     /* Not ref'd if !charfunc. */
7275
7276       type = build_pointer_type (type);
7277       result = build_decl (PARM_DECL, result, type);
7278
7279       push_parm_decl (result);
7280       if (multi)
7281         ffecom_multi_retval_ = result;
7282       else
7283         ffecom_func_result_ = result;
7284
7285       if (charfunc)
7286         {
7287           push_parm_decl (length);
7288           ffecom_func_length_ = length;
7289         }
7290     }
7291
7292   if (ffecom_primary_entry_is_proc_)
7293     {
7294       if (altentries)
7295         arglist = ffecom_master_arglist_;
7296       else
7297         arglist = ffesymbol_dummyargs (fn);
7298       ffecom_push_dummy_decls_ (arglist, FALSE);
7299     }
7300
7301   if (TREE_CODE (current_function_decl) != ERROR_MARK)
7302     store_parm_decls (main_program ? 1 : 0);
7303
7304   ffecom_start_compstmt ();
7305   /* Disallow temp vars at this level.  */
7306   current_binding_level->prep_state = 2;
7307
7308   lineno = old_lineno;
7309   input_filename = old_input_filename;
7310
7311   /* This handles any symbols still untransformed, in case -g specified.
7312      This used to be done in ffecom_finish_progunit, but it turns out to
7313      be necessary to do it here so that statement functions are
7314      expanded before code.  But don't bother for BLOCK DATA.  */
7315
7316   if (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
7317     ffesymbol_drive (ffecom_finish_symbol_transform_);
7318 }
7319
7320 /* ffecom_sym_transform_ -- Transform FFE sym into backend sym
7321
7322    ffesymbol s;
7323    ffecom_sym_transform_(s);
7324
7325    The ffesymbol_hook info for s is updated with appropriate backend info
7326    on the symbol.  */
7327
7328 static ffesymbol
7329 ffecom_sym_transform_ (ffesymbol s)
7330 {
7331   tree t;                       /* Transformed thingy. */
7332   tree tlen;                    /* Length if CHAR*(*). */
7333   bool addr;                    /* Is t the address of the thingy? */
7334   ffeinfoBasictype bt;
7335   ffeinfoKindtype kt;
7336   ffeglobal g;
7337   int old_lineno = lineno;
7338   const char *old_input_filename = input_filename;
7339
7340   /* Must ensure special ASSIGN variables are declared at top of outermost
7341      block, else they'll end up in the innermost block when their first
7342      ASSIGN is seen, which leaves them out of scope when they're the
7343      subject of a GOTO or I/O statement.
7344
7345      We make this variable even if -fugly-assign.  Just let it go unused,
7346      in case it turns out there are cases where we really want to use this
7347      variable anyway (e.g. ASSIGN to INTEGER*2 variable).  */
7348
7349   if (! ffecom_transform_only_dummies_
7350       && ffesymbol_assigned (s)
7351       && ! ffesymbol_hook (s).assign_tree)
7352     s = ffecom_sym_transform_assign_ (s);
7353
7354   if (ffesymbol_sfdummyparent (s) == NULL)
7355     {
7356       input_filename = ffesymbol_where_filename (s);
7357       lineno = ffesymbol_where_filelinenum (s);
7358     }
7359   else
7360     {
7361       ffesymbol sf = ffesymbol_sfdummyparent (s);
7362
7363       input_filename = ffesymbol_where_filename (sf);
7364       lineno = ffesymbol_where_filelinenum (sf);
7365     }
7366
7367   bt = ffeinfo_basictype (ffebld_info (s));
7368   kt = ffeinfo_kindtype (ffebld_info (s));
7369
7370   t = NULL_TREE;
7371   tlen = NULL_TREE;
7372   addr = FALSE;
7373
7374   switch (ffesymbol_kind (s))
7375     {
7376     case FFEINFO_kindNONE:
7377       switch (ffesymbol_where (s))
7378         {
7379         case FFEINFO_whereDUMMY:        /* Subroutine or function. */
7380           assert (ffecom_transform_only_dummies_);
7381
7382           /* Before 0.4, this could be ENTITY/DUMMY, but see
7383              ffestu_sym_end_transition -- no longer true (in particular, if
7384              it could be an ENTITY, it _will_ be made one, so that
7385              possibility won't come through here).  So we never make length
7386              arg for CHARACTER type.  */
7387
7388           t = build_decl (PARM_DECL,
7389                           ffecom_get_identifier_ (ffesymbol_text (s)),
7390                           ffecom_tree_ptr_to_subr_type);
7391           DECL_ARTIFICIAL (t) = 1;
7392           addr = TRUE;
7393           break;
7394
7395         case FFEINFO_whereGLOBAL:       /* Subroutine or function. */
7396           assert (!ffecom_transform_only_dummies_);
7397
7398           if (((g = ffesymbol_global (s)) != NULL)
7399               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7400                   || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7401                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
7402               && (ffeglobal_hook (g) != NULL_TREE)
7403               && ffe_is_globals ())
7404             {
7405               t = ffeglobal_hook (g);
7406               break;
7407             }
7408
7409           t = build_decl (FUNCTION_DECL,
7410                           ffecom_get_external_identifier_ (s),
7411                           ffecom_tree_subr_type);       /* Assume subr. */
7412           DECL_EXTERNAL (t) = 1;
7413           TREE_PUBLIC (t) = 1;
7414
7415           t = start_decl (t, FALSE);
7416           finish_decl (t, NULL_TREE, FALSE);
7417
7418           if ((g != NULL)
7419               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7420                   || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7421                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
7422             ffeglobal_set_hook (g, t);
7423
7424           ffecom_save_tree_forever (t);
7425
7426           break;
7427
7428         default:
7429           assert ("NONE where unexpected" == NULL);
7430           /* Fall through. */
7431         case FFEINFO_whereANY:
7432           break;
7433         }
7434       break;
7435
7436     case FFEINFO_kindENTITY:
7437       switch (ffeinfo_where (ffesymbol_info (s)))
7438         {
7439
7440         case FFEINFO_whereCONSTANT:
7441           /* ~~Debugging info needed? */
7442           assert (!ffecom_transform_only_dummies_);
7443           t = error_mark_node;  /* Shouldn't ever see this in expr. */
7444           break;
7445
7446         case FFEINFO_whereLOCAL:
7447           assert (!ffecom_transform_only_dummies_);
7448
7449           {
7450             ffestorag st = ffesymbol_storage (s);
7451             tree type;
7452
7453             if ((st != NULL)
7454                 && (ffestorag_size (st) == 0))
7455               {
7456                 t = error_mark_node;
7457                 break;
7458               }
7459
7460             type = ffecom_type_localvar_ (s, bt, kt);
7461
7462             if (type == error_mark_node)
7463               {
7464                 t = error_mark_node;
7465                 break;
7466               }
7467
7468             if ((st != NULL)
7469                 && (ffestorag_parent (st) != NULL))
7470               {                 /* Child of EQUIVALENCE parent. */
7471                 ffestorag est;
7472                 tree et;
7473                 ffetargetOffset offset;
7474
7475                 est = ffestorag_parent (st);
7476                 ffecom_transform_equiv_ (est);
7477
7478                 et = ffestorag_hook (est);
7479                 assert (et != NULL_TREE);
7480
7481                 if (! TREE_STATIC (et))
7482                   put_var_into_stack (et);
7483
7484                 offset = ffestorag_modulo (est)
7485                   + ffestorag_offset (ffesymbol_storage (s))
7486                   - ffestorag_offset (est);
7487
7488                 ffecom_debug_kludge_ (et, "EQUIVALENCE", s, type, offset);
7489
7490                 /* (t_type *) (((char *) &et) + offset) */
7491
7492                 t = convert (string_type_node,  /* (char *) */
7493                              ffecom_1 (ADDR_EXPR,
7494                                        build_pointer_type (TREE_TYPE (et)),
7495                                        et));
7496                 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
7497                               t,
7498                               build_int_2 (offset, 0));
7499                 t = convert (build_pointer_type (type),
7500                              t);
7501                 TREE_CONSTANT (t) = staticp (et);
7502
7503                 addr = TRUE;
7504               }
7505             else
7506               {
7507                 tree initexpr;
7508                 bool init = ffesymbol_is_init (s);
7509
7510                 t = build_decl (VAR_DECL,
7511                                 ffecom_get_identifier_ (ffesymbol_text (s)),
7512                                 type);
7513
7514                 if (init
7515                     || ffesymbol_namelisted (s)
7516 #ifdef FFECOM_sizeMAXSTACKITEM
7517                     || ((st != NULL)
7518                         && (ffestorag_size (st) > FFECOM_sizeMAXSTACKITEM))
7519 #endif
7520                     || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
7521                         && (ffecom_primary_entry_kind_
7522                             != FFEINFO_kindBLOCKDATA)
7523                         && (ffesymbol_is_save (s) || ffe_is_saveall ())))
7524                   TREE_STATIC (t) = !ffesymbol_attr (s, FFESYMBOL_attrADJUSTABLE);
7525                 else
7526                   TREE_STATIC (t) = 0;  /* No need to make static. */
7527
7528                 if (init || ffe_is_init_local_zero ())
7529                   DECL_INITIAL (t) = error_mark_node;
7530
7531                 /* Keep -Wunused from complaining about var if it
7532                    is used as sfunc arg or DATA implied-DO.  */
7533                 if (ffesymbol_attrs (s) & FFESYMBOL_attrsSFARG)
7534                   DECL_IN_SYSTEM_HEADER (t) = 1;
7535
7536                 t = start_decl (t, FALSE);
7537
7538                 if (init)
7539                   {
7540                     if (ffesymbol_init (s) != NULL)
7541                       initexpr = ffecom_expr (ffesymbol_init (s));
7542                     else
7543                       initexpr = ffecom_init_zero_ (t);
7544                   }
7545                 else if (ffe_is_init_local_zero ())
7546                   initexpr = ffecom_init_zero_ (t);
7547                 else
7548                   initexpr = NULL_TREE; /* Not ref'd if !init. */
7549
7550                 finish_decl (t, initexpr, FALSE);
7551
7552                 if (st != NULL && DECL_SIZE (t) != error_mark_node)
7553                   {
7554                     assert (TREE_CODE (DECL_SIZE_UNIT (t)) == INTEGER_CST);
7555                     assert (0 == compare_tree_int (DECL_SIZE_UNIT (t),
7556                                                    ffestorag_size (st)));
7557                   }
7558               }
7559           }
7560           break;
7561
7562         case FFEINFO_whereRESULT:
7563           assert (!ffecom_transform_only_dummies_);
7564
7565           if (bt == FFEINFO_basictypeCHARACTER)
7566             {                   /* Result is already in list of dummies, use
7567                                    it (& length). */
7568               t = ffecom_func_result_;
7569               tlen = ffecom_func_length_;
7570               addr = TRUE;
7571               break;
7572             }
7573           if ((ffecom_num_entrypoints_ == 0)
7574               && (bt == FFEINFO_basictypeCOMPLEX)
7575               && (ffesymbol_is_f2c (ffecom_primary_entry_)))
7576             {                   /* Result is already in list of dummies, use
7577                                    it. */
7578               t = ffecom_func_result_;
7579               addr = TRUE;
7580               break;
7581             }
7582           if (ffecom_func_result_ != NULL_TREE)
7583             {
7584               t = ffecom_func_result_;
7585               break;
7586             }
7587           if ((ffecom_num_entrypoints_ != 0)
7588               && (ffecom_master_bt_ == FFEINFO_basictypeNONE))
7589             {
7590               assert (ffecom_multi_retval_ != NULL_TREE);
7591               t = ffecom_1 (INDIRECT_REF, ffecom_multi_type_node_,
7592                             ffecom_multi_retval_);
7593               t = ffecom_2 (COMPONENT_REF, ffecom_tree_type[bt][kt],
7594                             t, ffecom_multi_fields_[bt][kt]);
7595
7596               break;
7597             }
7598
7599           t = build_decl (VAR_DECL,
7600                           ffecom_get_identifier_ (ffesymbol_text (s)),
7601                           ffecom_tree_type[bt][kt]);
7602           TREE_STATIC (t) = 0;  /* Put result on stack. */
7603           t = start_decl (t, FALSE);
7604           finish_decl (t, NULL_TREE, FALSE);
7605
7606           ffecom_func_result_ = t;
7607
7608           break;
7609
7610         case FFEINFO_whereDUMMY:
7611           {
7612             tree type;
7613             ffebld dl;
7614             ffebld dim;
7615             tree low;
7616             tree high;
7617             tree old_sizes;
7618             bool adjustable = FALSE;    /* Conditionally adjustable? */
7619
7620             type = ffecom_tree_type[bt][kt];
7621             if (ffesymbol_sfdummyparent (s) != NULL)
7622               {
7623                 if (current_function_decl == ffecom_outer_function_decl_)
7624                   {                     /* Exec transition before sfunc
7625                                            context; get it later. */
7626                     break;
7627                   }
7628                 t = ffecom_get_identifier_ (ffesymbol_text
7629                                             (ffesymbol_sfdummyparent (s)));
7630               }
7631             else
7632               t = ffecom_get_identifier_ (ffesymbol_text (s));
7633
7634             assert (ffecom_transform_only_dummies_);
7635
7636             old_sizes = get_pending_sizes ();
7637             put_pending_sizes (old_sizes);
7638
7639             if (bt == FFEINFO_basictypeCHARACTER)
7640               tlen = ffecom_char_enhance_arg_ (&type, s);
7641             type = ffecom_check_size_overflow_ (s, type, TRUE);
7642
7643             for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
7644               {
7645                 if (type == error_mark_node)
7646                   break;
7647
7648                 dim = ffebld_head (dl);
7649                 assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
7650                 if ((ffebld_left (dim) == NULL) || ffecom_doing_entry_)
7651                   low = ffecom_integer_one_node;
7652                 else
7653                   low = ffecom_expr (ffebld_left (dim));
7654                 assert (ffebld_right (dim) != NULL);
7655                 if ((ffebld_op (ffebld_right (dim)) == FFEBLD_opSTAR)
7656                     || ffecom_doing_entry_)
7657                   {
7658                     /* Used to just do high=low.  But for ffecom_tree_
7659                        canonize_ref_, it probably is important to correctly
7660                        assess the size.  E.g. given COMPLEX C(*),CFUNC and
7661                        C(2)=CFUNC(C), overlap can happen, while it can't
7662                        for, say, C(1)=CFUNC(C(2)).  */
7663                     /* Even more recently used to set to INT_MAX, but that
7664                        broke when some overflow checking went into the back
7665                        end.  Now we just leave the upper bound unspecified.  */
7666                     high = NULL;
7667                   }
7668                 else
7669                   high = ffecom_expr (ffebld_right (dim));
7670
7671                 /* Determine whether array is conditionally adjustable,
7672                    to decide whether back-end magic is needed.
7673
7674                    Normally the front end uses the back-end function
7675                    variable_size to wrap SAVE_EXPR's around expressions
7676                    affecting the size/shape of an array so that the
7677                    size/shape info doesn't change during execution
7678                    of the compiled code even though variables and
7679                    functions referenced in those expressions might.
7680
7681                    variable_size also makes sure those saved expressions
7682                    get evaluated immediately upon entry to the
7683                    compiled procedure -- the front end normally doesn't
7684                    have to worry about that.
7685
7686                    However, there is a problem with this that affects
7687                    g77's implementation of entry points, and that is
7688                    that it is _not_ true that each invocation of the
7689                    compiled procedure is permitted to evaluate
7690                    array size/shape info -- because it is possible
7691                    that, for some invocations, that info is invalid (in
7692                    which case it is "promised" -- i.e. a violation of
7693                    the Fortran standard -- that the compiled code
7694                    won't reference the array or its size/shape
7695                    during that particular invocation).
7696
7697                    To phrase this in C terms, consider this gcc function:
7698
7699                      void foo (int *n, float (*a)[*n])
7700                      {
7701                        // a is "pointer to array ...", fyi.
7702                      }
7703
7704                    Suppose that, for some invocations, it is permitted
7705                    for a caller of foo to do this:
7706
7707                        foo (NULL, NULL);
7708
7709                    Now the _written_ code for foo can take such a call
7710                    into account by either testing explicitly for whether
7711                    (a == NULL) || (n == NULL) -- presumably it is
7712                    not permitted to reference *a in various fashions
7713                    if (n == NULL) I suppose -- or it can avoid it by
7714                    looking at other info (other arguments, static/global
7715                    data, etc.).
7716
7717                    However, this won't work in gcc 2.5.8 because it'll
7718                    automatically emit the code to save the "*n"
7719                    expression, which'll yield a NULL dereference for
7720                    the "foo (NULL, NULL)" call, something the code
7721                    for foo cannot prevent.
7722
7723                    g77 definitely needs to avoid executing such
7724                    code anytime the pointer to the adjustable array
7725                    is NULL, because even if its bounds expressions
7726                    don't have any references to possible "absent"
7727                    variables like "*n" -- say all variable references
7728                    are to COMMON variables, i.e. global (though in C,
7729                    local static could actually make sense) -- the
7730                    expressions could yield other run-time problems
7731                    for allowably "dead" values in those variables.
7732
7733                    For example, let's consider a more complicated
7734                    version of foo:
7735
7736                      extern int i;
7737                      extern int j;
7738
7739                      void foo (float (*a)[i/j])
7740                      {
7741                        ...
7742                      }
7743
7744                    The above is (essentially) quite valid for Fortran
7745                    but, again, for a call like "foo (NULL);", it is
7746                    permitted for i and j to be undefined when the
7747                    call is made.  If j happened to be zero, for
7748                    example, emitting the code to evaluate "i/j"
7749                    could result in a run-time error.
7750
7751                    Offhand, though I don't have my F77 or F90
7752                    standards handy, it might even be valid for a
7753                    bounds expression to contain a function reference,
7754                    in which case I doubt it is permitted for an
7755                    implementation to invoke that function in the
7756                    Fortran case involved here (invocation of an
7757                    alternate ENTRY point that doesn't have the adjustable
7758                    array as one of its arguments).
7759
7760                    So, the code that the compiler would normally emit
7761                    to preevaluate the size/shape info for an
7762                    adjustable array _must not_ be executed at run time
7763                    in certain cases.  Specifically, for Fortran,
7764                    the case is when the pointer to the adjustable
7765                    array == NULL.  (For gnu-ish C, it might be nice
7766                    for the source code itself to specify an expression
7767                    that, if TRUE, inhibits execution of the code.  Or
7768                    reverse the sense for elegance.)
7769
7770                    (Note that g77 could use a different test than NULL,
7771                    actually, since it happens to always pass an
7772                    integer to the called function that specifies which
7773                    entry point is being invoked.  Hmm, this might
7774                    solve the next problem.)
7775
7776                    One way a user could, I suppose, write "foo" so
7777                    it works is to insert COND_EXPR's for the
7778                    size/shape info so the dangerous stuff isn't
7779                    actually done, as in:
7780
7781                      void foo (int *n, float (*a)[(a == NULL) ? 0 : *n])
7782                      {
7783                        ...
7784                      }
7785
7786                    The next problem is that the front end needs to
7787                    be able to tell the back end about the array's
7788                    decl _before_ it tells it about the conditional
7789                    expression to inhibit evaluation of size/shape info,
7790                    as shown above.
7791
7792                    To solve this, the front end needs to be able
7793                    to give the back end the expression to inhibit
7794                    generation of the preevaluation code _after_
7795                    it makes the decl for the adjustable array.
7796
7797                    Until then, the above example using the COND_EXPR
7798                    doesn't pass muster with gcc because the "(a == NULL)"
7799                    part has a reference to "a", which is still
7800                    undefined at that point.
7801
7802                    g77 will therefore use a different mechanism in the
7803                    meantime.  */
7804
7805                 if (!adjustable
7806                     && ((TREE_CODE (low) != INTEGER_CST)
7807                         || (high && TREE_CODE (high) != INTEGER_CST)))
7808                   adjustable = TRUE;
7809
7810 #if 0                           /* Old approach -- see below. */
7811                 if (TREE_CODE (low) != INTEGER_CST)
7812                   low = ffecom_3 (COND_EXPR, integer_type_node,
7813                                   ffecom_adjarray_passed_ (s),
7814                                   low,
7815                                   ffecom_integer_zero_node);
7816
7817                 if (high && TREE_CODE (high) != INTEGER_CST)
7818                   high = ffecom_3 (COND_EXPR, integer_type_node,
7819                                    ffecom_adjarray_passed_ (s),
7820                                    high,
7821                                    ffecom_integer_zero_node);
7822 #endif
7823
7824                 /* ~~~gcc/stor-layout.c (layout_type) should do this,
7825                    probably.  Fixes 950302-1.f.  */
7826
7827                 if (TREE_CODE (low) != INTEGER_CST)
7828                   low = variable_size (low);
7829
7830                 /* ~~~Similarly, this fixes dumb0.f.  The C front end
7831                    does this, which is why dumb0.c would work.  */
7832
7833                 if (high && TREE_CODE (high) != INTEGER_CST)
7834                   high = variable_size (high);
7835
7836                 type
7837                   = build_array_type
7838                     (type,
7839                      build_range_type (ffecom_integer_type_node,
7840                                        low, high));
7841                 type = ffecom_check_size_overflow_ (s, type, TRUE);
7842               }
7843
7844             if (type == error_mark_node)
7845               {
7846                 t = error_mark_node;
7847                 break;
7848               }
7849
7850             if ((ffesymbol_sfdummyparent (s) == NULL)
7851                  || (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER))
7852               {
7853                 type = build_pointer_type (type);
7854                 addr = TRUE;
7855               }
7856
7857             t = build_decl (PARM_DECL, t, type);
7858             DECL_ARTIFICIAL (t) = 1;
7859
7860             /* If this arg is present in every entry point's list of
7861                dummy args, then we're done.  */
7862
7863             if (ffesymbol_numentries (s)
7864                 == (ffecom_num_entrypoints_ + 1))
7865               break;
7866
7867 #if 1
7868
7869             /* If variable_size in stor-layout has been called during
7870                the above, then get_pending_sizes should have the
7871                yet-to-be-evaluated saved expressions pending.
7872                Make the whole lot of them get emitted, conditionally
7873                on whether the array decl ("t" above) is not NULL.  */
7874
7875             {
7876               tree sizes = get_pending_sizes ();
7877               tree tem;
7878
7879               for (tem = sizes;
7880                    tem != old_sizes;
7881                    tem = TREE_CHAIN (tem))
7882                 {
7883                   tree temv = TREE_VALUE (tem);
7884
7885                   if (sizes == tem)
7886                     sizes = temv;
7887                   else
7888                     sizes
7889                       = ffecom_2 (COMPOUND_EXPR,
7890                                   TREE_TYPE (sizes),
7891                                   temv,
7892                                   sizes);
7893                 }
7894
7895               if (sizes != tem)
7896                 {
7897                   sizes
7898                     = ffecom_3 (COND_EXPR,
7899                                 TREE_TYPE (sizes),
7900                                 ffecom_2 (NE_EXPR,
7901                                           integer_type_node,
7902                                           t,
7903                                           null_pointer_node),
7904                                 sizes,
7905                                 convert (TREE_TYPE (sizes),
7906                                          integer_zero_node));
7907                   sizes = ffecom_save_tree (sizes);
7908
7909                   sizes
7910                     = tree_cons (NULL_TREE, sizes, tem);
7911                 }
7912
7913               if (sizes)
7914                 put_pending_sizes (sizes);
7915             }
7916
7917 #else
7918 #if 0
7919             if (adjustable
7920                 && (ffesymbol_numentries (s)
7921                     != ffecom_num_entrypoints_ + 1))
7922               DECL_SOMETHING (t)
7923                 = ffecom_2 (NE_EXPR, integer_type_node,
7924                             t,
7925                             null_pointer_node);
7926 #else
7927 #if 0
7928             if (adjustable
7929                 && (ffesymbol_numentries (s)
7930                     != ffecom_num_entrypoints_ + 1))
7931               {
7932                 ffebad_start (FFEBAD_MISSING_ADJARRAY_UNSUPPORTED);
7933                 ffebad_here (0, ffesymbol_where_line (s),
7934                              ffesymbol_where_column (s));
7935                 ffebad_string (ffesymbol_text (s));
7936                 ffebad_finish ();
7937               }
7938 #endif
7939 #endif
7940 #endif
7941           }
7942           break;
7943
7944         case FFEINFO_whereCOMMON:
7945           {
7946             ffesymbol cs;
7947             ffeglobal cg;
7948             tree ct;
7949             ffestorag st = ffesymbol_storage (s);
7950             tree type;
7951
7952             cs = ffesymbol_common (s);  /* The COMMON area itself.  */
7953             if (st != NULL)     /* Else not laid out. */
7954               {
7955                 ffecom_transform_common_ (cs);
7956                 st = ffesymbol_storage (s);
7957               }
7958
7959             type = ffecom_type_localvar_ (s, bt, kt);
7960
7961             cg = ffesymbol_global (cs); /* The global COMMON info.  */
7962             if ((cg == NULL)
7963                 || (ffeglobal_type (cg) != FFEGLOBAL_typeCOMMON))
7964               ct = NULL_TREE;
7965             else
7966               ct = ffeglobal_hook (cg); /* The common area's tree.  */
7967
7968             if ((ct == NULL_TREE)
7969                 || (st == NULL)
7970                 || (type == error_mark_node))
7971               t = error_mark_node;
7972             else
7973               {
7974                 ffetargetOffset offset;
7975                 ffestorag cst;
7976
7977                 cst = ffestorag_parent (st);
7978                 assert (cst == ffesymbol_storage (cs));
7979
7980                 offset = ffestorag_modulo (cst)
7981                   + ffestorag_offset (st)
7982                   - ffestorag_offset (cst);
7983
7984                 ffecom_debug_kludge_ (ct, "COMMON", s, type, offset);
7985
7986                 /* (t_type *) (((char *) &ct) + offset) */
7987
7988                 t = convert (string_type_node,  /* (char *) */
7989                              ffecom_1 (ADDR_EXPR,
7990                                        build_pointer_type (TREE_TYPE (ct)),
7991                                        ct));
7992                 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
7993                               t,
7994                               build_int_2 (offset, 0));
7995                 t = convert (build_pointer_type (type),
7996                              t);
7997                 TREE_CONSTANT (t) = 1;
7998
7999                 addr = TRUE;
8000               }
8001           }
8002           break;
8003
8004         case FFEINFO_whereIMMEDIATE:
8005         case FFEINFO_whereGLOBAL:
8006         case FFEINFO_whereFLEETING:
8007         case FFEINFO_whereFLEETING_CADDR:
8008         case FFEINFO_whereFLEETING_IADDR:
8009         case FFEINFO_whereINTRINSIC:
8010         case FFEINFO_whereCONSTANT_SUBOBJECT:
8011         default:
8012           assert ("ENTITY where unheard of" == NULL);
8013           /* Fall through. */
8014         case FFEINFO_whereANY:
8015           t = error_mark_node;
8016           break;
8017         }
8018       break;
8019
8020     case FFEINFO_kindFUNCTION:
8021       switch (ffeinfo_where (ffesymbol_info (s)))
8022         {
8023         case FFEINFO_whereLOCAL:        /* Me. */
8024           assert (!ffecom_transform_only_dummies_);
8025           t = current_function_decl;
8026           break;
8027
8028         case FFEINFO_whereGLOBAL:
8029           assert (!ffecom_transform_only_dummies_);
8030
8031           if (((g = ffesymbol_global (s)) != NULL)
8032               && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8033                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8034               && (ffeglobal_hook (g) != NULL_TREE)
8035               && ffe_is_globals ())
8036             {
8037               t = ffeglobal_hook (g);
8038               break;
8039             }
8040
8041           if (ffesymbol_is_f2c (s)
8042               && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8043             t = ffecom_tree_fun_type[bt][kt];
8044           else
8045             t = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
8046
8047           t = build_decl (FUNCTION_DECL,
8048                           ffecom_get_external_identifier_ (s),
8049                           t);
8050           DECL_EXTERNAL (t) = 1;
8051           TREE_PUBLIC (t) = 1;
8052
8053           t = start_decl (t, FALSE);
8054           finish_decl (t, NULL_TREE, FALSE);
8055
8056           if ((g != NULL)
8057               && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8058                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8059             ffeglobal_set_hook (g, t);
8060
8061           ffecom_save_tree_forever (t);
8062
8063           break;
8064
8065         case FFEINFO_whereDUMMY:
8066           assert (ffecom_transform_only_dummies_);
8067
8068           if (ffesymbol_is_f2c (s)
8069               && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8070             t = ffecom_tree_ptr_to_fun_type[bt][kt];
8071           else
8072             t = build_pointer_type
8073               (build_function_type (ffecom_tree_type[bt][kt], NULL_TREE));
8074
8075           t = build_decl (PARM_DECL,
8076                           ffecom_get_identifier_ (ffesymbol_text (s)),
8077                           t);
8078           DECL_ARTIFICIAL (t) = 1;
8079           addr = TRUE;
8080           break;
8081
8082         case FFEINFO_whereCONSTANT:     /* Statement function. */
8083           assert (!ffecom_transform_only_dummies_);
8084           t = ffecom_gen_sfuncdef_ (s, bt, kt);
8085           break;
8086
8087         case FFEINFO_whereINTRINSIC:
8088           assert (!ffecom_transform_only_dummies_);
8089           break;                /* Let actual references generate their
8090                                    decls. */
8091
8092         default:
8093           assert ("FUNCTION where unheard of" == NULL);
8094           /* Fall through. */
8095         case FFEINFO_whereANY:
8096           t = error_mark_node;
8097           break;
8098         }
8099       break;
8100
8101     case FFEINFO_kindSUBROUTINE:
8102       switch (ffeinfo_where (ffesymbol_info (s)))
8103         {
8104         case FFEINFO_whereLOCAL:        /* Me. */
8105           assert (!ffecom_transform_only_dummies_);
8106           t = current_function_decl;
8107           break;
8108
8109         case FFEINFO_whereGLOBAL:
8110           assert (!ffecom_transform_only_dummies_);
8111
8112           if (((g = ffesymbol_global (s)) != NULL)
8113               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8114                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8115               && (ffeglobal_hook (g) != NULL_TREE)
8116               && ffe_is_globals ())
8117             {
8118               t = ffeglobal_hook (g);
8119               break;
8120             }
8121
8122           t = build_decl (FUNCTION_DECL,
8123                           ffecom_get_external_identifier_ (s),
8124                           ffecom_tree_subr_type);
8125           DECL_EXTERNAL (t) = 1;
8126           TREE_PUBLIC (t) = 1;
8127
8128           t = start_decl (t, FALSE);
8129           finish_decl (t, NULL_TREE, FALSE);
8130
8131           if ((g != NULL)
8132               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8133                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8134             ffeglobal_set_hook (g, t);
8135
8136           ffecom_save_tree_forever (t);
8137
8138           break;
8139
8140         case FFEINFO_whereDUMMY:
8141           assert (ffecom_transform_only_dummies_);
8142
8143           t = build_decl (PARM_DECL,
8144                           ffecom_get_identifier_ (ffesymbol_text (s)),
8145                           ffecom_tree_ptr_to_subr_type);
8146           DECL_ARTIFICIAL (t) = 1;
8147           addr = TRUE;
8148           break;
8149
8150         case FFEINFO_whereINTRINSIC:
8151           assert (!ffecom_transform_only_dummies_);
8152           break;                /* Let actual references generate their
8153                                    decls. */
8154
8155         default:
8156           assert ("SUBROUTINE where unheard of" == NULL);
8157           /* Fall through. */
8158         case FFEINFO_whereANY:
8159           t = error_mark_node;
8160           break;
8161         }
8162       break;
8163
8164     case FFEINFO_kindPROGRAM:
8165       switch (ffeinfo_where (ffesymbol_info (s)))
8166         {
8167         case FFEINFO_whereLOCAL:        /* Me. */
8168           assert (!ffecom_transform_only_dummies_);
8169           t = current_function_decl;
8170           break;
8171
8172         case FFEINFO_whereCOMMON:
8173         case FFEINFO_whereDUMMY:
8174         case FFEINFO_whereGLOBAL:
8175         case FFEINFO_whereRESULT:
8176         case FFEINFO_whereFLEETING:
8177         case FFEINFO_whereFLEETING_CADDR:
8178         case FFEINFO_whereFLEETING_IADDR:
8179         case FFEINFO_whereIMMEDIATE:
8180         case FFEINFO_whereINTRINSIC:
8181         case FFEINFO_whereCONSTANT:
8182         case FFEINFO_whereCONSTANT_SUBOBJECT:
8183         default:
8184           assert ("PROGRAM where unheard of" == NULL);
8185           /* Fall through. */
8186         case FFEINFO_whereANY:
8187           t = error_mark_node;
8188           break;
8189         }
8190       break;
8191
8192     case FFEINFO_kindBLOCKDATA:
8193       switch (ffeinfo_where (ffesymbol_info (s)))
8194         {
8195         case FFEINFO_whereLOCAL:        /* Me. */
8196           assert (!ffecom_transform_only_dummies_);
8197           t = current_function_decl;
8198           break;
8199
8200         case FFEINFO_whereGLOBAL:
8201           assert (!ffecom_transform_only_dummies_);
8202
8203           t = build_decl (FUNCTION_DECL,
8204                           ffecom_get_external_identifier_ (s),
8205                           ffecom_tree_blockdata_type);
8206           DECL_EXTERNAL (t) = 1;
8207           TREE_PUBLIC (t) = 1;
8208
8209           t = start_decl (t, FALSE);
8210           finish_decl (t, NULL_TREE, FALSE);
8211
8212           ffecom_save_tree_forever (t);
8213
8214           break;
8215
8216         case FFEINFO_whereCOMMON:
8217         case FFEINFO_whereDUMMY:
8218         case FFEINFO_whereRESULT:
8219         case FFEINFO_whereFLEETING:
8220         case FFEINFO_whereFLEETING_CADDR:
8221         case FFEINFO_whereFLEETING_IADDR:
8222         case FFEINFO_whereIMMEDIATE:
8223         case FFEINFO_whereINTRINSIC:
8224         case FFEINFO_whereCONSTANT:
8225         case FFEINFO_whereCONSTANT_SUBOBJECT:
8226         default:
8227           assert ("BLOCKDATA where unheard of" == NULL);
8228           /* Fall through. */
8229         case FFEINFO_whereANY:
8230           t = error_mark_node;
8231           break;
8232         }
8233       break;
8234
8235     case FFEINFO_kindCOMMON:
8236       switch (ffeinfo_where (ffesymbol_info (s)))
8237         {
8238         case FFEINFO_whereLOCAL:
8239           assert (!ffecom_transform_only_dummies_);
8240           ffecom_transform_common_ (s);
8241           break;
8242
8243         case FFEINFO_whereNONE:
8244         case FFEINFO_whereCOMMON:
8245         case FFEINFO_whereDUMMY:
8246         case FFEINFO_whereGLOBAL:
8247         case FFEINFO_whereRESULT:
8248         case FFEINFO_whereFLEETING:
8249         case FFEINFO_whereFLEETING_CADDR:
8250         case FFEINFO_whereFLEETING_IADDR:
8251         case FFEINFO_whereIMMEDIATE:
8252         case FFEINFO_whereINTRINSIC:
8253         case FFEINFO_whereCONSTANT:
8254         case FFEINFO_whereCONSTANT_SUBOBJECT:
8255         default:
8256           assert ("COMMON where unheard of" == NULL);
8257           /* Fall through. */
8258         case FFEINFO_whereANY:
8259           t = error_mark_node;
8260           break;
8261         }
8262       break;
8263
8264     case FFEINFO_kindCONSTRUCT:
8265       switch (ffeinfo_where (ffesymbol_info (s)))
8266         {
8267         case FFEINFO_whereLOCAL:
8268           assert (!ffecom_transform_only_dummies_);
8269           break;
8270
8271         case FFEINFO_whereNONE:
8272         case FFEINFO_whereCOMMON:
8273         case FFEINFO_whereDUMMY:
8274         case FFEINFO_whereGLOBAL:
8275         case FFEINFO_whereRESULT:
8276         case FFEINFO_whereFLEETING:
8277         case FFEINFO_whereFLEETING_CADDR:
8278         case FFEINFO_whereFLEETING_IADDR:
8279         case FFEINFO_whereIMMEDIATE:
8280         case FFEINFO_whereINTRINSIC:
8281         case FFEINFO_whereCONSTANT:
8282         case FFEINFO_whereCONSTANT_SUBOBJECT:
8283         default:
8284           assert ("CONSTRUCT where unheard of" == NULL);
8285           /* Fall through. */
8286         case FFEINFO_whereANY:
8287           t = error_mark_node;
8288           break;
8289         }
8290       break;
8291
8292     case FFEINFO_kindNAMELIST:
8293       switch (ffeinfo_where (ffesymbol_info (s)))
8294         {
8295         case FFEINFO_whereLOCAL:
8296           assert (!ffecom_transform_only_dummies_);
8297           t = ffecom_transform_namelist_ (s);
8298           break;
8299
8300         case FFEINFO_whereNONE:
8301         case FFEINFO_whereCOMMON:
8302         case FFEINFO_whereDUMMY:
8303         case FFEINFO_whereGLOBAL:
8304         case FFEINFO_whereRESULT:
8305         case FFEINFO_whereFLEETING:
8306         case FFEINFO_whereFLEETING_CADDR:
8307         case FFEINFO_whereFLEETING_IADDR:
8308         case FFEINFO_whereIMMEDIATE:
8309         case FFEINFO_whereINTRINSIC:
8310         case FFEINFO_whereCONSTANT:
8311         case FFEINFO_whereCONSTANT_SUBOBJECT:
8312         default:
8313           assert ("NAMELIST where unheard of" == NULL);
8314           /* Fall through. */
8315         case FFEINFO_whereANY:
8316           t = error_mark_node;
8317           break;
8318         }
8319       break;
8320
8321     default:
8322       assert ("kind unheard of" == NULL);
8323       /* Fall through. */
8324     case FFEINFO_kindANY:
8325       t = error_mark_node;
8326       break;
8327     }
8328
8329   ffesymbol_hook (s).decl_tree = t;
8330   ffesymbol_hook (s).length_tree = tlen;
8331   ffesymbol_hook (s).addr = addr;
8332
8333   lineno = old_lineno;
8334   input_filename = old_input_filename;
8335
8336   return s;
8337 }
8338
8339 /* Transform into ASSIGNable symbol.
8340
8341    Symbol has already been transformed, but for whatever reason, the
8342    resulting decl_tree has been deemed not usable for an ASSIGN target.
8343    (E.g. it isn't wide enough to hold a pointer.)  So, here we invent
8344    another local symbol of type void * and stuff that in the assign_tree
8345    argument.  The F77/F90 standards allow this implementation.  */
8346
8347 static ffesymbol
8348 ffecom_sym_transform_assign_ (ffesymbol s)
8349 {
8350   tree t;                       /* Transformed thingy. */
8351   int old_lineno = lineno;
8352   const char *old_input_filename = input_filename;
8353
8354   if (ffesymbol_sfdummyparent (s) == NULL)
8355     {
8356       input_filename = ffesymbol_where_filename (s);
8357       lineno = ffesymbol_where_filelinenum (s);
8358     }
8359   else
8360     {
8361       ffesymbol sf = ffesymbol_sfdummyparent (s);
8362
8363       input_filename = ffesymbol_where_filename (sf);
8364       lineno = ffesymbol_where_filelinenum (sf);
8365     }
8366
8367   assert (!ffecom_transform_only_dummies_);
8368
8369   t = build_decl (VAR_DECL,
8370                   ffecom_get_invented_identifier ("__g77_ASSIGN_%s",
8371                                                    ffesymbol_text (s)),
8372                   TREE_TYPE (null_pointer_node));
8373
8374   switch (ffesymbol_where (s))
8375     {
8376     case FFEINFO_whereLOCAL:
8377       /* Unlike for regular vars, SAVE status is easy to determine for
8378          ASSIGNed vars, since there's no initialization, there's no
8379          effective storage association (so "SAVE J" does not apply to
8380          K even given "EQUIVALENCE (J,K)"), there's no size issue
8381          to worry about, etc.  */
8382       if ((ffesymbol_is_save (s) || ffe_is_saveall ())
8383           && (ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8384           && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA))
8385         TREE_STATIC (t) = 1;    /* SAVEd in proc, make static. */
8386       else
8387         TREE_STATIC (t) = 0;    /* No need to make static. */
8388       break;
8389
8390     case FFEINFO_whereCOMMON:
8391       TREE_STATIC (t) = 1;      /* Assume COMMONs always SAVEd. */
8392       break;
8393
8394     case FFEINFO_whereDUMMY:
8395       /* Note that twinning a DUMMY means the caller won't see
8396          the ASSIGNed value.  But both F77 and F90 allow implementations
8397          to do this, i.e. disallow Fortran code that would try and
8398          take advantage of actually putting a label into a variable
8399          via a dummy argument (or any other storage association, for
8400          that matter).  */
8401       TREE_STATIC (t) = 0;
8402       break;
8403
8404     default:
8405       TREE_STATIC (t) = 0;
8406       break;
8407     }
8408
8409   t = start_decl (t, FALSE);
8410   finish_decl (t, NULL_TREE, FALSE);
8411
8412   ffesymbol_hook (s).assign_tree = t;
8413
8414   lineno = old_lineno;
8415   input_filename = old_input_filename;
8416
8417   return s;
8418 }
8419
8420 /* Implement COMMON area in back end.
8421
8422    Because COMMON-based variables can be referenced in the dimension
8423    expressions of dummy (adjustable) arrays, and because dummies
8424    (in the gcc back end) need to be put in the outer binding level
8425    of a function (which has two binding levels, the outer holding
8426    the dummies and the inner holding the other vars), special care
8427    must be taken to handle COMMON areas.
8428
8429    The current strategy is basically to always tell the back end about
8430    the COMMON area as a top-level external reference to just a block
8431    of storage of the master type of that area (e.g. integer, real,
8432    character, whatever -- not a structure).  As a distinct action,
8433    if initial values are provided, tell the back end about the area
8434    as a top-level non-external (initialized) area and remember not to
8435    allow further initialization or expansion of the area.  Meanwhile,
8436    if no initialization happens at all, tell the back end about
8437    the largest size we've seen declared so the space does get reserved.
8438    (This function doesn't handle all that stuff, but it does some
8439    of the important things.)
8440
8441    Meanwhile, for COMMON variables themselves, just keep creating
8442    references like *((float *) (&common_area + offset)) each time
8443    we reference the variable.  In other words, don't make a VAR_DECL
8444    or any kind of component reference (like we used to do before 0.4),
8445    though we might do that as well just for debugging purposes (and
8446    stuff the rtl with the appropriate offset expression).  */
8447
8448 static void
8449 ffecom_transform_common_ (ffesymbol s)
8450 {
8451   ffestorag st = ffesymbol_storage (s);
8452   ffeglobal g = ffesymbol_global (s);
8453   tree cbt;
8454   tree cbtype;
8455   tree init;
8456   tree high;
8457   bool is_init = ffestorag_is_init (st);
8458
8459   assert (st != NULL);
8460
8461   if ((g == NULL)
8462       || (ffeglobal_type (g) != FFEGLOBAL_typeCOMMON))
8463     return;
8464
8465   /* First update the size of the area in global terms.  */
8466
8467   ffeglobal_size_common (s, ffestorag_size (st));
8468
8469   if (!ffeglobal_common_init (g))
8470     is_init = FALSE;    /* No explicit init, don't let erroneous joins init. */
8471
8472   cbt = ffeglobal_hook (g);
8473
8474   /* If we already have declared this common block for a previous program
8475      unit, and either we already initialized it or we don't have new
8476      initialization for it, just return what we have without changing it.  */
8477
8478   if ((cbt != NULL_TREE)
8479       && (!is_init
8480           || !DECL_EXTERNAL (cbt)))
8481     {
8482       if (st->hook == NULL) ffestorag_set_hook (st, cbt);
8483       return;
8484     }
8485
8486   /* Process inits.  */
8487
8488   if (is_init)
8489     {
8490       if (ffestorag_init (st) != NULL)
8491         {
8492           ffebld sexp;
8493
8494           /* Set the padding for the expression, so ffecom_expr
8495              knows to insert that many zeros.  */
8496           switch (ffebld_op (sexp = ffestorag_init (st)))
8497             {
8498             case FFEBLD_opCONTER:
8499               ffebld_conter_set_pad (sexp, ffestorag_modulo (st));
8500               break;
8501
8502             case FFEBLD_opARRTER:
8503               ffebld_arrter_set_pad (sexp, ffestorag_modulo (st));
8504               break;
8505
8506             case FFEBLD_opACCTER:
8507               ffebld_accter_set_pad (sexp, ffestorag_modulo (st));
8508               break;
8509
8510             default:
8511               assert ("bad op for cmn init (pad)" == NULL);
8512               break;
8513             }
8514
8515           init = ffecom_expr (sexp);
8516           if (init == error_mark_node)
8517             {                   /* Hopefully the back end complained! */
8518               init = NULL_TREE;
8519               if (cbt != NULL_TREE)
8520                 return;
8521             }
8522         }
8523       else
8524         init = error_mark_node;
8525     }
8526   else
8527     init = NULL_TREE;
8528
8529   /* cbtype must be permanently allocated!  */
8530
8531   /* Allocate the MAX of the areas so far, seen filewide.  */
8532   high = build_int_2 ((ffeglobal_common_size (g)
8533                        + ffeglobal_common_pad (g)) - 1, 0);
8534   TREE_TYPE (high) = ffecom_integer_type_node;
8535
8536   if (init)
8537     cbtype = build_array_type (char_type_node,
8538                                build_range_type (integer_type_node,
8539                                                  integer_zero_node,
8540                                                  high));
8541   else
8542     cbtype = build_array_type (char_type_node, NULL_TREE);
8543
8544   if (cbt == NULL_TREE)
8545     {
8546       cbt
8547         = build_decl (VAR_DECL,
8548                       ffecom_get_external_identifier_ (s),
8549                       cbtype);
8550       TREE_STATIC (cbt) = 1;
8551       TREE_PUBLIC (cbt) = 1;
8552     }
8553   else
8554     {
8555       assert (is_init);
8556       TREE_TYPE (cbt) = cbtype;
8557     }
8558   DECL_EXTERNAL (cbt) = init ? 0 : 1;
8559   DECL_INITIAL (cbt) = init ? error_mark_node : NULL_TREE;
8560
8561   cbt = start_decl (cbt, TRUE);
8562   if (ffeglobal_hook (g) != NULL)
8563     assert (cbt == ffeglobal_hook (g));
8564
8565   assert (!init || !DECL_EXTERNAL (cbt));
8566
8567   /* Make sure that any type can live in COMMON and be referenced
8568      without getting a bus error.  We could pick the most restrictive
8569      alignment of all entities actually placed in the COMMON, but
8570      this seems easy enough.  */
8571
8572   DECL_ALIGN (cbt) = BIGGEST_ALIGNMENT;
8573   DECL_USER_ALIGN (cbt) = 0;
8574
8575   if (is_init && (ffestorag_init (st) == NULL))
8576     init = ffecom_init_zero_ (cbt);
8577
8578   finish_decl (cbt, init, TRUE);
8579
8580   if (is_init)
8581     ffestorag_set_init (st, ffebld_new_any ());
8582
8583   if (init)
8584     {
8585       assert (DECL_SIZE_UNIT (cbt) != NULL_TREE);
8586       assert (TREE_CODE (DECL_SIZE_UNIT (cbt)) == INTEGER_CST);
8587       assert (0 == compare_tree_int (DECL_SIZE_UNIT (cbt),
8588                                      (ffeglobal_common_size (g)
8589                                       + ffeglobal_common_pad (g))));
8590     }
8591
8592   ffeglobal_set_hook (g, cbt);
8593
8594   ffestorag_set_hook (st, cbt);
8595
8596   ffecom_save_tree_forever (cbt);
8597 }
8598
8599 /* Make master area for local EQUIVALENCE.  */
8600
8601 static void
8602 ffecom_transform_equiv_ (ffestorag eqst)
8603 {
8604   tree eqt;
8605   tree eqtype;
8606   tree init;
8607   tree high;
8608   bool is_init = ffestorag_is_init (eqst);
8609
8610   assert (eqst != NULL);
8611
8612   eqt = ffestorag_hook (eqst);
8613
8614   if (eqt != NULL_TREE)
8615     return;
8616
8617   /* Process inits.  */
8618
8619   if (is_init)
8620     {
8621       if (ffestorag_init (eqst) != NULL)
8622         {
8623           ffebld sexp;
8624
8625           /* Set the padding for the expression, so ffecom_expr
8626              knows to insert that many zeros.  */
8627           switch (ffebld_op (sexp = ffestorag_init (eqst)))
8628             {
8629             case FFEBLD_opCONTER:
8630               ffebld_conter_set_pad (sexp, ffestorag_modulo (eqst));
8631               break;
8632
8633             case FFEBLD_opARRTER:
8634               ffebld_arrter_set_pad (sexp, ffestorag_modulo (eqst));
8635               break;
8636
8637             case FFEBLD_opACCTER:
8638               ffebld_accter_set_pad (sexp, ffestorag_modulo (eqst));
8639               break;
8640
8641             default:
8642               assert ("bad op for eqv init (pad)" == NULL);
8643               break;
8644             }
8645
8646           init = ffecom_expr (sexp);
8647           if (init == error_mark_node)
8648             init = NULL_TREE;   /* Hopefully the back end complained! */
8649         }
8650       else
8651         init = error_mark_node;
8652     }
8653   else if (ffe_is_init_local_zero ())
8654     init = error_mark_node;
8655   else
8656     init = NULL_TREE;
8657
8658   ffecom_member_namelisted_ = FALSE;
8659   ffestorag_drive (ffestorag_list_equivs (eqst),
8660                    &ffecom_member_phase1_,
8661                    eqst);
8662
8663   high = build_int_2 ((ffestorag_size (eqst)
8664                        + ffestorag_modulo (eqst)) - 1, 0);
8665   TREE_TYPE (high) = ffecom_integer_type_node;
8666
8667   eqtype = build_array_type (char_type_node,
8668                              build_range_type (ffecom_integer_type_node,
8669                                                ffecom_integer_zero_node,
8670                                                high));
8671
8672   eqt = build_decl (VAR_DECL,
8673                     ffecom_get_invented_identifier ("__g77_equiv_%s",
8674                                                     ffesymbol_text
8675                                                     (ffestorag_symbol (eqst))),
8676                     eqtype);
8677   DECL_EXTERNAL (eqt) = 0;
8678   if (is_init
8679       || ffecom_member_namelisted_
8680 #ifdef FFECOM_sizeMAXSTACKITEM
8681       || (ffestorag_size (eqst) > FFECOM_sizeMAXSTACKITEM)
8682 #endif
8683       || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8684           && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
8685           && (ffestorag_is_save (eqst) || ffe_is_saveall ())))
8686     TREE_STATIC (eqt) = 1;
8687   else
8688     TREE_STATIC (eqt) = 0;
8689   TREE_PUBLIC (eqt) = 0;
8690   TREE_ADDRESSABLE (eqt) = 1;  /* Ensure non-register allocation */
8691   DECL_CONTEXT (eqt) = current_function_decl;
8692   if (init)
8693     DECL_INITIAL (eqt) = error_mark_node;
8694   else
8695     DECL_INITIAL (eqt) = NULL_TREE;
8696
8697   eqt = start_decl (eqt, FALSE);
8698
8699   /* Make sure that any type can live in EQUIVALENCE and be referenced
8700      without getting a bus error.  We could pick the most restrictive
8701      alignment of all entities actually placed in the EQUIVALENCE, but
8702      this seems easy enough.  */
8703
8704   DECL_ALIGN (eqt) = BIGGEST_ALIGNMENT;
8705   DECL_USER_ALIGN (eqt) = 0;
8706
8707   if ((!is_init && ffe_is_init_local_zero ())
8708       || (is_init && (ffestorag_init (eqst) == NULL)))
8709     init = ffecom_init_zero_ (eqt);
8710
8711   finish_decl (eqt, init, FALSE);
8712
8713   if (is_init)
8714     ffestorag_set_init (eqst, ffebld_new_any ());
8715
8716   {
8717     assert (TREE_CODE (DECL_SIZE_UNIT (eqt)) == INTEGER_CST);
8718     assert (0 == compare_tree_int (DECL_SIZE_UNIT (eqt),
8719                                    (ffestorag_size (eqst)
8720                                     + ffestorag_modulo (eqst))));
8721   }
8722
8723   ffestorag_set_hook (eqst, eqt);
8724
8725   ffestorag_drive (ffestorag_list_equivs (eqst),
8726                    &ffecom_member_phase2_,
8727                    eqst);
8728 }
8729
8730 /* Implement NAMELIST in back end.  See f2c/format.c for more info.  */
8731
8732 static tree
8733 ffecom_transform_namelist_ (ffesymbol s)
8734 {
8735   tree nmlt;
8736   tree nmltype = ffecom_type_namelist_ ();
8737   tree nmlinits;
8738   tree nameinit;
8739   tree varsinit;
8740   tree nvarsinit;
8741   tree field;
8742   tree high;
8743   int i;
8744   static int mynumber = 0;
8745
8746   nmlt = build_decl (VAR_DECL,
8747                      ffecom_get_invented_identifier ("__g77_namelist_%d",
8748                                                      mynumber++),
8749                      nmltype);
8750   TREE_STATIC (nmlt) = 1;
8751   DECL_INITIAL (nmlt) = error_mark_node;
8752
8753   nmlt = start_decl (nmlt, FALSE);
8754
8755   /* Process inits.  */
8756
8757   i = strlen (ffesymbol_text (s));
8758
8759   high = build_int_2 (i, 0);
8760   TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
8761
8762   nameinit = ffecom_build_f2c_string_ (i + 1,
8763                                        ffesymbol_text (s));
8764   TREE_TYPE (nameinit)
8765     = build_type_variant
8766     (build_array_type
8767      (char_type_node,
8768       build_range_type (ffecom_f2c_ftnlen_type_node,
8769                         ffecom_f2c_ftnlen_one_node,
8770                         high)),
8771      1, 0);
8772   TREE_CONSTANT (nameinit) = 1;
8773   TREE_STATIC (nameinit) = 1;
8774   nameinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (nameinit)),
8775                        nameinit);
8776
8777   varsinit = ffecom_vardesc_array_ (s);
8778   varsinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (varsinit)),
8779                        varsinit);
8780   TREE_CONSTANT (varsinit) = 1;
8781   TREE_STATIC (varsinit) = 1;
8782
8783   {
8784     ffebld b;
8785
8786     for (i = 0, b = ffesymbol_namelist (s); b != NULL; b = ffebld_trail (b))
8787       ++i;
8788   }
8789   nvarsinit = build_int_2 (i, 0);
8790   TREE_TYPE (nvarsinit) = integer_type_node;
8791   TREE_CONSTANT (nvarsinit) = 1;
8792   TREE_STATIC (nvarsinit) = 1;
8793
8794   nmlinits = build_tree_list ((field = TYPE_FIELDS (nmltype)), nameinit);
8795   TREE_CHAIN (nmlinits) = build_tree_list ((field = TREE_CHAIN (field)),
8796                                            varsinit);
8797   TREE_CHAIN (TREE_CHAIN (nmlinits))
8798     = build_tree_list ((field = TREE_CHAIN (field)), nvarsinit);
8799
8800   nmlinits = build (CONSTRUCTOR, nmltype, NULL_TREE, nmlinits);
8801   TREE_CONSTANT (nmlinits) = 1;
8802   TREE_STATIC (nmlinits) = 1;
8803
8804   finish_decl (nmlt, nmlinits, FALSE);
8805
8806   nmlt = ffecom_1 (ADDR_EXPR, build_pointer_type (nmltype), nmlt);
8807
8808   return nmlt;
8809 }
8810
8811 /* A subroutine of ffecom_tree_canonize_ref_.  The incoming tree is
8812    analyzed on the assumption it is calculating a pointer to be
8813    indirected through.  It must return the proper decl and offset,
8814    taking into account different units of measurements for offsets.  */
8815
8816 static void
8817 ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
8818                            tree t)
8819 {
8820   switch (TREE_CODE (t))
8821     {
8822     case NOP_EXPR:
8823     case CONVERT_EXPR:
8824     case NON_LVALUE_EXPR:
8825       ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
8826       break;
8827
8828     case PLUS_EXPR:
8829       ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
8830       if ((*decl == NULL_TREE)
8831           || (*decl == error_mark_node))
8832         break;
8833
8834       if (TREE_CODE (TREE_OPERAND (t, 1)) == INTEGER_CST)
8835         {
8836           /* An offset into COMMON.  */
8837           *offset = fold (build (PLUS_EXPR, TREE_TYPE (*offset),
8838                                  *offset, TREE_OPERAND (t, 1)));
8839           /* Convert offset (presumably in bytes) into canonical units
8840              (presumably bits).  */
8841           *offset = size_binop (MULT_EXPR,
8842                                 convert (bitsizetype, *offset),
8843                                 TYPE_SIZE (TREE_TYPE (TREE_TYPE (t))));
8844           break;
8845         }
8846       /* Not a COMMON reference, so an unrecognized pattern.  */
8847       *decl = error_mark_node;
8848       break;
8849
8850     case PARM_DECL:
8851       *decl = t;
8852       *offset = bitsize_zero_node;
8853       break;
8854
8855     case ADDR_EXPR:
8856       if (TREE_CODE (TREE_OPERAND (t, 0)) == VAR_DECL)
8857         {
8858           /* A reference to COMMON.  */
8859           *decl = TREE_OPERAND (t, 0);
8860           *offset = bitsize_zero_node;
8861           break;
8862         }
8863       /* Fall through.  */
8864     default:
8865       /* Not a COMMON reference, so an unrecognized pattern.  */
8866       *decl = error_mark_node;
8867       break;
8868     }
8869 }
8870
8871 /* Given a tree that is possibly intended for use as an lvalue, return
8872    information representing a canonical view of that tree as a decl, an
8873    offset into that decl, and a size for the lvalue.
8874
8875    If there's no applicable decl, NULL_TREE is returned for the decl,
8876    and the other fields are left undefined.
8877
8878    If the tree doesn't fit the recognizable forms, an ERROR_MARK node
8879    is returned for the decl, and the other fields are left undefined.
8880
8881    Otherwise, the decl returned currently is either a VAR_DECL or a
8882    PARM_DECL.
8883
8884    The offset returned is always valid, but of course not necessarily
8885    a constant, and not necessarily converted into the appropriate
8886    type, leaving that up to the caller (so as to avoid that overhead
8887    if the decls being looked at are different anyway).
8888
8889    If the size cannot be determined (e.g. an adjustable array),
8890    an ERROR_MARK node is returned for the size.  Otherwise, the
8891    size returned is valid, not necessarily a constant, and not
8892    necessarily converted into the appropriate type as with the
8893    offset.
8894
8895    Note that the offset and size expressions are expressed in the
8896    base storage units (usually bits) rather than in the units of
8897    the type of the decl, because two decls with different types
8898    might overlap but with apparently non-overlapping array offsets,
8899    whereas converting the array offsets to consistant offsets will
8900    reveal the overlap.  */
8901
8902 static void
8903 ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
8904                            tree *size, tree t)
8905 {
8906   /* The default path is to report a nonexistant decl.  */
8907   *decl = NULL_TREE;
8908
8909   if (t == NULL_TREE)
8910     return;
8911
8912   switch (TREE_CODE (t))
8913     {
8914     case ERROR_MARK:
8915     case IDENTIFIER_NODE:
8916     case INTEGER_CST:
8917     case REAL_CST:
8918     case COMPLEX_CST:
8919     case STRING_CST:
8920     case CONST_DECL:
8921     case PLUS_EXPR:
8922     case MINUS_EXPR:
8923     case MULT_EXPR:
8924     case TRUNC_DIV_EXPR:
8925     case CEIL_DIV_EXPR:
8926     case FLOOR_DIV_EXPR:
8927     case ROUND_DIV_EXPR:
8928     case TRUNC_MOD_EXPR:
8929     case CEIL_MOD_EXPR:
8930     case FLOOR_MOD_EXPR:
8931     case ROUND_MOD_EXPR:
8932     case RDIV_EXPR:
8933     case EXACT_DIV_EXPR:
8934     case FIX_TRUNC_EXPR:
8935     case FIX_CEIL_EXPR:
8936     case FIX_FLOOR_EXPR:
8937     case FIX_ROUND_EXPR:
8938     case FLOAT_EXPR:
8939     case NEGATE_EXPR:
8940     case MIN_EXPR:
8941     case MAX_EXPR:
8942     case ABS_EXPR:
8943     case FFS_EXPR:
8944     case LSHIFT_EXPR:
8945     case RSHIFT_EXPR:
8946     case LROTATE_EXPR:
8947     case RROTATE_EXPR:
8948     case BIT_IOR_EXPR:
8949     case BIT_XOR_EXPR:
8950     case BIT_AND_EXPR:
8951     case BIT_ANDTC_EXPR:
8952     case BIT_NOT_EXPR:
8953     case TRUTH_ANDIF_EXPR:
8954     case TRUTH_ORIF_EXPR:
8955     case TRUTH_AND_EXPR:
8956     case TRUTH_OR_EXPR:
8957     case TRUTH_XOR_EXPR:
8958     case TRUTH_NOT_EXPR:
8959     case LT_EXPR:
8960     case LE_EXPR:
8961     case GT_EXPR:
8962     case GE_EXPR:
8963     case EQ_EXPR:
8964     case NE_EXPR:
8965     case COMPLEX_EXPR:
8966     case CONJ_EXPR:
8967     case REALPART_EXPR:
8968     case IMAGPART_EXPR:
8969     case LABEL_EXPR:
8970     case COMPONENT_REF:
8971     case COMPOUND_EXPR:
8972     case ADDR_EXPR:
8973       return;
8974
8975     case VAR_DECL:
8976     case PARM_DECL:
8977       *decl = t;
8978       *offset = bitsize_zero_node;
8979       *size = TYPE_SIZE (TREE_TYPE (t));
8980       return;
8981
8982     case ARRAY_REF:
8983       {
8984         tree array = TREE_OPERAND (t, 0);
8985         tree element = TREE_OPERAND (t, 1);
8986         tree init_offset;
8987
8988         if ((array == NULL_TREE)
8989             || (element == NULL_TREE))
8990           {
8991             *decl = error_mark_node;
8992             return;
8993           }
8994
8995         ffecom_tree_canonize_ref_ (decl, &init_offset, size,
8996                                    array);
8997         if ((*decl == NULL_TREE)
8998             || (*decl == error_mark_node))
8999           return;
9000
9001         /* Calculate ((element - base) * NBBY) + init_offset.  */
9002         *offset = fold (build (MINUS_EXPR, TREE_TYPE (element),
9003                                element,
9004                                TYPE_MIN_VALUE (TYPE_DOMAIN
9005                                                (TREE_TYPE (array)))));
9006
9007         *offset = size_binop (MULT_EXPR,
9008                               convert (bitsizetype, *offset),
9009                               TYPE_SIZE (TREE_TYPE (TREE_TYPE (array))));
9010
9011         *offset = size_binop (PLUS_EXPR, init_offset, *offset);
9012
9013         *size = TYPE_SIZE (TREE_TYPE (t));
9014         return;
9015       }
9016
9017     case INDIRECT_REF:
9018
9019       /* Most of this code is to handle references to COMMON.  And so
9020          far that is useful only for calling library functions, since
9021          external (user) functions might reference common areas.  But
9022          even calling an external function, it's worthwhile to decode
9023          COMMON references because if not storing into COMMON, we don't
9024          want COMMON-based arguments to gratuitously force use of a
9025          temporary.  */
9026
9027       *size = TYPE_SIZE (TREE_TYPE (t));
9028
9029       ffecom_tree_canonize_ptr_ (decl, offset,
9030                                  TREE_OPERAND (t, 0));
9031
9032       return;
9033
9034     case CONVERT_EXPR:
9035     case NOP_EXPR:
9036     case MODIFY_EXPR:
9037     case NON_LVALUE_EXPR:
9038     case RESULT_DECL:
9039     case FIELD_DECL:
9040     case COND_EXPR:             /* More cases than we can handle. */
9041     case SAVE_EXPR:
9042     case REFERENCE_EXPR:
9043     case PREDECREMENT_EXPR:
9044     case PREINCREMENT_EXPR:
9045     case POSTDECREMENT_EXPR:
9046     case POSTINCREMENT_EXPR:
9047     case CALL_EXPR:
9048     default:
9049       *decl = error_mark_node;
9050       return;
9051     }
9052 }
9053
9054 /* Do divide operation appropriate to type of operands.  */
9055
9056 static tree
9057 ffecom_tree_divide_ (tree tree_type, tree left, tree right,
9058                      tree dest_tree, ffebld dest, bool *dest_used,
9059                      tree hook)
9060 {
9061   if ((left == error_mark_node)
9062       || (right == error_mark_node))
9063     return error_mark_node;
9064
9065   switch (TREE_CODE (tree_type))
9066     {
9067     case INTEGER_TYPE:
9068       return ffecom_2 (TRUNC_DIV_EXPR, tree_type,
9069                        left,
9070                        right);
9071
9072     case COMPLEX_TYPE:
9073       if (! optimize_size)
9074         return ffecom_2 (RDIV_EXPR, tree_type,
9075                          left,
9076                          right);
9077       {
9078         ffecomGfrt ix;
9079
9080         if (TREE_TYPE (tree_type)
9081             == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9082           ix = FFECOM_gfrtDIV_CC;       /* Overlapping result okay. */
9083         else
9084           ix = FFECOM_gfrtDIV_ZZ;       /* Overlapping result okay. */
9085
9086         left = ffecom_1 (ADDR_EXPR,
9087                          build_pointer_type (TREE_TYPE (left)),
9088                          left);
9089         left = build_tree_list (NULL_TREE, left);
9090         right = ffecom_1 (ADDR_EXPR,
9091                           build_pointer_type (TREE_TYPE (right)),
9092                           right);
9093         right = build_tree_list (NULL_TREE, right);
9094         TREE_CHAIN (left) = right;
9095
9096         return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9097                              ffecom_gfrt_kindtype (ix),
9098                              ffe_is_f2c_library (),
9099                              tree_type,
9100                              left,
9101                              dest_tree, dest, dest_used,
9102                              NULL_TREE, TRUE, hook);
9103       }
9104       break;
9105
9106     case RECORD_TYPE:
9107       {
9108         ffecomGfrt ix;
9109
9110         if (TREE_TYPE (TYPE_FIELDS (tree_type))
9111             == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9112           ix = FFECOM_gfrtDIV_CC;       /* Overlapping result okay. */
9113         else
9114           ix = FFECOM_gfrtDIV_ZZ;       /* Overlapping result okay. */
9115
9116         left = ffecom_1 (ADDR_EXPR,
9117                          build_pointer_type (TREE_TYPE (left)),
9118                          left);
9119         left = build_tree_list (NULL_TREE, left);
9120         right = ffecom_1 (ADDR_EXPR,
9121                           build_pointer_type (TREE_TYPE (right)),
9122                           right);
9123         right = build_tree_list (NULL_TREE, right);
9124         TREE_CHAIN (left) = right;
9125
9126         return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9127                              ffecom_gfrt_kindtype (ix),
9128                              ffe_is_f2c_library (),
9129                              tree_type,
9130                              left,
9131                              dest_tree, dest, dest_used,
9132                              NULL_TREE, TRUE, hook);
9133       }
9134       break;
9135
9136     default:
9137       return ffecom_2 (RDIV_EXPR, tree_type,
9138                        left,
9139                        right);
9140     }
9141 }
9142
9143 /* Build type info for non-dummy variable.  */
9144
9145 static tree
9146 ffecom_type_localvar_ (ffesymbol s, ffeinfoBasictype bt,
9147                        ffeinfoKindtype kt)
9148 {
9149   tree type;
9150   ffebld dl;
9151   ffebld dim;
9152   tree lowt;
9153   tree hight;
9154
9155   type = ffecom_tree_type[bt][kt];
9156   if (bt == FFEINFO_basictypeCHARACTER)
9157     {
9158       hight = build_int_2 (ffesymbol_size (s), 0);
9159       TREE_TYPE (hight) = ffecom_f2c_ftnlen_type_node;
9160
9161       type
9162         = build_array_type
9163           (type,
9164            build_range_type (ffecom_f2c_ftnlen_type_node,
9165                              ffecom_f2c_ftnlen_one_node,
9166                              hight));
9167       type = ffecom_check_size_overflow_ (s, type, FALSE);
9168     }
9169
9170   for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
9171     {
9172       if (type == error_mark_node)
9173         break;
9174
9175       dim = ffebld_head (dl);
9176       assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
9177
9178       if (ffebld_left (dim) == NULL)
9179         lowt = integer_one_node;
9180       else
9181         lowt = ffecom_expr (ffebld_left (dim));
9182
9183       if (TREE_CODE (lowt) != INTEGER_CST)
9184         lowt = variable_size (lowt);
9185
9186       assert (ffebld_right (dim) != NULL);
9187       hight = ffecom_expr (ffebld_right (dim));
9188
9189       if (TREE_CODE (hight) != INTEGER_CST)
9190         hight = variable_size (hight);
9191
9192       type = build_array_type (type,
9193                                build_range_type (ffecom_integer_type_node,
9194                                                  lowt, hight));
9195       type = ffecom_check_size_overflow_ (s, type, FALSE);
9196     }
9197
9198   return type;
9199 }
9200
9201 /* Build Namelist type.  */
9202
9203 static tree
9204 ffecom_type_namelist_ ()
9205 {
9206   static tree type = NULL_TREE;
9207
9208   if (type == NULL_TREE)
9209     {
9210       static tree namefield, varsfield, nvarsfield;
9211       tree vardesctype;
9212
9213       vardesctype = ffecom_type_vardesc_ ();
9214
9215       type = make_node (RECORD_TYPE);
9216
9217       vardesctype = build_pointer_type (build_pointer_type (vardesctype));
9218
9219       namefield = ffecom_decl_field (type, NULL_TREE, "name",
9220                                      string_type_node);
9221       varsfield = ffecom_decl_field (type, namefield, "vars", vardesctype);
9222       nvarsfield = ffecom_decl_field (type, varsfield, "nvars",
9223                                       integer_type_node);
9224
9225       TYPE_FIELDS (type) = namefield;
9226       layout_type (type);
9227
9228       ggc_add_tree_root (&type, 1);
9229     }
9230
9231   return type;
9232 }
9233
9234 /* Build Vardesc type.  */
9235
9236 static tree
9237 ffecom_type_vardesc_ ()
9238 {
9239   static tree type = NULL_TREE;
9240   static tree namefield, addrfield, dimsfield, typefield;
9241
9242   if (type == NULL_TREE)
9243     {
9244       type = make_node (RECORD_TYPE);
9245
9246       namefield = ffecom_decl_field (type, NULL_TREE, "name",
9247                                      string_type_node);
9248       addrfield = ffecom_decl_field (type, namefield, "addr",
9249                                      string_type_node);
9250       dimsfield = ffecom_decl_field (type, addrfield, "dims",
9251                                      ffecom_f2c_ptr_to_ftnlen_type_node);
9252       typefield = ffecom_decl_field (type, dimsfield, "type",
9253                                      integer_type_node);
9254
9255       TYPE_FIELDS (type) = namefield;
9256       layout_type (type);
9257
9258       ggc_add_tree_root (&type, 1);
9259     }
9260
9261   return type;
9262 }
9263
9264 static tree
9265 ffecom_vardesc_ (ffebld expr)
9266 {
9267   ffesymbol s;
9268
9269   assert (ffebld_op (expr) == FFEBLD_opSYMTER);
9270   s = ffebld_symter (expr);
9271
9272   if (ffesymbol_hook (s).vardesc_tree == NULL_TREE)
9273     {
9274       int i;
9275       tree vardesctype = ffecom_type_vardesc_ ();
9276       tree var;
9277       tree nameinit;
9278       tree dimsinit;
9279       tree addrinit;
9280       tree typeinit;
9281       tree field;
9282       tree varinits;
9283       static int mynumber = 0;
9284
9285       var = build_decl (VAR_DECL,
9286                         ffecom_get_invented_identifier ("__g77_vardesc_%d",
9287                                                         mynumber++),
9288                         vardesctype);
9289       TREE_STATIC (var) = 1;
9290       DECL_INITIAL (var) = error_mark_node;
9291
9292       var = start_decl (var, FALSE);
9293
9294       /* Process inits.  */
9295
9296       nameinit = ffecom_build_f2c_string_ ((i = strlen (ffesymbol_text (s)))
9297                                            + 1,
9298                                            ffesymbol_text (s));
9299       TREE_TYPE (nameinit)
9300         = build_type_variant
9301         (build_array_type
9302          (char_type_node,
9303           build_range_type (integer_type_node,
9304                             integer_one_node,
9305                             build_int_2 (i, 0))),
9306          1, 0);
9307       TREE_CONSTANT (nameinit) = 1;
9308       TREE_STATIC (nameinit) = 1;
9309       nameinit = ffecom_1 (ADDR_EXPR,
9310                            build_pointer_type (TREE_TYPE (nameinit)),
9311                            nameinit);
9312
9313       addrinit = ffecom_arg_ptr_to_expr (expr, &typeinit);
9314
9315       dimsinit = ffecom_vardesc_dims_ (s);
9316
9317       if (typeinit == NULL_TREE)
9318         {
9319           ffeinfoBasictype bt = ffesymbol_basictype (s);
9320           ffeinfoKindtype kt = ffesymbol_kindtype (s);
9321           int tc = ffecom_f2c_typecode (bt, kt);
9322
9323           assert (tc != -1);
9324           typeinit = build_int_2 (tc, (tc < 0) ? -1 : 0);
9325         }
9326       else
9327         typeinit = ffecom_1 (NEGATE_EXPR, TREE_TYPE (typeinit), typeinit);
9328
9329       varinits = build_tree_list ((field = TYPE_FIELDS (vardesctype)),
9330                                   nameinit);
9331       TREE_CHAIN (varinits) = build_tree_list ((field = TREE_CHAIN (field)),
9332                                                addrinit);
9333       TREE_CHAIN (TREE_CHAIN (varinits))
9334         = build_tree_list ((field = TREE_CHAIN (field)), dimsinit);
9335       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (varinits)))
9336         = build_tree_list ((field = TREE_CHAIN (field)), typeinit);
9337
9338       varinits = build (CONSTRUCTOR, vardesctype, NULL_TREE, varinits);
9339       TREE_CONSTANT (varinits) = 1;
9340       TREE_STATIC (varinits) = 1;
9341
9342       finish_decl (var, varinits, FALSE);
9343
9344       var = ffecom_1 (ADDR_EXPR, build_pointer_type (vardesctype), var);
9345
9346       ffesymbol_hook (s).vardesc_tree = var;
9347     }
9348
9349   return ffesymbol_hook (s).vardesc_tree;
9350 }
9351
9352 static tree
9353 ffecom_vardesc_array_ (ffesymbol s)
9354 {
9355   ffebld b;
9356   tree list;
9357   tree item = NULL_TREE;
9358   tree var;
9359   int i;
9360   static int mynumber = 0;
9361
9362   for (i = 0, list = NULL_TREE, b = ffesymbol_namelist (s);
9363        b != NULL;
9364        b = ffebld_trail (b), ++i)
9365     {
9366       tree t;
9367
9368       t = ffecom_vardesc_ (ffebld_head (b));
9369
9370       if (list == NULL_TREE)
9371         list = item = build_tree_list (NULL_TREE, t);
9372       else
9373         {
9374           TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9375           item = TREE_CHAIN (item);
9376         }
9377     }
9378
9379   item = build_array_type (build_pointer_type (ffecom_type_vardesc_ ()),
9380                            build_range_type (integer_type_node,
9381                                              integer_one_node,
9382                                              build_int_2 (i, 0)));
9383   list = build (CONSTRUCTOR, item, NULL_TREE, list);
9384   TREE_CONSTANT (list) = 1;
9385   TREE_STATIC (list) = 1;
9386
9387   var = ffecom_get_invented_identifier ("__g77_vardesc_array_%d", mynumber++);
9388   var = build_decl (VAR_DECL, var, item);
9389   TREE_STATIC (var) = 1;
9390   DECL_INITIAL (var) = error_mark_node;
9391   var = start_decl (var, FALSE);
9392   finish_decl (var, list, FALSE);
9393
9394   return var;
9395 }
9396
9397 static tree
9398 ffecom_vardesc_dims_ (ffesymbol s)
9399 {
9400   if (ffesymbol_dims (s) == NULL)
9401     return convert (ffecom_f2c_ptr_to_ftnlen_type_node,
9402                     integer_zero_node);
9403
9404   {
9405     ffebld b;
9406     ffebld e;
9407     tree list;
9408     tree backlist;
9409     tree item = NULL_TREE;
9410     tree var;
9411     tree numdim;
9412     tree numelem;
9413     tree baseoff = NULL_TREE;
9414     static int mynumber = 0;
9415
9416     numdim = build_int_2 ((int) ffesymbol_rank (s), 0);
9417     TREE_TYPE (numdim) = ffecom_f2c_ftnlen_type_node;
9418
9419     numelem = ffecom_expr (ffesymbol_arraysize (s));
9420     TREE_TYPE (numelem) = ffecom_f2c_ftnlen_type_node;
9421
9422     list = NULL_TREE;
9423     backlist = NULL_TREE;
9424     for (b = ffesymbol_dims (s), e = ffesymbol_extents (s);
9425          b != NULL;
9426          b = ffebld_trail (b), e = ffebld_trail (e))
9427       {
9428         tree t;
9429         tree low;
9430         tree back;
9431
9432         if (ffebld_trail (b) == NULL)
9433           t = NULL_TREE;
9434         else
9435           {
9436             t = convert (ffecom_f2c_ftnlen_type_node,
9437                          ffecom_expr (ffebld_head (e)));
9438
9439             if (list == NULL_TREE)
9440               list = item = build_tree_list (NULL_TREE, t);
9441             else
9442               {
9443                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9444                 item = TREE_CHAIN (item);
9445               }
9446           }
9447
9448         if (ffebld_left (ffebld_head (b)) == NULL)
9449           low = ffecom_integer_one_node;
9450         else
9451           low = ffecom_expr (ffebld_left (ffebld_head (b)));
9452         low = convert (ffecom_f2c_ftnlen_type_node, low);
9453
9454         back = build_tree_list (low, t);
9455         TREE_CHAIN (back) = backlist;
9456         backlist = back;
9457       }
9458
9459     for (item = backlist; item != NULL_TREE; item = TREE_CHAIN (item))
9460       {
9461         if (TREE_VALUE (item) == NULL_TREE)
9462           baseoff = TREE_PURPOSE (item);
9463         else
9464           baseoff = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
9465                               TREE_PURPOSE (item),
9466                               ffecom_2 (MULT_EXPR,
9467                                         ffecom_f2c_ftnlen_type_node,
9468                                         TREE_VALUE (item),
9469                                         baseoff));
9470       }
9471
9472     /* backlist now dead, along with all TREE_PURPOSEs on it.  */
9473
9474     baseoff = build_tree_list (NULL_TREE, baseoff);
9475     TREE_CHAIN (baseoff) = list;
9476
9477     numelem = build_tree_list (NULL_TREE, numelem);
9478     TREE_CHAIN (numelem) = baseoff;
9479
9480     numdim = build_tree_list (NULL_TREE, numdim);
9481     TREE_CHAIN (numdim) = numelem;
9482
9483     item = build_array_type (ffecom_f2c_ftnlen_type_node,
9484                              build_range_type (integer_type_node,
9485                                                integer_zero_node,
9486                                                build_int_2
9487                                                ((int) ffesymbol_rank (s)
9488                                                 + 2, 0)));
9489     list = build (CONSTRUCTOR, item, NULL_TREE, numdim);
9490     TREE_CONSTANT (list) = 1;
9491     TREE_STATIC (list) = 1;
9492
9493     var = ffecom_get_invented_identifier ("__g77_dims_%d", mynumber++);
9494     var = build_decl (VAR_DECL, var, item);
9495     TREE_STATIC (var) = 1;
9496     DECL_INITIAL (var) = error_mark_node;
9497     var = start_decl (var, FALSE);
9498     finish_decl (var, list, FALSE);
9499
9500     var = ffecom_1 (ADDR_EXPR, build_pointer_type (item), var);
9501
9502     return var;
9503   }
9504 }
9505
9506 /* Essentially does a "fold (build1 (code, type, node))" while checking
9507    for certain housekeeping things.
9508
9509    NOTE: for building an ADDR_EXPR around a FUNCTION_DECL, use
9510    ffecom_1_fn instead.  */
9511
9512 tree
9513 ffecom_1 (enum tree_code code, tree type, tree node)
9514 {
9515   tree item;
9516
9517   if ((node == error_mark_node)
9518       || (type == error_mark_node))
9519     return error_mark_node;
9520
9521   if (code == ADDR_EXPR)
9522     {
9523       if (!mark_addressable (node))
9524         assert ("can't mark_addressable this node!" == NULL);
9525     }
9526
9527   switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9528     {
9529       tree realtype;
9530
9531     case REALPART_EXPR:
9532       item = build (COMPONENT_REF, type, node, TYPE_FIELDS (TREE_TYPE (node)));
9533       break;
9534
9535     case IMAGPART_EXPR:
9536       item = build (COMPONENT_REF, type, node, TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (node))));
9537       break;
9538
9539
9540     case NEGATE_EXPR:
9541       if (TREE_CODE (type) != RECORD_TYPE)
9542         {
9543           item = build1 (code, type, node);
9544           break;
9545         }
9546       node = ffecom_stabilize_aggregate_ (node);
9547       realtype = TREE_TYPE (TYPE_FIELDS (type));
9548       item =
9549         ffecom_2 (COMPLEX_EXPR, type,
9550                   ffecom_1 (NEGATE_EXPR, realtype,
9551                             ffecom_1 (REALPART_EXPR, realtype,
9552                                       node)),
9553                   ffecom_1 (NEGATE_EXPR, realtype,
9554                             ffecom_1 (IMAGPART_EXPR, realtype,
9555                                       node)));
9556       break;
9557
9558     default:
9559       item = build1 (code, type, node);
9560       break;
9561     }
9562
9563   if (TREE_SIDE_EFFECTS (node))
9564     TREE_SIDE_EFFECTS (item) = 1;
9565   if (code == ADDR_EXPR && staticp (node))
9566     TREE_CONSTANT (item) = 1;
9567   else if (code == INDIRECT_REF)
9568     TREE_READONLY (item) = TYPE_READONLY (type);
9569   return fold (item);
9570 }
9571
9572 /* Like ffecom_1 (ADDR_EXPR, TREE_TYPE (node), node), except
9573    handles TREE_CODE (node) == FUNCTION_DECL.  In particular,
9574    does not set TREE_ADDRESSABLE (because calling an inline
9575    function does not mean the function needs to be separately
9576    compiled).  */
9577
9578 tree
9579 ffecom_1_fn (tree node)
9580 {
9581   tree item;
9582   tree type;
9583
9584   if (node == error_mark_node)
9585     return error_mark_node;
9586
9587   type = build_type_variant (TREE_TYPE (node),
9588                              TREE_READONLY (node),
9589                              TREE_THIS_VOLATILE (node));
9590   item = build1 (ADDR_EXPR,
9591                  build_pointer_type (type), node);
9592   if (TREE_SIDE_EFFECTS (node))
9593     TREE_SIDE_EFFECTS (item) = 1;
9594   if (staticp (node))
9595     TREE_CONSTANT (item) = 1;
9596   return fold (item);
9597 }
9598
9599 /* Essentially does a "fold (build (code, type, node1, node2))" while
9600    checking for certain housekeeping things.  */
9601
9602 tree
9603 ffecom_2 (enum tree_code code, tree type, tree node1,
9604           tree node2)
9605 {
9606   tree item;
9607
9608   if ((node1 == error_mark_node)
9609       || (node2 == error_mark_node)
9610       || (type == error_mark_node))
9611     return error_mark_node;
9612
9613   switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9614     {
9615       tree a, b, c, d, realtype;
9616
9617     case CONJ_EXPR:
9618       assert ("no CONJ_EXPR support yet" == NULL);
9619       return error_mark_node;
9620
9621     case COMPLEX_EXPR:
9622       item = build_tree_list (TYPE_FIELDS (type), node1);
9623       TREE_CHAIN (item) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), node2);
9624       item = build (CONSTRUCTOR, type, NULL_TREE, item);
9625       break;
9626
9627     case PLUS_EXPR:
9628       if (TREE_CODE (type) != RECORD_TYPE)
9629         {
9630           item = build (code, type, node1, node2);
9631           break;
9632         }
9633       node1 = ffecom_stabilize_aggregate_ (node1);
9634       node2 = ffecom_stabilize_aggregate_ (node2);
9635       realtype = TREE_TYPE (TYPE_FIELDS (type));
9636       item =
9637         ffecom_2 (COMPLEX_EXPR, type,
9638                   ffecom_2 (PLUS_EXPR, realtype,
9639                             ffecom_1 (REALPART_EXPR, realtype,
9640                                       node1),
9641                             ffecom_1 (REALPART_EXPR, realtype,
9642                                       node2)),
9643                   ffecom_2 (PLUS_EXPR, realtype,
9644                             ffecom_1 (IMAGPART_EXPR, realtype,
9645                                       node1),
9646                             ffecom_1 (IMAGPART_EXPR, realtype,
9647                                       node2)));
9648       break;
9649
9650     case MINUS_EXPR:
9651       if (TREE_CODE (type) != RECORD_TYPE)
9652         {
9653           item = build (code, type, node1, node2);
9654           break;
9655         }
9656       node1 = ffecom_stabilize_aggregate_ (node1);
9657       node2 = ffecom_stabilize_aggregate_ (node2);
9658       realtype = TREE_TYPE (TYPE_FIELDS (type));
9659       item =
9660         ffecom_2 (COMPLEX_EXPR, type,
9661                   ffecom_2 (MINUS_EXPR, realtype,
9662                             ffecom_1 (REALPART_EXPR, realtype,
9663                                       node1),
9664                             ffecom_1 (REALPART_EXPR, realtype,
9665                                       node2)),
9666                   ffecom_2 (MINUS_EXPR, realtype,
9667                             ffecom_1 (IMAGPART_EXPR, realtype,
9668                                       node1),
9669                             ffecom_1 (IMAGPART_EXPR, realtype,
9670                                       node2)));
9671       break;
9672
9673     case MULT_EXPR:
9674       if (TREE_CODE (type) != RECORD_TYPE)
9675         {
9676           item = build (code, type, node1, node2);
9677           break;
9678         }
9679       node1 = ffecom_stabilize_aggregate_ (node1);
9680       node2 = ffecom_stabilize_aggregate_ (node2);
9681       realtype = TREE_TYPE (TYPE_FIELDS (type));
9682       a = save_expr (ffecom_1 (REALPART_EXPR, realtype,
9683                                node1));
9684       b = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
9685                                node1));
9686       c = save_expr (ffecom_1 (REALPART_EXPR, realtype,
9687                                node2));
9688       d = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
9689                                node2));
9690       item =
9691         ffecom_2 (COMPLEX_EXPR, type,
9692                   ffecom_2 (MINUS_EXPR, realtype,
9693                             ffecom_2 (MULT_EXPR, realtype,
9694                                       a,
9695                                       c),
9696                             ffecom_2 (MULT_EXPR, realtype,
9697                                       b,
9698                                       d)),
9699                   ffecom_2 (PLUS_EXPR, realtype,
9700                             ffecom_2 (MULT_EXPR, realtype,
9701                                       a,
9702                                       d),
9703                             ffecom_2 (MULT_EXPR, realtype,
9704                                       c,
9705                                       b)));
9706       break;
9707
9708     case EQ_EXPR:
9709       if ((TREE_CODE (node1) != RECORD_TYPE)
9710           && (TREE_CODE (node2) != RECORD_TYPE))
9711         {
9712           item = build (code, type, node1, node2);
9713           break;
9714         }
9715       assert (TREE_CODE (node1) == RECORD_TYPE);
9716       assert (TREE_CODE (node2) == RECORD_TYPE);
9717       node1 = ffecom_stabilize_aggregate_ (node1);
9718       node2 = ffecom_stabilize_aggregate_ (node2);
9719       realtype = TREE_TYPE (TYPE_FIELDS (type));
9720       item =
9721         ffecom_2 (TRUTH_ANDIF_EXPR, type,
9722                   ffecom_2 (code, type,
9723                             ffecom_1 (REALPART_EXPR, realtype,
9724                                       node1),
9725                             ffecom_1 (REALPART_EXPR, realtype,
9726                                       node2)),
9727                   ffecom_2 (code, type,
9728                             ffecom_1 (IMAGPART_EXPR, realtype,
9729                                       node1),
9730                             ffecom_1 (IMAGPART_EXPR, realtype,
9731                                       node2)));
9732       break;
9733
9734     case NE_EXPR:
9735       if ((TREE_CODE (node1) != RECORD_TYPE)
9736           && (TREE_CODE (node2) != RECORD_TYPE))
9737         {
9738           item = build (code, type, node1, node2);
9739           break;
9740         }
9741       assert (TREE_CODE (node1) == RECORD_TYPE);
9742       assert (TREE_CODE (node2) == RECORD_TYPE);
9743       node1 = ffecom_stabilize_aggregate_ (node1);
9744       node2 = ffecom_stabilize_aggregate_ (node2);
9745       realtype = TREE_TYPE (TYPE_FIELDS (type));
9746       item =
9747         ffecom_2 (TRUTH_ORIF_EXPR, type,
9748                   ffecom_2 (code, type,
9749                             ffecom_1 (REALPART_EXPR, realtype,
9750                                       node1),
9751                             ffecom_1 (REALPART_EXPR, realtype,
9752                                       node2)),
9753                   ffecom_2 (code, type,
9754                             ffecom_1 (IMAGPART_EXPR, realtype,
9755                                       node1),
9756                             ffecom_1 (IMAGPART_EXPR, realtype,
9757                                       node2)));
9758       break;
9759
9760     default:
9761       item = build (code, type, node1, node2);
9762       break;
9763     }
9764
9765   if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2))
9766     TREE_SIDE_EFFECTS (item) = 1;
9767   return fold (item);
9768 }
9769
9770 /* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint
9771
9772    ffesymbol s;  // the ENTRY point itself
9773    if (ffecom_2pass_advise_entrypoint(s))
9774        // the ENTRY point has been accepted
9775
9776    Does whatever compiler needs to do when it learns about the entrypoint,
9777    like determine the return type of the master function, count the
9778    number of entrypoints, etc.  Returns FALSE if the return type is
9779    not compatible with the return type(s) of other entrypoint(s).
9780
9781    NOTE: for every call to this fn that returns TRUE, _do_entrypoint must
9782    later (after _finish_progunit) be called with the same entrypoint(s)
9783    as passed to this fn for which TRUE was returned.
9784
9785    03-Jan-92  JCB  2.0
9786       Return FALSE if the return type conflicts with previous entrypoints.  */
9787
9788 bool
9789 ffecom_2pass_advise_entrypoint (ffesymbol entry)
9790 {
9791   ffebld list;                  /* opITEM. */
9792   ffebld mlist;                 /* opITEM. */
9793   ffebld plist;                 /* opITEM. */
9794   ffebld arg;                   /* ffebld_head(opITEM). */
9795   ffebld item;                  /* opITEM. */
9796   ffesymbol s;                  /* ffebld_symter(arg). */
9797   ffeinfoBasictype bt = ffesymbol_basictype (entry);
9798   ffeinfoKindtype kt = ffesymbol_kindtype (entry);
9799   ffetargetCharacterSize size = ffesymbol_size (entry);
9800   bool ok;
9801
9802   if (ffecom_num_entrypoints_ == 0)
9803     {                           /* First entrypoint, make list of main
9804                                    arglist's dummies. */
9805       assert (ffecom_primary_entry_ != NULL);
9806
9807       ffecom_master_bt_ = ffesymbol_basictype (ffecom_primary_entry_);
9808       ffecom_master_kt_ = ffesymbol_kindtype (ffecom_primary_entry_);
9809       ffecom_master_size_ = ffesymbol_size (ffecom_primary_entry_);
9810
9811       for (plist = NULL, list = ffesymbol_dummyargs (ffecom_primary_entry_);
9812            list != NULL;
9813            list = ffebld_trail (list))
9814         {
9815           arg = ffebld_head (list);
9816           if (ffebld_op (arg) != FFEBLD_opSYMTER)
9817             continue;           /* Alternate return or some such thing. */
9818           item = ffebld_new_item (arg, NULL);
9819           if (plist == NULL)
9820             ffecom_master_arglist_ = item;
9821           else
9822             ffebld_set_trail (plist, item);
9823           plist = item;
9824         }
9825     }
9826
9827   /* If necessary, scan entry arglist for alternate returns.  Do this scan
9828      apparently redundantly (it's done below to UNIONize the arglists) so
9829      that we don't complain about RETURN 1 if an offending ENTRY is the only
9830      one with an alternate return.  */
9831
9832   if (!ffecom_is_altreturning_)
9833     {
9834       for (list = ffesymbol_dummyargs (entry);
9835            list != NULL;
9836            list = ffebld_trail (list))
9837         {
9838           arg = ffebld_head (list);
9839           if (ffebld_op (arg) == FFEBLD_opSTAR)
9840             {
9841               ffecom_is_altreturning_ = TRUE;
9842               break;
9843             }
9844         }
9845     }
9846
9847   /* Now check type compatibility. */
9848
9849   switch (ffecom_master_bt_)
9850     {
9851     case FFEINFO_basictypeNONE:
9852       ok = (bt != FFEINFO_basictypeCHARACTER);
9853       break;
9854
9855     case FFEINFO_basictypeCHARACTER:
9856       ok
9857         = (bt == FFEINFO_basictypeCHARACTER)
9858         && (kt == ffecom_master_kt_)
9859         && (size == ffecom_master_size_);
9860       break;
9861
9862     case FFEINFO_basictypeANY:
9863       return FALSE;             /* Just don't bother. */
9864
9865     default:
9866       if (bt == FFEINFO_basictypeCHARACTER)
9867         {
9868           ok = FALSE;
9869           break;
9870         }
9871       ok = TRUE;
9872       if ((bt != ffecom_master_bt_) || (kt != ffecom_master_kt_))
9873         {
9874           ffecom_master_bt_ = FFEINFO_basictypeNONE;
9875           ffecom_master_kt_ = FFEINFO_kindtypeNONE;
9876         }
9877       break;
9878     }
9879
9880   if (!ok)
9881     {
9882       ffebad_start (FFEBAD_ENTRY_CONFLICTS);
9883       ffest_ffebad_here_current_stmt (0);
9884       ffebad_finish ();
9885       return FALSE;             /* Can't handle entrypoint. */
9886     }
9887
9888   /* Entrypoint type compatible with previous types. */
9889
9890   ++ffecom_num_entrypoints_;
9891
9892   /* Master-arg-list = UNION(Master-arg-list,entry-arg-list). */
9893
9894   for (list = ffesymbol_dummyargs (entry);
9895        list != NULL;
9896        list = ffebld_trail (list))
9897     {
9898       arg = ffebld_head (list);
9899       if (ffebld_op (arg) != FFEBLD_opSYMTER)
9900         continue;               /* Alternate return or some such thing. */
9901       s = ffebld_symter (arg);
9902       for (plist = NULL, mlist = ffecom_master_arglist_;
9903            mlist != NULL;
9904            plist = mlist, mlist = ffebld_trail (mlist))
9905         {                       /* plist points to previous item for easy
9906                                    appending of arg. */
9907           if (ffebld_symter (ffebld_head (mlist)) == s)
9908             break;              /* Already have this arg in the master list. */
9909         }
9910       if (mlist != NULL)
9911         continue;               /* Already have this arg in the master list. */
9912
9913       /* Append this arg to the master list. */
9914
9915       item = ffebld_new_item (arg, NULL);
9916       if (plist == NULL)
9917         ffecom_master_arglist_ = item;
9918       else
9919         ffebld_set_trail (plist, item);
9920     }
9921
9922   return TRUE;
9923 }
9924
9925 /* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint
9926
9927    ffesymbol s;  // the ENTRY point itself
9928    ffecom_2pass_do_entrypoint(s);
9929
9930    Does whatever compiler needs to do to make the entrypoint actually
9931    happen.  Must be called for each entrypoint after
9932    ffecom_finish_progunit is called.  */
9933
9934 void
9935 ffecom_2pass_do_entrypoint (ffesymbol entry)
9936 {
9937   static int mfn_num = 0;
9938   static int ent_num;
9939
9940   if (mfn_num != ffecom_num_fns_)
9941     {                           /* First entrypoint for this program unit. */
9942       ent_num = 1;
9943       mfn_num = ffecom_num_fns_;
9944       ffecom_do_entry_ (ffecom_primary_entry_, 0);
9945     }
9946   else
9947     ++ent_num;
9948
9949   --ffecom_num_entrypoints_;
9950
9951   ffecom_do_entry_ (entry, ent_num);
9952 }
9953
9954 /* Essentially does a "fold (build (code, type, node1, node2))" while
9955    checking for certain housekeeping things.  Always sets
9956    TREE_SIDE_EFFECTS.  */
9957
9958 tree
9959 ffecom_2s (enum tree_code code, tree type, tree node1,
9960            tree node2)
9961 {
9962   tree item;
9963
9964   if ((node1 == error_mark_node)
9965       || (node2 == error_mark_node)
9966       || (type == error_mark_node))
9967     return error_mark_node;
9968
9969   item = build (code, type, node1, node2);
9970   TREE_SIDE_EFFECTS (item) = 1;
9971   return fold (item);
9972 }
9973
9974 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
9975    checking for certain housekeeping things.  */
9976
9977 tree
9978 ffecom_3 (enum tree_code code, tree type, tree node1,
9979           tree node2, tree node3)
9980 {
9981   tree item;
9982
9983   if ((node1 == error_mark_node)
9984       || (node2 == error_mark_node)
9985       || (node3 == error_mark_node)
9986       || (type == error_mark_node))
9987     return error_mark_node;
9988
9989   item = build (code, type, node1, node2, node3);
9990   if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2)
9991       || (node3 != NULL_TREE && TREE_SIDE_EFFECTS (node3)))
9992     TREE_SIDE_EFFECTS (item) = 1;
9993   return fold (item);
9994 }
9995
9996 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
9997    checking for certain housekeeping things.  Always sets
9998    TREE_SIDE_EFFECTS.  */
9999
10000 tree
10001 ffecom_3s (enum tree_code code, tree type, tree node1,
10002            tree node2, tree node3)
10003 {
10004   tree item;
10005
10006   if ((node1 == error_mark_node)
10007       || (node2 == error_mark_node)
10008       || (node3 == error_mark_node)
10009       || (type == error_mark_node))
10010     return error_mark_node;
10011
10012   item = build (code, type, node1, node2, node3);
10013   TREE_SIDE_EFFECTS (item) = 1;
10014   return fold (item);
10015 }
10016
10017 /* ffecom_arg_expr -- Transform argument expr into gcc tree
10018
10019    See use by ffecom_list_expr.
10020
10021    If expression is NULL, returns an integer zero tree.  If it is not
10022    a CHARACTER expression, returns whatever ffecom_expr
10023    returns and sets the length return value to NULL_TREE.  Otherwise
10024    generates code to evaluate the character expression, returns the proper
10025    pointer to the result, but does NOT set the length return value to a tree
10026    that specifies the length of the result.  (In other words, the length
10027    variable is always set to NULL_TREE, because a length is never passed.)
10028
10029    21-Dec-91  JCB  1.1
10030       Don't set returned length, since nobody needs it (yet; someday if
10031       we allow CHARACTER*(*) dummies to statement functions, we'll need
10032       it).  */
10033
10034 tree
10035 ffecom_arg_expr (ffebld expr, tree *length)
10036 {
10037   tree ign;
10038
10039   *length = NULL_TREE;
10040
10041   if (expr == NULL)
10042     return integer_zero_node;
10043
10044   if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10045     return ffecom_expr (expr);
10046
10047   return ffecom_arg_ptr_to_expr (expr, &ign);
10048 }
10049
10050 /* Transform expression into constant argument-pointer-to-expression tree.
10051
10052    If the expression can be transformed into a argument-pointer-to-expression
10053    tree that is constant, that is done, and the tree returned.  Else
10054    NULL_TREE is returned.
10055
10056    That way, a caller can attempt to provide compile-time initialization
10057    of a variable and, if that fails, *then* choose to start a new block
10058    and resort to using temporaries, as appropriate.  */
10059
10060 tree
10061 ffecom_arg_ptr_to_const_expr (ffebld expr, tree *length)
10062 {
10063   if (! expr)
10064     return integer_zero_node;
10065
10066   if (ffebld_op (expr) == FFEBLD_opANY)
10067     {
10068       if (length)
10069         *length = error_mark_node;
10070       return error_mark_node;
10071     }
10072
10073   if (ffebld_arity (expr) == 0
10074       && (ffebld_op (expr) != FFEBLD_opSYMTER
10075           || ffebld_where (expr) == FFEINFO_whereCOMMON
10076           || ffebld_where (expr) == FFEINFO_whereGLOBAL
10077           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10078     {
10079       tree t;
10080
10081       t = ffecom_arg_ptr_to_expr (expr, length);
10082       assert (TREE_CONSTANT (t));
10083       assert (! length || TREE_CONSTANT (*length));
10084       return t;
10085     }
10086
10087   if (length
10088       && ffebld_size (expr) != FFETARGET_charactersizeNONE)
10089     *length = build_int_2 (ffebld_size (expr), 0);
10090   else if (length)
10091     *length = NULL_TREE;
10092   return NULL_TREE;
10093 }
10094
10095 /* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree
10096
10097    See use by ffecom_list_ptr_to_expr.
10098
10099    If expression is NULL, returns an integer zero tree.  If it is not
10100    a CHARACTER expression, returns whatever ffecom_ptr_to_expr
10101    returns and sets the length return value to NULL_TREE.  Otherwise
10102    generates code to evaluate the character expression, returns the proper
10103    pointer to the result, AND sets the length return value to a tree that
10104    specifies the length of the result.
10105
10106    If the length argument is NULL, this is a slightly special
10107    case of building a FORMAT expression, that is, an expression that
10108    will be used at run time without regard to length.  For the current
10109    implementation, which uses the libf2c library, this means it is nice
10110    to append a null byte to the end of the expression, where feasible,
10111    to make sure any diagnostic about the FORMAT string terminates at
10112    some useful point.
10113
10114    For now, treat %REF(char-expr) as the same as char-expr with a NULL
10115    length argument.  This might even be seen as a feature, if a null
10116    byte can always be appended.  */
10117
10118 tree
10119 ffecom_arg_ptr_to_expr (ffebld expr, tree *length)
10120 {
10121   tree item;
10122   tree ign_length;
10123   ffecomConcatList_ catlist;
10124
10125   if (length != NULL)
10126     *length = NULL_TREE;
10127
10128   if (expr == NULL)
10129     return integer_zero_node;
10130
10131   switch (ffebld_op (expr))
10132     {
10133     case FFEBLD_opPERCENT_VAL:
10134       if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10135         return ffecom_expr (ffebld_left (expr));
10136       {
10137         tree temp_exp;
10138         tree temp_length;
10139
10140         temp_exp = ffecom_arg_ptr_to_expr (ffebld_left (expr), &temp_length);
10141         if (temp_exp == error_mark_node)
10142           return error_mark_node;
10143
10144         return ffecom_1 (INDIRECT_REF, TREE_TYPE (TREE_TYPE (temp_exp)),
10145                          temp_exp);
10146       }
10147
10148     case FFEBLD_opPERCENT_REF:
10149       if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10150         return ffecom_ptr_to_expr (ffebld_left (expr));
10151       if (length != NULL)
10152         {
10153           ign_length = NULL_TREE;
10154           length = &ign_length;
10155         }
10156       expr = ffebld_left (expr);
10157       break;
10158
10159     case FFEBLD_opPERCENT_DESCR:
10160       switch (ffeinfo_basictype (ffebld_info (expr)))
10161         {
10162 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10163         case FFEINFO_basictypeHOLLERITH:
10164 #endif
10165         case FFEINFO_basictypeCHARACTER:
10166           break;                /* Passed by descriptor anyway. */
10167
10168         default:
10169           item = ffecom_ptr_to_expr (expr);
10170           if (item != error_mark_node)
10171             *length = TYPE_SIZE (TREE_TYPE (TREE_TYPE (item)));
10172           break;
10173         }
10174       break;
10175
10176     default:
10177       break;
10178     }
10179
10180 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10181   if ((ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeHOLLERITH)
10182       && (length != NULL))
10183     {                           /* Pass Hollerith by descriptor. */
10184       ffetargetHollerith h;
10185
10186       assert (ffebld_op (expr) == FFEBLD_opCONTER);
10187       h = ffebld_cu_val_hollerith (ffebld_constant_union
10188                                    (ffebld_conter (expr)));
10189       *length
10190         = build_int_2 (h.length, 0);
10191       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10192     }
10193 #endif
10194
10195   if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10196     return ffecom_ptr_to_expr (expr);
10197
10198   assert (ffeinfo_kindtype (ffebld_info (expr))
10199           == FFEINFO_kindtypeCHARACTER1);
10200
10201   while (ffebld_op (expr) == FFEBLD_opPAREN)
10202     expr = ffebld_left (expr);
10203
10204   catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
10205   switch (ffecom_concat_list_count_ (catlist))
10206     {
10207     case 0:                     /* Shouldn't happen, but in case it does... */
10208       if (length != NULL)
10209         {
10210           *length = ffecom_f2c_ftnlen_zero_node;
10211           TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10212         }
10213       ffecom_concat_list_kill_ (catlist);
10214       return null_pointer_node;
10215
10216     case 1:                     /* The (fairly) easy case. */
10217       if (length == NULL)
10218         ffecom_char_args_with_null_ (&item, &ign_length,
10219                                      ffecom_concat_list_expr_ (catlist, 0));
10220       else
10221         ffecom_char_args_ (&item, length,
10222                            ffecom_concat_list_expr_ (catlist, 0));
10223       ffecom_concat_list_kill_ (catlist);
10224       assert (item != NULL_TREE);
10225       return item;
10226
10227     default:                    /* Must actually concatenate things. */
10228       break;
10229     }
10230
10231   {
10232     int count = ffecom_concat_list_count_ (catlist);
10233     int i;
10234     tree lengths;
10235     tree items;
10236     tree length_array;
10237     tree item_array;
10238     tree citem;
10239     tree clength;
10240     tree temporary;
10241     tree num;
10242     tree known_length;
10243     ffetargetCharacterSize sz;
10244
10245     sz = ffecom_concat_list_maxlen_ (catlist);
10246     /* ~~Kludge! */
10247     assert (sz != FFETARGET_charactersizeNONE);
10248
10249 #ifdef HOHO
10250     length_array
10251       = lengths
10252       = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
10253                              FFETARGET_charactersizeNONE, count, TRUE);
10254     item_array
10255       = items
10256       = ffecom_push_tempvar (ffecom_f2c_address_type_node,
10257                              FFETARGET_charactersizeNONE, count, TRUE);
10258     temporary = ffecom_push_tempvar (char_type_node,
10259                                      sz, -1, TRUE);
10260 #else
10261     {
10262       tree hook;
10263
10264       hook = ffebld_nonter_hook (expr);
10265       assert (hook);
10266       assert (TREE_CODE (hook) == TREE_VEC);
10267       assert (TREE_VEC_LENGTH (hook) == 3);
10268       length_array = lengths = TREE_VEC_ELT (hook, 0);
10269       item_array = items = TREE_VEC_ELT (hook, 1);
10270       temporary = TREE_VEC_ELT (hook, 2);
10271     }
10272 #endif
10273
10274     known_length = ffecom_f2c_ftnlen_zero_node;
10275
10276     for (i = 0; i < count; ++i)
10277       {
10278         if ((i == count)
10279             && (length == NULL))
10280           ffecom_char_args_with_null_ (&citem, &clength,
10281                                        ffecom_concat_list_expr_ (catlist, i));
10282         else
10283           ffecom_char_args_ (&citem, &clength,
10284                              ffecom_concat_list_expr_ (catlist, i));
10285         if ((citem == error_mark_node)
10286             || (clength == error_mark_node))
10287           {
10288             ffecom_concat_list_kill_ (catlist);
10289             *length = error_mark_node;
10290             return error_mark_node;
10291           }
10292
10293         items
10294           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
10295                       ffecom_modify (void_type_node,
10296                                      ffecom_2 (ARRAY_REF,
10297                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
10298                                                item_array,
10299                                                build_int_2 (i, 0)),
10300                                      citem),
10301                       items);
10302         clength = ffecom_save_tree (clength);
10303         if (length != NULL)
10304           known_length
10305             = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
10306                         known_length,
10307                         clength);
10308         lengths
10309           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
10310                       ffecom_modify (void_type_node,
10311                                      ffecom_2 (ARRAY_REF,
10312                    TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
10313                                                length_array,
10314                                                build_int_2 (i, 0)),
10315                                      clength),
10316                       lengths);
10317       }
10318
10319     temporary = ffecom_1 (ADDR_EXPR,
10320                           build_pointer_type (TREE_TYPE (temporary)),
10321                           temporary);
10322
10323     item = build_tree_list (NULL_TREE, temporary);
10324     TREE_CHAIN (item)
10325       = build_tree_list (NULL_TREE,
10326                          ffecom_1 (ADDR_EXPR,
10327                                    build_pointer_type (TREE_TYPE (items)),
10328                                    items));
10329     TREE_CHAIN (TREE_CHAIN (item))
10330       = build_tree_list (NULL_TREE,
10331                          ffecom_1 (ADDR_EXPR,
10332                                    build_pointer_type (TREE_TYPE (lengths)),
10333                                    lengths));
10334     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
10335       = build_tree_list
10336         (NULL_TREE,
10337          ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
10338                    convert (ffecom_f2c_ftnlen_type_node,
10339                             build_int_2 (count, 0))));
10340     num = build_int_2 (sz, 0);
10341     TREE_TYPE (num) = ffecom_f2c_ftnlen_type_node;
10342     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item))))
10343       = build_tree_list (NULL_TREE, num);
10344
10345     item = ffecom_call_gfrt (FFECOM_gfrtCAT, item, NULL_TREE);
10346     TREE_SIDE_EFFECTS (item) = 1;
10347     item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (temporary),
10348                      item,
10349                      temporary);
10350
10351     if (length != NULL)
10352       *length = known_length;
10353   }
10354
10355   ffecom_concat_list_kill_ (catlist);
10356   assert (item != NULL_TREE);
10357   return item;
10358 }
10359
10360 /* Generate call to run-time function.
10361
10362    The first arg is the GNU Fortran Run-Time function index, the second
10363    arg is the list of arguments to pass to it.  Returned is the expression
10364    (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the
10365    result (which may be void).  */
10366
10367 tree
10368 ffecom_call_gfrt (ffecomGfrt ix, tree args, tree hook)
10369 {
10370   return ffecom_call_ (ffecom_gfrt_tree_ (ix),
10371                        ffecom_gfrt_kindtype (ix),
10372                        ffe_is_f2c_library () && ffecom_gfrt_complex_[ix],
10373                        NULL_TREE, args, NULL_TREE, NULL,
10374                        NULL, NULL_TREE, TRUE, hook);
10375 }
10376
10377 /* Transform constant-union to tree.  */
10378
10379 tree
10380 ffecom_constantunion (ffebldConstantUnion *cu, ffeinfoBasictype bt,
10381                       ffeinfoKindtype kt, tree tree_type)
10382 {
10383   tree item;
10384
10385   switch (bt)
10386     {
10387     case FFEINFO_basictypeINTEGER:
10388       {
10389         int val;
10390
10391         switch (kt)
10392           {
10393 #if FFETARGET_okINTEGER1
10394           case FFEINFO_kindtypeINTEGER1:
10395             val = ffebld_cu_val_integer1 (*cu);
10396             break;
10397 #endif
10398
10399 #if FFETARGET_okINTEGER2
10400           case FFEINFO_kindtypeINTEGER2:
10401             val = ffebld_cu_val_integer2 (*cu);
10402             break;
10403 #endif
10404
10405 #if FFETARGET_okINTEGER3
10406           case FFEINFO_kindtypeINTEGER3:
10407             val = ffebld_cu_val_integer3 (*cu);
10408             break;
10409 #endif
10410
10411 #if FFETARGET_okINTEGER4
10412           case FFEINFO_kindtypeINTEGER4:
10413             val = ffebld_cu_val_integer4 (*cu);
10414             break;
10415 #endif
10416
10417           default:
10418             assert ("bad INTEGER constant kind type" == NULL);
10419             /* Fall through. */
10420           case FFEINFO_kindtypeANY:
10421             return error_mark_node;
10422           }
10423         item = build_int_2 (val, (val < 0) ? -1 : 0);
10424         TREE_TYPE (item) = tree_type;
10425       }
10426       break;
10427
10428     case FFEINFO_basictypeLOGICAL:
10429       {
10430         int val;
10431
10432         switch (kt)
10433           {
10434 #if FFETARGET_okLOGICAL1
10435           case FFEINFO_kindtypeLOGICAL1:
10436             val = ffebld_cu_val_logical1 (*cu);
10437             break;
10438 #endif
10439
10440 #if FFETARGET_okLOGICAL2
10441           case FFEINFO_kindtypeLOGICAL2:
10442             val = ffebld_cu_val_logical2 (*cu);
10443             break;
10444 #endif
10445
10446 #if FFETARGET_okLOGICAL3
10447           case FFEINFO_kindtypeLOGICAL3:
10448             val = ffebld_cu_val_logical3 (*cu);
10449             break;
10450 #endif
10451
10452 #if FFETARGET_okLOGICAL4
10453           case FFEINFO_kindtypeLOGICAL4:
10454             val = ffebld_cu_val_logical4 (*cu);
10455             break;
10456 #endif
10457
10458           default:
10459             assert ("bad LOGICAL constant kind type" == NULL);
10460             /* Fall through. */
10461           case FFEINFO_kindtypeANY:
10462             return error_mark_node;
10463           }
10464         item = build_int_2 (val, (val < 0) ? -1 : 0);
10465         TREE_TYPE (item) = tree_type;
10466       }
10467       break;
10468
10469     case FFEINFO_basictypeREAL:
10470       {
10471         REAL_VALUE_TYPE val;
10472
10473         switch (kt)
10474           {
10475 #if FFETARGET_okREAL1
10476           case FFEINFO_kindtypeREAL1:
10477             val = ffetarget_value_real1 (ffebld_cu_val_real1 (*cu));
10478             break;
10479 #endif
10480
10481 #if FFETARGET_okREAL2
10482           case FFEINFO_kindtypeREAL2:
10483             val = ffetarget_value_real2 (ffebld_cu_val_real2 (*cu));
10484             break;
10485 #endif
10486
10487 #if FFETARGET_okREAL3
10488           case FFEINFO_kindtypeREAL3:
10489             val = ffetarget_value_real3 (ffebld_cu_val_real3 (*cu));
10490             break;
10491 #endif
10492
10493 #if FFETARGET_okREAL4
10494           case FFEINFO_kindtypeREAL4:
10495             val = ffetarget_value_real4 (ffebld_cu_val_real4 (*cu));
10496             break;
10497 #endif
10498
10499           default:
10500             assert ("bad REAL constant kind type" == NULL);
10501             /* Fall through. */
10502           case FFEINFO_kindtypeANY:
10503             return error_mark_node;
10504           }
10505         item = build_real (tree_type, val);
10506       }
10507       break;
10508
10509     case FFEINFO_basictypeCOMPLEX:
10510       {
10511         REAL_VALUE_TYPE real;
10512         REAL_VALUE_TYPE imag;
10513         tree el_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
10514
10515         switch (kt)
10516           {
10517 #if FFETARGET_okCOMPLEX1
10518           case FFEINFO_kindtypeREAL1:
10519             real = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).real);
10520             imag = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).imaginary);
10521             break;
10522 #endif
10523
10524 #if FFETARGET_okCOMPLEX2
10525           case FFEINFO_kindtypeREAL2:
10526             real = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).real);
10527             imag = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).imaginary);
10528             break;
10529 #endif
10530
10531 #if FFETARGET_okCOMPLEX3
10532           case FFEINFO_kindtypeREAL3:
10533             real = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).real);
10534             imag = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).imaginary);
10535             break;
10536 #endif
10537
10538 #if FFETARGET_okCOMPLEX4
10539           case FFEINFO_kindtypeREAL4:
10540             real = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).real);
10541             imag = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).imaginary);
10542             break;
10543 #endif
10544
10545           default:
10546             assert ("bad REAL constant kind type" == NULL);
10547             /* Fall through. */
10548           case FFEINFO_kindtypeANY:
10549             return error_mark_node;
10550           }
10551         item = ffecom_build_complex_constant_ (tree_type,
10552                                                build_real (el_type, real),
10553                                                build_real (el_type, imag));
10554       }
10555       break;
10556
10557     case FFEINFO_basictypeCHARACTER:
10558       {                         /* Happens only in DATA and similar contexts. */
10559         ffetargetCharacter1 val;
10560
10561         switch (kt)
10562           {
10563 #if FFETARGET_okCHARACTER1
10564           case FFEINFO_kindtypeLOGICAL1:
10565             val = ffebld_cu_val_character1 (*cu);
10566             break;
10567 #endif
10568
10569           default:
10570             assert ("bad CHARACTER constant kind type" == NULL);
10571             /* Fall through. */
10572           case FFEINFO_kindtypeANY:
10573             return error_mark_node;
10574           }
10575         item = build_string (ffetarget_length_character1 (val),
10576                              ffetarget_text_character1 (val));
10577         TREE_TYPE (item)
10578           = build_type_variant (build_array_type (char_type_node,
10579                                                   build_range_type
10580                                                   (integer_type_node,
10581                                                    integer_one_node,
10582                                                    build_int_2
10583                                                 (ffetarget_length_character1
10584                                                  (val), 0))),
10585                                 1, 0);
10586       }
10587       break;
10588
10589     case FFEINFO_basictypeHOLLERITH:
10590       {
10591         ffetargetHollerith h;
10592
10593         h = ffebld_cu_val_hollerith (*cu);
10594
10595         /* If not at least as wide as default INTEGER, widen it.  */
10596         if (h.length >= FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE)
10597           item = build_string (h.length, h.text);
10598         else
10599           {
10600             char str[FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE];
10601
10602             memcpy (str, h.text, h.length);
10603             memset (&str[h.length], ' ',
10604                     FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE
10605                     - h.length);
10606             item = build_string (FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE,
10607                                  str);
10608           }
10609         TREE_TYPE (item)
10610           = build_type_variant (build_array_type (char_type_node,
10611                                                   build_range_type
10612                                                   (integer_type_node,
10613                                                    integer_one_node,
10614                                                    build_int_2
10615                                                    (h.length, 0))),
10616                                 1, 0);
10617       }
10618       break;
10619
10620     case FFEINFO_basictypeTYPELESS:
10621       {
10622         ffetargetInteger1 ival;
10623         ffetargetTypeless tless;
10624         ffebad error;
10625
10626         tless = ffebld_cu_val_typeless (*cu);
10627         error = ffetarget_convert_integer1_typeless (&ival, tless);
10628         assert (error == FFEBAD);
10629
10630         item = build_int_2 ((int) ival, 0);
10631       }
10632       break;
10633
10634     default:
10635       assert ("not yet on constant type" == NULL);
10636       /* Fall through. */
10637     case FFEINFO_basictypeANY:
10638       return error_mark_node;
10639     }
10640
10641   TREE_CONSTANT (item) = 1;
10642
10643   return item;
10644 }
10645
10646 /* Transform expression into constant tree.
10647
10648    If the expression can be transformed into a tree that is constant,
10649    that is done, and the tree returned.  Else NULL_TREE is returned.
10650
10651    That way, a caller can attempt to provide compile-time initialization
10652    of a variable and, if that fails, *then* choose to start a new block
10653    and resort to using temporaries, as appropriate.  */
10654
10655 tree
10656 ffecom_const_expr (ffebld expr)
10657 {
10658   if (! expr)
10659     return integer_zero_node;
10660
10661   if (ffebld_op (expr) == FFEBLD_opANY)
10662     return error_mark_node;
10663
10664   if (ffebld_arity (expr) == 0
10665       && (ffebld_op (expr) != FFEBLD_opSYMTER
10666 #if NEWCOMMON
10667           /* ~~Enable once common/equivalence is handled properly?  */
10668           || ffebld_where (expr) == FFEINFO_whereCOMMON
10669 #endif
10670           || ffebld_where (expr) == FFEINFO_whereGLOBAL
10671           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10672     {
10673       tree t;
10674
10675       t = ffecom_expr (expr);
10676       assert (TREE_CONSTANT (t));
10677       return t;
10678     }
10679
10680   return NULL_TREE;
10681 }
10682
10683 /* Handy way to make a field in a struct/union.  */
10684
10685 tree
10686 ffecom_decl_field (tree context, tree prevfield,
10687                    const char *name, tree type)
10688 {
10689   tree field;
10690
10691   field = build_decl (FIELD_DECL, get_identifier (name), type);
10692   DECL_CONTEXT (field) = context;
10693   DECL_ALIGN (field) = 0;
10694   DECL_USER_ALIGN (field) = 0;
10695   if (prevfield != NULL_TREE)
10696     TREE_CHAIN (prevfield) = field;
10697
10698   return field;
10699 }
10700
10701 void
10702 ffecom_close_include (FILE *f)
10703 {
10704   ffecom_close_include_ (f);
10705 }
10706
10707 int
10708 ffecom_decode_include_option (char *spec)
10709 {
10710   return ffecom_decode_include_option_ (spec);
10711 }
10712
10713 /* End a compound statement (block).  */
10714
10715 tree
10716 ffecom_end_compstmt (void)
10717 {
10718   return bison_rule_compstmt_ ();
10719 }
10720
10721 /* ffecom_end_transition -- Perform end transition on all symbols
10722
10723    ffecom_end_transition();
10724
10725    Calls ffecom_sym_end_transition for each global and local symbol.  */
10726
10727 void
10728 ffecom_end_transition ()
10729 {
10730   ffebld item;
10731
10732   if (ffe_is_ffedebug ())
10733     fprintf (dmpout, "; end_stmt_transition\n");
10734
10735   ffecom_list_blockdata_ = NULL;
10736   ffecom_list_common_ = NULL;
10737
10738   ffesymbol_drive (ffecom_sym_end_transition);
10739   if (ffe_is_ffedebug ())
10740     {
10741       ffestorag_report ();
10742     }
10743
10744   ffecom_start_progunit_ ();
10745
10746   for (item = ffecom_list_blockdata_;
10747        item != NULL;
10748        item = ffebld_trail (item))
10749     {
10750       ffebld callee;
10751       ffesymbol s;
10752       tree dt;
10753       tree t;
10754       tree var;
10755       static int number = 0;
10756
10757       callee = ffebld_head (item);
10758       s = ffebld_symter (callee);
10759       t = ffesymbol_hook (s).decl_tree;
10760       if (t == NULL_TREE)
10761         {
10762           s = ffecom_sym_transform_ (s);
10763           t = ffesymbol_hook (s).decl_tree;
10764         }
10765
10766       dt = build_pointer_type (TREE_TYPE (t));
10767
10768       var = build_decl (VAR_DECL,
10769                         ffecom_get_invented_identifier ("__g77_forceload_%d",
10770                                                         number++),
10771                         dt);
10772       DECL_EXTERNAL (var) = 0;
10773       TREE_STATIC (var) = 1;
10774       TREE_PUBLIC (var) = 0;
10775       DECL_INITIAL (var) = error_mark_node;
10776       TREE_USED (var) = 1;
10777
10778       var = start_decl (var, FALSE);
10779
10780       t = ffecom_1 (ADDR_EXPR, dt, t);
10781
10782       finish_decl (var, t, FALSE);
10783     }
10784
10785   /* This handles any COMMON areas that weren't referenced but have, for
10786      example, important initial data.  */
10787
10788   for (item = ffecom_list_common_;
10789        item != NULL;
10790        item = ffebld_trail (item))
10791     ffecom_transform_common_ (ffebld_symter (ffebld_head (item)));
10792
10793   ffecom_list_common_ = NULL;
10794 }
10795
10796 /* ffecom_exec_transition -- Perform exec transition on all symbols
10797
10798    ffecom_exec_transition();
10799
10800    Calls ffecom_sym_exec_transition for each global and local symbol.
10801    Make sure error updating not inhibited.  */
10802
10803 void
10804 ffecom_exec_transition ()
10805 {
10806   bool inhibited;
10807
10808   if (ffe_is_ffedebug ())
10809     fprintf (dmpout, "; exec_stmt_transition\n");
10810
10811   inhibited = ffebad_inhibit ();
10812   ffebad_set_inhibit (FALSE);
10813
10814   ffesymbol_drive (ffecom_sym_exec_transition); /* Don't retract! */
10815   ffeequiv_exec_transition ();  /* Handle all pending EQUIVALENCEs. */
10816   if (ffe_is_ffedebug ())
10817     {
10818       ffestorag_report ();
10819     }
10820
10821   if (inhibited)
10822     ffebad_set_inhibit (TRUE);
10823 }
10824
10825 /* Handle assignment statement.
10826
10827    Convert dest and source using ffecom_expr, then join them
10828    with an ASSIGN op and pass the whole thing to expand_expr_stmt.  */
10829
10830 void
10831 ffecom_expand_let_stmt (ffebld dest, ffebld source)
10832 {
10833   tree dest_tree;
10834   tree dest_length;
10835   tree source_tree;
10836   tree expr_tree;
10837
10838   if (ffeinfo_basictype (ffebld_info (dest)) != FFEINFO_basictypeCHARACTER)
10839     {
10840       bool dest_used;
10841       tree assign_temp;
10842
10843       /* This attempts to replicate the test below, but must not be
10844          true when the test below is false.  (Always err on the side
10845          of creating unused temporaries, to avoid ICEs.)  */
10846       if (ffebld_op (dest) != FFEBLD_opSYMTER
10847           || ((dest_tree = ffesymbol_hook (ffebld_symter (dest)).decl_tree)
10848               && (TREE_CODE (dest_tree) != VAR_DECL
10849                   || TREE_ADDRESSABLE (dest_tree))))
10850         {
10851           ffecom_prepare_expr_ (source, dest);
10852           dest_used = TRUE;
10853         }
10854       else
10855         {
10856           ffecom_prepare_expr_ (source, NULL);
10857           dest_used = FALSE;
10858         }
10859
10860       ffecom_prepare_expr_w (NULL_TREE, dest);
10861
10862       /* For COMPLEX assignment like C1=C2, if partial overlap is possible,
10863          create a temporary through which the assignment is to take place,
10864          since MODIFY_EXPR doesn't handle partial overlap properly.  */
10865       if (ffebld_basictype (dest) == FFEINFO_basictypeCOMPLEX
10866           && ffecom_possible_partial_overlap_ (dest, source))
10867         {
10868           assign_temp = ffecom_make_tempvar ("complex_let",
10869                                              ffecom_tree_type
10870                                              [ffebld_basictype (dest)]
10871                                              [ffebld_kindtype (dest)],
10872                                              FFETARGET_charactersizeNONE,
10873                                              -1);
10874         }
10875       else
10876         assign_temp = NULL_TREE;
10877
10878       ffecom_prepare_end ();
10879
10880       dest_tree = ffecom_expr_w (NULL_TREE, dest);
10881       if (dest_tree == error_mark_node)
10882         return;
10883
10884       if ((TREE_CODE (dest_tree) != VAR_DECL)
10885           || TREE_ADDRESSABLE (dest_tree))
10886         source_tree = ffecom_expr_ (source, dest_tree, dest, &dest_used,
10887                                     FALSE, FALSE);
10888       else
10889         {
10890           assert (! dest_used);
10891           dest_used = FALSE;
10892           source_tree = ffecom_expr (source);
10893         }
10894       if (source_tree == error_mark_node)
10895         return;
10896
10897       if (dest_used)
10898         expr_tree = source_tree;
10899       else if (assign_temp)
10900         {
10901 #ifdef MOVE_EXPR
10902           /* The back end understands a conceptual move (evaluate source;
10903              store into dest), so use that, in case it can determine
10904              that it is going to use, say, two registers as temporaries
10905              anyway.  So don't use the temp (and someday avoid generating
10906              it, once this code starts triggering regularly).  */
10907           expr_tree = ffecom_2s (MOVE_EXPR, void_type_node,
10908                                  dest_tree,
10909                                  source_tree);
10910 #else
10911           expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
10912                                  assign_temp,
10913                                  source_tree);
10914           expand_expr_stmt (expr_tree);
10915           expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
10916                                  dest_tree,
10917                                  assign_temp);
10918 #endif
10919         }
10920       else
10921         expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
10922                                dest_tree,
10923                                source_tree);
10924
10925       expand_expr_stmt (expr_tree);
10926       return;
10927     }
10928
10929   ffecom_prepare_let_char_ (ffebld_size_known (dest), source);
10930   ffecom_prepare_expr_w (NULL_TREE, dest);
10931
10932   ffecom_prepare_end ();
10933
10934   ffecom_char_args_ (&dest_tree, &dest_length, dest);
10935   ffecom_let_char_ (dest_tree, dest_length, ffebld_size_known (dest),
10936                     source);
10937 }
10938
10939 /* ffecom_expr -- Transform expr into gcc tree
10940
10941    tree t;
10942    ffebld expr;  // FFE expression.
10943    tree = ffecom_expr(expr);
10944
10945    Recursive descent on expr while making corresponding tree nodes and
10946    attaching type info and such.  */
10947
10948 tree
10949 ffecom_expr (ffebld expr)
10950 {
10951   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, FALSE, FALSE);
10952 }
10953
10954 /* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT.  */
10955
10956 tree
10957 ffecom_expr_assign (ffebld expr)
10958 {
10959   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
10960 }
10961
10962 /* Like ffecom_expr_rw, but return tree usable for ASSIGN.  */
10963
10964 tree
10965 ffecom_expr_assign_w (ffebld expr)
10966 {
10967   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
10968 }
10969
10970 /* Transform expr for use as into read/write tree and stabilize the
10971    reference.  Not for use on CHARACTER expressions.
10972
10973    Recursive descent on expr while making corresponding tree nodes and
10974    attaching type info and such.  */
10975
10976 tree
10977 ffecom_expr_rw (tree type, ffebld expr)
10978 {
10979   assert (expr != NULL);
10980   /* Different target types not yet supported.  */
10981   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
10982
10983   return stabilize_reference (ffecom_expr (expr));
10984 }
10985
10986 /* Transform expr for use as into write tree and stabilize the
10987    reference.  Not for use on CHARACTER expressions.
10988
10989    Recursive descent on expr while making corresponding tree nodes and
10990    attaching type info and such.  */
10991
10992 tree
10993 ffecom_expr_w (tree type, ffebld expr)
10994 {
10995   assert (expr != NULL);
10996   /* Different target types not yet supported.  */
10997   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
10998
10999   return stabilize_reference (ffecom_expr (expr));
11000 }
11001
11002 /* Do global stuff.  */
11003
11004 void
11005 ffecom_finish_compile ()
11006 {
11007   assert (ffecom_outer_function_decl_ == NULL_TREE);
11008   assert (current_function_decl == NULL_TREE);
11009
11010   ffeglobal_drive (ffecom_finish_global_);
11011 }
11012
11013 /* Public entry point for front end to access finish_decl.  */
11014
11015 void
11016 ffecom_finish_decl (tree decl, tree init, bool is_top_level)
11017 {
11018   assert (!is_top_level);
11019   finish_decl (decl, init, FALSE);
11020 }
11021
11022 /* Finish a program unit.  */
11023
11024 void
11025 ffecom_finish_progunit ()
11026 {
11027   ffecom_end_compstmt ();
11028
11029   ffecom_previous_function_decl_ = current_function_decl;
11030   ffecom_which_entrypoint_decl_ = NULL_TREE;
11031
11032   finish_function (0);
11033 }
11034
11035 /* Wrapper for get_identifier.  pattern is sprintf-like.  */
11036
11037 tree
11038 ffecom_get_invented_identifier (const char *pattern, ...)
11039 {
11040   tree decl;
11041   char *nam;
11042   va_list ap;
11043
11044   va_start (ap, pattern);
11045   if (vasprintf (&nam, pattern, ap) == 0)
11046     abort ();
11047   va_end (ap);
11048   decl = get_identifier (nam);
11049   free (nam);
11050   IDENTIFIER_INVENTED (decl) = 1;
11051   return decl;
11052 }
11053
11054 ffeinfoBasictype
11055 ffecom_gfrt_basictype (ffecomGfrt gfrt)
11056 {
11057   assert (gfrt < FFECOM_gfrt);
11058
11059   switch (ffecom_gfrt_type_[gfrt])
11060     {
11061     case FFECOM_rttypeVOID_:
11062     case FFECOM_rttypeVOIDSTAR_:
11063       return FFEINFO_basictypeNONE;
11064
11065     case FFECOM_rttypeFTNINT_:
11066       return FFEINFO_basictypeINTEGER;
11067
11068     case FFECOM_rttypeINTEGER_:
11069       return FFEINFO_basictypeINTEGER;
11070
11071     case FFECOM_rttypeLONGINT_:
11072       return FFEINFO_basictypeINTEGER;
11073
11074     case FFECOM_rttypeLOGICAL_:
11075       return FFEINFO_basictypeLOGICAL;
11076
11077     case FFECOM_rttypeREAL_F2C_:
11078     case FFECOM_rttypeREAL_GNU_:
11079       return FFEINFO_basictypeREAL;
11080
11081     case FFECOM_rttypeCOMPLEX_F2C_:
11082     case FFECOM_rttypeCOMPLEX_GNU_:
11083       return FFEINFO_basictypeCOMPLEX;
11084
11085     case FFECOM_rttypeDOUBLE_:
11086     case FFECOM_rttypeDOUBLEREAL_:
11087       return FFEINFO_basictypeREAL;
11088
11089     case FFECOM_rttypeDBLCMPLX_F2C_:
11090     case FFECOM_rttypeDBLCMPLX_GNU_:
11091       return FFEINFO_basictypeCOMPLEX;
11092
11093     case FFECOM_rttypeCHARACTER_:
11094       return FFEINFO_basictypeCHARACTER;
11095
11096     default:
11097       return FFEINFO_basictypeANY;
11098     }
11099 }
11100
11101 ffeinfoKindtype
11102 ffecom_gfrt_kindtype (ffecomGfrt gfrt)
11103 {
11104   assert (gfrt < FFECOM_gfrt);
11105
11106   switch (ffecom_gfrt_type_[gfrt])
11107     {
11108     case FFECOM_rttypeVOID_:
11109     case FFECOM_rttypeVOIDSTAR_:
11110       return FFEINFO_kindtypeNONE;
11111
11112     case FFECOM_rttypeFTNINT_:
11113       return FFEINFO_kindtypeINTEGER1;
11114
11115     case FFECOM_rttypeINTEGER_:
11116       return FFEINFO_kindtypeINTEGER1;
11117
11118     case FFECOM_rttypeLONGINT_:
11119       return FFEINFO_kindtypeINTEGER4;
11120
11121     case FFECOM_rttypeLOGICAL_:
11122       return FFEINFO_kindtypeLOGICAL1;
11123
11124     case FFECOM_rttypeREAL_F2C_:
11125     case FFECOM_rttypeREAL_GNU_:
11126       return FFEINFO_kindtypeREAL1;
11127
11128     case FFECOM_rttypeCOMPLEX_F2C_:
11129     case FFECOM_rttypeCOMPLEX_GNU_:
11130       return FFEINFO_kindtypeREAL1;
11131
11132     case FFECOM_rttypeDOUBLE_:
11133     case FFECOM_rttypeDOUBLEREAL_:
11134       return FFEINFO_kindtypeREAL2;
11135
11136     case FFECOM_rttypeDBLCMPLX_F2C_:
11137     case FFECOM_rttypeDBLCMPLX_GNU_:
11138       return FFEINFO_kindtypeREAL2;
11139
11140     case FFECOM_rttypeCHARACTER_:
11141       return FFEINFO_kindtypeCHARACTER1;
11142
11143     default:
11144       return FFEINFO_kindtypeANY;
11145     }
11146 }
11147
11148 void
11149 ffecom_init_0 ()
11150 {
11151   tree endlink;
11152   int i;
11153   int j;
11154   tree t;
11155   tree field;
11156   ffetype type;
11157   ffetype base_type;
11158   tree double_ftype_double;
11159   tree float_ftype_float;
11160   tree ldouble_ftype_ldouble;
11161   tree ffecom_tree_ptr_to_fun_type_void;
11162
11163   /* This block of code comes from the now-obsolete cktyps.c.  It checks
11164      whether the compiler environment is buggy in known ways, some of which
11165      would, if not explicitly checked here, result in subtle bugs in g77.  */
11166
11167   if (ffe_is_do_internal_checks ())
11168     {
11169       static const char names[][12]
11170         =
11171       {"bar", "bletch", "foo", "foobar"};
11172       const char *name;
11173       unsigned long ul;
11174       double fl;
11175
11176       name = bsearch ("foo", &names[0], ARRAY_SIZE (names), sizeof (names[0]),
11177                       (int (*)(const void *, const void *)) strcmp);
11178       if (name != &names[0][2])
11179         {
11180           assert ("bsearch doesn't work, #define FFEPROJ_BSEARCH 0 in proj.h"
11181                   == NULL);
11182           abort ();
11183         }
11184
11185       ul = strtoul ("123456789", NULL, 10);
11186       if (ul != 123456789L)
11187         {
11188           assert ("strtoul doesn't have enough range, #define FFEPROJ_STRTOUL 0\
11189  in proj.h" == NULL);
11190           abort ();
11191         }
11192
11193       fl = atof ("56.789");
11194       if ((fl < 56.788) || (fl > 56.79))
11195         {
11196           assert ("atof not type double, fix your #include <stdio.h>"
11197                   == NULL);
11198           abort ();
11199         }
11200     }
11201
11202   ffecom_outer_function_decl_ = NULL_TREE;
11203   current_function_decl = NULL_TREE;
11204   named_labels = NULL_TREE;
11205   current_binding_level = NULL_BINDING_LEVEL;
11206   free_binding_level = NULL_BINDING_LEVEL;
11207   /* Make the binding_level structure for global names.  */
11208   pushlevel (0);
11209   global_binding_level = current_binding_level;
11210   current_binding_level->prep_state = 2;
11211
11212   build_common_tree_nodes (1);
11213
11214   /* Define `int' and `char' first so that dbx will output them first.  */
11215   pushdecl (build_decl (TYPE_DECL, get_identifier ("int"),
11216                         integer_type_node));
11217   /* CHARACTER*1 is unsigned in ICHAR contexts.  */
11218   char_type_node = make_unsigned_type (CHAR_TYPE_SIZE);
11219   pushdecl (build_decl (TYPE_DECL, get_identifier ("char"),
11220                         char_type_node));
11221   pushdecl (build_decl (TYPE_DECL, get_identifier ("long int"),
11222                         long_integer_type_node));
11223   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned int"),
11224                         unsigned_type_node));
11225   pushdecl (build_decl (TYPE_DECL, get_identifier ("long unsigned int"),
11226                         long_unsigned_type_node));
11227   pushdecl (build_decl (TYPE_DECL, get_identifier ("long long int"),
11228                         long_long_integer_type_node));
11229   pushdecl (build_decl (TYPE_DECL, get_identifier ("long long unsigned int"),
11230                         long_long_unsigned_type_node));
11231   pushdecl (build_decl (TYPE_DECL, get_identifier ("short int"),
11232                         short_integer_type_node));
11233   pushdecl (build_decl (TYPE_DECL, get_identifier ("short unsigned int"),
11234                         short_unsigned_type_node));
11235
11236   /* Set the sizetype before we make other types.  This *should* be the
11237      first type we create.  */
11238
11239   set_sizetype
11240     (TREE_TYPE (IDENTIFIER_GLOBAL_VALUE (get_identifier (SIZE_TYPE))));
11241   ffecom_typesize_pointer_
11242     = TREE_INT_CST_LOW (TYPE_SIZE (sizetype)) / BITS_PER_UNIT;
11243
11244   build_common_tree_nodes_2 (0);
11245
11246   /* Define both `signed char' and `unsigned char'.  */
11247   pushdecl (build_decl (TYPE_DECL, get_identifier ("signed char"),
11248                         signed_char_type_node));
11249
11250   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned char"),
11251                         unsigned_char_type_node));
11252
11253   pushdecl (build_decl (TYPE_DECL, get_identifier ("float"),
11254                         float_type_node));
11255   pushdecl (build_decl (TYPE_DECL, get_identifier ("double"),
11256                         double_type_node));
11257   pushdecl (build_decl (TYPE_DECL, get_identifier ("long double"),
11258                         long_double_type_node));
11259
11260   /* For now, override what build_common_tree_nodes has done.  */
11261   complex_integer_type_node = ffecom_make_complex_type_ (integer_type_node);
11262   complex_float_type_node = ffecom_make_complex_type_ (float_type_node);
11263   complex_double_type_node = ffecom_make_complex_type_ (double_type_node);
11264   complex_long_double_type_node
11265     = ffecom_make_complex_type_ (long_double_type_node);
11266
11267   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex int"),
11268                         complex_integer_type_node));
11269   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex float"),
11270                         complex_float_type_node));
11271   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex double"),
11272                         complex_double_type_node));
11273   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex long double"),
11274                         complex_long_double_type_node));
11275
11276   pushdecl (build_decl (TYPE_DECL, get_identifier ("void"),
11277                         void_type_node));
11278   /* We are not going to have real types in C with less than byte alignment,
11279      so we might as well not have any types that claim to have it.  */
11280   TYPE_ALIGN (void_type_node) = BITS_PER_UNIT;
11281   TYPE_USER_ALIGN (void_type_node) = 0;
11282
11283   string_type_node = build_pointer_type (char_type_node);
11284
11285   ffecom_tree_fun_type_void
11286     = build_function_type (void_type_node, NULL_TREE);
11287
11288   ffecom_tree_ptr_to_fun_type_void
11289     = build_pointer_type (ffecom_tree_fun_type_void);
11290
11291   endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE);
11292
11293   float_ftype_float
11294     = build_function_type (float_type_node,
11295                            tree_cons (NULL_TREE, float_type_node, endlink));
11296
11297   double_ftype_double
11298     = build_function_type (double_type_node,
11299                            tree_cons (NULL_TREE, double_type_node, endlink));
11300
11301   ldouble_ftype_ldouble
11302     = build_function_type (long_double_type_node,
11303                            tree_cons (NULL_TREE, long_double_type_node,
11304                                       endlink));
11305
11306   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11307     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11308       {
11309         ffecom_tree_type[i][j] = NULL_TREE;
11310         ffecom_tree_fun_type[i][j] = NULL_TREE;
11311         ffecom_tree_ptr_to_fun_type[i][j] = NULL_TREE;
11312         ffecom_f2c_typecode_[i][j] = -1;
11313       }
11314
11315   /* Set up standard g77 types.  Note that INTEGER and LOGICAL are set
11316      to size FLOAT_TYPE_SIZE because they have to be the same size as
11317      REAL, which also is FLOAT_TYPE_SIZE, according to the standard.
11318      Compiler options and other such stuff that change the ways these
11319      types are set should not affect this particular setup.  */
11320
11321   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1]
11322     = t = make_signed_type (FLOAT_TYPE_SIZE);
11323   pushdecl (build_decl (TYPE_DECL, get_identifier ("integer"),
11324                         t));
11325   type = ffetype_new ();
11326   base_type = type;
11327   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER1,
11328                     type);
11329   ffetype_set_ams (type,
11330                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11331                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11332   ffetype_set_star (base_type,
11333                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11334                     type);
11335   ffetype_set_kind (base_type, 1, type);
11336   ffecom_typesize_integer1_ = ffetype_size (type);
11337   assert (ffetype_size (type) == sizeof (ffetargetInteger1));
11338
11339   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER1]
11340     = t = make_unsigned_type (FLOAT_TYPE_SIZE); /* HOLLERITH means unsigned. */
11341   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned"),
11342                         t));
11343
11344   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER2]
11345     = t = make_signed_type (CHAR_TYPE_SIZE);
11346   pushdecl (build_decl (TYPE_DECL, get_identifier ("byte"),
11347                         t));
11348   type = ffetype_new ();
11349   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER2,
11350                     type);
11351   ffetype_set_ams (type,
11352                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11353                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11354   ffetype_set_star (base_type,
11355                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11356                     type);
11357   ffetype_set_kind (base_type, 3, type);
11358   assert (ffetype_size (type) == sizeof (ffetargetInteger2));
11359
11360   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER2]
11361     = t = make_unsigned_type (CHAR_TYPE_SIZE);
11362   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned byte"),
11363                         t));
11364
11365   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER3]
11366     = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11367   pushdecl (build_decl (TYPE_DECL, get_identifier ("word"),
11368                         t));
11369   type = ffetype_new ();
11370   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER3,
11371                     type);
11372   ffetype_set_ams (type,
11373                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11374                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11375   ffetype_set_star (base_type,
11376                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11377                     type);
11378   ffetype_set_kind (base_type, 6, type);
11379   assert (ffetype_size (type) == sizeof (ffetargetInteger3));
11380
11381   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER3]
11382     = t = make_unsigned_type (CHAR_TYPE_SIZE * 2);
11383   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned word"),
11384                         t));
11385
11386   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER4]
11387     = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11388   pushdecl (build_decl (TYPE_DECL, get_identifier ("integer4"),
11389                         t));
11390   type = ffetype_new ();
11391   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER4,
11392                     type);
11393   ffetype_set_ams (type,
11394                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11395                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11396   ffetype_set_star (base_type,
11397                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11398                     type);
11399   ffetype_set_kind (base_type, 2, type);
11400   assert (ffetype_size (type) == sizeof (ffetargetInteger4));
11401
11402   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER4]
11403     = t = make_unsigned_type (FLOAT_TYPE_SIZE * 2);
11404   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned4"),
11405                         t));
11406
11407 #if 0
11408   if (ffe_is_do_internal_checks ()
11409       && LONG_TYPE_SIZE != FLOAT_TYPE_SIZE
11410       && LONG_TYPE_SIZE != CHAR_TYPE_SIZE
11411       && LONG_TYPE_SIZE != SHORT_TYPE_SIZE
11412       && LONG_TYPE_SIZE != LONG_LONG_TYPE_SIZE)
11413     {
11414       fprintf (stderr, "Sorry, no g77 support for LONG_TYPE_SIZE (%d bits) yet.\n",
11415                LONG_TYPE_SIZE);
11416     }
11417 #endif
11418
11419   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL1]
11420     = t = make_signed_type (FLOAT_TYPE_SIZE);
11421   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical"),
11422                         t));
11423   type = ffetype_new ();
11424   base_type = type;
11425   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL1,
11426                     type);
11427   ffetype_set_ams (type,
11428                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11429                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11430   ffetype_set_star (base_type,
11431                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11432                     type);
11433   ffetype_set_kind (base_type, 1, type);
11434   assert (ffetype_size (type) == sizeof (ffetargetLogical1));
11435
11436   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL2]
11437     = t = make_signed_type (CHAR_TYPE_SIZE);
11438   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical2"),
11439                         t));
11440   type = ffetype_new ();
11441   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL2,
11442                     type);
11443   ffetype_set_ams (type,
11444                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11445                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11446   ffetype_set_star (base_type,
11447                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11448                     type);
11449   ffetype_set_kind (base_type, 3, type);
11450   assert (ffetype_size (type) == sizeof (ffetargetLogical2));
11451
11452   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL3]
11453     = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11454   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical3"),
11455                         t));
11456   type = ffetype_new ();
11457   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL3,
11458                     type);
11459   ffetype_set_ams (type,
11460                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11461                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11462   ffetype_set_star (base_type,
11463                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11464                     type);
11465   ffetype_set_kind (base_type, 6, type);
11466   assert (ffetype_size (type) == sizeof (ffetargetLogical3));
11467
11468   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL4]
11469     = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11470   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical4"),
11471                         t));
11472   type = ffetype_new ();
11473   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL4,
11474                     type);
11475   ffetype_set_ams (type,
11476                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11477                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11478   ffetype_set_star (base_type,
11479                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11480                     type);
11481   ffetype_set_kind (base_type, 2, type);
11482   assert (ffetype_size (type) == sizeof (ffetargetLogical4));
11483
11484   ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11485     = t = make_node (REAL_TYPE);
11486   TYPE_PRECISION (t) = FLOAT_TYPE_SIZE;
11487   pushdecl (build_decl (TYPE_DECL, get_identifier ("real"),
11488                         t));
11489   layout_type (t);
11490   type = ffetype_new ();
11491   base_type = type;
11492   ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL1,
11493                     type);
11494   ffetype_set_ams (type,
11495                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11496                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11497   ffetype_set_star (base_type,
11498                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11499                     type);
11500   ffetype_set_kind (base_type, 1, type);
11501   ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11502     = FFETARGET_f2cTYREAL;
11503   assert (ffetype_size (type) == sizeof (ffetargetReal1));
11504
11505   ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREALDOUBLE]
11506     = t = make_node (REAL_TYPE);
11507   TYPE_PRECISION (t) = FLOAT_TYPE_SIZE * 2;     /* Always twice REAL. */
11508   pushdecl (build_decl (TYPE_DECL, get_identifier ("double precision"),
11509                         t));
11510   layout_type (t);
11511   type = ffetype_new ();
11512   ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE,
11513                     type);
11514   ffetype_set_ams (type,
11515                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11516                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11517   ffetype_set_star (base_type,
11518                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11519                     type);
11520   ffetype_set_kind (base_type, 2, type);
11521   ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]
11522     = FFETARGET_f2cTYDREAL;
11523   assert (ffetype_size (type) == sizeof (ffetargetReal2));
11524
11525   ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11526     = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]);
11527   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex"),
11528                         t));
11529   type = ffetype_new ();
11530   base_type = type;
11531   ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL1,
11532                     type);
11533   ffetype_set_ams (type,
11534                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11535                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11536   ffetype_set_star (base_type,
11537                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11538                     type);
11539   ffetype_set_kind (base_type, 1, type);
11540   ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11541     = FFETARGET_f2cTYCOMPLEX;
11542   assert (ffetype_size (type) == sizeof (ffetargetComplex1));
11543
11544   ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREALDOUBLE]
11545     = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]);
11546   pushdecl (build_decl (TYPE_DECL, get_identifier ("double complex"),
11547                         t));
11548   type = ffetype_new ();
11549   ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREALDOUBLE,
11550                     type);
11551   ffetype_set_ams (type,
11552                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11553                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11554   ffetype_set_star (base_type,
11555                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11556                     type);
11557   ffetype_set_kind (base_type, 2,
11558                     type);
11559   ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL2]
11560     = FFETARGET_f2cTYDCOMPLEX;
11561   assert (ffetype_size (type) == sizeof (ffetargetComplex2));
11562
11563   /* Make function and ptr-to-function types for non-CHARACTER types. */
11564
11565   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11566     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11567       {
11568         if ((t = ffecom_tree_type[i][j]) != NULL_TREE)
11569           {
11570             if (i == FFEINFO_basictypeINTEGER)
11571               {
11572                 /* Figure out the smallest INTEGER type that can hold
11573                    a pointer on this machine. */
11574                 if (GET_MODE_SIZE (TYPE_MODE (t))
11575                     >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
11576                   {
11577                     if ((ffecom_pointer_kind_ == FFEINFO_kindtypeNONE)
11578                         || (GET_MODE_SIZE (TYPE_MODE (ffecom_tree_type[i][ffecom_pointer_kind_]))
11579                             > GET_MODE_SIZE (TYPE_MODE (t))))
11580                       ffecom_pointer_kind_ = j;
11581                   }
11582               }
11583             else if (i == FFEINFO_basictypeCOMPLEX)
11584               t = void_type_node;
11585             /* For f2c compatibility, REAL functions are really
11586                implemented as DOUBLE PRECISION.  */
11587             else if ((i == FFEINFO_basictypeREAL)
11588                      && (j == FFEINFO_kindtypeREAL1))
11589               t = ffecom_tree_type
11590                 [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2];
11591
11592             t = ffecom_tree_fun_type[i][j] = build_function_type (t,
11593                                                                   NULL_TREE);
11594             ffecom_tree_ptr_to_fun_type[i][j] = build_pointer_type (t);
11595           }
11596       }
11597
11598   /* Set up pointer types.  */
11599
11600   if (ffecom_pointer_kind_ == FFEINFO_basictypeNONE)
11601     fatal_error ("no INTEGER type can hold a pointer on this configuration");
11602   else if (0 && ffe_is_do_internal_checks ())
11603     fprintf (stderr, "Pointer type kt=%d\n", ffecom_pointer_kind_);
11604   ffetype_set_kind (ffeinfo_type (FFEINFO_basictypeINTEGER,
11605                                   FFEINFO_kindtypeINTEGERDEFAULT),
11606                     7,
11607                     ffeinfo_type (FFEINFO_basictypeINTEGER,
11608                                   ffecom_pointer_kind_));
11609
11610   if (ffe_is_ugly_assign ())
11611     ffecom_label_kind_ = ffecom_pointer_kind_;  /* Require ASSIGN etc to this. */
11612   else
11613     ffecom_label_kind_ = FFEINFO_kindtypeINTEGERDEFAULT;
11614   if (0 && ffe_is_do_internal_checks ())
11615     fprintf (stderr, "Label type kt=%d\n", ffecom_label_kind_);
11616
11617   ffecom_integer_type_node
11618     = ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1];
11619   ffecom_integer_zero_node = convert (ffecom_integer_type_node,
11620                                       integer_zero_node);
11621   ffecom_integer_one_node = convert (ffecom_integer_type_node,
11622                                      integer_one_node);
11623
11624   /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional.
11625      Turns out that by TYLONG, runtime/libI77/lio.h really means
11626      "whatever size an ftnint is".  For consistency and sanity,
11627      com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen
11628      all are INTEGER, which we also make out of whatever back-end
11629      integer type is FLOAT_TYPE_SIZE bits wide.  This change, from
11630      LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to
11631      accommodate machines like the Alpha.  Note that this suggests
11632      f2c and libf2c are missing a distinction perhaps needed on
11633      some machines between "int" and "long int".  -- burley 0.5.5 950215 */
11634
11635   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, FLOAT_TYPE_SIZE,
11636                             FFETARGET_f2cTYLONG);
11637   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, SHORT_TYPE_SIZE,
11638                             FFETARGET_f2cTYSHORT);
11639   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, CHAR_TYPE_SIZE,
11640                             FFETARGET_f2cTYINT1);
11641   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, LONG_LONG_TYPE_SIZE,
11642                             FFETARGET_f2cTYQUAD);
11643   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, FLOAT_TYPE_SIZE,
11644                             FFETARGET_f2cTYLOGICAL);
11645   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, SHORT_TYPE_SIZE,
11646                             FFETARGET_f2cTYLOGICAL2);
11647   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, CHAR_TYPE_SIZE,
11648                             FFETARGET_f2cTYLOGICAL1);
11649   /* ~~~Not really such a type in libf2c, e.g. I/O support?  */
11650   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, LONG_LONG_TYPE_SIZE,
11651                             FFETARGET_f2cTYQUAD);
11652
11653   /* CHARACTER stuff is all special-cased, so it is not handled in the above
11654      loop.  CHARACTER items are built as arrays of unsigned char.  */
11655
11656   ffecom_tree_type[FFEINFO_basictypeCHARACTER]
11657     [FFEINFO_kindtypeCHARACTER1] = t = char_type_node;
11658   type = ffetype_new ();
11659   base_type = type;
11660   ffeinfo_set_type (FFEINFO_basictypeCHARACTER,
11661                     FFEINFO_kindtypeCHARACTER1,
11662                     type);
11663   ffetype_set_ams (type,
11664                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11665                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11666   ffetype_set_kind (base_type, 1, type);
11667   assert (ffetype_size (type)
11668           == sizeof (((ffetargetCharacter1) { 0, NULL }).text[0]));
11669
11670   ffecom_tree_fun_type[FFEINFO_basictypeCHARACTER]
11671     [FFEINFO_kindtypeCHARACTER1] = ffecom_tree_fun_type_void;
11672   ffecom_tree_ptr_to_fun_type[FFEINFO_basictypeCHARACTER]
11673     [FFEINFO_kindtypeCHARACTER1]
11674     = ffecom_tree_ptr_to_fun_type_void;
11675   ffecom_f2c_typecode_[FFEINFO_basictypeCHARACTER][FFEINFO_kindtypeCHARACTER1]
11676     = FFETARGET_f2cTYCHAR;
11677
11678   ffecom_f2c_typecode_[FFEINFO_basictypeANY][FFEINFO_kindtypeANY]
11679     = 0;
11680
11681   /* Make multi-return-value type and fields. */
11682
11683   ffecom_multi_type_node_ = make_node (UNION_TYPE);
11684
11685   field = NULL_TREE;
11686
11687   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11688     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11689       {
11690         char name[30];
11691
11692         if (ffecom_tree_type[i][j] == NULL_TREE)
11693           continue;             /* Not supported. */
11694         sprintf (&name[0], "bt_%s_kt_%s",
11695                  ffeinfo_basictype_string ((ffeinfoBasictype) i),
11696                  ffeinfo_kindtype_string ((ffeinfoKindtype) j));
11697         ffecom_multi_fields_[i][j] = build_decl (FIELD_DECL,
11698                                                  get_identifier (name),
11699                                                  ffecom_tree_type[i][j]);
11700         DECL_CONTEXT (ffecom_multi_fields_[i][j])
11701           = ffecom_multi_type_node_;
11702         DECL_ALIGN (ffecom_multi_fields_[i][j]) = 0;
11703         DECL_USER_ALIGN (ffecom_multi_fields_[i][j]) = 0;
11704         TREE_CHAIN (ffecom_multi_fields_[i][j]) = field;
11705         field = ffecom_multi_fields_[i][j];
11706       }
11707
11708   TYPE_FIELDS (ffecom_multi_type_node_) = field;
11709   layout_type (ffecom_multi_type_node_);
11710
11711   /* Subroutines usually return integer because they might have alternate
11712      returns. */
11713
11714   ffecom_tree_subr_type
11715     = build_function_type (integer_type_node, NULL_TREE);
11716   ffecom_tree_ptr_to_subr_type
11717     = build_pointer_type (ffecom_tree_subr_type);
11718   ffecom_tree_blockdata_type
11719     = build_function_type (void_type_node, NULL_TREE);
11720
11721   builtin_function ("__builtin_sqrtf", float_ftype_float,
11722                     BUILT_IN_SQRTF, BUILT_IN_NORMAL, "sqrtf");
11723   builtin_function ("__builtin_sqrt", double_ftype_double,
11724                     BUILT_IN_SQRT, BUILT_IN_NORMAL, "sqrt");
11725   builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble,
11726                     BUILT_IN_SQRTL, BUILT_IN_NORMAL, "sqrtl");
11727   builtin_function ("__builtin_sinf", float_ftype_float,
11728                     BUILT_IN_SINF, BUILT_IN_NORMAL, "sinf");
11729   builtin_function ("__builtin_sin", double_ftype_double,
11730                     BUILT_IN_SIN, BUILT_IN_NORMAL, "sin");
11731   builtin_function ("__builtin_sinl", ldouble_ftype_ldouble,
11732                     BUILT_IN_SINL, BUILT_IN_NORMAL, "sinl");
11733   builtin_function ("__builtin_cosf", float_ftype_float,
11734                     BUILT_IN_COSF, BUILT_IN_NORMAL, "cosf");
11735   builtin_function ("__builtin_cos", double_ftype_double,
11736                     BUILT_IN_COS, BUILT_IN_NORMAL, "cos");
11737   builtin_function ("__builtin_cosl", ldouble_ftype_ldouble,
11738                     BUILT_IN_COSL, BUILT_IN_NORMAL, "cosl");
11739
11740   pedantic_lvalues = FALSE;
11741
11742   ffecom_f2c_make_type_ (&ffecom_f2c_integer_type_node,
11743                          FFECOM_f2cINTEGER,
11744                          "integer");
11745   ffecom_f2c_make_type_ (&ffecom_f2c_address_type_node,
11746                          FFECOM_f2cADDRESS,
11747                          "address");
11748   ffecom_f2c_make_type_ (&ffecom_f2c_real_type_node,
11749                          FFECOM_f2cREAL,
11750                          "real");
11751   ffecom_f2c_make_type_ (&ffecom_f2c_doublereal_type_node,
11752                          FFECOM_f2cDOUBLEREAL,
11753                          "doublereal");
11754   ffecom_f2c_make_type_ (&ffecom_f2c_complex_type_node,
11755                          FFECOM_f2cCOMPLEX,
11756                          "complex");
11757   ffecom_f2c_make_type_ (&ffecom_f2c_doublecomplex_type_node,
11758                          FFECOM_f2cDOUBLECOMPLEX,
11759                          "doublecomplex");
11760   ffecom_f2c_make_type_ (&ffecom_f2c_longint_type_node,
11761                          FFECOM_f2cLONGINT,
11762                          "longint");
11763   ffecom_f2c_make_type_ (&ffecom_f2c_logical_type_node,
11764                          FFECOM_f2cLOGICAL,
11765                          "logical");
11766   ffecom_f2c_make_type_ (&ffecom_f2c_flag_type_node,
11767                          FFECOM_f2cFLAG,
11768                          "flag");
11769   ffecom_f2c_make_type_ (&ffecom_f2c_ftnlen_type_node,
11770                          FFECOM_f2cFTNLEN,
11771                          "ftnlen");
11772   ffecom_f2c_make_type_ (&ffecom_f2c_ftnint_type_node,
11773                          FFECOM_f2cFTNINT,
11774                          "ftnint");
11775
11776   ffecom_f2c_ftnlen_zero_node
11777     = convert (ffecom_f2c_ftnlen_type_node, integer_zero_node);
11778
11779   ffecom_f2c_ftnlen_one_node
11780     = convert (ffecom_f2c_ftnlen_type_node, integer_one_node);
11781
11782   ffecom_f2c_ftnlen_two_node = build_int_2 (2, 0);
11783   TREE_TYPE (ffecom_f2c_ftnlen_two_node) = ffecom_integer_type_node;
11784
11785   ffecom_f2c_ptr_to_ftnlen_type_node
11786     = build_pointer_type (ffecom_f2c_ftnlen_type_node);
11787
11788   ffecom_f2c_ptr_to_ftnint_type_node
11789     = build_pointer_type (ffecom_f2c_ftnint_type_node);
11790
11791   ffecom_f2c_ptr_to_integer_type_node
11792     = build_pointer_type (ffecom_f2c_integer_type_node);
11793
11794   ffecom_f2c_ptr_to_real_type_node
11795     = build_pointer_type (ffecom_f2c_real_type_node);
11796
11797   ffecom_float_zero_ = build_real (float_type_node, dconst0);
11798   ffecom_double_zero_ = build_real (double_type_node, dconst0);
11799   {
11800     REAL_VALUE_TYPE point_5;
11801
11802     REAL_ARITHMETIC (point_5, RDIV_EXPR, dconst1, dconst2);
11803     ffecom_float_half_ = build_real (float_type_node, point_5);
11804     ffecom_double_half_ = build_real (double_type_node, point_5);
11805   }
11806
11807   /* Do "extern int xargc;".  */
11808
11809   ffecom_tree_xargc_ = build_decl (VAR_DECL,
11810                                    get_identifier ("f__xargc"),
11811                                    integer_type_node);
11812   DECL_EXTERNAL (ffecom_tree_xargc_) = 1;
11813   TREE_STATIC (ffecom_tree_xargc_) = 1;
11814   TREE_PUBLIC (ffecom_tree_xargc_) = 1;
11815   ffecom_tree_xargc_ = start_decl (ffecom_tree_xargc_, FALSE);
11816   finish_decl (ffecom_tree_xargc_, NULL_TREE, FALSE);
11817
11818 #if 0   /* This is being fixed, and seems to be working now. */
11819   if ((FLOAT_TYPE_SIZE != 32)
11820       || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))) != 32))
11821     {
11822       warning ("configuration: REAL, INTEGER, and LOGICAL are %d bits wide,",
11823                (int) FLOAT_TYPE_SIZE);
11824       warning ("and pointers are %d bits wide, but g77 doesn't yet work",
11825           (int) TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))));
11826       warning ("properly unless they all are 32 bits wide");
11827       warning ("Please keep this in mind before you report bugs.");
11828     }
11829 #endif
11830
11831 #if 0   /* Code in ste.c that would crash has been commented out. */
11832   if (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)
11833       < TYPE_PRECISION (string_type_node))
11834     /* I/O will probably crash.  */
11835     warning ("configuration: char * holds %d bits, but ftnlen only %d",
11836              TYPE_PRECISION (string_type_node),
11837              TYPE_PRECISION (ffecom_f2c_ftnlen_type_node));
11838 #endif
11839
11840 #if 0   /* ASSIGN-related stuff has been changed to accommodate this. */
11841   if (TYPE_PRECISION (ffecom_integer_type_node)
11842       < TYPE_PRECISION (string_type_node))
11843     /* ASSIGN 10 TO I will crash.  */
11844     warning ("configuration: char * holds %d bits, but INTEGER only %d --\n\
11845  ASSIGN statement might fail",
11846              TYPE_PRECISION (string_type_node),
11847              TYPE_PRECISION (ffecom_integer_type_node));
11848 #endif
11849 }
11850
11851 /* ffecom_init_2 -- Initialize
11852
11853    ffecom_init_2();  */
11854
11855 void
11856 ffecom_init_2 ()
11857 {
11858   assert (ffecom_outer_function_decl_ == NULL_TREE);
11859   assert (current_function_decl == NULL_TREE);
11860   assert (ffecom_which_entrypoint_decl_ == NULL_TREE);
11861
11862   ffecom_master_arglist_ = NULL;
11863   ++ffecom_num_fns_;
11864   ffecom_primary_entry_ = NULL;
11865   ffecom_is_altreturning_ = FALSE;
11866   ffecom_func_result_ = NULL_TREE;
11867   ffecom_multi_retval_ = NULL_TREE;
11868 }
11869
11870 /* ffecom_list_expr -- Transform list of exprs into gcc tree
11871
11872    tree t;
11873    ffebld expr;  // FFE opITEM list.
11874    tree = ffecom_list_expr(expr);
11875
11876    List of actual args is transformed into corresponding gcc backend list.  */
11877
11878 tree
11879 ffecom_list_expr (ffebld expr)
11880 {
11881   tree list;
11882   tree *plist = &list;
11883   tree trail = NULL_TREE;       /* Append char length args here. */
11884   tree *ptrail = &trail;
11885   tree length;
11886
11887   while (expr != NULL)
11888     {
11889       tree texpr = ffecom_arg_expr (ffebld_head (expr), &length);
11890
11891       if (texpr == error_mark_node)
11892         return error_mark_node;
11893
11894       *plist = build_tree_list (NULL_TREE, texpr);
11895       plist = &TREE_CHAIN (*plist);
11896       expr = ffebld_trail (expr);
11897       if (length != NULL_TREE)
11898         {
11899           *ptrail = build_tree_list (NULL_TREE, length);
11900           ptrail = &TREE_CHAIN (*ptrail);
11901         }
11902     }
11903
11904   *plist = trail;
11905
11906   return list;
11907 }
11908
11909 /* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree
11910
11911    tree t;
11912    ffebld expr;  // FFE opITEM list.
11913    tree = ffecom_list_ptr_to_expr(expr);
11914
11915    List of actual args is transformed into corresponding gcc backend list for
11916    use in calling an external procedure (vs. a statement function).  */
11917
11918 tree
11919 ffecom_list_ptr_to_expr (ffebld expr)
11920 {
11921   tree list;
11922   tree *plist = &list;
11923   tree trail = NULL_TREE;       /* Append char length args here. */
11924   tree *ptrail = &trail;
11925   tree length;
11926
11927   while (expr != NULL)
11928     {
11929       tree texpr = ffecom_arg_ptr_to_expr (ffebld_head (expr), &length);
11930
11931       if (texpr == error_mark_node)
11932         return error_mark_node;
11933
11934       *plist = build_tree_list (NULL_TREE, texpr);
11935       plist = &TREE_CHAIN (*plist);
11936       expr = ffebld_trail (expr);
11937       if (length != NULL_TREE)
11938         {
11939           *ptrail = build_tree_list (NULL_TREE, length);
11940           ptrail = &TREE_CHAIN (*ptrail);
11941         }
11942     }
11943
11944   *plist = trail;
11945
11946   return list;
11947 }
11948
11949 /* Obtain gcc's LABEL_DECL tree for label.  */
11950
11951 tree
11952 ffecom_lookup_label (ffelab label)
11953 {
11954   tree glabel;
11955
11956   if (ffelab_hook (label) == NULL_TREE)
11957     {
11958       char labelname[16];
11959
11960       switch (ffelab_type (label))
11961         {
11962         case FFELAB_typeLOOPEND:
11963         case FFELAB_typeNOTLOOP:
11964         case FFELAB_typeENDIF:
11965           sprintf (labelname, "%" ffelabValue_f "u", ffelab_value (label));
11966           glabel = build_decl (LABEL_DECL, get_identifier (labelname),
11967                                void_type_node);
11968           DECL_CONTEXT (glabel) = current_function_decl;
11969           DECL_MODE (glabel) = VOIDmode;
11970           break;
11971
11972         case FFELAB_typeFORMAT:
11973           glabel = build_decl (VAR_DECL,
11974                                ffecom_get_invented_identifier
11975                                ("__g77_format_%d", (int) ffelab_value (label)),
11976                                build_type_variant (build_array_type
11977                                                    (char_type_node,
11978                                                     NULL_TREE),
11979                                                    1, 0));
11980           TREE_CONSTANT (glabel) = 1;
11981           TREE_STATIC (glabel) = 1;
11982           DECL_CONTEXT (glabel) = current_function_decl;
11983           DECL_INITIAL (glabel) = NULL;
11984           make_decl_rtl (glabel, NULL);
11985           expand_decl (glabel);
11986
11987           ffecom_save_tree_forever (glabel);
11988
11989           break;
11990
11991         case FFELAB_typeANY:
11992           glabel = error_mark_node;
11993           break;
11994
11995         default:
11996           assert ("bad label type" == NULL);
11997           glabel = NULL;
11998           break;
11999         }
12000       ffelab_set_hook (label, glabel);
12001     }
12002   else
12003     {
12004       glabel = ffelab_hook (label);
12005     }
12006
12007   return glabel;
12008 }
12009
12010 /* Stabilizes the arguments.  Don't use this if the lhs and rhs come from
12011    a single source specification (as in the fourth argument of MVBITS).
12012    If the type is NULL_TREE, the type of lhs is used to make the type of
12013    the MODIFY_EXPR.  */
12014
12015 tree
12016 ffecom_modify (tree newtype, tree lhs,
12017                tree rhs)
12018 {
12019   if (lhs == error_mark_node || rhs == error_mark_node)
12020     return error_mark_node;
12021
12022   if (newtype == NULL_TREE)
12023     newtype = TREE_TYPE (lhs);
12024
12025   if (TREE_SIDE_EFFECTS (lhs))
12026     lhs = stabilize_reference (lhs);
12027
12028   return ffecom_2s (MODIFY_EXPR, newtype, lhs, rhs);
12029 }
12030
12031 /* Register source file name.  */
12032
12033 void
12034 ffecom_file (const char *name)
12035 {
12036   ffecom_file_ (name);
12037 }
12038
12039 /* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed
12040
12041    ffestorag st;
12042    ffecom_notify_init_storage(st);
12043
12044    Gets called when all possible units in an aggregate storage area (a LOCAL
12045    with equivalences or a COMMON) have been initialized.  The initialization
12046    info either is in ffestorag_init or, if that is NULL,
12047    ffestorag_accretion:
12048
12049    ffestorag_init may contain an opCONTER or opARRTER.  opCONTER may occur
12050    even for an array if the array is one element in length!
12051
12052    ffestorag_accretion will contain an opACCTER.  It is much like an
12053    opARRTER except it has an ffebit object in it instead of just a size.
12054    The back end can use the info in the ffebit object, if it wants, to
12055    reduce the amount of actual initialization, but in any case it should
12056    kill the ffebit object when done.  Also, set accretion to NULL but
12057    init to a non-NULL value.
12058
12059    After performing initialization, DO NOT set init to NULL, because that'll
12060    tell the front end it is ok for more initialization to happen.  Instead,
12061    set init to an opANY expression or some such thing that you can use to
12062    tell that you've already initialized the object.
12063
12064    27-Oct-91  JCB  1.1
12065       Support two-pass FFE.  */
12066
12067 void
12068 ffecom_notify_init_storage (ffestorag st)
12069 {
12070   ffebld init;                  /* The initialization expression. */
12071
12072   if (ffestorag_init (st) == NULL)
12073     {
12074       init = ffestorag_accretion (st);
12075       assert (init != NULL);
12076       ffestorag_set_accretion (st, NULL);
12077       ffestorag_set_accretes (st, 0);
12078       ffestorag_set_init (st, init);
12079     }
12080 }
12081
12082 /* ffecom_notify_init_symbol -- A symbol is now fully init'ed
12083
12084    ffesymbol s;
12085    ffecom_notify_init_symbol(s);
12086
12087    Gets called when all possible units in a symbol (not placed in COMMON
12088    or involved in EQUIVALENCE, unless it as yet has no ffestorag object)
12089    have been initialized.  The initialization info either is in
12090    ffesymbol_init or, if that is NULL, ffesymbol_accretion:
12091
12092    ffesymbol_init may contain an opCONTER or opARRTER.  opCONTER may occur
12093    even for an array if the array is one element in length!
12094
12095    ffesymbol_accretion will contain an opACCTER.  It is much like an
12096    opARRTER except it has an ffebit object in it instead of just a size.
12097    The back end can use the info in the ffebit object, if it wants, to
12098    reduce the amount of actual initialization, but in any case it should
12099    kill the ffebit object when done.  Also, set accretion to NULL but
12100    init to a non-NULL value.
12101
12102    After performing initialization, DO NOT set init to NULL, because that'll
12103    tell the front end it is ok for more initialization to happen.  Instead,
12104    set init to an opANY expression or some such thing that you can use to
12105    tell that you've already initialized the object.
12106
12107    27-Oct-91  JCB  1.1
12108       Support two-pass FFE.  */
12109
12110 void
12111 ffecom_notify_init_symbol (ffesymbol s)
12112 {
12113   ffebld init;                  /* The initialization expression. */
12114
12115   if (ffesymbol_storage (s) == NULL)
12116     return;                     /* Do nothing until COMMON/EQUIVALENCE
12117                                    possibilities checked. */
12118
12119   if ((ffesymbol_init (s) == NULL)
12120       && ((init = ffesymbol_accretion (s)) != NULL))
12121     {
12122       ffesymbol_set_accretion (s, NULL);
12123       ffesymbol_set_accretes (s, 0);
12124       ffesymbol_set_init (s, init);
12125     }
12126 }
12127
12128 /* ffecom_notify_primary_entry -- Learn which is the primary entry point
12129
12130    ffesymbol s;
12131    ffecom_notify_primary_entry(s);
12132
12133    Gets called when implicit or explicit PROGRAM statement seen or when
12134    FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary
12135    global symbol that serves as the entry point.  */
12136
12137 void
12138 ffecom_notify_primary_entry (ffesymbol s)
12139 {
12140   ffecom_primary_entry_ = s;
12141   ffecom_primary_entry_kind_ = ffesymbol_kind (s);
12142
12143   if ((ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
12144       || (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE))
12145     ffecom_primary_entry_is_proc_ = TRUE;
12146   else
12147     ffecom_primary_entry_is_proc_ = FALSE;
12148
12149   if (!ffe_is_silent ())
12150     {
12151       if (ffecom_primary_entry_kind_ == FFEINFO_kindPROGRAM)
12152         fprintf (stderr, "%s:\n", ffesymbol_text (s));
12153       else
12154         fprintf (stderr, "  %s:\n", ffesymbol_text (s));
12155     }
12156
12157   if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
12158     {
12159       ffebld list;
12160       ffebld arg;
12161
12162       for (list = ffesymbol_dummyargs (s);
12163            list != NULL;
12164            list = ffebld_trail (list))
12165         {
12166           arg = ffebld_head (list);
12167           if (ffebld_op (arg) == FFEBLD_opSTAR)
12168             {
12169               ffecom_is_altreturning_ = TRUE;
12170               break;
12171             }
12172         }
12173     }
12174 }
12175
12176 FILE *
12177 ffecom_open_include (char *name, ffewhereLine l, ffewhereColumn c)
12178 {
12179   return ffecom_open_include_ (name, l, c);
12180 }
12181
12182 /* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front
12183
12184    tree t;
12185    ffebld expr;  // FFE expression.
12186    tree = ffecom_ptr_to_expr(expr);
12187
12188    Like ffecom_expr, but sticks address-of in front of most things.  */
12189
12190 tree
12191 ffecom_ptr_to_expr (ffebld expr)
12192 {
12193   tree item;
12194   ffeinfoBasictype bt;
12195   ffeinfoKindtype kt;
12196   ffesymbol s;
12197
12198   assert (expr != NULL);
12199
12200   switch (ffebld_op (expr))
12201     {
12202     case FFEBLD_opSYMTER:
12203       s = ffebld_symter (expr);
12204       if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
12205         {
12206           ffecomGfrt ix;
12207
12208           ix = ffeintrin_gfrt_indirect (ffebld_symter_implementation (expr));
12209           assert (ix != FFECOM_gfrt);
12210           if ((item = ffecom_gfrt_[ix]) == NULL_TREE)
12211             {
12212               ffecom_make_gfrt_ (ix);
12213               item = ffecom_gfrt_[ix];
12214             }
12215         }
12216       else
12217         {
12218           item = ffesymbol_hook (s).decl_tree;
12219           if (item == NULL_TREE)
12220             {
12221               s = ffecom_sym_transform_ (s);
12222               item = ffesymbol_hook (s).decl_tree;
12223             }
12224         }
12225       assert (item != NULL);
12226       if (item == error_mark_node)
12227         return item;
12228       if (!ffesymbol_hook (s).addr)
12229         item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12230                          item);
12231       return item;
12232
12233     case FFEBLD_opARRAYREF:
12234       return ffecom_arrayref_ (NULL_TREE, expr, 1);
12235
12236     case FFEBLD_opCONTER:
12237
12238       bt = ffeinfo_basictype (ffebld_info (expr));
12239       kt = ffeinfo_kindtype (ffebld_info (expr));
12240
12241       item = ffecom_constantunion (&ffebld_constant_union
12242                                    (ffebld_conter (expr)), bt, kt,
12243                                    ffecom_tree_type[bt][kt]);
12244       if (item == error_mark_node)
12245         return error_mark_node;
12246       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12247                        item);
12248       return item;
12249
12250     case FFEBLD_opANY:
12251       return error_mark_node;
12252
12253     default:
12254       bt = ffeinfo_basictype (ffebld_info (expr));
12255       kt = ffeinfo_kindtype (ffebld_info (expr));
12256
12257       item = ffecom_expr (expr);
12258       if (item == error_mark_node)
12259         return error_mark_node;
12260
12261       /* The back end currently optimizes a bit too zealously for us, in that
12262          we fail JCB001 if the following block of code is omitted.  It checks
12263          to see if the transformed expression is a symbol or array reference,
12264          and encloses it in a SAVE_EXPR if that is the case.  */
12265
12266       STRIP_NOPS (item);
12267       if ((TREE_CODE (item) == VAR_DECL)
12268           || (TREE_CODE (item) == PARM_DECL)
12269           || (TREE_CODE (item) == RESULT_DECL)
12270           || (TREE_CODE (item) == INDIRECT_REF)
12271           || (TREE_CODE (item) == ARRAY_REF)
12272           || (TREE_CODE (item) == COMPONENT_REF)
12273 #ifdef OFFSET_REF
12274           || (TREE_CODE (item) == OFFSET_REF)
12275 #endif
12276           || (TREE_CODE (item) == BUFFER_REF)
12277           || (TREE_CODE (item) == REALPART_EXPR)
12278           || (TREE_CODE (item) == IMAGPART_EXPR))
12279         {
12280           item = ffecom_save_tree (item);
12281         }
12282
12283       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12284                        item);
12285       return item;
12286     }
12287
12288   assert ("fall-through error" == NULL);
12289   return error_mark_node;
12290 }
12291
12292 /* Obtain a temp var with given data type.
12293
12294    size is FFETARGET_charactersizeNONE for a non-CHARACTER type
12295    or >= 0 for a CHARACTER type.
12296
12297    elements is -1 for a scalar or > 0 for an array of type.  */
12298
12299 tree
12300 ffecom_make_tempvar (const char *commentary, tree type,
12301                      ffetargetCharacterSize size, int elements)
12302 {
12303   tree t;
12304   static int mynumber;
12305
12306   assert (current_binding_level->prep_state < 2);
12307
12308   if (type == error_mark_node)
12309     return error_mark_node;
12310
12311   if (size != FFETARGET_charactersizeNONE)
12312     type = build_array_type (type,
12313                              build_range_type (ffecom_f2c_ftnlen_type_node,
12314                                                ffecom_f2c_ftnlen_one_node,
12315                                                build_int_2 (size, 0)));
12316   if (elements != -1)
12317     type = build_array_type (type,
12318                              build_range_type (integer_type_node,
12319                                                integer_zero_node,
12320                                                build_int_2 (elements - 1,
12321                                                             0)));
12322   t = build_decl (VAR_DECL,
12323                   ffecom_get_invented_identifier ("__g77_%s_%d",
12324                                                   commentary,
12325                                                   mynumber++),
12326                   type);
12327
12328   t = start_decl (t, FALSE);
12329   finish_decl (t, NULL_TREE, FALSE);
12330
12331   return t;
12332 }
12333
12334 /* Prepare argument pointer to expression.
12335
12336    Like ffecom_prepare_expr, except for expressions to be evaluated
12337    via ffecom_arg_ptr_to_expr.  */
12338
12339 void
12340 ffecom_prepare_arg_ptr_to_expr (ffebld expr)
12341 {
12342   /* ~~For now, it seems to be the same thing.  */
12343   ffecom_prepare_expr (expr);
12344   return;
12345 }
12346
12347 /* End of preparations.  */
12348
12349 bool
12350 ffecom_prepare_end (void)
12351 {
12352   int prep_state = current_binding_level->prep_state;
12353
12354   assert (prep_state < 2);
12355   current_binding_level->prep_state = 2;
12356
12357   return (prep_state == 1) ? TRUE : FALSE;
12358 }
12359
12360 /* Prepare expression.
12361
12362    This is called before any code is generated for the current block.
12363    It scans the expression, declares any temporaries that might be needed
12364    during evaluation of the expression, and stores those temporaries in
12365    the appropriate "hook" fields of the expression.  `dest', if not NULL,
12366    specifies the destination that ffecom_expr_ will see, in case that
12367    helps avoid generating unused temporaries.
12368
12369    ~~Improve to avoid allocating unused temporaries by taking `dest'
12370    into account vis-a-vis aliasing requirements of complex/character
12371    functions.  */
12372
12373 void
12374 ffecom_prepare_expr_ (ffebld expr, ffebld dest UNUSED)
12375 {
12376   ffeinfoBasictype bt;
12377   ffeinfoKindtype kt;
12378   ffetargetCharacterSize sz;
12379   tree tempvar = NULL_TREE;
12380
12381   assert (current_binding_level->prep_state < 2);
12382
12383   if (! expr)
12384     return;
12385
12386   bt = ffeinfo_basictype (ffebld_info (expr));
12387   kt = ffeinfo_kindtype (ffebld_info (expr));
12388   sz = ffeinfo_size (ffebld_info (expr));
12389
12390   /* Generate whatever temporaries are needed to represent the result
12391      of the expression.  */
12392
12393   if (bt == FFEINFO_basictypeCHARACTER)
12394     {
12395       while (ffebld_op (expr) == FFEBLD_opPAREN)
12396         expr = ffebld_left (expr);
12397     }
12398
12399   switch (ffebld_op (expr))
12400     {
12401     default:
12402       /* Don't make temps for SYMTER, CONTER, etc.  */
12403       if (ffebld_arity (expr) == 0)
12404         break;
12405
12406       switch (bt)
12407         {
12408         case FFEINFO_basictypeCOMPLEX:
12409           if (ffebld_op (expr) == FFEBLD_opFUNCREF)
12410             {
12411               ffesymbol s;
12412
12413               if (ffebld_op (ffebld_left (expr)) != FFEBLD_opSYMTER)
12414                 break;
12415
12416               s = ffebld_symter (ffebld_left (expr));
12417               if (ffesymbol_where (s) == FFEINFO_whereCONSTANT
12418                   || (ffesymbol_where (s) != FFEINFO_whereINTRINSIC
12419                       && ! ffesymbol_is_f2c (s))
12420                   || (ffesymbol_where (s) == FFEINFO_whereINTRINSIC
12421                       && ! ffe_is_f2c_library ()))
12422                 break;
12423             }
12424           else if (ffebld_op (expr) == FFEBLD_opPOWER)
12425             {
12426               /* Requires special treatment.  There's no POW_CC function
12427                  in libg2c, so POW_ZZ is used, which means we always
12428                  need a double-complex temp, not a single-complex.  */
12429               kt = FFEINFO_kindtypeREAL2;
12430             }
12431           else if (ffebld_op (expr) != FFEBLD_opDIVIDE)
12432             /* The other ops don't need temps for complex operands.  */
12433             break;
12434
12435           /* ~~~Avoid making temps for some intrinsics, such as AIMAG(C),
12436              REAL(C).  See 19990325-0.f, routine `check', for cases.  */
12437           tempvar = ffecom_make_tempvar ("complex",
12438                                          ffecom_tree_type
12439                                          [FFEINFO_basictypeCOMPLEX][kt],
12440                                          FFETARGET_charactersizeNONE,
12441                                          -1);
12442           break;
12443
12444         case FFEINFO_basictypeCHARACTER:
12445           if (ffebld_op (expr) != FFEBLD_opFUNCREF)
12446             break;
12447
12448           if (sz == FFETARGET_charactersizeNONE)
12449             /* ~~Kludge alert!  This should someday be fixed. */
12450             sz = 24;
12451
12452           tempvar = ffecom_make_tempvar ("char", char_type_node, sz, -1);
12453           break;
12454
12455         default:
12456           break;
12457         }
12458       break;
12459
12460 #ifdef HAHA
12461     case FFEBLD_opPOWER:
12462       {
12463         tree rtype, ltype;
12464         tree rtmp, ltmp, result;
12465
12466         ltype = ffecom_type_expr (ffebld_left (expr));
12467         rtype = ffecom_type_expr (ffebld_right (expr));
12468
12469         rtmp = ffecom_make_tempvar (rtype, FFETARGET_charactersizeNONE, -1);
12470         ltmp = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
12471         result = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
12472
12473         tempvar = make_tree_vec (3);
12474         TREE_VEC_ELT (tempvar, 0) = rtmp;
12475         TREE_VEC_ELT (tempvar, 1) = ltmp;
12476         TREE_VEC_ELT (tempvar, 2) = result;
12477       }
12478       break;
12479 #endif  /* HAHA */
12480
12481     case FFEBLD_opCONCATENATE:
12482       {
12483         /* This gets special handling, because only one set of temps
12484            is needed for a tree of these -- the tree is treated as
12485            a flattened list of concatenations when generating code.  */
12486
12487         ffecomConcatList_ catlist;
12488         tree ltmp, itmp, result;
12489         int count;
12490         int i;
12491
12492         catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
12493         count = ffecom_concat_list_count_ (catlist);
12494
12495         if (count >= 2)
12496           {
12497             ltmp
12498               = ffecom_make_tempvar ("concat_len",
12499                                      ffecom_f2c_ftnlen_type_node,
12500                                      FFETARGET_charactersizeNONE, count);
12501             itmp
12502               = ffecom_make_tempvar ("concat_item",
12503                                      ffecom_f2c_address_type_node,
12504                                      FFETARGET_charactersizeNONE, count);
12505             result
12506               = ffecom_make_tempvar ("concat_res",
12507                                      char_type_node,
12508                                      ffecom_concat_list_maxlen_ (catlist),
12509                                      -1);
12510
12511             tempvar = make_tree_vec (3);
12512             TREE_VEC_ELT (tempvar, 0) = ltmp;
12513             TREE_VEC_ELT (tempvar, 1) = itmp;
12514             TREE_VEC_ELT (tempvar, 2) = result;
12515           }
12516
12517         for (i = 0; i < count; ++i)
12518           ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist,
12519                                                                     i));
12520
12521         ffecom_concat_list_kill_ (catlist);
12522
12523         if (tempvar)
12524           {
12525             ffebld_nonter_set_hook (expr, tempvar);
12526             current_binding_level->prep_state = 1;
12527           }
12528       }
12529       return;
12530
12531     case FFEBLD_opCONVERT:
12532       if (bt == FFEINFO_basictypeCHARACTER
12533           && ((ffebld_size_known (ffebld_left (expr))
12534                == FFETARGET_charactersizeNONE)
12535               || (ffebld_size_known (ffebld_left (expr)) >= sz)))
12536         tempvar = ffecom_make_tempvar ("convert", char_type_node, sz, -1);
12537       break;
12538     }
12539
12540   if (tempvar)
12541     {
12542       ffebld_nonter_set_hook (expr, tempvar);
12543       current_binding_level->prep_state = 1;
12544     }
12545
12546   /* Prepare subexpressions for this expr.  */
12547
12548   switch (ffebld_op (expr))
12549     {
12550     case FFEBLD_opPERCENT_LOC:
12551       ffecom_prepare_ptr_to_expr (ffebld_left (expr));
12552       break;
12553
12554     case FFEBLD_opPERCENT_VAL:
12555     case FFEBLD_opPERCENT_REF:
12556       ffecom_prepare_expr (ffebld_left (expr));
12557       break;
12558
12559     case FFEBLD_opPERCENT_DESCR:
12560       ffecom_prepare_arg_ptr_to_expr (ffebld_left (expr));
12561       break;
12562
12563     case FFEBLD_opITEM:
12564       {
12565         ffebld item;
12566
12567         for (item = expr;
12568              item != NULL;
12569              item = ffebld_trail (item))
12570           if (ffebld_head (item) != NULL)
12571             ffecom_prepare_expr (ffebld_head (item));
12572       }
12573       break;
12574
12575     default:
12576       /* Need to handle character conversion specially.  */
12577       switch (ffebld_arity (expr))
12578         {
12579         case 2:
12580           ffecom_prepare_expr (ffebld_left (expr));
12581           ffecom_prepare_expr (ffebld_right (expr));
12582           break;
12583
12584         case 1:
12585           ffecom_prepare_expr (ffebld_left (expr));
12586           break;
12587
12588         default:
12589           break;
12590         }
12591     }
12592
12593   return;
12594 }
12595
12596 /* Prepare expression for reading and writing.
12597
12598    Like ffecom_prepare_expr, except for expressions to be evaluated
12599    via ffecom_expr_rw.  */
12600
12601 void
12602 ffecom_prepare_expr_rw (tree type, ffebld expr)
12603 {
12604   /* This is all we support for now.  */
12605   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
12606
12607   /* ~~For now, it seems to be the same thing.  */
12608   ffecom_prepare_expr (expr);
12609   return;
12610 }
12611
12612 /* Prepare expression for writing.
12613
12614    Like ffecom_prepare_expr, except for expressions to be evaluated
12615    via ffecom_expr_w.  */
12616
12617 void
12618 ffecom_prepare_expr_w (tree type, ffebld expr)
12619 {
12620   /* This is all we support for now.  */
12621   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
12622
12623   /* ~~For now, it seems to be the same thing.  */
12624   ffecom_prepare_expr (expr);
12625   return;
12626 }
12627
12628 /* Prepare expression for returning.
12629
12630    Like ffecom_prepare_expr, except for expressions to be evaluated
12631    via ffecom_return_expr.  */
12632
12633 void
12634 ffecom_prepare_return_expr (ffebld expr)
12635 {
12636   assert (current_binding_level->prep_state < 2);
12637
12638   if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE
12639       && ffecom_is_altreturning_
12640       && expr != NULL)
12641     ffecom_prepare_expr (expr);
12642 }
12643
12644 /* Prepare pointer to expression.
12645
12646    Like ffecom_prepare_expr, except for expressions to be evaluated
12647    via ffecom_ptr_to_expr.  */
12648
12649 void
12650 ffecom_prepare_ptr_to_expr (ffebld expr)
12651 {
12652   /* ~~For now, it seems to be the same thing.  */
12653   ffecom_prepare_expr (expr);
12654   return;
12655 }
12656
12657 /* Transform expression into constant pointer-to-expression tree.
12658
12659    If the expression can be transformed into a pointer-to-expression tree
12660    that is constant, that is done, and the tree returned.  Else NULL_TREE
12661    is returned.
12662
12663    That way, a caller can attempt to provide compile-time initialization
12664    of a variable and, if that fails, *then* choose to start a new block
12665    and resort to using temporaries, as appropriate.  */
12666
12667 tree
12668 ffecom_ptr_to_const_expr (ffebld expr)
12669 {
12670   if (! expr)
12671     return integer_zero_node;
12672
12673   if (ffebld_op (expr) == FFEBLD_opANY)
12674     return error_mark_node;
12675
12676   if (ffebld_arity (expr) == 0
12677       && (ffebld_op (expr) != FFEBLD_opSYMTER
12678           || ffebld_where (expr) == FFEINFO_whereCOMMON
12679           || ffebld_where (expr) == FFEINFO_whereGLOBAL
12680           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
12681     {
12682       tree t;
12683
12684       t = ffecom_ptr_to_expr (expr);
12685       assert (TREE_CONSTANT (t));
12686       return t;
12687     }
12688
12689   return NULL_TREE;
12690 }
12691
12692 /* ffecom_return_expr -- Returns return-value expr given alt return expr
12693
12694    tree rtn;  // NULL_TREE means use expand_null_return()
12695    ffebld expr;  // NULL if no alt return expr to RETURN stmt
12696    rtn = ffecom_return_expr(expr);
12697
12698    Based on the program unit type and other info (like return function
12699    type, return master function type when alternate ENTRY points,
12700    whether subroutine has any alternate RETURN points, etc), returns the
12701    appropriate expression to be returned to the caller, or NULL_TREE
12702    meaning no return value or the caller expects it to be returned somewhere
12703    else (which is handled by other parts of this module).  */
12704
12705 tree
12706 ffecom_return_expr (ffebld expr)
12707 {
12708   tree rtn;
12709
12710   switch (ffecom_primary_entry_kind_)
12711     {
12712     case FFEINFO_kindPROGRAM:
12713     case FFEINFO_kindBLOCKDATA:
12714       rtn = NULL_TREE;
12715       break;
12716
12717     case FFEINFO_kindSUBROUTINE:
12718       if (!ffecom_is_altreturning_)
12719         rtn = NULL_TREE;        /* No alt returns, never an expr. */
12720       else if (expr == NULL)
12721         rtn = integer_zero_node;
12722       else
12723         rtn = ffecom_expr (expr);
12724       break;
12725
12726     case FFEINFO_kindFUNCTION:
12727       if ((ffecom_multi_retval_ != NULL_TREE)
12728           || (ffesymbol_basictype (ffecom_primary_entry_)
12729               == FFEINFO_basictypeCHARACTER)
12730           || ((ffesymbol_basictype (ffecom_primary_entry_)
12731                == FFEINFO_basictypeCOMPLEX)
12732               && (ffecom_num_entrypoints_ == 0)
12733               && ffesymbol_is_f2c (ffecom_primary_entry_)))
12734         {                       /* Value is returned by direct assignment
12735                                    into (implicit) dummy. */
12736           rtn = NULL_TREE;
12737           break;
12738         }
12739       rtn = ffecom_func_result_;
12740 #if 0
12741       /* Spurious error if RETURN happens before first reference!  So elide
12742          this code.  In particular, for debugging registry, rtn should always
12743          be non-null after all, but TREE_USED won't be set until we encounter
12744          a reference in the code.  Perfectly okay (but weird) code that,
12745          e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in
12746          this diagnostic for no reason.  Have people use -O -Wuninitialized
12747          and leave it to the back end to find obviously weird cases.  */
12748
12749       /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid
12750          situation; if the return value has never been referenced, it won't
12751          have a tree under 2pass mode. */
12752       if ((rtn == NULL_TREE)
12753           || !TREE_USED (rtn))
12754         {
12755           ffebad_start (FFEBAD_RETURN_VALUE_UNSET);
12756           ffebad_here (0, ffesymbol_where_line (ffecom_primary_entry_),
12757                        ffesymbol_where_column (ffecom_primary_entry_));
12758           ffebad_string (ffesymbol_text (ffesymbol_funcresult
12759                                          (ffecom_primary_entry_)));
12760           ffebad_finish ();
12761         }
12762 #endif
12763       break;
12764
12765     default:
12766       assert ("bad unit kind" == NULL);
12767     case FFEINFO_kindANY:
12768       rtn = error_mark_node;
12769       break;
12770     }
12771
12772   return rtn;
12773 }
12774
12775 /* Do save_expr only if tree is not error_mark_node.  */
12776
12777 tree
12778 ffecom_save_tree (tree t)
12779 {
12780   return save_expr (t);
12781 }
12782
12783 /* Start a compound statement (block).  */
12784
12785 void
12786 ffecom_start_compstmt (void)
12787 {
12788   bison_rule_pushlevel_ ();
12789 }
12790
12791 /* Public entry point for front end to access start_decl.  */
12792
12793 tree
12794 ffecom_start_decl (tree decl, bool is_initialized)
12795 {
12796   DECL_INITIAL (decl) = is_initialized ? error_mark_node : NULL_TREE;
12797   return start_decl (decl, FALSE);
12798 }
12799
12800 /* ffecom_sym_commit -- Symbol's state being committed to reality
12801
12802    ffesymbol s;
12803    ffecom_sym_commit(s);
12804
12805    Does whatever the backend needs when a symbol is committed after having
12806    been backtrackable for a period of time.  */
12807
12808 void
12809 ffecom_sym_commit (ffesymbol s UNUSED)
12810 {
12811   assert (!ffesymbol_retractable ());
12812 }
12813
12814 /* ffecom_sym_end_transition -- Perform end transition on all symbols
12815
12816    ffecom_sym_end_transition();
12817
12818    Does backend-specific stuff and also calls ffest_sym_end_transition
12819    to do the necessary FFE stuff.
12820
12821    Backtracking is never enabled when this fn is called, so don't worry
12822    about it.  */
12823
12824 ffesymbol
12825 ffecom_sym_end_transition (ffesymbol s)
12826 {
12827   ffestorag st;
12828
12829   assert (!ffesymbol_retractable ());
12830
12831   s = ffest_sym_end_transition (s);
12832
12833   if ((ffesymbol_kind (s) == FFEINFO_kindBLOCKDATA)
12834       && (ffesymbol_where (s) == FFEINFO_whereGLOBAL))
12835     {
12836       ffecom_list_blockdata_
12837         = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
12838                                               FFEINTRIN_specNONE,
12839                                               FFEINTRIN_impNONE),
12840                            ffecom_list_blockdata_);
12841     }
12842
12843   /* This is where we finally notice that a symbol has partial initialization
12844      and finalize it. */
12845
12846   if (ffesymbol_accretion (s) != NULL)
12847     {
12848       assert (ffesymbol_init (s) == NULL);
12849       ffecom_notify_init_symbol (s);
12850     }
12851   else if (((st = ffesymbol_storage (s)) != NULL)
12852            && ((st = ffestorag_parent (st)) != NULL)
12853            && (ffestorag_accretion (st) != NULL))
12854     {
12855       assert (ffestorag_init (st) == NULL);
12856       ffecom_notify_init_storage (st);
12857     }
12858
12859   if ((ffesymbol_kind (s) == FFEINFO_kindCOMMON)
12860       && (ffesymbol_where (s) == FFEINFO_whereLOCAL)
12861       && (ffesymbol_storage (s) != NULL))
12862     {
12863       ffecom_list_common_
12864         = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
12865                                               FFEINTRIN_specNONE,
12866                                               FFEINTRIN_impNONE),
12867                            ffecom_list_common_);
12868     }
12869
12870   return s;
12871 }
12872
12873 /* ffecom_sym_exec_transition -- Perform exec transition on all symbols
12874
12875    ffecom_sym_exec_transition();
12876
12877    Does backend-specific stuff and also calls ffest_sym_exec_transition
12878    to do the necessary FFE stuff.
12879
12880    See the long-winded description in ffecom_sym_learned for info
12881    on handling the situation where backtracking is inhibited.  */
12882
12883 ffesymbol
12884 ffecom_sym_exec_transition (ffesymbol s)
12885 {
12886   s = ffest_sym_exec_transition (s);
12887
12888   return s;
12889 }
12890
12891 /* ffecom_sym_learned -- Initial or more info gained on symbol after exec
12892
12893    ffesymbol s;
12894    s = ffecom_sym_learned(s);
12895
12896    Called when a new symbol is seen after the exec transition or when more
12897    info (perhaps) is gained for an UNCERTAIN symbol.  The symbol state when
12898    it arrives here is that all its latest info is updated already, so its
12899    state may be UNCERTAIN or UNDERSTOOD, it might already have the hook
12900    field filled in if its gone through here or exec_transition first, and
12901    so on.
12902
12903    The backend probably wants to check ffesymbol_retractable() to see if
12904    backtracking is in effect.  If so, the FFE's changes to the symbol may
12905    be retracted (undone) or committed (ratified), at which time the
12906    appropriate ffecom_sym_retract or _commit function will be called
12907    for that function.
12908
12909    If the backend has its own backtracking mechanism, great, use it so that
12910    committal is a simple operation.  Though it doesn't make much difference,
12911    I suppose: the reason for tentative symbol evolution in the FFE is to
12912    enable error detection in weird incorrect statements early and to disable
12913    incorrect error detection on a correct statement.  The backend is not
12914    likely to introduce any information that'll get involved in these
12915    considerations, so it is probably just fine that the implementation
12916    model for this fn and for _exec_transition is to not do anything
12917    (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE
12918    and instead wait until ffecom_sym_commit is called (which it never
12919    will be as long as we're using ambiguity-detecting statement analysis in
12920    the FFE, which we are initially to shake out the code, but don't depend
12921    on this), otherwise go ahead and do whatever is needed.
12922
12923    In essence, then, when this fn and _exec_transition get called while
12924    backtracking is enabled, a general mechanism would be to flag which (or
12925    both) of these were called (and in what order? neat question as to what
12926    might happen that I'm too lame to think through right now) and then when
12927    _commit is called reproduce the original calling sequence, if any, for
12928    the two fns (at which point backtracking will, of course, be disabled).  */
12929
12930 ffesymbol
12931 ffecom_sym_learned (ffesymbol s)
12932 {
12933   ffestorag_exec_layout (s);
12934
12935   return s;
12936 }
12937
12938 /* ffecom_sym_retract -- Symbol's state being retracted from reality
12939
12940    ffesymbol s;
12941    ffecom_sym_retract(s);
12942
12943    Does whatever the backend needs when a symbol is retracted after having
12944    been backtrackable for a period of time.  */
12945
12946 void
12947 ffecom_sym_retract (ffesymbol s UNUSED)
12948 {
12949   assert (!ffesymbol_retractable ());
12950
12951 #if 0                           /* GCC doesn't commit any backtrackable sins,
12952                                    so nothing needed here. */
12953   switch (ffesymbol_hook (s).state)
12954     {
12955     case 0:                     /* nothing happened yet. */
12956       break;
12957
12958     case 1:                     /* exec transition happened. */
12959       break;
12960
12961     case 2:                     /* learned happened. */
12962       break;
12963
12964     case 3:                     /* learned then exec. */
12965       break;
12966
12967     case 4:                     /* exec then learned. */
12968       break;
12969
12970     default:
12971       assert ("bad hook state" == NULL);
12972       break;
12973     }
12974 #endif
12975 }
12976
12977 /* Create temporary gcc label.  */
12978
12979 tree
12980 ffecom_temp_label ()
12981 {
12982   tree glabel;
12983   static int mynumber = 0;
12984
12985   glabel = build_decl (LABEL_DECL,
12986                        ffecom_get_invented_identifier ("__g77_label_%d",
12987                                                        mynumber++),
12988                        void_type_node);
12989   DECL_CONTEXT (glabel) = current_function_decl;
12990   DECL_MODE (glabel) = VOIDmode;
12991
12992   return glabel;
12993 }
12994
12995 /* Return an expression that is usable as an arg in a conditional context
12996    (IF, DO WHILE, .NOT., and so on).
12997
12998    Use the one provided for the back end as of >2.6.0.  */
12999
13000 tree
13001 ffecom_truth_value (tree expr)
13002 {
13003   return truthvalue_conversion (expr);
13004 }
13005
13006 /* Return the inversion of a truth value (the inversion of what
13007    ffecom_truth_value builds).
13008
13009    Apparently invert_truthvalue, which is properly in the back end, is
13010    enough for now, so just use it.  */
13011
13012 tree
13013 ffecom_truth_value_invert (tree expr)
13014 {
13015   return invert_truthvalue (ffecom_truth_value (expr));
13016 }
13017
13018 /* Return the tree that is the type of the expression, as would be
13019    returned in TREE_TYPE(ffecom_expr(expr)), without otherwise
13020    transforming the expression, generating temporaries, etc.  */
13021
13022 tree
13023 ffecom_type_expr (ffebld expr)
13024 {
13025   ffeinfoBasictype bt;
13026   ffeinfoKindtype kt;
13027   tree tree_type;
13028
13029   assert (expr != NULL);
13030
13031   bt = ffeinfo_basictype (ffebld_info (expr));
13032   kt = ffeinfo_kindtype (ffebld_info (expr));
13033   tree_type = ffecom_tree_type[bt][kt];
13034
13035   switch (ffebld_op (expr))
13036     {
13037     case FFEBLD_opCONTER:
13038     case FFEBLD_opSYMTER:
13039     case FFEBLD_opARRAYREF:
13040     case FFEBLD_opUPLUS:
13041     case FFEBLD_opPAREN:
13042     case FFEBLD_opUMINUS:
13043     case FFEBLD_opADD:
13044     case FFEBLD_opSUBTRACT:
13045     case FFEBLD_opMULTIPLY:
13046     case FFEBLD_opDIVIDE:
13047     case FFEBLD_opPOWER:
13048     case FFEBLD_opNOT:
13049     case FFEBLD_opFUNCREF:
13050     case FFEBLD_opSUBRREF:
13051     case FFEBLD_opAND:
13052     case FFEBLD_opOR:
13053     case FFEBLD_opXOR:
13054     case FFEBLD_opNEQV:
13055     case FFEBLD_opEQV:
13056     case FFEBLD_opCONVERT:
13057     case FFEBLD_opLT:
13058     case FFEBLD_opLE:
13059     case FFEBLD_opEQ:
13060     case FFEBLD_opNE:
13061     case FFEBLD_opGT:
13062     case FFEBLD_opGE:
13063     case FFEBLD_opPERCENT_LOC:
13064       return tree_type;
13065
13066     case FFEBLD_opACCTER:
13067     case FFEBLD_opARRTER:
13068     case FFEBLD_opITEM:
13069     case FFEBLD_opSTAR:
13070     case FFEBLD_opBOUNDS:
13071     case FFEBLD_opREPEAT:
13072     case FFEBLD_opLABTER:
13073     case FFEBLD_opLABTOK:
13074     case FFEBLD_opIMPDO:
13075     case FFEBLD_opCONCATENATE:
13076     case FFEBLD_opSUBSTR:
13077     default:
13078       assert ("bad op for ffecom_type_expr" == NULL);
13079       /* Fall through. */
13080     case FFEBLD_opANY:
13081       return error_mark_node;
13082     }
13083 }
13084
13085 /* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points
13086
13087    If the PARM_DECL already exists, return it, else create it.  It's an
13088    integer_type_node argument for the master function that implements a
13089    subroutine or function with more than one entrypoint and is bound at
13090    run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for
13091    first ENTRY statement, and so on).  */
13092
13093 tree
13094 ffecom_which_entrypoint_decl ()
13095 {
13096   assert (ffecom_which_entrypoint_decl_ != NULL_TREE);
13097
13098   return ffecom_which_entrypoint_decl_;
13099 }
13100 \f
13101 /* The following sections consists of private and public functions
13102    that have the same names and perform roughly the same functions
13103    as counterparts in the C front end.  Changes in the C front end
13104    might affect how things should be done here.  Only functions
13105    needed by the back end should be public here; the rest should
13106    be private (static in the C sense).  Functions needed by other
13107    g77 front-end modules should be accessed by them via public
13108    ffecom_* names, which should themselves call private versions
13109    in this section so the private versions are easy to recognize
13110    when upgrading to a new gcc and finding interesting changes
13111    in the front end.
13112
13113    Functions named after rule "foo:" in c-parse.y are named
13114    "bison_rule_foo_" so they are easy to find.  */
13115
13116 static void
13117 bison_rule_pushlevel_ ()
13118 {
13119   emit_line_note (input_filename, lineno);
13120   pushlevel (0);
13121   clear_last_expr ();
13122   expand_start_bindings (0);
13123 }
13124
13125 static tree
13126 bison_rule_compstmt_ ()
13127 {
13128   tree t;
13129   int keep = kept_level_p ();
13130
13131   /* Make the temps go away.  */
13132   if (! keep)
13133     current_binding_level->names = NULL_TREE;
13134
13135   emit_line_note (input_filename, lineno);
13136   expand_end_bindings (getdecls (), keep, 0);
13137   t = poplevel (keep, 1, 0);
13138
13139   return t;
13140 }
13141
13142 /* Return a definition for a builtin function named NAME and whose data type
13143    is TYPE.  TYPE should be a function type with argument types.
13144    FUNCTION_CODE tells later passes how to compile calls to this function.
13145    See tree.h for its possible values.
13146
13147    If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
13148    the name to be called if we can't opencode the function.  */
13149
13150 tree
13151 builtin_function (const char *name, tree type, int function_code,
13152                   enum built_in_class class,
13153                   const char *library_name)
13154 {
13155   tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type);
13156   DECL_EXTERNAL (decl) = 1;
13157   TREE_PUBLIC (decl) = 1;
13158   if (library_name)
13159     SET_DECL_ASSEMBLER_NAME (decl, get_identifier (library_name));
13160   make_decl_rtl (decl, NULL);
13161   pushdecl (decl);
13162   DECL_BUILT_IN_CLASS (decl) = class;
13163   DECL_FUNCTION_CODE (decl) = function_code;
13164
13165   return decl;
13166 }
13167
13168 /* Handle when a new declaration NEWDECL
13169    has the same name as an old one OLDDECL
13170    in the same binding contour.
13171    Prints an error message if appropriate.
13172
13173    If safely possible, alter OLDDECL to look like NEWDECL, and return 1.
13174    Otherwise, return 0.  */
13175
13176 static int
13177 duplicate_decls (tree newdecl, tree olddecl)
13178 {
13179   int types_match = 1;
13180   int new_is_definition = (TREE_CODE (newdecl) == FUNCTION_DECL
13181                            && DECL_INITIAL (newdecl) != 0);
13182   tree oldtype = TREE_TYPE (olddecl);
13183   tree newtype = TREE_TYPE (newdecl);
13184
13185   if (olddecl == newdecl)
13186     return 1;
13187
13188   if (TREE_CODE (newtype) == ERROR_MARK
13189       || TREE_CODE (oldtype) == ERROR_MARK)
13190     types_match = 0;
13191
13192   /* New decl is completely inconsistent with the old one =>
13193      tell caller to replace the old one.
13194      This is always an error except in the case of shadowing a builtin.  */
13195   if (TREE_CODE (olddecl) != TREE_CODE (newdecl))
13196     return 0;
13197
13198   /* For real parm decl following a forward decl,
13199      return 1 so old decl will be reused.  */
13200   if (types_match && TREE_CODE (newdecl) == PARM_DECL
13201       && TREE_ASM_WRITTEN (olddecl) && ! TREE_ASM_WRITTEN (newdecl))
13202     return 1;
13203
13204   /* The new declaration is the same kind of object as the old one.
13205      The declarations may partially match.  Print warnings if they don't
13206      match enough.  Ultimately, copy most of the information from the new
13207      decl to the old one, and keep using the old one.  */
13208
13209   if (TREE_CODE (olddecl) == FUNCTION_DECL
13210       && DECL_BUILT_IN (olddecl))
13211     {
13212       /* A function declaration for a built-in function.  */
13213       if (!TREE_PUBLIC (newdecl))
13214         return 0;
13215       else if (!types_match)
13216         {
13217           /* Accept the return type of the new declaration if same modes.  */
13218           tree oldreturntype = TREE_TYPE (TREE_TYPE (olddecl));
13219           tree newreturntype = TREE_TYPE (TREE_TYPE (newdecl));
13220
13221           if (TYPE_MODE (oldreturntype) == TYPE_MODE (newreturntype))
13222             {
13223               /* Function types may be shared, so we can't just modify
13224                  the return type of olddecl's function type.  */
13225               tree newtype
13226                 = build_function_type (newreturntype,
13227                                        TYPE_ARG_TYPES (TREE_TYPE (olddecl)));
13228
13229               types_match = 1;
13230               if (types_match)
13231                 TREE_TYPE (olddecl) = newtype;
13232             }
13233         }
13234       if (!types_match)
13235         return 0;
13236     }
13237   else if (TREE_CODE (olddecl) == FUNCTION_DECL
13238            && DECL_SOURCE_LINE (olddecl) == 0)
13239     {
13240       /* A function declaration for a predeclared function
13241          that isn't actually built in.  */
13242       if (!TREE_PUBLIC (newdecl))
13243         return 0;
13244       else if (!types_match)
13245         {
13246           /* If the types don't match, preserve volatility indication.
13247              Later on, we will discard everything else about the
13248              default declaration.  */
13249           TREE_THIS_VOLATILE (newdecl) |= TREE_THIS_VOLATILE (olddecl);
13250         }
13251     }
13252
13253   /* Copy all the DECL_... slots specified in the new decl
13254      except for any that we copy here from the old type.
13255
13256      Past this point, we don't change OLDTYPE and NEWTYPE
13257      even if we change the types of NEWDECL and OLDDECL.  */
13258
13259   if (types_match)
13260     {
13261       /* Merge the data types specified in the two decls.  */
13262       if (TREE_CODE (newdecl) != FUNCTION_DECL || !DECL_BUILT_IN (olddecl))
13263         TREE_TYPE (newdecl)
13264           = TREE_TYPE (olddecl)
13265             = TREE_TYPE (newdecl);
13266
13267       /* Lay the type out, unless already done.  */
13268       if (oldtype != TREE_TYPE (newdecl))
13269         {
13270           if (TREE_TYPE (newdecl) != error_mark_node)
13271             layout_type (TREE_TYPE (newdecl));
13272           if (TREE_CODE (newdecl) != FUNCTION_DECL
13273               && TREE_CODE (newdecl) != TYPE_DECL
13274               && TREE_CODE (newdecl) != CONST_DECL)
13275             layout_decl (newdecl, 0);
13276         }
13277       else
13278         {
13279           /* Since the type is OLDDECL's, make OLDDECL's size go with.  */
13280           DECL_SIZE (newdecl) = DECL_SIZE (olddecl);
13281           DECL_SIZE_UNIT (newdecl) = DECL_SIZE_UNIT (olddecl);
13282           if (TREE_CODE (olddecl) != FUNCTION_DECL)
13283             if (DECL_ALIGN (olddecl) > DECL_ALIGN (newdecl))
13284               {
13285                 DECL_ALIGN (newdecl) = DECL_ALIGN (olddecl);
13286                 DECL_USER_ALIGN (newdecl) |= DECL_USER_ALIGN (olddecl);
13287               }
13288         }
13289
13290       /* Keep the old rtl since we can safely use it.  */
13291       COPY_DECL_RTL (olddecl, newdecl);
13292
13293       /* Merge the type qualifiers.  */
13294       if (DECL_BUILT_IN_NONANSI (olddecl) && TREE_THIS_VOLATILE (olddecl)
13295           && !TREE_THIS_VOLATILE (newdecl))
13296         TREE_THIS_VOLATILE (olddecl) = 0;
13297       if (TREE_READONLY (newdecl))
13298         TREE_READONLY (olddecl) = 1;
13299       if (TREE_THIS_VOLATILE (newdecl))
13300         {
13301           TREE_THIS_VOLATILE (olddecl) = 1;
13302           if (TREE_CODE (newdecl) == VAR_DECL)
13303             make_var_volatile (newdecl);
13304         }
13305
13306       /* Keep source location of definition rather than declaration.
13307          Likewise, keep decl at outer scope.  */
13308       if ((DECL_INITIAL (newdecl) == 0 && DECL_INITIAL (olddecl) != 0)
13309           || (DECL_CONTEXT (newdecl) != 0 && DECL_CONTEXT (olddecl) == 0))
13310         {
13311           DECL_SOURCE_LINE (newdecl) = DECL_SOURCE_LINE (olddecl);
13312           DECL_SOURCE_FILE (newdecl) = DECL_SOURCE_FILE (olddecl);
13313
13314           if (DECL_CONTEXT (olddecl) == 0
13315               && TREE_CODE (newdecl) != FUNCTION_DECL)
13316             DECL_CONTEXT (newdecl) = 0;
13317         }
13318
13319       /* Merge the unused-warning information.  */
13320       if (DECL_IN_SYSTEM_HEADER (olddecl))
13321         DECL_IN_SYSTEM_HEADER (newdecl) = 1;
13322       else if (DECL_IN_SYSTEM_HEADER (newdecl))
13323         DECL_IN_SYSTEM_HEADER (olddecl) = 1;
13324
13325       /* Merge the initialization information.  */
13326       if (DECL_INITIAL (newdecl) == 0)
13327         DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13328
13329       /* Merge the section attribute.
13330          We want to issue an error if the sections conflict but that must be
13331          done later in decl_attributes since we are called before attributes
13332          are assigned.  */
13333       if (DECL_SECTION_NAME (newdecl) == NULL_TREE)
13334         DECL_SECTION_NAME (newdecl) = DECL_SECTION_NAME (olddecl);
13335
13336       if (TREE_CODE (newdecl) == FUNCTION_DECL)
13337         {
13338           DECL_STATIC_CONSTRUCTOR(newdecl) |= DECL_STATIC_CONSTRUCTOR(olddecl);
13339           DECL_STATIC_DESTRUCTOR (newdecl) |= DECL_STATIC_DESTRUCTOR (olddecl);
13340         }
13341     }
13342   /* If cannot merge, then use the new type and qualifiers,
13343      and don't preserve the old rtl.  */
13344   else
13345     {
13346       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13347       TREE_READONLY (olddecl) = TREE_READONLY (newdecl);
13348       TREE_THIS_VOLATILE (olddecl) = TREE_THIS_VOLATILE (newdecl);
13349       TREE_SIDE_EFFECTS (olddecl) = TREE_SIDE_EFFECTS (newdecl);
13350     }
13351
13352   /* Merge the storage class information.  */
13353   /* For functions, static overrides non-static.  */
13354   if (TREE_CODE (newdecl) == FUNCTION_DECL)
13355     {
13356       TREE_PUBLIC (newdecl) &= TREE_PUBLIC (olddecl);
13357       /* This is since we don't automatically
13358          copy the attributes of NEWDECL into OLDDECL.  */
13359       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13360       /* If this clears `static', clear it in the identifier too.  */
13361       if (! TREE_PUBLIC (olddecl))
13362         TREE_PUBLIC (DECL_NAME (olddecl)) = 0;
13363     }
13364   if (DECL_EXTERNAL (newdecl))
13365     {
13366       TREE_STATIC (newdecl) = TREE_STATIC (olddecl);
13367       DECL_EXTERNAL (newdecl) = DECL_EXTERNAL (olddecl);
13368       /* An extern decl does not override previous storage class.  */
13369       TREE_PUBLIC (newdecl) = TREE_PUBLIC (olddecl);
13370     }
13371   else
13372     {
13373       TREE_STATIC (olddecl) = TREE_STATIC (newdecl);
13374       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13375     }
13376
13377   /* If either decl says `inline', this fn is inline,
13378      unless its definition was passed already.  */
13379   if (DECL_INLINE (newdecl) && DECL_INITIAL (olddecl) == 0)
13380     DECL_INLINE (olddecl) = 1;
13381   DECL_INLINE (newdecl) = DECL_INLINE (olddecl);
13382
13383   /* Get rid of any built-in function if new arg types don't match it
13384      or if we have a function definition.  */
13385   if (TREE_CODE (newdecl) == FUNCTION_DECL
13386       && DECL_BUILT_IN (olddecl)
13387       && (!types_match || new_is_definition))
13388     {
13389       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13390       DECL_BUILT_IN_CLASS (olddecl) = NOT_BUILT_IN;
13391     }
13392
13393   /* If redeclaring a builtin function, and not a definition,
13394      it stays built in.
13395      Also preserve various other info from the definition.  */
13396   if (TREE_CODE (newdecl) == FUNCTION_DECL && !new_is_definition)
13397     {
13398       if (DECL_BUILT_IN (olddecl))
13399         {
13400           DECL_BUILT_IN_CLASS (newdecl) = DECL_BUILT_IN_CLASS (olddecl);
13401           DECL_FUNCTION_CODE (newdecl) = DECL_FUNCTION_CODE (olddecl);
13402         }
13403
13404       DECL_RESULT (newdecl) = DECL_RESULT (olddecl);
13405       DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13406       DECL_SAVED_INSNS (newdecl) = DECL_SAVED_INSNS (olddecl);
13407       DECL_ARGUMENTS (newdecl) = DECL_ARGUMENTS (olddecl);
13408     }
13409
13410   /* Copy most of the decl-specific fields of NEWDECL into OLDDECL.
13411      But preserve olddecl's DECL_UID.  */
13412   {
13413     register unsigned olddecl_uid = DECL_UID (olddecl);
13414
13415     memcpy ((char *) olddecl + sizeof (struct tree_common),
13416             (char *) newdecl + sizeof (struct tree_common),
13417             sizeof (struct tree_decl) - sizeof (struct tree_common));
13418     DECL_UID (olddecl) = olddecl_uid;
13419   }
13420
13421   return 1;
13422 }
13423
13424 /* Finish processing of a declaration;
13425    install its initial value.
13426    If the length of an array type is not known before,
13427    it must be determined now, from the initial value, or it is an error.  */
13428
13429 static void
13430 finish_decl (tree decl, tree init, bool is_top_level)
13431 {
13432   register tree type = TREE_TYPE (decl);
13433   int was_incomplete = (DECL_SIZE (decl) == 0);
13434   bool at_top_level = (current_binding_level == global_binding_level);
13435   bool top_level = is_top_level || at_top_level;
13436
13437   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13438      level anyway.  */
13439   assert (!is_top_level || !at_top_level);
13440
13441   if (TREE_CODE (decl) == PARM_DECL)
13442     assert (init == NULL_TREE);
13443   /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it
13444      overlaps DECL_ARG_TYPE.  */
13445   else if (init == NULL_TREE)
13446     assert (DECL_INITIAL (decl) == NULL_TREE);
13447   else
13448     assert (DECL_INITIAL (decl) == error_mark_node);
13449
13450   if (init != NULL_TREE)
13451     {
13452       if (TREE_CODE (decl) != TYPE_DECL)
13453         DECL_INITIAL (decl) = init;
13454       else
13455         {
13456           /* typedef foo = bar; store the type of bar as the type of foo.  */
13457           TREE_TYPE (decl) = TREE_TYPE (init);
13458           DECL_INITIAL (decl) = init = 0;
13459         }
13460     }
13461
13462   /* Deduce size of array from initialization, if not already known */
13463
13464   if (TREE_CODE (type) == ARRAY_TYPE
13465       && TYPE_DOMAIN (type) == 0
13466       && TREE_CODE (decl) != TYPE_DECL)
13467     {
13468       assert (top_level);
13469       assert (was_incomplete);
13470
13471       layout_decl (decl, 0);
13472     }
13473
13474   if (TREE_CODE (decl) == VAR_DECL)
13475     {
13476       if (DECL_SIZE (decl) == NULL_TREE
13477           && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
13478         layout_decl (decl, 0);
13479
13480       if (DECL_SIZE (decl) == NULL_TREE
13481           && (TREE_STATIC (decl)
13482               ?
13483       /* A static variable with an incomplete type is an error if it is
13484          initialized. Also if it is not file scope. Otherwise, let it
13485          through, but if it is not `extern' then it may cause an error
13486          message later.  */
13487               (DECL_INITIAL (decl) != 0 || DECL_CONTEXT (decl) != 0)
13488               :
13489       /* An automatic variable with an incomplete type is an error.  */
13490               !DECL_EXTERNAL (decl)))
13491         {
13492           assert ("storage size not known" == NULL);
13493           abort ();
13494         }
13495
13496       if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl))
13497           && (DECL_SIZE (decl) != 0)
13498           && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST))
13499         {
13500           assert ("storage size not constant" == NULL);
13501           abort ();
13502         }
13503     }
13504
13505   /* Output the assembler code and/or RTL code for variables and functions,
13506      unless the type is an undefined structure or union. If not, it will get
13507      done when the type is completed.  */
13508
13509   if (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == FUNCTION_DECL)
13510     {
13511       rest_of_decl_compilation (decl, NULL,
13512                                 DECL_CONTEXT (decl) == 0,
13513                                 0);
13514
13515       if (DECL_CONTEXT (decl) != 0)
13516         {
13517           /* Recompute the RTL of a local array now if it used to be an
13518              incomplete type.  */
13519           if (was_incomplete
13520               && !TREE_STATIC (decl) && !DECL_EXTERNAL (decl))
13521             {
13522               /* If we used it already as memory, it must stay in memory.  */
13523               TREE_ADDRESSABLE (decl) = TREE_USED (decl);
13524               /* If it's still incomplete now, no init will save it.  */
13525               if (DECL_SIZE (decl) == 0)
13526                 DECL_INITIAL (decl) = 0;
13527               expand_decl (decl);
13528             }
13529           /* Compute and store the initial value.  */
13530           if (TREE_CODE (decl) != FUNCTION_DECL)
13531             expand_decl_init (decl);
13532         }
13533     }
13534   else if (TREE_CODE (decl) == TYPE_DECL)
13535     {
13536       rest_of_decl_compilation (decl, NULL,
13537                                 DECL_CONTEXT (decl) == 0,
13538                                 0);
13539     }
13540
13541   /* At the end of a declaration, throw away any variable type sizes of types
13542      defined inside that declaration.  There is no use computing them in the
13543      following function definition.  */
13544   if (current_binding_level == global_binding_level)
13545     get_pending_sizes ();
13546 }
13547
13548 /* Finish up a function declaration and compile that function
13549    all the way to assembler language output.  The free the storage
13550    for the function definition.
13551
13552    This is called after parsing the body of the function definition.
13553
13554    NESTED is nonzero if the function being finished is nested in another.  */
13555
13556 static void
13557 finish_function (int nested)
13558 {
13559   register tree fndecl = current_function_decl;
13560
13561   assert (fndecl != NULL_TREE);
13562   if (TREE_CODE (fndecl) != ERROR_MARK)
13563     {
13564       if (nested)
13565         assert (DECL_CONTEXT (fndecl) != NULL_TREE);
13566       else
13567         assert (DECL_CONTEXT (fndecl) == NULL_TREE);
13568     }
13569
13570 /*  TREE_READONLY (fndecl) = 1;
13571     This caused &foo to be of type ptr-to-const-function
13572     which then got a warning when stored in a ptr-to-function variable.  */
13573
13574   poplevel (1, 0, 1);
13575
13576   if (TREE_CODE (fndecl) != ERROR_MARK)
13577     {
13578       BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
13579
13580       /* Must mark the RESULT_DECL as being in this function.  */
13581
13582       DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl;
13583
13584       /* Obey `register' declarations if `setjmp' is called in this fn.  */
13585       /* Generate rtl for function exit.  */
13586       expand_function_end (input_filename, lineno, 0);
13587
13588       /* If this is a nested function, protect the local variables in the stack
13589          above us from being collected while we're compiling this function.  */
13590       if (nested)
13591         ggc_push_context ();
13592
13593       /* Run the optimizers and output the assembler code for this function.  */
13594       rest_of_compilation (fndecl);
13595
13596       /* Undo the GC context switch.  */
13597       if (nested)
13598         ggc_pop_context ();
13599     }
13600
13601   if (TREE_CODE (fndecl) != ERROR_MARK
13602       && !nested
13603       && DECL_SAVED_INSNS (fndecl) == 0)
13604     {
13605       /* Stop pointing to the local nodes about to be freed.  */
13606       /* But DECL_INITIAL must remain nonzero so we know this was an actual
13607          function definition.  */
13608       /* For a nested function, this is done in pop_f_function_context.  */
13609       /* If rest_of_compilation set this to 0, leave it 0.  */
13610       if (DECL_INITIAL (fndecl) != 0)
13611         DECL_INITIAL (fndecl) = error_mark_node;
13612       DECL_ARGUMENTS (fndecl) = 0;
13613     }
13614
13615   if (!nested)
13616     {
13617       /* Let the error reporting routines know that we're outside a function.
13618          For a nested function, this value is used in pop_c_function_context
13619          and then reset via pop_function_context.  */
13620       ffecom_outer_function_decl_ = current_function_decl = NULL;
13621     }
13622 }
13623
13624 /* Plug-in replacement for identifying the name of a decl and, for a
13625    function, what we call it in diagnostics.  For now, "program unit"
13626    should suffice, since it's a bit of a hassle to figure out which
13627    of several kinds of things it is.  Note that it could conceivably
13628    be a statement function, which probably isn't really a program unit
13629    per se, but if that comes up, it should be easy to check (being a
13630    nested function and all).  */
13631
13632 static const char *
13633 lang_printable_name (tree decl, int v)
13634 {
13635   /* Just to keep GCC quiet about the unused variable.
13636      In theory, differing values of V should produce different
13637      output.  */
13638   switch (v)
13639     {
13640     default:
13641       if (TREE_CODE (decl) == ERROR_MARK)
13642         return "erroneous code";
13643       return IDENTIFIER_POINTER (DECL_NAME (decl));
13644     }
13645 }
13646
13647 /* g77's function to print out name of current function that caused
13648    an error.  */
13649
13650 static void
13651 lang_print_error_function (diagnostic_context *context __attribute__((unused)),
13652                            const char *file)
13653 {
13654   static ffeglobal last_g = NULL;
13655   static ffesymbol last_s = NULL;
13656   ffeglobal g;
13657   ffesymbol s;
13658   const char *kind;
13659
13660   if ((ffecom_primary_entry_ == NULL)
13661       || (ffesymbol_global (ffecom_primary_entry_) == NULL))
13662     {
13663       g = NULL;
13664       s = NULL;
13665       kind = NULL;
13666     }
13667   else
13668     {
13669       g = ffesymbol_global (ffecom_primary_entry_);
13670       if (ffecom_nested_entry_ == NULL)
13671         {
13672           s = ffecom_primary_entry_;
13673           kind = _(ffeinfo_kind_message (ffesymbol_kind (s)));
13674         }
13675       else
13676         {
13677           s = ffecom_nested_entry_;
13678           kind = _("In statement function");
13679         }
13680     }
13681
13682   if ((last_g != g) || (last_s != s))
13683     {
13684       if (file)
13685         fprintf (stderr, "%s: ", file);
13686
13687       if (s == NULL)
13688         fprintf (stderr, _("Outside of any program unit:\n"));
13689       else
13690         {
13691           const char *name = ffesymbol_text (s);
13692
13693           fprintf (stderr, "%s `%s':\n", kind, name);
13694         }
13695
13696       last_g = g;
13697       last_s = s;
13698     }
13699 }
13700
13701 /* Similar to `lookup_name' but look only at current binding level.  */
13702
13703 static tree
13704 lookup_name_current_level (tree name)
13705 {
13706   register tree t;
13707
13708   if (current_binding_level == global_binding_level)
13709     return IDENTIFIER_GLOBAL_VALUE (name);
13710
13711   if (IDENTIFIER_LOCAL_VALUE (name) == 0)
13712     return 0;
13713
13714   for (t = current_binding_level->names; t; t = TREE_CHAIN (t))
13715     if (DECL_NAME (t) == name)
13716       break;
13717
13718   return t;
13719 }
13720
13721 /* Create a new `struct binding_level'.  */
13722
13723 static struct binding_level *
13724 make_binding_level ()
13725 {
13726   /* NOSTRICT */
13727   return (struct binding_level *) xmalloc (sizeof (struct binding_level));
13728 }
13729
13730 /* Save and restore the variables in this file and elsewhere
13731    that keep track of the progress of compilation of the current function.
13732    Used for nested functions.  */
13733
13734 struct f_function
13735 {
13736   struct f_function *next;
13737   tree named_labels;
13738   tree shadowed_labels;
13739   struct binding_level *binding_level;
13740 };
13741
13742 struct f_function *f_function_chain;
13743
13744 /* Restore the variables used during compilation of a C function.  */
13745
13746 static void
13747 pop_f_function_context ()
13748 {
13749   struct f_function *p = f_function_chain;
13750   tree link;
13751
13752   /* Bring back all the labels that were shadowed.  */
13753   for (link = shadowed_labels; link; link = TREE_CHAIN (link))
13754     if (DECL_NAME (TREE_VALUE (link)) != 0)
13755       IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link)))
13756         = TREE_VALUE (link);
13757
13758   if (current_function_decl != error_mark_node
13759       && DECL_SAVED_INSNS (current_function_decl) == 0)
13760     {
13761       /* Stop pointing to the local nodes about to be freed.  */
13762       /* But DECL_INITIAL must remain nonzero so we know this was an actual
13763          function definition.  */
13764       DECL_INITIAL (current_function_decl) = error_mark_node;
13765       DECL_ARGUMENTS (current_function_decl) = 0;
13766     }
13767
13768   pop_function_context ();
13769
13770   f_function_chain = p->next;
13771
13772   named_labels = p->named_labels;
13773   shadowed_labels = p->shadowed_labels;
13774   current_binding_level = p->binding_level;
13775
13776   free (p);
13777 }
13778
13779 /* Save and reinitialize the variables
13780    used during compilation of a C function.  */
13781
13782 static void
13783 push_f_function_context ()
13784 {
13785   struct f_function *p
13786   = (struct f_function *) xmalloc (sizeof (struct f_function));
13787
13788   push_function_context ();
13789
13790   p->next = f_function_chain;
13791   f_function_chain = p;
13792
13793   p->named_labels = named_labels;
13794   p->shadowed_labels = shadowed_labels;
13795   p->binding_level = current_binding_level;
13796 }
13797
13798 static void
13799 push_parm_decl (tree parm)
13800 {
13801   int old_immediate_size_expand = immediate_size_expand;
13802
13803   /* Don't try computing parm sizes now -- wait till fn is called.  */
13804
13805   immediate_size_expand = 0;
13806
13807   /* Fill in arg stuff.  */
13808
13809   DECL_ARG_TYPE (parm) = TREE_TYPE (parm);
13810   DECL_ARG_TYPE_AS_WRITTEN (parm) = TREE_TYPE (parm);
13811   TREE_READONLY (parm) = 1;     /* All implementation args are read-only. */
13812
13813   parm = pushdecl (parm);
13814
13815   immediate_size_expand = old_immediate_size_expand;
13816
13817   finish_decl (parm, NULL_TREE, FALSE);
13818 }
13819
13820 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate.  */
13821
13822 static tree
13823 pushdecl_top_level (x)
13824      tree x;
13825 {
13826   register tree t;
13827   register struct binding_level *b = current_binding_level;
13828   register tree f = current_function_decl;
13829
13830   current_binding_level = global_binding_level;
13831   current_function_decl = NULL_TREE;
13832   t = pushdecl (x);
13833   current_binding_level = b;
13834   current_function_decl = f;
13835   return t;
13836 }
13837
13838 /* Store the list of declarations of the current level.
13839    This is done for the parameter declarations of a function being defined,
13840    after they are modified in the light of any missing parameters.  */
13841
13842 static tree
13843 storedecls (decls)
13844      tree decls;
13845 {
13846   return current_binding_level->names = decls;
13847 }
13848
13849 /* Store the parameter declarations into the current function declaration.
13850    This is called after parsing the parameter declarations, before
13851    digesting the body of the function.
13852
13853    For an old-style definition, modify the function's type
13854    to specify at least the number of arguments.  */
13855
13856 static void
13857 store_parm_decls (int is_main_program UNUSED)
13858 {
13859   register tree fndecl = current_function_decl;
13860
13861   if (fndecl == error_mark_node)
13862     return;
13863
13864   /* This is a chain of PARM_DECLs from old-style parm declarations.  */
13865   DECL_ARGUMENTS (fndecl) = storedecls (nreverse (getdecls ()));
13866
13867   /* Initialize the RTL code for the function.  */
13868
13869   init_function_start (fndecl, input_filename, lineno);
13870
13871   /* Set up parameters and prepare for return, for the function.  */
13872
13873   expand_function_start (fndecl, 0);
13874 }
13875
13876 static tree
13877 start_decl (tree decl, bool is_top_level)
13878 {
13879   register tree tem;
13880   bool at_top_level = (current_binding_level == global_binding_level);
13881   bool top_level = is_top_level || at_top_level;
13882
13883   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13884      level anyway.  */
13885   assert (!is_top_level || !at_top_level);
13886
13887   if (DECL_INITIAL (decl) != NULL_TREE)
13888     {
13889       assert (DECL_INITIAL (decl) == error_mark_node);
13890       assert (!DECL_EXTERNAL (decl));
13891     }
13892   else if (top_level)
13893     assert ((TREE_STATIC (decl) == 1) || DECL_EXTERNAL (decl) == 1);
13894
13895   /* For Fortran, we by default put things in .common when possible.  */
13896   DECL_COMMON (decl) = 1;
13897
13898   /* Add this decl to the current binding level. TEM may equal DECL or it may
13899      be a previous decl of the same name.  */
13900   if (is_top_level)
13901     tem = pushdecl_top_level (decl);
13902   else
13903     tem = pushdecl (decl);
13904
13905   /* For a local variable, define the RTL now.  */
13906   if (!top_level
13907   /* But not if this is a duplicate decl and we preserved the rtl from the
13908      previous one (which may or may not happen).  */
13909       && !DECL_RTL_SET_P (tem))
13910     {
13911       if (TYPE_SIZE (TREE_TYPE (tem)) != 0)
13912         expand_decl (tem);
13913       else if (TREE_CODE (TREE_TYPE (tem)) == ARRAY_TYPE
13914                && DECL_INITIAL (tem) != 0)
13915         expand_decl (tem);
13916     }
13917
13918   return tem;
13919 }
13920
13921 /* Create the FUNCTION_DECL for a function definition.
13922    DECLSPECS and DECLARATOR are the parts of the declaration;
13923    they describe the function's name and the type it returns,
13924    but twisted together in a fashion that parallels the syntax of C.
13925
13926    This function creates a binding context for the function body
13927    as well as setting up the FUNCTION_DECL in current_function_decl.
13928
13929    Returns 1 on success.  If the DECLARATOR is not suitable for a function
13930    (it defines a datum instead), we return 0, which tells
13931    ffe_parse_file to report a parse error.
13932
13933    NESTED is nonzero for a function nested within another function.  */
13934
13935 static void
13936 start_function (tree name, tree type, int nested, int public)
13937 {
13938   tree decl1;
13939   tree restype;
13940   int old_immediate_size_expand = immediate_size_expand;
13941
13942   named_labels = 0;
13943   shadowed_labels = 0;
13944
13945   /* Don't expand any sizes in the return type of the function.  */
13946   immediate_size_expand = 0;
13947
13948   if (nested)
13949     {
13950       assert (!public);
13951       assert (current_function_decl != NULL_TREE);
13952       assert (DECL_CONTEXT (current_function_decl) == NULL_TREE);
13953     }
13954   else
13955     {
13956       assert (current_function_decl == NULL_TREE);
13957     }
13958
13959   if (TREE_CODE (type) == ERROR_MARK)
13960     decl1 = current_function_decl = error_mark_node;
13961   else
13962     {
13963       decl1 = build_decl (FUNCTION_DECL,
13964                           name,
13965                           type);
13966       TREE_PUBLIC (decl1) = public ? 1 : 0;
13967       if (nested)
13968         DECL_INLINE (decl1) = 1;
13969       TREE_STATIC (decl1) = 1;
13970       DECL_EXTERNAL (decl1) = 0;
13971
13972       announce_function (decl1);
13973
13974       /* Make the init_value nonzero so pushdecl knows this is not tentative.
13975          error_mark_node is replaced below (in poplevel) with the BLOCK.  */
13976       DECL_INITIAL (decl1) = error_mark_node;
13977
13978       /* Record the decl so that the function name is defined. If we already have
13979          a decl for this name, and it is a FUNCTION_DECL, use the old decl.  */
13980
13981       current_function_decl = pushdecl (decl1);
13982     }
13983
13984   if (!nested)
13985     ffecom_outer_function_decl_ = current_function_decl;
13986
13987   pushlevel (0);
13988   current_binding_level->prep_state = 2;
13989
13990   if (TREE_CODE (current_function_decl) != ERROR_MARK)
13991     {
13992       make_decl_rtl (current_function_decl, NULL);
13993
13994       restype = TREE_TYPE (TREE_TYPE (current_function_decl));
13995       DECL_RESULT (current_function_decl)
13996         = build_decl (RESULT_DECL, NULL_TREE, restype);
13997     }
13998
13999   if (!nested && (TREE_CODE (current_function_decl) != ERROR_MARK))
14000     TREE_ADDRESSABLE (current_function_decl) = 1;
14001
14002   immediate_size_expand = old_immediate_size_expand;
14003 }
14004 \f
14005 /* Here are the public functions the GNU back end needs.  */
14006
14007 tree
14008 convert (type, expr)
14009      tree type, expr;
14010 {
14011   register tree e = expr;
14012   register enum tree_code code = TREE_CODE (type);
14013
14014   if (type == TREE_TYPE (e)
14015       || TREE_CODE (e) == ERROR_MARK)
14016     return e;
14017   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
14018     return fold (build1 (NOP_EXPR, type, e));
14019   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
14020       || code == ERROR_MARK)
14021     return error_mark_node;
14022   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
14023     {
14024       assert ("void value not ignored as it ought to be" == NULL);
14025       return error_mark_node;
14026     }
14027   if (code == VOID_TYPE)
14028     return build1 (CONVERT_EXPR, type, e);
14029   if ((code != RECORD_TYPE)
14030       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
14031     e = ffecom_1 (REALPART_EXPR, TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e))),
14032                   e);
14033   if (code == INTEGER_TYPE || code == ENUMERAL_TYPE)
14034     return fold (convert_to_integer (type, e));
14035   if (code == POINTER_TYPE)
14036     return fold (convert_to_pointer (type, e));
14037   if (code == REAL_TYPE)
14038     return fold (convert_to_real (type, e));
14039   if (code == COMPLEX_TYPE)
14040     return fold (convert_to_complex (type, e));
14041   if (code == RECORD_TYPE)
14042     return fold (ffecom_convert_to_complex_ (type, e));
14043
14044   assert ("conversion to non-scalar type requested" == NULL);
14045   return error_mark_node;
14046 }
14047
14048 /* Return the list of declarations of the current level.
14049    Note that this list is in reverse order unless/until
14050    you nreverse it; and when you do nreverse it, you must
14051    store the result back using `storedecls' or you will lose.  */
14052
14053 tree
14054 getdecls ()
14055 {
14056   return current_binding_level->names;
14057 }
14058
14059 /* Nonzero if we are currently in the global binding level.  */
14060
14061 int
14062 global_bindings_p ()
14063 {
14064   return current_binding_level == global_binding_level;
14065 }
14066
14067 /* Print an error message for invalid use of an incomplete type.
14068    VALUE is the expression that was used (or 0 if that isn't known)
14069    and TYPE is the type that was invalid.  */
14070
14071 void
14072 incomplete_type_error (value, type)
14073      tree value UNUSED;
14074      tree type;
14075 {
14076   if (TREE_CODE (type) == ERROR_MARK)
14077     return;
14078
14079   assert ("incomplete type?!?" == NULL);
14080 }
14081
14082 /* Mark ARG for GC.  */
14083 static void
14084 mark_binding_level (void *arg)
14085 {
14086   struct binding_level *level = *(struct binding_level **) arg;
14087
14088   while (level)
14089     {
14090       ggc_mark_tree (level->names);
14091       ggc_mark_tree (level->blocks);
14092       ggc_mark_tree (level->this_block);
14093       level = level->level_chain;
14094     }
14095 }
14096
14097 static void
14098 ffecom_init_decl_processing ()
14099 {
14100   static tree *const tree_roots[] = {
14101     &current_function_decl,
14102     &string_type_node,
14103     &ffecom_tree_fun_type_void,
14104     &ffecom_integer_zero_node,
14105     &ffecom_integer_one_node,
14106     &ffecom_tree_subr_type,
14107     &ffecom_tree_ptr_to_subr_type,
14108     &ffecom_tree_blockdata_type,
14109     &ffecom_tree_xargc_,
14110     &ffecom_f2c_integer_type_node,
14111     &ffecom_f2c_ptr_to_integer_type_node,
14112     &ffecom_f2c_address_type_node,
14113     &ffecom_f2c_real_type_node,
14114     &ffecom_f2c_ptr_to_real_type_node,
14115     &ffecom_f2c_doublereal_type_node,
14116     &ffecom_f2c_complex_type_node,
14117     &ffecom_f2c_doublecomplex_type_node,
14118     &ffecom_f2c_longint_type_node,
14119     &ffecom_f2c_logical_type_node,
14120     &ffecom_f2c_flag_type_node,
14121     &ffecom_f2c_ftnlen_type_node,
14122     &ffecom_f2c_ftnlen_zero_node,
14123     &ffecom_f2c_ftnlen_one_node,
14124     &ffecom_f2c_ftnlen_two_node,
14125     &ffecom_f2c_ptr_to_ftnlen_type_node,
14126     &ffecom_f2c_ftnint_type_node,
14127     &ffecom_f2c_ptr_to_ftnint_type_node,
14128     &ffecom_outer_function_decl_,
14129     &ffecom_previous_function_decl_,
14130     &ffecom_which_entrypoint_decl_,
14131     &ffecom_float_zero_,
14132     &ffecom_float_half_,
14133     &ffecom_double_zero_,
14134     &ffecom_double_half_,
14135     &ffecom_func_result_,
14136     &ffecom_func_length_,
14137     &ffecom_multi_type_node_,
14138     &ffecom_multi_retval_,
14139     &named_labels,
14140     &shadowed_labels
14141   };
14142   size_t i;
14143
14144   malloc_init ();
14145
14146   /* Record our roots.  */
14147   for (i = 0; i < ARRAY_SIZE (tree_roots); i++)
14148     ggc_add_tree_root (tree_roots[i], 1);
14149   ggc_add_tree_root (&ffecom_tree_type[0][0],
14150                      FFEINFO_basictype*FFEINFO_kindtype);
14151   ggc_add_tree_root (&ffecom_tree_fun_type[0][0],
14152                      FFEINFO_basictype*FFEINFO_kindtype);
14153   ggc_add_tree_root (&ffecom_tree_ptr_to_fun_type[0][0],
14154                      FFEINFO_basictype*FFEINFO_kindtype);
14155   ggc_add_tree_root (ffecom_gfrt_, FFECOM_gfrt);
14156   ggc_add_root (&current_binding_level, 1, sizeof current_binding_level,
14157                 mark_binding_level);
14158   ggc_add_root (&free_binding_level, 1, sizeof current_binding_level,
14159                 mark_binding_level);
14160   ggc_add_root (&tracker_head, 1, sizeof tracker_head, mark_tracker_head);
14161
14162   ffe_init_0 ();
14163 }
14164
14165 /* Delete the node BLOCK from the current binding level.
14166    This is used for the block inside a stmt expr ({...})
14167    so that the block can be reinserted where appropriate.  */
14168
14169 static void
14170 delete_block (block)
14171      tree block;
14172 {
14173   tree t;
14174   if (current_binding_level->blocks == block)
14175     current_binding_level->blocks = TREE_CHAIN (block);
14176   for (t = current_binding_level->blocks; t;)
14177     {
14178       if (TREE_CHAIN (t) == block)
14179         TREE_CHAIN (t) = TREE_CHAIN (block);
14180       else
14181         t = TREE_CHAIN (t);
14182     }
14183   TREE_CHAIN (block) = NULL;
14184   /* Clear TREE_USED which is always set by poplevel.
14185      The flag is set again if insert_block is called.  */
14186   TREE_USED (block) = 0;
14187 }
14188
14189 void
14190 insert_block (block)
14191      tree block;
14192 {
14193   TREE_USED (block) = 1;
14194   current_binding_level->blocks
14195     = chainon (current_binding_level->blocks, block);
14196 }
14197
14198 /* Each front end provides its own.  */
14199 static const char *ffe_init PARAMS ((const char *));
14200 static void ffe_finish PARAMS ((void));
14201 static void ffe_init_options PARAMS ((void));
14202 static void ffe_print_identifier PARAMS ((FILE *, tree, int));
14203
14204 #undef  LANG_HOOKS_NAME
14205 #define LANG_HOOKS_NAME                 "GNU F77"
14206 #undef  LANG_HOOKS_INIT
14207 #define LANG_HOOKS_INIT                 ffe_init
14208 #undef  LANG_HOOKS_FINISH
14209 #define LANG_HOOKS_FINISH               ffe_finish
14210 #undef  LANG_HOOKS_INIT_OPTIONS
14211 #define LANG_HOOKS_INIT_OPTIONS         ffe_init_options
14212 #undef  LANG_HOOKS_DECODE_OPTION
14213 #define LANG_HOOKS_DECODE_OPTION        ffe_decode_option
14214 #undef  LANG_HOOKS_PARSE_FILE
14215 #define LANG_HOOKS_PARSE_FILE           ffe_parse_file
14216 #undef  LANG_HOOKS_PRINT_IDENTIFIER
14217 #define LANG_HOOKS_PRINT_IDENTIFIER     ffe_print_identifier
14218
14219 /* We do not wish to use alias-set based aliasing at all.  Used in the
14220    extreme (every object with its own set, with equivalences recorded) it
14221    might be helpful, but there are problems when it comes to inlining.  We
14222    get on ok with flag_argument_noalias, and alias-set aliasing does
14223    currently limit how stack slots can be reused, which is a lose.  */
14224 #undef LANG_HOOKS_GET_ALIAS_SET
14225 #define LANG_HOOKS_GET_ALIAS_SET hook_get_alias_set_0
14226
14227 const struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER;
14228
14229 /* Table indexed by tree code giving a string containing a character
14230    classifying the tree code.  Possibilities are
14231    t, d, s, c, r, <, 1, 2 and e.  See tree.def for details.  */
14232
14233 #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) TYPE,
14234
14235 const char tree_code_type[] = {
14236 #include "tree.def"
14237 };
14238 #undef DEFTREECODE
14239
14240 /* Table indexed by tree code giving number of expression
14241    operands beyond the fixed part of the node structure.
14242    Not used for types or decls.  */
14243
14244 #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) LENGTH,
14245
14246 const unsigned char tree_code_length[] = {
14247 #include "tree.def"
14248 };
14249 #undef DEFTREECODE
14250
14251 /* Names of tree components.
14252    Used for printing out the tree and error messages.  */
14253 #define DEFTREECODE(SYM, NAME, TYPE, LEN) NAME,
14254
14255 const char *const tree_code_name[] = {
14256 #include "tree.def"
14257 };
14258 #undef DEFTREECODE
14259
14260 static const char *
14261 ffe_init (filename)
14262      const char *filename;
14263 {
14264   /* Open input file.  */
14265   if (filename == 0 || !strcmp (filename, "-"))
14266     {
14267       finput = stdin;
14268       filename = "stdin";
14269     }
14270   else
14271     finput = fopen (filename, "r");
14272   if (finput == 0)
14273     fatal_io_error ("can't open %s", filename);
14274
14275 #ifdef IO_BUFFER_SIZE
14276   setvbuf (finput, (char *) xmalloc (IO_BUFFER_SIZE), _IOFBF, IO_BUFFER_SIZE);
14277 #endif
14278
14279   ffecom_init_decl_processing ();
14280   decl_printable_name = lang_printable_name;
14281   print_error_function = lang_print_error_function;
14282
14283   /* If the file is output from cpp, it should contain a first line
14284      `# 1 "real-filename"', and the current design of gcc (toplev.c
14285      in particular and the way it sets up information relied on by
14286      INCLUDE) requires that we read this now, and store the
14287      "real-filename" info in master_input_filename.  Ask the lexer
14288      to try doing this.  */
14289   ffelex_hash_kludge (finput);
14290
14291   /* FIXME: The ffelex_hash_kludge code needs to be cleaned up to
14292      return the new file name.  */
14293   if (main_input_filename)
14294     filename = main_input_filename;
14295
14296   return filename;
14297 }
14298
14299 static void
14300 ffe_finish ()
14301 {
14302   ffe_terminate_0 ();
14303
14304   if (ffe_is_ffedebug ())
14305     malloc_pool_display (malloc_pool_image ());
14306
14307   fclose (finput);
14308 }
14309
14310 static void
14311 ffe_init_options ()
14312 {
14313   /* Set default options for Fortran.  */
14314   flag_move_all_movables = 1;
14315   flag_reduce_all_givs = 1;
14316   flag_argument_noalias = 2;
14317   flag_merge_constants = 2;
14318   flag_errno_math = 0;
14319   flag_complex_divide_method = 1;
14320 }
14321
14322 int
14323 mark_addressable (exp)
14324      tree exp;
14325 {
14326   register tree x = exp;
14327   while (1)
14328     switch (TREE_CODE (x))
14329       {
14330       case ADDR_EXPR:
14331       case COMPONENT_REF:
14332       case ARRAY_REF:
14333         x = TREE_OPERAND (x, 0);
14334         break;
14335
14336       case CONSTRUCTOR:
14337         TREE_ADDRESSABLE (x) = 1;
14338         return 1;
14339
14340       case VAR_DECL:
14341       case CONST_DECL:
14342       case PARM_DECL:
14343       case RESULT_DECL:
14344         if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x)
14345             && DECL_NONLOCAL (x))
14346           {
14347             if (TREE_PUBLIC (x))
14348               {
14349                 assert ("address of global register var requested" == NULL);
14350                 return 0;
14351               }
14352             assert ("address of register variable requested" == NULL);
14353           }
14354         else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x))
14355           {
14356             if (TREE_PUBLIC (x))
14357               {
14358                 assert ("address of global register var requested" == NULL);
14359                 return 0;
14360               }
14361             assert ("address of register var requested" == NULL);
14362           }
14363         put_var_into_stack (x);
14364
14365         /* drops in */
14366       case FUNCTION_DECL:
14367         TREE_ADDRESSABLE (x) = 1;
14368 #if 0                           /* poplevel deals with this now.  */
14369         if (DECL_CONTEXT (x) == 0)
14370           TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x)) = 1;
14371 #endif
14372
14373       default:
14374         return 1;
14375       }
14376 }
14377
14378 /* If DECL has a cleanup, build and return that cleanup here.
14379    This is a callback called by expand_expr.  */
14380
14381 tree
14382 maybe_build_cleanup (decl)
14383      tree decl UNUSED;
14384 {
14385   /* There are no cleanups in Fortran.  */
14386   return NULL_TREE;
14387 }
14388
14389 /* Exit a binding level.
14390    Pop the level off, and restore the state of the identifier-decl mappings
14391    that were in effect when this level was entered.
14392
14393    If KEEP is nonzero, this level had explicit declarations, so
14394    and create a "block" (a BLOCK node) for the level
14395    to record its declarations and subblocks for symbol table output.
14396
14397    If FUNCTIONBODY is nonzero, this level is the body of a function,
14398    so create a block as if KEEP were set and also clear out all
14399    label names.
14400
14401    If REVERSE is nonzero, reverse the order of decls before putting
14402    them into the BLOCK.  */
14403
14404 tree
14405 poplevel (keep, reverse, functionbody)
14406      int keep;
14407      int reverse;
14408      int functionbody;
14409 {
14410   register tree link;
14411   /* The chain of decls was accumulated in reverse order.
14412      Put it into forward order, just for cleanliness.  */
14413   tree decls;
14414   tree subblocks = current_binding_level->blocks;
14415   tree block = 0;
14416   tree decl;
14417   int block_previously_created;
14418
14419   /* Get the decls in the order they were written.
14420      Usually current_binding_level->names is in reverse order.
14421      But parameter decls were previously put in forward order.  */
14422
14423   if (reverse)
14424     current_binding_level->names
14425       = decls = nreverse (current_binding_level->names);
14426   else
14427     decls = current_binding_level->names;
14428
14429   /* Output any nested inline functions within this block
14430      if they weren't already output.  */
14431
14432   for (decl = decls; decl; decl = TREE_CHAIN (decl))
14433     if (TREE_CODE (decl) == FUNCTION_DECL
14434         && ! TREE_ASM_WRITTEN (decl)
14435         && DECL_INITIAL (decl) != 0
14436         && TREE_ADDRESSABLE (decl))
14437       {
14438         /* If this decl was copied from a file-scope decl
14439            on account of a block-scope extern decl,
14440            propagate TREE_ADDRESSABLE to the file-scope decl.
14441
14442            DECL_ABSTRACT_ORIGIN can be set to itself if warn_return_type is
14443            true, since then the decl goes through save_for_inline_copying.  */
14444         if (DECL_ABSTRACT_ORIGIN (decl) != 0
14445             && DECL_ABSTRACT_ORIGIN (decl) != decl)
14446           TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl)) = 1;
14447         else if (DECL_SAVED_INSNS (decl) != 0)
14448           {
14449             push_function_context ();
14450             output_inline_function (decl);
14451             pop_function_context ();
14452           }
14453       }
14454
14455   /* If there were any declarations or structure tags in that level,
14456      or if this level is a function body,
14457      create a BLOCK to record them for the life of this function.  */
14458
14459   block = 0;
14460   block_previously_created = (current_binding_level->this_block != 0);
14461   if (block_previously_created)
14462     block = current_binding_level->this_block;
14463   else if (keep || functionbody)
14464     block = make_node (BLOCK);
14465   if (block != 0)
14466     {
14467       BLOCK_VARS (block) = decls;
14468       BLOCK_SUBBLOCKS (block) = subblocks;
14469     }
14470
14471   /* In each subblock, record that this is its superior.  */
14472
14473   for (link = subblocks; link; link = TREE_CHAIN (link))
14474     BLOCK_SUPERCONTEXT (link) = block;
14475
14476   /* Clear out the meanings of the local variables of this level.  */
14477
14478   for (link = decls; link; link = TREE_CHAIN (link))
14479     {
14480       if (DECL_NAME (link) != 0)
14481         {
14482           /* If the ident. was used or addressed via a local extern decl,
14483              don't forget that fact.  */
14484           if (DECL_EXTERNAL (link))
14485             {
14486               if (TREE_USED (link))
14487                 TREE_USED (DECL_NAME (link)) = 1;
14488               if (TREE_ADDRESSABLE (link))
14489                 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (link)) = 1;
14490             }
14491           IDENTIFIER_LOCAL_VALUE (DECL_NAME (link)) = 0;
14492         }
14493     }
14494
14495   /* If the level being exited is the top level of a function,
14496      check over all the labels, and clear out the current
14497      (function local) meanings of their names.  */
14498
14499   if (functionbody)
14500     {
14501       /* If this is the top level block of a function,
14502          the vars are the function's parameters.
14503          Don't leave them in the BLOCK because they are
14504          found in the FUNCTION_DECL instead.  */
14505
14506       BLOCK_VARS (block) = 0;
14507     }
14508
14509   /* Pop the current level, and free the structure for reuse.  */
14510
14511   {
14512     register struct binding_level *level = current_binding_level;
14513     current_binding_level = current_binding_level->level_chain;
14514
14515     level->level_chain = free_binding_level;
14516     free_binding_level = level;
14517   }
14518
14519   /* Dispose of the block that we just made inside some higher level.  */
14520   if (functionbody
14521       && current_function_decl != error_mark_node)
14522     DECL_INITIAL (current_function_decl) = block;
14523   else if (block)
14524     {
14525       if (!block_previously_created)
14526         current_binding_level->blocks
14527           = chainon (current_binding_level->blocks, block);
14528     }
14529   /* If we did not make a block for the level just exited,
14530      any blocks made for inner levels
14531      (since they cannot be recorded as subblocks in that level)
14532      must be carried forward so they will later become subblocks
14533      of something else.  */
14534   else if (subblocks)
14535     current_binding_level->blocks
14536       = chainon (current_binding_level->blocks, subblocks);
14537
14538   if (block)
14539     TREE_USED (block) = 1;
14540   return block;
14541 }
14542
14543 static void
14544 ffe_print_identifier (file, node, indent)
14545      FILE *file;
14546      tree node;
14547      int indent;
14548 {
14549   print_node (file, "global", IDENTIFIER_GLOBAL_VALUE (node), indent + 4);
14550   print_node (file, "local", IDENTIFIER_LOCAL_VALUE (node), indent + 4);
14551 }
14552
14553 /* Record a decl-node X as belonging to the current lexical scope.
14554    Check for errors (such as an incompatible declaration for the same
14555    name already seen in the same scope).
14556
14557    Returns either X or an old decl for the same name.
14558    If an old decl is returned, it may have been smashed
14559    to agree with what X says.  */
14560
14561 tree
14562 pushdecl (x)
14563      tree x;
14564 {
14565   register tree t;
14566   register tree name = DECL_NAME (x);
14567   register struct binding_level *b = current_binding_level;
14568
14569   if ((TREE_CODE (x) == FUNCTION_DECL)
14570       && (DECL_INITIAL (x) == 0)
14571       && DECL_EXTERNAL (x))
14572     DECL_CONTEXT (x) = NULL_TREE;
14573   else
14574     DECL_CONTEXT (x) = current_function_decl;
14575
14576   if (name)
14577     {
14578       if (IDENTIFIER_INVENTED (name))
14579         {
14580           DECL_ARTIFICIAL (x) = 1;
14581           DECL_IN_SYSTEM_HEADER (x) = 1;
14582         }
14583
14584       t = lookup_name_current_level (name);
14585
14586       assert ((t == NULL_TREE) || (DECL_CONTEXT (x) == NULL_TREE));
14587
14588       /* Don't push non-parms onto list for parms until we understand
14589          why we're doing this and whether it works.  */
14590
14591       assert ((b == global_binding_level)
14592               || !ffecom_transform_only_dummies_
14593               || TREE_CODE (x) == PARM_DECL);
14594
14595       if ((t != NULL_TREE) && duplicate_decls (x, t))
14596         return t;
14597
14598       /* If we are processing a typedef statement, generate a whole new
14599          ..._TYPE node (which will be just an variant of the existing
14600          ..._TYPE node with identical properties) and then install the
14601          TYPE_DECL node generated to represent the typedef name as the
14602          TYPE_NAME of this brand new (duplicate) ..._TYPE node.
14603
14604          The whole point here is to end up with a situation where each and every
14605          ..._TYPE node the compiler creates will be uniquely associated with
14606          AT MOST one node representing a typedef name. This way, even though
14607          the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL
14608          (i.e. "typedef name") nodes very early on, later parts of the
14609          compiler can always do the reverse translation and get back the
14610          corresponding typedef name.  For example, given:
14611
14612          typedef struct S MY_TYPE; MY_TYPE object;
14613
14614          Later parts of the compiler might only know that `object' was of type
14615          `struct S' if it were not for code just below.  With this code
14616          however, later parts of the compiler see something like:
14617
14618          struct S' == struct S typedef struct S' MY_TYPE; struct S' object;
14619
14620          And they can then deduce (from the node for type struct S') that the
14621          original object declaration was:
14622
14623          MY_TYPE object;
14624
14625          Being able to do this is important for proper support of protoize, and
14626          also for generating precise symbolic debugging information which
14627          takes full account of the programmer's (typedef) vocabulary.
14628
14629          Obviously, we don't want to generate a duplicate ..._TYPE node if the
14630          TYPE_DECL node that we are now processing really represents a
14631          standard built-in type.
14632
14633          Since all standard types are effectively declared at line zero in the
14634          source file, we can easily check to see if we are working on a
14635          standard type by checking the current value of lineno.  */
14636
14637       if (TREE_CODE (x) == TYPE_DECL)
14638         {
14639           if (DECL_SOURCE_LINE (x) == 0)
14640             {
14641               if (TYPE_NAME (TREE_TYPE (x)) == 0)
14642                 TYPE_NAME (TREE_TYPE (x)) = x;
14643             }
14644           else if (TREE_TYPE (x) != error_mark_node)
14645             {
14646               tree tt = TREE_TYPE (x);
14647
14648               tt = build_type_copy (tt);
14649               TYPE_NAME (tt) = x;
14650               TREE_TYPE (x) = tt;
14651             }
14652         }
14653
14654       /* This name is new in its binding level. Install the new declaration
14655          and return it.  */
14656       if (b == global_binding_level)
14657         IDENTIFIER_GLOBAL_VALUE (name) = x;
14658       else
14659         IDENTIFIER_LOCAL_VALUE (name) = x;
14660     }
14661
14662   /* Put decls on list in reverse order. We will reverse them later if
14663      necessary.  */
14664   TREE_CHAIN (x) = b->names;
14665   b->names = x;
14666
14667   return x;
14668 }
14669
14670 /* Nonzero if the current level needs to have a BLOCK made.  */
14671
14672 static int
14673 kept_level_p ()
14674 {
14675   tree decl;
14676
14677   for (decl = current_binding_level->names;
14678        decl;
14679        decl = TREE_CHAIN (decl))
14680     {
14681       if (TREE_USED (decl) || TREE_CODE (decl) != VAR_DECL
14682           || (DECL_NAME (decl) && ! DECL_ARTIFICIAL (decl)))
14683         /* Currently, there aren't supposed to be non-artificial names
14684            at other than the top block for a function -- they're
14685            believed to always be temps.  But it's wise to check anyway.  */
14686         return 1;
14687     }
14688   return 0;
14689 }
14690
14691 /* Enter a new binding level.
14692    If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
14693    not for that of tags.  */
14694
14695 void
14696 pushlevel (tag_transparent)
14697      int tag_transparent;
14698 {
14699   register struct binding_level *newlevel = NULL_BINDING_LEVEL;
14700
14701   assert (! tag_transparent);
14702
14703   if (current_binding_level == global_binding_level)
14704     {
14705       named_labels = 0;
14706     }
14707
14708   /* Reuse or create a struct for this binding level.  */
14709
14710   if (free_binding_level)
14711     {
14712       newlevel = free_binding_level;
14713       free_binding_level = free_binding_level->level_chain;
14714     }
14715   else
14716     {
14717       newlevel = make_binding_level ();
14718     }
14719
14720   /* Add this level to the front of the chain (stack) of levels that
14721      are active.  */
14722
14723   *newlevel = clear_binding_level;
14724   newlevel->level_chain = current_binding_level;
14725   current_binding_level = newlevel;
14726 }
14727
14728 /* Set the BLOCK node for the innermost scope
14729    (the one we are currently in).  */
14730
14731 void
14732 set_block (block)
14733      register tree block;
14734 {
14735   current_binding_level->this_block = block;
14736   current_binding_level->names = chainon (current_binding_level->names,
14737                                           BLOCK_VARS (block));
14738   current_binding_level->blocks = chainon (current_binding_level->blocks,
14739                                            BLOCK_SUBBLOCKS (block));
14740 }
14741
14742 tree
14743 signed_or_unsigned_type (unsignedp, type)
14744      int unsignedp;
14745      tree type;
14746 {
14747   tree type2;
14748
14749   if (! INTEGRAL_TYPE_P (type))
14750     return type;
14751   if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node))
14752     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
14753   if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node))
14754     return unsignedp ? unsigned_type_node : integer_type_node;
14755   if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node))
14756     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
14757   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node))
14758     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
14759   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node))
14760     return (unsignedp ? long_long_unsigned_type_node
14761             : long_long_integer_type_node);
14762
14763   type2 = type_for_size (TYPE_PRECISION (type), unsignedp);
14764   if (type2 == NULL_TREE)
14765     return type;
14766
14767   return type2;
14768 }
14769
14770 tree
14771 signed_type (type)
14772      tree type;
14773 {
14774   tree type1 = TYPE_MAIN_VARIANT (type);
14775   ffeinfoKindtype kt;
14776   tree type2;
14777
14778   if (type1 == unsigned_char_type_node || type1 == char_type_node)
14779     return signed_char_type_node;
14780   if (type1 == unsigned_type_node)
14781     return integer_type_node;
14782   if (type1 == short_unsigned_type_node)
14783     return short_integer_type_node;
14784   if (type1 == long_unsigned_type_node)
14785     return long_integer_type_node;
14786   if (type1 == long_long_unsigned_type_node)
14787     return long_long_integer_type_node;
14788 #if 0   /* gcc/c-* files only */
14789   if (type1 == unsigned_intDI_type_node)
14790     return intDI_type_node;
14791   if (type1 == unsigned_intSI_type_node)
14792     return intSI_type_node;
14793   if (type1 == unsigned_intHI_type_node)
14794     return intHI_type_node;
14795   if (type1 == unsigned_intQI_type_node)
14796     return intQI_type_node;
14797 #endif
14798
14799   type2 = type_for_size (TYPE_PRECISION (type1), 0);
14800   if (type2 != NULL_TREE)
14801     return type2;
14802
14803   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
14804     {
14805       type2 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
14806
14807       if (type1 == type2)
14808         return ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
14809     }
14810
14811   return type;
14812 }
14813
14814 /* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
14815    or validate its data type for an `if' or `while' statement or ?..: exp.
14816
14817    This preparation consists of taking the ordinary
14818    representation of an expression expr and producing a valid tree
14819    boolean expression describing whether expr is nonzero.  We could
14820    simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
14821    but we optimize comparisons, &&, ||, and !.
14822
14823    The resulting type should always be `integer_type_node'.  */
14824
14825 tree
14826 truthvalue_conversion (expr)
14827      tree expr;
14828 {
14829   if (TREE_CODE (expr) == ERROR_MARK)
14830     return expr;
14831
14832 #if 0 /* This appears to be wrong for C++.  */
14833   /* These really should return error_mark_node after 2.4 is stable.
14834      But not all callers handle ERROR_MARK properly.  */
14835   switch (TREE_CODE (TREE_TYPE (expr)))
14836     {
14837     case RECORD_TYPE:
14838       error ("struct type value used where scalar is required");
14839       return integer_zero_node;
14840
14841     case UNION_TYPE:
14842       error ("union type value used where scalar is required");
14843       return integer_zero_node;
14844
14845     case ARRAY_TYPE:
14846       error ("array type value used where scalar is required");
14847       return integer_zero_node;
14848
14849     default:
14850       break;
14851     }
14852 #endif /* 0 */
14853
14854   switch (TREE_CODE (expr))
14855     {
14856       /* It is simpler and generates better code to have only TRUTH_*_EXPR
14857          or comparison expressions as truth values at this level.  */
14858 #if 0
14859     case COMPONENT_REF:
14860       /* A one-bit unsigned bit-field is already acceptable.  */
14861       if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr, 1)))
14862           && TREE_UNSIGNED (TREE_OPERAND (expr, 1)))
14863         return expr;
14864       break;
14865 #endif
14866
14867     case EQ_EXPR:
14868       /* It is simpler and generates better code to have only TRUTH_*_EXPR
14869          or comparison expressions as truth values at this level.  */
14870 #if 0
14871       if (integer_zerop (TREE_OPERAND (expr, 1)))
14872         return build_unary_op (TRUTH_NOT_EXPR, TREE_OPERAND (expr, 0), 0);
14873 #endif
14874     case NE_EXPR: case LE_EXPR: case GE_EXPR: case LT_EXPR: case GT_EXPR:
14875     case TRUTH_ANDIF_EXPR:
14876     case TRUTH_ORIF_EXPR:
14877     case TRUTH_AND_EXPR:
14878     case TRUTH_OR_EXPR:
14879     case TRUTH_XOR_EXPR:
14880       TREE_TYPE (expr) = integer_type_node;
14881       return expr;
14882
14883     case ERROR_MARK:
14884       return expr;
14885
14886     case INTEGER_CST:
14887       return integer_zerop (expr) ? integer_zero_node : integer_one_node;
14888
14889     case REAL_CST:
14890       return real_zerop (expr) ? integer_zero_node : integer_one_node;
14891
14892     case ADDR_EXPR:
14893       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 0)))
14894         return build (COMPOUND_EXPR, integer_type_node,
14895                       TREE_OPERAND (expr, 0), integer_one_node);
14896       else
14897         return integer_one_node;
14898
14899     case COMPLEX_EXPR:
14900       return ffecom_2 ((TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1))
14901                         ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
14902                        integer_type_node,
14903                        truthvalue_conversion (TREE_OPERAND (expr, 0)),
14904                        truthvalue_conversion (TREE_OPERAND (expr, 1)));
14905
14906     case NEGATE_EXPR:
14907     case ABS_EXPR:
14908     case FLOAT_EXPR:
14909     case FFS_EXPR:
14910       /* These don't change whether an object is non-zero or zero.  */
14911       return truthvalue_conversion (TREE_OPERAND (expr, 0));
14912
14913     case LROTATE_EXPR:
14914     case RROTATE_EXPR:
14915       /* These don't change whether an object is zero or non-zero, but
14916          we can't ignore them if their second arg has side-effects.  */
14917       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1)))
14918         return build (COMPOUND_EXPR, integer_type_node, TREE_OPERAND (expr, 1),
14919                       truthvalue_conversion (TREE_OPERAND (expr, 0)));
14920       else
14921         return truthvalue_conversion (TREE_OPERAND (expr, 0));
14922
14923     case COND_EXPR:
14924       /* Distribute the conversion into the arms of a COND_EXPR.  */
14925       return fold (build (COND_EXPR, integer_type_node, TREE_OPERAND (expr, 0),
14926                           truthvalue_conversion (TREE_OPERAND (expr, 1)),
14927                           truthvalue_conversion (TREE_OPERAND (expr, 2))));
14928
14929     case CONVERT_EXPR:
14930       /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
14931          since that affects how `default_conversion' will behave.  */
14932       if (TREE_CODE (TREE_TYPE (expr)) == REFERENCE_TYPE
14933           || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) == REFERENCE_TYPE)
14934         break;
14935       /* fall through... */
14936     case NOP_EXPR:
14937       /* If this is widening the argument, we can ignore it.  */
14938       if (TYPE_PRECISION (TREE_TYPE (expr))
14939           >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr, 0))))
14940         return truthvalue_conversion (TREE_OPERAND (expr, 0));
14941       break;
14942
14943     case MINUS_EXPR:
14944       /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize
14945          this case.  */
14946       if (TARGET_FLOAT_FORMAT == IEEE_FLOAT_FORMAT
14947           && TREE_CODE (TREE_TYPE (expr)) == REAL_TYPE)
14948         break;
14949       /* fall through... */
14950     case BIT_XOR_EXPR:
14951       /* This and MINUS_EXPR can be changed into a comparison of the
14952          two objects.  */
14953       if (TREE_TYPE (TREE_OPERAND (expr, 0))
14954           == TREE_TYPE (TREE_OPERAND (expr, 1)))
14955         return ffecom_2 (NE_EXPR, integer_type_node,
14956                          TREE_OPERAND (expr, 0),
14957                          TREE_OPERAND (expr, 1));
14958       return ffecom_2 (NE_EXPR, integer_type_node,
14959                        TREE_OPERAND (expr, 0),
14960                        fold (build1 (NOP_EXPR,
14961                                      TREE_TYPE (TREE_OPERAND (expr, 0)),
14962                                      TREE_OPERAND (expr, 1))));
14963
14964     case BIT_AND_EXPR:
14965       if (integer_onep (TREE_OPERAND (expr, 1)))
14966         return expr;
14967       break;
14968
14969     case MODIFY_EXPR:
14970 #if 0                           /* No such thing in Fortran. */
14971       if (warn_parentheses && C_EXP_ORIGINAL_CODE (expr) == MODIFY_EXPR)
14972         warning ("suggest parentheses around assignment used as truth value");
14973 #endif
14974       break;
14975
14976     default:
14977       break;
14978     }
14979
14980   if (TREE_CODE (TREE_TYPE (expr)) == COMPLEX_TYPE)
14981     return (ffecom_2
14982             ((TREE_SIDE_EFFECTS (expr)
14983               ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
14984              integer_type_node,
14985              truthvalue_conversion (ffecom_1 (REALPART_EXPR,
14986                                               TREE_TYPE (TREE_TYPE (expr)),
14987                                               expr)),
14988              truthvalue_conversion (ffecom_1 (IMAGPART_EXPR,
14989                                               TREE_TYPE (TREE_TYPE (expr)),
14990                                               expr))));
14991
14992   return ffecom_2 (NE_EXPR, integer_type_node,
14993                    expr,
14994                    convert (TREE_TYPE (expr), integer_zero_node));
14995 }
14996
14997 tree
14998 type_for_mode (mode, unsignedp)
14999      enum machine_mode mode;
15000      int unsignedp;
15001 {
15002   int i;
15003   int j;
15004   tree t;
15005
15006   if (mode == TYPE_MODE (integer_type_node))
15007     return unsignedp ? unsigned_type_node : integer_type_node;
15008
15009   if (mode == TYPE_MODE (signed_char_type_node))
15010     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15011
15012   if (mode == TYPE_MODE (short_integer_type_node))
15013     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15014
15015   if (mode == TYPE_MODE (long_integer_type_node))
15016     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15017
15018   if (mode == TYPE_MODE (long_long_integer_type_node))
15019     return unsignedp ? long_long_unsigned_type_node : long_long_integer_type_node;
15020
15021 #if HOST_BITS_PER_WIDE_INT >= 64
15022   if (mode == TYPE_MODE (intTI_type_node))
15023     return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
15024 #endif
15025
15026   if (mode == TYPE_MODE (float_type_node))
15027     return float_type_node;
15028
15029   if (mode == TYPE_MODE (double_type_node))
15030     return double_type_node;
15031
15032   if (mode == TYPE_MODE (build_pointer_type (char_type_node)))
15033     return build_pointer_type (char_type_node);
15034
15035   if (mode == TYPE_MODE (build_pointer_type (integer_type_node)))
15036     return build_pointer_type (integer_type_node);
15037
15038   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
15039     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
15040       {
15041         if (((t = ffecom_tree_type[i][j]) != NULL_TREE)
15042             && (mode == TYPE_MODE (t)))
15043           {
15044             if ((i == FFEINFO_basictypeINTEGER) && unsignedp)
15045               return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][j];
15046             else
15047               return t;
15048           }
15049       }
15050
15051   return 0;
15052 }
15053
15054 tree
15055 type_for_size (bits, unsignedp)
15056      unsigned bits;
15057      int unsignedp;
15058 {
15059   ffeinfoKindtype kt;
15060   tree type_node;
15061
15062   if (bits == TYPE_PRECISION (integer_type_node))
15063     return unsignedp ? unsigned_type_node : integer_type_node;
15064
15065   if (bits == TYPE_PRECISION (signed_char_type_node))
15066     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15067
15068   if (bits == TYPE_PRECISION (short_integer_type_node))
15069     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15070
15071   if (bits == TYPE_PRECISION (long_integer_type_node))
15072     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15073
15074   if (bits == TYPE_PRECISION (long_long_integer_type_node))
15075     return (unsignedp ? long_long_unsigned_type_node
15076             : long_long_integer_type_node);
15077
15078   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15079     {
15080       type_node = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15081
15082       if ((type_node != NULL_TREE) && (bits == TYPE_PRECISION (type_node)))
15083         return unsignedp ? ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]
15084           : type_node;
15085     }
15086
15087   return 0;
15088 }
15089
15090 tree
15091 unsigned_type (type)
15092      tree type;
15093 {
15094   tree type1 = TYPE_MAIN_VARIANT (type);
15095   ffeinfoKindtype kt;
15096   tree type2;
15097
15098   if (type1 == signed_char_type_node || type1 == char_type_node)
15099     return unsigned_char_type_node;
15100   if (type1 == integer_type_node)
15101     return unsigned_type_node;
15102   if (type1 == short_integer_type_node)
15103     return short_unsigned_type_node;
15104   if (type1 == long_integer_type_node)
15105     return long_unsigned_type_node;
15106   if (type1 == long_long_integer_type_node)
15107     return long_long_unsigned_type_node;
15108 #if 0   /* gcc/c-* files only */
15109   if (type1 == intDI_type_node)
15110     return unsigned_intDI_type_node;
15111   if (type1 == intSI_type_node)
15112     return unsigned_intSI_type_node;
15113   if (type1 == intHI_type_node)
15114     return unsigned_intHI_type_node;
15115   if (type1 == intQI_type_node)
15116     return unsigned_intQI_type_node;
15117 #endif
15118
15119   type2 = type_for_size (TYPE_PRECISION (type1), 1);
15120   if (type2 != NULL_TREE)
15121     return type2;
15122
15123   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15124     {
15125       type2 = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15126
15127       if (type1 == type2)
15128         return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
15129     }
15130
15131   return type;
15132 }
15133
15134 void
15135 lang_mark_tree (t)
15136      union tree_node *t ATTRIBUTE_UNUSED;
15137 {
15138   if (TREE_CODE (t) == IDENTIFIER_NODE)
15139     {
15140       struct lang_identifier *i = (struct lang_identifier *) t;
15141       ggc_mark_tree (IDENTIFIER_GLOBAL_VALUE (i));
15142       ggc_mark_tree (IDENTIFIER_LOCAL_VALUE (i));
15143       ggc_mark_tree (IDENTIFIER_LABEL_VALUE (i));
15144     }
15145   else if (TYPE_P (t) && TYPE_LANG_SPECIFIC (t))
15146     ggc_mark (TYPE_LANG_SPECIFIC (t));
15147 }
15148 \f
15149 /* From gcc/cccp.c, the code to handle -I.  */
15150
15151 /* Skip leading "./" from a directory name.
15152    This may yield the empty string, which represents the current directory.  */
15153
15154 static const char *
15155 skip_redundant_dir_prefix (const char *dir)
15156 {
15157   while (dir[0] == '.' && dir[1] == '/')
15158     for (dir += 2; *dir == '/'; dir++)
15159       continue;
15160   if (dir[0] == '.' && !dir[1])
15161     dir++;
15162   return dir;
15163 }
15164
15165 /* The file_name_map structure holds a mapping of file names for a
15166    particular directory.  This mapping is read from the file named
15167    FILE_NAME_MAP_FILE in that directory.  Such a file can be used to
15168    map filenames on a file system with severe filename restrictions,
15169    such as DOS.  The format of the file name map file is just a series
15170    of lines with two tokens on each line.  The first token is the name
15171    to map, and the second token is the actual name to use.  */
15172
15173 struct file_name_map
15174 {
15175   struct file_name_map *map_next;
15176   char *map_from;
15177   char *map_to;
15178 };
15179
15180 #define FILE_NAME_MAP_FILE "header.gcc"
15181
15182 /* Current maximum length of directory names in the search path
15183    for include files.  (Altered as we get more of them.)  */
15184
15185 static int max_include_len = 0;
15186
15187 struct file_name_list
15188   {
15189     struct file_name_list *next;
15190     char *fname;
15191     /* Mapping of file names for this directory.  */
15192     struct file_name_map *name_map;
15193     /* Non-zero if name_map is valid.  */
15194     int got_name_map;
15195   };
15196
15197 static struct file_name_list *include = NULL;   /* First dir to search */
15198 static struct file_name_list *last_include = NULL;      /* Last in chain */
15199
15200 /* I/O buffer structure.
15201    The `fname' field is nonzero for source files and #include files
15202    and for the dummy text used for -D and -U.
15203    It is zero for rescanning results of macro expansion
15204    and for expanding macro arguments.  */
15205 #define INPUT_STACK_MAX 400
15206 static struct file_buf {
15207   const char *fname;
15208   /* Filename specified with #line command.  */
15209   const char *nominal_fname;
15210   /* Record where in the search path this file was found.
15211      For #include_next.  */
15212   struct file_name_list *dir;
15213   ffewhereLine line;
15214   ffewhereColumn column;
15215 } instack[INPUT_STACK_MAX];
15216
15217 static int last_error_tick = 0;    /* Incremented each time we print it.  */
15218 static int input_file_stack_tick = 0;  /* Incremented when status changes.  */
15219
15220 /* Current nesting level of input sources.
15221    `instack[indepth]' is the level currently being read.  */
15222 static int indepth = -1;
15223
15224 typedef struct file_buf FILE_BUF;
15225
15226 /* Nonzero means -I- has been seen,
15227    so don't look for #include "foo" the source-file directory.  */
15228 static int ignore_srcdir;
15229
15230 #ifndef INCLUDE_LEN_FUDGE
15231 #define INCLUDE_LEN_FUDGE 0
15232 #endif
15233
15234 static void append_include_chain (struct file_name_list *first,
15235                                   struct file_name_list *last);
15236 static FILE *open_include_file (char *filename,
15237                                 struct file_name_list *searchptr);
15238 static void print_containing_files (ffebadSeverity sev);
15239 static char *read_filename_string (int ch, FILE *f);
15240 static struct file_name_map *read_name_map (const char *dirname);
15241
15242 /* Append a chain of `struct file_name_list's
15243    to the end of the main include chain.
15244    FIRST is the beginning of the chain to append, and LAST is the end.  */
15245
15246 static void
15247 append_include_chain (first, last)
15248      struct file_name_list *first, *last;
15249 {
15250   struct file_name_list *dir;
15251
15252   if (!first || !last)
15253     return;
15254
15255   if (include == 0)
15256     include = first;
15257   else
15258     last_include->next = first;
15259
15260   for (dir = first; ; dir = dir->next) {
15261     int len = strlen (dir->fname) + INCLUDE_LEN_FUDGE;
15262     if (len > max_include_len)
15263       max_include_len = len;
15264     if (dir == last)
15265       break;
15266   }
15267
15268   last->next = NULL;
15269   last_include = last;
15270 }
15271
15272 /* Try to open include file FILENAME.  SEARCHPTR is the directory
15273    being tried from the include file search path.  This function maps
15274    filenames on file systems based on information read by
15275    read_name_map.  */
15276
15277 static FILE *
15278 open_include_file (filename, searchptr)
15279      char *filename;
15280      struct file_name_list *searchptr;
15281 {
15282   register struct file_name_map *map;
15283   register char *from;
15284   char *p, *dir;
15285
15286   if (searchptr && ! searchptr->got_name_map)
15287     {
15288       searchptr->name_map = read_name_map (searchptr->fname
15289                                            ? searchptr->fname : ".");
15290       searchptr->got_name_map = 1;
15291     }
15292
15293   /* First check the mapping for the directory we are using.  */
15294   if (searchptr && searchptr->name_map)
15295     {
15296       from = filename;
15297       if (searchptr->fname)
15298         from += strlen (searchptr->fname) + 1;
15299       for (map = searchptr->name_map; map; map = map->map_next)
15300         {
15301           if (! strcmp (map->map_from, from))
15302             {
15303               /* Found a match.  */
15304               return fopen (map->map_to, "r");
15305             }
15306         }
15307     }
15308
15309   /* Try to find a mapping file for the particular directory we are
15310      looking in.  Thus #include <sys/types.h> will look up sys/types.h
15311      in /usr/include/header.gcc and look up types.h in
15312      /usr/include/sys/header.gcc.  */
15313   p = strrchr (filename, '/');
15314 #ifdef DIR_SEPARATOR
15315   if (! p) p = strrchr (filename, DIR_SEPARATOR);
15316   else {
15317     char *tmp = strrchr (filename, DIR_SEPARATOR);
15318     if (tmp != NULL && tmp > p) p = tmp;
15319   }
15320 #endif
15321   if (! p)
15322     p = filename;
15323   if (searchptr
15324       && searchptr->fname
15325       && strlen (searchptr->fname) == (size_t) (p - filename)
15326       && ! strncmp (searchptr->fname, filename, (int) (p - filename)))
15327     {
15328       /* FILENAME is in SEARCHPTR, which we've already checked.  */
15329       return fopen (filename, "r");
15330     }
15331
15332   if (p == filename)
15333     {
15334       from = filename;
15335       map = read_name_map (".");
15336     }
15337   else
15338     {
15339       dir = (char *) xmalloc (p - filename + 1);
15340       memcpy (dir, filename, p - filename);
15341       dir[p - filename] = '\0';
15342       from = p + 1;
15343       map = read_name_map (dir);
15344       free (dir);
15345     }
15346   for (; map; map = map->map_next)
15347     if (! strcmp (map->map_from, from))
15348       return fopen (map->map_to, "r");
15349
15350   return fopen (filename, "r");
15351 }
15352
15353 /* Print the file names and line numbers of the #include
15354    commands which led to the current file.  */
15355
15356 static void
15357 print_containing_files (ffebadSeverity sev)
15358 {
15359   FILE_BUF *ip = NULL;
15360   int i;
15361   int first = 1;
15362   const char *str1;
15363   const char *str2;
15364
15365   /* If stack of files hasn't changed since we last printed
15366      this info, don't repeat it.  */
15367   if (last_error_tick == input_file_stack_tick)
15368     return;
15369
15370   for (i = indepth; i >= 0; i--)
15371     if (instack[i].fname != NULL) {
15372       ip = &instack[i];
15373       break;
15374     }
15375
15376   /* Give up if we don't find a source file.  */
15377   if (ip == NULL)
15378     return;
15379
15380   /* Find the other, outer source files.  */
15381   for (i--; i >= 0; i--)
15382     if (instack[i].fname != NULL)
15383       {
15384         ip = &instack[i];
15385         if (first)
15386           {
15387             first = 0;
15388             str1 = "In file included";
15389           }
15390         else
15391           {
15392             str1 = "...          ...";
15393           }
15394
15395         if (i == 1)
15396           str2 = ":";
15397         else
15398           str2 = "";
15399
15400         /* xgettext:no-c-format */
15401         ffebad_start_msg ("%A from %B at %0%C", sev);
15402         ffebad_here (0, ip->line, ip->column);
15403         ffebad_string (str1);
15404         ffebad_string (ip->nominal_fname);
15405         ffebad_string (str2);
15406         ffebad_finish ();
15407       }
15408
15409   /* Record we have printed the status as of this time.  */
15410   last_error_tick = input_file_stack_tick;
15411 }
15412
15413 /* Read a space delimited string of unlimited length from a stdio
15414    file.  */
15415
15416 static char *
15417 read_filename_string (ch, f)
15418      int ch;
15419      FILE *f;
15420 {
15421   char *alloc, *set;
15422   int len;
15423
15424   len = 20;
15425   set = alloc = xmalloc (len + 1);
15426   if (! ISSPACE (ch))
15427     {
15428       *set++ = ch;
15429       while ((ch = getc (f)) != EOF && ! ISSPACE (ch))
15430         {
15431           if (set - alloc == len)
15432             {
15433               len *= 2;
15434               alloc = xrealloc (alloc, len + 1);
15435               set = alloc + len / 2;
15436             }
15437           *set++ = ch;
15438         }
15439     }
15440   *set = '\0';
15441   ungetc (ch, f);
15442   return alloc;
15443 }
15444
15445 /* Read the file name map file for DIRNAME.  */
15446
15447 static struct file_name_map *
15448 read_name_map (dirname)
15449      const char *dirname;
15450 {
15451   /* This structure holds a linked list of file name maps, one per
15452      directory.  */
15453   struct file_name_map_list
15454     {
15455       struct file_name_map_list *map_list_next;
15456       char *map_list_name;
15457       struct file_name_map *map_list_map;
15458     };
15459   static struct file_name_map_list *map_list;
15460   register struct file_name_map_list *map_list_ptr;
15461   char *name;
15462   FILE *f;
15463   size_t dirlen;
15464   int separator_needed;
15465
15466   dirname = skip_redundant_dir_prefix (dirname);
15467
15468   for (map_list_ptr = map_list; map_list_ptr;
15469        map_list_ptr = map_list_ptr->map_list_next)
15470     if (! strcmp (map_list_ptr->map_list_name, dirname))
15471       return map_list_ptr->map_list_map;
15472
15473   map_list_ptr = ((struct file_name_map_list *)
15474                   xmalloc (sizeof (struct file_name_map_list)));
15475   map_list_ptr->map_list_name = xstrdup (dirname);
15476   map_list_ptr->map_list_map = NULL;
15477
15478   dirlen = strlen (dirname);
15479   separator_needed = dirlen != 0 && dirname[dirlen - 1] != '/';
15480   name = (char *) xmalloc (dirlen + strlen (FILE_NAME_MAP_FILE) + 2);
15481   strcpy (name, dirname);
15482   name[dirlen] = '/';
15483   strcpy (name + dirlen + separator_needed, FILE_NAME_MAP_FILE);
15484   f = fopen (name, "r");
15485   free (name);
15486   if (!f)
15487     map_list_ptr->map_list_map = NULL;
15488   else
15489     {
15490       int ch;
15491
15492       while ((ch = getc (f)) != EOF)
15493         {
15494           char *from, *to;
15495           struct file_name_map *ptr;
15496
15497           if (ISSPACE (ch))
15498             continue;
15499           from = read_filename_string (ch, f);
15500           while ((ch = getc (f)) != EOF && ISSPACE (ch) && ch != '\n')
15501             ;
15502           to = read_filename_string (ch, f);
15503
15504           ptr = ((struct file_name_map *)
15505                  xmalloc (sizeof (struct file_name_map)));
15506           ptr->map_from = from;
15507
15508           /* Make the real filename absolute.  */
15509           if (*to == '/')
15510             ptr->map_to = to;
15511           else
15512             {
15513               ptr->map_to = xmalloc (dirlen + strlen (to) + 2);
15514               strcpy (ptr->map_to, dirname);
15515               ptr->map_to[dirlen] = '/';
15516               strcpy (ptr->map_to + dirlen + separator_needed, to);
15517               free (to);
15518             }
15519
15520           ptr->map_next = map_list_ptr->map_list_map;
15521           map_list_ptr->map_list_map = ptr;
15522
15523           while ((ch = getc (f)) != '\n')
15524             if (ch == EOF)
15525               break;
15526         }
15527       fclose (f);
15528     }
15529
15530   map_list_ptr->map_list_next = map_list;
15531   map_list = map_list_ptr;
15532
15533   return map_list_ptr->map_list_map;
15534 }
15535
15536 static void
15537 ffecom_file_ (const char *name)
15538 {
15539   FILE_BUF *fp;
15540
15541   /* Do partial setup of input buffer for the sake of generating
15542      early #line directives (when -g is in effect).  */
15543
15544   fp = &instack[++indepth];
15545   memset ((char *) fp, 0, sizeof (FILE_BUF));
15546   if (name == NULL)
15547     name = "";
15548   fp->nominal_fname = fp->fname = name;
15549 }
15550
15551 static void
15552 ffecom_close_include_ (FILE *f)
15553 {
15554   fclose (f);
15555
15556   indepth--;
15557   input_file_stack_tick++;
15558
15559   ffewhere_line_kill (instack[indepth].line);
15560   ffewhere_column_kill (instack[indepth].column);
15561 }
15562
15563 static int
15564 ffecom_decode_include_option_ (char *spec)
15565 {
15566   struct file_name_list *dirtmp;
15567
15568   if (! ignore_srcdir && !strcmp (spec, "-"))
15569     ignore_srcdir = 1;
15570   else
15571     {
15572       dirtmp = (struct file_name_list *)
15573         xmalloc (sizeof (struct file_name_list));
15574       dirtmp->next = 0;         /* New one goes on the end */
15575       dirtmp->fname = spec;
15576       dirtmp->got_name_map = 0;
15577       if (spec[0] == 0)
15578         error ("directory name must immediately follow -I");
15579       else
15580         append_include_chain (dirtmp, dirtmp);
15581     }
15582   return 1;
15583 }
15584
15585 /* Open INCLUDEd file.  */
15586
15587 static FILE *
15588 ffecom_open_include_ (char *name, ffewhereLine l, ffewhereColumn c)
15589 {
15590   char *fbeg = name;
15591   size_t flen = strlen (fbeg);
15592   struct file_name_list *search_start = include; /* Chain of dirs to search */
15593   struct file_name_list dsp[1]; /* First in chain, if #include "..." */
15594   struct file_name_list *searchptr = 0;
15595   char *fname;          /* Dynamically allocated fname buffer */
15596   FILE *f;
15597   FILE_BUF *fp;
15598
15599   if (flen == 0)
15600     return NULL;
15601
15602   dsp[0].fname = NULL;
15603
15604   /* If -I- was specified, don't search current dir, only spec'd ones. */
15605   if (!ignore_srcdir)
15606     {
15607       for (fp = &instack[indepth]; fp >= instack; fp--)
15608         {
15609           int n;
15610           char *ep;
15611           const char *nam;
15612
15613           if ((nam = fp->nominal_fname) != NULL)
15614             {
15615               /* Found a named file.  Figure out dir of the file,
15616                  and put it in front of the search list.  */
15617               dsp[0].next = search_start;
15618               search_start = dsp;
15619 #ifndef VMS
15620               ep = strrchr (nam, '/');
15621 #ifdef DIR_SEPARATOR
15622             if (ep == NULL) ep = strrchr (nam, DIR_SEPARATOR);
15623             else {
15624               char *tmp = strrchr (nam, DIR_SEPARATOR);
15625               if (tmp != NULL && tmp > ep) ep = tmp;
15626             }
15627 #endif
15628 #else                           /* VMS */
15629               ep = strrchr (nam, ']');
15630               if (ep == NULL) ep = strrchr (nam, '>');
15631               if (ep == NULL) ep = strrchr (nam, ':');
15632               if (ep != NULL) ep++;
15633 #endif                          /* VMS */
15634               if (ep != NULL)
15635                 {
15636                   n = ep - nam;
15637                   dsp[0].fname = (char *) xmalloc (n + 1);
15638                   strncpy (dsp[0].fname, nam, n);
15639                   dsp[0].fname[n] = '\0';
15640                   if (n + INCLUDE_LEN_FUDGE > max_include_len)
15641                     max_include_len = n + INCLUDE_LEN_FUDGE;
15642                 }
15643               else
15644                 dsp[0].fname = NULL; /* Current directory */
15645               dsp[0].got_name_map = 0;
15646               break;
15647             }
15648         }
15649     }
15650
15651   /* Allocate this permanently, because it gets stored in the definitions
15652      of macros.  */
15653   fname = xmalloc (max_include_len + flen + 4);
15654   /* + 2 above for slash and terminating null.  */
15655   /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED
15656      for g77 yet).  */
15657
15658   /* If specified file name is absolute, just open it.  */
15659
15660   if (*fbeg == '/'
15661 #ifdef DIR_SEPARATOR
15662       || *fbeg == DIR_SEPARATOR
15663 #endif
15664       )
15665     {
15666       strncpy (fname, (char *) fbeg, flen);
15667       fname[flen] = 0;
15668       f = open_include_file (fname, NULL);
15669     }
15670   else
15671     {
15672       f = NULL;
15673
15674       /* Search directory path, trying to open the file.
15675          Copy each filename tried into FNAME.  */
15676
15677       for (searchptr = search_start; searchptr; searchptr = searchptr->next)
15678         {
15679           if (searchptr->fname)
15680             {
15681               /* The empty string in a search path is ignored.
15682                  This makes it possible to turn off entirely
15683                  a standard piece of the list.  */
15684               if (searchptr->fname[0] == 0)
15685                 continue;
15686               strcpy (fname, skip_redundant_dir_prefix (searchptr->fname));
15687               if (fname[0] && fname[strlen (fname) - 1] != '/')
15688                 strcat (fname, "/");
15689               fname[strlen (fname) + flen] = 0;
15690             }
15691           else
15692             fname[0] = 0;
15693
15694           strncat (fname, fbeg, flen);
15695 #ifdef VMS
15696           /* Change this 1/2 Unix 1/2 VMS file specification into a
15697              full VMS file specification */
15698           if (searchptr->fname && (searchptr->fname[0] != 0))
15699             {
15700               /* Fix up the filename */
15701               hack_vms_include_specification (fname);
15702             }
15703           else
15704             {
15705               /* This is a normal VMS filespec, so use it unchanged.  */
15706               strncpy (fname, (char *) fbeg, flen);
15707               fname[flen] = 0;
15708 #if 0   /* Not for g77.  */
15709               /* if it's '#include filename', add the missing .h */
15710               if (strchr (fname, '.') == NULL)
15711                 strcat (fname, ".h");
15712 #endif
15713             }
15714 #endif /* VMS */
15715           f = open_include_file (fname, searchptr);
15716 #ifdef EACCES
15717           if (f == NULL && errno == EACCES)
15718             {
15719               print_containing_files (FFEBAD_severityWARNING);
15720               /* xgettext:no-c-format */
15721               ffebad_start_msg ("At %0, INCLUDE file %A exists, but is not readable",
15722                                 FFEBAD_severityWARNING);
15723               ffebad_string (fname);
15724               ffebad_here (0, l, c);
15725               ffebad_finish ();
15726             }
15727 #endif
15728           if (f != NULL)
15729             break;
15730         }
15731     }
15732
15733   if (f == NULL)
15734     {
15735       /* A file that was not found.  */
15736
15737       strncpy (fname, (char *) fbeg, flen);
15738       fname[flen] = 0;
15739       print_containing_files (ffebad_severity (FFEBAD_OPEN_INCLUDE));
15740       ffebad_start (FFEBAD_OPEN_INCLUDE);
15741       ffebad_here (0, l, c);
15742       ffebad_string (fname);
15743       ffebad_finish ();
15744     }
15745
15746   if (dsp[0].fname != NULL)
15747     free (dsp[0].fname);
15748
15749   if (f == NULL)
15750     return NULL;
15751
15752   if (indepth >= (INPUT_STACK_MAX - 1))
15753     {
15754       print_containing_files (FFEBAD_severityFATAL);
15755       /* xgettext:no-c-format */
15756       ffebad_start_msg ("At %0, INCLUDE nesting too deep",
15757                         FFEBAD_severityFATAL);
15758       ffebad_string (fname);
15759       ffebad_here (0, l, c);
15760       ffebad_finish ();
15761       return NULL;
15762     }
15763
15764   instack[indepth].line = ffewhere_line_use (l);
15765   instack[indepth].column = ffewhere_column_use (c);
15766
15767   fp = &instack[indepth + 1];
15768   memset ((char *) fp, 0, sizeof (FILE_BUF));
15769   fp->nominal_fname = fp->fname = fname;
15770   fp->dir = searchptr;
15771
15772   indepth++;
15773   input_file_stack_tick++;
15774
15775   return f;
15776 }
15777
15778 /**INDENT* (Do not reformat this comment even with -fca option.)
15779    Data-gathering files: Given the source file listed below, compiled with
15780    f2c I obtained the output file listed after that, and from the output
15781    file I derived the above code.
15782
15783 -------- (begin input file to f2c)
15784         implicit none
15785         character*10 A1,A2
15786         complex C1,C2
15787         integer I1,I2
15788         real R1,R2
15789         double precision D1,D2
15790 C
15791         call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2)
15792 c /
15793         call fooI(I1/I2)
15794         call fooR(R1/I1)
15795         call fooD(D1/I1)
15796         call fooC(C1/I1)
15797         call fooR(R1/R2)
15798         call fooD(R1/D1)
15799         call fooD(D1/D2)
15800         call fooD(D1/R1)
15801         call fooC(C1/C2)
15802         call fooC(C1/R1)
15803         call fooZ(C1/D1)
15804 c **
15805         call fooI(I1**I2)
15806         call fooR(R1**I1)
15807         call fooD(D1**I1)
15808         call fooC(C1**I1)
15809         call fooR(R1**R2)
15810         call fooD(R1**D1)
15811         call fooD(D1**D2)
15812         call fooD(D1**R1)
15813         call fooC(C1**C2)
15814         call fooC(C1**R1)
15815         call fooZ(C1**D1)
15816 c FFEINTRIN_impABS
15817         call fooR(ABS(R1))
15818 c FFEINTRIN_impACOS
15819         call fooR(ACOS(R1))
15820 c FFEINTRIN_impAIMAG
15821         call fooR(AIMAG(C1))
15822 c FFEINTRIN_impAINT
15823         call fooR(AINT(R1))
15824 c FFEINTRIN_impALOG
15825         call fooR(ALOG(R1))
15826 c FFEINTRIN_impALOG10
15827         call fooR(ALOG10(R1))
15828 c FFEINTRIN_impAMAX0
15829         call fooR(AMAX0(I1,I2))
15830 c FFEINTRIN_impAMAX1
15831         call fooR(AMAX1(R1,R2))
15832 c FFEINTRIN_impAMIN0
15833         call fooR(AMIN0(I1,I2))
15834 c FFEINTRIN_impAMIN1
15835         call fooR(AMIN1(R1,R2))
15836 c FFEINTRIN_impAMOD
15837         call fooR(AMOD(R1,R2))
15838 c FFEINTRIN_impANINT
15839         call fooR(ANINT(R1))
15840 c FFEINTRIN_impASIN
15841         call fooR(ASIN(R1))
15842 c FFEINTRIN_impATAN
15843         call fooR(ATAN(R1))
15844 c FFEINTRIN_impATAN2
15845         call fooR(ATAN2(R1,R2))
15846 c FFEINTRIN_impCABS
15847         call fooR(CABS(C1))
15848 c FFEINTRIN_impCCOS
15849         call fooC(CCOS(C1))
15850 c FFEINTRIN_impCEXP
15851         call fooC(CEXP(C1))
15852 c FFEINTRIN_impCHAR
15853         call fooA(CHAR(I1))
15854 c FFEINTRIN_impCLOG
15855         call fooC(CLOG(C1))
15856 c FFEINTRIN_impCONJG
15857         call fooC(CONJG(C1))
15858 c FFEINTRIN_impCOS
15859         call fooR(COS(R1))
15860 c FFEINTRIN_impCOSH
15861         call fooR(COSH(R1))
15862 c FFEINTRIN_impCSIN
15863         call fooC(CSIN(C1))
15864 c FFEINTRIN_impCSQRT
15865         call fooC(CSQRT(C1))
15866 c FFEINTRIN_impDABS
15867         call fooD(DABS(D1))
15868 c FFEINTRIN_impDACOS
15869         call fooD(DACOS(D1))
15870 c FFEINTRIN_impDASIN
15871         call fooD(DASIN(D1))
15872 c FFEINTRIN_impDATAN
15873         call fooD(DATAN(D1))
15874 c FFEINTRIN_impDATAN2
15875         call fooD(DATAN2(D1,D2))
15876 c FFEINTRIN_impDCOS
15877         call fooD(DCOS(D1))
15878 c FFEINTRIN_impDCOSH
15879         call fooD(DCOSH(D1))
15880 c FFEINTRIN_impDDIM
15881         call fooD(DDIM(D1,D2))
15882 c FFEINTRIN_impDEXP
15883         call fooD(DEXP(D1))
15884 c FFEINTRIN_impDIM
15885         call fooR(DIM(R1,R2))
15886 c FFEINTRIN_impDINT
15887         call fooD(DINT(D1))
15888 c FFEINTRIN_impDLOG
15889         call fooD(DLOG(D1))
15890 c FFEINTRIN_impDLOG10
15891         call fooD(DLOG10(D1))
15892 c FFEINTRIN_impDMAX1
15893         call fooD(DMAX1(D1,D2))
15894 c FFEINTRIN_impDMIN1
15895         call fooD(DMIN1(D1,D2))
15896 c FFEINTRIN_impDMOD
15897         call fooD(DMOD(D1,D2))
15898 c FFEINTRIN_impDNINT
15899         call fooD(DNINT(D1))
15900 c FFEINTRIN_impDPROD
15901         call fooD(DPROD(R1,R2))
15902 c FFEINTRIN_impDSIGN
15903         call fooD(DSIGN(D1,D2))
15904 c FFEINTRIN_impDSIN
15905         call fooD(DSIN(D1))
15906 c FFEINTRIN_impDSINH
15907         call fooD(DSINH(D1))
15908 c FFEINTRIN_impDSQRT
15909         call fooD(DSQRT(D1))
15910 c FFEINTRIN_impDTAN
15911         call fooD(DTAN(D1))
15912 c FFEINTRIN_impDTANH
15913         call fooD(DTANH(D1))
15914 c FFEINTRIN_impEXP
15915         call fooR(EXP(R1))
15916 c FFEINTRIN_impIABS
15917         call fooI(IABS(I1))
15918 c FFEINTRIN_impICHAR
15919         call fooI(ICHAR(A1))
15920 c FFEINTRIN_impIDIM
15921         call fooI(IDIM(I1,I2))
15922 c FFEINTRIN_impIDNINT
15923         call fooI(IDNINT(D1))
15924 c FFEINTRIN_impINDEX
15925         call fooI(INDEX(A1,A2))
15926 c FFEINTRIN_impISIGN
15927         call fooI(ISIGN(I1,I2))
15928 c FFEINTRIN_impLEN
15929         call fooI(LEN(A1))
15930 c FFEINTRIN_impLGE
15931         call fooL(LGE(A1,A2))
15932 c FFEINTRIN_impLGT
15933         call fooL(LGT(A1,A2))
15934 c FFEINTRIN_impLLE
15935         call fooL(LLE(A1,A2))
15936 c FFEINTRIN_impLLT
15937         call fooL(LLT(A1,A2))
15938 c FFEINTRIN_impMAX0
15939         call fooI(MAX0(I1,I2))
15940 c FFEINTRIN_impMAX1
15941         call fooI(MAX1(R1,R2))
15942 c FFEINTRIN_impMIN0
15943         call fooI(MIN0(I1,I2))
15944 c FFEINTRIN_impMIN1
15945         call fooI(MIN1(R1,R2))
15946 c FFEINTRIN_impMOD
15947         call fooI(MOD(I1,I2))
15948 c FFEINTRIN_impNINT
15949         call fooI(NINT(R1))
15950 c FFEINTRIN_impSIGN
15951         call fooR(SIGN(R1,R2))
15952 c FFEINTRIN_impSIN
15953         call fooR(SIN(R1))
15954 c FFEINTRIN_impSINH
15955         call fooR(SINH(R1))
15956 c FFEINTRIN_impSQRT
15957         call fooR(SQRT(R1))
15958 c FFEINTRIN_impTAN
15959         call fooR(TAN(R1))
15960 c FFEINTRIN_impTANH
15961         call fooR(TANH(R1))
15962 c FFEINTRIN_imp_CMPLX_C
15963         call fooC(cmplx(C1,C2))
15964 c FFEINTRIN_imp_CMPLX_D
15965         call fooZ(cmplx(D1,D2))
15966 c FFEINTRIN_imp_CMPLX_I
15967         call fooC(cmplx(I1,I2))
15968 c FFEINTRIN_imp_CMPLX_R
15969         call fooC(cmplx(R1,R2))
15970 c FFEINTRIN_imp_DBLE_C
15971         call fooD(dble(C1))
15972 c FFEINTRIN_imp_DBLE_D
15973         call fooD(dble(D1))
15974 c FFEINTRIN_imp_DBLE_I
15975         call fooD(dble(I1))
15976 c FFEINTRIN_imp_DBLE_R
15977         call fooD(dble(R1))
15978 c FFEINTRIN_imp_INT_C
15979         call fooI(int(C1))
15980 c FFEINTRIN_imp_INT_D
15981         call fooI(int(D1))
15982 c FFEINTRIN_imp_INT_I
15983         call fooI(int(I1))
15984 c FFEINTRIN_imp_INT_R
15985         call fooI(int(R1))
15986 c FFEINTRIN_imp_REAL_C
15987         call fooR(real(C1))
15988 c FFEINTRIN_imp_REAL_D
15989         call fooR(real(D1))
15990 c FFEINTRIN_imp_REAL_I
15991         call fooR(real(I1))
15992 c FFEINTRIN_imp_REAL_R
15993         call fooR(real(R1))
15994 c
15995 c FFEINTRIN_imp_INT_D:
15996 c
15997 c FFEINTRIN_specIDINT
15998         call fooI(IDINT(D1))
15999 c
16000 c FFEINTRIN_imp_INT_R:
16001 c
16002 c FFEINTRIN_specIFIX
16003         call fooI(IFIX(R1))
16004 c FFEINTRIN_specINT
16005         call fooI(INT(R1))
16006 c
16007 c FFEINTRIN_imp_REAL_D:
16008 c
16009 c FFEINTRIN_specSNGL
16010         call fooR(SNGL(D1))
16011 c
16012 c FFEINTRIN_imp_REAL_I:
16013 c
16014 c FFEINTRIN_specFLOAT
16015         call fooR(FLOAT(I1))
16016 c FFEINTRIN_specREAL
16017         call fooR(REAL(I1))
16018 c
16019         end
16020 -------- (end input file to f2c)
16021
16022 -------- (begin output from providing above input file as input to:
16023 --------  `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
16024 --------     -e "s:^#.*$::g"')
16025
16026 //  -- translated by f2c (version 19950223).
16027    You must link the resulting object file with the libraries:
16028         -lf2c -lm   (in that order)
16029 //
16030
16031
16032 // f2c.h  --  Standard Fortran to C header file //
16033
16034 ///  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
16035
16036         - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
16037
16038
16039
16040
16041 // F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems //
16042 // we assume short, float are OK //
16043 typedef long int // long int // integer;
16044 typedef char *address;
16045 typedef short int shortint;
16046 typedef float real;
16047 typedef double doublereal;
16048 typedef struct { real r, i; } complex;
16049 typedef struct { doublereal r, i; } doublecomplex;
16050 typedef long int // long int // logical;
16051 typedef short int shortlogical;
16052 typedef char logical1;
16053 typedef char integer1;
16054 // typedef long long longint; // // system-dependent //
16055
16056
16057
16058
16059 // Extern is for use with -E //
16060
16061
16062
16063
16064 // I/O stuff //
16065
16066
16067
16068
16069
16070
16071
16072
16073 typedef long int // int or long int // flag;
16074 typedef long int // int or long int // ftnlen;
16075 typedef long int // int or long int // ftnint;
16076
16077
16078 //external read, write//
16079 typedef struct
16080 {       flag cierr;
16081         ftnint ciunit;
16082         flag ciend;
16083         char *cifmt;
16084         ftnint cirec;
16085 } cilist;
16086
16087 //internal read, write//
16088 typedef struct
16089 {       flag icierr;
16090         char *iciunit;
16091         flag iciend;
16092         char *icifmt;
16093         ftnint icirlen;
16094         ftnint icirnum;
16095 } icilist;
16096
16097 //open//
16098 typedef struct
16099 {       flag oerr;
16100         ftnint ounit;
16101         char *ofnm;
16102         ftnlen ofnmlen;
16103         char *osta;
16104         char *oacc;
16105         char *ofm;
16106         ftnint orl;
16107         char *oblnk;
16108 } olist;
16109
16110 //close//
16111 typedef struct
16112 {       flag cerr;
16113         ftnint cunit;
16114         char *csta;
16115 } cllist;
16116
16117 //rewind, backspace, endfile//
16118 typedef struct
16119 {       flag aerr;
16120         ftnint aunit;
16121 } alist;
16122
16123 // inquire //
16124 typedef struct
16125 {       flag inerr;
16126         ftnint inunit;
16127         char *infile;
16128         ftnlen infilen;
16129         ftnint  *inex;  //parameters in standard's order//
16130         ftnint  *inopen;
16131         ftnint  *innum;
16132         ftnint  *innamed;
16133         char    *inname;
16134         ftnlen  innamlen;
16135         char    *inacc;
16136         ftnlen  inacclen;
16137         char    *inseq;
16138         ftnlen  inseqlen;
16139         char    *indir;
16140         ftnlen  indirlen;
16141         char    *infmt;
16142         ftnlen  infmtlen;
16143         char    *inform;
16144         ftnint  informlen;
16145         char    *inunf;
16146         ftnlen  inunflen;
16147         ftnint  *inrecl;
16148         ftnint  *innrec;
16149         char    *inblank;
16150         ftnlen  inblanklen;
16151 } inlist;
16152
16153
16154
16155 union Multitype {       // for multiple entry points //
16156         integer1 g;
16157         shortint h;
16158         integer i;
16159         // longint j; //
16160         real r;
16161         doublereal d;
16162         complex c;
16163         doublecomplex z;
16164         };
16165
16166 typedef union Multitype Multitype;
16167
16168 typedef long Long;      // No longer used; formerly in Namelist //
16169
16170 struct Vardesc {        // for Namelist //
16171         char *name;
16172         char *addr;
16173         ftnlen *dims;
16174         int  type;
16175         };
16176 typedef struct Vardesc Vardesc;
16177
16178 struct Namelist {
16179         char *name;
16180         Vardesc **vars;
16181         int nvars;
16182         };
16183 typedef struct Namelist Namelist;
16184
16185
16186
16187
16188
16189
16190
16191
16192 // procedure parameter types for -A and -C++ //
16193
16194
16195
16196
16197 typedef int // Unknown procedure type // (*U_fp)();
16198 typedef shortint (*J_fp)();
16199 typedef integer (*I_fp)();
16200 typedef real (*R_fp)();
16201 typedef doublereal (*D_fp)(), (*E_fp)();
16202 typedef // Complex // void  (*C_fp)();
16203 typedef // Double Complex // void  (*Z_fp)();
16204 typedef logical (*L_fp)();
16205 typedef shortlogical (*K_fp)();
16206 typedef // Character // void  (*H_fp)();
16207 typedef // Subroutine // int (*S_fp)();
16208
16209 // E_fp is for real functions when -R is not specified //
16210 typedef void  C_f;      // complex function //
16211 typedef void  H_f;      // character function //
16212 typedef void  Z_f;      // double complex function //
16213 typedef doublereal E_f; // real function with -R not specified //
16214
16215 // undef any lower-case symbols that your C compiler predefines, e.g.: //
16216
16217
16218 // (No such symbols should be defined in a strict ANSI C compiler.
16219    We can avoid trouble with f2c-translated code by using
16220    gcc -ansi.) //
16221
16222
16223
16224
16225
16226
16227
16228
16229
16230
16231
16232
16233
16234
16235
16236
16237
16238
16239
16240
16241
16242
16243
16244 // Main program // MAIN__()
16245 {
16246     // System generated locals //
16247     integer i__1;
16248     real r__1, r__2;
16249     doublereal d__1, d__2;
16250     complex q__1;
16251     doublecomplex z__1, z__2, z__3;
16252     logical L__1;
16253     char ch__1[1];
16254
16255     // Builtin functions //
16256     void c_div();
16257     integer pow_ii();
16258     double pow_ri(), pow_di();
16259     void pow_ci();
16260     double pow_dd();
16261     void pow_zz();
16262     double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
16263             asin(), atan(), atan2(), c_abs();
16264     void c_cos(), c_exp(), c_log(), r_cnjg();
16265     double cos(), cosh();
16266     void c_sin(), c_sqrt();
16267     double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
16268             d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
16269     integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
16270     logical l_ge(), l_gt(), l_le(), l_lt();
16271     integer i_nint();
16272     double r_sign();
16273
16274     // Local variables //
16275     extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
16276             fool_(), fooz_(), getem_();
16277     static char a1[10], a2[10];
16278     static complex c1, c2;
16279     static doublereal d1, d2;
16280     static integer i1, i2;
16281     static real r1, r2;
16282
16283
16284     getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L);
16285 // / //
16286     i__1 = i1 / i2;
16287     fooi_(&i__1);
16288     r__1 = r1 / i1;
16289     foor_(&r__1);
16290     d__1 = d1 / i1;
16291     food_(&d__1);
16292     d__1 = (doublereal) i1;
16293     q__1.r = c1.r / d__1, q__1.i = c1.i / d__1;
16294     fooc_(&q__1);
16295     r__1 = r1 / r2;
16296     foor_(&r__1);
16297     d__1 = r1 / d1;
16298     food_(&d__1);
16299     d__1 = d1 / d2;
16300     food_(&d__1);
16301     d__1 = d1 / r1;
16302     food_(&d__1);
16303     c_div(&q__1, &c1, &c2);
16304     fooc_(&q__1);
16305     q__1.r = c1.r / r1, q__1.i = c1.i / r1;
16306     fooc_(&q__1);
16307     z__1.r = c1.r / d1, z__1.i = c1.i / d1;
16308     fooz_(&z__1);
16309 // ** //
16310     i__1 = pow_ii(&i1, &i2);
16311     fooi_(&i__1);
16312     r__1 = pow_ri(&r1, &i1);
16313     foor_(&r__1);
16314     d__1 = pow_di(&d1, &i1);
16315     food_(&d__1);
16316     pow_ci(&q__1, &c1, &i1);
16317     fooc_(&q__1);
16318     d__1 = (doublereal) r1;
16319     d__2 = (doublereal) r2;
16320     r__1 = pow_dd(&d__1, &d__2);
16321     foor_(&r__1);
16322     d__2 = (doublereal) r1;
16323     d__1 = pow_dd(&d__2, &d1);
16324     food_(&d__1);
16325     d__1 = pow_dd(&d1, &d2);
16326     food_(&d__1);
16327     d__2 = (doublereal) r1;
16328     d__1 = pow_dd(&d1, &d__2);
16329     food_(&d__1);
16330     z__2.r = c1.r, z__2.i = c1.i;
16331     z__3.r = c2.r, z__3.i = c2.i;
16332     pow_zz(&z__1, &z__2, &z__3);
16333     q__1.r = z__1.r, q__1.i = z__1.i;
16334     fooc_(&q__1);
16335     z__2.r = c1.r, z__2.i = c1.i;
16336     z__3.r = r1, z__3.i = 0.;
16337     pow_zz(&z__1, &z__2, &z__3);
16338     q__1.r = z__1.r, q__1.i = z__1.i;
16339     fooc_(&q__1);
16340     z__2.r = c1.r, z__2.i = c1.i;
16341     z__3.r = d1, z__3.i = 0.;
16342     pow_zz(&z__1, &z__2, &z__3);
16343     fooz_(&z__1);
16344 // FFEINTRIN_impABS //
16345     r__1 = (doublereal)((  r1  ) >= 0 ? (  r1  ) : -(  r1  ))  ;
16346     foor_(&r__1);
16347 // FFEINTRIN_impACOS //
16348     r__1 = acos(r1);
16349     foor_(&r__1);
16350 // FFEINTRIN_impAIMAG //
16351     r__1 = r_imag(&c1);
16352     foor_(&r__1);
16353 // FFEINTRIN_impAINT //
16354     r__1 = r_int(&r1);
16355     foor_(&r__1);
16356 // FFEINTRIN_impALOG //
16357     r__1 = log(r1);
16358     foor_(&r__1);
16359 // FFEINTRIN_impALOG10 //
16360     r__1 = r_lg10(&r1);
16361     foor_(&r__1);
16362 // FFEINTRIN_impAMAX0 //
16363     r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16364     foor_(&r__1);
16365 // FFEINTRIN_impAMAX1 //
16366     r__1 = (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16367     foor_(&r__1);
16368 // FFEINTRIN_impAMIN0 //
16369     r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16370     foor_(&r__1);
16371 // FFEINTRIN_impAMIN1 //
16372     r__1 = (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16373     foor_(&r__1);
16374 // FFEINTRIN_impAMOD //
16375     r__1 = r_mod(&r1, &r2);
16376     foor_(&r__1);
16377 // FFEINTRIN_impANINT //
16378     r__1 = r_nint(&r1);
16379     foor_(&r__1);
16380 // FFEINTRIN_impASIN //
16381     r__1 = asin(r1);
16382     foor_(&r__1);
16383 // FFEINTRIN_impATAN //
16384     r__1 = atan(r1);
16385     foor_(&r__1);
16386 // FFEINTRIN_impATAN2 //
16387     r__1 = atan2(r1, r2);
16388     foor_(&r__1);
16389 // FFEINTRIN_impCABS //
16390     r__1 = c_abs(&c1);
16391     foor_(&r__1);
16392 // FFEINTRIN_impCCOS //
16393     c_cos(&q__1, &c1);
16394     fooc_(&q__1);
16395 // FFEINTRIN_impCEXP //
16396     c_exp(&q__1, &c1);
16397     fooc_(&q__1);
16398 // FFEINTRIN_impCHAR //
16399     *(unsigned char *)&ch__1[0] = i1;
16400     fooa_(ch__1, 1L);
16401 // FFEINTRIN_impCLOG //
16402     c_log(&q__1, &c1);
16403     fooc_(&q__1);
16404 // FFEINTRIN_impCONJG //
16405     r_cnjg(&q__1, &c1);
16406     fooc_(&q__1);
16407 // FFEINTRIN_impCOS //
16408     r__1 = cos(r1);
16409     foor_(&r__1);
16410 // FFEINTRIN_impCOSH //
16411     r__1 = cosh(r1);
16412     foor_(&r__1);
16413 // FFEINTRIN_impCSIN //
16414     c_sin(&q__1, &c1);
16415     fooc_(&q__1);
16416 // FFEINTRIN_impCSQRT //
16417     c_sqrt(&q__1, &c1);
16418     fooc_(&q__1);
16419 // FFEINTRIN_impDABS //
16420     d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ;
16421     food_(&d__1);
16422 // FFEINTRIN_impDACOS //
16423     d__1 = acos(d1);
16424     food_(&d__1);
16425 // FFEINTRIN_impDASIN //
16426     d__1 = asin(d1);
16427     food_(&d__1);
16428 // FFEINTRIN_impDATAN //
16429     d__1 = atan(d1);
16430     food_(&d__1);
16431 // FFEINTRIN_impDATAN2 //
16432     d__1 = atan2(d1, d2);
16433     food_(&d__1);
16434 // FFEINTRIN_impDCOS //
16435     d__1 = cos(d1);
16436     food_(&d__1);
16437 // FFEINTRIN_impDCOSH //
16438     d__1 = cosh(d1);
16439     food_(&d__1);
16440 // FFEINTRIN_impDDIM //
16441     d__1 = d_dim(&d1, &d2);
16442     food_(&d__1);
16443 // FFEINTRIN_impDEXP //
16444     d__1 = exp(d1);
16445     food_(&d__1);
16446 // FFEINTRIN_impDIM //
16447     r__1 = r_dim(&r1, &r2);
16448     foor_(&r__1);
16449 // FFEINTRIN_impDINT //
16450     d__1 = d_int(&d1);
16451     food_(&d__1);
16452 // FFEINTRIN_impDLOG //
16453     d__1 = log(d1);
16454     food_(&d__1);
16455 // FFEINTRIN_impDLOG10 //
16456     d__1 = d_lg10(&d1);
16457     food_(&d__1);
16458 // FFEINTRIN_impDMAX1 //
16459     d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ;
16460     food_(&d__1);
16461 // FFEINTRIN_impDMIN1 //
16462     d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ;
16463     food_(&d__1);
16464 // FFEINTRIN_impDMOD //
16465     d__1 = d_mod(&d1, &d2);
16466     food_(&d__1);
16467 // FFEINTRIN_impDNINT //
16468     d__1 = d_nint(&d1);
16469     food_(&d__1);
16470 // FFEINTRIN_impDPROD //
16471     d__1 = (doublereal) r1 * r2;
16472     food_(&d__1);
16473 // FFEINTRIN_impDSIGN //
16474     d__1 = d_sign(&d1, &d2);
16475     food_(&d__1);
16476 // FFEINTRIN_impDSIN //
16477     d__1 = sin(d1);
16478     food_(&d__1);
16479 // FFEINTRIN_impDSINH //
16480     d__1 = sinh(d1);
16481     food_(&d__1);
16482 // FFEINTRIN_impDSQRT //
16483     d__1 = sqrt(d1);
16484     food_(&d__1);
16485 // FFEINTRIN_impDTAN //
16486     d__1 = tan(d1);
16487     food_(&d__1);
16488 // FFEINTRIN_impDTANH //
16489     d__1 = tanh(d1);
16490     food_(&d__1);
16491 // FFEINTRIN_impEXP //
16492     r__1 = exp(r1);
16493     foor_(&r__1);
16494 // FFEINTRIN_impIABS //
16495     i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ;
16496     fooi_(&i__1);
16497 // FFEINTRIN_impICHAR //
16498     i__1 = *(unsigned char *)a1;
16499     fooi_(&i__1);
16500 // FFEINTRIN_impIDIM //
16501     i__1 = i_dim(&i1, &i2);
16502     fooi_(&i__1);
16503 // FFEINTRIN_impIDNINT //
16504     i__1 = i_dnnt(&d1);
16505     fooi_(&i__1);
16506 // FFEINTRIN_impINDEX //
16507     i__1 = i_indx(a1, a2, 10L, 10L);
16508     fooi_(&i__1);
16509 // FFEINTRIN_impISIGN //
16510     i__1 = i_sign(&i1, &i2);
16511     fooi_(&i__1);
16512 // FFEINTRIN_impLEN //
16513     i__1 = i_len(a1, 10L);
16514     fooi_(&i__1);
16515 // FFEINTRIN_impLGE //
16516     L__1 = l_ge(a1, a2, 10L, 10L);
16517     fool_(&L__1);
16518 // FFEINTRIN_impLGT //
16519     L__1 = l_gt(a1, a2, 10L, 10L);
16520     fool_(&L__1);
16521 // FFEINTRIN_impLLE //
16522     L__1 = l_le(a1, a2, 10L, 10L);
16523     fool_(&L__1);
16524 // FFEINTRIN_impLLT //
16525     L__1 = l_lt(a1, a2, 10L, 10L);
16526     fool_(&L__1);
16527 // FFEINTRIN_impMAX0 //
16528     i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16529     fooi_(&i__1);
16530 // FFEINTRIN_impMAX1 //
16531     i__1 = (integer) (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16532     fooi_(&i__1);
16533 // FFEINTRIN_impMIN0 //
16534     i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16535     fooi_(&i__1);
16536 // FFEINTRIN_impMIN1 //
16537     i__1 = (integer) (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16538     fooi_(&i__1);
16539 // FFEINTRIN_impMOD //
16540     i__1 = i1 % i2;
16541     fooi_(&i__1);
16542 // FFEINTRIN_impNINT //
16543     i__1 = i_nint(&r1);
16544     fooi_(&i__1);
16545 // FFEINTRIN_impSIGN //
16546     r__1 = r_sign(&r1, &r2);
16547     foor_(&r__1);
16548 // FFEINTRIN_impSIN //
16549     r__1 = sin(r1);
16550     foor_(&r__1);
16551 // FFEINTRIN_impSINH //
16552     r__1 = sinh(r1);
16553     foor_(&r__1);
16554 // FFEINTRIN_impSQRT //
16555     r__1 = sqrt(r1);
16556     foor_(&r__1);
16557 // FFEINTRIN_impTAN //
16558     r__1 = tan(r1);
16559     foor_(&r__1);
16560 // FFEINTRIN_impTANH //
16561     r__1 = tanh(r1);
16562     foor_(&r__1);
16563 // FFEINTRIN_imp_CMPLX_C //
16564     r__1 = c1.r;
16565     r__2 = c2.r;
16566     q__1.r = r__1, q__1.i = r__2;
16567     fooc_(&q__1);
16568 // FFEINTRIN_imp_CMPLX_D //
16569     z__1.r = d1, z__1.i = d2;
16570     fooz_(&z__1);
16571 // FFEINTRIN_imp_CMPLX_I //
16572     r__1 = (real) i1;
16573     r__2 = (real) i2;
16574     q__1.r = r__1, q__1.i = r__2;
16575     fooc_(&q__1);
16576 // FFEINTRIN_imp_CMPLX_R //
16577     q__1.r = r1, q__1.i = r2;
16578     fooc_(&q__1);
16579 // FFEINTRIN_imp_DBLE_C //
16580     d__1 = (doublereal) c1.r;
16581     food_(&d__1);
16582 // FFEINTRIN_imp_DBLE_D //
16583     d__1 = d1;
16584     food_(&d__1);
16585 // FFEINTRIN_imp_DBLE_I //
16586     d__1 = (doublereal) i1;
16587     food_(&d__1);
16588 // FFEINTRIN_imp_DBLE_R //
16589     d__1 = (doublereal) r1;
16590     food_(&d__1);
16591 // FFEINTRIN_imp_INT_C //
16592     i__1 = (integer) c1.r;
16593     fooi_(&i__1);
16594 // FFEINTRIN_imp_INT_D //
16595     i__1 = (integer) d1;
16596     fooi_(&i__1);
16597 // FFEINTRIN_imp_INT_I //
16598     i__1 = i1;
16599     fooi_(&i__1);
16600 // FFEINTRIN_imp_INT_R //
16601     i__1 = (integer) r1;
16602     fooi_(&i__1);
16603 // FFEINTRIN_imp_REAL_C //
16604     r__1 = c1.r;
16605     foor_(&r__1);
16606 // FFEINTRIN_imp_REAL_D //
16607     r__1 = (real) d1;
16608     foor_(&r__1);
16609 // FFEINTRIN_imp_REAL_I //
16610     r__1 = (real) i1;
16611     foor_(&r__1);
16612 // FFEINTRIN_imp_REAL_R //
16613     r__1 = r1;
16614     foor_(&r__1);
16615
16616 // FFEINTRIN_imp_INT_D: //
16617
16618 // FFEINTRIN_specIDINT //
16619     i__1 = (integer) d1;
16620     fooi_(&i__1);
16621
16622 // FFEINTRIN_imp_INT_R: //
16623
16624 // FFEINTRIN_specIFIX //
16625     i__1 = (integer) r1;
16626     fooi_(&i__1);
16627 // FFEINTRIN_specINT //
16628     i__1 = (integer) r1;
16629     fooi_(&i__1);
16630
16631 // FFEINTRIN_imp_REAL_D: //
16632
16633 // FFEINTRIN_specSNGL //
16634     r__1 = (real) d1;
16635     foor_(&r__1);
16636
16637 // FFEINTRIN_imp_REAL_I: //
16638
16639 // FFEINTRIN_specFLOAT //
16640     r__1 = (real) i1;
16641     foor_(&r__1);
16642 // FFEINTRIN_specREAL //
16643     r__1 = (real) i1;
16644     foor_(&r__1);
16645
16646 } // MAIN__ //
16647
16648 -------- (end output file from f2c)
16649
16650 */