gcc/f/com.c

   1 /* com.c -- Implementation File (module.c template V1.0)
   2    Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001
   3    Free Software Foundation, Inc.
   4    Contributed by James Craig Burley.
   5
   6 This file is part of GNU Fortran.
   7
   8 GNU Fortran is free software; you can redistribute it and/or modify
   9 it under the terms of the GNU General Public License as published by
  10 the Free Software Foundation; either version 2, or (at your option)
  11 any later version.
  12
  13 GNU Fortran is distributed in the hope that it will be useful,
  14 but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 GNU General Public License for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with GNU Fortran; see the file COPYING.  If not, write to
  20 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
  21 02111-1307, USA.
  22
  23    Related Modules:
  24       None
  25
  26    Description:
  27       Contains compiler-specific functions.
  28
  29    Modifications:
  30 */
  31
  32 /* Understanding this module means understanding the interface between
  33    the g77 front end and the gcc back end (or, perhaps, some other
  34    back end).  In here are the functions called by the front end proper
  35    to notify whatever back end is in place about certain things, and
  36    also the back-end-specific functions.  It's a bear to deal with, so
  37    lately I've been trying to simplify things, especially with regard
  38    to the gcc-back-end-specific stuff.
  39
  40    Building expressions generally seems quite easy, but building decls
  41    has been challenging and is undergoing revision.  gcc has several
  42    kinds of decls:
  43
  44    TYPE_DECL -- a type (int, float, struct, function, etc.)
  45    CONST_DECL -- a constant of some type other than function
  46    LABEL_DECL -- a variable or a constant?
  47    PARM_DECL -- an argument to a function (a variable that is a dummy)
  48    RESULT_DECL -- the return value of a function (a variable)
  49    VAR_DECL -- other variable (can hold a ptr-to-function, struct, int, etc.)
  50    FUNCTION_DECL -- a function (either the actual function or an extern ref)
  51    FIELD_DECL -- a field in a struct or union (goes into types)
  52
  53    g77 has a set of functions that somewhat parallels the gcc front end
  54    when it comes to building decls:
  55
  56    Internal Function (one we define, not just declare as extern):
  57    if (is_nested) push_f_function_context ();
  58    start_function (get_identifier ("function_name"), function_type,
  59                    is_nested, is_public);
  60    // for each arg, build PARM_DECL and call push_parm_decl (decl) with it;
  61    store_parm_decls (is_main_program);
  62    ffecom_start_compstmt ();
  63    // for stmts and decls inside function, do appropriate things;
  64    ffecom_end_compstmt ();
  65    finish_function (is_nested);
  66    if (is_nested) pop_f_function_context ();
  67
  68    Everything Else:
  69    tree d;
  70    tree init;
  71    // fill in external, public, static, &c for decl, and
  72    // set DECL_INITIAL to error_mark_node if going to initialize
  73    // set is_top_level TRUE only if not at top level and decl
  74    // must go in top level (i.e. not within current function decl context)
  75    d = start_decl (decl, is_top_level);
  76    init = ...;  // if have initializer
  77    finish_decl (d, init, is_top_level);
  78
  79 */
  80
  81 /* Include files. */
  82
  83 #include "proj.h"
  84 #include "flags.h"
  85 #include "rtl.h"
  86 #include "toplev.h"
  87 #include "tree.h"
  88 #include "output.h"  /* Must follow tree.h so TREE_CODE is defined! */
  89 #include "convert.h"
  90 #include "ggc.h"
  91 #include "diagnostic.h"
  92 #include "langhooks.h"
  93 #include "langhooks-def.h"
  94
  95 /* VMS-specific definitions */
  96 #ifdef VMS
  97 #include <descrip.h>
  98 #define O_RDONLY        0       /* Open arg for Read/Only  */
  99 #define O_WRONLY        1       /* Open arg for Write/Only */
 100 #define read(fd,buf,size)       VMS_read (fd,buf,size)
 101 #define write(fd,buf,size)      VMS_write (fd,buf,size)
 102 #define open(fname,mode,prot)   VMS_open (fname,mode,prot)
 103 #define fopen(fname,mode)       VMS_fopen (fname,mode)
 104 #define freopen(fname,mode,ofile) VMS_freopen (fname,mode,ofile)
 105 #define strncat(dst,src,cnt) VMS_strncat (dst,src,cnt)
 106 #define fstat(fd,stbuf)         VMS_fstat (fd,stbuf)
 107 static int VMS_fstat (), VMS_stat ();
 108 static char * VMS_strncat ();
 109 static int VMS_read ();
 110 static int VMS_write ();
 111 static int VMS_open ();
 112 static FILE * VMS_fopen ();
 113 static FILE * VMS_freopen ();
 114 static void hack_vms_include_specification ();
 115 typedef struct { unsigned :16, :16, :16; } vms_ino_t;
 116 #define ino_t vms_ino_t
 117 #define INCLUDE_LEN_FUDGE 10    /* leave room for VMS syntax conversion */
 118 #endif /* VMS */
 119
 120 #define FFECOM_DETERMINE_TYPES 1 /* for com.h */
 121 #include "com.h"
 122 #include "bad.h"
 123 #include "bld.h"
 124 #include "equiv.h"
 125 #include "expr.h"
 126 #include "implic.h"
 127 #include "info.h"
 128 #include "malloc.h"
 129 #include "src.h"
 130 #include "st.h"
 131 #include "storag.h"
 132 #include "symbol.h"
 133 #include "target.h"
 134 #include "top.h"
 135 #include "type.h"
 136
 137 /* Externals defined here.  */
 138
 139 /* Stream for reading from the input file.  */
 140 FILE *finput;
 141
 142 /* These definitions parallel those in c-decl.c so that code from that
 143    module can be used pretty much as is.  Much of these defs aren't
 144    otherwise used, i.e. by g77 code per se, except some of them are used
 145    to build some of them that are.  The ones that are global (i.e. not
 146    "static") are those that ste.c and such might use (directly
 147    or by using com macros that reference them in their definitions).  */
 148
 149 tree string_type_node;
 150
 151 /* The rest of these are inventions for g77, though there might be
 152    similar things in the C front end.  As they are found, these
 153    inventions should be renamed to be canonical.  Note that only
 154    the ones currently required to be global are so.  */
 155
 156 static tree ffecom_tree_fun_type_void;
 157
 158 tree ffecom_integer_type_node;  /* Abbrev for _tree_type[blah][blah]. */
 159 tree ffecom_integer_zero_node;  /* Like *_*_* with g77's integer type. */
 160 tree ffecom_integer_one_node;   /* " */
 161 tree ffecom_tree_type[FFEINFO_basictype][FFEINFO_kindtype];
 162
 163 /* _fun_type things are the f2c-specific versions.  For -fno-f2c,
 164    just use build_function_type and build_pointer_type on the
 165    appropriate _tree_type array element.  */
 166
 167 static tree ffecom_tree_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
 168 static tree ffecom_tree_ptr_to_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
 169 static tree ffecom_tree_subr_type;
 170 static tree ffecom_tree_ptr_to_subr_type;
 171 static tree ffecom_tree_blockdata_type;
 172
 173 static tree ffecom_tree_xargc_;
 174
 175 ffecomSymbol ffecom_symbol_null_
 176 =
 177 {
 178   NULL_TREE,
 179   NULL_TREE,
 180   NULL_TREE,
 181   NULL_TREE,
 182   false
 183 };
 184 ffeinfoKindtype ffecom_pointer_kind_ = FFEINFO_basictypeNONE;
 185 ffeinfoKindtype ffecom_label_kind_ = FFEINFO_basictypeNONE;
 186
 187 int ffecom_f2c_typecode_[FFEINFO_basictype][FFEINFO_kindtype];
 188 tree ffecom_f2c_integer_type_node;
 189 tree ffecom_f2c_ptr_to_integer_type_node;
 190 tree ffecom_f2c_address_type_node;
 191 tree ffecom_f2c_real_type_node;
 192 tree ffecom_f2c_ptr_to_real_type_node;
 193 tree ffecom_f2c_doublereal_type_node;
 194 tree ffecom_f2c_complex_type_node;
 195 tree ffecom_f2c_doublecomplex_type_node;
 196 tree ffecom_f2c_longint_type_node;
 197 tree ffecom_f2c_logical_type_node;
 198 tree ffecom_f2c_flag_type_node;
 199 tree ffecom_f2c_ftnlen_type_node;
 200 tree ffecom_f2c_ftnlen_zero_node;
 201 tree ffecom_f2c_ftnlen_one_node;
 202 tree ffecom_f2c_ftnlen_two_node;
 203 tree ffecom_f2c_ptr_to_ftnlen_type_node;
 204 tree ffecom_f2c_ftnint_type_node;
 205 tree ffecom_f2c_ptr_to_ftnint_type_node;
 206
 207 /* Simple definitions and enumerations. */
 208
 209 #ifndef FFECOM_sizeMAXSTACKITEM
 210 #define FFECOM_sizeMAXSTACKITEM 32*1024 /* Keep user-declared things
 211                                            larger than this # bytes
 212                                            off stack if possible. */
 213 #endif
 214
 215 /* For systems that have large enough stacks, they should define
 216    this to 0, and here, for ease of use later on, we just undefine
 217    it if it is 0.  */
 218
 219 #if FFECOM_sizeMAXSTACKITEM == 0
 220 #undef FFECOM_sizeMAXSTACKITEM
 221 #endif
 222
 223 typedef enum
 224   {
 225     FFECOM_rttypeVOID_,
 226     FFECOM_rttypeVOIDSTAR_,     /* C's `void *' type. */
 227     FFECOM_rttypeFTNINT_,       /* f2c's `ftnint' type. */
 228     FFECOM_rttypeINTEGER_,      /* f2c's `integer' type. */
 229     FFECOM_rttypeLONGINT_,      /* f2c's `longint' type. */
 230     FFECOM_rttypeLOGICAL_,      /* f2c's `logical' type. */
 231     FFECOM_rttypeREAL_F2C_,     /* f2c's `real' returned as `double'. */
 232     FFECOM_rttypeREAL_GNU_,     /* `real' returned as such. */
 233     FFECOM_rttypeCOMPLEX_F2C_,  /* f2c's `complex' returned via 1st arg. */
 234     FFECOM_rttypeCOMPLEX_GNU_,  /* f2c's `complex' returned directly. */
 235     FFECOM_rttypeDOUBLE_,       /* C's `double' type. */
 236     FFECOM_rttypeDOUBLEREAL_,   /* f2c's `doublereal' type. */
 237     FFECOM_rttypeDBLCMPLX_F2C_, /* f2c's `doublecomplex' returned via 1st arg. */
 238     FFECOM_rttypeDBLCMPLX_GNU_, /* f2c's `doublecomplex' returned directly. */
 239     FFECOM_rttypeCHARACTER_,    /* f2c `char *'/`ftnlen' pair. */
 240     FFECOM_rttype_
 241   } ffecomRttype_;
 242
 243 /* Internal typedefs. */
 244
 245 typedef struct _ffecom_concat_list_ ffecomConcatList_;
 246
 247 /* Private include files. */
 248
 249
 250 /* Internal structure definitions. */
 251
 252 struct _ffecom_concat_list_
 253   {
 254     ffebld *exprs;
 255     int count;
 256     int max;
 257     ffetargetCharacterSize minlen;
 258     ffetargetCharacterSize maxlen;
 259   };
 260
 261 /* Static functions (internal). */
 262
 263 static void ffecom_init_decl_processing PARAMS ((void));
 264 static tree ffecom_arglist_expr_ (const char *argstring, ffebld args);
 265 static tree ffecom_widest_expr_type_ (ffebld list);
 266 static bool ffecom_overlap_ (tree dest_decl, tree dest_offset,
 267                              tree dest_size, tree source_tree,
 268                              ffebld source, bool scalar_arg);
 269 static bool ffecom_args_overlapping_ (tree dest_tree, ffebld dest,
 270                                       tree args, tree callee_commons,
 271                                       bool scalar_args);
 272 static tree ffecom_build_f2c_string_ (int i, const char *s);
 273 static tree ffecom_call_ (tree fn, ffeinfoKindtype kt,
 274                           bool is_f2c_complex, tree type,
 275                           tree args, tree dest_tree,
 276                           ffebld dest, bool *dest_used,
 277                           tree callee_commons, bool scalar_args, tree hook);
 278 static tree ffecom_call_binop_ (tree fn, ffeinfoKindtype kt,
 279                                 bool is_f2c_complex, tree type,
 280                                 ffebld left, ffebld right,
 281                                 tree dest_tree, ffebld dest,
 282                                 bool *dest_used, tree callee_commons,
 283                                 bool scalar_args, bool ref, tree hook);
 284 static void ffecom_char_args_x_ (tree *xitem, tree *length,
 285                                  ffebld expr, bool with_null);
 286 static tree ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy);
 287 static tree ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s);
 288 static ffecomConcatList_
 289   ffecom_concat_list_gather_ (ffecomConcatList_ catlist,
 290                               ffebld expr,
 291                               ffetargetCharacterSize max);
 292 static void ffecom_concat_list_kill_ (ffecomConcatList_ catlist);
 293 static ffecomConcatList_ ffecom_concat_list_new_ (ffebld expr,
 294                                                 ffetargetCharacterSize max);
 295 static void ffecom_debug_kludge_ (tree aggr, const char *aggr_type,
 296                                   ffesymbol member, tree member_type,
 297                                   ffetargetOffset offset);
 298 static void ffecom_do_entry_ (ffesymbol fn, int entrynum);
 299 static tree ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
 300                           bool *dest_used, bool assignp, bool widenp);
 301 static tree ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
 302                                     ffebld dest, bool *dest_used);
 303 static tree ffecom_expr_power_integer_ (ffebld expr);
 304 static void ffecom_expr_transform_ (ffebld expr);
 305 static void ffecom_f2c_make_type_ (tree *type, int tcode, const char *name);
 306 static void ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
 307                                       int code);
 308 static ffeglobal ffecom_finish_global_ (ffeglobal global);
 309 static ffesymbol ffecom_finish_symbol_transform_ (ffesymbol s);
 310 static tree ffecom_get_appended_identifier_ (char us, const char *text);
 311 static tree ffecom_get_external_identifier_ (ffesymbol s);
 312 static tree ffecom_get_identifier_ (const char *text);
 313 static tree ffecom_gen_sfuncdef_ (ffesymbol s,
 314                                   ffeinfoBasictype bt,
 315                                   ffeinfoKindtype kt);
 316 static const char *ffecom_gfrt_args_ (ffecomGfrt ix);
 317 static tree ffecom_gfrt_tree_ (ffecomGfrt ix);
 318 static tree ffecom_init_zero_ (tree decl);
 319 static tree ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
 320                                      tree *maybe_tree);
 321 static tree ffecom_intrinsic_len_ (ffebld expr);
 322 static void ffecom_let_char_ (tree dest_tree,
 323                               tree dest_length,
 324                               ffetargetCharacterSize dest_size,
 325                               ffebld source);
 326 static void ffecom_make_gfrt_ (ffecomGfrt ix);
 327 static void ffecom_member_phase1_ (ffestorag mst, ffestorag st);
 328 static void ffecom_member_phase2_ (ffestorag mst, ffestorag st);
 329 static void ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size,
 330                                       ffebld source);
 331 static void ffecom_push_dummy_decls_ (ffebld dumlist,
 332                                       bool stmtfunc);
 333 static void ffecom_start_progunit_ (void);
 334 static ffesymbol ffecom_sym_transform_ (ffesymbol s);
 335 static ffesymbol ffecom_sym_transform_assign_ (ffesymbol s);
 336 static void ffecom_transform_common_ (ffesymbol s);
 337 static void ffecom_transform_equiv_ (ffestorag st);
 338 static tree ffecom_transform_namelist_ (ffesymbol s);
 339 static void ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
 340                                        tree t);
 341 static void ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
 342                                        tree *size, tree tree);
 343 static tree ffecom_tree_divide_ (tree tree_type, tree left, tree right,
 344                                  tree dest_tree, ffebld dest,
 345                                  bool *dest_used, tree hook);
 346 static tree ffecom_type_localvar_ (ffesymbol s,
 347                                    ffeinfoBasictype bt,
 348                                    ffeinfoKindtype kt);
 349 static tree ffecom_type_namelist_ (void);
 350 static tree ffecom_type_vardesc_ (void);
 351 static tree ffecom_vardesc_ (ffebld expr);
 352 static tree ffecom_vardesc_array_ (ffesymbol s);
 353 static tree ffecom_vardesc_dims_ (ffesymbol s);
 354 static tree ffecom_convert_narrow_ (tree type, tree expr);
 355 static tree ffecom_convert_widen_ (tree type, tree expr);
 356
 357 /* These are static functions that parallel those found in the C front
 358    end and thus have the same names.  */
 359
 360 static tree bison_rule_compstmt_ (void);
 361 static void bison_rule_pushlevel_ (void);
 362 static void delete_block (tree block);
 363 static int duplicate_decls (tree newdecl, tree olddecl);
 364 static void finish_decl (tree decl, tree init, bool is_top_level);
 365 static void finish_function (int nested);
 366 static const char *lang_printable_name (tree decl, int v);
 367 static tree lookup_name_current_level (tree name);
 368 static struct binding_level *make_binding_level (void);
 369 static void pop_f_function_context (void);
 370 static void push_f_function_context (void);
 371 static void push_parm_decl (tree parm);
 372 static tree pushdecl_top_level (tree decl);
 373 static int kept_level_p (void);
 374 static tree storedecls (tree decls);
 375 static void store_parm_decls (int is_main_program);
 376 static tree start_decl (tree decl, bool is_top_level);
 377 static void start_function (tree name, tree type, int nested, int public);
 378 static void ffecom_file_ (const char *name);
 379 static void ffecom_close_include_ (FILE *f);
 380 static int ffecom_decode_include_option_ (char *spec);
 381 static FILE *ffecom_open_include_ (char *name, ffewhereLine l,
 382                                    ffewhereColumn c);
 383
 384 /* Static objects accessed by functions in this module. */
 385
 386 static ffesymbol ffecom_primary_entry_ = NULL;
 387 static ffesymbol ffecom_nested_entry_ = NULL;
 388 static ffeinfoKind ffecom_primary_entry_kind_;
 389 static bool ffecom_primary_entry_is_proc_;
 390 static tree ffecom_outer_function_decl_;
 391 static tree ffecom_previous_function_decl_;
 392 static tree ffecom_which_entrypoint_decl_;
 393 static tree ffecom_float_zero_ = NULL_TREE;
 394 static tree ffecom_float_half_ = NULL_TREE;
 395 static tree ffecom_double_zero_ = NULL_TREE;
 396 static tree ffecom_double_half_ = NULL_TREE;
 397 static tree ffecom_func_result_;/* For functions. */
 398 static tree ffecom_func_length_;/* For CHARACTER fns. */
 399 static ffebld ffecom_list_blockdata_;
 400 static ffebld ffecom_list_common_;
 401 static ffebld ffecom_master_arglist_;
 402 static ffeinfoBasictype ffecom_master_bt_;
 403 static ffeinfoKindtype ffecom_master_kt_;
 404 static ffetargetCharacterSize ffecom_master_size_;
 405 static int ffecom_num_fns_ = 0;
 406 static int ffecom_num_entrypoints_ = 0;
 407 static bool ffecom_is_altreturning_ = FALSE;
 408 static tree ffecom_multi_type_node_;
 409 static tree ffecom_multi_retval_;
 410 static tree
 411   ffecom_multi_fields_[FFEINFO_basictype][FFEINFO_kindtype];
 412 static bool ffecom_member_namelisted_;  /* _member_phase1_ namelisted? */
 413 static bool ffecom_doing_entry_ = FALSE;
 414 static bool ffecom_transform_only_dummies_ = FALSE;
 415 static int ffecom_typesize_pointer_;
 416 static int ffecom_typesize_integer1_;
 417
 418 /* Holds pointer-to-function expressions.  */
 419
 420 static tree ffecom_gfrt_[FFECOM_gfrt]
 421 =
 422 {
 423 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NULL_TREE,
 424 #include "com-rt.def"
 425 #undef DEFGFRT
 426 };
 427
 428 /* Holds the external names of the functions.  */
 429
 430 static const char *const ffecom_gfrt_name_[FFECOM_gfrt]
 431 =
 432 {
 433 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NAME,
 434 #include "com-rt.def"
 435 #undef DEFGFRT
 436 };
 437
 438 /* Whether the function returns.  */
 439
 440 static const bool ffecom_gfrt_volatile_[FFECOM_gfrt]
 441 =
 442 {
 443 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) VOLATILE,
 444 #include "com-rt.def"
 445 #undef DEFGFRT
 446 };
 447
 448 /* Whether the function returns type complex.  */
 449
 450 static const bool ffecom_gfrt_complex_[FFECOM_gfrt]
 451 =
 452 {
 453 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) COMPLEX,
 454 #include "com-rt.def"
 455 #undef DEFGFRT
 456 };
 457
 458 /* Whether the function is const
 459    (i.e., has no side effects and only depends on its arguments).  */
 460
 461 static const bool ffecom_gfrt_const_[FFECOM_gfrt]
 462 =
 463 {
 464 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) CONST,
 465 #include "com-rt.def"
 466 #undef DEFGFRT
 467 };
 468
 469 /* Type code for the function return value.  */
 470
 471 static const ffecomRttype_ ffecom_gfrt_type_[FFECOM_gfrt]
 472 =
 473 {
 474 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) TYPE,
 475 #include "com-rt.def"
 476 #undef DEFGFRT
 477 };
 478
 479 /* String of codes for the function's arguments.  */
 480
 481 static const char *const ffecom_gfrt_argstring_[FFECOM_gfrt]
 482 =
 483 {
 484 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) ARGS,
 485 #include "com-rt.def"
 486 #undef DEFGFRT
 487 };
 488
 489 /* Internal macros. */
 490
 491 /* We let tm.h override the types used here, to handle trivial differences
 492    such as the choice of unsigned int or long unsigned int for size_t.
 493    When machines start needing nontrivial differences in the size type,
 494    it would be best to do something here to figure out automatically
 495    from other information what type to use.  */
 496
 497 #ifndef SIZE_TYPE
 498 #define SIZE_TYPE "long unsigned int"
 499 #endif
 500
 501 #define ffecom_concat_list_count_(catlist) ((catlist).count)
 502 #define ffecom_concat_list_expr_(catlist,i) ((catlist).exprs[(i)])
 503 #define ffecom_concat_list_maxlen_(catlist) ((catlist).maxlen)
 504 #define ffecom_concat_list_minlen_(catlist) ((catlist).minlen)
 505
 506 #define ffecom_char_args_(i,l,e) ffecom_char_args_x_((i),(l),(e),FALSE)
 507 #define ffecom_char_args_with_null_(i,l,e) ffecom_char_args_x_((i),(l),(e),TRUE)
 508
 509 /* For each binding contour we allocate a binding_level structure
 510  * which records the names defined in that contour.
 511  * Contours include:
 512  *  0) the global one
 513  *  1) one for each function definition,
 514  *     where internal declarations of the parameters appear.
 515  *
 516  * The current meaning of a name can be found by searching the levels from
 517  * the current one out to the global one.
 518  */
 519
 520 /* Note that the information in the `names' component of the global contour
 521    is duplicated in the IDENTIFIER_GLOBAL_VALUEs of all identifiers.  */
 522
 523 struct binding_level
 524   {
 525     /* A chain of _DECL nodes for all variables, constants, functions,
 526        and typedef types.  These are in the reverse of the order supplied.
 527      */
 528     tree names;
 529
 530     /* For each level (except not the global one),
 531        a chain of BLOCK nodes for all the levels
 532        that were entered and exited one level down.  */
 533     tree blocks;
 534
 535     /* The BLOCK node for this level, if one has been preallocated.
 536        If 0, the BLOCK is allocated (if needed) when the level is popped.  */
 537     tree this_block;
 538
 539     /* The binding level which this one is contained in (inherits from).  */
 540     struct binding_level *level_chain;
 541
 542     /* 0: no ffecom_prepare_* functions called at this level yet;
 543        1: ffecom_prepare* functions called, except not ffecom_prepare_end;
 544        2: ffecom_prepare_end called.  */
 545     int prep_state;
 546   };
 547
 548 #define NULL_BINDING_LEVEL (struct binding_level *) NULL
 549
 550 /* The binding level currently in effect.  */
 551
 552 static struct binding_level *current_binding_level;
 553
 554 /* A chain of binding_level structures awaiting reuse.  */
 555
 556 static struct binding_level *free_binding_level;
 557
 558 /* The outermost binding level, for names of file scope.
 559    This is created when the compiler is started and exists
 560    through the entire run.  */
 561
 562 static struct binding_level *global_binding_level;
 563
 564 /* Binding level structures are initialized by copying this one.  */
 565
 566 static const struct binding_level clear_binding_level
 567 =
 568 {NULL, NULL, NULL, NULL_BINDING_LEVEL, 0};
 569
 570 /* Language-dependent contents of an identifier.  */
 571
 572 struct lang_identifier
 573   {
 574     struct tree_identifier ignore;
 575     tree global_value, local_value, label_value;
 576     bool invented;
 577   };
 578
 579 /* Macros for access to language-specific slots in an identifier.  */
 580 /* Each of these slots contains a DECL node or null.  */
 581
 582 /* This represents the value which the identifier has in the
 583    file-scope namespace.  */
 584 #define IDENTIFIER_GLOBAL_VALUE(NODE)   \
 585   (((struct lang_identifier *)(NODE))->global_value)
 586 /* This represents the value which the identifier has in the current
 587    scope.  */
 588 #define IDENTIFIER_LOCAL_VALUE(NODE)    \
 589   (((struct lang_identifier *)(NODE))->local_value)
 590 /* This represents the value which the identifier has as a label in
 591    the current label scope.  */
 592 #define IDENTIFIER_LABEL_VALUE(NODE)    \
 593   (((struct lang_identifier *)(NODE))->label_value)
 594 /* This is nonzero if the identifier was "made up" by g77 code.  */
 595 #define IDENTIFIER_INVENTED(NODE)       \
 596   (((struct lang_identifier *)(NODE))->invented)
 597
 598 /* In identifiers, C uses the following fields in a special way:
 599    TREE_PUBLIC        to record that there was a previous local extern decl.
 600    TREE_USED          to record that such a decl was used.
 601    TREE_ADDRESSABLE   to record that the address of such a decl was used.  */
 602
 603 /* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function
 604    that have names.  Here so we can clear out their names' definitions
 605    at the end of the function.  */
 606
 607 static tree named_labels;
 608
 609 /* A list of LABEL_DECLs from outer contexts that are currently shadowed.  */
 610
 611 static tree shadowed_labels;
 612 \f
 613 /* Return the subscript expression, modified to do range-checking.
 614
 615    `array' is the array to be checked against.
 616    `element' is the subscript expression to check.
 617    `dim' is the dimension number (starting at 0).
 618    `total_dims' is the total number of dimensions (0 for CHARACTER substring).
 619 */
 620
 621 static tree
 622 ffecom_subscript_check_ (tree array, tree element, int dim, int total_dims,
 623                          const char *array_name)
 624 {
 625   tree low = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
 626   tree high = TYPE_MAX_VALUE (TYPE_DOMAIN (array));
 627   tree cond;
 628   tree die;
 629   tree args;
 630
 631   if (element == error_mark_node)
 632     return element;
 633
 634   if (TREE_TYPE (low) != TREE_TYPE (element))
 635     {
 636       if (TYPE_PRECISION (TREE_TYPE (low))
 637           > TYPE_PRECISION (TREE_TYPE (element)))
 638         element = convert (TREE_TYPE (low), element);
 639       else
 640         {
 641           low = convert (TREE_TYPE (element), low);
 642           if (high)
 643             high = convert (TREE_TYPE (element), high);
 644         }
 645     }
 646
 647   element = ffecom_save_tree (element);
 648   if (total_dims == 0)
 649     {
 650       /* Special handling for substring range checks.  Fortran allows the
 651          end subscript < begin subscript, which means that expressions like
 652        string(1:0) are valid (and yield a null string).  In view of this,
 653        enforce two simpler conditions:
 654           1) element<=high for end-substring;
 655           2) element>=low for start-substring.
 656        Run-time character movement will enforce remaining conditions.
 657
 658        More complicated checks would be better, but present structure only
 659        provides one index element at a time, so it is not possible to
 660        enforce a check of both i and j in string(i:j).  If it were, the
 661        complete set of rules would read,
 662          if ( ((j<i) && ((low<=i<=high) || (low<=j<=high))) ||
 663               ((low<=i<=high) && (low<=j<=high)) )
 664            ok ;
 665          else
 666            range error ;
 667       */
 668       if (dim)
 669         cond = ffecom_2 (LE_EXPR, integer_type_node, element, high);
 670       else
 671         cond = ffecom_2 (LE_EXPR, integer_type_node, low, element);
 672     }
 673   else
 674     {
 675       /* Array reference substring range checking.  */
 676
 677       cond = ffecom_2 (LE_EXPR, integer_type_node,
 678                      low,
 679                      element);
 680       if (high)
 681         {
 682           cond = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
 683                          cond,
 684                          ffecom_2 (LE_EXPR, integer_type_node,
 685                                    element,
 686                                    high));
 687         }
 688     }
 689
 690   {
 691     int len;
 692     char *proc;
 693     char *var;
 694     tree arg3;
 695     tree arg2;
 696     tree arg1;
 697     tree arg4;
 698
 699     switch (total_dims)
 700       {
 701       case 0:
 702         var = concat (array_name, "[", (dim ? "end" : "start"),
 703                       "-substring]", NULL);
 704         len = strlen (var) + 1;
 705         arg1 = build_string (len, var);
 706         free (var);
 707         break;
 708
 709       case 1:
 710         len = strlen (array_name) + 1;
 711         arg1 = build_string (len, array_name);
 712         break;
 713
 714       default:
 715         var = xmalloc (strlen (array_name) + 40);
 716         sprintf (var, "%s[subscript-%d-of-%d]",
 717                  array_name,
 718                  dim + 1, total_dims);
 719         len = strlen (var) + 1;
 720         arg1 = build_string (len, var);
 721         free (var);
 722         break;
 723       }
 724
 725     TREE_TYPE (arg1)
 726       = build_type_variant (build_array_type (char_type_node,
 727                                               build_range_type
 728                                               (integer_type_node,
 729                                                integer_one_node,
 730                                                build_int_2 (len, 0))),
 731                             1, 0);
 732     TREE_CONSTANT (arg1) = 1;
 733     TREE_STATIC (arg1) = 1;
 734     arg1 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg1)),
 735                      arg1);
 736
 737     /* s_rnge adds one to the element to print it, so bias against
 738        that -- want to print a faithful *subscript* value.  */
 739     arg2 = convert (ffecom_f2c_ftnint_type_node,
 740                     ffecom_2 (MINUS_EXPR,
 741                               TREE_TYPE (element),
 742                               element,
 743                               convert (TREE_TYPE (element),
 744                                        integer_one_node)));
 745
 746     proc = concat (input_filename, "/",
 747                    IDENTIFIER_POINTER (DECL_NAME (current_function_decl)),
 748                    NULL);
 749     len = strlen (proc) + 1;
 750     arg3 = build_string (len, proc);
 751
 752     free (proc);
 753
 754     TREE_TYPE (arg3)
 755       = build_type_variant (build_array_type (char_type_node,
 756                                               build_range_type
 757                                               (integer_type_node,
 758                                                integer_one_node,
 759                                                build_int_2 (len, 0))),
 760                             1, 0);
 761     TREE_CONSTANT (arg3) = 1;
 762     TREE_STATIC (arg3) = 1;
 763     arg3 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg3)),
 764                      arg3);
 765
 766     arg4 = convert (ffecom_f2c_ftnint_type_node,
 767                     build_int_2 (lineno, 0));
 768
 769     arg1 = build_tree_list (NULL_TREE, arg1);
 770     arg2 = build_tree_list (NULL_TREE, arg2);
 771     arg3 = build_tree_list (NULL_TREE, arg3);
 772     arg4 = build_tree_list (NULL_TREE, arg4);
 773     TREE_CHAIN (arg3) = arg4;
 774     TREE_CHAIN (arg2) = arg3;
 775     TREE_CHAIN (arg1) = arg2;
 776
 777     args = arg1;
 778   }
 779   die = ffecom_call_gfrt (FFECOM_gfrtRANGE,
 780                           args, NULL_TREE);
 781   TREE_SIDE_EFFECTS (die) = 1;
 782
 783   element = ffecom_3 (COND_EXPR,
 784                       TREE_TYPE (element),
 785                       cond,
 786                       element,
 787                       die);
 788
 789   return element;
 790 }
 791
 792 /* Return the computed element of an array reference.
 793
 794    `item' is NULL_TREE, or the transformed pointer to the array.
 795    `expr' is the original opARRAYREF expression, which is transformed
 796      if `item' is NULL_TREE.
 797    `want_ptr' is non-zero if a pointer to the element, instead of
 798      the element itself, is to be returned.  */
 799
 800 static tree
 801 ffecom_arrayref_ (tree item, ffebld expr, int want_ptr)
 802 {
 803   ffebld dims[FFECOM_dimensionsMAX];
 804   int i;
 805   int total_dims;
 806   int flatten = ffe_is_flatten_arrays ();
 807   int need_ptr;
 808   tree array;
 809   tree element;
 810   tree tree_type;
 811   tree tree_type_x;
 812   const char *array_name;
 813   ffetype type;
 814   ffebld list;
 815
 816   if (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER)
 817     array_name = ffesymbol_text (ffebld_symter (ffebld_left (expr)));
 818   else
 819     array_name = "[expr?]";
 820
 821   /* Build up ARRAY_REFs in reverse order (since we're column major
 822      here in Fortran land). */
 823
 824   for (i = 0, list = ffebld_right (expr);
 825        list != NULL;
 826        ++i, list = ffebld_trail (list))
 827     {
 828       dims[i] = ffebld_head (list);
 829       type = ffeinfo_type (ffebld_basictype (dims[i]),
 830                            ffebld_kindtype (dims[i]));
 831       if (! flatten
 832           && ffecom_typesize_pointer_ > ffecom_typesize_integer1_
 833           && ffetype_size (type) > ffecom_typesize_integer1_)
 834         /* E.g. ARRAY(INDEX), given INTEGER*8 INDEX, on a system with 64-bit
 835            pointers and 32-bit integers.  Do the full 64-bit pointer
 836            arithmetic, for codes using arrays for nonstandard heap-like
 837            work.  */
 838         flatten = 1;
 839     }
 840
 841   total_dims = i;
 842
 843   need_ptr = want_ptr || flatten;
 844
 845   if (! item)
 846     {
 847       if (need_ptr)
 848         item = ffecom_ptr_to_expr (ffebld_left (expr));
 849       else
 850         item = ffecom_expr (ffebld_left (expr));
 851
 852       if (item == error_mark_node)
 853         return item;
 854
 855       if (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereFLEETING
 856           && ! mark_addressable (item))
 857         return error_mark_node;
 858     }
 859
 860   if (item == error_mark_node)
 861     return item;
 862
 863   if (need_ptr)
 864     {
 865       tree min;
 866
 867       for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
 868            i >= 0;
 869            --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array)))
 870         {
 871           min = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
 872           element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
 873           if (flag_bounds_check)
 874             element = ffecom_subscript_check_ (array, element, i, total_dims,
 875                                                array_name);
 876           if (element == error_mark_node)
 877             return element;
 878
 879           /* Widen integral arithmetic as desired while preserving
 880              signedness.  */
 881           tree_type = TREE_TYPE (element);
 882           tree_type_x = tree_type;
 883           if (tree_type
 884               && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
 885               && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
 886             tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
 887
 888           if (TREE_TYPE (min) != tree_type_x)
 889             min = convert (tree_type_x, min);
 890           if (TREE_TYPE (element) != tree_type_x)
 891             element = convert (tree_type_x, element);
 892
 893           item = ffecom_2 (PLUS_EXPR,
 894                            build_pointer_type (TREE_TYPE (array)),
 895                            item,
 896                            size_binop (MULT_EXPR,
 897                                        size_in_bytes (TREE_TYPE (array)),
 898                                        convert (sizetype,
 899                                                 fold (build (MINUS_EXPR,
 900                                                              tree_type_x,
 901                                                              element, min)))));
 902         }
 903       if (! want_ptr)
 904         {
 905           item = ffecom_1 (INDIRECT_REF,
 906                            TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
 907                            item);
 908         }
 909     }
 910   else
 911     {
 912       for (--i;
 913            i >= 0;
 914            --i)
 915         {
 916           array = TYPE_MAIN_VARIANT (TREE_TYPE (item));
 917
 918           element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
 919           if (flag_bounds_check)
 920             element = ffecom_subscript_check_ (array, element, i, total_dims,
 921                                                array_name);
 922           if (element == error_mark_node)
 923             return element;
 924
 925           /* Widen integral arithmetic as desired while preserving
 926              signedness.  */
 927           tree_type = TREE_TYPE (element);
 928           tree_type_x = tree_type;
 929           if (tree_type
 930               && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
 931               && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
 932             tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
 933
 934           element = convert (tree_type_x, element);
 935
 936           item = ffecom_2 (ARRAY_REF,
 937                            TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
 938                            item,
 939                            element);
 940         }
 941     }
 942
 943   return item;
 944 }
 945
 946 /* This is like gcc's stabilize_reference -- in fact, most of the code
 947    comes from that -- but it handles the situation where the reference
 948    is going to have its subparts picked at, and it shouldn't change
 949    (or trigger extra invocations of functions in the subtrees) due to
 950    this.  save_expr is a bit overzealous, because we don't need the
 951    entire thing calculated and saved like a temp.  So, for DECLs, no
 952    change is needed, because these are stable aggregates, and ARRAY_REF
 953    and such might well be stable too, but for things like calculations,
 954    we do need to calculate a snapshot of a value before picking at it.  */
 955
 956 static tree
 957 ffecom_stabilize_aggregate_ (tree ref)
 958 {
 959   tree result;
 960   enum tree_code code = TREE_CODE (ref);
 961
 962   switch (code)
 963     {
 964     case VAR_DECL:
 965     case PARM_DECL:
 966     case RESULT_DECL:
 967       /* No action is needed in this case.  */
 968       return ref;
 969
 970     case NOP_EXPR:
 971     case CONVERT_EXPR:
 972     case FLOAT_EXPR:
 973     case FIX_TRUNC_EXPR:
 974     case FIX_FLOOR_EXPR:
 975     case FIX_ROUND_EXPR:
 976     case FIX_CEIL_EXPR:
 977       result = build_nt (code, stabilize_reference (TREE_OPERAND (ref, 0)));
 978       break;
 979
 980     case INDIRECT_REF:
 981       result = build_nt (INDIRECT_REF,
 982                          stabilize_reference_1 (TREE_OPERAND (ref, 0)));
 983       break;
 984
 985     case COMPONENT_REF:
 986       result = build_nt (COMPONENT_REF,
 987                          stabilize_reference (TREE_OPERAND (ref, 0)),
 988                          TREE_OPERAND (ref, 1));
 989       break;
 990
 991     case BIT_FIELD_REF:
 992       result = build_nt (BIT_FIELD_REF,
 993                          stabilize_reference (TREE_OPERAND (ref, 0)),
 994                          stabilize_reference_1 (TREE_OPERAND (ref, 1)),
 995                          stabilize_reference_1 (TREE_OPERAND (ref, 2)));
 996       break;
 997
 998     case ARRAY_REF:
 999       result = build_nt (ARRAY_REF,
1000                          stabilize_reference (TREE_OPERAND (ref, 0)),
1001                          stabilize_reference_1 (TREE_OPERAND (ref, 1)));
1002       break;
1003
1004     case COMPOUND_EXPR:
1005       result = build_nt (COMPOUND_EXPR,
1006                          stabilize_reference_1 (TREE_OPERAND (ref, 0)),
1007                          stabilize_reference (TREE_OPERAND (ref, 1)));
1008       break;
1009
1010     case RTL_EXPR:
1011       abort ();
1012
1013
1014     default:
1015       return save_expr (ref);
1016
1017     case ERROR_MARK:
1018       return error_mark_node;
1019     }
1020
1021   TREE_TYPE (result) = TREE_TYPE (ref);
1022   TREE_READONLY (result) = TREE_READONLY (ref);
1023   TREE_SIDE_EFFECTS (result) = TREE_SIDE_EFFECTS (ref);
1024   TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref);
1025
1026   return result;
1027 }
1028
1029 /* A rip-off of gcc's convert.c convert_to_complex function,
1030    reworked to handle complex implemented as C structures
1031    (RECORD_TYPE with two fields, real and imaginary `r' and `i').  */
1032
1033 static tree
1034 ffecom_convert_to_complex_ (tree type, tree expr)
1035 {
1036   register enum tree_code form = TREE_CODE (TREE_TYPE (expr));
1037   tree subtype;
1038
1039   assert (TREE_CODE (type) == RECORD_TYPE);
1040
1041   subtype = TREE_TYPE (TYPE_FIELDS (type));
1042
1043   if (form == REAL_TYPE || form == INTEGER_TYPE || form == ENUMERAL_TYPE)
1044     {
1045       expr = convert (subtype, expr);
1046       return ffecom_2 (COMPLEX_EXPR, type, expr,
1047                        convert (subtype, integer_zero_node));
1048     }
1049
1050   if (form == RECORD_TYPE)
1051     {
1052       tree elt_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr)));
1053       if (TYPE_MAIN_VARIANT (elt_type) == TYPE_MAIN_VARIANT (subtype))
1054         return expr;
1055       else
1056         {
1057           expr = save_expr (expr);
1058           return ffecom_2 (COMPLEX_EXPR,
1059                            type,
1060                            convert (subtype,
1061                                     ffecom_1 (REALPART_EXPR,
1062                                               TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1063                                               expr)),
1064                            convert (subtype,
1065                                     ffecom_1 (IMAGPART_EXPR,
1066                                               TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1067                                               expr)));
1068         }
1069     }
1070
1071   if (form == POINTER_TYPE || form == REFERENCE_TYPE)
1072     error ("pointer value used where a complex was expected");
1073   else
1074     error ("aggregate value used where a complex was expected");
1075
1076   return ffecom_2 (COMPLEX_EXPR, type,
1077                    convert (subtype, integer_zero_node),
1078                    convert (subtype, integer_zero_node));
1079 }
1080
1081 /* Like gcc's convert(), but crashes if widening might happen.  */
1082
1083 static tree
1084 ffecom_convert_narrow_ (type, expr)
1085      tree type, expr;
1086 {
1087   register tree e = expr;
1088   register enum tree_code code = TREE_CODE (type);
1089
1090   if (type == TREE_TYPE (e)
1091       || TREE_CODE (e) == ERROR_MARK)
1092     return e;
1093   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1094     return fold (build1 (NOP_EXPR, type, e));
1095   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1096       || code == ERROR_MARK)
1097     return error_mark_node;
1098   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1099     {
1100       assert ("void value not ignored as it ought to be" == NULL);
1101       return error_mark_node;
1102     }
1103   assert (code != VOID_TYPE);
1104   if ((code != RECORD_TYPE)
1105       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1106     assert ("converting COMPLEX to REAL" == NULL);
1107   assert (code != ENUMERAL_TYPE);
1108   if (code == INTEGER_TYPE)
1109     {
1110       assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1111                && TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)))
1112               || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1113                   && (TYPE_PRECISION (type)
1114                       == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1115       return fold (convert_to_integer (type, e));
1116     }
1117   if (code == POINTER_TYPE)
1118     {
1119       assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1120       return fold (convert_to_pointer (type, e));
1121     }
1122   if (code == REAL_TYPE)
1123     {
1124       assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1125       assert (TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)));
1126       return fold (convert_to_real (type, e));
1127     }
1128   if (code == COMPLEX_TYPE)
1129     {
1130       assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1131       assert (TYPE_PRECISION (TREE_TYPE (type)) <= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1132       return fold (convert_to_complex (type, e));
1133     }
1134   if (code == RECORD_TYPE)
1135     {
1136       assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1137       /* Check that at least the first field name agrees.  */
1138       assert (DECL_NAME (TYPE_FIELDS (type))
1139               == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1140       assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1141               <= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1142       if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1143           == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1144         return e;
1145       return fold (ffecom_convert_to_complex_ (type, e));
1146     }
1147
1148   assert ("conversion to non-scalar type requested" == NULL);
1149   return error_mark_node;
1150 }
1151
1152 /* Like gcc's convert(), but crashes if narrowing might happen.  */
1153
1154 static tree
1155 ffecom_convert_widen_ (type, expr)
1156      tree type, expr;
1157 {
1158   register tree e = expr;
1159   register enum tree_code code = TREE_CODE (type);
1160
1161   if (type == TREE_TYPE (e)
1162       || TREE_CODE (e) == ERROR_MARK)
1163     return e;
1164   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1165     return fold (build1 (NOP_EXPR, type, e));
1166   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1167       || code == ERROR_MARK)
1168     return error_mark_node;
1169   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1170     {
1171       assert ("void value not ignored as it ought to be" == NULL);
1172       return error_mark_node;
1173     }
1174   assert (code != VOID_TYPE);
1175   if ((code != RECORD_TYPE)
1176       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1177     assert ("narrowing COMPLEX to REAL" == NULL);
1178   assert (code != ENUMERAL_TYPE);
1179   if (code == INTEGER_TYPE)
1180     {
1181       assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1182                && TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)))
1183               || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1184                   && (TYPE_PRECISION (type)
1185                       == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1186       return fold (convert_to_integer (type, e));
1187     }
1188   if (code == POINTER_TYPE)
1189     {
1190       assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1191       return fold (convert_to_pointer (type, e));
1192     }
1193   if (code == REAL_TYPE)
1194     {
1195       assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1196       assert (TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)));
1197       return fold (convert_to_real (type, e));
1198     }
1199   if (code == COMPLEX_TYPE)
1200     {
1201       assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1202       assert (TYPE_PRECISION (TREE_TYPE (type)) >= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1203       return fold (convert_to_complex (type, e));
1204     }
1205   if (code == RECORD_TYPE)
1206     {
1207       assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1208       /* Check that at least the first field name agrees.  */
1209       assert (DECL_NAME (TYPE_FIELDS (type))
1210               == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1211       assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1212               >= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1213       if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1214           == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1215         return e;
1216       return fold (ffecom_convert_to_complex_ (type, e));
1217     }
1218
1219   assert ("conversion to non-scalar type requested" == NULL);
1220   return error_mark_node;
1221 }
1222
1223 /* Handles making a COMPLEX type, either the standard
1224    (but buggy?) gbe way, or the safer (but less elegant?)
1225    f2c way.  */
1226
1227 static tree
1228 ffecom_make_complex_type_ (tree subtype)
1229 {
1230   tree type;
1231   tree realfield;
1232   tree imagfield;
1233
1234   if (ffe_is_emulate_complex ())
1235     {
1236       type = make_node (RECORD_TYPE);
1237       realfield = ffecom_decl_field (type, NULL_TREE, "r", subtype);
1238       imagfield = ffecom_decl_field (type, realfield, "i", subtype);
1239       TYPE_FIELDS (type) = realfield;
1240       layout_type (type);
1241     }
1242   else
1243     {
1244       type = make_node (COMPLEX_TYPE);
1245       TREE_TYPE (type) = subtype;
1246       layout_type (type);
1247     }
1248
1249   return type;
1250 }
1251
1252 /* Chooses either the gbe or the f2c way to build a
1253    complex constant.  */
1254
1255 static tree
1256 ffecom_build_complex_constant_ (tree type, tree realpart, tree imagpart)
1257 {
1258   tree bothparts;
1259
1260   if (ffe_is_emulate_complex ())
1261     {
1262       bothparts = build_tree_list (TYPE_FIELDS (type), realpart);
1263       TREE_CHAIN (bothparts) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), imagpart);
1264       bothparts = build (CONSTRUCTOR, type, NULL_TREE, bothparts);
1265     }
1266   else
1267     {
1268       bothparts = build_complex (type, realpart, imagpart);
1269     }
1270
1271   return bothparts;
1272 }
1273
1274 static tree
1275 ffecom_arglist_expr_ (const char *c, ffebld expr)
1276 {
1277   tree list;
1278   tree *plist = &list;
1279   tree trail = NULL_TREE;       /* Append char length args here. */
1280   tree *ptrail = &trail;
1281   tree length;
1282   ffebld exprh;
1283   tree item;
1284   bool ptr = FALSE;
1285   tree wanted = NULL_TREE;
1286   static const char zed[] = "0";
1287
1288   if (c == NULL)
1289     c = &zed[0];
1290
1291   while (expr != NULL)
1292     {
1293       if (*c != '\0')
1294         {
1295           ptr = FALSE;
1296           if (*c == '&')
1297             {
1298               ptr = TRUE;
1299               ++c;
1300             }
1301           switch (*(c++))
1302             {
1303             case '\0':
1304               ptr = TRUE;
1305               wanted = NULL_TREE;
1306               break;
1307
1308             case 'a':
1309               assert (ptr);
1310               wanted = NULL_TREE;
1311               break;
1312
1313             case 'c':
1314               wanted = ffecom_f2c_complex_type_node;
1315               break;
1316
1317             case 'd':
1318               wanted = ffecom_f2c_doublereal_type_node;
1319               break;
1320
1321             case 'e':
1322               wanted = ffecom_f2c_doublecomplex_type_node;
1323               break;
1324
1325             case 'f':
1326               wanted = ffecom_f2c_real_type_node;
1327               break;
1328
1329             case 'i':
1330               wanted = ffecom_f2c_integer_type_node;
1331               break;
1332
1333             case 'j':
1334               wanted = ffecom_f2c_longint_type_node;
1335               break;
1336
1337             default:
1338               assert ("bad argstring code" == NULL);
1339               wanted = NULL_TREE;
1340               break;
1341             }
1342         }
1343
1344       exprh = ffebld_head (expr);
1345       if (exprh == NULL)
1346         wanted = NULL_TREE;
1347
1348       if ((wanted == NULL_TREE)
1349           || (ptr
1350               && (TYPE_MODE
1351                   (ffecom_tree_type[ffeinfo_basictype (ffebld_info (exprh))]
1352                    [ffeinfo_kindtype (ffebld_info (exprh))])
1353                    == TYPE_MODE (wanted))))
1354         *plist
1355           = build_tree_list (NULL_TREE,
1356                              ffecom_arg_ptr_to_expr (exprh,
1357                                                      &length));
1358       else
1359         {
1360           item = ffecom_arg_expr (exprh, &length);
1361           item = ffecom_convert_widen_ (wanted, item);
1362           if (ptr)
1363             {
1364               item = ffecom_1 (ADDR_EXPR,
1365                                build_pointer_type (TREE_TYPE (item)),
1366                                item);
1367             }
1368           *plist
1369             = build_tree_list (NULL_TREE,
1370                                item);
1371         }
1372
1373       plist = &TREE_CHAIN (*plist);
1374       expr = ffebld_trail (expr);
1375       if (length != NULL_TREE)
1376         {
1377           *ptrail = build_tree_list (NULL_TREE, length);
1378           ptrail = &TREE_CHAIN (*ptrail);
1379         }
1380     }
1381
1382   /* We've run out of args in the call; if the implementation expects
1383      more, supply null pointers for them, which the implementation can
1384      check to see if an arg was omitted. */
1385
1386   while (*c != '\0' && *c != '0')
1387     {
1388       if (*c == '&')
1389         ++c;
1390       else
1391         assert ("missing arg to run-time routine!" == NULL);
1392
1393       switch (*(c++))
1394         {
1395         case '\0':
1396         case 'a':
1397         case 'c':
1398         case 'd':
1399         case 'e':
1400         case 'f':
1401         case 'i':
1402         case 'j':
1403           break;
1404
1405         default:
1406           assert ("bad arg string code" == NULL);
1407           break;
1408         }
1409       *plist
1410         = build_tree_list (NULL_TREE,
1411                            null_pointer_node);
1412       plist = &TREE_CHAIN (*plist);
1413     }
1414
1415   *plist = trail;
1416
1417   return list;
1418 }
1419
1420 static tree
1421 ffecom_widest_expr_type_ (ffebld list)
1422 {
1423   ffebld item;
1424   ffebld widest = NULL;
1425   ffetype type;
1426   ffetype widest_type = NULL;
1427   tree t;
1428
1429   for (; list != NULL; list = ffebld_trail (list))
1430     {
1431       item = ffebld_head (list);
1432       if (item == NULL)
1433         continue;
1434       if ((widest != NULL)
1435           && (ffeinfo_basictype (ffebld_info (item))
1436               != ffeinfo_basictype (ffebld_info (widest))))
1437         continue;
1438       type = ffeinfo_type (ffeinfo_basictype (ffebld_info (item)),
1439                            ffeinfo_kindtype (ffebld_info (item)));
1440       if ((widest == FFEINFO_kindtypeNONE)
1441           || (ffetype_size (type)
1442               > ffetype_size (widest_type)))
1443         {
1444           widest = item;
1445           widest_type = type;
1446         }
1447     }
1448
1449   assert (widest != NULL);
1450   t = ffecom_tree_type[ffeinfo_basictype (ffebld_info (widest))]
1451     [ffeinfo_kindtype (ffebld_info (widest))];
1452   assert (t != NULL_TREE);
1453   return t;
1454 }
1455
1456 /* Check whether a partial overlap between two expressions is possible.
1457
1458    Can *starting* to write a portion of expr1 change the value
1459    computed (perhaps already, *partially*) by expr2?
1460
1461    Currently, this is a concern only for a COMPLEX expr1.  But if it
1462    isn't in COMMON or local EQUIVALENCE, since we don't support
1463    aliasing of arguments, it isn't a concern.  */
1464
1465 static bool
1466 ffecom_possible_partial_overlap_ (ffebld expr1, ffebld expr2 ATTRIBUTE_UNUSED)
1467 {
1468   ffesymbol sym;
1469   ffestorag st;
1470
1471   switch (ffebld_op (expr1))
1472     {
1473     case FFEBLD_opSYMTER:
1474       sym = ffebld_symter (expr1);
1475       break;
1476
1477     case FFEBLD_opARRAYREF:
1478       if (ffebld_op (ffebld_left (expr1)) != FFEBLD_opSYMTER)
1479         return FALSE;
1480       sym = ffebld_symter (ffebld_left (expr1));
1481       break;
1482
1483     default:
1484       return FALSE;
1485     }
1486
1487   if (ffesymbol_where (sym) != FFEINFO_whereCOMMON
1488       && (ffesymbol_where (sym) != FFEINFO_whereLOCAL
1489           || ! (st = ffesymbol_storage (sym))
1490           || ! ffestorag_parent (st)))
1491     return FALSE;
1492
1493   /* It's in COMMON or local EQUIVALENCE.  */
1494
1495   return TRUE;
1496 }
1497
1498 /* Check whether dest and source might overlap.  ffebld versions of these
1499    might or might not be passed, will be NULL if not.
1500
1501    The test is really whether source_tree is modifiable and, if modified,
1502    might overlap destination such that the value(s) in the destination might
1503    change before it is finally modified.  dest_* are the canonized
1504    destination itself.  */
1505
1506 static bool
1507 ffecom_overlap_ (tree dest_decl, tree dest_offset, tree dest_size,
1508                  tree source_tree, ffebld source UNUSED,
1509                  bool scalar_arg)
1510 {
1511   tree source_decl;
1512   tree source_offset;
1513   tree source_size;
1514   tree t;
1515
1516   if (source_tree == NULL_TREE)
1517     return FALSE;
1518
1519   switch (TREE_CODE (source_tree))
1520     {
1521     case ERROR_MARK:
1522     case IDENTIFIER_NODE:
1523     case INTEGER_CST:
1524     case REAL_CST:
1525     case COMPLEX_CST:
1526     case STRING_CST:
1527     case CONST_DECL:
1528     case VAR_DECL:
1529     case RESULT_DECL:
1530     case FIELD_DECL:
1531     case MINUS_EXPR:
1532     case MULT_EXPR:
1533     case TRUNC_DIV_EXPR:
1534     case CEIL_DIV_EXPR:
1535     case FLOOR_DIV_EXPR:
1536     case ROUND_DIV_EXPR:
1537     case TRUNC_MOD_EXPR:
1538     case CEIL_MOD_EXPR:
1539     case FLOOR_MOD_EXPR:
1540     case ROUND_MOD_EXPR:
1541     case RDIV_EXPR:
1542     case EXACT_DIV_EXPR:
1543     case FIX_TRUNC_EXPR:
1544     case FIX_CEIL_EXPR:
1545     case FIX_FLOOR_EXPR:
1546     case FIX_ROUND_EXPR:
1547     case FLOAT_EXPR:
1548     case NEGATE_EXPR:
1549     case MIN_EXPR:
1550     case MAX_EXPR:
1551     case ABS_EXPR:
1552     case FFS_EXPR:
1553     case LSHIFT_EXPR:
1554     case RSHIFT_EXPR:
1555     case LROTATE_EXPR:
1556     case RROTATE_EXPR:
1557     case BIT_IOR_EXPR:
1558     case BIT_XOR_EXPR:
1559     case BIT_AND_EXPR:
1560     case BIT_ANDTC_EXPR:
1561     case BIT_NOT_EXPR:
1562     case TRUTH_ANDIF_EXPR:
1563     case TRUTH_ORIF_EXPR:
1564     case TRUTH_AND_EXPR:
1565     case TRUTH_OR_EXPR:
1566     case TRUTH_XOR_EXPR:
1567     case TRUTH_NOT_EXPR:
1568     case LT_EXPR:
1569     case LE_EXPR:
1570     case GT_EXPR:
1571     case GE_EXPR:
1572     case EQ_EXPR:
1573     case NE_EXPR:
1574     case COMPLEX_EXPR:
1575     case CONJ_EXPR:
1576     case REALPART_EXPR:
1577     case IMAGPART_EXPR:
1578     case LABEL_EXPR:
1579     case COMPONENT_REF:
1580       return FALSE;
1581
1582     case COMPOUND_EXPR:
1583       return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1584                               TREE_OPERAND (source_tree, 1), NULL,
1585                               scalar_arg);
1586
1587     case MODIFY_EXPR:
1588       return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1589                               TREE_OPERAND (source_tree, 0), NULL,
1590                               scalar_arg);
1591
1592     case CONVERT_EXPR:
1593     case NOP_EXPR:
1594     case NON_LVALUE_EXPR:
1595     case PLUS_EXPR:
1596       if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1597         return TRUE;
1598
1599       ffecom_tree_canonize_ptr_ (&source_decl, &source_offset,
1600                                  source_tree);
1601       source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1602       break;
1603
1604     case COND_EXPR:
1605       return
1606         ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1607                          TREE_OPERAND (source_tree, 1), NULL,
1608                          scalar_arg)
1609           || ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1610                               TREE_OPERAND (source_tree, 2), NULL,
1611                               scalar_arg);
1612
1613
1614     case ADDR_EXPR:
1615       ffecom_tree_canonize_ref_ (&source_decl, &source_offset,
1616                                  &source_size,
1617                                  TREE_OPERAND (source_tree, 0));
1618       break;
1619
1620     case PARM_DECL:
1621       if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1622         return TRUE;
1623
1624       source_decl = source_tree;
1625       source_offset = bitsize_zero_node;
1626       source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1627       break;
1628
1629     case SAVE_EXPR:
1630     case REFERENCE_EXPR:
1631     case PREDECREMENT_EXPR:
1632     case PREINCREMENT_EXPR:
1633     case POSTDECREMENT_EXPR:
1634     case POSTINCREMENT_EXPR:
1635     case INDIRECT_REF:
1636     case ARRAY_REF:
1637     case CALL_EXPR:
1638     default:
1639       return TRUE;
1640     }
1641
1642   /* Come here when source_decl, source_offset, and source_size filled
1643      in appropriately.  */
1644
1645   if (source_decl == NULL_TREE)
1646     return FALSE;               /* No decl involved, so no overlap. */
1647
1648   if (source_decl != dest_decl)
1649     return FALSE;               /* Different decl, no overlap. */
1650
1651   if (TREE_CODE (dest_size) == ERROR_MARK)
1652     return TRUE;                /* Assignment into entire assumed-size
1653                                    array?  Shouldn't happen.... */
1654
1655   t = ffecom_2 (LE_EXPR, integer_type_node,
1656                 ffecom_2 (PLUS_EXPR, TREE_TYPE (dest_offset),
1657                           dest_offset,
1658                           convert (TREE_TYPE (dest_offset),
1659                                    dest_size)),
1660                 convert (TREE_TYPE (dest_offset),
1661                          source_offset));
1662
1663   if (integer_onep (t))
1664     return FALSE;               /* Destination precedes source. */
1665
1666   if (!scalar_arg
1667       || (source_size == NULL_TREE)
1668       || (TREE_CODE (source_size) == ERROR_MARK)
1669       || integer_zerop (source_size))
1670     return TRUE;                /* No way to tell if dest follows source. */
1671
1672   t = ffecom_2 (LE_EXPR, integer_type_node,
1673                 ffecom_2 (PLUS_EXPR, TREE_TYPE (source_offset),
1674                           source_offset,
1675                           convert (TREE_TYPE (source_offset),
1676                                    source_size)),
1677                 convert (TREE_TYPE (source_offset),
1678                          dest_offset));
1679
1680   if (integer_onep (t))
1681     return FALSE;               /* Destination follows source. */
1682
1683   return TRUE;          /* Destination and source overlap. */
1684 }
1685
1686 /* Check whether dest might overlap any of a list of arguments or is
1687    in a COMMON area the callee might know about (and thus modify).  */
1688
1689 static bool
1690 ffecom_args_overlapping_ (tree dest_tree, ffebld dest UNUSED,
1691                           tree args, tree callee_commons,
1692                           bool scalar_args)
1693 {
1694   tree arg;
1695   tree dest_decl;
1696   tree dest_offset;
1697   tree dest_size;
1698
1699   ffecom_tree_canonize_ref_ (&dest_decl, &dest_offset, &dest_size,
1700                              dest_tree);
1701
1702   if (dest_decl == NULL_TREE)
1703     return FALSE;               /* Seems unlikely! */
1704
1705   /* If the decl cannot be determined reliably, or if its in COMMON
1706      and the callee isn't known to not futz with COMMON via other
1707      means, overlap might happen.  */
1708
1709   if ((TREE_CODE (dest_decl) == ERROR_MARK)
1710       || ((callee_commons != NULL_TREE)
1711           && TREE_PUBLIC (dest_decl)))
1712     return TRUE;
1713
1714   for (; args != NULL_TREE; args = TREE_CHAIN (args))
1715     {
1716       if (((arg = TREE_VALUE (args)) != NULL_TREE)
1717           && ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1718                               arg, NULL, scalar_args))
1719         return TRUE;
1720     }
1721
1722   return FALSE;
1723 }
1724
1725 /* Build a string for a variable name as used by NAMELIST.  This means that
1726    if we're using the f2c library, we build an uppercase string, since
1727    f2c does this.  */
1728
1729 static tree
1730 ffecom_build_f2c_string_ (int i, const char *s)
1731 {
1732   if (!ffe_is_f2c_library ())
1733     return build_string (i, s);
1734
1735   {
1736     char *tmp;
1737     const char *p;
1738     char *q;
1739     char space[34];
1740     tree t;
1741
1742     if (((size_t) i) > ARRAY_SIZE (space))
1743       tmp = malloc_new_ks (malloc_pool_image (), "f2c_string", i);
1744     else
1745       tmp = &space[0];
1746
1747     for (p = s, q = tmp; *p != '\0'; ++p, ++q)
1748       *q = TOUPPER (*p);
1749     *q = '\0';
1750
1751     t = build_string (i, tmp);
1752
1753     if (((size_t) i) > ARRAY_SIZE (space))
1754       malloc_kill_ks (malloc_pool_image (), tmp, i);
1755
1756     return t;
1757   }
1758 }
1759
1760 /* Returns CALL_EXPR or equivalent with given type (pass NULL_TREE for
1761    type to just get whatever the function returns), handling the
1762    f2c value-returning convention, if required, by prepending
1763    to the arglist a pointer to a temporary to receive the return value.  */
1764
1765 static tree
1766 ffecom_call_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1767               tree type, tree args, tree dest_tree,
1768               ffebld dest, bool *dest_used, tree callee_commons,
1769               bool scalar_args, tree hook)
1770 {
1771   tree item;
1772   tree tempvar;
1773
1774   if (dest_used != NULL)
1775     *dest_used = FALSE;
1776
1777   if (is_f2c_complex)
1778     {
1779       if ((dest_used == NULL)
1780           || (dest == NULL)
1781           || (ffeinfo_basictype (ffebld_info (dest))
1782               != FFEINFO_basictypeCOMPLEX)
1783           || (ffeinfo_kindtype (ffebld_info (dest)) != kt)
1784           || ((type != NULL_TREE) && (TREE_TYPE (dest_tree) != type))
1785           || ffecom_args_overlapping_ (dest_tree, dest, args,
1786                                        callee_commons,
1787                                        scalar_args))
1788         {
1789 #ifdef HOHO
1790           tempvar = ffecom_make_tempvar (ffecom_tree_type
1791                                          [FFEINFO_basictypeCOMPLEX][kt],
1792                                          FFETARGET_charactersizeNONE,
1793                                          -1);
1794 #else
1795           tempvar = hook;
1796           assert (tempvar);
1797 #endif
1798         }
1799       else
1800         {
1801           *dest_used = TRUE;
1802           tempvar = dest_tree;
1803           type = NULL_TREE;
1804         }
1805
1806       item
1807         = build_tree_list (NULL_TREE,
1808                            ffecom_1 (ADDR_EXPR,
1809                                      build_pointer_type (TREE_TYPE (tempvar)),
1810                                      tempvar));
1811       TREE_CHAIN (item) = args;
1812
1813       item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1814                         item, NULL_TREE);
1815
1816       if (tempvar != dest_tree)
1817         item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item, tempvar);
1818     }
1819   else
1820     item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1821                       args, NULL_TREE);
1822
1823   if ((type != NULL_TREE) && (TREE_TYPE (item) != type))
1824     item = ffecom_convert_narrow_ (type, item);
1825
1826   return item;
1827 }
1828
1829 /* Given two arguments, transform them and make a call to the given
1830    function via ffecom_call_.  */
1831
1832 static tree
1833 ffecom_call_binop_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1834                     tree type, ffebld left, ffebld right,
1835                     tree dest_tree, ffebld dest, bool *dest_used,
1836                     tree callee_commons, bool scalar_args, bool ref, tree hook)
1837 {
1838   tree left_tree;
1839   tree right_tree;
1840   tree left_length;
1841   tree right_length;
1842
1843   if (ref)
1844     {
1845       /* Pass arguments by reference.  */
1846       left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
1847       right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
1848     }
1849   else
1850     {
1851       /* Pass arguments by value.  */
1852       left_tree = ffecom_arg_expr (left, &left_length);
1853       right_tree = ffecom_arg_expr (right, &right_length);
1854     }
1855
1856
1857   left_tree = build_tree_list (NULL_TREE, left_tree);
1858   right_tree = build_tree_list (NULL_TREE, right_tree);
1859   TREE_CHAIN (left_tree) = right_tree;
1860
1861   if (left_length != NULL_TREE)
1862     {
1863       left_length = build_tree_list (NULL_TREE, left_length);
1864       TREE_CHAIN (right_tree) = left_length;
1865     }
1866
1867   if (right_length != NULL_TREE)
1868     {
1869       right_length = build_tree_list (NULL_TREE, right_length);
1870       if (left_length != NULL_TREE)
1871         TREE_CHAIN (left_length) = right_length;
1872       else
1873         TREE_CHAIN (right_tree) = right_length;
1874     }
1875
1876   return ffecom_call_ (fn, kt, is_f2c_complex, type, left_tree,
1877                        dest_tree, dest, dest_used, callee_commons,
1878                        scalar_args, hook);
1879 }
1880
1881 /* Return ptr/length args for char subexpression
1882
1883    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
1884    subexpressions by constructing the appropriate trees for the ptr-to-
1885    character-text and length-of-character-text arguments in a calling
1886    sequence.
1887
1888    Note that if with_null is TRUE, and the expression is an opCONTER,
1889    a null byte is appended to the string.  */
1890
1891 static void
1892 ffecom_char_args_x_ (tree *xitem, tree *length, ffebld expr, bool with_null)
1893 {
1894   tree item;
1895   tree high;
1896   ffetargetCharacter1 val;
1897   ffetargetCharacterSize newlen;
1898
1899   switch (ffebld_op (expr))
1900     {
1901     case FFEBLD_opCONTER:
1902       val = ffebld_constant_character1 (ffebld_conter (expr));
1903       newlen = ffetarget_length_character1 (val);
1904       if (with_null)
1905         {
1906           /* Begin FFETARGET-NULL-KLUDGE.  */
1907           if (newlen != 0)
1908             ++newlen;
1909         }
1910       *length = build_int_2 (newlen, 0);
1911       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
1912       high = build_int_2 (newlen, 0);
1913       TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
1914       item = build_string (newlen,
1915                            ffetarget_text_character1 (val));
1916       /* End FFETARGET-NULL-KLUDGE.  */
1917       TREE_TYPE (item)
1918         = build_type_variant
1919           (build_array_type
1920            (char_type_node,
1921             build_range_type
1922             (ffecom_f2c_ftnlen_type_node,
1923              ffecom_f2c_ftnlen_one_node,
1924              high)),
1925            1, 0);
1926       TREE_CONSTANT (item) = 1;
1927       TREE_STATIC (item) = 1;
1928       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
1929                        item);
1930       break;
1931
1932     case FFEBLD_opSYMTER:
1933       {
1934         ffesymbol s = ffebld_symter (expr);
1935
1936         item = ffesymbol_hook (s).decl_tree;
1937         if (item == NULL_TREE)
1938           {
1939             s = ffecom_sym_transform_ (s);
1940             item = ffesymbol_hook (s).decl_tree;
1941           }
1942         if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
1943           {
1944             if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
1945               *length = ffesymbol_hook (s).length_tree;
1946             else
1947               {
1948                 *length = build_int_2 (ffesymbol_size (s), 0);
1949                 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
1950               }
1951           }
1952         else if (item == error_mark_node)
1953           *length = error_mark_node;
1954         else
1955           /* FFEINFO_kindFUNCTION.  */
1956           *length = NULL_TREE;
1957         if (!ffesymbol_hook (s).addr
1958             && (item != error_mark_node))
1959           item = ffecom_1 (ADDR_EXPR,
1960                            build_pointer_type (TREE_TYPE (item)),
1961                            item);
1962       }
1963       break;
1964
1965     case FFEBLD_opARRAYREF:
1966       {
1967         ffecom_char_args_ (&item, length, ffebld_left (expr));
1968
1969         if (item == error_mark_node || *length == error_mark_node)
1970           {
1971             item = *length = error_mark_node;
1972             break;
1973           }
1974
1975         item = ffecom_arrayref_ (item, expr, 1);
1976       }
1977       break;
1978
1979     case FFEBLD_opSUBSTR:
1980       {
1981         ffebld start;
1982         ffebld end;
1983         ffebld thing = ffebld_right (expr);
1984         tree start_tree;
1985         tree end_tree;
1986         const char *char_name;
1987         ffebld left_symter;
1988         tree array;
1989
1990         assert (ffebld_op (thing) == FFEBLD_opITEM);
1991         start = ffebld_head (thing);
1992         thing = ffebld_trail (thing);
1993         assert (ffebld_trail (thing) == NULL);
1994         end = ffebld_head (thing);
1995
1996         /* Determine name for pretty-printing range-check errors.  */
1997         for (left_symter = ffebld_left (expr);
1998              left_symter && ffebld_op (left_symter) == FFEBLD_opARRAYREF;
1999              left_symter = ffebld_left (left_symter))
2000           ;
2001         if (ffebld_op (left_symter) == FFEBLD_opSYMTER)
2002           char_name = ffesymbol_text (ffebld_symter (left_symter));
2003         else
2004           char_name = "[expr?]";
2005
2006         ffecom_char_args_ (&item, length, ffebld_left (expr));
2007
2008         if (item == error_mark_node || *length == error_mark_node)
2009           {
2010             item = *length = error_mark_node;
2011             break;
2012           }
2013
2014         array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
2015
2016         /* ~~~~Handle INTEGER*8 start/end, a la FFEBLD_opARRAYREF.  */
2017
2018         if (start == NULL)
2019           {
2020             if (end == NULL)
2021               ;
2022             else
2023               {
2024                 end_tree = ffecom_expr (end);
2025                 if (flag_bounds_check)
2026                   end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2027                                                       char_name);
2028                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2029                                     end_tree);
2030
2031                 if (end_tree == error_mark_node)
2032                   {
2033                     item = *length = error_mark_node;
2034                     break;
2035                   }
2036
2037                 *length = end_tree;
2038               }
2039           }
2040         else
2041           {
2042             start_tree = ffecom_expr (start);
2043             if (flag_bounds_check)
2044               start_tree = ffecom_subscript_check_ (array, start_tree, 0, 0,
2045                                                     char_name);
2046             start_tree = convert (ffecom_f2c_ftnlen_type_node,
2047                                   start_tree);
2048
2049             if (start_tree == error_mark_node)
2050               {
2051                 item = *length = error_mark_node;
2052                 break;
2053               }
2054
2055             start_tree = ffecom_save_tree (start_tree);
2056
2057             item = ffecom_2 (PLUS_EXPR, TREE_TYPE (item),
2058                              item,
2059                              ffecom_2 (MINUS_EXPR,
2060                                        TREE_TYPE (start_tree),
2061                                        start_tree,
2062                                        ffecom_f2c_ftnlen_one_node));
2063
2064             if (end == NULL)
2065               {
2066                 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2067                                     ffecom_f2c_ftnlen_one_node,
2068                                     ffecom_2 (MINUS_EXPR,
2069                                               ffecom_f2c_ftnlen_type_node,
2070                                               *length,
2071                                               start_tree));
2072               }
2073             else
2074               {
2075                 end_tree = ffecom_expr (end);
2076                 if (flag_bounds_check)
2077                   end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2078                                                       char_name);
2079                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2080                                     end_tree);
2081
2082                 if (end_tree == error_mark_node)
2083                   {
2084                     item = *length = error_mark_node;
2085                     break;
2086                   }
2087
2088                 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2089                                     ffecom_f2c_ftnlen_one_node,
2090                                     ffecom_2 (MINUS_EXPR,
2091                                               ffecom_f2c_ftnlen_type_node,
2092                                               end_tree, start_tree));
2093               }
2094           }
2095       }
2096       break;
2097
2098     case FFEBLD_opFUNCREF:
2099       {
2100         ffesymbol s = ffebld_symter (ffebld_left (expr));
2101         tree tempvar;
2102         tree args;
2103         ffetargetCharacterSize size = ffeinfo_size (ffebld_info (expr));
2104         ffecomGfrt ix;
2105
2106         if (size == FFETARGET_charactersizeNONE)
2107           /* ~~Kludge alert!  This should someday be fixed. */
2108           size = 24;
2109
2110         *length = build_int_2 (size, 0);
2111         TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2112
2113         if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
2114             == FFEINFO_whereINTRINSIC)
2115           {
2116             if (size == 1)
2117               {
2118                 /* Invocation of an intrinsic returning CHARACTER*1.  */
2119                 item = ffecom_expr_intrinsic_ (expr, NULL_TREE,
2120                                                NULL, NULL);
2121                 break;
2122               }
2123             ix = ffeintrin_gfrt_direct (ffebld_symter_implementation (ffebld_left (expr)));
2124             assert (ix != FFECOM_gfrt);
2125             item = ffecom_gfrt_tree_ (ix);
2126           }
2127         else
2128           {
2129             ix = FFECOM_gfrt;
2130             item = ffesymbol_hook (s).decl_tree;
2131             if (item == NULL_TREE)
2132               {
2133                 s = ffecom_sym_transform_ (s);
2134                 item = ffesymbol_hook (s).decl_tree;
2135               }
2136             if (item == error_mark_node)
2137               {
2138                 item = *length = error_mark_node;
2139                 break;
2140               }
2141
2142             if (!ffesymbol_hook (s).addr)
2143               item = ffecom_1_fn (item);
2144           }
2145
2146 #ifdef HOHO
2147         tempvar = ffecom_push_tempvar (char_type_node, size, -1, TRUE);
2148 #else
2149         tempvar = ffebld_nonter_hook (expr);
2150         assert (tempvar);
2151 #endif
2152         tempvar = ffecom_1 (ADDR_EXPR,
2153                             build_pointer_type (TREE_TYPE (tempvar)),
2154                             tempvar);
2155
2156         args = build_tree_list (NULL_TREE, tempvar);
2157
2158         if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)       /* Sfunc args by value. */
2159           TREE_CHAIN (args) = ffecom_list_expr (ffebld_right (expr));
2160         else
2161           {
2162             TREE_CHAIN (args) = build_tree_list (NULL_TREE, *length);
2163             if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
2164               {
2165                 TREE_CHAIN (TREE_CHAIN (args))
2166                   = ffecom_arglist_expr_ (ffecom_gfrt_args_ (ix),
2167                                           ffebld_right (expr));
2168               }
2169             else
2170               {
2171                 TREE_CHAIN (TREE_CHAIN (args))
2172                   = ffecom_list_ptr_to_expr (ffebld_right (expr));
2173               }
2174           }
2175
2176         item = ffecom_3s (CALL_EXPR,
2177                           TREE_TYPE (TREE_TYPE (TREE_TYPE (item))),
2178                           item, args, NULL_TREE);
2179         item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item,
2180                          tempvar);
2181       }
2182       break;
2183
2184     case FFEBLD_opCONVERT:
2185
2186       ffecom_char_args_ (&item, length, ffebld_left (expr));
2187
2188       if (item == error_mark_node || *length == error_mark_node)
2189         {
2190           item = *length = error_mark_node;
2191           break;
2192         }
2193
2194       if ((ffebld_size_known (ffebld_left (expr))
2195            == FFETARGET_charactersizeNONE)
2196           || (ffebld_size_known (ffebld_left (expr)) < (ffebld_size (expr))))
2197         {                       /* Possible blank-padding needed, copy into
2198                                    temporary. */
2199           tree tempvar;
2200           tree args;
2201           tree newlen;
2202
2203 #ifdef HOHO
2204           tempvar = ffecom_make_tempvar (char_type_node,
2205                                          ffebld_size (expr), -1);
2206 #else
2207           tempvar = ffebld_nonter_hook (expr);
2208           assert (tempvar);
2209 #endif
2210           tempvar = ffecom_1 (ADDR_EXPR,
2211                               build_pointer_type (TREE_TYPE (tempvar)),
2212                               tempvar);
2213
2214           newlen = build_int_2 (ffebld_size (expr), 0);
2215           TREE_TYPE (newlen) = ffecom_f2c_ftnlen_type_node;
2216
2217           args = build_tree_list (NULL_TREE, tempvar);
2218           TREE_CHAIN (args) = build_tree_list (NULL_TREE, item);
2219           TREE_CHAIN (TREE_CHAIN (args)) = build_tree_list (NULL_TREE, newlen);
2220           TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (args)))
2221             = build_tree_list (NULL_TREE, *length);
2222
2223           item = ffecom_call_gfrt (FFECOM_gfrtCOPY, args, NULL_TREE);
2224           TREE_SIDE_EFFECTS (item) = 1;
2225           item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), fold (item),
2226                            tempvar);
2227           *length = newlen;
2228         }
2229       else
2230         {                       /* Just truncate the length. */
2231           *length = build_int_2 (ffebld_size (expr), 0);
2232           TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2233         }
2234       break;
2235
2236     default:
2237       assert ("bad op for single char arg expr" == NULL);
2238       item = NULL_TREE;
2239       break;
2240     }
2241
2242   *xitem = item;
2243 }
2244
2245 /* Check the size of the type to be sure it doesn't overflow the
2246    "portable" capacities of the compiler back end.  `dummy' types
2247    can generally overflow the normal sizes as long as the computations
2248    themselves don't overflow.  A particular target of the back end
2249    must still enforce its size requirements, though, and the back
2250    end takes care of this in stor-layout.c.  */
2251
2252 static tree
2253 ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy)
2254 {
2255   if (TREE_CODE (type) == ERROR_MARK)
2256     return type;
2257
2258   if (TYPE_SIZE (type) == NULL_TREE)
2259     return type;
2260
2261   if (TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST)
2262     return type;
2263
2264   if ((tree_int_cst_sgn (TYPE_SIZE (type)) < 0)
2265       || (!dummy && TREE_OVERFLOW (TYPE_SIZE (type))))
2266     {
2267       ffebad_start (FFEBAD_ARRAY_LARGE);
2268       ffebad_string (ffesymbol_text (s));
2269       ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s));
2270       ffebad_finish ();
2271
2272       return error_mark_node;
2273     }
2274
2275   return type;
2276 }
2277
2278 /* Builds a length argument (PARM_DECL).  Also wraps type in an array type
2279    where the dimension info is (1:size) where <size> is ffesymbol_size(s) if
2280    known, length_arg if not known (FFETARGET_charactersizeNONE).  */
2281
2282 static tree
2283 ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s)
2284 {
2285   ffetargetCharacterSize sz = ffesymbol_size (s);
2286   tree highval;
2287   tree tlen;
2288   tree type = *xtype;
2289
2290   if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
2291     tlen = NULL_TREE;           /* A statement function, no length passed. */
2292   else
2293     {
2294       if (ffesymbol_where (s) == FFEINFO_whereDUMMY)
2295         tlen = ffecom_get_invented_identifier ("__g77_length_%s",
2296                                                ffesymbol_text (s));
2297       else
2298         tlen = ffecom_get_invented_identifier ("__g77_%s", "length");
2299       tlen = build_decl (PARM_DECL, tlen, ffecom_f2c_ftnlen_type_node);
2300       DECL_ARTIFICIAL (tlen) = 1;
2301     }
2302
2303   if (sz == FFETARGET_charactersizeNONE)
2304     {
2305       assert (tlen != NULL_TREE);
2306       highval = variable_size (tlen);
2307     }
2308   else
2309     {
2310       highval = build_int_2 (sz, 0);
2311       TREE_TYPE (highval) = ffecom_f2c_ftnlen_type_node;
2312     }
2313
2314   type = build_array_type (type,
2315                            build_range_type (ffecom_f2c_ftnlen_type_node,
2316                                              ffecom_f2c_ftnlen_one_node,
2317                                              highval));
2318
2319   *xtype = type;
2320   return tlen;
2321 }
2322
2323 /* ffecom_concat_list_gather_ -- Gather list of concatenated string exprs
2324
2325    ffecomConcatList_ catlist;
2326    ffebld expr;  // expr of CHARACTER basictype.
2327    ffetargetCharacterSize max;  // max chars to gather or _...NONE if no max
2328    catlist = ffecom_concat_list_gather_(catlist,expr,max);
2329
2330    Scans expr for character subexpressions, updates and returns catlist
2331    accordingly.  */
2332
2333 static ffecomConcatList_
2334 ffecom_concat_list_gather_ (ffecomConcatList_ catlist, ffebld expr,
2335                             ffetargetCharacterSize max)
2336 {
2337   ffetargetCharacterSize sz;
2338
2339  recurse:
2340
2341   if (expr == NULL)
2342     return catlist;
2343
2344   if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen >= max))
2345     return catlist;             /* Don't append any more items. */
2346
2347   switch (ffebld_op (expr))
2348     {
2349     case FFEBLD_opCONTER:
2350     case FFEBLD_opSYMTER:
2351     case FFEBLD_opARRAYREF:
2352     case FFEBLD_opFUNCREF:
2353     case FFEBLD_opSUBSTR:
2354     case FFEBLD_opCONVERT:      /* Callers should strip this off beforehand
2355                                    if they don't need to preserve it. */
2356       if (catlist.count == catlist.max)
2357         {                       /* Make a (larger) list. */
2358           ffebld *newx;
2359           int newmax;
2360
2361           newmax = (catlist.max == 0) ? 8 : catlist.max * 2;
2362           newx = malloc_new_ks (malloc_pool_image (), "catlist",
2363                                 newmax * sizeof (newx[0]));
2364           if (catlist.max != 0)
2365             {
2366               memcpy (newx, catlist.exprs, catlist.max * sizeof (newx[0]));
2367               malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2368                               catlist.max * sizeof (newx[0]));
2369             }
2370           catlist.max = newmax;
2371           catlist.exprs = newx;
2372         }
2373       if ((sz = ffebld_size_known (expr)) != FFETARGET_charactersizeNONE)
2374         catlist.minlen += sz;
2375       else
2376         ++catlist.minlen;       /* Not true for F90; can be 0 length. */
2377       if ((sz = ffebld_size_max (expr)) == FFETARGET_charactersizeNONE)
2378         catlist.maxlen = sz;
2379       else
2380         catlist.maxlen += sz;
2381       if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen > max))
2382         {                       /* This item overlaps (or is beyond) the end
2383                                    of the destination. */
2384           switch (ffebld_op (expr))
2385             {
2386             case FFEBLD_opCONTER:
2387             case FFEBLD_opSYMTER:
2388             case FFEBLD_opARRAYREF:
2389             case FFEBLD_opFUNCREF:
2390             case FFEBLD_opSUBSTR:
2391               /* ~~Do useful truncations here. */
2392               break;
2393
2394             default:
2395               assert ("op changed or inconsistent switches!" == NULL);
2396               break;
2397             }
2398         }
2399       catlist.exprs[catlist.count++] = expr;
2400       return catlist;
2401
2402     case FFEBLD_opPAREN:
2403       expr = ffebld_left (expr);
2404       goto recurse;             /* :::::::::::::::::::: */
2405
2406     case FFEBLD_opCONCATENATE:
2407       catlist = ffecom_concat_list_gather_ (catlist, ffebld_left (expr), max);
2408       expr = ffebld_right (expr);
2409       goto recurse;             /* :::::::::::::::::::: */
2410
2411 #if 0                           /* Breaks passing small actual arg to larger
2412                                    dummy arg of sfunc */
2413     case FFEBLD_opCONVERT:
2414       expr = ffebld_left (expr);
2415       {
2416         ffetargetCharacterSize cmax;
2417
2418         cmax = catlist.len + ffebld_size_known (expr);
2419
2420         if ((max == FFETARGET_charactersizeNONE) || (max > cmax))
2421           max = cmax;
2422       }
2423       goto recurse;             /* :::::::::::::::::::: */
2424 #endif
2425
2426     case FFEBLD_opANY:
2427       return catlist;
2428
2429     default:
2430       assert ("bad op in _gather_" == NULL);
2431       return catlist;
2432     }
2433 }
2434
2435 /* ffecom_concat_list_kill_ -- Kill list of concatenated string exprs
2436
2437    ffecomConcatList_ catlist;
2438    ffecom_concat_list_kill_(catlist);
2439
2440    Anything allocated within the list info is deallocated.  */
2441
2442 static void
2443 ffecom_concat_list_kill_ (ffecomConcatList_ catlist)
2444 {
2445   if (catlist.max != 0)
2446     malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2447                     catlist.max * sizeof (catlist.exprs[0]));
2448 }
2449
2450 /* Make list of concatenated string exprs.
2451
2452    Returns a flattened list of concatenated subexpressions given a
2453    tree of such expressions.  */
2454
2455 static ffecomConcatList_
2456 ffecom_concat_list_new_ (ffebld expr, ffetargetCharacterSize max)
2457 {
2458   ffecomConcatList_ catlist;
2459
2460   catlist.maxlen = catlist.minlen = catlist.max = catlist.count = 0;
2461   return ffecom_concat_list_gather_ (catlist, expr, max);
2462 }
2463
2464 /* Provide some kind of useful info on member of aggregate area,
2465    since current g77/gcc technology does not provide debug info
2466    on these members.  */
2467
2468 static void
2469 ffecom_debug_kludge_ (tree aggr, const char *aggr_type, ffesymbol member,
2470                       tree member_type UNUSED, ffetargetOffset offset)
2471 {
2472   tree value;
2473   tree decl;
2474   int len;
2475   char *buff;
2476   char space[120];
2477 #if 0
2478   tree type_id;
2479
2480   for (type_id = member_type;
2481        TREE_CODE (type_id) != IDENTIFIER_NODE;
2482        )
2483     {
2484       switch (TREE_CODE (type_id))
2485         {
2486         case INTEGER_TYPE:
2487         case REAL_TYPE:
2488           type_id = TYPE_NAME (type_id);
2489           break;
2490
2491         case ARRAY_TYPE:
2492         case COMPLEX_TYPE:
2493           type_id = TREE_TYPE (type_id);
2494           break;
2495
2496         default:
2497           assert ("no IDENTIFIER_NODE for type!" == NULL);
2498           type_id = error_mark_node;
2499           break;
2500         }
2501     }
2502 #endif
2503
2504   if (ffecom_transform_only_dummies_
2505       || !ffe_is_debug_kludge ())
2506     return;     /* Can't do this yet, maybe later. */
2507
2508   len = 60
2509     + strlen (aggr_type)
2510     + IDENTIFIER_LENGTH (DECL_NAME (aggr));
2511 #if 0
2512     + IDENTIFIER_LENGTH (type_id);
2513 #endif
2514
2515   if (((size_t) len) >= ARRAY_SIZE (space))
2516     buff = malloc_new_ks (malloc_pool_image (), "debug_kludge", len + 1);
2517   else
2518     buff = &space[0];
2519
2520   sprintf (&buff[0], "At (%s) `%s' plus %ld bytes",
2521            aggr_type,
2522            IDENTIFIER_POINTER (DECL_NAME (aggr)),
2523            (long int) offset);
2524
2525   value = build_string (len, buff);
2526   TREE_TYPE (value)
2527     = build_type_variant (build_array_type (char_type_node,
2528                                             build_range_type
2529                                             (integer_type_node,
2530                                              integer_one_node,
2531                                              build_int_2 (strlen (buff), 0))),
2532                           1, 0);
2533   decl = build_decl (VAR_DECL,
2534                      ffecom_get_identifier_ (ffesymbol_text (member)),
2535                      TREE_TYPE (value));
2536   TREE_CONSTANT (decl) = 1;
2537   TREE_STATIC (decl) = 1;
2538   DECL_INITIAL (decl) = error_mark_node;
2539   DECL_IN_SYSTEM_HEADER (decl) = 1;     /* Don't let -Wunused complain. */
2540   decl = start_decl (decl, FALSE);
2541   finish_decl (decl, value, FALSE);
2542
2543   if (buff != &space[0])
2544     malloc_kill_ks (malloc_pool_image (), buff, len + 1);
2545 }
2546
2547 /* ffecom_do_entry_ -- Do compilation of a particular entrypoint
2548
2549    ffesymbol fn;  // the SUBROUTINE, FUNCTION, or ENTRY symbol itself
2550    int i;  // entry# for this entrypoint (used by master fn)
2551    ffecom_do_entrypoint_(s,i);
2552
2553    Makes a public entry point that calls our private master fn (already
2554    compiled).  */
2555
2556 static void
2557 ffecom_do_entry_ (ffesymbol fn, int entrynum)
2558 {
2559   ffebld item;
2560   tree type;                    /* Type of function. */
2561   tree multi_retval;            /* Var holding return value (union). */
2562   tree result;                  /* Var holding result. */
2563   ffeinfoBasictype bt;
2564   ffeinfoKindtype kt;
2565   ffeglobal g;
2566   ffeglobalType gt;
2567   bool charfunc;                /* All entry points return same type
2568                                    CHARACTER. */
2569   bool cmplxfunc;               /* Use f2c way of returning COMPLEX. */
2570   bool multi;                   /* Master fn has multiple return types. */
2571   bool altreturning = FALSE;    /* This entry point has alternate returns. */
2572   int old_lineno = lineno;
2573   const char *old_input_filename = input_filename;
2574
2575   input_filename = ffesymbol_where_filename (fn);
2576   lineno = ffesymbol_where_filelinenum (fn);
2577
2578   ffecom_doing_entry_ = TRUE;   /* Don't bother with array dimensions. */
2579
2580   switch (ffecom_primary_entry_kind_)
2581     {
2582     case FFEINFO_kindFUNCTION:
2583
2584       /* Determine actual return type for function. */
2585
2586       gt = FFEGLOBAL_typeFUNC;
2587       bt = ffesymbol_basictype (fn);
2588       kt = ffesymbol_kindtype (fn);
2589       if (bt == FFEINFO_basictypeNONE)
2590         {
2591           ffeimplic_establish_symbol (fn);
2592           if (ffesymbol_funcresult (fn) != NULL)
2593             ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
2594           bt = ffesymbol_basictype (fn);
2595           kt = ffesymbol_kindtype (fn);
2596         }
2597
2598       if (bt == FFEINFO_basictypeCHARACTER)
2599         charfunc = TRUE, cmplxfunc = FALSE;
2600       else if ((bt == FFEINFO_basictypeCOMPLEX)
2601                && ffesymbol_is_f2c (fn))
2602         charfunc = FALSE, cmplxfunc = TRUE;
2603       else
2604         charfunc = cmplxfunc = FALSE;
2605
2606       if (charfunc)
2607         type = ffecom_tree_fun_type_void;
2608       else if (ffesymbol_is_f2c (fn))
2609         type = ffecom_tree_fun_type[bt][kt];
2610       else
2611         type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
2612
2613       if ((type == NULL_TREE)
2614           || (TREE_TYPE (type) == NULL_TREE))
2615         type = ffecom_tree_fun_type_void;       /* _sym_exec_transition. */
2616
2617       multi = (ffecom_master_bt_ == FFEINFO_basictypeNONE);
2618       break;
2619
2620     case FFEINFO_kindSUBROUTINE:
2621       gt = FFEGLOBAL_typeSUBR;
2622       bt = FFEINFO_basictypeNONE;
2623       kt = FFEINFO_kindtypeNONE;
2624       if (ffecom_is_altreturning_)
2625         {                       /* Am _I_ altreturning? */
2626           for (item = ffesymbol_dummyargs (fn);
2627                item != NULL;
2628                item = ffebld_trail (item))
2629             {
2630               if (ffebld_op (ffebld_head (item)) == FFEBLD_opSTAR)
2631                 {
2632                   altreturning = TRUE;
2633                   break;
2634                 }
2635             }
2636           if (altreturning)
2637             type = ffecom_tree_subr_type;
2638           else
2639             type = ffecom_tree_fun_type_void;
2640         }
2641       else
2642         type = ffecom_tree_fun_type_void;
2643       charfunc = FALSE;
2644       cmplxfunc = FALSE;
2645       multi = FALSE;
2646       break;
2647
2648     default:
2649       assert ("say what??" == NULL);
2650       /* Fall through. */
2651     case FFEINFO_kindANY:
2652       gt = FFEGLOBAL_typeANY;
2653       bt = FFEINFO_basictypeNONE;
2654       kt = FFEINFO_kindtypeNONE;
2655       type = error_mark_node;
2656       charfunc = FALSE;
2657       cmplxfunc = FALSE;
2658       multi = FALSE;
2659       break;
2660     }
2661
2662   /* build_decl uses the current lineno and input_filename to set the decl
2663      source info.  So, I've putzed with ffestd and ffeste code to update that
2664      source info to point to the appropriate statement just before calling
2665      ffecom_do_entrypoint (which calls this fn).  */
2666
2667   start_function (ffecom_get_external_identifier_ (fn),
2668                   type,
2669                   0,            /* nested/inline */
2670                   1);           /* TREE_PUBLIC */
2671
2672   if (((g = ffesymbol_global (fn)) != NULL)
2673       && ((ffeglobal_type (g) == gt)
2674           || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
2675     {
2676       ffeglobal_set_hook (g, current_function_decl);
2677     }
2678
2679   /* Reset args in master arg list so they get retransitioned. */
2680
2681   for (item = ffecom_master_arglist_;
2682        item != NULL;
2683        item = ffebld_trail (item))
2684     {
2685       ffebld arg;
2686       ffesymbol s;
2687
2688       arg = ffebld_head (item);
2689       if (ffebld_op (arg) != FFEBLD_opSYMTER)
2690         continue;               /* Alternate return or some such thing. */
2691       s = ffebld_symter (arg);
2692       ffesymbol_hook (s).decl_tree = NULL_TREE;
2693       ffesymbol_hook (s).length_tree = NULL_TREE;
2694     }
2695
2696   /* Build dummy arg list for this entry point. */
2697
2698   if (charfunc || cmplxfunc)
2699     {                           /* Prepend arg for where result goes. */
2700       tree type;
2701       tree length;
2702
2703       if (charfunc)
2704         type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
2705       else
2706         type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
2707
2708       result = ffecom_get_invented_identifier ("__g77_%s", "result");
2709
2710       /* Make length arg _and_ enhance type info for CHAR arg itself.  */
2711
2712       if (charfunc)
2713         length = ffecom_char_enhance_arg_ (&type, fn);
2714       else
2715         length = NULL_TREE;     /* Not ref'd if !charfunc. */
2716
2717       type = build_pointer_type (type);
2718       result = build_decl (PARM_DECL, result, type);
2719
2720       push_parm_decl (result);
2721       ffecom_func_result_ = result;
2722
2723       if (charfunc)
2724         {
2725           push_parm_decl (length);
2726           ffecom_func_length_ = length;
2727         }
2728     }
2729   else
2730     result = DECL_RESULT (current_function_decl);
2731
2732   ffecom_push_dummy_decls_ (ffesymbol_dummyargs (fn), FALSE);
2733
2734   store_parm_decls (0);
2735
2736   ffecom_start_compstmt ();
2737   /* Disallow temp vars at this level.  */
2738   current_binding_level->prep_state = 2;
2739
2740   /* Make local var to hold return type for multi-type master fn. */
2741
2742   if (multi)
2743     {
2744       multi_retval = ffecom_get_invented_identifier ("__g77_%s",
2745                                                      "multi_retval");
2746       multi_retval = build_decl (VAR_DECL, multi_retval,
2747                                  ffecom_multi_type_node_);
2748       multi_retval = start_decl (multi_retval, FALSE);
2749       finish_decl (multi_retval, NULL_TREE, FALSE);
2750     }
2751   else
2752     multi_retval = NULL_TREE;   /* Not actually ref'd if !multi. */
2753
2754   /* Here we emit the actual code for the entry point. */
2755
2756   {
2757     ffebld list;
2758     ffebld arg;
2759     ffesymbol s;
2760     tree arglist = NULL_TREE;
2761     tree *plist = &arglist;
2762     tree prepend;
2763     tree call;
2764     tree actarg;
2765     tree master_fn;
2766
2767     /* Prepare actual arg list based on master arg list. */
2768
2769     for (list = ffecom_master_arglist_;
2770          list != NULL;
2771          list = ffebld_trail (list))
2772       {
2773         arg = ffebld_head (list);
2774         if (ffebld_op (arg) != FFEBLD_opSYMTER)
2775           continue;
2776         s = ffebld_symter (arg);
2777         if (ffesymbol_hook (s).decl_tree == NULL_TREE
2778             || ffesymbol_hook (s).decl_tree == error_mark_node)
2779           actarg = null_pointer_node;   /* We don't have this arg. */
2780         else
2781           actarg = ffesymbol_hook (s).decl_tree;
2782         *plist = build_tree_list (NULL_TREE, actarg);
2783         plist = &TREE_CHAIN (*plist);
2784       }
2785
2786     /* This code appends the length arguments for character
2787        variables/arrays.  */
2788
2789     for (list = ffecom_master_arglist_;
2790          list != NULL;
2791          list = ffebld_trail (list))
2792       {
2793         arg = ffebld_head (list);
2794         if (ffebld_op (arg) != FFEBLD_opSYMTER)
2795           continue;
2796         s = ffebld_symter (arg);
2797         if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
2798           continue;             /* Only looking for CHARACTER arguments. */
2799         if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
2800           continue;             /* Only looking for variables and arrays. */
2801         if (ffesymbol_hook (s).length_tree == NULL_TREE
2802             || ffesymbol_hook (s).length_tree == error_mark_node)
2803           actarg = ffecom_f2c_ftnlen_zero_node; /* We don't have this arg. */
2804         else
2805           actarg = ffesymbol_hook (s).length_tree;
2806         *plist = build_tree_list (NULL_TREE, actarg);
2807         plist = &TREE_CHAIN (*plist);
2808       }
2809
2810     /* Prepend character-value return info to actual arg list. */
2811
2812     if (charfunc)
2813       {
2814         prepend = build_tree_list (NULL_TREE, ffecom_func_result_);
2815         TREE_CHAIN (prepend)
2816           = build_tree_list (NULL_TREE, ffecom_func_length_);
2817         TREE_CHAIN (TREE_CHAIN (prepend)) = arglist;
2818         arglist = prepend;
2819       }
2820
2821     /* Prepend multi-type return value to actual arg list. */
2822
2823     if (multi)
2824       {
2825         prepend
2826           = build_tree_list (NULL_TREE,
2827                              ffecom_1 (ADDR_EXPR,
2828                               build_pointer_type (TREE_TYPE (multi_retval)),
2829                                        multi_retval));
2830         TREE_CHAIN (prepend) = arglist;
2831         arglist = prepend;
2832       }
2833
2834     /* Prepend my entry-point number to the actual arg list. */
2835
2836     prepend = build_tree_list (NULL_TREE, build_int_2 (entrynum, 0));
2837     TREE_CHAIN (prepend) = arglist;
2838     arglist = prepend;
2839
2840     /* Build the call to the master function. */
2841
2842     master_fn = ffecom_1_fn (ffecom_previous_function_decl_);
2843     call = ffecom_3s (CALL_EXPR,
2844                       TREE_TYPE (TREE_TYPE (TREE_TYPE (master_fn))),
2845                       master_fn, arglist, NULL_TREE);
2846
2847     /* Decide whether the master function is a function or subroutine, and
2848        handle the return value for my entry point. */
2849
2850     if (charfunc || ((ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
2851                      && !altreturning))
2852       {
2853         expand_expr_stmt (call);
2854         expand_null_return ();
2855       }
2856     else if (multi && cmplxfunc)
2857       {
2858         expand_expr_stmt (call);
2859         result
2860           = ffecom_1 (INDIRECT_REF,
2861                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
2862                       result);
2863         result = ffecom_modify (NULL_TREE, result,
2864                                 ffecom_2 (COMPONENT_REF, TREE_TYPE (result),
2865                                           multi_retval,
2866                                           ffecom_multi_fields_[bt][kt]));
2867         expand_expr_stmt (result);
2868         expand_null_return ();
2869       }
2870     else if (multi)
2871       {
2872         expand_expr_stmt (call);
2873         result
2874           = ffecom_modify (NULL_TREE, result,
2875                            convert (TREE_TYPE (result),
2876                                     ffecom_2 (COMPONENT_REF,
2877                                               ffecom_tree_type[bt][kt],
2878                                               multi_retval,
2879                                               ffecom_multi_fields_[bt][kt])));
2880         expand_return (result);
2881       }
2882     else if (cmplxfunc)
2883       {
2884         result
2885           = ffecom_1 (INDIRECT_REF,
2886                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
2887                       result);
2888         result = ffecom_modify (NULL_TREE, result, call);
2889         expand_expr_stmt (result);
2890         expand_null_return ();
2891       }
2892     else
2893       {
2894         result = ffecom_modify (NULL_TREE,
2895                                 result,
2896                                 convert (TREE_TYPE (result),
2897                                          call));
2898         expand_return (result);
2899       }
2900   }
2901
2902   ffecom_end_compstmt ();
2903
2904   finish_function (0);
2905
2906   lineno = old_lineno;
2907   input_filename = old_input_filename;
2908
2909   ffecom_doing_entry_ = FALSE;
2910 }
2911
2912 /* Transform expr into gcc tree with possible destination
2913
2914    Recursive descent on expr while making corresponding tree nodes and
2915    attaching type info and such.  If destination supplied and compatible
2916    with temporary that would be made in certain cases, temporary isn't
2917    made, destination used instead, and dest_used flag set TRUE.  */
2918
2919 static tree
2920 ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
2921               bool *dest_used, bool assignp, bool widenp)
2922 {
2923   tree item;
2924   tree list;
2925   tree args;
2926   ffeinfoBasictype bt;
2927   ffeinfoKindtype kt;
2928   tree t;
2929   tree dt;                      /* decl_tree for an ffesymbol. */
2930   tree tree_type, tree_type_x;
2931   tree left, right;
2932   ffesymbol s;
2933   enum tree_code code;
2934
2935   assert (expr != NULL);
2936
2937   if (dest_used != NULL)
2938     *dest_used = FALSE;
2939
2940   bt = ffeinfo_basictype (ffebld_info (expr));
2941   kt = ffeinfo_kindtype (ffebld_info (expr));
2942   tree_type = ffecom_tree_type[bt][kt];
2943
2944   /* Widen integral arithmetic as desired while preserving signedness.  */
2945   tree_type_x = NULL_TREE;
2946   if (widenp && tree_type
2947       && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
2948       && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
2949     tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
2950
2951   switch (ffebld_op (expr))
2952     {
2953     case FFEBLD_opACCTER:
2954       {
2955         ffebitCount i;
2956         ffebit bits = ffebld_accter_bits (expr);
2957         ffetargetOffset source_offset = 0;
2958         ffetargetOffset dest_offset = ffebld_accter_pad (expr);
2959         tree purpose;
2960
2961         assert (dest_offset == 0
2962                 || (bt == FFEINFO_basictypeCHARACTER
2963                     && kt == FFEINFO_kindtypeCHARACTER1));
2964
2965         list = item = NULL;
2966         for (;;)
2967           {
2968             ffebldConstantUnion cu;
2969             ffebitCount length;
2970             bool value;
2971             ffebldConstantArray ca = ffebld_accter (expr);
2972
2973             ffebit_test (bits, source_offset, &value, &length);
2974             if (length == 0)
2975               break;
2976
2977             if (value)
2978               {
2979                 for (i = 0; i < length; ++i)
2980                   {
2981                     cu = ffebld_constantarray_get (ca, bt, kt,
2982                                                    source_offset + i);
2983
2984                     t = ffecom_constantunion (&cu, bt, kt, tree_type);
2985
2986                     if (i == 0
2987                         && dest_offset != 0)
2988                       purpose = build_int_2 (dest_offset, 0);
2989                     else
2990                       purpose = NULL_TREE;
2991
2992                     if (list == NULL_TREE)
2993                       list = item = build_tree_list (purpose, t);
2994                     else
2995                       {
2996                         TREE_CHAIN (item) = build_tree_list (purpose, t);
2997                         item = TREE_CHAIN (item);
2998                       }
2999                   }
3000               }
3001             source_offset += length;
3002             dest_offset += length;
3003           }
3004       }
3005
3006       item = build_int_2 ((ffebld_accter_size (expr)
3007                            + ffebld_accter_pad (expr)) - 1, 0);
3008       ffebit_kill (ffebld_accter_bits (expr));
3009       TREE_TYPE (item) = ffecom_integer_type_node;
3010       item
3011         = build_array_type
3012           (tree_type,
3013            build_range_type (ffecom_integer_type_node,
3014                              ffecom_integer_zero_node,
3015                              item));
3016       list = build (CONSTRUCTOR, item, NULL_TREE, list);
3017       TREE_CONSTANT (list) = 1;
3018       TREE_STATIC (list) = 1;
3019       return list;
3020
3021     case FFEBLD_opARRTER:
3022       {
3023         ffetargetOffset i;
3024
3025         list = NULL_TREE;
3026         if (ffebld_arrter_pad (expr) == 0)
3027           item = NULL_TREE;
3028         else
3029           {
3030             assert (bt == FFEINFO_basictypeCHARACTER
3031                     && kt == FFEINFO_kindtypeCHARACTER1);
3032
3033             /* Becomes PURPOSE first time through loop.  */
3034             item = build_int_2 (ffebld_arrter_pad (expr), 0);
3035           }
3036
3037         for (i = 0; i < ffebld_arrter_size (expr); ++i)
3038           {
3039             ffebldConstantUnion cu
3040             = ffebld_constantarray_get (ffebld_arrter (expr), bt, kt, i);
3041
3042             t = ffecom_constantunion (&cu, bt, kt, tree_type);
3043
3044             if (list == NULL_TREE)
3045               /* Assume item is PURPOSE first time through loop.  */
3046               list = item = build_tree_list (item, t);
3047             else
3048               {
3049                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
3050                 item = TREE_CHAIN (item);
3051               }
3052           }
3053       }
3054
3055       item = build_int_2 ((ffebld_arrter_size (expr)
3056                           + ffebld_arrter_pad (expr)) - 1, 0);
3057       TREE_TYPE (item) = ffecom_integer_type_node;
3058       item
3059         = build_array_type
3060           (tree_type,
3061            build_range_type (ffecom_integer_type_node,
3062                              ffecom_integer_zero_node,
3063                              item));
3064       list = build (CONSTRUCTOR, item, NULL_TREE, list);
3065       TREE_CONSTANT (list) = 1;
3066       TREE_STATIC (list) = 1;
3067       return list;
3068
3069     case FFEBLD_opCONTER:
3070       assert (ffebld_conter_pad (expr) == 0);
3071       item
3072         = ffecom_constantunion (&ffebld_constant_union (ffebld_conter (expr)),
3073                                 bt, kt, tree_type);
3074       return item;
3075
3076     case FFEBLD_opSYMTER:
3077       if ((ffebld_symter_generic (expr) != FFEINTRIN_genNONE)
3078           || (ffebld_symter_specific (expr) != FFEINTRIN_specNONE))
3079         return ffecom_ptr_to_expr (expr);       /* Same as %REF(intrinsic). */
3080       s = ffebld_symter (expr);
3081       t = ffesymbol_hook (s).decl_tree;
3082
3083       if (assignp)
3084         {                       /* ASSIGN'ed-label expr. */
3085           if (ffe_is_ugly_assign ())
3086             {
3087               /* User explicitly wants ASSIGN'ed variables to be at the same
3088                  memory address as the variables when used in non-ASSIGN
3089                  contexts.  That can make old, arcane, non-standard code
3090                  work, but don't try to do it when a pointer wouldn't fit
3091                  in the normal variable (take other approach, and warn,
3092                  instead).  */
3093
3094               if (t == NULL_TREE)
3095                 {
3096                   s = ffecom_sym_transform_ (s);
3097                   t = ffesymbol_hook (s).decl_tree;
3098                   assert (t != NULL_TREE);
3099                 }
3100
3101               if (t == error_mark_node)
3102                 return t;
3103
3104               if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t)))
3105                   >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
3106                 {
3107                   if (ffesymbol_hook (s).addr)
3108                     t = ffecom_1 (INDIRECT_REF,
3109                                   TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3110                   return t;
3111                 }
3112
3113               if (ffesymbol_hook (s).assign_tree == NULL_TREE)
3114                 {
3115                   ffebad_start_msg ("ASSIGN'ed label cannot fit into `%A' at %0 -- using wider sibling",
3116                                     FFEBAD_severityWARNING);
3117                   ffebad_string (ffesymbol_text (s));
3118                   ffebad_here (0, ffesymbol_where_line (s),
3119                                ffesymbol_where_column (s));
3120                   ffebad_finish ();
3121                 }
3122             }
3123
3124           /* Don't use the normal variable's tree for ASSIGN, though mark
3125              it as in the system header (housekeeping).  Use an explicit,
3126              specially created sibling that is known to be wide enough
3127              to hold pointers to labels.  */
3128
3129           if (t != NULL_TREE
3130               && TREE_CODE (t) == VAR_DECL)
3131             DECL_IN_SYSTEM_HEADER (t) = 1;      /* Don't let -Wunused complain. */
3132
3133           t = ffesymbol_hook (s).assign_tree;
3134           if (t == NULL_TREE)
3135             {
3136               s = ffecom_sym_transform_assign_ (s);
3137               t = ffesymbol_hook (s).assign_tree;
3138               assert (t != NULL_TREE);
3139             }
3140         }
3141       else
3142         {
3143           if (t == NULL_TREE)
3144             {
3145               s = ffecom_sym_transform_ (s);
3146               t = ffesymbol_hook (s).decl_tree;
3147               assert (t != NULL_TREE);
3148             }
3149           if (ffesymbol_hook (s).addr)
3150             t = ffecom_1 (INDIRECT_REF,
3151                           TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3152         }
3153       return t;
3154
3155     case FFEBLD_opARRAYREF:
3156       return ffecom_arrayref_ (NULL_TREE, expr, 0);
3157
3158     case FFEBLD_opUPLUS:
3159       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3160       return ffecom_1 (NOP_EXPR, tree_type, left);
3161
3162     case FFEBLD_opPAREN:
3163       /* ~~~Make sure Fortran rules respected here */
3164       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3165       return ffecom_1 (NOP_EXPR, tree_type, left);
3166
3167     case FFEBLD_opUMINUS:
3168       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3169       if (tree_type_x)
3170         {
3171           tree_type = tree_type_x;
3172           left = convert (tree_type, left);
3173         }
3174       return ffecom_1 (NEGATE_EXPR, tree_type, left);
3175
3176     case FFEBLD_opADD:
3177       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3178       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3179       if (tree_type_x)
3180         {
3181           tree_type = tree_type_x;
3182           left = convert (tree_type, left);
3183           right = convert (tree_type, right);
3184         }
3185       return ffecom_2 (PLUS_EXPR, tree_type, left, right);
3186
3187     case FFEBLD_opSUBTRACT:
3188       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3189       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3190       if (tree_type_x)
3191         {
3192           tree_type = tree_type_x;
3193           left = convert (tree_type, left);
3194           right = convert (tree_type, right);
3195         }
3196       return ffecom_2 (MINUS_EXPR, tree_type, left, right);
3197
3198     case FFEBLD_opMULTIPLY:
3199       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3200       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3201       if (tree_type_x)
3202         {
3203           tree_type = tree_type_x;
3204           left = convert (tree_type, left);
3205           right = convert (tree_type, right);
3206         }
3207       return ffecom_2 (MULT_EXPR, tree_type, left, right);
3208
3209     case FFEBLD_opDIVIDE:
3210       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3211       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3212       if (tree_type_x)
3213         {
3214           tree_type = tree_type_x;
3215           left = convert (tree_type, left);
3216           right = convert (tree_type, right);
3217         }
3218       return ffecom_tree_divide_ (tree_type, left, right,
3219                                   dest_tree, dest, dest_used,
3220                                   ffebld_nonter_hook (expr));
3221
3222     case FFEBLD_opPOWER:
3223       {
3224         ffebld left = ffebld_left (expr);
3225         ffebld right = ffebld_right (expr);
3226         ffecomGfrt code;
3227         ffeinfoKindtype rtkt;
3228         ffeinfoKindtype ltkt;
3229         bool ref = TRUE;
3230
3231         switch (ffeinfo_basictype (ffebld_info (right)))
3232           {
3233
3234           case FFEINFO_basictypeINTEGER:
3235             if (1 || optimize)
3236               {
3237                 item = ffecom_expr_power_integer_ (expr);
3238                 if (item != NULL_TREE)
3239                   return item;
3240               }
3241
3242             rtkt = FFEINFO_kindtypeINTEGER1;
3243             switch (ffeinfo_basictype (ffebld_info (left)))
3244               {
3245               case FFEINFO_basictypeINTEGER:
3246                 if ((ffeinfo_kindtype (ffebld_info (left))
3247                     == FFEINFO_kindtypeINTEGER4)
3248                     || (ffeinfo_kindtype (ffebld_info (right))
3249                         == FFEINFO_kindtypeINTEGER4))
3250                   {
3251                     code = FFECOM_gfrtPOW_QQ;
3252                     ltkt = FFEINFO_kindtypeINTEGER4;
3253                     rtkt = FFEINFO_kindtypeINTEGER4;
3254                   }
3255                 else
3256                   {
3257                     code = FFECOM_gfrtPOW_II;
3258                     ltkt = FFEINFO_kindtypeINTEGER1;
3259                   }
3260                 break;
3261
3262               case FFEINFO_basictypeREAL:
3263                 if (ffeinfo_kindtype (ffebld_info (left))
3264                     == FFEINFO_kindtypeREAL1)
3265                   {
3266                     code = FFECOM_gfrtPOW_RI;
3267                     ltkt = FFEINFO_kindtypeREAL1;
3268                   }
3269                 else
3270                   {
3271                     code = FFECOM_gfrtPOW_DI;
3272                     ltkt = FFEINFO_kindtypeREAL2;
3273                   }
3274                 break;
3275
3276               case FFEINFO_basictypeCOMPLEX:
3277                 if (ffeinfo_kindtype (ffebld_info (left))
3278                     == FFEINFO_kindtypeREAL1)
3279                   {
3280                     code = FFECOM_gfrtPOW_CI;   /* Overlapping result okay. */
3281                     ltkt = FFEINFO_kindtypeREAL1;
3282                   }
3283                 else
3284                   {
3285                     code = FFECOM_gfrtPOW_ZI;   /* Overlapping result okay. */
3286                     ltkt = FFEINFO_kindtypeREAL2;
3287                   }
3288                 break;
3289
3290               default:
3291                 assert ("bad pow_*i" == NULL);
3292                 code = FFECOM_gfrtPOW_CI;       /* Overlapping result okay. */
3293                 ltkt = FFEINFO_kindtypeREAL1;
3294                 break;
3295               }
3296             if (ffeinfo_kindtype (ffebld_info (left)) != ltkt)
3297               left = ffeexpr_convert (left, NULL, NULL,
3298                                       ffeinfo_basictype (ffebld_info (left)),
3299                                       ltkt, 0,
3300                                       FFETARGET_charactersizeNONE,
3301                                       FFEEXPR_contextLET);
3302             if (ffeinfo_kindtype (ffebld_info (right)) != rtkt)
3303               right = ffeexpr_convert (right, NULL, NULL,
3304                                        FFEINFO_basictypeINTEGER,
3305                                        rtkt, 0,
3306                                        FFETARGET_charactersizeNONE,
3307                                        FFEEXPR_contextLET);
3308             break;
3309
3310           case FFEINFO_basictypeREAL:
3311             if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3312               left = ffeexpr_convert (left, NULL, NULL, FFEINFO_basictypeREAL,
3313                                       FFEINFO_kindtypeREALDOUBLE, 0,
3314                                       FFETARGET_charactersizeNONE,
3315                                       FFEEXPR_contextLET);
3316             if (ffeinfo_kindtype (ffebld_info (right))
3317                 == FFEINFO_kindtypeREAL1)
3318               right = ffeexpr_convert (right, NULL, NULL,
3319                                        FFEINFO_basictypeREAL,
3320                                        FFEINFO_kindtypeREALDOUBLE, 0,
3321                                        FFETARGET_charactersizeNONE,
3322                                        FFEEXPR_contextLET);
3323             /* We used to call FFECOM_gfrtPOW_DD here,
3324                which passes arguments by reference.  */
3325             code = FFECOM_gfrtL_POW;
3326             /* Pass arguments by value. */
3327             ref  = FALSE;
3328             break;
3329
3330           case FFEINFO_basictypeCOMPLEX:
3331             if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3332               left = ffeexpr_convert (left, NULL, NULL,
3333                                       FFEINFO_basictypeCOMPLEX,
3334                                       FFEINFO_kindtypeREALDOUBLE, 0,
3335                                       FFETARGET_charactersizeNONE,
3336                                       FFEEXPR_contextLET);
3337             if (ffeinfo_kindtype (ffebld_info (right))
3338                 == FFEINFO_kindtypeREAL1)
3339               right = ffeexpr_convert (right, NULL, NULL,
3340                                        FFEINFO_basictypeCOMPLEX,
3341                                        FFEINFO_kindtypeREALDOUBLE, 0,
3342                                        FFETARGET_charactersizeNONE,
3343                                        FFEEXPR_contextLET);
3344             code = FFECOM_gfrtPOW_ZZ;   /* Overlapping result okay. */
3345             ref = TRUE;                 /* Pass arguments by reference. */
3346             break;
3347
3348           default:
3349             assert ("bad pow_x*" == NULL);
3350             code = FFECOM_gfrtPOW_II;
3351             break;
3352           }
3353         return ffecom_call_binop_ (ffecom_gfrt_tree_ (code),
3354                                    ffecom_gfrt_kindtype (code),
3355                                    (ffe_is_f2c_library ()
3356                                     && ffecom_gfrt_complex_[code]),
3357                                    tree_type, left, right,
3358                                    dest_tree, dest, dest_used,
3359                                    NULL_TREE, FALSE, ref,
3360                                    ffebld_nonter_hook (expr));
3361       }
3362
3363     case FFEBLD_opNOT:
3364       switch (bt)
3365         {
3366         case FFEINFO_basictypeLOGICAL:
3367           item = ffecom_truth_value_invert (ffecom_expr (ffebld_left (expr)));
3368           return convert (tree_type, item);
3369
3370         case FFEINFO_basictypeINTEGER:
3371           return ffecom_1 (BIT_NOT_EXPR, tree_type,
3372                            ffecom_expr (ffebld_left (expr)));
3373
3374         default:
3375           assert ("NOT bad basictype" == NULL);
3376           /* Fall through. */
3377         case FFEINFO_basictypeANY:
3378           return error_mark_node;
3379         }
3380       break;
3381
3382     case FFEBLD_opFUNCREF:
3383       assert (ffeinfo_basictype (ffebld_info (expr))
3384               != FFEINFO_basictypeCHARACTER);
3385       /* Fall through.   */
3386     case FFEBLD_opSUBRREF:
3387       if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
3388           == FFEINFO_whereINTRINSIC)
3389         {                       /* Invocation of an intrinsic. */
3390           item = ffecom_expr_intrinsic_ (expr, dest_tree, dest,
3391                                          dest_used);
3392           return item;
3393         }
3394       s = ffebld_symter (ffebld_left (expr));
3395       dt = ffesymbol_hook (s).decl_tree;
3396       if (dt == NULL_TREE)
3397         {
3398           s = ffecom_sym_transform_ (s);
3399           dt = ffesymbol_hook (s).decl_tree;
3400         }
3401       if (dt == error_mark_node)
3402         return dt;
3403
3404       if (ffesymbol_hook (s).addr)
3405         item = dt;
3406       else
3407         item = ffecom_1_fn (dt);
3408
3409       if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
3410         args = ffecom_list_expr (ffebld_right (expr));
3411       else
3412         args = ffecom_list_ptr_to_expr (ffebld_right (expr));
3413
3414       if (args == error_mark_node)
3415         return error_mark_node;
3416
3417       item = ffecom_call_ (item, kt,
3418                            ffesymbol_is_f2c (s)
3419                            && (bt == FFEINFO_basictypeCOMPLEX)
3420                            && (ffesymbol_where (s)
3421                                != FFEINFO_whereCONSTANT),
3422                            tree_type,
3423                            args,
3424                            dest_tree, dest, dest_used,
3425                            error_mark_node, FALSE,
3426                            ffebld_nonter_hook (expr));
3427       TREE_SIDE_EFFECTS (item) = 1;
3428       return item;
3429
3430     case FFEBLD_opAND:
3431       switch (bt)
3432         {
3433         case FFEINFO_basictypeLOGICAL:
3434           item
3435             = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3436                        ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3437                      ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3438           return convert (tree_type, item);
3439
3440         case FFEINFO_basictypeINTEGER:
3441           return ffecom_2 (BIT_AND_EXPR, tree_type,
3442                            ffecom_expr (ffebld_left (expr)),
3443                            ffecom_expr (ffebld_right (expr)));
3444
3445         default:
3446           assert ("AND bad basictype" == NULL);
3447           /* Fall through. */
3448         case FFEINFO_basictypeANY:
3449           return error_mark_node;
3450         }
3451       break;
3452
3453     case FFEBLD_opOR:
3454       switch (bt)
3455         {
3456         case FFEINFO_basictypeLOGICAL:
3457           item
3458             = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
3459                        ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3460                      ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3461           return convert (tree_type, item);
3462
3463         case FFEINFO_basictypeINTEGER:
3464           return ffecom_2 (BIT_IOR_EXPR, tree_type,
3465                            ffecom_expr (ffebld_left (expr)),
3466                            ffecom_expr (ffebld_right (expr)));
3467
3468         default:
3469           assert ("OR bad basictype" == NULL);
3470           /* Fall through. */
3471         case FFEINFO_basictypeANY:
3472           return error_mark_node;
3473         }
3474       break;
3475
3476     case FFEBLD_opXOR:
3477     case FFEBLD_opNEQV:
3478       switch (bt)
3479         {
3480         case FFEINFO_basictypeLOGICAL:
3481           item
3482             = ffecom_2 (NE_EXPR, integer_type_node,
3483                         ffecom_expr (ffebld_left (expr)),
3484                         ffecom_expr (ffebld_right (expr)));
3485           return convert (tree_type, ffecom_truth_value (item));
3486
3487         case FFEINFO_basictypeINTEGER:
3488           return ffecom_2 (BIT_XOR_EXPR, tree_type,
3489                            ffecom_expr (ffebld_left (expr)),
3490                            ffecom_expr (ffebld_right (expr)));
3491
3492         default:
3493           assert ("XOR/NEQV bad basictype" == NULL);
3494           /* Fall through. */
3495         case FFEINFO_basictypeANY:
3496           return error_mark_node;
3497         }
3498       break;
3499
3500     case FFEBLD_opEQV:
3501       switch (bt)
3502         {
3503         case FFEINFO_basictypeLOGICAL:
3504           item
3505             = ffecom_2 (EQ_EXPR, integer_type_node,
3506                         ffecom_expr (ffebld_left (expr)),
3507                         ffecom_expr (ffebld_right (expr)));
3508           return convert (tree_type, ffecom_truth_value (item));
3509
3510         case FFEINFO_basictypeINTEGER:
3511           return
3512             ffecom_1 (BIT_NOT_EXPR, tree_type,
3513                       ffecom_2 (BIT_XOR_EXPR, tree_type,
3514                                 ffecom_expr (ffebld_left (expr)),
3515                                 ffecom_expr (ffebld_right (expr))));
3516
3517         default:
3518           assert ("EQV bad basictype" == NULL);
3519           /* Fall through. */
3520         case FFEINFO_basictypeANY:
3521           return error_mark_node;
3522         }
3523       break;
3524
3525     case FFEBLD_opCONVERT:
3526       if (ffebld_op (ffebld_left (expr)) == FFEBLD_opANY)
3527         return error_mark_node;
3528
3529       switch (bt)
3530         {
3531         case FFEINFO_basictypeLOGICAL:
3532         case FFEINFO_basictypeINTEGER:
3533         case FFEINFO_basictypeREAL:
3534           return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3535
3536         case FFEINFO_basictypeCOMPLEX:
3537           switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3538             {
3539             case FFEINFO_basictypeINTEGER:
3540             case FFEINFO_basictypeLOGICAL:
3541             case FFEINFO_basictypeREAL:
3542               item = ffecom_expr (ffebld_left (expr));
3543               if (item == error_mark_node)
3544                 return error_mark_node;
3545               /* convert() takes care of converting to the subtype first,
3546                  at least in gcc-2.7.2. */
3547               item = convert (tree_type, item);
3548               return item;
3549
3550             case FFEINFO_basictypeCOMPLEX:
3551               return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3552
3553             default:
3554               assert ("CONVERT COMPLEX bad basictype" == NULL);
3555               /* Fall through. */
3556             case FFEINFO_basictypeANY:
3557               return error_mark_node;
3558             }
3559           break;
3560
3561         default:
3562           assert ("CONVERT bad basictype" == NULL);
3563           /* Fall through. */
3564         case FFEINFO_basictypeANY:
3565           return error_mark_node;
3566         }
3567       break;
3568
3569     case FFEBLD_opLT:
3570       code = LT_EXPR;
3571       goto relational;          /* :::::::::::::::::::: */
3572
3573     case FFEBLD_opLE:
3574       code = LE_EXPR;
3575       goto relational;          /* :::::::::::::::::::: */
3576
3577     case FFEBLD_opEQ:
3578       code = EQ_EXPR;
3579       goto relational;          /* :::::::::::::::::::: */
3580
3581     case FFEBLD_opNE:
3582       code = NE_EXPR;
3583       goto relational;          /* :::::::::::::::::::: */
3584
3585     case FFEBLD_opGT:
3586       code = GT_EXPR;
3587       goto relational;          /* :::::::::::::::::::: */
3588
3589     case FFEBLD_opGE:
3590       code = GE_EXPR;
3591
3592     relational:         /* :::::::::::::::::::: */
3593       switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3594         {
3595         case FFEINFO_basictypeLOGICAL:
3596         case FFEINFO_basictypeINTEGER:
3597         case FFEINFO_basictypeREAL:
3598           item = ffecom_2 (code, integer_type_node,
3599                            ffecom_expr (ffebld_left (expr)),
3600                            ffecom_expr (ffebld_right (expr)));
3601           return convert (tree_type, item);
3602
3603         case FFEINFO_basictypeCOMPLEX:
3604           assert (code == EQ_EXPR || code == NE_EXPR);
3605           {
3606             tree real_type;
3607             tree arg1 = ffecom_expr (ffebld_left (expr));
3608             tree arg2 = ffecom_expr (ffebld_right (expr));
3609
3610             if (arg1 == error_mark_node || arg2 == error_mark_node)
3611               return error_mark_node;
3612
3613             arg1 = ffecom_save_tree (arg1);
3614             arg2 = ffecom_save_tree (arg2);
3615
3616             if (TREE_CODE (TREE_TYPE (arg1)) == COMPLEX_TYPE)
3617               {
3618                 real_type = TREE_TYPE (TREE_TYPE (arg1));
3619                 assert (real_type == TREE_TYPE (TREE_TYPE (arg2)));
3620               }
3621             else
3622               {
3623                 real_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg1)));
3624                 assert (real_type == TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg2))));
3625               }
3626
3627             item
3628               = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3629                           ffecom_2 (EQ_EXPR, integer_type_node,
3630                                   ffecom_1 (REALPART_EXPR, real_type, arg1),
3631                                  ffecom_1 (REALPART_EXPR, real_type, arg2)),
3632                           ffecom_2 (EQ_EXPR, integer_type_node,
3633                                   ffecom_1 (IMAGPART_EXPR, real_type, arg1),
3634                                     ffecom_1 (IMAGPART_EXPR, real_type,
3635                                               arg2)));
3636             if (code == EQ_EXPR)
3637               item = ffecom_truth_value (item);
3638             else
3639               item = ffecom_truth_value_invert (item);
3640             return convert (tree_type, item);
3641           }
3642
3643         case FFEINFO_basictypeCHARACTER:
3644           {
3645             ffebld left = ffebld_left (expr);
3646             ffebld right = ffebld_right (expr);
3647             tree left_tree;
3648             tree right_tree;
3649             tree left_length;
3650             tree right_length;
3651
3652             /* f2c run-time functions do the implicit blank-padding for us,
3653                so we don't usually have to implement blank-padding ourselves.
3654                (The exception is when we pass an argument to a separately
3655                compiled statement function -- if we know the arg is not the
3656                same length as the dummy, we must truncate or extend it.  If
3657                we "inline" statement functions, that necessity goes away as
3658                well.)
3659
3660                Strip off the CONVERT operators that blank-pad.  (Truncation by
3661                CONVERT shouldn't happen here, but it can happen in
3662                assignments.) */
3663
3664             while (ffebld_op (left) == FFEBLD_opCONVERT)
3665               left = ffebld_left (left);
3666             while (ffebld_op (right) == FFEBLD_opCONVERT)
3667               right = ffebld_left (right);
3668
3669             left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
3670             right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
3671
3672             if (left_tree == error_mark_node || left_length == error_mark_node
3673                 || right_tree == error_mark_node
3674                 || right_length == error_mark_node)
3675               return error_mark_node;
3676
3677             if ((ffebld_size_known (left) == 1)
3678                 && (ffebld_size_known (right) == 1))
3679               {
3680                 left_tree
3681                   = ffecom_1 (INDIRECT_REF,
3682                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3683                               left_tree);
3684                 right_tree
3685                   = ffecom_1 (INDIRECT_REF,
3686                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3687                               right_tree);
3688
3689                 item
3690                   = ffecom_2 (code, integer_type_node,
3691                               ffecom_2 (ARRAY_REF,
3692                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3693                                         left_tree,
3694                                         integer_one_node),
3695                               ffecom_2 (ARRAY_REF,
3696                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3697                                         right_tree,
3698                                         integer_one_node));
3699               }
3700             else
3701               {
3702                 item = build_tree_list (NULL_TREE, left_tree);
3703                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, right_tree);
3704                 TREE_CHAIN (TREE_CHAIN (item)) = build_tree_list (NULL_TREE,
3705                                                                left_length);
3706                 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
3707                   = build_tree_list (NULL_TREE, right_length);
3708                 item = ffecom_call_gfrt (FFECOM_gfrtCMP, item, NULL_TREE);
3709                 item = ffecom_2 (code, integer_type_node,
3710                                  item,
3711                                  convert (TREE_TYPE (item),
3712                                           integer_zero_node));
3713               }
3714             item = convert (tree_type, item);
3715           }
3716
3717           return item;
3718
3719         default:
3720           assert ("relational bad basictype" == NULL);
3721           /* Fall through. */
3722         case FFEINFO_basictypeANY:
3723           return error_mark_node;
3724         }
3725       break;
3726
3727     case FFEBLD_opPERCENT_LOC:
3728       item = ffecom_arg_ptr_to_expr (ffebld_left (expr), &list);
3729       return convert (tree_type, item);
3730
3731     case FFEBLD_opITEM:
3732     case FFEBLD_opSTAR:
3733     case FFEBLD_opBOUNDS:
3734     case FFEBLD_opREPEAT:
3735     case FFEBLD_opLABTER:
3736     case FFEBLD_opLABTOK:
3737     case FFEBLD_opIMPDO:
3738     case FFEBLD_opCONCATENATE:
3739     case FFEBLD_opSUBSTR:
3740     default:
3741       assert ("bad op" == NULL);
3742       /* Fall through. */
3743     case FFEBLD_opANY:
3744       return error_mark_node;
3745     }
3746
3747 #if 1
3748   assert ("didn't think anything got here anymore!!" == NULL);
3749 #else
3750   switch (ffebld_arity (expr))
3751     {
3752     case 2:
3753       TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3754       TREE_OPERAND (item, 1) = ffecom_expr (ffebld_right (expr));
3755       if (TREE_OPERAND (item, 0) == error_mark_node
3756           || TREE_OPERAND (item, 1) == error_mark_node)
3757         return error_mark_node;
3758       break;
3759
3760     case 1:
3761       TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3762       if (TREE_OPERAND (item, 0) == error_mark_node)
3763         return error_mark_node;
3764       break;
3765
3766     default:
3767       break;
3768     }
3769
3770   return fold (item);
3771 #endif
3772 }
3773
3774 /* Returns the tree that does the intrinsic invocation.
3775
3776    Note: this function applies only to intrinsics returning
3777    CHARACTER*1 or non-CHARACTER results, and to intrinsic
3778    subroutines.  */
3779
3780 static tree
3781 ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
3782                         ffebld dest, bool *dest_used)
3783 {
3784   tree expr_tree;
3785   tree saved_expr1;             /* For those who need it. */
3786   tree saved_expr2;             /* For those who need it. */
3787   ffeinfoBasictype bt;
3788   ffeinfoKindtype kt;
3789   tree tree_type;
3790   tree arg1_type;
3791   tree real_type;               /* REAL type corresponding to COMPLEX. */
3792   tree tempvar;
3793   ffebld list = ffebld_right (expr);    /* List of (some) args. */
3794   ffebld arg1;                  /* For handy reference. */
3795   ffebld arg2;
3796   ffebld arg3;
3797   ffeintrinImp codegen_imp;
3798   ffecomGfrt gfrt;
3799
3800   assert (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER);
3801
3802   if (dest_used != NULL)
3803     *dest_used = FALSE;
3804
3805   bt = ffeinfo_basictype (ffebld_info (expr));
3806   kt = ffeinfo_kindtype (ffebld_info (expr));
3807   tree_type = ffecom_tree_type[bt][kt];
3808
3809   if (list != NULL)
3810     {
3811       arg1 = ffebld_head (list);
3812       if (arg1 != NULL && ffebld_op (arg1) == FFEBLD_opANY)
3813         return error_mark_node;
3814       if ((list = ffebld_trail (list)) != NULL)
3815         {
3816           arg2 = ffebld_head (list);
3817           if (arg2 != NULL && ffebld_op (arg2) == FFEBLD_opANY)
3818             return error_mark_node;
3819           if ((list = ffebld_trail (list)) != NULL)
3820             {
3821               arg3 = ffebld_head (list);
3822               if (arg3 != NULL && ffebld_op (arg3) == FFEBLD_opANY)
3823                 return error_mark_node;
3824             }
3825           else
3826             arg3 = NULL;
3827         }
3828       else
3829         arg2 = arg3 = NULL;
3830     }
3831   else
3832     arg1 = arg2 = arg3 = NULL;
3833
3834   /* <list> ends up at the opITEM of the 3rd arg, or NULL if there are < 3
3835      args.  This is used by the MAX/MIN expansions. */
3836
3837   if (arg1 != NULL)
3838     arg1_type = ffecom_tree_type
3839       [ffeinfo_basictype (ffebld_info (arg1))]
3840       [ffeinfo_kindtype (ffebld_info (arg1))];
3841   else
3842     arg1_type = NULL_TREE;      /* Really not needed, but might catch bugs
3843                                    here. */
3844
3845   /* There are several ways for each of the cases in the following switch
3846      statements to exit (from simplest to use to most complicated):
3847
3848      break;  (when expr_tree == NULL)
3849
3850      A standard call is made to the specific intrinsic just as if it had been
3851      passed in as a dummy procedure and called as any old procedure.  This
3852      method can produce slower code but in some cases it's the easiest way for
3853      now.  However, if a (presumably faster) direct call is available,
3854      that is used, so this is the easiest way in many more cases now.
3855
3856      gfrt = FFECOM_gfrtWHATEVER;
3857      break;
3858
3859      gfrt contains the gfrt index of a library function to call, passing the
3860      argument(s) by value rather than by reference.  Used when a more
3861      careful choice of library function is needed than that provided
3862      by the vanilla `break;'.
3863
3864      return expr_tree;
3865
3866      The expr_tree has been completely set up and is ready to be returned
3867      as is.  No further actions are taken.  Use this when the tree is not
3868      in the simple form for one of the arity_n labels.   */
3869
3870   /* For info on how the switch statement cases were written, see the files
3871      enclosed in comments below the switch statement. */
3872
3873   codegen_imp = ffebld_symter_implementation (ffebld_left (expr));
3874   gfrt = ffeintrin_gfrt_direct (codegen_imp);
3875   if (gfrt == FFECOM_gfrt)
3876     gfrt = ffeintrin_gfrt_indirect (codegen_imp);
3877
3878   switch (codegen_imp)
3879     {
3880     case FFEINTRIN_impABS:
3881     case FFEINTRIN_impCABS:
3882     case FFEINTRIN_impCDABS:
3883     case FFEINTRIN_impDABS:
3884     case FFEINTRIN_impIABS:
3885       if (ffeinfo_basictype (ffebld_info (arg1))
3886           == FFEINFO_basictypeCOMPLEX)
3887         {
3888           if (kt == FFEINFO_kindtypeREAL1)
3889             gfrt = FFECOM_gfrtCABS;
3890           else if (kt == FFEINFO_kindtypeREAL2)
3891             gfrt = FFECOM_gfrtCDABS;
3892           break;
3893         }
3894       return ffecom_1 (ABS_EXPR, tree_type,
3895                        convert (tree_type, ffecom_expr (arg1)));
3896
3897     case FFEINTRIN_impACOS:
3898     case FFEINTRIN_impDACOS:
3899       break;
3900
3901     case FFEINTRIN_impAIMAG:
3902     case FFEINTRIN_impDIMAG:
3903     case FFEINTRIN_impIMAGPART:
3904       if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
3905         arg1_type = TREE_TYPE (arg1_type);
3906       else
3907         arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
3908
3909       return
3910         convert (tree_type,
3911                  ffecom_1 (IMAGPART_EXPR, arg1_type,
3912                            ffecom_expr (arg1)));
3913
3914     case FFEINTRIN_impAINT:
3915     case FFEINTRIN_impDINT:
3916 #if 0
3917       /* ~~Someday implement FIX_TRUNC_EXPR yielding same type as arg.  */
3918       return ffecom_1 (FIX_TRUNC_EXPR, tree_type, ffecom_expr (arg1));
3919 #else /* in the meantime, must use floor to avoid range problems with ints */
3920       /* r__1 = r1 >= 0 ? floor(r1) : -floor(-r1); */
3921       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
3922       return
3923         convert (tree_type,
3924                  ffecom_3 (COND_EXPR, double_type_node,
3925                            ffecom_truth_value
3926                            (ffecom_2 (GE_EXPR, integer_type_node,
3927                                       saved_expr1,
3928                                       convert (arg1_type,
3929                                                ffecom_float_zero_))),
3930                            ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
3931                                              build_tree_list (NULL_TREE,
3932                                                   convert (double_type_node,
3933                                                            saved_expr1)),
3934                                              NULL_TREE),
3935                            ffecom_1 (NEGATE_EXPR, double_type_node,
3936                                      ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
3937                                                  build_tree_list (NULL_TREE,
3938                                                   convert (double_type_node,
3939                                                       ffecom_1 (NEGATE_EXPR,
3940                                                                 arg1_type,
3941                                                                saved_expr1))),
3942                                                        NULL_TREE)
3943                                      ))
3944                  );
3945 #endif
3946
3947     case FFEINTRIN_impANINT:
3948     case FFEINTRIN_impDNINT:
3949 #if 0                           /* This way of doing it won't handle real
3950                                    numbers of large magnitudes. */
3951       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
3952       expr_tree = convert (tree_type,
3953                            convert (integer_type_node,
3954                                     ffecom_3 (COND_EXPR, tree_type,
3955                                               ffecom_truth_value
3956                                               (ffecom_2 (GE_EXPR,
3957                                                          integer_type_node,
3958                                                          saved_expr1,
3959                                                        ffecom_float_zero_)),
3960                                               ffecom_2 (PLUS_EXPR,
3961                                                         tree_type,
3962                                                         saved_expr1,
3963                                                         ffecom_float_half_),
3964                                               ffecom_2 (MINUS_EXPR,
3965                                                         tree_type,
3966                                                         saved_expr1,
3967                                                      ffecom_float_half_))));
3968       return expr_tree;
3969 #else /* So we instead call floor. */
3970       /* r__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1) */
3971       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
3972       return
3973         convert (tree_type,
3974                  ffecom_3 (COND_EXPR, double_type_node,
3975                            ffecom_truth_value
3976                            (ffecom_2 (GE_EXPR, integer_type_node,
3977                                       saved_expr1,
3978                                       convert (arg1_type,
3979                                                ffecom_float_zero_))),
3980                            ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
3981                                              build_tree_list (NULL_TREE,
3982                                                   convert (double_type_node,
3983                                                            ffecom_2 (PLUS_EXPR,
3984                                                                      arg1_type,
3985                                                                      saved_expr1,
3986                                                                      convert (arg1_type,
3987                                                                               ffecom_float_half_)))),
3988                                              NULL_TREE),
3989                            ffecom_1 (NEGATE_EXPR, double_type_node,
3990                                      ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
3991                                                        build_tree_list (NULL_TREE,
3992                                                                         convert (double_type_node,
3993                                                                                  ffecom_2 (MINUS_EXPR,
3994                                                                                            arg1_type,
3995                                                                                            convert (arg1_type,
3996                                                                                                     ffecom_float_half_),
3997                                                                                            saved_expr1))),
3998                                                        NULL_TREE))
3999                            )
4000                  );
4001 #endif
4002
4003     case FFEINTRIN_impASIN:
4004     case FFEINTRIN_impDASIN:
4005     case FFEINTRIN_impATAN:
4006     case FFEINTRIN_impDATAN:
4007     case FFEINTRIN_impATAN2:
4008     case FFEINTRIN_impDATAN2:
4009       break;
4010
4011     case FFEINTRIN_impCHAR:
4012     case FFEINTRIN_impACHAR:
4013 #ifdef HOHO
4014       tempvar = ffecom_make_tempvar (char_type_node, 1, -1);
4015 #else
4016       tempvar = ffebld_nonter_hook (expr);
4017       assert (tempvar);
4018 #endif
4019       {
4020         tree tmv = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (tempvar)));
4021
4022         expr_tree = ffecom_modify (tmv,
4023                                    ffecom_2 (ARRAY_REF, tmv, tempvar,
4024                                              integer_one_node),
4025                                    convert (tmv, ffecom_expr (arg1)));
4026       }
4027       expr_tree = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar),
4028                             expr_tree,
4029                             tempvar);
4030       expr_tree = ffecom_1 (ADDR_EXPR,
4031                             build_pointer_type (TREE_TYPE (expr_tree)),
4032                             expr_tree);
4033       return expr_tree;
4034
4035     case FFEINTRIN_impCMPLX:
4036     case FFEINTRIN_impDCMPLX:
4037       if (arg2 == NULL)
4038         return
4039           convert (tree_type, ffecom_expr (arg1));
4040
4041       real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4042       return
4043         ffecom_2 (COMPLEX_EXPR, tree_type,
4044                   convert (real_type, ffecom_expr (arg1)),
4045                   convert (real_type,
4046                            ffecom_expr (arg2)));
4047
4048     case FFEINTRIN_impCOMPLEX:
4049       return
4050         ffecom_2 (COMPLEX_EXPR, tree_type,
4051                   ffecom_expr (arg1),
4052                   ffecom_expr (arg2));
4053
4054     case FFEINTRIN_impCONJG:
4055     case FFEINTRIN_impDCONJG:
4056       {
4057         tree arg1_tree;
4058
4059         real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4060         arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4061         return
4062           ffecom_2 (COMPLEX_EXPR, tree_type,
4063                     ffecom_1 (REALPART_EXPR, real_type, arg1_tree),
4064                     ffecom_1 (NEGATE_EXPR, real_type,
4065                               ffecom_1 (IMAGPART_EXPR, real_type, arg1_tree)));
4066       }
4067
4068     case FFEINTRIN_impCOS:
4069     case FFEINTRIN_impCCOS:
4070     case FFEINTRIN_impCDCOS:
4071     case FFEINTRIN_impDCOS:
4072       if (bt == FFEINFO_basictypeCOMPLEX)
4073         {
4074           if (kt == FFEINFO_kindtypeREAL1)
4075             gfrt = FFECOM_gfrtCCOS;     /* Overlapping result okay. */
4076           else if (kt == FFEINFO_kindtypeREAL2)
4077             gfrt = FFECOM_gfrtCDCOS;    /* Overlapping result okay. */
4078         }
4079       break;
4080
4081     case FFEINTRIN_impCOSH:
4082     case FFEINTRIN_impDCOSH:
4083       break;
4084
4085     case FFEINTRIN_impDBLE:
4086     case FFEINTRIN_impDFLOAT:
4087     case FFEINTRIN_impDREAL:
4088     case FFEINTRIN_impFLOAT:
4089     case FFEINTRIN_impIDINT:
4090     case FFEINTRIN_impIFIX:
4091     case FFEINTRIN_impINT2:
4092     case FFEINTRIN_impINT8:
4093     case FFEINTRIN_impINT:
4094     case FFEINTRIN_impLONG:
4095     case FFEINTRIN_impREAL:
4096     case FFEINTRIN_impSHORT:
4097     case FFEINTRIN_impSNGL:
4098       return convert (tree_type, ffecom_expr (arg1));
4099
4100     case FFEINTRIN_impDIM:
4101     case FFEINTRIN_impDDIM:
4102     case FFEINTRIN_impIDIM:
4103       saved_expr1 = ffecom_save_tree (convert (tree_type,
4104                                                ffecom_expr (arg1)));
4105       saved_expr2 = ffecom_save_tree (convert (tree_type,
4106                                                ffecom_expr (arg2)));
4107       return
4108         ffecom_3 (COND_EXPR, tree_type,
4109                   ffecom_truth_value
4110                   (ffecom_2 (GT_EXPR, integer_type_node,
4111                              saved_expr1,
4112                              saved_expr2)),
4113                   ffecom_2 (MINUS_EXPR, tree_type,
4114                             saved_expr1,
4115                             saved_expr2),
4116                   convert (tree_type, ffecom_float_zero_));
4117
4118     case FFEINTRIN_impDPROD:
4119       return
4120         ffecom_2 (MULT_EXPR, tree_type,
4121                   convert (tree_type, ffecom_expr (arg1)),
4122                   convert (tree_type, ffecom_expr (arg2)));
4123
4124     case FFEINTRIN_impEXP:
4125     case FFEINTRIN_impCDEXP:
4126     case FFEINTRIN_impCEXP:
4127     case FFEINTRIN_impDEXP:
4128       if (bt == FFEINFO_basictypeCOMPLEX)
4129         {
4130           if (kt == FFEINFO_kindtypeREAL1)
4131             gfrt = FFECOM_gfrtCEXP;     /* Overlapping result okay. */
4132           else if (kt == FFEINFO_kindtypeREAL2)
4133             gfrt = FFECOM_gfrtCDEXP;    /* Overlapping result okay. */
4134         }
4135       break;
4136
4137     case FFEINTRIN_impICHAR:
4138     case FFEINTRIN_impIACHAR:
4139 #if 0                           /* The simple approach. */
4140       ffecom_char_args_ (&expr_tree, &saved_expr1 /* Ignored */ , arg1);
4141       expr_tree
4142         = ffecom_1 (INDIRECT_REF,
4143                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4144                     expr_tree);
4145       expr_tree
4146         = ffecom_2 (ARRAY_REF,
4147                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4148                     expr_tree,
4149                     integer_one_node);
4150       return convert (tree_type, expr_tree);
4151 #else /* The more interesting (and more optimal) approach. */
4152       expr_tree = ffecom_intrinsic_ichar_ (tree_type, arg1, &saved_expr1);
4153       expr_tree = ffecom_3 (COND_EXPR, tree_type,
4154                             saved_expr1,
4155                             expr_tree,
4156                             convert (tree_type, integer_zero_node));
4157       return expr_tree;
4158 #endif
4159
4160     case FFEINTRIN_impINDEX:
4161       break;
4162
4163     case FFEINTRIN_impLEN:
4164 #if 0
4165       break;                                    /* The simple approach. */
4166 #else
4167       return ffecom_intrinsic_len_ (arg1);      /* The more optimal approach. */
4168 #endif
4169
4170     case FFEINTRIN_impLGE:
4171     case FFEINTRIN_impLGT:
4172     case FFEINTRIN_impLLE:
4173     case FFEINTRIN_impLLT:
4174       break;
4175
4176     case FFEINTRIN_impLOG:
4177     case FFEINTRIN_impALOG:
4178     case FFEINTRIN_impCDLOG:
4179     case FFEINTRIN_impCLOG:
4180     case FFEINTRIN_impDLOG:
4181       if (bt == FFEINFO_basictypeCOMPLEX)
4182         {
4183           if (kt == FFEINFO_kindtypeREAL1)
4184             gfrt = FFECOM_gfrtCLOG;     /* Overlapping result okay. */
4185           else if (kt == FFEINFO_kindtypeREAL2)
4186             gfrt = FFECOM_gfrtCDLOG;    /* Overlapping result okay. */
4187         }
4188       break;
4189
4190     case FFEINTRIN_impLOG10:
4191     case FFEINTRIN_impALOG10:
4192     case FFEINTRIN_impDLOG10:
4193       if (gfrt != FFECOM_gfrt)
4194         break;  /* Already picked one, stick with it. */
4195
4196       if (kt == FFEINFO_kindtypeREAL1)
4197         /* We used to call FFECOM_gfrtALOG10 here.  */
4198         gfrt = FFECOM_gfrtL_LOG10;
4199       else if (kt == FFEINFO_kindtypeREAL2)
4200         /* We used to call FFECOM_gfrtDLOG10 here.  */
4201         gfrt = FFECOM_gfrtL_LOG10;
4202       break;
4203
4204     case FFEINTRIN_impMAX:
4205     case FFEINTRIN_impAMAX0:
4206     case FFEINTRIN_impAMAX1:
4207     case FFEINTRIN_impDMAX1:
4208     case FFEINTRIN_impMAX0:
4209     case FFEINTRIN_impMAX1:
4210       if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4211         arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4212       else
4213         arg1_type = tree_type;
4214       expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4215                             convert (arg1_type, ffecom_expr (arg1)),
4216                             convert (arg1_type, ffecom_expr (arg2)));
4217       for (; list != NULL; list = ffebld_trail (list))
4218         {
4219           if ((ffebld_head (list) == NULL)
4220               || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4221             continue;
4222           expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4223                                 expr_tree,
4224                                 convert (arg1_type,
4225                                          ffecom_expr (ffebld_head (list))));
4226         }
4227       return convert (tree_type, expr_tree);
4228
4229     case FFEINTRIN_impMIN:
4230     case FFEINTRIN_impAMIN0:
4231     case FFEINTRIN_impAMIN1:
4232     case FFEINTRIN_impDMIN1:
4233     case FFEINTRIN_impMIN0:
4234     case FFEINTRIN_impMIN1:
4235       if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4236         arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4237       else
4238         arg1_type = tree_type;
4239       expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4240                             convert (arg1_type, ffecom_expr (arg1)),
4241                             convert (arg1_type, ffecom_expr (arg2)));
4242       for (; list != NULL; list = ffebld_trail (list))
4243         {
4244           if ((ffebld_head (list) == NULL)
4245               || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4246             continue;
4247           expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4248                                 expr_tree,
4249                                 convert (arg1_type,
4250                                          ffecom_expr (ffebld_head (list))));
4251         }
4252       return convert (tree_type, expr_tree);
4253
4254     case FFEINTRIN_impMOD:
4255     case FFEINTRIN_impAMOD:
4256     case FFEINTRIN_impDMOD:
4257       if (bt != FFEINFO_basictypeREAL)
4258         return ffecom_2 (TRUNC_MOD_EXPR, tree_type,
4259                          convert (tree_type, ffecom_expr (arg1)),
4260                          convert (tree_type, ffecom_expr (arg2)));
4261
4262       if (kt == FFEINFO_kindtypeREAL1)
4263         /* We used to call FFECOM_gfrtAMOD here.  */
4264         gfrt = FFECOM_gfrtL_FMOD;
4265       else if (kt == FFEINFO_kindtypeREAL2)
4266         /* We used to call FFECOM_gfrtDMOD here.  */
4267         gfrt = FFECOM_gfrtL_FMOD;
4268       break;
4269
4270     case FFEINTRIN_impNINT:
4271     case FFEINTRIN_impIDNINT:
4272 #if 0
4273       /* ~~Ideally FIX_ROUND_EXPR would be implemented, but it ain't yet.  */
4274       return ffecom_1 (FIX_ROUND_EXPR, tree_type, ffecom_expr (arg1));
4275 #else
4276       /* i__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1); */
4277       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4278       return
4279         convert (ffecom_integer_type_node,
4280                  ffecom_3 (COND_EXPR, arg1_type,
4281                            ffecom_truth_value
4282                            (ffecom_2 (GE_EXPR, integer_type_node,
4283                                       saved_expr1,
4284                                       convert (arg1_type,
4285                                                ffecom_float_zero_))),
4286                            ffecom_2 (PLUS_EXPR, arg1_type,
4287                                      saved_expr1,
4288                                      convert (arg1_type,
4289                                               ffecom_float_half_)),
4290                            ffecom_2 (MINUS_EXPR, arg1_type,
4291                                      saved_expr1,
4292                                      convert (arg1_type,
4293                                               ffecom_float_half_))));
4294 #endif
4295
4296     case FFEINTRIN_impSIGN:
4297     case FFEINTRIN_impDSIGN:
4298     case FFEINTRIN_impISIGN:
4299       {
4300         tree arg2_tree = ffecom_expr (arg2);
4301
4302         saved_expr1
4303           = ffecom_save_tree
4304           (ffecom_1 (ABS_EXPR, tree_type,
4305                      convert (tree_type,
4306                               ffecom_expr (arg1))));
4307         expr_tree
4308           = ffecom_3 (COND_EXPR, tree_type,
4309                       ffecom_truth_value
4310                       (ffecom_2 (GE_EXPR, integer_type_node,
4311                                  arg2_tree,
4312                                  convert (TREE_TYPE (arg2_tree),
4313                                           integer_zero_node))),
4314                       saved_expr1,
4315                       ffecom_1 (NEGATE_EXPR, tree_type, saved_expr1));
4316         /* Make sure SAVE_EXPRs get referenced early enough. */
4317         expr_tree
4318           = ffecom_2 (COMPOUND_EXPR, tree_type,
4319                       convert (void_type_node, saved_expr1),
4320                       expr_tree);
4321       }
4322       return expr_tree;
4323
4324     case FFEINTRIN_impSIN:
4325     case FFEINTRIN_impCDSIN:
4326     case FFEINTRIN_impCSIN:
4327     case FFEINTRIN_impDSIN:
4328       if (bt == FFEINFO_basictypeCOMPLEX)
4329         {
4330           if (kt == FFEINFO_kindtypeREAL1)
4331             gfrt = FFECOM_gfrtCSIN;     /* Overlapping result okay. */
4332           else if (kt == FFEINFO_kindtypeREAL2)
4333             gfrt = FFECOM_gfrtCDSIN;    /* Overlapping result okay. */
4334         }
4335       break;
4336
4337     case FFEINTRIN_impSINH:
4338     case FFEINTRIN_impDSINH:
4339       break;
4340
4341     case FFEINTRIN_impSQRT:
4342     case FFEINTRIN_impCDSQRT:
4343     case FFEINTRIN_impCSQRT:
4344     case FFEINTRIN_impDSQRT:
4345       if (bt == FFEINFO_basictypeCOMPLEX)
4346         {
4347           if (kt == FFEINFO_kindtypeREAL1)
4348             gfrt = FFECOM_gfrtCSQRT;    /* Overlapping result okay. */
4349           else if (kt == FFEINFO_kindtypeREAL2)
4350             gfrt = FFECOM_gfrtCDSQRT;   /* Overlapping result okay. */
4351         }
4352       break;
4353
4354     case FFEINTRIN_impTAN:
4355     case FFEINTRIN_impDTAN:
4356     case FFEINTRIN_impTANH:
4357     case FFEINTRIN_impDTANH:
4358       break;
4359
4360     case FFEINTRIN_impREALPART:
4361       if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
4362         arg1_type = TREE_TYPE (arg1_type);
4363       else
4364         arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
4365
4366       return
4367         convert (tree_type,
4368                  ffecom_1 (REALPART_EXPR, arg1_type,
4369                            ffecom_expr (arg1)));
4370
4371     case FFEINTRIN_impIAND:
4372     case FFEINTRIN_impAND:
4373       return ffecom_2 (BIT_AND_EXPR, tree_type,
4374                        convert (tree_type,
4375                                 ffecom_expr (arg1)),
4376                        convert (tree_type,
4377                                 ffecom_expr (arg2)));
4378
4379     case FFEINTRIN_impIOR:
4380     case FFEINTRIN_impOR:
4381       return ffecom_2 (BIT_IOR_EXPR, tree_type,
4382                        convert (tree_type,
4383                                 ffecom_expr (arg1)),
4384                        convert (tree_type,
4385                                 ffecom_expr (arg2)));
4386
4387     case FFEINTRIN_impIEOR:
4388     case FFEINTRIN_impXOR:
4389       return ffecom_2 (BIT_XOR_EXPR, tree_type,
4390                        convert (tree_type,
4391                                 ffecom_expr (arg1)),
4392                        convert (tree_type,
4393                                 ffecom_expr (arg2)));
4394
4395     case FFEINTRIN_impLSHIFT:
4396       return ffecom_2 (LSHIFT_EXPR, tree_type,
4397                        ffecom_expr (arg1),
4398                        convert (integer_type_node,
4399                                 ffecom_expr (arg2)));
4400
4401     case FFEINTRIN_impRSHIFT:
4402       return ffecom_2 (RSHIFT_EXPR, tree_type,
4403                        ffecom_expr (arg1),
4404                        convert (integer_type_node,
4405                                 ffecom_expr (arg2)));
4406
4407     case FFEINTRIN_impNOT:
4408       return ffecom_1 (BIT_NOT_EXPR, tree_type, ffecom_expr (arg1));
4409
4410     case FFEINTRIN_impBIT_SIZE:
4411       return convert (tree_type, TYPE_SIZE (arg1_type));
4412
4413     case FFEINTRIN_impBTEST:
4414       {
4415         ffetargetLogical1 target_true;
4416         ffetargetLogical1 target_false;
4417         tree true_tree;
4418         tree false_tree;
4419
4420         ffetarget_logical1 (&target_true, TRUE);
4421         ffetarget_logical1 (&target_false, FALSE);
4422         if (target_true == 1)
4423           true_tree = convert (tree_type, integer_one_node);
4424         else
4425           true_tree = convert (tree_type, build_int_2 (target_true, 0));
4426         if (target_false == 0)
4427           false_tree = convert (tree_type, integer_zero_node);
4428         else
4429           false_tree = convert (tree_type, build_int_2 (target_false, 0));
4430
4431         return
4432           ffecom_3 (COND_EXPR, tree_type,
4433                     ffecom_truth_value
4434                     (ffecom_2 (EQ_EXPR, integer_type_node,
4435                                ffecom_2 (BIT_AND_EXPR, arg1_type,
4436                                          ffecom_expr (arg1),
4437                                          ffecom_2 (LSHIFT_EXPR, arg1_type,
4438                                                    convert (arg1_type,
4439                                                           integer_one_node),
4440                                                    convert (integer_type_node,
4441                                                             ffecom_expr (arg2)))),
4442                                convert (arg1_type,
4443                                         integer_zero_node))),
4444                     false_tree,
4445                     true_tree);
4446       }
4447
4448     case FFEINTRIN_impIBCLR:
4449       return
4450         ffecom_2 (BIT_AND_EXPR, tree_type,
4451                   ffecom_expr (arg1),
4452                   ffecom_1 (BIT_NOT_EXPR, tree_type,
4453                             ffecom_2 (LSHIFT_EXPR, tree_type,
4454                                       convert (tree_type,
4455                                                integer_one_node),
4456                                       convert (integer_type_node,
4457                                                ffecom_expr (arg2)))));
4458
4459     case FFEINTRIN_impIBITS:
4460       {
4461         tree arg3_tree = ffecom_save_tree (convert (integer_type_node,
4462                                                     ffecom_expr (arg3)));
4463         tree uns_type
4464         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4465
4466         expr_tree
4467           = ffecom_2 (BIT_AND_EXPR, tree_type,
4468                       ffecom_2 (RSHIFT_EXPR, tree_type,
4469                                 ffecom_expr (arg1),
4470                                 convert (integer_type_node,
4471                                          ffecom_expr (arg2))),
4472                       convert (tree_type,
4473                                ffecom_2 (RSHIFT_EXPR, uns_type,
4474                                          ffecom_1 (BIT_NOT_EXPR,
4475                                                    uns_type,
4476                                                    convert (uns_type,
4477                                                         integer_zero_node)),
4478                                          ffecom_2 (MINUS_EXPR,
4479                                                    integer_type_node,
4480                                                    TYPE_SIZE (uns_type),
4481                                                    arg3_tree))));
4482         /* Fix up, because the RSHIFT_EXPR above can't shift over TYPE_SIZE.  */
4483         expr_tree
4484           = ffecom_3 (COND_EXPR, tree_type,
4485                       ffecom_truth_value
4486                       (ffecom_2 (NE_EXPR, integer_type_node,
4487                                  arg3_tree,
4488                                  integer_zero_node)),
4489                       expr_tree,
4490                       convert (tree_type, integer_zero_node));
4491       }
4492       return expr_tree;
4493
4494     case FFEINTRIN_impIBSET:
4495       return
4496         ffecom_2 (BIT_IOR_EXPR, tree_type,
4497                   ffecom_expr (arg1),
4498                   ffecom_2 (LSHIFT_EXPR, tree_type,
4499                             convert (tree_type, integer_one_node),
4500                             convert (integer_type_node,
4501                                      ffecom_expr (arg2))));
4502
4503     case FFEINTRIN_impISHFT:
4504       {
4505         tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4506         tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4507                                                     ffecom_expr (arg2)));
4508         tree uns_type
4509         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4510
4511         expr_tree
4512           = ffecom_3 (COND_EXPR, tree_type,
4513                       ffecom_truth_value
4514                       (ffecom_2 (GE_EXPR, integer_type_node,
4515                                  arg2_tree,
4516                                  integer_zero_node)),
4517                       ffecom_2 (LSHIFT_EXPR, tree_type,
4518                                 arg1_tree,
4519                                 arg2_tree),
4520                       convert (tree_type,
4521                                ffecom_2 (RSHIFT_EXPR, uns_type,
4522                                          convert (uns_type, arg1_tree),
4523                                          ffecom_1 (NEGATE_EXPR,
4524                                                    integer_type_node,
4525                                                    arg2_tree))));
4526         /* Fix up, because {L|R}SHIFT_EXPR don't go over TYPE_SIZE bounds.  */
4527         expr_tree
4528           = ffecom_3 (COND_EXPR, tree_type,
4529                       ffecom_truth_value
4530                       (ffecom_2 (NE_EXPR, integer_type_node,
4531                                  ffecom_1 (ABS_EXPR,
4532                                            integer_type_node,
4533                                            arg2_tree),
4534                                  TYPE_SIZE (uns_type))),
4535                       expr_tree,
4536                       convert (tree_type, integer_zero_node));
4537         /* Make sure SAVE_EXPRs get referenced early enough. */
4538         expr_tree
4539           = ffecom_2 (COMPOUND_EXPR, tree_type,
4540                       convert (void_type_node, arg1_tree),
4541                       ffecom_2 (COMPOUND_EXPR, tree_type,
4542                                 convert (void_type_node, arg2_tree),
4543                                 expr_tree));
4544       }
4545       return expr_tree;
4546
4547     case FFEINTRIN_impISHFTC:
4548       {
4549         tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4550         tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4551                                                     ffecom_expr (arg2)));
4552         tree arg3_tree = (arg3 == NULL) ? TYPE_SIZE (tree_type)
4553         : ffecom_save_tree (convert (integer_type_node, ffecom_expr (arg3)));
4554         tree shift_neg;
4555         tree shift_pos;
4556         tree mask_arg1;
4557         tree masked_arg1;
4558         tree uns_type
4559         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4560
4561         mask_arg1
4562           = ffecom_2 (LSHIFT_EXPR, tree_type,
4563                       ffecom_1 (BIT_NOT_EXPR, tree_type,
4564                                 convert (tree_type, integer_zero_node)),
4565                       arg3_tree);
4566         /* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE.  */
4567         mask_arg1
4568           = ffecom_3 (COND_EXPR, tree_type,
4569                       ffecom_truth_value
4570                       (ffecom_2 (NE_EXPR, integer_type_node,
4571                                  arg3_tree,
4572                                  TYPE_SIZE (uns_type))),
4573                       mask_arg1,
4574                       convert (tree_type, integer_zero_node));
4575         mask_arg1 = ffecom_save_tree (mask_arg1);
4576         masked_arg1
4577           = ffecom_2 (BIT_AND_EXPR, tree_type,
4578                       arg1_tree,
4579                       ffecom_1 (BIT_NOT_EXPR, tree_type,
4580                                 mask_arg1));
4581         masked_arg1 = ffecom_save_tree (masked_arg1);
4582         shift_neg
4583           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4584                       convert (tree_type,
4585                                ffecom_2 (RSHIFT_EXPR, uns_type,
4586                                          convert (uns_type, masked_arg1),
4587                                          ffecom_1 (NEGATE_EXPR,
4588                                                    integer_type_node,
4589                                                    arg2_tree))),
4590                       ffecom_2 (LSHIFT_EXPR, tree_type,
4591                                 arg1_tree,
4592                                 ffecom_2 (PLUS_EXPR, integer_type_node,
4593                                           arg2_tree,
4594                                           arg3_tree)));
4595         shift_pos
4596           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4597                       ffecom_2 (LSHIFT_EXPR, tree_type,
4598                                 arg1_tree,
4599                                 arg2_tree),
4600                       convert (tree_type,
4601                                ffecom_2 (RSHIFT_EXPR, uns_type,
4602                                          convert (uns_type, masked_arg1),
4603                                          ffecom_2 (MINUS_EXPR,
4604                                                    integer_type_node,
4605                                                    arg3_tree,
4606                                                    arg2_tree))));
4607         expr_tree
4608           = ffecom_3 (COND_EXPR, tree_type,
4609                       ffecom_truth_value
4610                       (ffecom_2 (LT_EXPR, integer_type_node,
4611                                  arg2_tree,
4612                                  integer_zero_node)),
4613                       shift_neg,
4614                       shift_pos);
4615         expr_tree
4616           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4617                       ffecom_2 (BIT_AND_EXPR, tree_type,
4618                                 mask_arg1,
4619                                 arg1_tree),
4620                       ffecom_2 (BIT_AND_EXPR, tree_type,
4621                                 ffecom_1 (BIT_NOT_EXPR, tree_type,
4622                                           mask_arg1),
4623                                 expr_tree));
4624         expr_tree
4625           = ffecom_3 (COND_EXPR, tree_type,
4626                       ffecom_truth_value
4627                       (ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
4628                                  ffecom_2 (EQ_EXPR, integer_type_node,
4629                                            ffecom_1 (ABS_EXPR,
4630                                                      integer_type_node,
4631                                                      arg2_tree),
4632                                            arg3_tree),
4633                                  ffecom_2 (EQ_EXPR, integer_type_node,
4634                                            arg2_tree,
4635                                            integer_zero_node))),
4636                       arg1_tree,
4637                       expr_tree);
4638         /* Make sure SAVE_EXPRs get referenced early enough. */
4639         expr_tree
4640           = ffecom_2 (COMPOUND_EXPR, tree_type,
4641                       convert (void_type_node, arg1_tree),
4642                       ffecom_2 (COMPOUND_EXPR, tree_type,
4643                                 convert (void_type_node, arg2_tree),
4644                                 ffecom_2 (COMPOUND_EXPR, tree_type,
4645                                           convert (void_type_node,
4646                                                    mask_arg1),
4647                                           ffecom_2 (COMPOUND_EXPR, tree_type,
4648                                                     convert (void_type_node,
4649                                                              masked_arg1),
4650                                                     expr_tree))));
4651         expr_tree
4652           = ffecom_2 (COMPOUND_EXPR, tree_type,
4653                       convert (void_type_node,
4654                                arg3_tree),
4655                       expr_tree);
4656       }
4657       return expr_tree;
4658
4659     case FFEINTRIN_impLOC:
4660       {
4661         tree arg1_tree = ffecom_expr (arg1);
4662
4663         expr_tree
4664           = convert (tree_type,
4665                      ffecom_1 (ADDR_EXPR,
4666                                build_pointer_type (TREE_TYPE (arg1_tree)),
4667                                arg1_tree));
4668       }
4669       return expr_tree;
4670
4671     case FFEINTRIN_impMVBITS:
4672       {
4673         tree arg1_tree;
4674         tree arg2_tree;
4675         tree arg3_tree;
4676         ffebld arg4 = ffebld_head (ffebld_trail (list));
4677         tree arg4_tree;
4678         tree arg4_type;
4679         ffebld arg5 = ffebld_head (ffebld_trail (ffebld_trail (list)));
4680         tree arg5_tree;
4681         tree prep_arg1;
4682         tree prep_arg4;
4683         tree arg5_plus_arg3;
4684
4685         arg2_tree = convert (integer_type_node,
4686                              ffecom_expr (arg2));
4687         arg3_tree = ffecom_save_tree (convert (integer_type_node,
4688                                                ffecom_expr (arg3)));
4689         arg4_tree = ffecom_expr_rw (NULL_TREE, arg4);
4690         arg4_type = TREE_TYPE (arg4_tree);
4691
4692         arg1_tree = ffecom_save_tree (convert (arg4_type,
4693                                                ffecom_expr (arg1)));
4694
4695         arg5_tree = ffecom_save_tree (convert (integer_type_node,
4696                                                ffecom_expr (arg5)));
4697
4698         prep_arg1
4699           = ffecom_2 (LSHIFT_EXPR, arg4_type,
4700                       ffecom_2 (BIT_AND_EXPR, arg4_type,
4701                                 ffecom_2 (RSHIFT_EXPR, arg4_type,
4702                                           arg1_tree,
4703                                           arg2_tree),
4704                                 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4705                                           ffecom_2 (LSHIFT_EXPR, arg4_type,
4706                                                     ffecom_1 (BIT_NOT_EXPR,
4707                                                               arg4_type,
4708                                                               convert
4709                                                               (arg4_type,
4710                                                         integer_zero_node)),
4711                                                     arg3_tree))),
4712                       arg5_tree);
4713         arg5_plus_arg3
4714           = ffecom_save_tree (ffecom_2 (PLUS_EXPR, arg4_type,
4715                                         arg5_tree,
4716                                         arg3_tree));
4717         prep_arg4
4718           = ffecom_2 (LSHIFT_EXPR, arg4_type,
4719                       ffecom_1 (BIT_NOT_EXPR, arg4_type,
4720                                 convert (arg4_type,
4721                                          integer_zero_node)),
4722                       arg5_plus_arg3);
4723         /* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE.  */
4724         prep_arg4
4725           = ffecom_3 (COND_EXPR, arg4_type,
4726                       ffecom_truth_value
4727                       (ffecom_2 (NE_EXPR, integer_type_node,
4728                                  arg5_plus_arg3,
4729                                  convert (TREE_TYPE (arg5_plus_arg3),
4730                                           TYPE_SIZE (arg4_type)))),
4731                       prep_arg4,
4732                       convert (arg4_type, integer_zero_node));
4733         prep_arg4
4734           = ffecom_2 (BIT_AND_EXPR, arg4_type,
4735                       arg4_tree,
4736                       ffecom_2 (BIT_IOR_EXPR, arg4_type,
4737                                 prep_arg4,
4738                                 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4739                                           ffecom_2 (LSHIFT_EXPR, arg4_type,
4740                                                     ffecom_1 (BIT_NOT_EXPR,
4741                                                               arg4_type,
4742                                                               convert
4743                                                               (arg4_type,
4744                                                         integer_zero_node)),
4745                                                     arg5_tree))));
4746         prep_arg1
4747           = ffecom_2 (BIT_IOR_EXPR, arg4_type,
4748                       prep_arg1,
4749                       prep_arg4);
4750         /* Fix up (twice), because LSHIFT_EXPR above
4751            can't shift over TYPE_SIZE.  */
4752         prep_arg1
4753           = ffecom_3 (COND_EXPR, arg4_type,
4754                       ffecom_truth_value
4755                       (ffecom_2 (NE_EXPR, integer_type_node,
4756                                  arg3_tree,
4757                                  convert (TREE_TYPE (arg3_tree),
4758                                           integer_zero_node))),
4759                       prep_arg1,
4760                       arg4_tree);
4761         prep_arg1
4762           = ffecom_3 (COND_EXPR, arg4_type,
4763                       ffecom_truth_value
4764                       (ffecom_2 (NE_EXPR, integer_type_node,
4765                                  arg3_tree,
4766                                  convert (TREE_TYPE (arg3_tree),
4767                                           TYPE_SIZE (arg4_type)))),
4768                       prep_arg1,
4769                       arg1_tree);
4770         expr_tree
4771           = ffecom_2s (MODIFY_EXPR, void_type_node,
4772                        arg4_tree,
4773                        prep_arg1);
4774         /* Make sure SAVE_EXPRs get referenced early enough. */
4775         expr_tree
4776           = ffecom_2 (COMPOUND_EXPR, void_type_node,
4777                       arg1_tree,
4778                       ffecom_2 (COMPOUND_EXPR, void_type_node,
4779                                 arg3_tree,
4780                                 ffecom_2 (COMPOUND_EXPR, void_type_node,
4781                                           arg5_tree,
4782                                           ffecom_2 (COMPOUND_EXPR, void_type_node,
4783                                                     arg5_plus_arg3,
4784                                                     expr_tree))));
4785         expr_tree
4786           = ffecom_2 (COMPOUND_EXPR, void_type_node,
4787                       arg4_tree,
4788                       expr_tree);
4789
4790       }
4791       return expr_tree;
4792
4793     case FFEINTRIN_impDERF:
4794     case FFEINTRIN_impERF:
4795     case FFEINTRIN_impDERFC:
4796     case FFEINTRIN_impERFC:
4797       break;
4798
4799     case FFEINTRIN_impIARGC:
4800       /* extern int xargc; i__1 = xargc - 1; */
4801       expr_tree = ffecom_2 (MINUS_EXPR, TREE_TYPE (ffecom_tree_xargc_),
4802                             ffecom_tree_xargc_,
4803                             convert (TREE_TYPE (ffecom_tree_xargc_),
4804                                      integer_one_node));
4805       return expr_tree;
4806
4807     case FFEINTRIN_impSIGNAL_func:
4808     case FFEINTRIN_impSIGNAL_subr:
4809       {
4810         tree arg1_tree;
4811         tree arg2_tree;
4812         tree arg3_tree;
4813
4814         arg1_tree = convert (ffecom_f2c_integer_type_node,
4815                              ffecom_expr (arg1));
4816         arg1_tree = ffecom_1 (ADDR_EXPR,
4817                               build_pointer_type (TREE_TYPE (arg1_tree)),
4818                               arg1_tree);
4819
4820         /* Pass procedure as a pointer to it, anything else by value.  */
4821         if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
4822           arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
4823         else
4824           arg2_tree = ffecom_ptr_to_expr (arg2);
4825         arg2_tree = convert (TREE_TYPE (null_pointer_node),
4826                              arg2_tree);
4827
4828         if (arg3 != NULL)
4829           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
4830         else
4831           arg3_tree = NULL_TREE;
4832
4833         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4834         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4835         TREE_CHAIN (arg1_tree) = arg2_tree;
4836
4837         expr_tree
4838           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4839                           ffecom_gfrt_kindtype (gfrt),
4840                           FALSE,
4841                           ((codegen_imp == FFEINTRIN_impSIGNAL_subr) ?
4842                            NULL_TREE :
4843                            tree_type),
4844                           arg1_tree,
4845                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4846                           ffebld_nonter_hook (expr));
4847
4848         if (arg3_tree != NULL_TREE)
4849           expr_tree
4850             = ffecom_modify (NULL_TREE, arg3_tree,
4851                              convert (TREE_TYPE (arg3_tree),
4852                                       expr_tree));
4853       }
4854       return expr_tree;
4855
4856     case FFEINTRIN_impALARM:
4857       {
4858         tree arg1_tree;
4859         tree arg2_tree;
4860         tree arg3_tree;
4861
4862         arg1_tree = convert (ffecom_f2c_integer_type_node,
4863                              ffecom_expr (arg1));
4864         arg1_tree = ffecom_1 (ADDR_EXPR,
4865                               build_pointer_type (TREE_TYPE (arg1_tree)),
4866                               arg1_tree);
4867
4868         /* Pass procedure as a pointer to it, anything else by value.  */
4869         if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
4870           arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
4871         else
4872           arg2_tree = ffecom_ptr_to_expr (arg2);
4873         arg2_tree = convert (TREE_TYPE (null_pointer_node),
4874                              arg2_tree);
4875
4876         if (arg3 != NULL)
4877           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
4878         else
4879           arg3_tree = NULL_TREE;
4880
4881         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4882         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4883         TREE_CHAIN (arg1_tree) = arg2_tree;
4884
4885         expr_tree
4886           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4887                           ffecom_gfrt_kindtype (gfrt),
4888                           FALSE,
4889                           NULL_TREE,
4890                           arg1_tree,
4891                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4892                           ffebld_nonter_hook (expr));
4893
4894         if (arg3_tree != NULL_TREE)
4895           expr_tree
4896             = ffecom_modify (NULL_TREE, arg3_tree,
4897                              convert (TREE_TYPE (arg3_tree),
4898                                       expr_tree));
4899       }
4900       return expr_tree;
4901
4902     case FFEINTRIN_impCHDIR_subr:
4903     case FFEINTRIN_impFDATE_subr:
4904     case FFEINTRIN_impFGET_subr:
4905     case FFEINTRIN_impFPUT_subr:
4906     case FFEINTRIN_impGETCWD_subr:
4907     case FFEINTRIN_impHOSTNM_subr:
4908     case FFEINTRIN_impSYSTEM_subr:
4909     case FFEINTRIN_impUNLINK_subr:
4910       {
4911         tree arg1_len = integer_zero_node;
4912         tree arg1_tree;
4913         tree arg2_tree;
4914
4915         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
4916
4917         if (arg2 != NULL)
4918           arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
4919         else
4920           arg2_tree = NULL_TREE;
4921
4922         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4923         arg1_len = build_tree_list (NULL_TREE, arg1_len);
4924         TREE_CHAIN (arg1_tree) = arg1_len;
4925
4926         expr_tree
4927           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4928                           ffecom_gfrt_kindtype (gfrt),
4929                           FALSE,
4930                           NULL_TREE,
4931                           arg1_tree,
4932                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4933                           ffebld_nonter_hook (expr));
4934
4935         if (arg2_tree != NULL_TREE)
4936           expr_tree
4937             = ffecom_modify (NULL_TREE, arg2_tree,
4938                              convert (TREE_TYPE (arg2_tree),
4939                                       expr_tree));
4940       }
4941       return expr_tree;
4942
4943     case FFEINTRIN_impEXIT:
4944       if (arg1 != NULL)
4945         break;
4946
4947       expr_tree = build_tree_list (NULL_TREE,
4948                                    ffecom_1 (ADDR_EXPR,
4949                                              build_pointer_type
4950                                              (ffecom_integer_type_node),
4951                                              integer_zero_node));
4952
4953       return
4954         ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4955                       ffecom_gfrt_kindtype (gfrt),
4956                       FALSE,
4957                       void_type_node,
4958                       expr_tree,
4959                       NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4960                       ffebld_nonter_hook (expr));
4961
4962     case FFEINTRIN_impFLUSH:
4963       if (arg1 == NULL)
4964         gfrt = FFECOM_gfrtFLUSH;
4965       else
4966         gfrt = FFECOM_gfrtFLUSH1;
4967       break;
4968
4969     case FFEINTRIN_impCHMOD_subr:
4970     case FFEINTRIN_impLINK_subr:
4971     case FFEINTRIN_impRENAME_subr:
4972     case FFEINTRIN_impSYMLNK_subr:
4973       {
4974         tree arg1_len = integer_zero_node;
4975         tree arg1_tree;
4976         tree arg2_len = integer_zero_node;
4977         tree arg2_tree;
4978         tree arg3_tree;
4979
4980         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
4981         arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
4982         if (arg3 != NULL)
4983           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
4984         else
4985           arg3_tree = NULL_TREE;
4986
4987         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4988         arg1_len = build_tree_list (NULL_TREE, arg1_len);
4989         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4990         arg2_len = build_tree_list (NULL_TREE, arg2_len);
4991         TREE_CHAIN (arg1_tree) = arg2_tree;
4992         TREE_CHAIN (arg2_tree) = arg1_len;
4993         TREE_CHAIN (arg1_len) = arg2_len;
4994         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4995                                   ffecom_gfrt_kindtype (gfrt),
4996                                   FALSE,
4997                                   NULL_TREE,
4998                                   arg1_tree,
4999                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5000                                   ffebld_nonter_hook (expr));
5001         if (arg3_tree != NULL_TREE)
5002           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5003                                      convert (TREE_TYPE (arg3_tree),
5004                                               expr_tree));
5005       }
5006       return expr_tree;
5007
5008     case FFEINTRIN_impLSTAT_subr:
5009     case FFEINTRIN_impSTAT_subr:
5010       {
5011         tree arg1_len = integer_zero_node;
5012         tree arg1_tree;
5013         tree arg2_tree;
5014         tree arg3_tree;
5015
5016         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5017
5018         arg2_tree = ffecom_ptr_to_expr (arg2);
5019
5020         if (arg3 != NULL)
5021           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5022         else
5023           arg3_tree = NULL_TREE;
5024
5025         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5026         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5027         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5028         TREE_CHAIN (arg1_tree) = arg2_tree;
5029         TREE_CHAIN (arg2_tree) = arg1_len;
5030         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5031                                   ffecom_gfrt_kindtype (gfrt),
5032                                   FALSE,
5033                                   NULL_TREE,
5034                                   arg1_tree,
5035                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5036                                   ffebld_nonter_hook (expr));
5037         if (arg3_tree != NULL_TREE)
5038           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5039                                      convert (TREE_TYPE (arg3_tree),
5040                                               expr_tree));
5041       }
5042       return expr_tree;
5043
5044     case FFEINTRIN_impFGETC_subr:
5045     case FFEINTRIN_impFPUTC_subr:
5046       {
5047         tree arg1_tree;
5048         tree arg2_tree;
5049         tree arg2_len = integer_zero_node;
5050         tree arg3_tree;
5051
5052         arg1_tree = convert (ffecom_f2c_integer_type_node,
5053                              ffecom_expr (arg1));
5054         arg1_tree = ffecom_1 (ADDR_EXPR,
5055                               build_pointer_type (TREE_TYPE (arg1_tree)),
5056                               arg1_tree);
5057
5058         arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
5059         if (arg3 != NULL)
5060           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5061         else
5062           arg3_tree = NULL_TREE;
5063
5064         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5065         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5066         arg2_len = build_tree_list (NULL_TREE, arg2_len);
5067         TREE_CHAIN (arg1_tree) = arg2_tree;
5068         TREE_CHAIN (arg2_tree) = arg2_len;
5069
5070         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5071                                   ffecom_gfrt_kindtype (gfrt),
5072                                   FALSE,
5073                                   NULL_TREE,
5074                                   arg1_tree,
5075                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5076                                   ffebld_nonter_hook (expr));
5077         if (arg3_tree != NULL_TREE)
5078           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5079                                      convert (TREE_TYPE (arg3_tree),
5080                                               expr_tree));
5081       }
5082       return expr_tree;
5083
5084     case FFEINTRIN_impFSTAT_subr:
5085       {
5086         tree arg1_tree;
5087         tree arg2_tree;
5088         tree arg3_tree;
5089
5090         arg1_tree = convert (ffecom_f2c_integer_type_node,
5091                              ffecom_expr (arg1));
5092         arg1_tree = ffecom_1 (ADDR_EXPR,
5093                               build_pointer_type (TREE_TYPE (arg1_tree)),
5094                               arg1_tree);
5095
5096         arg2_tree = convert (ffecom_f2c_ptr_to_integer_type_node,
5097                              ffecom_ptr_to_expr (arg2));
5098
5099         if (arg3 == NULL)
5100           arg3_tree = NULL_TREE;
5101         else
5102           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5103
5104         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5105         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5106         TREE_CHAIN (arg1_tree) = arg2_tree;
5107         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5108                                   ffecom_gfrt_kindtype (gfrt),
5109                                   FALSE,
5110                                   NULL_TREE,
5111                                   arg1_tree,
5112                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5113                                   ffebld_nonter_hook (expr));
5114         if (arg3_tree != NULL_TREE) {
5115           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5116                                      convert (TREE_TYPE (arg3_tree),
5117                                               expr_tree));
5118         }
5119       }
5120       return expr_tree;
5121
5122     case FFEINTRIN_impKILL_subr:
5123       {
5124         tree arg1_tree;
5125         tree arg2_tree;
5126         tree arg3_tree;
5127
5128         arg1_tree = convert (ffecom_f2c_integer_type_node,
5129                              ffecom_expr (arg1));
5130         arg1_tree = ffecom_1 (ADDR_EXPR,
5131                               build_pointer_type (TREE_TYPE (arg1_tree)),
5132                               arg1_tree);
5133
5134         arg2_tree = convert (ffecom_f2c_integer_type_node,
5135                              ffecom_expr (arg2));
5136         arg2_tree = ffecom_1 (ADDR_EXPR,
5137                               build_pointer_type (TREE_TYPE (arg2_tree)),
5138                               arg2_tree);
5139
5140         if (arg3 == NULL)
5141           arg3_tree = NULL_TREE;
5142         else
5143           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5144
5145         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5146         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5147         TREE_CHAIN (arg1_tree) = arg2_tree;
5148         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5149                                   ffecom_gfrt_kindtype (gfrt),
5150                                   FALSE,
5151                                   NULL_TREE,
5152                                   arg1_tree,
5153                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5154                                   ffebld_nonter_hook (expr));
5155         if (arg3_tree != NULL_TREE) {
5156           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5157                                      convert (TREE_TYPE (arg3_tree),
5158                                               expr_tree));
5159         }
5160       }
5161       return expr_tree;
5162
5163     case FFEINTRIN_impCTIME_subr:
5164     case FFEINTRIN_impTTYNAM_subr:
5165       {
5166         tree arg1_len = integer_zero_node;
5167         tree arg1_tree;
5168         tree arg2_tree;
5169
5170         arg1_tree = ffecom_arg_ptr_to_expr (arg2, &arg1_len);
5171
5172         arg2_tree = convert (((codegen_imp == FFEINTRIN_impCTIME_subr) ?
5173                               ffecom_f2c_longint_type_node :
5174                               ffecom_f2c_integer_type_node),
5175                              ffecom_expr (arg1));
5176         arg2_tree = ffecom_1 (ADDR_EXPR,
5177                               build_pointer_type (TREE_TYPE (arg2_tree)),
5178                               arg2_tree);
5179
5180         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5181         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5182         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5183         TREE_CHAIN (arg1_len) = arg2_tree;
5184         TREE_CHAIN (arg1_tree) = arg1_len;
5185
5186         expr_tree
5187           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5188                           ffecom_gfrt_kindtype (gfrt),
5189                           FALSE,
5190                           NULL_TREE,
5191                           arg1_tree,
5192                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5193                           ffebld_nonter_hook (expr));
5194         TREE_SIDE_EFFECTS (expr_tree) = 1;
5195       }
5196       return expr_tree;
5197
5198     case FFEINTRIN_impIRAND:
5199     case FFEINTRIN_impRAND:
5200       /* Arg defaults to 0 (normal random case) */
5201       {
5202         tree arg1_tree;
5203
5204         if (arg1 == NULL)
5205           arg1_tree = ffecom_integer_zero_node;
5206         else
5207           arg1_tree = ffecom_expr (arg1);
5208         arg1_tree = convert (ffecom_f2c_integer_type_node,
5209                              arg1_tree);
5210         arg1_tree = ffecom_1 (ADDR_EXPR,
5211                               build_pointer_type (TREE_TYPE (arg1_tree)),
5212                               arg1_tree);
5213         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5214
5215         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5216                                   ffecom_gfrt_kindtype (gfrt),
5217                                   FALSE,
5218                                   ((codegen_imp == FFEINTRIN_impIRAND) ?
5219                                    ffecom_f2c_integer_type_node :
5220                                    ffecom_f2c_real_type_node),
5221                                   arg1_tree,
5222                                   dest_tree, dest, dest_used,
5223                                   NULL_TREE, TRUE,
5224                                   ffebld_nonter_hook (expr));
5225       }
5226       return expr_tree;
5227
5228     case FFEINTRIN_impFTELL_subr:
5229     case FFEINTRIN_impUMASK_subr:
5230       {
5231         tree arg1_tree;
5232         tree arg2_tree;
5233
5234         arg1_tree = convert (ffecom_f2c_integer_type_node,
5235                              ffecom_expr (arg1));
5236         arg1_tree = ffecom_1 (ADDR_EXPR,
5237                               build_pointer_type (TREE_TYPE (arg1_tree)),
5238                               arg1_tree);
5239
5240         if (arg2 == NULL)
5241           arg2_tree = NULL_TREE;
5242         else
5243           arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
5244
5245         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5246                                   ffecom_gfrt_kindtype (gfrt),
5247                                   FALSE,
5248                                   NULL_TREE,
5249                                   build_tree_list (NULL_TREE, arg1_tree),
5250                                   NULL_TREE, NULL, NULL, NULL_TREE,
5251                                   TRUE,
5252                                   ffebld_nonter_hook (expr));
5253         if (arg2_tree != NULL_TREE) {
5254           expr_tree = ffecom_modify (NULL_TREE, arg2_tree,
5255                                      convert (TREE_TYPE (arg2_tree),
5256                                               expr_tree));
5257         }
5258       }
5259       return expr_tree;
5260
5261     case FFEINTRIN_impCPU_TIME:
5262     case FFEINTRIN_impSECOND_subr:
5263       {
5264         tree arg1_tree;
5265
5266         arg1_tree = ffecom_expr_w (NULL_TREE, arg1);
5267
5268         expr_tree
5269           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5270                           ffecom_gfrt_kindtype (gfrt),
5271                           FALSE,
5272                           NULL_TREE,
5273                           NULL_TREE,
5274                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5275                           ffebld_nonter_hook (expr));
5276
5277         expr_tree
5278           = ffecom_modify (NULL_TREE, arg1_tree,
5279                            convert (TREE_TYPE (arg1_tree),
5280                                     expr_tree));
5281       }
5282       return expr_tree;
5283
5284     case FFEINTRIN_impDTIME_subr:
5285     case FFEINTRIN_impETIME_subr:
5286       {
5287         tree arg1_tree;
5288         tree result_tree;
5289
5290         result_tree = ffecom_expr_w (NULL_TREE, arg2);
5291
5292         arg1_tree = ffecom_ptr_to_expr (arg1);
5293
5294         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5295                                   ffecom_gfrt_kindtype (gfrt),
5296                                   FALSE,
5297                                   NULL_TREE,
5298                                   build_tree_list (NULL_TREE, arg1_tree),
5299                                   NULL_TREE, NULL, NULL, NULL_TREE,
5300                                   TRUE,
5301                                   ffebld_nonter_hook (expr));
5302         expr_tree = ffecom_modify (NULL_TREE, result_tree,
5303                                    convert (TREE_TYPE (result_tree),
5304                                             expr_tree));
5305       }
5306       return expr_tree;
5307
5308       /* Straightforward calls of libf2c routines: */
5309     case FFEINTRIN_impABORT:
5310     case FFEINTRIN_impACCESS:
5311     case FFEINTRIN_impBESJ0:
5312     case FFEINTRIN_impBESJ1:
5313     case FFEINTRIN_impBESJN:
5314     case FFEINTRIN_impBESY0:
5315     case FFEINTRIN_impBESY1:
5316     case FFEINTRIN_impBESYN:
5317     case FFEINTRIN_impCHDIR_func:
5318     case FFEINTRIN_impCHMOD_func:
5319     case FFEINTRIN_impDATE:
5320     case FFEINTRIN_impDATE_AND_TIME:
5321     case FFEINTRIN_impDBESJ0:
5322     case FFEINTRIN_impDBESJ1:
5323     case FFEINTRIN_impDBESJN:
5324     case FFEINTRIN_impDBESY0:
5325     case FFEINTRIN_impDBESY1:
5326     case FFEINTRIN_impDBESYN:
5327     case FFEINTRIN_impDTIME_func:
5328     case FFEINTRIN_impETIME_func:
5329     case FFEINTRIN_impFGETC_func:
5330     case FFEINTRIN_impFGET_func:
5331     case FFEINTRIN_impFNUM:
5332     case FFEINTRIN_impFPUTC_func:
5333     case FFEINTRIN_impFPUT_func:
5334     case FFEINTRIN_impFSEEK:
5335     case FFEINTRIN_impFSTAT_func:
5336     case FFEINTRIN_impFTELL_func:
5337     case FFEINTRIN_impGERROR:
5338     case FFEINTRIN_impGETARG:
5339     case FFEINTRIN_impGETCWD_func:
5340     case FFEINTRIN_impGETENV:
5341     case FFEINTRIN_impGETGID:
5342     case FFEINTRIN_impGETLOG:
5343     case FFEINTRIN_impGETPID:
5344     case FFEINTRIN_impGETUID:
5345     case FFEINTRIN_impGMTIME:
5346     case FFEINTRIN_impHOSTNM_func:
5347     case FFEINTRIN_impIDATE_unix:
5348     case FFEINTRIN_impIDATE_vxt:
5349     case FFEINTRIN_impIERRNO:
5350     case FFEINTRIN_impISATTY:
5351     case FFEINTRIN_impITIME:
5352     case FFEINTRIN_impKILL_func:
5353     case FFEINTRIN_impLINK_func:
5354     case FFEINTRIN_impLNBLNK:
5355     case FFEINTRIN_impLSTAT_func:
5356     case FFEINTRIN_impLTIME:
5357     case FFEINTRIN_impMCLOCK8:
5358     case FFEINTRIN_impMCLOCK:
5359     case FFEINTRIN_impPERROR:
5360     case FFEINTRIN_impRENAME_func:
5361     case FFEINTRIN_impSECNDS:
5362     case FFEINTRIN_impSECOND_func:
5363     case FFEINTRIN_impSLEEP:
5364     case FFEINTRIN_impSRAND:
5365     case FFEINTRIN_impSTAT_func:
5366     case FFEINTRIN_impSYMLNK_func:
5367     case FFEINTRIN_impSYSTEM_CLOCK:
5368     case FFEINTRIN_impSYSTEM_func:
5369     case FFEINTRIN_impTIME8:
5370     case FFEINTRIN_impTIME_unix:
5371     case FFEINTRIN_impTIME_vxt:
5372     case FFEINTRIN_impUMASK_func:
5373     case FFEINTRIN_impUNLINK_func:
5374       break;
5375
5376     case FFEINTRIN_impCTIME_func:       /* CHARACTER functions not handled here. */
5377     case FFEINTRIN_impFDATE_func:       /* CHARACTER functions not handled here. */
5378     case FFEINTRIN_impTTYNAM_func:      /* CHARACTER functions not handled here. */
5379     case FFEINTRIN_impNONE:
5380     case FFEINTRIN_imp:         /* Hush up gcc warning. */
5381       fprintf (stderr, "No %s implementation.\n",
5382                ffeintrin_name_implementation (ffebld_symter_implementation (ffebld_left (expr))));
5383       assert ("unimplemented intrinsic" == NULL);
5384       return error_mark_node;
5385     }
5386
5387   assert (gfrt != FFECOM_gfrt); /* Must have an implementation! */
5388
5389   expr_tree = ffecom_arglist_expr_ (ffecom_gfrt_args_ (gfrt),
5390                                     ffebld_right (expr));
5391
5392   return ffecom_call_ (ffecom_gfrt_tree_ (gfrt), ffecom_gfrt_kindtype (gfrt),
5393                        (ffe_is_f2c_library () && ffecom_gfrt_complex_[gfrt]),
5394                        tree_type,
5395                        expr_tree, dest_tree, dest, dest_used,
5396                        NULL_TREE, TRUE,
5397                        ffebld_nonter_hook (expr));
5398
5399   /* See bottom of this file for f2c transforms used to determine
5400      many of the above implementations.  The info seems to confuse
5401      Emacs's C mode indentation, which is why it's been moved to
5402      the bottom of this source file.  */
5403 }
5404
5405 /* For power (exponentiation) where right-hand operand is type INTEGER,
5406    generate in-line code to do it the fast way (which, if the operand
5407    is a constant, might just mean a series of multiplies).  */
5408
5409 static tree
5410 ffecom_expr_power_integer_ (ffebld expr)
5411 {
5412   tree l = ffecom_expr (ffebld_left (expr));
5413   tree r = ffecom_expr (ffebld_right (expr));
5414   tree ltype = TREE_TYPE (l);
5415   tree rtype = TREE_TYPE (r);
5416   tree result = NULL_TREE;
5417
5418   if (l == error_mark_node
5419       || r == error_mark_node)
5420     return error_mark_node;
5421
5422   if (TREE_CODE (r) == INTEGER_CST)
5423     {
5424       int sgn = tree_int_cst_sgn (r);
5425
5426       if (sgn == 0)
5427         return convert (ltype, integer_one_node);
5428
5429       if ((TREE_CODE (ltype) == INTEGER_TYPE)
5430           && (sgn < 0))
5431         {
5432           /* Reciprocal of integer is either 0, -1, or 1, so after
5433              calculating that (which we leave to the back end to do
5434              or not do optimally), don't bother with any multiplying.  */
5435
5436           result = ffecom_tree_divide_ (ltype,
5437                                         convert (ltype, integer_one_node),
5438                                         l,
5439                                         NULL_TREE, NULL, NULL, NULL_TREE);
5440           r = ffecom_1 (NEGATE_EXPR,
5441                         rtype,
5442                         r);
5443           if ((TREE_INT_CST_LOW (r) & 1) == 0)
5444             result = ffecom_1 (ABS_EXPR, rtype,
5445                                result);
5446         }
5447
5448       /* Generate appropriate series of multiplies, preceded
5449          by divide if the exponent is negative.  */
5450
5451       l = save_expr (l);
5452
5453       if (sgn < 0)
5454         {
5455           l = ffecom_tree_divide_ (ltype,
5456                                    convert (ltype, integer_one_node),
5457                                    l,
5458                                    NULL_TREE, NULL, NULL,
5459                                    ffebld_nonter_hook (expr));
5460           r = ffecom_1 (NEGATE_EXPR, rtype, r);
5461           assert (TREE_CODE (r) == INTEGER_CST);
5462
5463           if (tree_int_cst_sgn (r) < 0)
5464             {                   /* The "most negative" number.  */
5465               r = ffecom_1 (NEGATE_EXPR, rtype,
5466                             ffecom_2 (RSHIFT_EXPR, rtype,
5467                                       r,
5468                                       integer_one_node));
5469               l = save_expr (l);
5470               l = ffecom_2 (MULT_EXPR, ltype,
5471                             l,
5472                             l);
5473             }
5474         }
5475
5476       for (;;)
5477         {
5478           if (TREE_INT_CST_LOW (r) & 1)
5479             {
5480               if (result == NULL_TREE)
5481                 result = l;
5482               else
5483                 result = ffecom_2 (MULT_EXPR, ltype,
5484                                    result,
5485                                    l);
5486             }
5487
5488           r = ffecom_2 (RSHIFT_EXPR, rtype,
5489                         r,
5490                         integer_one_node);
5491           if (integer_zerop (r))
5492             break;
5493           assert (TREE_CODE (r) == INTEGER_CST);
5494
5495           l = save_expr (l);
5496           l = ffecom_2 (MULT_EXPR, ltype,
5497                         l,
5498                         l);
5499         }
5500       return result;
5501     }
5502
5503   /* Though rhs isn't a constant, in-line code cannot be expanded
5504      while transforming dummies
5505      because the back end cannot be easily convinced to generate
5506      stores (MODIFY_EXPR), handle temporaries, and so on before
5507      all the appropriate rtx's have been generated for things like
5508      dummy args referenced in rhs -- which doesn't happen until
5509      store_parm_decls() is called (expand_function_start, I believe,
5510      does the actual rtx-stuffing of PARM_DECLs).
5511
5512      So, in this case, let the caller generate the call to the
5513      run-time-library function to evaluate the power for us.  */
5514
5515   if (ffecom_transform_only_dummies_)
5516     return NULL_TREE;
5517
5518   /* Right-hand operand not a constant, expand in-line code to figure
5519      out how to do the multiplies, &c.
5520
5521      The returned expression is expressed this way in GNU C, where l and
5522      r are the "inputs":
5523
5524      ({ typeof (r) rtmp = r;
5525         typeof (l) ltmp = l;
5526         typeof (l) result;
5527
5528         if (rtmp == 0)
5529           result = 1;
5530         else
5531           {
5532             if ((basetypeof (l) == basetypeof (int))
5533                 && (rtmp < 0))
5534               {
5535                 result = ((typeof (l)) 1) / ltmp;
5536                 if ((ltmp < 0) && (((-rtmp) & 1) == 0))
5537                   result = -result;
5538               }
5539             else
5540               {
5541                 result = 1;
5542                 if ((basetypeof (l) != basetypeof (int))
5543                     && (rtmp < 0))
5544                   {
5545                     ltmp = ((typeof (l)) 1) / ltmp;
5546                     rtmp = -rtmp;
5547                     if (rtmp < 0)
5548                       {
5549                         rtmp = -(rtmp >> 1);
5550                         ltmp *= ltmp;
5551                       }
5552                   }
5553                 for (;;)
5554                   {
5555                     if (rtmp & 1)
5556                       result *= ltmp;
5557                     if ((rtmp >>= 1) == 0)
5558                       break;
5559                     ltmp *= ltmp;
5560                   }
5561               }
5562           }
5563         result;
5564      })
5565
5566      Note that some of the above is compile-time collapsable, such as
5567      the first part of the if statements that checks the base type of
5568      l against int.  The if statements are phrased that way to suggest
5569      an easy way to generate the if/else constructs here, knowing that
5570      the back end should (and probably does) eliminate the resulting
5571      dead code (either the int case or the non-int case), something
5572      it couldn't do without the redundant phrasing, requiring explicit
5573      dead-code elimination here, which would be kind of difficult to
5574      read.  */
5575
5576   {
5577     tree rtmp;
5578     tree ltmp;
5579     tree divide;
5580     tree basetypeof_l_is_int;
5581     tree se;
5582     tree t;
5583
5584     basetypeof_l_is_int
5585       = build_int_2 ((TREE_CODE (ltype) == INTEGER_TYPE), 0);
5586
5587     se = expand_start_stmt_expr ();
5588
5589     ffecom_start_compstmt ();
5590
5591 #ifndef HAHA
5592     rtmp = ffecom_make_tempvar ("power_r", rtype,
5593                                 FFETARGET_charactersizeNONE, -1);
5594     ltmp = ffecom_make_tempvar ("power_l", ltype,
5595                                 FFETARGET_charactersizeNONE, -1);
5596     result = ffecom_make_tempvar ("power_res", ltype,
5597                                   FFETARGET_charactersizeNONE, -1);
5598     if (TREE_CODE (ltype) == COMPLEX_TYPE
5599         || TREE_CODE (ltype) == RECORD_TYPE)
5600       divide = ffecom_make_tempvar ("power_div", ltype,
5601                                     FFETARGET_charactersizeNONE, -1);
5602     else
5603       divide = NULL_TREE;
5604 #else  /* HAHA */
5605     {
5606       tree hook;
5607
5608       hook = ffebld_nonter_hook (expr);
5609       assert (hook);
5610       assert (TREE_CODE (hook) == TREE_VEC);
5611       assert (TREE_VEC_LENGTH (hook) == 4);
5612       rtmp = TREE_VEC_ELT (hook, 0);
5613       ltmp = TREE_VEC_ELT (hook, 1);
5614       result = TREE_VEC_ELT (hook, 2);
5615       divide = TREE_VEC_ELT (hook, 3);
5616       if (TREE_CODE (ltype) == COMPLEX_TYPE
5617           || TREE_CODE (ltype) == RECORD_TYPE)
5618         assert (divide);
5619       else
5620         assert (! divide);
5621     }
5622 #endif  /* HAHA */
5623
5624     expand_expr_stmt (ffecom_modify (void_type_node,
5625                                      rtmp,
5626                                      r));
5627     expand_expr_stmt (ffecom_modify (void_type_node,
5628                                      ltmp,
5629                                      l));
5630     expand_start_cond (ffecom_truth_value
5631                        (ffecom_2 (EQ_EXPR, integer_type_node,
5632                                   rtmp,
5633                                   convert (rtype, integer_zero_node))),
5634                        0);
5635     expand_expr_stmt (ffecom_modify (void_type_node,
5636                                      result,
5637                                      convert (ltype, integer_one_node)));
5638     expand_start_else ();
5639     if (! integer_zerop (basetypeof_l_is_int))
5640       {
5641         expand_start_cond (ffecom_2 (LT_EXPR, integer_type_node,
5642                                      rtmp,
5643                                      convert (rtype,
5644                                               integer_zero_node)),
5645                            0);
5646         expand_expr_stmt (ffecom_modify (void_type_node,
5647                                          result,
5648                                          ffecom_tree_divide_
5649                                          (ltype,
5650                                           convert (ltype, integer_one_node),
5651                                           ltmp,
5652                                           NULL_TREE, NULL, NULL,
5653                                           divide)));
5654         expand_start_cond (ffecom_truth_value
5655                            (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5656                                       ffecom_2 (LT_EXPR, integer_type_node,
5657                                                 ltmp,
5658                                                 convert (ltype,
5659                                                          integer_zero_node)),
5660                                       ffecom_2 (EQ_EXPR, integer_type_node,
5661                                                 ffecom_2 (BIT_AND_EXPR,
5662                                                           rtype,
5663                                                           ffecom_1 (NEGATE_EXPR,
5664                                                                     rtype,
5665                                                                     rtmp),
5666                                                           convert (rtype,
5667                                                                    integer_one_node)),
5668                                                 convert (rtype,
5669                                                          integer_zero_node)))),
5670                            0);
5671         expand_expr_stmt (ffecom_modify (void_type_node,
5672                                          result,
5673                                          ffecom_1 (NEGATE_EXPR,
5674                                                    ltype,
5675                                                    result)));
5676         expand_end_cond ();
5677         expand_start_else ();
5678       }
5679     expand_expr_stmt (ffecom_modify (void_type_node,
5680                                      result,
5681                                      convert (ltype, integer_one_node)));
5682     expand_start_cond (ffecom_truth_value
5683                        (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5684                                   ffecom_truth_value_invert
5685                                   (basetypeof_l_is_int),
5686                                   ffecom_2 (LT_EXPR, integer_type_node,
5687                                             rtmp,
5688                                             convert (rtype,
5689                                                      integer_zero_node)))),
5690                        0);
5691     expand_expr_stmt (ffecom_modify (void_type_node,
5692                                      ltmp,
5693                                      ffecom_tree_divide_
5694                                      (ltype,
5695                                       convert (ltype, integer_one_node),
5696                                       ltmp,
5697                                       NULL_TREE, NULL, NULL,
5698                                       divide)));
5699     expand_expr_stmt (ffecom_modify (void_type_node,
5700                                      rtmp,
5701                                      ffecom_1 (NEGATE_EXPR, rtype,
5702                                                rtmp)));
5703     expand_start_cond (ffecom_truth_value
5704                        (ffecom_2 (LT_EXPR, integer_type_node,
5705                                   rtmp,
5706                                   convert (rtype, integer_zero_node))),
5707                        0);
5708     expand_expr_stmt (ffecom_modify (void_type_node,
5709                                      rtmp,
5710                                      ffecom_1 (NEGATE_EXPR, rtype,
5711                                                ffecom_2 (RSHIFT_EXPR,
5712                                                          rtype,
5713                                                          rtmp,
5714                                                          integer_one_node))));
5715     expand_expr_stmt (ffecom_modify (void_type_node,
5716                                      ltmp,
5717                                      ffecom_2 (MULT_EXPR, ltype,
5718                                                ltmp,
5719                                                ltmp)));
5720     expand_end_cond ();
5721     expand_end_cond ();
5722     expand_start_loop (1);
5723     expand_start_cond (ffecom_truth_value
5724                        (ffecom_2 (BIT_AND_EXPR, rtype,
5725                                   rtmp,
5726                                   convert (rtype, integer_one_node))),
5727                        0);
5728     expand_expr_stmt (ffecom_modify (void_type_node,
5729                                      result,
5730                                      ffecom_2 (MULT_EXPR, ltype,
5731                                                result,
5732                                                ltmp)));
5733     expand_end_cond ();
5734     expand_exit_loop_if_false (NULL,
5735                                ffecom_truth_value
5736                                (ffecom_modify (rtype,
5737                                                rtmp,
5738                                                ffecom_2 (RSHIFT_EXPR,
5739                                                          rtype,
5740                                                          rtmp,
5741                                                          integer_one_node))));
5742     expand_expr_stmt (ffecom_modify (void_type_node,
5743                                      ltmp,
5744                                      ffecom_2 (MULT_EXPR, ltype,
5745                                                ltmp,
5746                                                ltmp)));
5747     expand_end_loop ();
5748     expand_end_cond ();
5749     if (!integer_zerop (basetypeof_l_is_int))
5750       expand_end_cond ();
5751     expand_expr_stmt (result);
5752
5753     t = ffecom_end_compstmt ();
5754
5755     result = expand_end_stmt_expr (se);
5756
5757     /* This code comes from c-parse.in, after its expand_end_stmt_expr.  */
5758
5759     if (TREE_CODE (t) == BLOCK)
5760       {
5761         /* Make a BIND_EXPR for the BLOCK already made.  */
5762         result = build (BIND_EXPR, TREE_TYPE (result),
5763                         NULL_TREE, result, t);
5764         /* Remove the block from the tree at this point.
5765            It gets put back at the proper place
5766            when the BIND_EXPR is expanded.  */
5767         delete_block (t);
5768       }
5769     else
5770       result = t;
5771   }
5772
5773   return result;
5774 }
5775
5776 /* ffecom_expr_transform_ -- Transform symbols in expr
5777
5778    ffebld expr;  // FFE expression.
5779    ffecom_expr_transform_ (expr);
5780
5781    Recursive descent on expr while transforming any untransformed SYMTERs.  */
5782
5783 static void
5784 ffecom_expr_transform_ (ffebld expr)
5785 {
5786   tree t;
5787   ffesymbol s;
5788
5789  tail_recurse:
5790
5791   if (expr == NULL)
5792     return;
5793
5794   switch (ffebld_op (expr))
5795     {
5796     case FFEBLD_opSYMTER:
5797       s = ffebld_symter (expr);
5798       t = ffesymbol_hook (s).decl_tree;
5799       if ((t == NULL_TREE)
5800           && ((ffesymbol_kind (s) != FFEINFO_kindNONE)
5801               || ((ffesymbol_where (s) != FFEINFO_whereNONE)
5802                   && (ffesymbol_where (s) != FFEINFO_whereINTRINSIC))))
5803         {
5804           s = ffecom_sym_transform_ (s);
5805           t = ffesymbol_hook (s).decl_tree;     /* Sfunc expr non-dummy,
5806                                                    DIMENSION expr? */
5807         }
5808       break;                    /* Ok if (t == NULL) here. */
5809
5810     case FFEBLD_opITEM:
5811       ffecom_expr_transform_ (ffebld_head (expr));
5812       expr = ffebld_trail (expr);
5813       goto tail_recurse;        /* :::::::::::::::::::: */
5814
5815     default:
5816       break;
5817     }
5818
5819   switch (ffebld_arity (expr))
5820     {
5821     case 2:
5822       ffecom_expr_transform_ (ffebld_left (expr));
5823       expr = ffebld_right (expr);
5824       goto tail_recurse;        /* :::::::::::::::::::: */
5825
5826     case 1:
5827       expr = ffebld_left (expr);
5828       goto tail_recurse;        /* :::::::::::::::::::: */
5829
5830     default:
5831       break;
5832     }
5833
5834   return;
5835 }
5836
5837 /* Make a type based on info in live f2c.h file.  */
5838
5839 static void
5840 ffecom_f2c_make_type_ (tree *type, int tcode, const char *name)
5841 {
5842   switch (tcode)
5843     {
5844     case FFECOM_f2ccodeCHAR:
5845       *type = make_signed_type (CHAR_TYPE_SIZE);
5846       break;
5847
5848     case FFECOM_f2ccodeSHORT:
5849       *type = make_signed_type (SHORT_TYPE_SIZE);
5850       break;
5851
5852     case FFECOM_f2ccodeINT:
5853       *type = make_signed_type (INT_TYPE_SIZE);
5854       break;
5855
5856     case FFECOM_f2ccodeLONG:
5857       *type = make_signed_type (LONG_TYPE_SIZE);
5858       break;
5859
5860     case FFECOM_f2ccodeLONGLONG:
5861       *type = make_signed_type (LONG_LONG_TYPE_SIZE);
5862       break;
5863
5864     case FFECOM_f2ccodeCHARPTR:
5865       *type = build_pointer_type (DEFAULT_SIGNED_CHAR
5866                                   ? signed_char_type_node
5867                                   : unsigned_char_type_node);
5868       break;
5869
5870     case FFECOM_f2ccodeFLOAT:
5871       *type = make_node (REAL_TYPE);
5872       TYPE_PRECISION (*type) = FLOAT_TYPE_SIZE;
5873       layout_type (*type);
5874       break;
5875
5876     case FFECOM_f2ccodeDOUBLE:
5877       *type = make_node (REAL_TYPE);
5878       TYPE_PRECISION (*type) = DOUBLE_TYPE_SIZE;
5879       layout_type (*type);
5880       break;
5881
5882     case FFECOM_f2ccodeLONGDOUBLE:
5883       *type = make_node (REAL_TYPE);
5884       TYPE_PRECISION (*type) = LONG_DOUBLE_TYPE_SIZE;
5885       layout_type (*type);
5886       break;
5887
5888     case FFECOM_f2ccodeTWOREALS:
5889       *type = ffecom_make_complex_type_ (ffecom_f2c_real_type_node);
5890       break;
5891
5892     case FFECOM_f2ccodeTWODOUBLEREALS:
5893       *type = ffecom_make_complex_type_ (ffecom_f2c_doublereal_type_node);
5894       break;
5895
5896     default:
5897       assert ("unexpected FFECOM_f2ccodeXYZZY!" == NULL);
5898       *type = error_mark_node;
5899       return;
5900     }
5901
5902   pushdecl (build_decl (TYPE_DECL,
5903                         ffecom_get_invented_identifier ("__g77_f2c_%s", name),
5904                         *type));
5905 }
5906
5907 /* Set the f2c list-directed-I/O code for whatever (integral) type has the
5908    given size.  */
5909
5910 static void
5911 ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
5912                           int code)
5913 {
5914   int j;
5915   tree t;
5916
5917   for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
5918     if ((t = ffecom_tree_type[bt][j]) != NULL_TREE
5919         && compare_tree_int (TYPE_SIZE (t), size) == 0)
5920       {
5921         assert (code != -1);
5922         ffecom_f2c_typecode_[bt][j] = code;
5923         code = -1;
5924       }
5925 }
5926
5927 /* Finish up globals after doing all program units in file
5928
5929    Need to handle only uninitialized COMMON areas.  */
5930
5931 static ffeglobal
5932 ffecom_finish_global_ (ffeglobal global)
5933 {
5934   tree cbtype;
5935   tree cbt;
5936   tree size;
5937
5938   if (ffeglobal_type (global) != FFEGLOBAL_typeCOMMON)
5939       return global;
5940
5941   if (ffeglobal_common_init (global))
5942       return global;
5943
5944   cbt = ffeglobal_hook (global);
5945   if ((cbt == NULL_TREE)
5946       || !ffeglobal_common_have_size (global))
5947     return global;              /* No need to make common, never ref'd. */
5948
5949   DECL_EXTERNAL (cbt) = 0;
5950
5951   /* Give the array a size now.  */
5952
5953   size = build_int_2 ((ffeglobal_common_size (global)
5954                       + ffeglobal_common_pad (global)) - 1,
5955                       0);
5956
5957   cbtype = TREE_TYPE (cbt);
5958   TYPE_DOMAIN (cbtype) = build_range_type (integer_type_node,
5959                                            integer_zero_node,
5960                                            size);
5961   if (!TREE_TYPE (size))
5962     TREE_TYPE (size) = TYPE_DOMAIN (cbtype);
5963   layout_type (cbtype);
5964
5965   cbt = start_decl (cbt, FALSE);
5966   assert (cbt == ffeglobal_hook (global));
5967
5968   finish_decl (cbt, NULL_TREE, FALSE);
5969
5970   return global;
5971 }
5972
5973 /* Finish up any untransformed symbols.  */
5974
5975 static ffesymbol
5976 ffecom_finish_symbol_transform_ (ffesymbol s)
5977 {
5978   if ((s == NULL) || (TREE_CODE (current_function_decl) == ERROR_MARK))
5979     return s;
5980
5981   /* It's easy to know to transform an untransformed symbol, to make sure
5982      we put out debugging info for it.  But COMMON variables, unlike
5983      EQUIVALENCE ones, aren't given declarations in addition to the
5984      tree expressions that specify offsets, because COMMON variables
5985      can be referenced in the outer scope where only dummy arguments
5986      (PARM_DECLs) should really be seen.  To be safe, just don't do any
5987      VAR_DECLs for COMMON variables when we transform them for real
5988      use, and therefore we do all the VAR_DECL creating here.  */
5989
5990   if (ffesymbol_hook (s).decl_tree == NULL_TREE)
5991     {
5992       if (ffesymbol_kind (s) != FFEINFO_kindNONE
5993           || (ffesymbol_where (s) != FFEINFO_whereNONE
5994               && ffesymbol_where (s) != FFEINFO_whereINTRINSIC
5995               && ffesymbol_where (s) != FFEINFO_whereDUMMY))
5996         /* Not transformed, and not CHARACTER*(*), and not a dummy
5997            argument, which can happen only if the entry point names
5998            it "rides in on" are all invalidated for other reasons.  */
5999         s = ffecom_sym_transform_ (s);
6000     }
6001
6002   if ((ffesymbol_where (s) == FFEINFO_whereCOMMON)
6003       && (ffesymbol_hook (s).decl_tree != error_mark_node))
6004     {
6005       /* This isn't working, at least for dbxout.  The .s file looks
6006          okay to me (burley), but in gdb 4.9 at least, the variables
6007          appear to reside somewhere outside of the common area, so
6008          it doesn't make sense to mislead anyone by generating the info
6009          on those variables until this is fixed.  NOTE: Same problem
6010          with EQUIVALENCE, sadly...see similar #if later.  */
6011       ffecom_member_phase2_ (ffesymbol_storage (ffesymbol_common (s)),
6012                              ffesymbol_storage (s));
6013     }
6014
6015   return s;
6016 }
6017
6018 /* Append underscore(s) to name before calling get_identifier.  "us"
6019    is nonzero if the name already contains an underscore and thus
6020    needs two underscores appended.  */
6021
6022 static tree
6023 ffecom_get_appended_identifier_ (char us, const char *name)
6024 {
6025   int i;
6026   char *newname;
6027   tree id;
6028
6029   newname = xmalloc ((i = strlen (name)) + 1
6030                      + ffe_is_underscoring ()
6031                      + us);
6032   memcpy (newname, name, i);
6033   newname[i] = '_';
6034   newname[i + us] = '_';
6035   newname[i + 1 + us] = '\0';
6036   id = get_identifier (newname);
6037
6038   free (newname);
6039
6040   return id;
6041 }
6042
6043 /* Decide whether to append underscore to name before calling
6044    get_identifier.  */
6045
6046 static tree
6047 ffecom_get_external_identifier_ (ffesymbol s)
6048 {
6049   char us;
6050   const char *name = ffesymbol_text (s);
6051
6052   /* If name is a built-in name, just return it as is.  */
6053
6054   if (!ffe_is_underscoring ()
6055       || (strcmp (name, FFETARGET_nameBLANK_COMMON) == 0)
6056 #if FFETARGET_isENFORCED_MAIN_NAME
6057       || (strcmp (name, FFETARGET_nameENFORCED_NAME) == 0)
6058 #else
6059       || (strcmp (name, FFETARGET_nameUNNAMED_MAIN) == 0)
6060 #endif
6061       || (strcmp (name, FFETARGET_nameUNNAMED_BLOCK_DATA) == 0))
6062     return get_identifier (name);
6063
6064   us = ffe_is_second_underscore ()
6065     ? (strchr (name, '_') != NULL)
6066       : 0;
6067
6068   return ffecom_get_appended_identifier_ (us, name);
6069 }
6070
6071 /* Decide whether to append underscore to internal name before calling
6072    get_identifier.
6073
6074    This is for non-external, top-function-context names only.  Transform
6075    identifier so it doesn't conflict with the transformed result
6076    of using a _different_ external name.  E.g. if "CALL FOO" is
6077    transformed into "FOO_();", then the variable in "FOO_ = 3"
6078    must be transformed into something that does not conflict, since
6079    these two things should be independent.
6080
6081    The transformation is as follows.  If the name does not contain
6082    an underscore, there is no possible conflict, so just return.
6083    If the name does contain an underscore, then transform it just
6084    like we transform an external identifier.  */
6085
6086 static tree
6087 ffecom_get_identifier_ (const char *name)
6088 {
6089   /* If name does not contain an underscore, just return it as is.  */
6090
6091   if (!ffe_is_underscoring ()
6092       || (strchr (name, '_') == NULL))
6093     return get_identifier (name);
6094
6095   return ffecom_get_appended_identifier_ (ffe_is_second_underscore (),
6096                                           name);
6097 }
6098
6099 /* ffecom_gen_sfuncdef_ -- Generate definition of statement function
6100
6101    tree t;
6102    ffesymbol s;  // kindFUNCTION, whereIMMEDIATE.
6103    t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s),
6104          ffesymbol_kindtype(s));
6105
6106    Call after setting up containing function and getting trees for all
6107    other symbols.  */
6108
6109 static tree
6110 ffecom_gen_sfuncdef_ (ffesymbol s, ffeinfoBasictype bt, ffeinfoKindtype kt)
6111 {
6112   ffebld expr = ffesymbol_sfexpr (s);
6113   tree type;
6114   tree func;
6115   tree result;
6116   bool charfunc = (bt == FFEINFO_basictypeCHARACTER);
6117   static bool recurse = FALSE;
6118   int old_lineno = lineno;
6119   const char *old_input_filename = input_filename;
6120
6121   ffecom_nested_entry_ = s;
6122
6123   /* For now, we don't have a handy pointer to where the sfunc is actually
6124      defined, though that should be easy to add to an ffesymbol. (The
6125      token/where info available might well point to the place where the type
6126      of the sfunc is declared, especially if that precedes the place where
6127      the sfunc itself is defined, which is typically the case.)  We should
6128      put out a null pointer rather than point somewhere wrong, but I want to
6129      see how it works at this point.  */
6130
6131   input_filename = ffesymbol_where_filename (s);
6132   lineno = ffesymbol_where_filelinenum (s);
6133
6134   /* Pretransform the expression so any newly discovered things belong to the
6135      outer program unit, not to the statement function. */
6136
6137   ffecom_expr_transform_ (expr);
6138
6139   /* Make sure no recursive invocation of this fn (a specific case of failing
6140      to pretransform an sfunc's expression, i.e. where its expression
6141      references another untransformed sfunc) happens. */
6142
6143   assert (!recurse);
6144   recurse = TRUE;
6145
6146   push_f_function_context ();
6147
6148   if (charfunc)
6149     type = void_type_node;
6150   else
6151     {
6152       type = ffecom_tree_type[bt][kt];
6153       if (type == NULL_TREE)
6154         type = integer_type_node;       /* _sym_exec_transition reports
6155                                            error. */
6156     }
6157
6158   start_function (ffecom_get_identifier_ (ffesymbol_text (s)),
6159                   build_function_type (type, NULL_TREE),
6160                   1,            /* nested/inline */
6161                   0);           /* TREE_PUBLIC */
6162
6163   /* We don't worry about COMPLEX return values here, because this is
6164      entirely internal to our code, and gcc has the ability to return COMPLEX
6165      directly as a value.  */
6166
6167   if (charfunc)
6168     {                           /* Prepend arg for where result goes. */
6169       tree type;
6170
6171       type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
6172
6173       result = ffecom_get_invented_identifier ("__g77_%s", "result");
6174
6175       ffecom_char_enhance_arg_ (&type, s);      /* Ignore returned length. */
6176
6177       type = build_pointer_type (type);
6178       result = build_decl (PARM_DECL, result, type);
6179
6180       push_parm_decl (result);
6181     }
6182   else
6183     result = NULL_TREE;         /* Not ref'd if !charfunc. */
6184
6185   ffecom_push_dummy_decls_ (ffesymbol_dummyargs (s), TRUE);
6186
6187   store_parm_decls (0);
6188
6189   ffecom_start_compstmt ();
6190
6191   if (expr != NULL)
6192     {
6193       if (charfunc)
6194         {
6195           ffetargetCharacterSize sz = ffesymbol_size (s);
6196           tree result_length;
6197
6198           result_length = build_int_2 (sz, 0);
6199           TREE_TYPE (result_length) = ffecom_f2c_ftnlen_type_node;
6200
6201           ffecom_prepare_let_char_ (sz, expr);
6202
6203           ffecom_prepare_end ();
6204
6205           ffecom_let_char_ (result, result_length, sz, expr);
6206           expand_null_return ();
6207         }
6208       else
6209         {
6210           ffecom_prepare_expr (expr);
6211
6212           ffecom_prepare_end ();
6213
6214           expand_return (ffecom_modify (NULL_TREE,
6215                                         DECL_RESULT (current_function_decl),
6216                                         ffecom_expr (expr)));
6217         }
6218     }
6219
6220   ffecom_end_compstmt ();
6221
6222   func = current_function_decl;
6223   finish_function (1);
6224
6225   pop_f_function_context ();
6226
6227   recurse = FALSE;
6228
6229   lineno = old_lineno;
6230   input_filename = old_input_filename;
6231
6232   ffecom_nested_entry_ = NULL;
6233
6234   return func;
6235 }
6236
6237 static const char *
6238 ffecom_gfrt_args_ (ffecomGfrt ix)
6239 {
6240   return ffecom_gfrt_argstring_[ix];
6241 }
6242
6243 static tree
6244 ffecom_gfrt_tree_ (ffecomGfrt ix)
6245 {
6246   if (ffecom_gfrt_[ix] == NULL_TREE)
6247     ffecom_make_gfrt_ (ix);
6248
6249   return ffecom_1 (ADDR_EXPR,
6250                    build_pointer_type (TREE_TYPE (ffecom_gfrt_[ix])),
6251                    ffecom_gfrt_[ix]);
6252 }
6253
6254 /* Return initialize-to-zero expression for this VAR_DECL.  */
6255
6256 /* A somewhat evil way to prevent the garbage collector
6257    from collecting 'tree' structures.  */
6258 #define NUM_TRACKED_CHUNK 63
6259 static struct tree_ggc_tracker
6260 {
6261   struct tree_ggc_tracker *next;
6262   tree trees[NUM_TRACKED_CHUNK];
6263 } *tracker_head = NULL;
6264
6265 static void
6266 mark_tracker_head (void *arg)
6267 {
6268   struct tree_ggc_tracker *head;
6269   int i;
6270
6271   for (head = * (struct tree_ggc_tracker **) arg;
6272        head != NULL;
6273        head = head->next)
6274   {
6275     ggc_mark (head);
6276     for (i = 0; i < NUM_TRACKED_CHUNK; i++)
6277       ggc_mark_tree (head->trees[i]);
6278   }
6279 }
6280
6281 void
6282 ffecom_save_tree_forever (tree t)
6283 {
6284   int i;
6285   if (tracker_head != NULL)
6286     for (i = 0; i < NUM_TRACKED_CHUNK; i++)
6287       if (tracker_head->trees[i] == NULL)
6288         {
6289           tracker_head->trees[i] = t;
6290           return;
6291         }
6292
6293   {
6294     /* Need to allocate a new block.  */
6295     struct tree_ggc_tracker *old_head = tracker_head;
6296
6297     tracker_head = ggc_alloc (sizeof (*tracker_head));
6298     tracker_head->next = old_head;
6299     tracker_head->trees[0] = t;
6300     for (i = 1; i < NUM_TRACKED_CHUNK; i++)
6301       tracker_head->trees[i] = NULL;
6302   }
6303 }
6304
6305 static tree
6306 ffecom_init_zero_ (tree decl)
6307 {
6308   tree init;
6309   int incremental = TREE_STATIC (decl);
6310   tree type = TREE_TYPE (decl);
6311
6312   if (incremental)
6313     {
6314       make_decl_rtl (decl, NULL);
6315       assemble_variable (decl, TREE_PUBLIC (decl) ? 1 : 0, 0, 1);
6316     }
6317
6318   if ((TREE_CODE (type) != ARRAY_TYPE)
6319       && (TREE_CODE (type) != RECORD_TYPE)
6320       && (TREE_CODE (type) != UNION_TYPE)
6321       && !incremental)
6322     init = convert (type, integer_zero_node);
6323   else if (!incremental)
6324     {
6325       init = build (CONSTRUCTOR, type, NULL_TREE, NULL_TREE);
6326       TREE_CONSTANT (init) = 1;
6327       TREE_STATIC (init) = 1;
6328     }
6329   else
6330     {
6331       assemble_zeros (int_size_in_bytes (type));
6332       init = error_mark_node;
6333     }
6334
6335   return init;
6336 }
6337
6338 static tree
6339 ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
6340                          tree *maybe_tree)
6341 {
6342   tree expr_tree;
6343   tree length_tree;
6344
6345   switch (ffebld_op (arg))
6346     {
6347     case FFEBLD_opCONTER:       /* For F90, check 0-length. */
6348       if (ffetarget_length_character1
6349           (ffebld_constant_character1
6350            (ffebld_conter (arg))) == 0)
6351         {
6352           *maybe_tree = integer_zero_node;
6353           return convert (tree_type, integer_zero_node);
6354         }
6355
6356       *maybe_tree = integer_one_node;
6357       expr_tree = build_int_2 (*ffetarget_text_character1
6358                                (ffebld_constant_character1
6359                                 (ffebld_conter (arg))),
6360                                0);
6361       TREE_TYPE (expr_tree) = tree_type;
6362       return expr_tree;
6363
6364     case FFEBLD_opSYMTER:
6365     case FFEBLD_opARRAYREF:
6366     case FFEBLD_opFUNCREF:
6367     case FFEBLD_opSUBSTR:
6368       ffecom_char_args_ (&expr_tree, &length_tree, arg);
6369
6370       if ((expr_tree == error_mark_node)
6371           || (length_tree == error_mark_node))
6372         {
6373           *maybe_tree = error_mark_node;
6374           return error_mark_node;
6375         }
6376
6377       if (integer_zerop (length_tree))
6378         {
6379           *maybe_tree = integer_zero_node;
6380           return convert (tree_type, integer_zero_node);
6381         }
6382
6383       expr_tree
6384         = ffecom_1 (INDIRECT_REF,
6385                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6386                     expr_tree);
6387       expr_tree
6388         = ffecom_2 (ARRAY_REF,
6389                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6390                     expr_tree,
6391                     integer_one_node);
6392       expr_tree = convert (tree_type, expr_tree);
6393
6394       if (TREE_CODE (length_tree) == INTEGER_CST)
6395         *maybe_tree = integer_one_node;
6396       else                      /* Must check length at run time.  */
6397         *maybe_tree
6398           = ffecom_truth_value
6399             (ffecom_2 (GT_EXPR, integer_type_node,
6400                        length_tree,
6401                        ffecom_f2c_ftnlen_zero_node));
6402       return expr_tree;
6403
6404     case FFEBLD_opPAREN:
6405     case FFEBLD_opCONVERT:
6406       if (ffeinfo_size (ffebld_info (arg)) == 0)
6407         {
6408           *maybe_tree = integer_zero_node;
6409           return convert (tree_type, integer_zero_node);
6410         }
6411       return ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6412                                       maybe_tree);
6413
6414     case FFEBLD_opCONCATENATE:
6415       {
6416         tree maybe_left;
6417         tree maybe_right;
6418         tree expr_left;
6419         tree expr_right;
6420
6421         expr_left = ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6422                                              &maybe_left);
6423         expr_right = ffecom_intrinsic_ichar_ (tree_type, ffebld_right (arg),
6424                                               &maybe_right);
6425         *maybe_tree = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
6426                                 maybe_left,
6427                                 maybe_right);
6428         expr_tree = ffecom_3 (COND_EXPR, tree_type,
6429                               maybe_left,
6430                               expr_left,
6431                               expr_right);
6432         return expr_tree;
6433       }
6434
6435     default:
6436       assert ("bad op in ICHAR" == NULL);
6437       return error_mark_node;
6438     }
6439 }
6440
6441 /* ffecom_intrinsic_len_ -- Return length info for char arg (LEN())
6442
6443    tree length_arg;
6444    ffebld expr;
6445    length_arg = ffecom_intrinsic_len_ (expr);
6446
6447    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
6448    subexpressions by constructing the appropriate tree for the
6449    length-of-character-text argument in a calling sequence.  */
6450
6451 static tree
6452 ffecom_intrinsic_len_ (ffebld expr)
6453 {
6454   ffetargetCharacter1 val;
6455   tree length;
6456
6457   switch (ffebld_op (expr))
6458     {
6459     case FFEBLD_opCONTER:
6460       val = ffebld_constant_character1 (ffebld_conter (expr));
6461       length = build_int_2 (ffetarget_length_character1 (val), 0);
6462       TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6463       break;
6464
6465     case FFEBLD_opSYMTER:
6466       {
6467         ffesymbol s = ffebld_symter (expr);
6468         tree item;
6469
6470         item = ffesymbol_hook (s).decl_tree;
6471         if (item == NULL_TREE)
6472           {
6473             s = ffecom_sym_transform_ (s);
6474             item = ffesymbol_hook (s).decl_tree;
6475           }
6476         if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
6477           {
6478             if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
6479               length = ffesymbol_hook (s).length_tree;
6480             else
6481               {
6482                 length = build_int_2 (ffesymbol_size (s), 0);
6483                 TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6484               }
6485           }
6486         else if (item == error_mark_node)
6487           length = error_mark_node;
6488         else                    /* FFEINFO_kindFUNCTION: */
6489           length = NULL_TREE;
6490       }
6491       break;
6492
6493     case FFEBLD_opARRAYREF:
6494       length = ffecom_intrinsic_len_ (ffebld_left (expr));
6495       break;
6496
6497     case FFEBLD_opSUBSTR:
6498       {
6499         ffebld start;
6500         ffebld end;
6501         ffebld thing = ffebld_right (expr);
6502         tree start_tree;
6503         tree end_tree;
6504
6505         assert (ffebld_op (thing) == FFEBLD_opITEM);
6506         start = ffebld_head (thing);
6507         thing = ffebld_trail (thing);
6508         assert (ffebld_trail (thing) == NULL);
6509         end = ffebld_head (thing);
6510
6511         length = ffecom_intrinsic_len_ (ffebld_left (expr));
6512
6513         if (length == error_mark_node)
6514           break;
6515
6516         if (start == NULL)
6517           {
6518             if (end == NULL)
6519               ;
6520             else
6521               {
6522                 length = convert (ffecom_f2c_ftnlen_type_node,
6523                                   ffecom_expr (end));
6524               }
6525           }
6526         else
6527           {
6528             start_tree = convert (ffecom_f2c_ftnlen_type_node,
6529                                   ffecom_expr (start));
6530
6531             if (start_tree == error_mark_node)
6532               {
6533                 length = error_mark_node;
6534                 break;
6535               }
6536
6537             if (end == NULL)
6538               {
6539                 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6540                                    ffecom_f2c_ftnlen_one_node,
6541                                    ffecom_2 (MINUS_EXPR,
6542                                              ffecom_f2c_ftnlen_type_node,
6543                                              length,
6544                                              start_tree));
6545               }
6546             else
6547               {
6548                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
6549                                     ffecom_expr (end));
6550
6551                 if (end_tree == error_mark_node)
6552                   {
6553                     length = error_mark_node;
6554                     break;
6555                   }
6556
6557                 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6558                                    ffecom_f2c_ftnlen_one_node,
6559                                    ffecom_2 (MINUS_EXPR,
6560                                              ffecom_f2c_ftnlen_type_node,
6561                                              end_tree, start_tree));
6562               }
6563           }
6564       }
6565       break;
6566
6567     case FFEBLD_opCONCATENATE:
6568       length
6569         = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6570                     ffecom_intrinsic_len_ (ffebld_left (expr)),
6571                     ffecom_intrinsic_len_ (ffebld_right (expr)));
6572       break;
6573
6574     case FFEBLD_opFUNCREF:
6575     case FFEBLD_opCONVERT:
6576       length = build_int_2 (ffebld_size (expr), 0);
6577       TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6578       break;
6579
6580     default:
6581       assert ("bad op for single char arg expr" == NULL);
6582       length = ffecom_f2c_ftnlen_zero_node;
6583       break;
6584     }
6585
6586   assert (length != NULL_TREE);
6587
6588   return length;
6589 }
6590
6591 /* Handle CHARACTER assignments.
6592
6593    Generates code to do the assignment.  Used by ordinary assignment
6594    statement handler ffecom_let_stmt and by statement-function
6595    handler to generate code for a statement function.  */
6596
6597 static void
6598 ffecom_let_char_ (tree dest_tree, tree dest_length,
6599                   ffetargetCharacterSize dest_size, ffebld source)
6600 {
6601   ffecomConcatList_ catlist;
6602   tree source_length;
6603   tree source_tree;
6604   tree expr_tree;
6605
6606   if ((dest_tree == error_mark_node)
6607       || (dest_length == error_mark_node))
6608     return;
6609
6610   assert (dest_tree != NULL_TREE);
6611   assert (dest_length != NULL_TREE);
6612
6613   /* Source might be an opCONVERT, which just means it is a different size
6614      than the destination.  Since the underlying implementation here handles
6615      that (directly or via the s_copy or s_cat run-time-library functions),
6616      we don't need the "convenience" of an opCONVERT that tells us to
6617      truncate or blank-pad, particularly since the resulting implementation
6618      would probably be slower than otherwise. */
6619
6620   while (ffebld_op (source) == FFEBLD_opCONVERT)
6621     source = ffebld_left (source);
6622
6623   catlist = ffecom_concat_list_new_ (source, dest_size);
6624   switch (ffecom_concat_list_count_ (catlist))
6625     {
6626     case 0:                     /* Shouldn't happen, but in case it does... */
6627       ffecom_concat_list_kill_ (catlist);
6628       source_tree = null_pointer_node;
6629       source_length = ffecom_f2c_ftnlen_zero_node;
6630       expr_tree = build_tree_list (NULL_TREE, dest_tree);
6631       TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6632       TREE_CHAIN (TREE_CHAIN (expr_tree))
6633         = build_tree_list (NULL_TREE, dest_length);
6634       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6635         = build_tree_list (NULL_TREE, source_length);
6636
6637       expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6638       TREE_SIDE_EFFECTS (expr_tree) = 1;
6639
6640       expand_expr_stmt (expr_tree);
6641
6642       return;
6643
6644     case 1:                     /* The (fairly) easy case. */
6645       ffecom_char_args_ (&source_tree, &source_length,
6646                          ffecom_concat_list_expr_ (catlist, 0));
6647       ffecom_concat_list_kill_ (catlist);
6648       assert (source_tree != NULL_TREE);
6649       assert (source_length != NULL_TREE);
6650
6651       if ((source_tree == error_mark_node)
6652           || (source_length == error_mark_node))
6653         return;
6654
6655       if (dest_size == 1)
6656         {
6657           dest_tree
6658             = ffecom_1 (INDIRECT_REF,
6659                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6660                                                       (dest_tree))),
6661                         dest_tree);
6662           dest_tree
6663             = ffecom_2 (ARRAY_REF,
6664                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6665                                                       (dest_tree))),
6666                         dest_tree,
6667                         integer_one_node);
6668           source_tree
6669             = ffecom_1 (INDIRECT_REF,
6670                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6671                                                       (source_tree))),
6672                         source_tree);
6673           source_tree
6674             = ffecom_2 (ARRAY_REF,
6675                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6676                                                       (source_tree))),
6677                         source_tree,
6678                         integer_one_node);
6679
6680           expr_tree = ffecom_modify (void_type_node, dest_tree, source_tree);
6681
6682           expand_expr_stmt (expr_tree);
6683
6684           return;
6685         }
6686
6687       expr_tree = build_tree_list (NULL_TREE, dest_tree);
6688       TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6689       TREE_CHAIN (TREE_CHAIN (expr_tree))
6690         = build_tree_list (NULL_TREE, dest_length);
6691       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6692         = build_tree_list (NULL_TREE, source_length);
6693
6694       expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6695       TREE_SIDE_EFFECTS (expr_tree) = 1;
6696
6697       expand_expr_stmt (expr_tree);
6698
6699       return;
6700
6701     default:                    /* Must actually concatenate things. */
6702       break;
6703     }
6704
6705   /* Heavy-duty concatenation. */
6706
6707   {
6708     int count = ffecom_concat_list_count_ (catlist);
6709     int i;
6710     tree lengths;
6711     tree items;
6712     tree length_array;
6713     tree item_array;
6714     tree citem;
6715     tree clength;
6716
6717 #ifdef HOHO
6718     length_array
6719       = lengths
6720       = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
6721                              FFETARGET_charactersizeNONE, count, TRUE);
6722     item_array = items = ffecom_push_tempvar (ffecom_f2c_address_type_node,
6723                                               FFETARGET_charactersizeNONE,
6724                                               count, TRUE);
6725 #else
6726     {
6727       tree hook;
6728
6729       hook = ffebld_nonter_hook (source);
6730       assert (hook);
6731       assert (TREE_CODE (hook) == TREE_VEC);
6732       assert (TREE_VEC_LENGTH (hook) == 2);
6733       length_array = lengths = TREE_VEC_ELT (hook, 0);
6734       item_array = items = TREE_VEC_ELT (hook, 1);
6735     }
6736 #endif
6737
6738     for (i = 0; i < count; ++i)
6739       {
6740         ffecom_char_args_ (&citem, &clength,
6741                            ffecom_concat_list_expr_ (catlist, i));
6742         if ((citem == error_mark_node)
6743             || (clength == error_mark_node))
6744           {
6745             ffecom_concat_list_kill_ (catlist);
6746             return;
6747           }
6748
6749         items
6750           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
6751                       ffecom_modify (void_type_node,
6752                                      ffecom_2 (ARRAY_REF,
6753                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
6754                                                item_array,
6755                                                build_int_2 (i, 0)),
6756                                      citem),
6757                       items);
6758         lengths
6759           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
6760                       ffecom_modify (void_type_node,
6761                                      ffecom_2 (ARRAY_REF,
6762                    TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
6763                                                length_array,
6764                                                build_int_2 (i, 0)),
6765                                      clength),
6766                       lengths);
6767       }
6768
6769     expr_tree = build_tree_list (NULL_TREE, dest_tree);
6770     TREE_CHAIN (expr_tree)
6771       = build_tree_list (NULL_TREE,
6772                          ffecom_1 (ADDR_EXPR,
6773                                    build_pointer_type (TREE_TYPE (items)),
6774                                    items));
6775     TREE_CHAIN (TREE_CHAIN (expr_tree))
6776       = build_tree_list (NULL_TREE,
6777                          ffecom_1 (ADDR_EXPR,
6778                                    build_pointer_type (TREE_TYPE (lengths)),
6779                                    lengths));
6780     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6781       = build_tree_list
6782         (NULL_TREE,
6783          ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
6784                    convert (ffecom_f2c_ftnlen_type_node,
6785                             build_int_2 (count, 0))));
6786     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree))))
6787       = build_tree_list (NULL_TREE, dest_length);
6788
6789     expr_tree = ffecom_call_gfrt (FFECOM_gfrtCAT, expr_tree, NULL_TREE);
6790     TREE_SIDE_EFFECTS (expr_tree) = 1;
6791
6792     expand_expr_stmt (expr_tree);
6793   }
6794
6795   ffecom_concat_list_kill_ (catlist);
6796 }
6797
6798 /* ffecom_make_gfrt_ -- Make initial info for run-time routine
6799
6800    ffecomGfrt ix;
6801    ffecom_make_gfrt_(ix);
6802
6803    Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL
6804    for the indicated run-time routine (ix).  */
6805
6806 static void
6807 ffecom_make_gfrt_ (ffecomGfrt ix)
6808 {
6809   tree t;
6810   tree ttype;
6811
6812   switch (ffecom_gfrt_type_[ix])
6813     {
6814     case FFECOM_rttypeVOID_:
6815       ttype = void_type_node;
6816       break;
6817
6818     case FFECOM_rttypeVOIDSTAR_:
6819       ttype = TREE_TYPE (null_pointer_node);    /* `void *'. */
6820       break;
6821
6822     case FFECOM_rttypeFTNINT_:
6823       ttype = ffecom_f2c_ftnint_type_node;
6824       break;
6825
6826     case FFECOM_rttypeINTEGER_:
6827       ttype = ffecom_f2c_integer_type_node;
6828       break;
6829
6830     case FFECOM_rttypeLONGINT_:
6831       ttype = ffecom_f2c_longint_type_node;
6832       break;
6833
6834     case FFECOM_rttypeLOGICAL_:
6835       ttype = ffecom_f2c_logical_type_node;
6836       break;
6837
6838     case FFECOM_rttypeREAL_F2C_:
6839       ttype = double_type_node;
6840       break;
6841
6842     case FFECOM_rttypeREAL_GNU_:
6843       ttype = float_type_node;
6844       break;
6845
6846     case FFECOM_rttypeCOMPLEX_F2C_:
6847       ttype = void_type_node;
6848       break;
6849
6850     case FFECOM_rttypeCOMPLEX_GNU_:
6851       ttype = ffecom_f2c_complex_type_node;
6852       break;
6853
6854     case FFECOM_rttypeDOUBLE_:
6855       ttype = double_type_node;
6856       break;
6857
6858     case FFECOM_rttypeDOUBLEREAL_:
6859       ttype = ffecom_f2c_doublereal_type_node;
6860       break;
6861
6862     case FFECOM_rttypeDBLCMPLX_F2C_:
6863       ttype = void_type_node;
6864       break;
6865
6866     case FFECOM_rttypeDBLCMPLX_GNU_:
6867       ttype = ffecom_f2c_doublecomplex_type_node;
6868       break;
6869
6870     case FFECOM_rttypeCHARACTER_:
6871       ttype = void_type_node;
6872       break;
6873
6874     default:
6875       ttype = NULL;
6876       assert ("bad rttype" == NULL);
6877       break;
6878     }
6879
6880   ttype = build_function_type (ttype, NULL_TREE);
6881   t = build_decl (FUNCTION_DECL,
6882                   get_identifier (ffecom_gfrt_name_[ix]),
6883                   ttype);
6884   DECL_EXTERNAL (t) = 1;
6885   TREE_READONLY (t) = ffecom_gfrt_const_[ix] ? 1 : 0;
6886   TREE_PUBLIC (t) = 1;
6887   TREE_THIS_VOLATILE (t) = ffecom_gfrt_volatile_[ix] ? 1 : 0;
6888
6889   /* Sanity check:  A function that's const cannot be volatile.  */
6890
6891   assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_volatile_[ix] : 1);
6892
6893   /* Sanity check: A function that's const cannot return complex.  */
6894
6895   assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_complex_[ix] : 1);
6896
6897   t = start_decl (t, TRUE);
6898
6899   finish_decl (t, NULL_TREE, TRUE);
6900
6901   ffecom_gfrt_[ix] = t;
6902 }
6903
6904 /* Phase 1 pass over each member of a COMMON/EQUIVALENCE group.  */
6905
6906 static void
6907 ffecom_member_phase1_ (ffestorag mst UNUSED, ffestorag st)
6908 {
6909   ffesymbol s = ffestorag_symbol (st);
6910
6911   if (ffesymbol_namelisted (s))
6912     ffecom_member_namelisted_ = TRUE;
6913 }
6914
6915 /* Phase 2 pass over each member of a COMMON/EQUIVALENCE group.  Declare
6916    the member so debugger will see it.  Otherwise nobody should be
6917    referencing the member.  */
6918
6919 static void
6920 ffecom_member_phase2_ (ffestorag mst, ffestorag st)
6921 {
6922   ffesymbol s;
6923   tree t;
6924   tree mt;
6925   tree type;
6926
6927   if ((mst == NULL)
6928       || ((mt = ffestorag_hook (mst)) == NULL)
6929       || (mt == error_mark_node))
6930     return;
6931
6932   if ((st == NULL)
6933       || ((s = ffestorag_symbol (st)) == NULL))
6934     return;
6935
6936   type = ffecom_type_localvar_ (s,
6937                                 ffesymbol_basictype (s),
6938                                 ffesymbol_kindtype (s));
6939   if (type == error_mark_node)
6940     return;
6941
6942   t = build_decl (VAR_DECL,
6943                   ffecom_get_identifier_ (ffesymbol_text (s)),
6944                   type);
6945
6946   TREE_STATIC (t) = TREE_STATIC (mt);
6947   DECL_INITIAL (t) = NULL_TREE;
6948   TREE_ASM_WRITTEN (t) = 1;
6949   TREE_USED (t) = 1;
6950
6951   SET_DECL_RTL (t,
6952                 gen_rtx (MEM, TYPE_MODE (type),
6953                          plus_constant (XEXP (DECL_RTL (mt), 0),
6954                                         ffestorag_modulo (mst)
6955                                         + ffestorag_offset (st)
6956                                         - ffestorag_offset (mst))));
6957
6958   t = start_decl (t, FALSE);
6959
6960   finish_decl (t, NULL_TREE, FALSE);
6961 }
6962
6963 /* Prepare source expression for assignment into a destination perhaps known
6964    to be of a specific size.  */
6965
6966 static void
6967 ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size, ffebld source)
6968 {
6969   ffecomConcatList_ catlist;
6970   int count;
6971   int i;
6972   tree ltmp;
6973   tree itmp;
6974   tree tempvar = NULL_TREE;
6975
6976   while (ffebld_op (source) == FFEBLD_opCONVERT)
6977     source = ffebld_left (source);
6978
6979   catlist = ffecom_concat_list_new_ (source, dest_size);
6980   count = ffecom_concat_list_count_ (catlist);
6981
6982   if (count >= 2)
6983     {
6984       ltmp
6985         = ffecom_make_tempvar ("let_char_len", ffecom_f2c_ftnlen_type_node,
6986                                FFETARGET_charactersizeNONE, count);
6987       itmp
6988         = ffecom_make_tempvar ("let_char_item", ffecom_f2c_address_type_node,
6989                                FFETARGET_charactersizeNONE, count);
6990
6991       tempvar = make_tree_vec (2);
6992       TREE_VEC_ELT (tempvar, 0) = ltmp;
6993       TREE_VEC_ELT (tempvar, 1) = itmp;
6994     }
6995
6996   for (i = 0; i < count; ++i)
6997     ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist, i));
6998
6999   ffecom_concat_list_kill_ (catlist);
7000
7001   if (tempvar)
7002     {
7003       ffebld_nonter_set_hook (source, tempvar);
7004       current_binding_level->prep_state = 1;
7005     }
7006 }
7007
7008 /* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order
7009
7010    Ignores STAR (alternate-return) dummies.  All other get exec-transitioned
7011    (which generates their trees) and then their trees get push_parm_decl'd.
7012
7013    The second arg is TRUE if the dummies are for a statement function, in
7014    which case lengths are not pushed for character arguments (since they are
7015    always known by both the caller and the callee, though the code allows
7016    for someday permitting CHAR*(*) stmtfunc dummies).  */
7017
7018 static void
7019 ffecom_push_dummy_decls_ (ffebld dummy_list, bool stmtfunc)
7020 {
7021   ffebld dummy;
7022   ffebld dumlist;
7023   ffesymbol s;
7024   tree parm;
7025
7026   ffecom_transform_only_dummies_ = TRUE;
7027
7028   /* First push the parms corresponding to actual dummy "contents".  */
7029
7030   for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7031     {
7032       dummy = ffebld_head (dumlist);
7033       switch (ffebld_op (dummy))
7034         {
7035         case FFEBLD_opSTAR:
7036         case FFEBLD_opANY:
7037           continue;             /* Forget alternate returns. */
7038
7039         default:
7040           break;
7041         }
7042       assert (ffebld_op (dummy) == FFEBLD_opSYMTER);
7043       s = ffebld_symter (dummy);
7044       parm = ffesymbol_hook (s).decl_tree;
7045       if (parm == NULL_TREE)
7046         {
7047           s = ffecom_sym_transform_ (s);
7048           parm = ffesymbol_hook (s).decl_tree;
7049           assert (parm != NULL_TREE);
7050         }
7051       if (parm != error_mark_node)
7052         push_parm_decl (parm);
7053     }
7054
7055   /* Then, for CHARACTER dummies, push the parms giving their lengths.  */
7056
7057   for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7058     {
7059       dummy = ffebld_head (dumlist);
7060       switch (ffebld_op (dummy))
7061         {
7062         case FFEBLD_opSTAR:
7063         case FFEBLD_opANY:
7064           continue;             /* Forget alternate returns, they mean
7065                                    NOTHING! */
7066
7067         default:
7068           break;
7069         }
7070       s = ffebld_symter (dummy);
7071       if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
7072         continue;               /* Only looking for CHARACTER arguments. */
7073       if (stmtfunc && (ffesymbol_size (s) != FFETARGET_charactersizeNONE))
7074         continue;               /* Stmtfunc arg with known size needs no
7075                                    length param. */
7076       if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
7077         continue;               /* Only looking for variables and arrays. */
7078       parm = ffesymbol_hook (s).length_tree;
7079       assert (parm != NULL_TREE);
7080       if (parm != error_mark_node)
7081         push_parm_decl (parm);
7082     }
7083
7084   ffecom_transform_only_dummies_ = FALSE;
7085 }
7086
7087 /* ffecom_start_progunit_ -- Beginning of program unit
7088
7089    Does GNU back end stuff necessary to teach it about the start of its
7090    equivalent of a Fortran program unit.  */
7091
7092 static void
7093 ffecom_start_progunit_ ()
7094 {
7095   ffesymbol fn = ffecom_primary_entry_;
7096   ffebld arglist;
7097   tree id;                      /* Identifier (name) of function. */
7098   tree type;                    /* Type of function. */
7099   tree result;                  /* Result of function. */
7100   ffeinfoBasictype bt;
7101   ffeinfoKindtype kt;
7102   ffeglobal g;
7103   ffeglobalType gt;
7104   ffeglobalType egt = FFEGLOBAL_type;
7105   bool charfunc;
7106   bool cmplxfunc;
7107   bool altentries = (ffecom_num_entrypoints_ != 0);
7108   bool multi
7109   = altentries
7110   && (ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
7111   && (ffecom_master_bt_ == FFEINFO_basictypeNONE);
7112   bool main_program = FALSE;
7113   int old_lineno = lineno;
7114   const char *old_input_filename = input_filename;
7115
7116   assert (fn != NULL);
7117   assert (ffesymbol_hook (fn).decl_tree == NULL_TREE);
7118
7119   input_filename = ffesymbol_where_filename (fn);
7120   lineno = ffesymbol_where_filelinenum (fn);
7121
7122   switch (ffecom_primary_entry_kind_)
7123     {
7124     case FFEINFO_kindPROGRAM:
7125       main_program = TRUE;
7126       gt = FFEGLOBAL_typeMAIN;
7127       bt = FFEINFO_basictypeNONE;
7128       kt = FFEINFO_kindtypeNONE;
7129       type = ffecom_tree_fun_type_void;
7130       charfunc = FALSE;
7131       cmplxfunc = FALSE;
7132       break;
7133
7134     case FFEINFO_kindBLOCKDATA:
7135       gt = FFEGLOBAL_typeBDATA;
7136       bt = FFEINFO_basictypeNONE;
7137       kt = FFEINFO_kindtypeNONE;
7138       type = ffecom_tree_fun_type_void;
7139       charfunc = FALSE;
7140       cmplxfunc = FALSE;
7141       break;
7142
7143     case FFEINFO_kindFUNCTION:
7144       gt = FFEGLOBAL_typeFUNC;
7145       egt = FFEGLOBAL_typeEXT;
7146       bt = ffesymbol_basictype (fn);
7147       kt = ffesymbol_kindtype (fn);
7148       if (bt == FFEINFO_basictypeNONE)
7149         {
7150           ffeimplic_establish_symbol (fn);
7151           if (ffesymbol_funcresult (fn) != NULL)
7152             ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
7153           bt = ffesymbol_basictype (fn);
7154           kt = ffesymbol_kindtype (fn);
7155         }
7156
7157       if (multi)
7158         charfunc = cmplxfunc = FALSE;
7159       else if (bt == FFEINFO_basictypeCHARACTER)
7160         charfunc = TRUE, cmplxfunc = FALSE;
7161       else if ((bt == FFEINFO_basictypeCOMPLEX)
7162                && ffesymbol_is_f2c (fn)
7163                && !altentries)
7164         charfunc = FALSE, cmplxfunc = TRUE;
7165       else
7166         charfunc = cmplxfunc = FALSE;
7167
7168       if (multi || charfunc)
7169         type = ffecom_tree_fun_type_void;
7170       else if (ffesymbol_is_f2c (fn) && !altentries)
7171         type = ffecom_tree_fun_type[bt][kt];
7172       else
7173         type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
7174
7175       if ((type == NULL_TREE)
7176           || (TREE_TYPE (type) == NULL_TREE))
7177         type = ffecom_tree_fun_type_void;       /* _sym_exec_transition. */
7178       break;
7179
7180     case FFEINFO_kindSUBROUTINE:
7181       gt = FFEGLOBAL_typeSUBR;
7182       egt = FFEGLOBAL_typeEXT;
7183       bt = FFEINFO_basictypeNONE;
7184       kt = FFEINFO_kindtypeNONE;
7185       if (ffecom_is_altreturning_)
7186         type = ffecom_tree_subr_type;
7187       else
7188         type = ffecom_tree_fun_type_void;
7189       charfunc = FALSE;
7190       cmplxfunc = FALSE;
7191       break;
7192
7193     default:
7194       assert ("say what??" == NULL);
7195       /* Fall through. */
7196     case FFEINFO_kindANY:
7197       gt = FFEGLOBAL_typeANY;
7198       bt = FFEINFO_basictypeNONE;
7199       kt = FFEINFO_kindtypeNONE;
7200       type = error_mark_node;
7201       charfunc = FALSE;
7202       cmplxfunc = FALSE;
7203       break;
7204     }
7205
7206   if (altentries)
7207     {
7208       id = ffecom_get_invented_identifier ("__g77_masterfun_%s",
7209                                            ffesymbol_text (fn));
7210     }
7211 #if FFETARGET_isENFORCED_MAIN
7212   else if (main_program)
7213     id = get_identifier (FFETARGET_nameENFORCED_MAIN_NAME);
7214 #endif
7215   else
7216     id = ffecom_get_external_identifier_ (fn);
7217
7218   start_function (id,
7219                   type,
7220                   0,            /* nested/inline */
7221                   !altentries); /* TREE_PUBLIC */
7222
7223   TREE_USED (current_function_decl) = 1;        /* Avoid spurious warning if altentries. */
7224
7225   if (!altentries
7226       && ((g = ffesymbol_global (fn)) != NULL)
7227       && ((ffeglobal_type (g) == gt)
7228           || (ffeglobal_type (g) == egt)))
7229     {
7230       ffeglobal_set_hook (g, current_function_decl);
7231     }
7232
7233   /* Arg handling needs exec-transitioned ffesymbols to work with.  But
7234      exec-transitioning needs current_function_decl to be filled in.  So we
7235      do these things in two phases. */
7236
7237   if (altentries)
7238     {                           /* 1st arg identifies which entrypoint. */
7239       ffecom_which_entrypoint_decl_
7240         = build_decl (PARM_DECL,
7241                       ffecom_get_invented_identifier ("__g77_%s",
7242                                                       "which_entrypoint"),
7243                       integer_type_node);
7244       push_parm_decl (ffecom_which_entrypoint_decl_);
7245     }
7246
7247   if (charfunc
7248       || cmplxfunc
7249       || multi)
7250     {                           /* Arg for result (return value). */
7251       tree type;
7252       tree length;
7253
7254       if (charfunc)
7255         type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
7256       else if (cmplxfunc)
7257         type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
7258       else
7259         type = ffecom_multi_type_node_;
7260
7261       result = ffecom_get_invented_identifier ("__g77_%s", "result");
7262
7263       /* Make length arg _and_ enhance type info for CHAR arg itself.  */
7264
7265       if (charfunc)
7266         length = ffecom_char_enhance_arg_ (&type, fn);
7267       else
7268         length = NULL_TREE;     /* Not ref'd if !charfunc. */
7269
7270       type = build_pointer_type (type);
7271       result = build_decl (PARM_DECL, result, type);
7272
7273       push_parm_decl (result);
7274       if (multi)
7275         ffecom_multi_retval_ = result;
7276       else
7277         ffecom_func_result_ = result;
7278
7279       if (charfunc)
7280         {
7281           push_parm_decl (length);
7282           ffecom_func_length_ = length;
7283         }
7284     }
7285
7286   if (ffecom_primary_entry_is_proc_)
7287     {
7288       if (altentries)
7289         arglist = ffecom_master_arglist_;
7290       else
7291         arglist = ffesymbol_dummyargs (fn);
7292       ffecom_push_dummy_decls_ (arglist, FALSE);
7293     }
7294
7295   if (TREE_CODE (current_function_decl) != ERROR_MARK)
7296     store_parm_decls (main_program ? 1 : 0);
7297
7298   ffecom_start_compstmt ();
7299   /* Disallow temp vars at this level.  */
7300   current_binding_level->prep_state = 2;
7301
7302   lineno = old_lineno;
7303   input_filename = old_input_filename;
7304
7305   /* This handles any symbols still untransformed, in case -g specified.
7306      This used to be done in ffecom_finish_progunit, but it turns out to
7307      be necessary to do it here so that statement functions are
7308      expanded before code.  But don't bother for BLOCK DATA.  */
7309
7310   if (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
7311     ffesymbol_drive (ffecom_finish_symbol_transform_);
7312 }
7313
7314 /* ffecom_sym_transform_ -- Transform FFE sym into backend sym
7315
7316    ffesymbol s;
7317    ffecom_sym_transform_(s);
7318
7319    The ffesymbol_hook info for s is updated with appropriate backend info
7320    on the symbol.  */
7321
7322 static ffesymbol
7323 ffecom_sym_transform_ (ffesymbol s)
7324 {
7325   tree t;                       /* Transformed thingy. */
7326   tree tlen;                    /* Length if CHAR*(*). */
7327   bool addr;                    /* Is t the address of the thingy? */
7328   ffeinfoBasictype bt;
7329   ffeinfoKindtype kt;
7330   ffeglobal g;
7331   int old_lineno = lineno;
7332   const char *old_input_filename = input_filename;
7333
7334   /* Must ensure special ASSIGN variables are declared at top of outermost
7335      block, else they'll end up in the innermost block when their first
7336      ASSIGN is seen, which leaves them out of scope when they're the
7337      subject of a GOTO or I/O statement.
7338
7339      We make this variable even if -fugly-assign.  Just let it go unused,
7340      in case it turns out there are cases where we really want to use this
7341      variable anyway (e.g. ASSIGN to INTEGER*2 variable).  */
7342
7343   if (! ffecom_transform_only_dummies_
7344       && ffesymbol_assigned (s)
7345       && ! ffesymbol_hook (s).assign_tree)
7346     s = ffecom_sym_transform_assign_ (s);
7347
7348   if (ffesymbol_sfdummyparent (s) == NULL)
7349     {
7350       input_filename = ffesymbol_where_filename (s);
7351       lineno = ffesymbol_where_filelinenum (s);
7352     }
7353   else
7354     {
7355       ffesymbol sf = ffesymbol_sfdummyparent (s);
7356
7357       input_filename = ffesymbol_where_filename (sf);
7358       lineno = ffesymbol_where_filelinenum (sf);
7359     }
7360
7361   bt = ffeinfo_basictype (ffebld_info (s));
7362   kt = ffeinfo_kindtype (ffebld_info (s));
7363
7364   t = NULL_TREE;
7365   tlen = NULL_TREE;
7366   addr = FALSE;
7367
7368   switch (ffesymbol_kind (s))
7369     {
7370     case FFEINFO_kindNONE:
7371       switch (ffesymbol_where (s))
7372         {
7373         case FFEINFO_whereDUMMY:        /* Subroutine or function. */
7374           assert (ffecom_transform_only_dummies_);
7375
7376           /* Before 0.4, this could be ENTITY/DUMMY, but see
7377              ffestu_sym_end_transition -- no longer true (in particular, if
7378              it could be an ENTITY, it _will_ be made one, so that
7379              possibility won't come through here).  So we never make length
7380              arg for CHARACTER type.  */
7381
7382           t = build_decl (PARM_DECL,
7383                           ffecom_get_identifier_ (ffesymbol_text (s)),
7384                           ffecom_tree_ptr_to_subr_type);
7385           DECL_ARTIFICIAL (t) = 1;
7386           addr = TRUE;
7387           break;
7388
7389         case FFEINFO_whereGLOBAL:       /* Subroutine or function. */
7390           assert (!ffecom_transform_only_dummies_);
7391
7392           if (((g = ffesymbol_global (s)) != NULL)
7393               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7394                   || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7395                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
7396               && (ffeglobal_hook (g) != NULL_TREE)
7397               && ffe_is_globals ())
7398             {
7399               t = ffeglobal_hook (g);
7400               break;
7401             }
7402
7403           t = build_decl (FUNCTION_DECL,
7404                           ffecom_get_external_identifier_ (s),
7405                           ffecom_tree_subr_type);       /* Assume subr. */
7406           DECL_EXTERNAL (t) = 1;
7407           TREE_PUBLIC (t) = 1;
7408
7409           t = start_decl (t, FALSE);
7410           finish_decl (t, NULL_TREE, FALSE);
7411
7412           if ((g != NULL)
7413               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7414                   || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7415                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
7416             ffeglobal_set_hook (g, t);
7417
7418           ffecom_save_tree_forever (t);
7419
7420           break;
7421
7422         default:
7423           assert ("NONE where unexpected" == NULL);
7424           /* Fall through. */
7425         case FFEINFO_whereANY:
7426           break;
7427         }
7428       break;
7429
7430     case FFEINFO_kindENTITY:
7431       switch (ffeinfo_where (ffesymbol_info (s)))
7432         {
7433
7434         case FFEINFO_whereCONSTANT:
7435           /* ~~Debugging info needed? */
7436           assert (!ffecom_transform_only_dummies_);
7437           t = error_mark_node;  /* Shouldn't ever see this in expr. */
7438           break;
7439
7440         case FFEINFO_whereLOCAL:
7441           assert (!ffecom_transform_only_dummies_);
7442
7443           {
7444             ffestorag st = ffesymbol_storage (s);
7445             tree type;
7446
7447             if ((st != NULL)
7448                 && (ffestorag_size (st) == 0))
7449               {
7450                 t = error_mark_node;
7451                 break;
7452               }
7453
7454             type = ffecom_type_localvar_ (s, bt, kt);
7455
7456             if (type == error_mark_node)
7457               {
7458                 t = error_mark_node;
7459                 break;
7460               }
7461
7462             if ((st != NULL)
7463                 && (ffestorag_parent (st) != NULL))
7464               {                 /* Child of EQUIVALENCE parent. */
7465                 ffestorag est;
7466                 tree et;
7467                 ffetargetOffset offset;
7468
7469                 est = ffestorag_parent (st);
7470                 ffecom_transform_equiv_ (est);
7471
7472                 et = ffestorag_hook (est);
7473                 assert (et != NULL_TREE);
7474
7475                 if (! TREE_STATIC (et))
7476                   put_var_into_stack (et);
7477
7478                 offset = ffestorag_modulo (est)
7479                   + ffestorag_offset (ffesymbol_storage (s))
7480                   - ffestorag_offset (est);
7481
7482                 ffecom_debug_kludge_ (et, "EQUIVALENCE", s, type, offset);
7483
7484                 /* (t_type *) (((char *) &et) + offset) */
7485
7486                 t = convert (string_type_node,  /* (char *) */
7487                              ffecom_1 (ADDR_EXPR,
7488                                        build_pointer_type (TREE_TYPE (et)),
7489                                        et));
7490                 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
7491                               t,
7492                               build_int_2 (offset, 0));
7493                 t = convert (build_pointer_type (type),
7494                              t);
7495                 TREE_CONSTANT (t) = staticp (et);
7496
7497                 addr = TRUE;
7498               }
7499             else
7500               {
7501                 tree initexpr;
7502                 bool init = ffesymbol_is_init (s);
7503
7504                 t = build_decl (VAR_DECL,
7505                                 ffecom_get_identifier_ (ffesymbol_text (s)),
7506                                 type);
7507
7508                 if (init
7509                     || ffesymbol_namelisted (s)
7510 #ifdef FFECOM_sizeMAXSTACKITEM
7511                     || ((st != NULL)
7512                         && (ffestorag_size (st) > FFECOM_sizeMAXSTACKITEM))
7513 #endif
7514                     || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
7515                         && (ffecom_primary_entry_kind_
7516                             != FFEINFO_kindBLOCKDATA)
7517                         && (ffesymbol_is_save (s) || ffe_is_saveall ())))
7518                   TREE_STATIC (t) = !ffesymbol_attr (s, FFESYMBOL_attrADJUSTABLE);
7519                 else
7520                   TREE_STATIC (t) = 0;  /* No need to make static. */
7521
7522                 if (init || ffe_is_init_local_zero ())
7523                   DECL_INITIAL (t) = error_mark_node;
7524
7525                 /* Keep -Wunused from complaining about var if it
7526                    is used as sfunc arg or DATA implied-DO.  */
7527                 if (ffesymbol_attrs (s) & FFESYMBOL_attrsSFARG)
7528                   DECL_IN_SYSTEM_HEADER (t) = 1;
7529
7530                 t = start_decl (t, FALSE);
7531
7532                 if (init)
7533                   {
7534                     if (ffesymbol_init (s) != NULL)
7535                       initexpr = ffecom_expr (ffesymbol_init (s));
7536                     else
7537                       initexpr = ffecom_init_zero_ (t);
7538                   }
7539                 else if (ffe_is_init_local_zero ())
7540                   initexpr = ffecom_init_zero_ (t);
7541                 else
7542                   initexpr = NULL_TREE; /* Not ref'd if !init. */
7543
7544                 finish_decl (t, initexpr, FALSE);
7545
7546                 if (st != NULL && DECL_SIZE (t) != error_mark_node)
7547                   {
7548                     assert (TREE_CODE (DECL_SIZE_UNIT (t)) == INTEGER_CST);
7549                     assert (0 == compare_tree_int (DECL_SIZE_UNIT (t),
7550                                                    ffestorag_size (st)));
7551                   }
7552               }
7553           }
7554           break;
7555
7556         case FFEINFO_whereRESULT:
7557           assert (!ffecom_transform_only_dummies_);
7558
7559           if (bt == FFEINFO_basictypeCHARACTER)
7560             {                   /* Result is already in list of dummies, use
7561                                    it (& length). */
7562               t = ffecom_func_result_;
7563               tlen = ffecom_func_length_;
7564               addr = TRUE;
7565               break;
7566             }
7567           if ((ffecom_num_entrypoints_ == 0)
7568               && (bt == FFEINFO_basictypeCOMPLEX)
7569               && (ffesymbol_is_f2c (ffecom_primary_entry_)))
7570             {                   /* Result is already in list of dummies, use
7571                                    it. */
7572               t = ffecom_func_result_;
7573               addr = TRUE;
7574               break;
7575             }
7576           if (ffecom_func_result_ != NULL_TREE)
7577             {
7578               t = ffecom_func_result_;
7579               break;
7580             }
7581           if ((ffecom_num_entrypoints_ != 0)
7582               && (ffecom_master_bt_ == FFEINFO_basictypeNONE))
7583             {
7584               assert (ffecom_multi_retval_ != NULL_TREE);
7585               t = ffecom_1 (INDIRECT_REF, ffecom_multi_type_node_,
7586                             ffecom_multi_retval_);
7587               t = ffecom_2 (COMPONENT_REF, ffecom_tree_type[bt][kt],
7588                             t, ffecom_multi_fields_[bt][kt]);
7589
7590               break;
7591             }
7592
7593           t = build_decl (VAR_DECL,
7594                           ffecom_get_identifier_ (ffesymbol_text (s)),
7595                           ffecom_tree_type[bt][kt]);
7596           TREE_STATIC (t) = 0;  /* Put result on stack. */
7597           t = start_decl (t, FALSE);
7598           finish_decl (t, NULL_TREE, FALSE);
7599
7600           ffecom_func_result_ = t;
7601
7602           break;
7603
7604         case FFEINFO_whereDUMMY:
7605           {
7606             tree type;
7607             ffebld dl;
7608             ffebld dim;
7609             tree low;
7610             tree high;
7611             tree old_sizes;
7612             bool adjustable = FALSE;    /* Conditionally adjustable? */
7613
7614             type = ffecom_tree_type[bt][kt];
7615             if (ffesymbol_sfdummyparent (s) != NULL)
7616               {
7617                 if (current_function_decl == ffecom_outer_function_decl_)
7618                   {                     /* Exec transition before sfunc
7619                                            context; get it later. */
7620                     break;
7621                   }
7622                 t = ffecom_get_identifier_ (ffesymbol_text
7623                                             (ffesymbol_sfdummyparent (s)));
7624               }
7625             else
7626               t = ffecom_get_identifier_ (ffesymbol_text (s));
7627
7628             assert (ffecom_transform_only_dummies_);
7629
7630             old_sizes = get_pending_sizes ();
7631             put_pending_sizes (old_sizes);
7632
7633             if (bt == FFEINFO_basictypeCHARACTER)
7634               tlen = ffecom_char_enhance_arg_ (&type, s);
7635             type = ffecom_check_size_overflow_ (s, type, TRUE);
7636
7637             for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
7638               {
7639                 if (type == error_mark_node)
7640                   break;
7641
7642                 dim = ffebld_head (dl);
7643                 assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
7644                 if ((ffebld_left (dim) == NULL) || ffecom_doing_entry_)
7645                   low = ffecom_integer_one_node;
7646                 else
7647                   low = ffecom_expr (ffebld_left (dim));
7648                 assert (ffebld_right (dim) != NULL);
7649                 if ((ffebld_op (ffebld_right (dim)) == FFEBLD_opSTAR)
7650                     || ffecom_doing_entry_)
7651                   {
7652                     /* Used to just do high=low.  But for ffecom_tree_
7653                        canonize_ref_, it probably is important to correctly
7654                        assess the size.  E.g. given COMPLEX C(*),CFUNC and
7655                        C(2)=CFUNC(C), overlap can happen, while it can't
7656                        for, say, C(1)=CFUNC(C(2)).  */
7657                     /* Even more recently used to set to INT_MAX, but that
7658                        broke when some overflow checking went into the back
7659                        end.  Now we just leave the upper bound unspecified.  */
7660                     high = NULL;
7661                   }
7662                 else
7663                   high = ffecom_expr (ffebld_right (dim));
7664
7665                 /* Determine whether array is conditionally adjustable,
7666                    to decide whether back-end magic is needed.
7667
7668                    Normally the front end uses the back-end function
7669                    variable_size to wrap SAVE_EXPR's around expressions
7670                    affecting the size/shape of an array so that the
7671                    size/shape info doesn't change during execution
7672                    of the compiled code even though variables and
7673                    functions referenced in those expressions might.
7674
7675                    variable_size also makes sure those saved expressions
7676                    get evaluated immediately upon entry to the
7677                    compiled procedure -- the front end normally doesn't
7678                    have to worry about that.
7679
7680                    However, there is a problem with this that affects
7681                    g77's implementation of entry points, and that is
7682                    that it is _not_ true that each invocation of the
7683                    compiled procedure is permitted to evaluate
7684                    array size/shape info -- because it is possible
7685                    that, for some invocations, that info is invalid (in
7686                    which case it is "promised" -- i.e. a violation of
7687                    the Fortran standard -- that the compiled code
7688                    won't reference the array or its size/shape
7689                    during that particular invocation).
7690
7691                    To phrase this in C terms, consider this gcc function:
7692
7693                      void foo (int *n, float (*a)[*n])
7694                      {
7695                        // a is "pointer to array ...", fyi.
7696                      }
7697
7698                    Suppose that, for some invocations, it is permitted
7699                    for a caller of foo to do this:
7700
7701                        foo (NULL, NULL);
7702
7703                    Now the _written_ code for foo can take such a call
7704                    into account by either testing explicitly for whether
7705                    (a == NULL) || (n == NULL) -- presumably it is
7706                    not permitted to reference *a in various fashions
7707                    if (n == NULL) I suppose -- or it can avoid it by
7708                    looking at other info (other arguments, static/global
7709                    data, etc.).
7710
7711                    However, this won't work in gcc 2.5.8 because it'll
7712                    automatically emit the code to save the "*n"
7713                    expression, which'll yield a NULL dereference for
7714                    the "foo (NULL, NULL)" call, something the code
7715                    for foo cannot prevent.
7716
7717                    g77 definitely needs to avoid executing such
7718                    code anytime the pointer to the adjustable array
7719                    is NULL, because even if its bounds expressions
7720                    don't have any references to possible "absent"
7721                    variables like "*n" -- say all variable references
7722                    are to COMMON variables, i.e. global (though in C,
7723                    local static could actually make sense) -- the
7724                    expressions could yield other run-time problems
7725                    for allowably "dead" values in those variables.
7726
7727                    For example, let's consider a more complicated
7728                    version of foo:
7729
7730                      extern int i;
7731                      extern int j;
7732
7733                      void foo (float (*a)[i/j])
7734                      {
7735                        ...
7736                      }
7737
7738                    The above is (essentially) quite valid for Fortran
7739                    but, again, for a call like "foo (NULL);", it is
7740                    permitted for i and j to be undefined when the
7741                    call is made.  If j happened to be zero, for
7742                    example, emitting the code to evaluate "i/j"
7743                    could result in a run-time error.
7744
7745                    Offhand, though I don't have my F77 or F90
7746                    standards handy, it might even be valid for a
7747                    bounds expression to contain a function reference,
7748                    in which case I doubt it is permitted for an
7749                    implementation to invoke that function in the
7750                    Fortran case involved here (invocation of an
7751                    alternate ENTRY point that doesn't have the adjustable
7752                    array as one of its arguments).
7753
7754                    So, the code that the compiler would normally emit
7755                    to preevaluate the size/shape info for an
7756                    adjustable array _must not_ be executed at run time
7757                    in certain cases.  Specifically, for Fortran,
7758                    the case is when the pointer to the adjustable
7759                    array == NULL.  (For gnu-ish C, it might be nice
7760                    for the source code itself to specify an expression
7761                    that, if TRUE, inhibits execution of the code.  Or
7762                    reverse the sense for elegance.)
7763
7764                    (Note that g77 could use a different test than NULL,
7765                    actually, since it happens to always pass an
7766                    integer to the called function that specifies which
7767                    entry point is being invoked.  Hmm, this might
7768                    solve the next problem.)
7769
7770                    One way a user could, I suppose, write "foo" so
7771                    it works is to insert COND_EXPR's for the
7772                    size/shape info so the dangerous stuff isn't
7773                    actually done, as in:
7774
7775                      void foo (int *n, float (*a)[(a == NULL) ? 0 : *n])
7776                      {
7777                        ...
7778                      }
7779
7780                    The next problem is that the front end needs to
7781                    be able to tell the back end about the array's
7782                    decl _before_ it tells it about the conditional
7783                    expression to inhibit evaluation of size/shape info,
7784                    as shown above.
7785
7786                    To solve this, the front end needs to be able
7787                    to give the back end the expression to inhibit
7788                    generation of the preevaluation code _after_
7789                    it makes the decl for the adjustable array.
7790
7791                    Until then, the above example using the COND_EXPR
7792                    doesn't pass muster with gcc because the "(a == NULL)"
7793                    part has a reference to "a", which is still
7794                    undefined at that point.
7795
7796                    g77 will therefore use a different mechanism in the
7797                    meantime.  */
7798
7799                 if (!adjustable
7800                     && ((TREE_CODE (low) != INTEGER_CST)
7801                         || (high && TREE_CODE (high) != INTEGER_CST)))
7802                   adjustable = TRUE;
7803
7804 #if 0                           /* Old approach -- see below. */
7805                 if (TREE_CODE (low) != INTEGER_CST)
7806                   low = ffecom_3 (COND_EXPR, integer_type_node,
7807                                   ffecom_adjarray_passed_ (s),
7808                                   low,
7809                                   ffecom_integer_zero_node);
7810
7811                 if (high && TREE_CODE (high) != INTEGER_CST)
7812                   high = ffecom_3 (COND_EXPR, integer_type_node,
7813                                    ffecom_adjarray_passed_ (s),
7814                                    high,
7815                                    ffecom_integer_zero_node);
7816 #endif
7817
7818                 /* ~~~gcc/stor-layout.c (layout_type) should do this,
7819                    probably.  Fixes 950302-1.f.  */
7820
7821                 if (TREE_CODE (low) != INTEGER_CST)
7822                   low = variable_size (low);
7823
7824                 /* ~~~Similarly, this fixes dumb0.f.  The C front end
7825                    does this, which is why dumb0.c would work.  */
7826
7827                 if (high && TREE_CODE (high) != INTEGER_CST)
7828                   high = variable_size (high);
7829
7830                 type
7831                   = build_array_type
7832                     (type,
7833                      build_range_type (ffecom_integer_type_node,
7834                                        low, high));
7835                 type = ffecom_check_size_overflow_ (s, type, TRUE);
7836               }
7837
7838             if (type == error_mark_node)
7839               {
7840                 t = error_mark_node;
7841                 break;
7842               }
7843
7844             if ((ffesymbol_sfdummyparent (s) == NULL)
7845                  || (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER))
7846               {
7847                 type = build_pointer_type (type);
7848                 addr = TRUE;
7849               }
7850
7851             t = build_decl (PARM_DECL, t, type);
7852             DECL_ARTIFICIAL (t) = 1;
7853
7854             /* If this arg is present in every entry point's list of
7855                dummy args, then we're done.  */
7856
7857             if (ffesymbol_numentries (s)
7858                 == (ffecom_num_entrypoints_ + 1))
7859               break;
7860
7861 #if 1
7862
7863             /* If variable_size in stor-layout has been called during
7864                the above, then get_pending_sizes should have the
7865                yet-to-be-evaluated saved expressions pending.
7866                Make the whole lot of them get emitted, conditionally
7867                on whether the array decl ("t" above) is not NULL.  */
7868
7869             {
7870               tree sizes = get_pending_sizes ();
7871               tree tem;
7872
7873               for (tem = sizes;
7874                    tem != old_sizes;
7875                    tem = TREE_CHAIN (tem))
7876                 {
7877                   tree temv = TREE_VALUE (tem);
7878
7879                   if (sizes == tem)
7880                     sizes = temv;
7881                   else
7882                     sizes
7883                       = ffecom_2 (COMPOUND_EXPR,
7884                                   TREE_TYPE (sizes),
7885                                   temv,
7886                                   sizes);
7887                 }
7888
7889               if (sizes != tem)
7890                 {
7891                   sizes
7892                     = ffecom_3 (COND_EXPR,
7893                                 TREE_TYPE (sizes),
7894                                 ffecom_2 (NE_EXPR,
7895                                           integer_type_node,
7896                                           t,
7897                                           null_pointer_node),
7898                                 sizes,
7899                                 convert (TREE_TYPE (sizes),
7900                                          integer_zero_node));
7901                   sizes = ffecom_save_tree (sizes);
7902
7903                   sizes
7904                     = tree_cons (NULL_TREE, sizes, tem);
7905                 }
7906
7907               if (sizes)
7908                 put_pending_sizes (sizes);
7909             }
7910
7911 #else
7912 #if 0
7913             if (adjustable
7914                 && (ffesymbol_numentries (s)
7915                     != ffecom_num_entrypoints_ + 1))
7916               DECL_SOMETHING (t)
7917                 = ffecom_2 (NE_EXPR, integer_type_node,
7918                             t,
7919                             null_pointer_node);
7920 #else
7921 #if 0
7922             if (adjustable
7923                 && (ffesymbol_numentries (s)
7924                     != ffecom_num_entrypoints_ + 1))
7925               {
7926                 ffebad_start (FFEBAD_MISSING_ADJARRAY_UNSUPPORTED);
7927                 ffebad_here (0, ffesymbol_where_line (s),
7928                              ffesymbol_where_column (s));
7929                 ffebad_string (ffesymbol_text (s));
7930                 ffebad_finish ();
7931               }
7932 #endif
7933 #endif
7934 #endif
7935           }
7936           break;
7937
7938         case FFEINFO_whereCOMMON:
7939           {
7940             ffesymbol cs;
7941             ffeglobal cg;
7942             tree ct;
7943             ffestorag st = ffesymbol_storage (s);
7944             tree type;
7945
7946             cs = ffesymbol_common (s);  /* The COMMON area itself.  */
7947             if (st != NULL)     /* Else not laid out. */
7948               {
7949                 ffecom_transform_common_ (cs);
7950                 st = ffesymbol_storage (s);
7951               }
7952
7953             type = ffecom_type_localvar_ (s, bt, kt);
7954
7955             cg = ffesymbol_global (cs); /* The global COMMON info.  */
7956             if ((cg == NULL)
7957                 || (ffeglobal_type (cg) != FFEGLOBAL_typeCOMMON))
7958               ct = NULL_TREE;
7959             else
7960               ct = ffeglobal_hook (cg); /* The common area's tree.  */
7961
7962             if ((ct == NULL_TREE)
7963                 || (st == NULL)
7964                 || (type == error_mark_node))
7965               t = error_mark_node;
7966             else
7967               {
7968                 ffetargetOffset offset;
7969                 ffestorag cst;
7970
7971                 cst = ffestorag_parent (st);
7972                 assert (cst == ffesymbol_storage (cs));
7973
7974                 offset = ffestorag_modulo (cst)
7975                   + ffestorag_offset (st)
7976                   - ffestorag_offset (cst);
7977
7978                 ffecom_debug_kludge_ (ct, "COMMON", s, type, offset);
7979
7980                 /* (t_type *) (((char *) &ct) + offset) */
7981
7982                 t = convert (string_type_node,  /* (char *) */
7983                              ffecom_1 (ADDR_EXPR,
7984                                        build_pointer_type (TREE_TYPE (ct)),
7985                                        ct));
7986                 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
7987                               t,
7988                               build_int_2 (offset, 0));
7989                 t = convert (build_pointer_type (type),
7990                              t);
7991                 TREE_CONSTANT (t) = 1;
7992
7993                 addr = TRUE;
7994               }
7995           }
7996           break;
7997
7998         case FFEINFO_whereIMMEDIATE:
7999         case FFEINFO_whereGLOBAL:
8000         case FFEINFO_whereFLEETING:
8001         case FFEINFO_whereFLEETING_CADDR:
8002         case FFEINFO_whereFLEETING_IADDR:
8003         case FFEINFO_whereINTRINSIC:
8004         case FFEINFO_whereCONSTANT_SUBOBJECT:
8005         default:
8006           assert ("ENTITY where unheard of" == NULL);
8007           /* Fall through. */
8008         case FFEINFO_whereANY:
8009           t = error_mark_node;
8010           break;
8011         }
8012       break;
8013
8014     case FFEINFO_kindFUNCTION:
8015       switch (ffeinfo_where (ffesymbol_info (s)))
8016         {
8017         case FFEINFO_whereLOCAL:        /* Me. */
8018           assert (!ffecom_transform_only_dummies_);
8019           t = current_function_decl;
8020           break;
8021
8022         case FFEINFO_whereGLOBAL:
8023           assert (!ffecom_transform_only_dummies_);
8024
8025           if (((g = ffesymbol_global (s)) != NULL)
8026               && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8027                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8028               && (ffeglobal_hook (g) != NULL_TREE)
8029               && ffe_is_globals ())
8030             {
8031               t = ffeglobal_hook (g);
8032               break;
8033             }
8034
8035           if (ffesymbol_is_f2c (s)
8036               && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8037             t = ffecom_tree_fun_type[bt][kt];
8038           else
8039             t = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
8040
8041           t = build_decl (FUNCTION_DECL,
8042                           ffecom_get_external_identifier_ (s),
8043                           t);
8044           DECL_EXTERNAL (t) = 1;
8045           TREE_PUBLIC (t) = 1;
8046
8047           t = start_decl (t, FALSE);
8048           finish_decl (t, NULL_TREE, FALSE);
8049
8050           if ((g != NULL)
8051               && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8052                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8053             ffeglobal_set_hook (g, t);
8054
8055           ffecom_save_tree_forever (t);
8056
8057           break;
8058
8059         case FFEINFO_whereDUMMY:
8060           assert (ffecom_transform_only_dummies_);
8061
8062           if (ffesymbol_is_f2c (s)
8063               && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8064             t = ffecom_tree_ptr_to_fun_type[bt][kt];
8065           else
8066             t = build_pointer_type
8067               (build_function_type (ffecom_tree_type[bt][kt], NULL_TREE));
8068
8069           t = build_decl (PARM_DECL,
8070                           ffecom_get_identifier_ (ffesymbol_text (s)),
8071                           t);
8072           DECL_ARTIFICIAL (t) = 1;
8073           addr = TRUE;
8074           break;
8075
8076         case FFEINFO_whereCONSTANT:     /* Statement function. */
8077           assert (!ffecom_transform_only_dummies_);
8078           t = ffecom_gen_sfuncdef_ (s, bt, kt);
8079           break;
8080
8081         case FFEINFO_whereINTRINSIC:
8082           assert (!ffecom_transform_only_dummies_);
8083           break;                /* Let actual references generate their
8084                                    decls. */
8085
8086         default:
8087           assert ("FUNCTION where unheard of" == NULL);
8088           /* Fall through. */
8089         case FFEINFO_whereANY:
8090           t = error_mark_node;
8091           break;
8092         }
8093       break;
8094
8095     case FFEINFO_kindSUBROUTINE:
8096       switch (ffeinfo_where (ffesymbol_info (s)))
8097         {
8098         case FFEINFO_whereLOCAL:        /* Me. */
8099           assert (!ffecom_transform_only_dummies_);
8100           t = current_function_decl;
8101           break;
8102
8103         case FFEINFO_whereGLOBAL:
8104           assert (!ffecom_transform_only_dummies_);
8105
8106           if (((g = ffesymbol_global (s)) != NULL)
8107               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8108                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8109               && (ffeglobal_hook (g) != NULL_TREE)
8110               && ffe_is_globals ())
8111             {
8112               t = ffeglobal_hook (g);
8113               break;
8114             }
8115
8116           t = build_decl (FUNCTION_DECL,
8117                           ffecom_get_external_identifier_ (s),
8118                           ffecom_tree_subr_type);
8119           DECL_EXTERNAL (t) = 1;
8120           TREE_PUBLIC (t) = 1;
8121
8122           t = start_decl (t, FALSE);
8123           finish_decl (t, NULL_TREE, FALSE);
8124
8125           if ((g != NULL)
8126               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8127                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8128             ffeglobal_set_hook (g, t);
8129
8130           ffecom_save_tree_forever (t);
8131
8132           break;
8133
8134         case FFEINFO_whereDUMMY:
8135           assert (ffecom_transform_only_dummies_);
8136
8137           t = build_decl (PARM_DECL,
8138                           ffecom_get_identifier_ (ffesymbol_text (s)),
8139                           ffecom_tree_ptr_to_subr_type);
8140           DECL_ARTIFICIAL (t) = 1;
8141           addr = TRUE;
8142           break;
8143
8144         case FFEINFO_whereINTRINSIC:
8145           assert (!ffecom_transform_only_dummies_);
8146           break;                /* Let actual references generate their
8147                                    decls. */
8148
8149         default:
8150           assert ("SUBROUTINE where unheard of" == NULL);
8151           /* Fall through. */
8152         case FFEINFO_whereANY:
8153           t = error_mark_node;
8154           break;
8155         }
8156       break;
8157
8158     case FFEINFO_kindPROGRAM:
8159       switch (ffeinfo_where (ffesymbol_info (s)))
8160         {
8161         case FFEINFO_whereLOCAL:        /* Me. */
8162           assert (!ffecom_transform_only_dummies_);
8163           t = current_function_decl;
8164           break;
8165
8166         case FFEINFO_whereCOMMON:
8167         case FFEINFO_whereDUMMY:
8168         case FFEINFO_whereGLOBAL:
8169         case FFEINFO_whereRESULT:
8170         case FFEINFO_whereFLEETING:
8171         case FFEINFO_whereFLEETING_CADDR:
8172         case FFEINFO_whereFLEETING_IADDR:
8173         case FFEINFO_whereIMMEDIATE:
8174         case FFEINFO_whereINTRINSIC:
8175         case FFEINFO_whereCONSTANT:
8176         case FFEINFO_whereCONSTANT_SUBOBJECT:
8177         default:
8178           assert ("PROGRAM where unheard of" == NULL);
8179           /* Fall through. */
8180         case FFEINFO_whereANY:
8181           t = error_mark_node;
8182           break;
8183         }
8184       break;
8185
8186     case FFEINFO_kindBLOCKDATA:
8187       switch (ffeinfo_where (ffesymbol_info (s)))
8188         {
8189         case FFEINFO_whereLOCAL:        /* Me. */
8190           assert (!ffecom_transform_only_dummies_);
8191           t = current_function_decl;
8192           break;
8193
8194         case FFEINFO_whereGLOBAL:
8195           assert (!ffecom_transform_only_dummies_);
8196
8197           t = build_decl (FUNCTION_DECL,
8198                           ffecom_get_external_identifier_ (s),
8199                           ffecom_tree_blockdata_type);
8200           DECL_EXTERNAL (t) = 1;
8201           TREE_PUBLIC (t) = 1;
8202
8203           t = start_decl (t, FALSE);
8204           finish_decl (t, NULL_TREE, FALSE);
8205
8206           ffecom_save_tree_forever (t);
8207
8208           break;
8209
8210         case FFEINFO_whereCOMMON:
8211         case FFEINFO_whereDUMMY:
8212         case FFEINFO_whereRESULT:
8213         case FFEINFO_whereFLEETING:
8214         case FFEINFO_whereFLEETING_CADDR:
8215         case FFEINFO_whereFLEETING_IADDR:
8216         case FFEINFO_whereIMMEDIATE:
8217         case FFEINFO_whereINTRINSIC:
8218         case FFEINFO_whereCONSTANT:
8219         case FFEINFO_whereCONSTANT_SUBOBJECT:
8220         default:
8221           assert ("BLOCKDATA where unheard of" == NULL);
8222           /* Fall through. */
8223         case FFEINFO_whereANY:
8224           t = error_mark_node;
8225           break;
8226         }
8227       break;
8228
8229     case FFEINFO_kindCOMMON:
8230       switch (ffeinfo_where (ffesymbol_info (s)))
8231         {
8232         case FFEINFO_whereLOCAL:
8233           assert (!ffecom_transform_only_dummies_);
8234           ffecom_transform_common_ (s);
8235           break;
8236
8237         case FFEINFO_whereNONE:
8238         case FFEINFO_whereCOMMON:
8239         case FFEINFO_whereDUMMY:
8240         case FFEINFO_whereGLOBAL:
8241         case FFEINFO_whereRESULT:
8242         case FFEINFO_whereFLEETING:
8243         case FFEINFO_whereFLEETING_CADDR:
8244         case FFEINFO_whereFLEETING_IADDR:
8245         case FFEINFO_whereIMMEDIATE:
8246         case FFEINFO_whereINTRINSIC:
8247         case FFEINFO_whereCONSTANT:
8248         case FFEINFO_whereCONSTANT_SUBOBJECT:
8249         default:
8250           assert ("COMMON where unheard of" == NULL);
8251           /* Fall through. */
8252         case FFEINFO_whereANY:
8253           t = error_mark_node;
8254           break;
8255         }
8256       break;
8257
8258     case FFEINFO_kindCONSTRUCT:
8259       switch (ffeinfo_where (ffesymbol_info (s)))
8260         {
8261         case FFEINFO_whereLOCAL:
8262           assert (!ffecom_transform_only_dummies_);
8263           break;
8264
8265         case FFEINFO_whereNONE:
8266         case FFEINFO_whereCOMMON:
8267         case FFEINFO_whereDUMMY:
8268         case FFEINFO_whereGLOBAL:
8269         case FFEINFO_whereRESULT:
8270         case FFEINFO_whereFLEETING:
8271         case FFEINFO_whereFLEETING_CADDR:
8272         case FFEINFO_whereFLEETING_IADDR:
8273         case FFEINFO_whereIMMEDIATE:
8274         case FFEINFO_whereINTRINSIC:
8275         case FFEINFO_whereCONSTANT:
8276         case FFEINFO_whereCONSTANT_SUBOBJECT:
8277         default:
8278           assert ("CONSTRUCT where unheard of" == NULL);
8279           /* Fall through. */
8280         case FFEINFO_whereANY:
8281           t = error_mark_node;
8282           break;
8283         }
8284       break;
8285
8286     case FFEINFO_kindNAMELIST:
8287       switch (ffeinfo_where (ffesymbol_info (s)))
8288         {
8289         case FFEINFO_whereLOCAL:
8290           assert (!ffecom_transform_only_dummies_);
8291           t = ffecom_transform_namelist_ (s);
8292           break;
8293
8294         case FFEINFO_whereNONE:
8295         case FFEINFO_whereCOMMON:
8296         case FFEINFO_whereDUMMY:
8297         case FFEINFO_whereGLOBAL:
8298         case FFEINFO_whereRESULT:
8299         case FFEINFO_whereFLEETING:
8300         case FFEINFO_whereFLEETING_CADDR:
8301         case FFEINFO_whereFLEETING_IADDR:
8302         case FFEINFO_whereIMMEDIATE:
8303         case FFEINFO_whereINTRINSIC:
8304         case FFEINFO_whereCONSTANT:
8305         case FFEINFO_whereCONSTANT_SUBOBJECT:
8306         default:
8307           assert ("NAMELIST where unheard of" == NULL);
8308           /* Fall through. */
8309         case FFEINFO_whereANY:
8310           t = error_mark_node;
8311           break;
8312         }
8313       break;
8314
8315     default:
8316       assert ("kind unheard of" == NULL);
8317       /* Fall through. */
8318     case FFEINFO_kindANY:
8319       t = error_mark_node;
8320       break;
8321     }
8322
8323   ffesymbol_hook (s).decl_tree = t;
8324   ffesymbol_hook (s).length_tree = tlen;
8325   ffesymbol_hook (s).addr = addr;
8326
8327   lineno = old_lineno;
8328   input_filename = old_input_filename;
8329
8330   return s;
8331 }
8332
8333 /* Transform into ASSIGNable symbol.
8334
8335    Symbol has already been transformed, but for whatever reason, the
8336    resulting decl_tree has been deemed not usable for an ASSIGN target.
8337    (E.g. it isn't wide enough to hold a pointer.)  So, here we invent
8338    another local symbol of type void * and stuff that in the assign_tree
8339    argument.  The F77/F90 standards allow this implementation.  */
8340
8341 static ffesymbol
8342 ffecom_sym_transform_assign_ (ffesymbol s)
8343 {
8344   tree t;                       /* Transformed thingy. */
8345   int old_lineno = lineno;
8346   const char *old_input_filename = input_filename;
8347
8348   if (ffesymbol_sfdummyparent (s) == NULL)
8349     {
8350       input_filename = ffesymbol_where_filename (s);
8351       lineno = ffesymbol_where_filelinenum (s);
8352     }
8353   else
8354     {
8355       ffesymbol sf = ffesymbol_sfdummyparent (s);
8356
8357       input_filename = ffesymbol_where_filename (sf);
8358       lineno = ffesymbol_where_filelinenum (sf);
8359     }
8360
8361   assert (!ffecom_transform_only_dummies_);
8362
8363   t = build_decl (VAR_DECL,
8364                   ffecom_get_invented_identifier ("__g77_ASSIGN_%s",
8365                                                    ffesymbol_text (s)),
8366                   TREE_TYPE (null_pointer_node));
8367
8368   switch (ffesymbol_where (s))
8369     {
8370     case FFEINFO_whereLOCAL:
8371       /* Unlike for regular vars, SAVE status is easy to determine for
8372          ASSIGNed vars, since there's no initialization, there's no
8373          effective storage association (so "SAVE J" does not apply to
8374          K even given "EQUIVALENCE (J,K)"), there's no size issue
8375          to worry about, etc.  */
8376       if ((ffesymbol_is_save (s) || ffe_is_saveall ())
8377           && (ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8378           && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA))
8379         TREE_STATIC (t) = 1;    /* SAVEd in proc, make static. */
8380       else
8381         TREE_STATIC (t) = 0;    /* No need to make static. */
8382       break;
8383
8384     case FFEINFO_whereCOMMON:
8385       TREE_STATIC (t) = 1;      /* Assume COMMONs always SAVEd. */
8386       break;
8387
8388     case FFEINFO_whereDUMMY:
8389       /* Note that twinning a DUMMY means the caller won't see
8390          the ASSIGNed value.  But both F77 and F90 allow implementations
8391          to do this, i.e. disallow Fortran code that would try and
8392          take advantage of actually putting a label into a variable
8393          via a dummy argument (or any other storage association, for
8394          that matter).  */
8395       TREE_STATIC (t) = 0;
8396       break;
8397
8398     default:
8399       TREE_STATIC (t) = 0;
8400       break;
8401     }
8402
8403   t = start_decl (t, FALSE);
8404   finish_decl (t, NULL_TREE, FALSE);
8405
8406   ffesymbol_hook (s).assign_tree = t;
8407
8408   lineno = old_lineno;
8409   input_filename = old_input_filename;
8410
8411   return s;
8412 }
8413
8414 /* Implement COMMON area in back end.
8415
8416    Because COMMON-based variables can be referenced in the dimension
8417    expressions of dummy (adjustable) arrays, and because dummies
8418    (in the gcc back end) need to be put in the outer binding level
8419    of a function (which has two binding levels, the outer holding
8420    the dummies and the inner holding the other vars), special care
8421    must be taken to handle COMMON areas.
8422
8423    The current strategy is basically to always tell the back end about
8424    the COMMON area as a top-level external reference to just a block
8425    of storage of the master type of that area (e.g. integer, real,
8426    character, whatever -- not a structure).  As a distinct action,
8427    if initial values are provided, tell the back end about the area
8428    as a top-level non-external (initialized) area and remember not to
8429    allow further initialization or expansion of the area.  Meanwhile,
8430    if no initialization happens at all, tell the back end about
8431    the largest size we've seen declared so the space does get reserved.
8432    (This function doesn't handle all that stuff, but it does some
8433    of the important things.)
8434
8435    Meanwhile, for COMMON variables themselves, just keep creating
8436    references like *((float *) (&common_area + offset)) each time
8437    we reference the variable.  In other words, don't make a VAR_DECL
8438    or any kind of component reference (like we used to do before 0.4),
8439    though we might do that as well just for debugging purposes (and
8440    stuff the rtl with the appropriate offset expression).  */
8441
8442 static void
8443 ffecom_transform_common_ (ffesymbol s)
8444 {
8445   ffestorag st = ffesymbol_storage (s);
8446   ffeglobal g = ffesymbol_global (s);
8447   tree cbt;
8448   tree cbtype;
8449   tree init;
8450   tree high;
8451   bool is_init = ffestorag_is_init (st);
8452
8453   assert (st != NULL);
8454
8455   if ((g == NULL)
8456       || (ffeglobal_type (g) != FFEGLOBAL_typeCOMMON))
8457     return;
8458
8459   /* First update the size of the area in global terms.  */
8460
8461   ffeglobal_size_common (s, ffestorag_size (st));
8462
8463   if (!ffeglobal_common_init (g))
8464     is_init = FALSE;    /* No explicit init, don't let erroneous joins init. */
8465
8466   cbt = ffeglobal_hook (g);
8467
8468   /* If we already have declared this common block for a previous program
8469      unit, and either we already initialized it or we don't have new
8470      initialization for it, just return what we have without changing it.  */
8471
8472   if ((cbt != NULL_TREE)
8473       && (!is_init
8474           || !DECL_EXTERNAL (cbt)))
8475     {
8476       if (st->hook == NULL) ffestorag_set_hook (st, cbt);
8477       return;
8478     }
8479
8480   /* Process inits.  */
8481
8482   if (is_init)
8483     {
8484       if (ffestorag_init (st) != NULL)
8485         {
8486           ffebld sexp;
8487
8488           /* Set the padding for the expression, so ffecom_expr
8489              knows to insert that many zeros.  */
8490           switch (ffebld_op (sexp = ffestorag_init (st)))
8491             {
8492             case FFEBLD_opCONTER:
8493               ffebld_conter_set_pad (sexp, ffestorag_modulo (st));
8494               break;
8495
8496             case FFEBLD_opARRTER:
8497               ffebld_arrter_set_pad (sexp, ffestorag_modulo (st));
8498               break;
8499
8500             case FFEBLD_opACCTER:
8501               ffebld_accter_set_pad (sexp, ffestorag_modulo (st));
8502               break;
8503
8504             default:
8505               assert ("bad op for cmn init (pad)" == NULL);
8506               break;
8507             }
8508
8509           init = ffecom_expr (sexp);
8510           if (init == error_mark_node)
8511             {                   /* Hopefully the back end complained! */
8512               init = NULL_TREE;
8513               if (cbt != NULL_TREE)
8514                 return;
8515             }
8516         }
8517       else
8518         init = error_mark_node;
8519     }
8520   else
8521     init = NULL_TREE;
8522
8523   /* cbtype must be permanently allocated!  */
8524
8525   /* Allocate the MAX of the areas so far, seen filewide.  */
8526   high = build_int_2 ((ffeglobal_common_size (g)
8527                        + ffeglobal_common_pad (g)) - 1, 0);
8528   TREE_TYPE (high) = ffecom_integer_type_node;
8529
8530   if (init)
8531     cbtype = build_array_type (char_type_node,
8532                                build_range_type (integer_type_node,
8533                                                  integer_zero_node,
8534                                                  high));
8535   else
8536     cbtype = build_array_type (char_type_node, NULL_TREE);
8537
8538   if (cbt == NULL_TREE)
8539     {
8540       cbt
8541         = build_decl (VAR_DECL,
8542                       ffecom_get_external_identifier_ (s),
8543                       cbtype);
8544       TREE_STATIC (cbt) = 1;
8545       TREE_PUBLIC (cbt) = 1;
8546     }
8547   else
8548     {
8549       assert (is_init);
8550       TREE_TYPE (cbt) = cbtype;
8551     }
8552   DECL_EXTERNAL (cbt) = init ? 0 : 1;
8553   DECL_INITIAL (cbt) = init ? error_mark_node : NULL_TREE;
8554
8555   cbt = start_decl (cbt, TRUE);
8556   if (ffeglobal_hook (g) != NULL)
8557     assert (cbt == ffeglobal_hook (g));
8558
8559   assert (!init || !DECL_EXTERNAL (cbt));
8560
8561   /* Make sure that any type can live in COMMON and be referenced
8562      without getting a bus error.  We could pick the most restrictive
8563      alignment of all entities actually placed in the COMMON, but
8564      this seems easy enough.  */
8565
8566   DECL_ALIGN (cbt) = BIGGEST_ALIGNMENT;
8567   DECL_USER_ALIGN (cbt) = 0;
8568
8569   if (is_init && (ffestorag_init (st) == NULL))
8570     init = ffecom_init_zero_ (cbt);
8571
8572   finish_decl (cbt, init, TRUE);
8573
8574   if (is_init)
8575     ffestorag_set_init (st, ffebld_new_any ());
8576
8577   if (init)
8578     {
8579       assert (DECL_SIZE_UNIT (cbt) != NULL_TREE);
8580       assert (TREE_CODE (DECL_SIZE_UNIT (cbt)) == INTEGER_CST);
8581       assert (0 == compare_tree_int (DECL_SIZE_UNIT (cbt),
8582                                      (ffeglobal_common_size (g)
8583                                       + ffeglobal_common_pad (g))));
8584     }
8585
8586   ffeglobal_set_hook (g, cbt);
8587
8588   ffestorag_set_hook (st, cbt);
8589
8590   ffecom_save_tree_forever (cbt);
8591 }
8592
8593 /* Make master area for local EQUIVALENCE.  */
8594
8595 static void
8596 ffecom_transform_equiv_ (ffestorag eqst)
8597 {
8598   tree eqt;
8599   tree eqtype;
8600   tree init;
8601   tree high;
8602   bool is_init = ffestorag_is_init (eqst);
8603
8604   assert (eqst != NULL);
8605
8606   eqt = ffestorag_hook (eqst);
8607
8608   if (eqt != NULL_TREE)
8609     return;
8610
8611   /* Process inits.  */
8612
8613   if (is_init)
8614     {
8615       if (ffestorag_init (eqst) != NULL)
8616         {
8617           ffebld sexp;
8618
8619           /* Set the padding for the expression, so ffecom_expr
8620              knows to insert that many zeros.  */
8621           switch (ffebld_op (sexp = ffestorag_init (eqst)))
8622             {
8623             case FFEBLD_opCONTER:
8624               ffebld_conter_set_pad (sexp, ffestorag_modulo (eqst));
8625               break;
8626
8627             case FFEBLD_opARRTER:
8628               ffebld_arrter_set_pad (sexp, ffestorag_modulo (eqst));
8629               break;
8630
8631             case FFEBLD_opACCTER:
8632               ffebld_accter_set_pad (sexp, ffestorag_modulo (eqst));
8633               break;
8634
8635             default:
8636               assert ("bad op for eqv init (pad)" == NULL);
8637               break;
8638             }
8639
8640           init = ffecom_expr (sexp);
8641           if (init == error_mark_node)
8642             init = NULL_TREE;   /* Hopefully the back end complained! */
8643         }
8644       else
8645         init = error_mark_node;
8646     }
8647   else if (ffe_is_init_local_zero ())
8648     init = error_mark_node;
8649   else
8650     init = NULL_TREE;
8651
8652   ffecom_member_namelisted_ = FALSE;
8653   ffestorag_drive (ffestorag_list_equivs (eqst),
8654                    &ffecom_member_phase1_,
8655                    eqst);
8656
8657   high = build_int_2 ((ffestorag_size (eqst)
8658                        + ffestorag_modulo (eqst)) - 1, 0);
8659   TREE_TYPE (high) = ffecom_integer_type_node;
8660
8661   eqtype = build_array_type (char_type_node,
8662                              build_range_type (ffecom_integer_type_node,
8663                                                ffecom_integer_zero_node,
8664                                                high));
8665
8666   eqt = build_decl (VAR_DECL,
8667                     ffecom_get_invented_identifier ("__g77_equiv_%s",
8668                                                     ffesymbol_text
8669                                                     (ffestorag_symbol (eqst))),
8670                     eqtype);
8671   DECL_EXTERNAL (eqt) = 0;
8672   if (is_init
8673       || ffecom_member_namelisted_
8674 #ifdef FFECOM_sizeMAXSTACKITEM
8675       || (ffestorag_size (eqst) > FFECOM_sizeMAXSTACKITEM)
8676 #endif
8677       || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8678           && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
8679           && (ffestorag_is_save (eqst) || ffe_is_saveall ())))
8680     TREE_STATIC (eqt) = 1;
8681   else
8682     TREE_STATIC (eqt) = 0;
8683   TREE_PUBLIC (eqt) = 0;
8684   TREE_ADDRESSABLE (eqt) = 1;  /* Ensure non-register allocation */
8685   DECL_CONTEXT (eqt) = current_function_decl;
8686   if (init)
8687     DECL_INITIAL (eqt) = error_mark_node;
8688   else
8689     DECL_INITIAL (eqt) = NULL_TREE;
8690
8691   eqt = start_decl (eqt, FALSE);
8692
8693   /* Make sure that any type can live in EQUIVALENCE and be referenced
8694      without getting a bus error.  We could pick the most restrictive
8695      alignment of all entities actually placed in the EQUIVALENCE, but
8696      this seems easy enough.  */
8697
8698   DECL_ALIGN (eqt) = BIGGEST_ALIGNMENT;
8699   DECL_USER_ALIGN (eqt) = 0;
8700
8701   if ((!is_init && ffe_is_init_local_zero ())
8702       || (is_init && (ffestorag_init (eqst) == NULL)))
8703     init = ffecom_init_zero_ (eqt);
8704
8705   finish_decl (eqt, init, FALSE);
8706
8707   if (is_init)
8708     ffestorag_set_init (eqst, ffebld_new_any ());
8709
8710   {
8711     assert (TREE_CODE (DECL_SIZE_UNIT (eqt)) == INTEGER_CST);
8712     assert (0 == compare_tree_int (DECL_SIZE_UNIT (eqt),
8713                                    (ffestorag_size (eqst)
8714                                     + ffestorag_modulo (eqst))));
8715   }
8716
8717   ffestorag_set_hook (eqst, eqt);
8718
8719   ffestorag_drive (ffestorag_list_equivs (eqst),
8720                    &ffecom_member_phase2_,
8721                    eqst);
8722 }
8723
8724 /* Implement NAMELIST in back end.  See f2c/format.c for more info.  */
8725
8726 static tree
8727 ffecom_transform_namelist_ (ffesymbol s)
8728 {
8729   tree nmlt;
8730   tree nmltype = ffecom_type_namelist_ ();
8731   tree nmlinits;
8732   tree nameinit;
8733   tree varsinit;
8734   tree nvarsinit;
8735   tree field;
8736   tree high;
8737   int i;
8738   static int mynumber = 0;
8739
8740   nmlt = build_decl (VAR_DECL,
8741                      ffecom_get_invented_identifier ("__g77_namelist_%d",
8742                                                      mynumber++),
8743                      nmltype);
8744   TREE_STATIC (nmlt) = 1;
8745   DECL_INITIAL (nmlt) = error_mark_node;
8746
8747   nmlt = start_decl (nmlt, FALSE);
8748
8749   /* Process inits.  */
8750
8751   i = strlen (ffesymbol_text (s));
8752
8753   high = build_int_2 (i, 0);
8754   TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
8755
8756   nameinit = ffecom_build_f2c_string_ (i + 1,
8757                                        ffesymbol_text (s));
8758   TREE_TYPE (nameinit)
8759     = build_type_variant
8760     (build_array_type
8761      (char_type_node,
8762       build_range_type (ffecom_f2c_ftnlen_type_node,
8763                         ffecom_f2c_ftnlen_one_node,
8764                         high)),
8765      1, 0);
8766   TREE_CONSTANT (nameinit) = 1;
8767   TREE_STATIC (nameinit) = 1;
8768   nameinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (nameinit)),
8769                        nameinit);
8770
8771   varsinit = ffecom_vardesc_array_ (s);
8772   varsinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (varsinit)),
8773                        varsinit);
8774   TREE_CONSTANT (varsinit) = 1;
8775   TREE_STATIC (varsinit) = 1;
8776
8777   {
8778     ffebld b;
8779
8780     for (i = 0, b = ffesymbol_namelist (s); b != NULL; b = ffebld_trail (b))
8781       ++i;
8782   }
8783   nvarsinit = build_int_2 (i, 0);
8784   TREE_TYPE (nvarsinit) = integer_type_node;
8785   TREE_CONSTANT (nvarsinit) = 1;
8786   TREE_STATIC (nvarsinit) = 1;
8787
8788   nmlinits = build_tree_list ((field = TYPE_FIELDS (nmltype)), nameinit);
8789   TREE_CHAIN (nmlinits) = build_tree_list ((field = TREE_CHAIN (field)),
8790                                            varsinit);
8791   TREE_CHAIN (TREE_CHAIN (nmlinits))
8792     = build_tree_list ((field = TREE_CHAIN (field)), nvarsinit);
8793
8794   nmlinits = build (CONSTRUCTOR, nmltype, NULL_TREE, nmlinits);
8795   TREE_CONSTANT (nmlinits) = 1;
8796   TREE_STATIC (nmlinits) = 1;
8797
8798   finish_decl (nmlt, nmlinits, FALSE);
8799
8800   nmlt = ffecom_1 (ADDR_EXPR, build_pointer_type (nmltype), nmlt);
8801
8802   return nmlt;
8803 }
8804
8805 /* A subroutine of ffecom_tree_canonize_ref_.  The incoming tree is
8806    analyzed on the assumption it is calculating a pointer to be
8807    indirected through.  It must return the proper decl and offset,
8808    taking into account different units of measurements for offsets.  */
8809
8810 static void
8811 ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
8812                            tree t)
8813 {
8814   switch (TREE_CODE (t))
8815     {
8816     case NOP_EXPR:
8817     case CONVERT_EXPR:
8818     case NON_LVALUE_EXPR:
8819       ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
8820       break;
8821
8822     case PLUS_EXPR:
8823       ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
8824       if ((*decl == NULL_TREE)
8825           || (*decl == error_mark_node))
8826         break;
8827
8828       if (TREE_CODE (TREE_OPERAND (t, 1)) == INTEGER_CST)
8829         {
8830           /* An offset into COMMON.  */
8831           *offset = fold (build (PLUS_EXPR, TREE_TYPE (*offset),
8832                                  *offset, TREE_OPERAND (t, 1)));
8833           /* Convert offset (presumably in bytes) into canonical units
8834              (presumably bits).  */
8835           *offset = size_binop (MULT_EXPR,
8836                                 convert (bitsizetype, *offset),
8837                                 TYPE_SIZE (TREE_TYPE (TREE_TYPE (t))));
8838           break;
8839         }
8840       /* Not a COMMON reference, so an unrecognized pattern.  */
8841       *decl = error_mark_node;
8842       break;
8843
8844     case PARM_DECL:
8845       *decl = t;
8846       *offset = bitsize_zero_node;
8847       break;
8848
8849     case ADDR_EXPR:
8850       if (TREE_CODE (TREE_OPERAND (t, 0)) == VAR_DECL)
8851         {
8852           /* A reference to COMMON.  */
8853           *decl = TREE_OPERAND (t, 0);
8854           *offset = bitsize_zero_node;
8855           break;
8856         }
8857       /* Fall through.  */
8858     default:
8859       /* Not a COMMON reference, so an unrecognized pattern.  */
8860       *decl = error_mark_node;
8861       break;
8862     }
8863 }
8864
8865 /* Given a tree that is possibly intended for use as an lvalue, return
8866    information representing a canonical view of that tree as a decl, an
8867    offset into that decl, and a size for the lvalue.
8868
8869    If there's no applicable decl, NULL_TREE is returned for the decl,
8870    and the other fields are left undefined.
8871
8872    If the tree doesn't fit the recognizable forms, an ERROR_MARK node
8873    is returned for the decl, and the other fields are left undefined.
8874
8875    Otherwise, the decl returned currently is either a VAR_DECL or a
8876    PARM_DECL.
8877
8878    The offset returned is always valid, but of course not necessarily
8879    a constant, and not necessarily converted into the appropriate
8880    type, leaving that up to the caller (so as to avoid that overhead
8881    if the decls being looked at are different anyway).
8882
8883    If the size cannot be determined (e.g. an adjustable array),
8884    an ERROR_MARK node is returned for the size.  Otherwise, the
8885    size returned is valid, not necessarily a constant, and not
8886    necessarily converted into the appropriate type as with the
8887    offset.
8888
8889    Note that the offset and size expressions are expressed in the
8890    base storage units (usually bits) rather than in the units of
8891    the type of the decl, because two decls with different types
8892    might overlap but with apparently non-overlapping array offsets,
8893    whereas converting the array offsets to consistant offsets will
8894    reveal the overlap.  */
8895
8896 static void
8897 ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
8898                            tree *size, tree t)
8899 {
8900   /* The default path is to report a nonexistant decl.  */
8901   *decl = NULL_TREE;
8902
8903   if (t == NULL_TREE)
8904     return;
8905
8906   switch (TREE_CODE (t))
8907     {
8908     case ERROR_MARK:
8909     case IDENTIFIER_NODE:
8910     case INTEGER_CST:
8911     case REAL_CST:
8912     case COMPLEX_CST:
8913     case STRING_CST:
8914     case CONST_DECL:
8915     case PLUS_EXPR:
8916     case MINUS_EXPR:
8917     case MULT_EXPR:
8918     case TRUNC_DIV_EXPR:
8919     case CEIL_DIV_EXPR:
8920     case FLOOR_DIV_EXPR:
8921     case ROUND_DIV_EXPR:
8922     case TRUNC_MOD_EXPR:
8923     case CEIL_MOD_EXPR:
8924     case FLOOR_MOD_EXPR:
8925     case ROUND_MOD_EXPR:
8926     case RDIV_EXPR:
8927     case EXACT_DIV_EXPR:
8928     case FIX_TRUNC_EXPR:
8929     case FIX_CEIL_EXPR:
8930     case FIX_FLOOR_EXPR:
8931     case FIX_ROUND_EXPR:
8932     case FLOAT_EXPR:
8933     case NEGATE_EXPR:
8934     case MIN_EXPR:
8935     case MAX_EXPR:
8936     case ABS_EXPR:
8937     case FFS_EXPR:
8938     case LSHIFT_EXPR:
8939     case RSHIFT_EXPR:
8940     case LROTATE_EXPR:
8941     case RROTATE_EXPR:
8942     case BIT_IOR_EXPR:
8943     case BIT_XOR_EXPR:
8944     case BIT_AND_EXPR:
8945     case BIT_ANDTC_EXPR:
8946     case BIT_NOT_EXPR:
8947     case TRUTH_ANDIF_EXPR:
8948     case TRUTH_ORIF_EXPR:
8949     case TRUTH_AND_EXPR:
8950     case TRUTH_OR_EXPR:
8951     case TRUTH_XOR_EXPR:
8952     case TRUTH_NOT_EXPR:
8953     case LT_EXPR:
8954     case LE_EXPR:
8955     case GT_EXPR:
8956     case GE_EXPR:
8957     case EQ_EXPR:
8958     case NE_EXPR:
8959     case COMPLEX_EXPR:
8960     case CONJ_EXPR:
8961     case REALPART_EXPR:
8962     case IMAGPART_EXPR:
8963     case LABEL_EXPR:
8964     case COMPONENT_REF:
8965     case COMPOUND_EXPR:
8966     case ADDR_EXPR:
8967       return;
8968
8969     case VAR_DECL:
8970     case PARM_DECL:
8971       *decl = t;
8972       *offset = bitsize_zero_node;
8973       *size = TYPE_SIZE (TREE_TYPE (t));
8974       return;
8975
8976     case ARRAY_REF:
8977       {
8978         tree array = TREE_OPERAND (t, 0);
8979         tree element = TREE_OPERAND (t, 1);
8980         tree init_offset;
8981
8982         if ((array == NULL_TREE)
8983             || (element == NULL_TREE))
8984           {
8985             *decl = error_mark_node;
8986             return;
8987           }
8988
8989         ffecom_tree_canonize_ref_ (decl, &init_offset, size,
8990                                    array);
8991         if ((*decl == NULL_TREE)
8992             || (*decl == error_mark_node))
8993           return;
8994
8995         /* Calculate ((element - base) * NBBY) + init_offset.  */
8996         *offset = fold (build (MINUS_EXPR, TREE_TYPE (element),
8997                                element,
8998                                TYPE_MIN_VALUE (TYPE_DOMAIN
8999                                                (TREE_TYPE (array)))));
9000
9001         *offset = size_binop (MULT_EXPR,
9002                               convert (bitsizetype, *offset),
9003                               TYPE_SIZE (TREE_TYPE (TREE_TYPE (array))));
9004
9005         *offset = size_binop (PLUS_EXPR, init_offset, *offset);
9006
9007         *size = TYPE_SIZE (TREE_TYPE (t));
9008         return;
9009       }
9010
9011     case INDIRECT_REF:
9012
9013       /* Most of this code is to handle references to COMMON.  And so
9014          far that is useful only for calling library functions, since
9015          external (user) functions might reference common areas.  But
9016          even calling an external function, it's worthwhile to decode
9017          COMMON references because if not storing into COMMON, we don't
9018          want COMMON-based arguments to gratuitously force use of a
9019          temporary.  */
9020
9021       *size = TYPE_SIZE (TREE_TYPE (t));
9022
9023       ffecom_tree_canonize_ptr_ (decl, offset,
9024                                  TREE_OPERAND (t, 0));
9025
9026       return;
9027
9028     case CONVERT_EXPR:
9029     case NOP_EXPR:
9030     case MODIFY_EXPR:
9031     case NON_LVALUE_EXPR:
9032     case RESULT_DECL:
9033     case FIELD_DECL:
9034     case COND_EXPR:             /* More cases than we can handle. */
9035     case SAVE_EXPR:
9036     case REFERENCE_EXPR:
9037     case PREDECREMENT_EXPR:
9038     case PREINCREMENT_EXPR:
9039     case POSTDECREMENT_EXPR:
9040     case POSTINCREMENT_EXPR:
9041     case CALL_EXPR:
9042     default:
9043       *decl = error_mark_node;
9044       return;
9045     }
9046 }
9047
9048 /* Do divide operation appropriate to type of operands.  */
9049
9050 static tree
9051 ffecom_tree_divide_ (tree tree_type, tree left, tree right,
9052                      tree dest_tree, ffebld dest, bool *dest_used,
9053                      tree hook)
9054 {
9055   if ((left == error_mark_node)
9056       || (right == error_mark_node))
9057     return error_mark_node;
9058
9059   switch (TREE_CODE (tree_type))
9060     {
9061     case INTEGER_TYPE:
9062       return ffecom_2 (TRUNC_DIV_EXPR, tree_type,
9063                        left,
9064                        right);
9065
9066     case COMPLEX_TYPE:
9067       if (! optimize_size)
9068         return ffecom_2 (RDIV_EXPR, tree_type,
9069                          left,
9070                          right);
9071       {
9072         ffecomGfrt ix;
9073
9074         if (TREE_TYPE (tree_type)
9075             == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9076           ix = FFECOM_gfrtDIV_CC;       /* Overlapping result okay. */
9077         else
9078           ix = FFECOM_gfrtDIV_ZZ;       /* Overlapping result okay. */
9079
9080         left = ffecom_1 (ADDR_EXPR,
9081                          build_pointer_type (TREE_TYPE (left)),
9082                          left);
9083         left = build_tree_list (NULL_TREE, left);
9084         right = ffecom_1 (ADDR_EXPR,
9085                           build_pointer_type (TREE_TYPE (right)),
9086                           right);
9087         right = build_tree_list (NULL_TREE, right);
9088         TREE_CHAIN (left) = right;
9089
9090         return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9091                              ffecom_gfrt_kindtype (ix),
9092                              ffe_is_f2c_library (),
9093                              tree_type,
9094                              left,
9095                              dest_tree, dest, dest_used,
9096                              NULL_TREE, TRUE, hook);
9097       }
9098       break;
9099
9100     case RECORD_TYPE:
9101       {
9102         ffecomGfrt ix;
9103
9104         if (TREE_TYPE (TYPE_FIELDS (tree_type))
9105             == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9106           ix = FFECOM_gfrtDIV_CC;       /* Overlapping result okay. */
9107         else
9108           ix = FFECOM_gfrtDIV_ZZ;       /* Overlapping result okay. */
9109
9110         left = ffecom_1 (ADDR_EXPR,
9111                          build_pointer_type (TREE_TYPE (left)),
9112                          left);
9113         left = build_tree_list (NULL_TREE, left);
9114         right = ffecom_1 (ADDR_EXPR,
9115                           build_pointer_type (TREE_TYPE (right)),
9116                           right);
9117         right = build_tree_list (NULL_TREE, right);
9118         TREE_CHAIN (left) = right;
9119
9120         return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9121                              ffecom_gfrt_kindtype (ix),
9122                              ffe_is_f2c_library (),
9123                              tree_type,
9124                              left,
9125                              dest_tree, dest, dest_used,
9126                              NULL_TREE, TRUE, hook);
9127       }
9128       break;
9129
9130     default:
9131       return ffecom_2 (RDIV_EXPR, tree_type,
9132                        left,
9133                        right);
9134     }
9135 }
9136
9137 /* Build type info for non-dummy variable.  */
9138
9139 static tree
9140 ffecom_type_localvar_ (ffesymbol s, ffeinfoBasictype bt,
9141                        ffeinfoKindtype kt)
9142 {
9143   tree type;
9144   ffebld dl;
9145   ffebld dim;
9146   tree lowt;
9147   tree hight;
9148
9149   type = ffecom_tree_type[bt][kt];
9150   if (bt == FFEINFO_basictypeCHARACTER)
9151     {
9152       hight = build_int_2 (ffesymbol_size (s), 0);
9153       TREE_TYPE (hight) = ffecom_f2c_ftnlen_type_node;
9154
9155       type
9156         = build_array_type
9157           (type,
9158            build_range_type (ffecom_f2c_ftnlen_type_node,
9159                              ffecom_f2c_ftnlen_one_node,
9160                              hight));
9161       type = ffecom_check_size_overflow_ (s, type, FALSE);
9162     }
9163
9164   for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
9165     {
9166       if (type == error_mark_node)
9167         break;
9168
9169       dim = ffebld_head (dl);
9170       assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
9171
9172       if (ffebld_left (dim) == NULL)
9173         lowt = integer_one_node;
9174       else
9175         lowt = ffecom_expr (ffebld_left (dim));
9176
9177       if (TREE_CODE (lowt) != INTEGER_CST)
9178         lowt = variable_size (lowt);
9179
9180       assert (ffebld_right (dim) != NULL);
9181       hight = ffecom_expr (ffebld_right (dim));
9182
9183       if (TREE_CODE (hight) != INTEGER_CST)
9184         hight = variable_size (hight);
9185
9186       type = build_array_type (type,
9187                                build_range_type (ffecom_integer_type_node,
9188                                                  lowt, hight));
9189       type = ffecom_check_size_overflow_ (s, type, FALSE);
9190     }
9191
9192   return type;
9193 }
9194
9195 /* Build Namelist type.  */
9196
9197 static tree
9198 ffecom_type_namelist_ ()
9199 {
9200   static tree type = NULL_TREE;
9201
9202   if (type == NULL_TREE)
9203     {
9204       static tree namefield, varsfield, nvarsfield;
9205       tree vardesctype;
9206
9207       vardesctype = ffecom_type_vardesc_ ();
9208
9209       type = make_node (RECORD_TYPE);
9210
9211       vardesctype = build_pointer_type (build_pointer_type (vardesctype));
9212
9213       namefield = ffecom_decl_field (type, NULL_TREE, "name",
9214                                      string_type_node);
9215       varsfield = ffecom_decl_field (type, namefield, "vars", vardesctype);
9216       nvarsfield = ffecom_decl_field (type, varsfield, "nvars",
9217                                       integer_type_node);
9218
9219       TYPE_FIELDS (type) = namefield;
9220       layout_type (type);
9221
9222       ggc_add_tree_root (&type, 1);
9223     }
9224
9225   return type;
9226 }
9227
9228 /* Build Vardesc type.  */
9229
9230 static tree
9231 ffecom_type_vardesc_ ()
9232 {
9233   static tree type = NULL_TREE;
9234   static tree namefield, addrfield, dimsfield, typefield;
9235
9236   if (type == NULL_TREE)
9237     {
9238       type = make_node (RECORD_TYPE);
9239
9240       namefield = ffecom_decl_field (type, NULL_TREE, "name",
9241                                      string_type_node);
9242       addrfield = ffecom_decl_field (type, namefield, "addr",
9243                                      string_type_node);
9244       dimsfield = ffecom_decl_field (type, addrfield, "dims",
9245                                      ffecom_f2c_ptr_to_ftnlen_type_node);
9246       typefield = ffecom_decl_field (type, dimsfield, "type",
9247                                      integer_type_node);
9248
9249       TYPE_FIELDS (type) = namefield;
9250       layout_type (type);
9251
9252       ggc_add_tree_root (&type, 1);
9253     }
9254
9255   return type;
9256 }
9257
9258 static tree
9259 ffecom_vardesc_ (ffebld expr)
9260 {
9261   ffesymbol s;
9262
9263   assert (ffebld_op (expr) == FFEBLD_opSYMTER);
9264   s = ffebld_symter (expr);
9265
9266   if (ffesymbol_hook (s).vardesc_tree == NULL_TREE)
9267     {
9268       int i;
9269       tree vardesctype = ffecom_type_vardesc_ ();
9270       tree var;
9271       tree nameinit;
9272       tree dimsinit;
9273       tree addrinit;
9274       tree typeinit;
9275       tree field;
9276       tree varinits;
9277       static int mynumber = 0;
9278
9279       var = build_decl (VAR_DECL,
9280                         ffecom_get_invented_identifier ("__g77_vardesc_%d",
9281                                                         mynumber++),
9282                         vardesctype);
9283       TREE_STATIC (var) = 1;
9284       DECL_INITIAL (var) = error_mark_node;
9285
9286       var = start_decl (var, FALSE);
9287
9288       /* Process inits.  */
9289
9290       nameinit = ffecom_build_f2c_string_ ((i = strlen (ffesymbol_text (s)))
9291                                            + 1,
9292                                            ffesymbol_text (s));
9293       TREE_TYPE (nameinit)
9294         = build_type_variant
9295         (build_array_type
9296          (char_type_node,
9297           build_range_type (integer_type_node,
9298                             integer_one_node,
9299                             build_int_2 (i, 0))),
9300          1, 0);
9301       TREE_CONSTANT (nameinit) = 1;
9302       TREE_STATIC (nameinit) = 1;
9303       nameinit = ffecom_1 (ADDR_EXPR,
9304                            build_pointer_type (TREE_TYPE (nameinit)),
9305                            nameinit);
9306
9307       addrinit = ffecom_arg_ptr_to_expr (expr, &typeinit);
9308
9309       dimsinit = ffecom_vardesc_dims_ (s);
9310
9311       if (typeinit == NULL_TREE)
9312         {
9313           ffeinfoBasictype bt = ffesymbol_basictype (s);
9314           ffeinfoKindtype kt = ffesymbol_kindtype (s);
9315           int tc = ffecom_f2c_typecode (bt, kt);
9316
9317           assert (tc != -1);
9318           typeinit = build_int_2 (tc, (tc < 0) ? -1 : 0);
9319         }
9320       else
9321         typeinit = ffecom_1 (NEGATE_EXPR, TREE_TYPE (typeinit), typeinit);
9322
9323       varinits = build_tree_list ((field = TYPE_FIELDS (vardesctype)),
9324                                   nameinit);
9325       TREE_CHAIN (varinits) = build_tree_list ((field = TREE_CHAIN (field)),
9326                                                addrinit);
9327       TREE_CHAIN (TREE_CHAIN (varinits))
9328         = build_tree_list ((field = TREE_CHAIN (field)), dimsinit);
9329       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (varinits)))
9330         = build_tree_list ((field = TREE_CHAIN (field)), typeinit);
9331
9332       varinits = build (CONSTRUCTOR, vardesctype, NULL_TREE, varinits);
9333       TREE_CONSTANT (varinits) = 1;
9334       TREE_STATIC (varinits) = 1;
9335
9336       finish_decl (var, varinits, FALSE);
9337
9338       var = ffecom_1 (ADDR_EXPR, build_pointer_type (vardesctype), var);
9339
9340       ffesymbol_hook (s).vardesc_tree = var;
9341     }
9342
9343   return ffesymbol_hook (s).vardesc_tree;
9344 }
9345
9346 static tree
9347 ffecom_vardesc_array_ (ffesymbol s)
9348 {
9349   ffebld b;
9350   tree list;
9351   tree item = NULL_TREE;
9352   tree var;
9353   int i;
9354   static int mynumber = 0;
9355
9356   for (i = 0, list = NULL_TREE, b = ffesymbol_namelist (s);
9357        b != NULL;
9358        b = ffebld_trail (b), ++i)
9359     {
9360       tree t;
9361
9362       t = ffecom_vardesc_ (ffebld_head (b));
9363
9364       if (list == NULL_TREE)
9365         list = item = build_tree_list (NULL_TREE, t);
9366       else
9367         {
9368           TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9369           item = TREE_CHAIN (item);
9370         }
9371     }
9372
9373   item = build_array_type (build_pointer_type (ffecom_type_vardesc_ ()),
9374                            build_range_type (integer_type_node,
9375                                              integer_one_node,
9376                                              build_int_2 (i, 0)));
9377   list = build (CONSTRUCTOR, item, NULL_TREE, list);
9378   TREE_CONSTANT (list) = 1;
9379   TREE_STATIC (list) = 1;
9380
9381   var = ffecom_get_invented_identifier ("__g77_vardesc_array_%d", mynumber++);
9382   var = build_decl (VAR_DECL, var, item);
9383   TREE_STATIC (var) = 1;
9384   DECL_INITIAL (var) = error_mark_node;
9385   var = start_decl (var, FALSE);
9386   finish_decl (var, list, FALSE);
9387
9388   return var;
9389 }
9390
9391 static tree
9392 ffecom_vardesc_dims_ (ffesymbol s)
9393 {
9394   if (ffesymbol_dims (s) == NULL)
9395     return convert (ffecom_f2c_ptr_to_ftnlen_type_node,
9396                     integer_zero_node);
9397
9398   {
9399     ffebld b;
9400     ffebld e;
9401     tree list;
9402     tree backlist;
9403     tree item = NULL_TREE;
9404     tree var;
9405     tree numdim;
9406     tree numelem;
9407     tree baseoff = NULL_TREE;
9408     static int mynumber = 0;
9409
9410     numdim = build_int_2 ((int) ffesymbol_rank (s), 0);
9411     TREE_TYPE (numdim) = ffecom_f2c_ftnlen_type_node;
9412
9413     numelem = ffecom_expr (ffesymbol_arraysize (s));
9414     TREE_TYPE (numelem) = ffecom_f2c_ftnlen_type_node;
9415
9416     list = NULL_TREE;
9417     backlist = NULL_TREE;
9418     for (b = ffesymbol_dims (s), e = ffesymbol_extents (s);
9419          b != NULL;
9420          b = ffebld_trail (b), e = ffebld_trail (e))
9421       {
9422         tree t;
9423         tree low;
9424         tree back;
9425
9426         if (ffebld_trail (b) == NULL)
9427           t = NULL_TREE;
9428         else
9429           {
9430             t = convert (ffecom_f2c_ftnlen_type_node,
9431                          ffecom_expr (ffebld_head (e)));
9432
9433             if (list == NULL_TREE)
9434               list = item = build_tree_list (NULL_TREE, t);
9435             else
9436               {
9437                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9438                 item = TREE_CHAIN (item);
9439               }
9440           }
9441
9442         if (ffebld_left (ffebld_head (b)) == NULL)
9443           low = ffecom_integer_one_node;
9444         else
9445           low = ffecom_expr (ffebld_left (ffebld_head (b)));
9446         low = convert (ffecom_f2c_ftnlen_type_node, low);
9447
9448         back = build_tree_list (low, t);
9449         TREE_CHAIN (back) = backlist;
9450         backlist = back;
9451       }
9452
9453     for (item = backlist; item != NULL_TREE; item = TREE_CHAIN (item))
9454       {
9455         if (TREE_VALUE (item) == NULL_TREE)
9456           baseoff = TREE_PURPOSE (item);
9457         else
9458           baseoff = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
9459                               TREE_PURPOSE (item),
9460                               ffecom_2 (MULT_EXPR,
9461                                         ffecom_f2c_ftnlen_type_node,
9462                                         TREE_VALUE (item),
9463                                         baseoff));
9464       }
9465
9466     /* backlist now dead, along with all TREE_PURPOSEs on it.  */
9467
9468     baseoff = build_tree_list (NULL_TREE, baseoff);
9469     TREE_CHAIN (baseoff) = list;
9470
9471     numelem = build_tree_list (NULL_TREE, numelem);
9472     TREE_CHAIN (numelem) = baseoff;
9473
9474     numdim = build_tree_list (NULL_TREE, numdim);
9475     TREE_CHAIN (numdim) = numelem;
9476
9477     item = build_array_type (ffecom_f2c_ftnlen_type_node,
9478                              build_range_type (integer_type_node,
9479                                                integer_zero_node,
9480                                                build_int_2
9481                                                ((int) ffesymbol_rank (s)
9482                                                 + 2, 0)));
9483     list = build (CONSTRUCTOR, item, NULL_TREE, numdim);
9484     TREE_CONSTANT (list) = 1;
9485     TREE_STATIC (list) = 1;
9486
9487     var = ffecom_get_invented_identifier ("__g77_dims_%d", mynumber++);
9488     var = build_decl (VAR_DECL, var, item);
9489     TREE_STATIC (var) = 1;
9490     DECL_INITIAL (var) = error_mark_node;
9491     var = start_decl (var, FALSE);
9492     finish_decl (var, list, FALSE);
9493
9494     var = ffecom_1 (ADDR_EXPR, build_pointer_type (item), var);
9495
9496     return var;
9497   }
9498 }
9499
9500 /* Essentially does a "fold (build1 (code, type, node))" while checking
9501    for certain housekeeping things.
9502
9503    NOTE: for building an ADDR_EXPR around a FUNCTION_DECL, use
9504    ffecom_1_fn instead.  */
9505
9506 tree
9507 ffecom_1 (enum tree_code code, tree type, tree node)
9508 {
9509   tree item;
9510
9511   if ((node == error_mark_node)
9512       || (type == error_mark_node))
9513     return error_mark_node;
9514
9515   if (code == ADDR_EXPR)
9516     {
9517       if (!mark_addressable (node))
9518         assert ("can't mark_addressable this node!" == NULL);
9519     }
9520
9521   switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9522     {
9523       tree realtype;
9524
9525     case REALPART_EXPR:
9526       item = build (COMPONENT_REF, type, node, TYPE_FIELDS (TREE_TYPE (node)));
9527       break;
9528
9529     case IMAGPART_EXPR:
9530       item = build (COMPONENT_REF, type, node, TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (node))));
9531       break;
9532
9533
9534     case NEGATE_EXPR:
9535       if (TREE_CODE (type) != RECORD_TYPE)
9536         {
9537           item = build1 (code, type, node);
9538           break;
9539         }
9540       node = ffecom_stabilize_aggregate_ (node);
9541       realtype = TREE_TYPE (TYPE_FIELDS (type));
9542       item =
9543         ffecom_2 (COMPLEX_EXPR, type,
9544                   ffecom_1 (NEGATE_EXPR, realtype,
9545                             ffecom_1 (REALPART_EXPR, realtype,
9546                                       node)),
9547                   ffecom_1 (NEGATE_EXPR, realtype,
9548                             ffecom_1 (IMAGPART_EXPR, realtype,
9549                                       node)));
9550       break;
9551
9552     default:
9553       item = build1 (code, type, node);
9554       break;
9555     }
9556
9557   if (TREE_SIDE_EFFECTS (node))
9558     TREE_SIDE_EFFECTS (item) = 1;
9559   if (code == ADDR_EXPR && staticp (node))
9560     TREE_CONSTANT (item) = 1;
9561   else if (code == INDIRECT_REF)
9562     TREE_READONLY (item) = TYPE_READONLY (type);
9563   return fold (item);
9564 }
9565
9566 /* Like ffecom_1 (ADDR_EXPR, TREE_TYPE (node), node), except
9567    handles TREE_CODE (node) == FUNCTION_DECL.  In particular,
9568    does not set TREE_ADDRESSABLE (because calling an inline
9569    function does not mean the function needs to be separately
9570    compiled).  */
9571
9572 tree
9573 ffecom_1_fn (tree node)
9574 {
9575   tree item;
9576   tree type;
9577
9578   if (node == error_mark_node)
9579     return error_mark_node;
9580
9581   type = build_type_variant (TREE_TYPE (node),
9582                              TREE_READONLY (node),
9583                              TREE_THIS_VOLATILE (node));
9584   item = build1 (ADDR_EXPR,
9585                  build_pointer_type (type), node);
9586   if (TREE_SIDE_EFFECTS (node))
9587     TREE_SIDE_EFFECTS (item) = 1;
9588   if (staticp (node))
9589     TREE_CONSTANT (item) = 1;
9590   return fold (item);
9591 }
9592
9593 /* Essentially does a "fold (build (code, type, node1, node2))" while
9594    checking for certain housekeeping things.  */
9595
9596 tree
9597 ffecom_2 (enum tree_code code, tree type, tree node1,
9598           tree node2)
9599 {
9600   tree item;
9601
9602   if ((node1 == error_mark_node)
9603       || (node2 == error_mark_node)
9604       || (type == error_mark_node))
9605     return error_mark_node;
9606
9607   switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9608     {
9609       tree a, b, c, d, realtype;
9610
9611     case CONJ_EXPR:
9612       assert ("no CONJ_EXPR support yet" == NULL);
9613       return error_mark_node;
9614
9615     case COMPLEX_EXPR:
9616       item = build_tree_list (TYPE_FIELDS (type), node1);
9617       TREE_CHAIN (item) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), node2);
9618       item = build (CONSTRUCTOR, type, NULL_TREE, item);
9619       break;
9620
9621     case PLUS_EXPR:
9622       if (TREE_CODE (type) != RECORD_TYPE)
9623         {
9624           item = build (code, type, node1, node2);
9625           break;
9626         }
9627       node1 = ffecom_stabilize_aggregate_ (node1);
9628       node2 = ffecom_stabilize_aggregate_ (node2);
9629       realtype = TREE_TYPE (TYPE_FIELDS (type));
9630       item =
9631         ffecom_2 (COMPLEX_EXPR, type,
9632                   ffecom_2 (PLUS_EXPR, realtype,
9633                             ffecom_1 (REALPART_EXPR, realtype,
9634                                       node1),
9635                             ffecom_1 (REALPART_EXPR, realtype,
9636                                       node2)),
9637                   ffecom_2 (PLUS_EXPR, realtype,
9638                             ffecom_1 (IMAGPART_EXPR, realtype,
9639                                       node1),
9640                             ffecom_1 (IMAGPART_EXPR, realtype,
9641                                       node2)));
9642       break;
9643
9644     case MINUS_EXPR:
9645       if (TREE_CODE (type) != RECORD_TYPE)
9646         {
9647           item = build (code, type, node1, node2);
9648           break;
9649         }
9650       node1 = ffecom_stabilize_aggregate_ (node1);
9651       node2 = ffecom_stabilize_aggregate_ (node2);
9652       realtype = TREE_TYPE (TYPE_FIELDS (type));
9653       item =
9654         ffecom_2 (COMPLEX_EXPR, type,
9655                   ffecom_2 (MINUS_EXPR, realtype,
9656                             ffecom_1 (REALPART_EXPR, realtype,
9657                                       node1),
9658                             ffecom_1 (REALPART_EXPR, realtype,
9659                                       node2)),
9660                   ffecom_2 (MINUS_EXPR, realtype,
9661                             ffecom_1 (IMAGPART_EXPR, realtype,
9662                                       node1),
9663                             ffecom_1 (IMAGPART_EXPR, realtype,
9664                                       node2)));
9665       break;
9666
9667     case MULT_EXPR:
9668       if (TREE_CODE (type) != RECORD_TYPE)
9669         {
9670           item = build (code, type, node1, node2);
9671           break;
9672         }
9673       node1 = ffecom_stabilize_aggregate_ (node1);
9674       node2 = ffecom_stabilize_aggregate_ (node2);
9675       realtype = TREE_TYPE (TYPE_FIELDS (type));
9676       a = save_expr (ffecom_1 (REALPART_EXPR, realtype,
9677                                node1));
9678       b = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
9679                                node1));
9680       c = save_expr (ffecom_1 (REALPART_EXPR, realtype,
9681                                node2));
9682       d = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
9683                                node2));
9684       item =
9685         ffecom_2 (COMPLEX_EXPR, type,
9686                   ffecom_2 (MINUS_EXPR, realtype,
9687                             ffecom_2 (MULT_EXPR, realtype,
9688                                       a,
9689                                       c),
9690                             ffecom_2 (MULT_EXPR, realtype,
9691                                       b,
9692                                       d)),
9693                   ffecom_2 (PLUS_EXPR, realtype,
9694                             ffecom_2 (MULT_EXPR, realtype,
9695                                       a,
9696                                       d),
9697                             ffecom_2 (MULT_EXPR, realtype,
9698                                       c,
9699                                       b)));
9700       break;
9701
9702     case EQ_EXPR:
9703       if ((TREE_CODE (node1) != RECORD_TYPE)
9704           && (TREE_CODE (node2) != RECORD_TYPE))
9705         {
9706           item = build (code, type, node1, node2);
9707           break;
9708         }
9709       assert (TREE_CODE (node1) == RECORD_TYPE);
9710       assert (TREE_CODE (node2) == RECORD_TYPE);
9711       node1 = ffecom_stabilize_aggregate_ (node1);
9712       node2 = ffecom_stabilize_aggregate_ (node2);
9713       realtype = TREE_TYPE (TYPE_FIELDS (type));
9714       item =
9715         ffecom_2 (TRUTH_ANDIF_EXPR, type,
9716                   ffecom_2 (code, type,
9717                             ffecom_1 (REALPART_EXPR, realtype,
9718                                       node1),
9719                             ffecom_1 (REALPART_EXPR, realtype,
9720                                       node2)),
9721                   ffecom_2 (code, type,
9722                             ffecom_1 (IMAGPART_EXPR, realtype,
9723                                       node1),
9724                             ffecom_1 (IMAGPART_EXPR, realtype,
9725                                       node2)));
9726       break;
9727
9728     case NE_EXPR:
9729       if ((TREE_CODE (node1) != RECORD_TYPE)
9730           && (TREE_CODE (node2) != RECORD_TYPE))
9731         {
9732           item = build (code, type, node1, node2);
9733           break;
9734         }
9735       assert (TREE_CODE (node1) == RECORD_TYPE);
9736       assert (TREE_CODE (node2) == RECORD_TYPE);
9737       node1 = ffecom_stabilize_aggregate_ (node1);
9738       node2 = ffecom_stabilize_aggregate_ (node2);
9739       realtype = TREE_TYPE (TYPE_FIELDS (type));
9740       item =
9741         ffecom_2 (TRUTH_ORIF_EXPR, type,
9742                   ffecom_2 (code, type,
9743                             ffecom_1 (REALPART_EXPR, realtype,
9744                                       node1),
9745                             ffecom_1 (REALPART_EXPR, realtype,
9746                                       node2)),
9747                   ffecom_2 (code, type,
9748                             ffecom_1 (IMAGPART_EXPR, realtype,
9749                                       node1),
9750                             ffecom_1 (IMAGPART_EXPR, realtype,
9751                                       node2)));
9752       break;
9753
9754     default:
9755       item = build (code, type, node1, node2);
9756       break;
9757     }
9758
9759   if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2))
9760     TREE_SIDE_EFFECTS (item) = 1;
9761   return fold (item);
9762 }
9763
9764 /* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint
9765
9766    ffesymbol s;  // the ENTRY point itself
9767    if (ffecom_2pass_advise_entrypoint(s))
9768        // the ENTRY point has been accepted
9769
9770    Does whatever compiler needs to do when it learns about the entrypoint,
9771    like determine the return type of the master function, count the
9772    number of entrypoints, etc.  Returns FALSE if the return type is
9773    not compatible with the return type(s) of other entrypoint(s).
9774
9775    NOTE: for every call to this fn that returns TRUE, _do_entrypoint must
9776    later (after _finish_progunit) be called with the same entrypoint(s)
9777    as passed to this fn for which TRUE was returned.
9778
9779    03-Jan-92  JCB  2.0
9780       Return FALSE if the return type conflicts with previous entrypoints.  */
9781
9782 bool
9783 ffecom_2pass_advise_entrypoint (ffesymbol entry)
9784 {
9785   ffebld list;                  /* opITEM. */
9786   ffebld mlist;                 /* opITEM. */
9787   ffebld plist;                 /* opITEM. */
9788   ffebld arg;                   /* ffebld_head(opITEM). */
9789   ffebld item;                  /* opITEM. */
9790   ffesymbol s;                  /* ffebld_symter(arg). */
9791   ffeinfoBasictype bt = ffesymbol_basictype (entry);
9792   ffeinfoKindtype kt = ffesymbol_kindtype (entry);
9793   ffetargetCharacterSize size = ffesymbol_size (entry);
9794   bool ok;
9795
9796   if (ffecom_num_entrypoints_ == 0)
9797     {                           /* First entrypoint, make list of main
9798                                    arglist's dummies. */
9799       assert (ffecom_primary_entry_ != NULL);
9800
9801       ffecom_master_bt_ = ffesymbol_basictype (ffecom_primary_entry_);
9802       ffecom_master_kt_ = ffesymbol_kindtype (ffecom_primary_entry_);
9803       ffecom_master_size_ = ffesymbol_size (ffecom_primary_entry_);
9804
9805       for (plist = NULL, list = ffesymbol_dummyargs (ffecom_primary_entry_);
9806            list != NULL;
9807            list = ffebld_trail (list))
9808         {
9809           arg = ffebld_head (list);
9810           if (ffebld_op (arg) != FFEBLD_opSYMTER)
9811             continue;           /* Alternate return or some such thing. */
9812           item = ffebld_new_item (arg, NULL);
9813           if (plist == NULL)
9814             ffecom_master_arglist_ = item;
9815           else
9816             ffebld_set_trail (plist, item);
9817           plist = item;
9818         }
9819     }
9820
9821   /* If necessary, scan entry arglist for alternate returns.  Do this scan
9822      apparently redundantly (it's done below to UNIONize the arglists) so
9823      that we don't complain about RETURN 1 if an offending ENTRY is the only
9824      one with an alternate return.  */
9825
9826   if (!ffecom_is_altreturning_)
9827     {
9828       for (list = ffesymbol_dummyargs (entry);
9829            list != NULL;
9830            list = ffebld_trail (list))
9831         {
9832           arg = ffebld_head (list);
9833           if (ffebld_op (arg) == FFEBLD_opSTAR)
9834             {
9835               ffecom_is_altreturning_ = TRUE;
9836               break;
9837             }
9838         }
9839     }
9840
9841   /* Now check type compatibility. */
9842
9843   switch (ffecom_master_bt_)
9844     {
9845     case FFEINFO_basictypeNONE:
9846       ok = (bt != FFEINFO_basictypeCHARACTER);
9847       break;
9848
9849     case FFEINFO_basictypeCHARACTER:
9850       ok
9851         = (bt == FFEINFO_basictypeCHARACTER)
9852         && (kt == ffecom_master_kt_)
9853         && (size == ffecom_master_size_);
9854       break;
9855
9856     case FFEINFO_basictypeANY:
9857       return FALSE;             /* Just don't bother. */
9858
9859     default:
9860       if (bt == FFEINFO_basictypeCHARACTER)
9861         {
9862           ok = FALSE;
9863           break;
9864         }
9865       ok = TRUE;
9866       if ((bt != ffecom_master_bt_) || (kt != ffecom_master_kt_))
9867         {
9868           ffecom_master_bt_ = FFEINFO_basictypeNONE;
9869           ffecom_master_kt_ = FFEINFO_kindtypeNONE;
9870         }
9871       break;
9872     }
9873
9874   if (!ok)
9875     {
9876       ffebad_start (FFEBAD_ENTRY_CONFLICTS);
9877       ffest_ffebad_here_current_stmt (0);
9878       ffebad_finish ();
9879       return FALSE;             /* Can't handle entrypoint. */
9880     }
9881
9882   /* Entrypoint type compatible with previous types. */
9883
9884   ++ffecom_num_entrypoints_;
9885
9886   /* Master-arg-list = UNION(Master-arg-list,entry-arg-list). */
9887
9888   for (list = ffesymbol_dummyargs (entry);
9889        list != NULL;
9890        list = ffebld_trail (list))
9891     {
9892       arg = ffebld_head (list);
9893       if (ffebld_op (arg) != FFEBLD_opSYMTER)
9894         continue;               /* Alternate return or some such thing. */
9895       s = ffebld_symter (arg);
9896       for (plist = NULL, mlist = ffecom_master_arglist_;
9897            mlist != NULL;
9898            plist = mlist, mlist = ffebld_trail (mlist))
9899         {                       /* plist points to previous item for easy
9900                                    appending of arg. */
9901           if (ffebld_symter (ffebld_head (mlist)) == s)
9902             break;              /* Already have this arg in the master list. */
9903         }
9904       if (mlist != NULL)
9905         continue;               /* Already have this arg in the master list. */
9906
9907       /* Append this arg to the master list. */
9908
9909       item = ffebld_new_item (arg, NULL);
9910       if (plist == NULL)
9911         ffecom_master_arglist_ = item;
9912       else
9913         ffebld_set_trail (plist, item);
9914     }
9915
9916   return TRUE;
9917 }
9918
9919 /* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint
9920
9921    ffesymbol s;  // the ENTRY point itself
9922    ffecom_2pass_do_entrypoint(s);
9923
9924    Does whatever compiler needs to do to make the entrypoint actually
9925    happen.  Must be called for each entrypoint after
9926    ffecom_finish_progunit is called.  */
9927
9928 void
9929 ffecom_2pass_do_entrypoint (ffesymbol entry)
9930 {
9931   static int mfn_num = 0;
9932   static int ent_num;
9933
9934   if (mfn_num != ffecom_num_fns_)
9935     {                           /* First entrypoint for this program unit. */
9936       ent_num = 1;
9937       mfn_num = ffecom_num_fns_;
9938       ffecom_do_entry_ (ffecom_primary_entry_, 0);
9939     }
9940   else
9941     ++ent_num;
9942
9943   --ffecom_num_entrypoints_;
9944
9945   ffecom_do_entry_ (entry, ent_num);
9946 }
9947
9948 /* Essentially does a "fold (build (code, type, node1, node2))" while
9949    checking for certain housekeeping things.  Always sets
9950    TREE_SIDE_EFFECTS.  */
9951
9952 tree
9953 ffecom_2s (enum tree_code code, tree type, tree node1,
9954            tree node2)
9955 {
9956   tree item;
9957
9958   if ((node1 == error_mark_node)
9959       || (node2 == error_mark_node)
9960       || (type == error_mark_node))
9961     return error_mark_node;
9962
9963   item = build (code, type, node1, node2);
9964   TREE_SIDE_EFFECTS (item) = 1;
9965   return fold (item);
9966 }
9967
9968 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
9969    checking for certain housekeeping things.  */
9970
9971 tree
9972 ffecom_3 (enum tree_code code, tree type, tree node1,
9973           tree node2, tree node3)
9974 {
9975   tree item;
9976
9977   if ((node1 == error_mark_node)
9978       || (node2 == error_mark_node)
9979       || (node3 == error_mark_node)
9980       || (type == error_mark_node))
9981     return error_mark_node;
9982
9983   item = build (code, type, node1, node2, node3);
9984   if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2)
9985       || (node3 != NULL_TREE && TREE_SIDE_EFFECTS (node3)))
9986     TREE_SIDE_EFFECTS (item) = 1;
9987   return fold (item);
9988 }
9989
9990 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
9991    checking for certain housekeeping things.  Always sets
9992    TREE_SIDE_EFFECTS.  */
9993
9994 tree
9995 ffecom_3s (enum tree_code code, tree type, tree node1,
9996            tree node2, tree node3)
9997 {
9998   tree item;
9999
10000   if ((node1 == error_mark_node)
10001       || (node2 == error_mark_node)
10002       || (node3 == error_mark_node)
10003       || (type == error_mark_node))
10004     return error_mark_node;
10005
10006   item = build (code, type, node1, node2, node3);
10007   TREE_SIDE_EFFECTS (item) = 1;
10008   return fold (item);
10009 }
10010
10011 /* ffecom_arg_expr -- Transform argument expr into gcc tree
10012
10013    See use by ffecom_list_expr.
10014
10015    If expression is NULL, returns an integer zero tree.  If it is not
10016    a CHARACTER expression, returns whatever ffecom_expr
10017    returns and sets the length return value to NULL_TREE.  Otherwise
10018    generates code to evaluate the character expression, returns the proper
10019    pointer to the result, but does NOT set the length return value to a tree
10020    that specifies the length of the result.  (In other words, the length
10021    variable is always set to NULL_TREE, because a length is never passed.)
10022
10023    21-Dec-91  JCB  1.1
10024       Don't set returned length, since nobody needs it (yet; someday if
10025       we allow CHARACTER*(*) dummies to statement functions, we'll need
10026       it).  */
10027
10028 tree
10029 ffecom_arg_expr (ffebld expr, tree *length)
10030 {
10031   tree ign;
10032
10033   *length = NULL_TREE;
10034
10035   if (expr == NULL)
10036     return integer_zero_node;
10037
10038   if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10039     return ffecom_expr (expr);
10040
10041   return ffecom_arg_ptr_to_expr (expr, &ign);
10042 }
10043
10044 /* Transform expression into constant argument-pointer-to-expression tree.
10045
10046    If the expression can be transformed into a argument-pointer-to-expression
10047    tree that is constant, that is done, and the tree returned.  Else
10048    NULL_TREE is returned.
10049
10050    That way, a caller can attempt to provide compile-time initialization
10051    of a variable and, if that fails, *then* choose to start a new block
10052    and resort to using temporaries, as appropriate.  */
10053
10054 tree
10055 ffecom_arg_ptr_to_const_expr (ffebld expr, tree *length)
10056 {
10057   if (! expr)
10058     return integer_zero_node;
10059
10060   if (ffebld_op (expr) == FFEBLD_opANY)
10061     {
10062       if (length)
10063         *length = error_mark_node;
10064       return error_mark_node;
10065     }
10066
10067   if (ffebld_arity (expr) == 0
10068       && (ffebld_op (expr) != FFEBLD_opSYMTER
10069           || ffebld_where (expr) == FFEINFO_whereCOMMON
10070           || ffebld_where (expr) == FFEINFO_whereGLOBAL
10071           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10072     {
10073       tree t;
10074
10075       t = ffecom_arg_ptr_to_expr (expr, length);
10076       assert (TREE_CONSTANT (t));
10077       assert (! length || TREE_CONSTANT (*length));
10078       return t;
10079     }
10080
10081   if (length
10082       && ffebld_size (expr) != FFETARGET_charactersizeNONE)
10083     *length = build_int_2 (ffebld_size (expr), 0);
10084   else if (length)
10085     *length = NULL_TREE;
10086   return NULL_TREE;
10087 }
10088
10089 /* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree
10090
10091    See use by ffecom_list_ptr_to_expr.
10092
10093    If expression is NULL, returns an integer zero tree.  If it is not
10094    a CHARACTER expression, returns whatever ffecom_ptr_to_expr
10095    returns and sets the length return value to NULL_TREE.  Otherwise
10096    generates code to evaluate the character expression, returns the proper
10097    pointer to the result, AND sets the length return value to a tree that
10098    specifies the length of the result.
10099
10100    If the length argument is NULL, this is a slightly special
10101    case of building a FORMAT expression, that is, an expression that
10102    will be used at run time without regard to length.  For the current
10103    implementation, which uses the libf2c library, this means it is nice
10104    to append a null byte to the end of the expression, where feasible,
10105    to make sure any diagnostic about the FORMAT string terminates at
10106    some useful point.
10107
10108    For now, treat %REF(char-expr) as the same as char-expr with a NULL
10109    length argument.  This might even be seen as a feature, if a null
10110    byte can always be appended.  */
10111
10112 tree
10113 ffecom_arg_ptr_to_expr (ffebld expr, tree *length)
10114 {
10115   tree item;
10116   tree ign_length;
10117   ffecomConcatList_ catlist;
10118
10119   if (length != NULL)
10120     *length = NULL_TREE;
10121
10122   if (expr == NULL)
10123     return integer_zero_node;
10124
10125   switch (ffebld_op (expr))
10126     {
10127     case FFEBLD_opPERCENT_VAL:
10128       if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10129         return ffecom_expr (ffebld_left (expr));
10130       {
10131         tree temp_exp;
10132         tree temp_length;
10133
10134         temp_exp = ffecom_arg_ptr_to_expr (ffebld_left (expr), &temp_length);
10135         if (temp_exp == error_mark_node)
10136           return error_mark_node;
10137
10138         return ffecom_1 (INDIRECT_REF, TREE_TYPE (TREE_TYPE (temp_exp)),
10139                          temp_exp);
10140       }
10141
10142     case FFEBLD_opPERCENT_REF:
10143       if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10144         return ffecom_ptr_to_expr (ffebld_left (expr));
10145       if (length != NULL)
10146         {
10147           ign_length = NULL_TREE;
10148           length = &ign_length;
10149         }
10150       expr = ffebld_left (expr);
10151       break;
10152
10153     case FFEBLD_opPERCENT_DESCR:
10154       switch (ffeinfo_basictype (ffebld_info (expr)))
10155         {
10156 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10157         case FFEINFO_basictypeHOLLERITH:
10158 #endif
10159         case FFEINFO_basictypeCHARACTER:
10160           break;                /* Passed by descriptor anyway. */
10161
10162         default:
10163           item = ffecom_ptr_to_expr (expr);
10164           if (item != error_mark_node)
10165             *length = TYPE_SIZE (TREE_TYPE (TREE_TYPE (item)));
10166           break;
10167         }
10168       break;
10169
10170     default:
10171       break;
10172     }
10173
10174 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10175   if ((ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeHOLLERITH)
10176       && (length != NULL))
10177     {                           /* Pass Hollerith by descriptor. */
10178       ffetargetHollerith h;
10179
10180       assert (ffebld_op (expr) == FFEBLD_opCONTER);
10181       h = ffebld_cu_val_hollerith (ffebld_constant_union
10182                                    (ffebld_conter (expr)));
10183       *length
10184         = build_int_2 (h.length, 0);
10185       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10186     }
10187 #endif
10188
10189   if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10190     return ffecom_ptr_to_expr (expr);
10191
10192   assert (ffeinfo_kindtype (ffebld_info (expr))
10193           == FFEINFO_kindtypeCHARACTER1);
10194
10195   while (ffebld_op (expr) == FFEBLD_opPAREN)
10196     expr = ffebld_left (expr);
10197
10198   catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
10199   switch (ffecom_concat_list_count_ (catlist))
10200     {
10201     case 0:                     /* Shouldn't happen, but in case it does... */
10202       if (length != NULL)
10203         {
10204           *length = ffecom_f2c_ftnlen_zero_node;
10205           TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10206         }
10207       ffecom_concat_list_kill_ (catlist);
10208       return null_pointer_node;
10209
10210     case 1:                     /* The (fairly) easy case. */
10211       if (length == NULL)
10212         ffecom_char_args_with_null_ (&item, &ign_length,
10213                                      ffecom_concat_list_expr_ (catlist, 0));
10214       else
10215         ffecom_char_args_ (&item, length,
10216                            ffecom_concat_list_expr_ (catlist, 0));
10217       ffecom_concat_list_kill_ (catlist);
10218       assert (item != NULL_TREE);
10219       return item;
10220
10221     default:                    /* Must actually concatenate things. */
10222       break;
10223     }
10224
10225   {
10226     int count = ffecom_concat_list_count_ (catlist);
10227     int i;
10228     tree lengths;
10229     tree items;
10230     tree length_array;
10231     tree item_array;
10232     tree citem;
10233     tree clength;
10234     tree temporary;
10235     tree num;
10236     tree known_length;
10237     ffetargetCharacterSize sz;
10238
10239     sz = ffecom_concat_list_maxlen_ (catlist);
10240     /* ~~Kludge! */
10241     assert (sz != FFETARGET_charactersizeNONE);
10242
10243 #ifdef HOHO
10244     length_array
10245       = lengths
10246       = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
10247                              FFETARGET_charactersizeNONE, count, TRUE);
10248     item_array
10249       = items
10250       = ffecom_push_tempvar (ffecom_f2c_address_type_node,
10251                              FFETARGET_charactersizeNONE, count, TRUE);
10252     temporary = ffecom_push_tempvar (char_type_node,
10253                                      sz, -1, TRUE);
10254 #else
10255     {
10256       tree hook;
10257
10258       hook = ffebld_nonter_hook (expr);
10259       assert (hook);
10260       assert (TREE_CODE (hook) == TREE_VEC);
10261       assert (TREE_VEC_LENGTH (hook) == 3);
10262       length_array = lengths = TREE_VEC_ELT (hook, 0);
10263       item_array = items = TREE_VEC_ELT (hook, 1);
10264       temporary = TREE_VEC_ELT (hook, 2);
10265     }
10266 #endif
10267
10268     known_length = ffecom_f2c_ftnlen_zero_node;
10269
10270     for (i = 0; i < count; ++i)
10271       {
10272         if ((i == count)
10273             && (length == NULL))
10274           ffecom_char_args_with_null_ (&citem, &clength,
10275                                        ffecom_concat_list_expr_ (catlist, i));
10276         else
10277           ffecom_char_args_ (&citem, &clength,
10278                              ffecom_concat_list_expr_ (catlist, i));
10279         if ((citem == error_mark_node)
10280             || (clength == error_mark_node))
10281           {
10282             ffecom_concat_list_kill_ (catlist);
10283             *length = error_mark_node;
10284             return error_mark_node;
10285           }
10286
10287         items
10288           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
10289                       ffecom_modify (void_type_node,
10290                                      ffecom_2 (ARRAY_REF,
10291                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
10292                                                item_array,
10293                                                build_int_2 (i, 0)),
10294                                      citem),
10295                       items);
10296         clength = ffecom_save_tree (clength);
10297         if (length != NULL)
10298           known_length
10299             = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
10300                         known_length,
10301                         clength);
10302         lengths
10303           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
10304                       ffecom_modify (void_type_node,
10305                                      ffecom_2 (ARRAY_REF,
10306                    TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
10307                                                length_array,
10308                                                build_int_2 (i, 0)),
10309                                      clength),
10310                       lengths);
10311       }
10312
10313     temporary = ffecom_1 (ADDR_EXPR,
10314                           build_pointer_type (TREE_TYPE (temporary)),
10315                           temporary);
10316
10317     item = build_tree_list (NULL_TREE, temporary);
10318     TREE_CHAIN (item)
10319       = build_tree_list (NULL_TREE,
10320                          ffecom_1 (ADDR_EXPR,
10321                                    build_pointer_type (TREE_TYPE (items)),
10322                                    items));
10323     TREE_CHAIN (TREE_CHAIN (item))
10324       = build_tree_list (NULL_TREE,
10325                          ffecom_1 (ADDR_EXPR,
10326                                    build_pointer_type (TREE_TYPE (lengths)),
10327                                    lengths));
10328     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
10329       = build_tree_list
10330         (NULL_TREE,
10331          ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
10332                    convert (ffecom_f2c_ftnlen_type_node,
10333                             build_int_2 (count, 0))));
10334     num = build_int_2 (sz, 0);
10335     TREE_TYPE (num) = ffecom_f2c_ftnlen_type_node;
10336     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item))))
10337       = build_tree_list (NULL_TREE, num);
10338
10339     item = ffecom_call_gfrt (FFECOM_gfrtCAT, item, NULL_TREE);
10340     TREE_SIDE_EFFECTS (item) = 1;
10341     item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (temporary),
10342                      item,
10343                      temporary);
10344
10345     if (length != NULL)
10346       *length = known_length;
10347   }
10348
10349   ffecom_concat_list_kill_ (catlist);
10350   assert (item != NULL_TREE);
10351   return item;
10352 }
10353
10354 /* Generate call to run-time function.
10355
10356    The first arg is the GNU Fortran Run-Time function index, the second
10357    arg is the list of arguments to pass to it.  Returned is the expression
10358    (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the
10359    result (which may be void).  */
10360
10361 tree
10362 ffecom_call_gfrt (ffecomGfrt ix, tree args, tree hook)
10363 {
10364   return ffecom_call_ (ffecom_gfrt_tree_ (ix),
10365                        ffecom_gfrt_kindtype (ix),
10366                        ffe_is_f2c_library () && ffecom_gfrt_complex_[ix],
10367                        NULL_TREE, args, NULL_TREE, NULL,
10368                        NULL, NULL_TREE, TRUE, hook);
10369 }
10370
10371 /* Transform constant-union to tree.  */
10372
10373 tree
10374 ffecom_constantunion (ffebldConstantUnion *cu, ffeinfoBasictype bt,
10375                       ffeinfoKindtype kt, tree tree_type)
10376 {
10377   tree item;
10378
10379   switch (bt)
10380     {
10381     case FFEINFO_basictypeINTEGER:
10382       {
10383         int val;
10384
10385         switch (kt)
10386           {
10387 #if FFETARGET_okINTEGER1
10388           case FFEINFO_kindtypeINTEGER1:
10389             val = ffebld_cu_val_integer1 (*cu);
10390             break;
10391 #endif
10392
10393 #if FFETARGET_okINTEGER2
10394           case FFEINFO_kindtypeINTEGER2:
10395             val = ffebld_cu_val_integer2 (*cu);
10396             break;
10397 #endif
10398
10399 #if FFETARGET_okINTEGER3
10400           case FFEINFO_kindtypeINTEGER3:
10401             val = ffebld_cu_val_integer3 (*cu);
10402             break;
10403 #endif
10404
10405 #if FFETARGET_okINTEGER4
10406           case FFEINFO_kindtypeINTEGER4:
10407             val = ffebld_cu_val_integer4 (*cu);
10408             break;
10409 #endif
10410
10411           default:
10412             assert ("bad INTEGER constant kind type" == NULL);
10413             /* Fall through. */
10414           case FFEINFO_kindtypeANY:
10415             return error_mark_node;
10416           }
10417         item = build_int_2 (val, (val < 0) ? -1 : 0);
10418         TREE_TYPE (item) = tree_type;
10419       }
10420       break;
10421
10422     case FFEINFO_basictypeLOGICAL:
10423       {
10424         int val;
10425
10426         switch (kt)
10427           {
10428 #if FFETARGET_okLOGICAL1
10429           case FFEINFO_kindtypeLOGICAL1:
10430             val = ffebld_cu_val_logical1 (*cu);
10431             break;
10432 #endif
10433
10434 #if FFETARGET_okLOGICAL2
10435           case FFEINFO_kindtypeLOGICAL2:
10436             val = ffebld_cu_val_logical2 (*cu);
10437             break;
10438 #endif
10439
10440 #if FFETARGET_okLOGICAL3
10441           case FFEINFO_kindtypeLOGICAL3:
10442             val = ffebld_cu_val_logical3 (*cu);
10443             break;
10444 #endif
10445
10446 #if FFETARGET_okLOGICAL4
10447           case FFEINFO_kindtypeLOGICAL4:
10448             val = ffebld_cu_val_logical4 (*cu);
10449             break;
10450 #endif
10451
10452           default:
10453             assert ("bad LOGICAL constant kind type" == NULL);
10454             /* Fall through. */
10455           case FFEINFO_kindtypeANY:
10456             return error_mark_node;
10457           }
10458         item = build_int_2 (val, (val < 0) ? -1 : 0);
10459         TREE_TYPE (item) = tree_type;
10460       }
10461       break;
10462
10463     case FFEINFO_basictypeREAL:
10464       {
10465         REAL_VALUE_TYPE val;
10466
10467         switch (kt)
10468           {
10469 #if FFETARGET_okREAL1
10470           case FFEINFO_kindtypeREAL1:
10471             val = ffetarget_value_real1 (ffebld_cu_val_real1 (*cu));
10472             break;
10473 #endif
10474
10475 #if FFETARGET_okREAL2
10476           case FFEINFO_kindtypeREAL2:
10477             val = ffetarget_value_real2 (ffebld_cu_val_real2 (*cu));
10478             break;
10479 #endif
10480
10481 #if FFETARGET_okREAL3
10482           case FFEINFO_kindtypeREAL3:
10483             val = ffetarget_value_real3 (ffebld_cu_val_real3 (*cu));
10484             break;
10485 #endif
10486
10487 #if FFETARGET_okREAL4
10488           case FFEINFO_kindtypeREAL4:
10489             val = ffetarget_value_real4 (ffebld_cu_val_real4 (*cu));
10490             break;
10491 #endif
10492
10493           default:
10494             assert ("bad REAL constant kind type" == NULL);
10495             /* Fall through. */
10496           case FFEINFO_kindtypeANY:
10497             return error_mark_node;
10498           }
10499         item = build_real (tree_type, val);
10500       }
10501       break;
10502
10503     case FFEINFO_basictypeCOMPLEX:
10504       {
10505         REAL_VALUE_TYPE real;
10506         REAL_VALUE_TYPE imag;
10507         tree el_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
10508
10509         switch (kt)
10510           {
10511 #if FFETARGET_okCOMPLEX1
10512           case FFEINFO_kindtypeREAL1:
10513             real = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).real);
10514             imag = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).imaginary);
10515             break;
10516 #endif
10517
10518 #if FFETARGET_okCOMPLEX2
10519           case FFEINFO_kindtypeREAL2:
10520             real = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).real);
10521             imag = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).imaginary);
10522             break;
10523 #endif
10524
10525 #if FFETARGET_okCOMPLEX3
10526           case FFEINFO_kindtypeREAL3:
10527             real = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).real);
10528             imag = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).imaginary);
10529             break;
10530 #endif
10531
10532 #if FFETARGET_okCOMPLEX4
10533           case FFEINFO_kindtypeREAL4:
10534             real = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).real);
10535             imag = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).imaginary);
10536             break;
10537 #endif
10538
10539           default:
10540             assert ("bad REAL constant kind type" == NULL);
10541             /* Fall through. */
10542           case FFEINFO_kindtypeANY:
10543             return error_mark_node;
10544           }
10545         item = ffecom_build_complex_constant_ (tree_type,
10546                                                build_real (el_type, real),
10547                                                build_real (el_type, imag));
10548       }
10549       break;
10550
10551     case FFEINFO_basictypeCHARACTER:
10552       {                         /* Happens only in DATA and similar contexts. */
10553         ffetargetCharacter1 val;
10554
10555         switch (kt)
10556           {
10557 #if FFETARGET_okCHARACTER1
10558           case FFEINFO_kindtypeLOGICAL1:
10559             val = ffebld_cu_val_character1 (*cu);
10560             break;
10561 #endif
10562
10563           default:
10564             assert ("bad CHARACTER constant kind type" == NULL);
10565             /* Fall through. */
10566           case FFEINFO_kindtypeANY:
10567             return error_mark_node;
10568           }
10569         item = build_string (ffetarget_length_character1 (val),
10570                              ffetarget_text_character1 (val));
10571         TREE_TYPE (item)
10572           = build_type_variant (build_array_type (char_type_node,
10573                                                   build_range_type
10574                                                   (integer_type_node,
10575                                                    integer_one_node,
10576                                                    build_int_2
10577                                                 (ffetarget_length_character1
10578                                                  (val), 0))),
10579                                 1, 0);
10580       }
10581       break;
10582
10583     case FFEINFO_basictypeHOLLERITH:
10584       {
10585         ffetargetHollerith h;
10586
10587         h = ffebld_cu_val_hollerith (*cu);
10588
10589         /* If not at least as wide as default INTEGER, widen it.  */
10590         if (h.length >= FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE)
10591           item = build_string (h.length, h.text);
10592         else
10593           {
10594             char str[FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE];
10595
10596             memcpy (str, h.text, h.length);
10597             memset (&str[h.length], ' ',
10598                     FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE
10599                     - h.length);
10600             item = build_string (FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE,
10601                                  str);
10602           }
10603         TREE_TYPE (item)
10604           = build_type_variant (build_array_type (char_type_node,
10605                                                   build_range_type
10606                                                   (integer_type_node,
10607                                                    integer_one_node,
10608                                                    build_int_2
10609                                                    (h.length, 0))),
10610                                 1, 0);
10611       }
10612       break;
10613
10614     case FFEINFO_basictypeTYPELESS:
10615       {
10616         ffetargetInteger1 ival;
10617         ffetargetTypeless tless;
10618         ffebad error;
10619
10620         tless = ffebld_cu_val_typeless (*cu);
10621         error = ffetarget_convert_integer1_typeless (&ival, tless);
10622         assert (error == FFEBAD);
10623
10624         item = build_int_2 ((int) ival, 0);
10625       }
10626       break;
10627
10628     default:
10629       assert ("not yet on constant type" == NULL);
10630       /* Fall through. */
10631     case FFEINFO_basictypeANY:
10632       return error_mark_node;
10633     }
10634
10635   TREE_CONSTANT (item) = 1;
10636
10637   return item;
10638 }
10639
10640 /* Transform expression into constant tree.
10641
10642    If the expression can be transformed into a tree that is constant,
10643    that is done, and the tree returned.  Else NULL_TREE is returned.
10644
10645    That way, a caller can attempt to provide compile-time initialization
10646    of a variable and, if that fails, *then* choose to start a new block
10647    and resort to using temporaries, as appropriate.  */
10648
10649 tree
10650 ffecom_const_expr (ffebld expr)
10651 {
10652   if (! expr)
10653     return integer_zero_node;
10654
10655   if (ffebld_op (expr) == FFEBLD_opANY)
10656     return error_mark_node;
10657
10658   if (ffebld_arity (expr) == 0
10659       && (ffebld_op (expr) != FFEBLD_opSYMTER
10660 #if NEWCOMMON
10661           /* ~~Enable once common/equivalence is handled properly?  */
10662           || ffebld_where (expr) == FFEINFO_whereCOMMON
10663 #endif
10664           || ffebld_where (expr) == FFEINFO_whereGLOBAL
10665           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10666     {
10667       tree t;
10668
10669       t = ffecom_expr (expr);
10670       assert (TREE_CONSTANT (t));
10671       return t;
10672     }
10673
10674   return NULL_TREE;
10675 }
10676
10677 /* Handy way to make a field in a struct/union.  */
10678
10679 tree
10680 ffecom_decl_field (tree context, tree prevfield,
10681                    const char *name, tree type)
10682 {
10683   tree field;
10684
10685   field = build_decl (FIELD_DECL, get_identifier (name), type);
10686   DECL_CONTEXT (field) = context;
10687   DECL_ALIGN (field) = 0;
10688   DECL_USER_ALIGN (field) = 0;
10689   if (prevfield != NULL_TREE)
10690     TREE_CHAIN (prevfield) = field;
10691
10692   return field;
10693 }
10694
10695 void
10696 ffecom_close_include (FILE *f)
10697 {
10698   ffecom_close_include_ (f);
10699 }
10700
10701 int
10702 ffecom_decode_include_option (char *spec)
10703 {
10704   return ffecom_decode_include_option_ (spec);
10705 }
10706
10707 /* End a compound statement (block).  */
10708
10709 tree
10710 ffecom_end_compstmt (void)
10711 {
10712   return bison_rule_compstmt_ ();
10713 }
10714
10715 /* ffecom_end_transition -- Perform end transition on all symbols
10716
10717    ffecom_end_transition();
10718
10719    Calls ffecom_sym_end_transition for each global and local symbol.  */
10720
10721 void
10722 ffecom_end_transition ()
10723 {
10724   ffebld item;
10725
10726   if (ffe_is_ffedebug ())
10727     fprintf (dmpout, "; end_stmt_transition\n");
10728
10729   ffecom_list_blockdata_ = NULL;
10730   ffecom_list_common_ = NULL;
10731
10732   ffesymbol_drive (ffecom_sym_end_transition);
10733   if (ffe_is_ffedebug ())
10734     {
10735       ffestorag_report ();
10736     }
10737
10738   ffecom_start_progunit_ ();
10739
10740   for (item = ffecom_list_blockdata_;
10741        item != NULL;
10742        item = ffebld_trail (item))
10743     {
10744       ffebld callee;
10745       ffesymbol s;
10746       tree dt;
10747       tree t;
10748       tree var;
10749       static int number = 0;
10750
10751       callee = ffebld_head (item);
10752       s = ffebld_symter (callee);
10753       t = ffesymbol_hook (s).decl_tree;
10754       if (t == NULL_TREE)
10755         {
10756           s = ffecom_sym_transform_ (s);
10757           t = ffesymbol_hook (s).decl_tree;
10758         }
10759
10760       dt = build_pointer_type (TREE_TYPE (t));
10761
10762       var = build_decl (VAR_DECL,
10763                         ffecom_get_invented_identifier ("__g77_forceload_%d",
10764                                                         number++),
10765                         dt);
10766       DECL_EXTERNAL (var) = 0;
10767       TREE_STATIC (var) = 1;
10768       TREE_PUBLIC (var) = 0;
10769       DECL_INITIAL (var) = error_mark_node;
10770       TREE_USED (var) = 1;
10771
10772       var = start_decl (var, FALSE);
10773
10774       t = ffecom_1 (ADDR_EXPR, dt, t);
10775
10776       finish_decl (var, t, FALSE);
10777     }
10778
10779   /* This handles any COMMON areas that weren't referenced but have, for
10780      example, important initial data.  */
10781
10782   for (item = ffecom_list_common_;
10783        item != NULL;
10784        item = ffebld_trail (item))
10785     ffecom_transform_common_ (ffebld_symter (ffebld_head (item)));
10786
10787   ffecom_list_common_ = NULL;
10788 }
10789
10790 /* ffecom_exec_transition -- Perform exec transition on all symbols
10791
10792    ffecom_exec_transition();
10793
10794    Calls ffecom_sym_exec_transition for each global and local symbol.
10795    Make sure error updating not inhibited.  */
10796
10797 void
10798 ffecom_exec_transition ()
10799 {
10800   bool inhibited;
10801
10802   if (ffe_is_ffedebug ())
10803     fprintf (dmpout, "; exec_stmt_transition\n");
10804
10805   inhibited = ffebad_inhibit ();
10806   ffebad_set_inhibit (FALSE);
10807
10808   ffesymbol_drive (ffecom_sym_exec_transition); /* Don't retract! */
10809   ffeequiv_exec_transition ();  /* Handle all pending EQUIVALENCEs. */
10810   if (ffe_is_ffedebug ())
10811     {
10812       ffestorag_report ();
10813     }
10814
10815   if (inhibited)
10816     ffebad_set_inhibit (TRUE);
10817 }
10818
10819 /* Handle assignment statement.
10820
10821    Convert dest and source using ffecom_expr, then join them
10822    with an ASSIGN op and pass the whole thing to expand_expr_stmt.  */
10823
10824 void
10825 ffecom_expand_let_stmt (ffebld dest, ffebld source)
10826 {
10827   tree dest_tree;
10828   tree dest_length;
10829   tree source_tree;
10830   tree expr_tree;
10831
10832   if (ffeinfo_basictype (ffebld_info (dest)) != FFEINFO_basictypeCHARACTER)
10833     {
10834       bool dest_used;
10835       tree assign_temp;
10836
10837       /* This attempts to replicate the test below, but must not be
10838          true when the test below is false.  (Always err on the side
10839          of creating unused temporaries, to avoid ICEs.)  */
10840       if (ffebld_op (dest) != FFEBLD_opSYMTER
10841           || ((dest_tree = ffesymbol_hook (ffebld_symter (dest)).decl_tree)
10842               && (TREE_CODE (dest_tree) != VAR_DECL
10843                   || TREE_ADDRESSABLE (dest_tree))))
10844         {
10845           ffecom_prepare_expr_ (source, dest);
10846           dest_used = TRUE;
10847         }
10848       else
10849         {
10850           ffecom_prepare_expr_ (source, NULL);
10851           dest_used = FALSE;
10852         }
10853
10854       ffecom_prepare_expr_w (NULL_TREE, dest);
10855
10856       /* For COMPLEX assignment like C1=C2, if partial overlap is possible,
10857          create a temporary through which the assignment is to take place,
10858          since MODIFY_EXPR doesn't handle partial overlap properly.  */
10859       if (ffebld_basictype (dest) == FFEINFO_basictypeCOMPLEX
10860           && ffecom_possible_partial_overlap_ (dest, source))
10861         {
10862           assign_temp = ffecom_make_tempvar ("complex_let",
10863                                              ffecom_tree_type
10864                                              [ffebld_basictype (dest)]
10865                                              [ffebld_kindtype (dest)],
10866                                              FFETARGET_charactersizeNONE,
10867                                              -1);
10868         }
10869       else
10870         assign_temp = NULL_TREE;
10871
10872       ffecom_prepare_end ();
10873
10874       dest_tree = ffecom_expr_w (NULL_TREE, dest);
10875       if (dest_tree == error_mark_node)
10876         return;
10877
10878       if ((TREE_CODE (dest_tree) != VAR_DECL)
10879           || TREE_ADDRESSABLE (dest_tree))
10880         source_tree = ffecom_expr_ (source, dest_tree, dest, &dest_used,
10881                                     FALSE, FALSE);
10882       else
10883         {
10884           assert (! dest_used);
10885           dest_used = FALSE;
10886           source_tree = ffecom_expr (source);
10887         }
10888       if (source_tree == error_mark_node)
10889         return;
10890
10891       if (dest_used)
10892         expr_tree = source_tree;
10893       else if (assign_temp)
10894         {
10895 #ifdef MOVE_EXPR
10896           /* The back end understands a conceptual move (evaluate source;
10897              store into dest), so use that, in case it can determine
10898              that it is going to use, say, two registers as temporaries
10899              anyway.  So don't use the temp (and someday avoid generating
10900              it, once this code starts triggering regularly).  */
10901           expr_tree = ffecom_2s (MOVE_EXPR, void_type_node,
10902                                  dest_tree,
10903                                  source_tree);
10904 #else
10905           expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
10906                                  assign_temp,
10907                                  source_tree);
10908           expand_expr_stmt (expr_tree);
10909           expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
10910                                  dest_tree,
10911                                  assign_temp);
10912 #endif
10913         }
10914       else
10915         expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
10916                                dest_tree,
10917                                source_tree);
10918
10919       expand_expr_stmt (expr_tree);
10920       return;
10921     }
10922
10923   ffecom_prepare_let_char_ (ffebld_size_known (dest), source);
10924   ffecom_prepare_expr_w (NULL_TREE, dest);
10925
10926   ffecom_prepare_end ();
10927
10928   ffecom_char_args_ (&dest_tree, &dest_length, dest);
10929   ffecom_let_char_ (dest_tree, dest_length, ffebld_size_known (dest),
10930                     source);
10931 }
10932
10933 /* ffecom_expr -- Transform expr into gcc tree
10934
10935    tree t;
10936    ffebld expr;  // FFE expression.
10937    tree = ffecom_expr(expr);
10938
10939    Recursive descent on expr while making corresponding tree nodes and
10940    attaching type info and such.  */
10941
10942 tree
10943 ffecom_expr (ffebld expr)
10944 {
10945   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, FALSE, FALSE);
10946 }
10947
10948 /* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT.  */
10949
10950 tree
10951 ffecom_expr_assign (ffebld expr)
10952 {
10953   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
10954 }
10955
10956 /* Like ffecom_expr_rw, but return tree usable for ASSIGN.  */
10957
10958 tree
10959 ffecom_expr_assign_w (ffebld expr)
10960 {
10961   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
10962 }
10963
10964 /* Transform expr for use as into read/write tree and stabilize the
10965    reference.  Not for use on CHARACTER expressions.
10966
10967    Recursive descent on expr while making corresponding tree nodes and
10968    attaching type info and such.  */
10969
10970 tree
10971 ffecom_expr_rw (tree type, ffebld expr)
10972 {
10973   assert (expr != NULL);
10974   /* Different target types not yet supported.  */
10975   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
10976
10977   return stabilize_reference (ffecom_expr (expr));
10978 }
10979
10980 /* Transform expr for use as into write tree and stabilize the
10981    reference.  Not for use on CHARACTER expressions.
10982
10983    Recursive descent on expr while making corresponding tree nodes and
10984    attaching type info and such.  */
10985
10986 tree
10987 ffecom_expr_w (tree type, ffebld expr)
10988 {
10989   assert (expr != NULL);
10990   /* Different target types not yet supported.  */
10991   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
10992
10993   return stabilize_reference (ffecom_expr (expr));
10994 }
10995
10996 /* Do global stuff.  */
10997
10998 void
10999 ffecom_finish_compile ()
11000 {
11001   assert (ffecom_outer_function_decl_ == NULL_TREE);
11002   assert (current_function_decl == NULL_TREE);
11003
11004   ffeglobal_drive (ffecom_finish_global_);
11005 }
11006
11007 /* Public entry point for front end to access finish_decl.  */
11008
11009 void
11010 ffecom_finish_decl (tree decl, tree init, bool is_top_level)
11011 {
11012   assert (!is_top_level);
11013   finish_decl (decl, init, FALSE);
11014 }
11015
11016 /* Finish a program unit.  */
11017
11018 void
11019 ffecom_finish_progunit ()
11020 {
11021   ffecom_end_compstmt ();
11022
11023   ffecom_previous_function_decl_ = current_function_decl;
11024   ffecom_which_entrypoint_decl_ = NULL_TREE;
11025
11026   finish_function (0);
11027 }
11028
11029 /* Wrapper for get_identifier.  pattern is sprintf-like.  */
11030
11031 tree
11032 ffecom_get_invented_identifier (const char *pattern, ...)
11033 {
11034   tree decl;
11035   char *nam;
11036   va_list ap;
11037
11038   va_start (ap, pattern);
11039   if (vasprintf (&nam, pattern, ap) == 0)
11040     abort ();
11041   va_end (ap);
11042   decl = get_identifier (nam);
11043   free (nam);
11044   IDENTIFIER_INVENTED (decl) = 1;
11045   return decl;
11046 }
11047
11048 ffeinfoBasictype
11049 ffecom_gfrt_basictype (ffecomGfrt gfrt)
11050 {
11051   assert (gfrt < FFECOM_gfrt);
11052
11053   switch (ffecom_gfrt_type_[gfrt])
11054     {
11055     case FFECOM_rttypeVOID_:
11056     case FFECOM_rttypeVOIDSTAR_:
11057       return FFEINFO_basictypeNONE;
11058
11059     case FFECOM_rttypeFTNINT_:
11060       return FFEINFO_basictypeINTEGER;
11061
11062     case FFECOM_rttypeINTEGER_:
11063       return FFEINFO_basictypeINTEGER;
11064
11065     case FFECOM_rttypeLONGINT_:
11066       return FFEINFO_basictypeINTEGER;
11067
11068     case FFECOM_rttypeLOGICAL_:
11069       return FFEINFO_basictypeLOGICAL;
11070
11071     case FFECOM_rttypeREAL_F2C_:
11072     case FFECOM_rttypeREAL_GNU_:
11073       return FFEINFO_basictypeREAL;
11074
11075     case FFECOM_rttypeCOMPLEX_F2C_:
11076     case FFECOM_rttypeCOMPLEX_GNU_:
11077       return FFEINFO_basictypeCOMPLEX;
11078
11079     case FFECOM_rttypeDOUBLE_:
11080     case FFECOM_rttypeDOUBLEREAL_:
11081       return FFEINFO_basictypeREAL;
11082
11083     case FFECOM_rttypeDBLCMPLX_F2C_:
11084     case FFECOM_rttypeDBLCMPLX_GNU_:
11085       return FFEINFO_basictypeCOMPLEX;
11086
11087     case FFECOM_rttypeCHARACTER_:
11088       return FFEINFO_basictypeCHARACTER;
11089
11090     default:
11091       return FFEINFO_basictypeANY;
11092     }
11093 }
11094
11095 ffeinfoKindtype
11096 ffecom_gfrt_kindtype (ffecomGfrt gfrt)
11097 {
11098   assert (gfrt < FFECOM_gfrt);
11099
11100   switch (ffecom_gfrt_type_[gfrt])
11101     {
11102     case FFECOM_rttypeVOID_:
11103     case FFECOM_rttypeVOIDSTAR_:
11104       return FFEINFO_kindtypeNONE;
11105
11106     case FFECOM_rttypeFTNINT_:
11107       return FFEINFO_kindtypeINTEGER1;
11108
11109     case FFECOM_rttypeINTEGER_:
11110       return FFEINFO_kindtypeINTEGER1;
11111
11112     case FFECOM_rttypeLONGINT_:
11113       return FFEINFO_kindtypeINTEGER4;
11114
11115     case FFECOM_rttypeLOGICAL_:
11116       return FFEINFO_kindtypeLOGICAL1;
11117
11118     case FFECOM_rttypeREAL_F2C_:
11119     case FFECOM_rttypeREAL_GNU_:
11120       return FFEINFO_kindtypeREAL1;
11121
11122     case FFECOM_rttypeCOMPLEX_F2C_:
11123     case FFECOM_rttypeCOMPLEX_GNU_:
11124       return FFEINFO_kindtypeREAL1;
11125
11126     case FFECOM_rttypeDOUBLE_:
11127     case FFECOM_rttypeDOUBLEREAL_:
11128       return FFEINFO_kindtypeREAL2;
11129
11130     case FFECOM_rttypeDBLCMPLX_F2C_:
11131     case FFECOM_rttypeDBLCMPLX_GNU_:
11132       return FFEINFO_kindtypeREAL2;
11133
11134     case FFECOM_rttypeCHARACTER_:
11135       return FFEINFO_kindtypeCHARACTER1;
11136
11137     default:
11138       return FFEINFO_kindtypeANY;
11139     }
11140 }
11141
11142 void
11143 ffecom_init_0 ()
11144 {
11145   tree endlink;
11146   int i;
11147   int j;
11148   tree t;
11149   tree field;
11150   ffetype type;
11151   ffetype base_type;
11152   tree double_ftype_double;
11153   tree float_ftype_float;
11154   tree ldouble_ftype_ldouble;
11155   tree ffecom_tree_ptr_to_fun_type_void;
11156
11157   /* This block of code comes from the now-obsolete cktyps.c.  It checks
11158      whether the compiler environment is buggy in known ways, some of which
11159      would, if not explicitly checked here, result in subtle bugs in g77.  */
11160
11161   if (ffe_is_do_internal_checks ())
11162     {
11163       static const char names[][12]
11164         =
11165       {"bar", "bletch", "foo", "foobar"};
11166       const char *name;
11167       unsigned long ul;
11168       double fl;
11169
11170       name = bsearch ("foo", &names[0], ARRAY_SIZE (names), sizeof (names[0]),
11171                       (int (*)(const void *, const void *)) strcmp);
11172       if (name != &names[0][2])
11173         {
11174           assert ("bsearch doesn't work, #define FFEPROJ_BSEARCH 0 in proj.h"
11175                   == NULL);
11176           abort ();
11177         }
11178
11179       ul = strtoul ("123456789", NULL, 10);
11180       if (ul != 123456789L)
11181         {
11182           assert ("strtoul doesn't have enough range, #define FFEPROJ_STRTOUL 0\
11183  in proj.h" == NULL);
11184           abort ();
11185         }
11186
11187       fl = atof ("56.789");
11188       if ((fl < 56.788) || (fl > 56.79))
11189         {
11190           assert ("atof not type double, fix your #include <stdio.h>"
11191                   == NULL);
11192           abort ();
11193         }
11194     }
11195
11196   ffecom_outer_function_decl_ = NULL_TREE;
11197   current_function_decl = NULL_TREE;
11198   named_labels = NULL_TREE;
11199   current_binding_level = NULL_BINDING_LEVEL;
11200   free_binding_level = NULL_BINDING_LEVEL;
11201   /* Make the binding_level structure for global names.  */
11202   pushlevel (0);
11203   global_binding_level = current_binding_level;
11204   current_binding_level->prep_state = 2;
11205
11206   build_common_tree_nodes (1);
11207
11208   /* Define `int' and `char' first so that dbx will output them first.  */
11209   pushdecl (build_decl (TYPE_DECL, get_identifier ("int"),
11210                         integer_type_node));
11211   /* CHARACTER*1 is unsigned in ICHAR contexts.  */
11212   char_type_node = make_unsigned_type (CHAR_TYPE_SIZE);
11213   pushdecl (build_decl (TYPE_DECL, get_identifier ("char"),
11214                         char_type_node));
11215   pushdecl (build_decl (TYPE_DECL, get_identifier ("long int"),
11216                         long_integer_type_node));
11217   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned int"),
11218                         unsigned_type_node));
11219   pushdecl (build_decl (TYPE_DECL, get_identifier ("long unsigned int"),
11220                         long_unsigned_type_node));
11221   pushdecl (build_decl (TYPE_DECL, get_identifier ("long long int"),
11222                         long_long_integer_type_node));
11223   pushdecl (build_decl (TYPE_DECL, get_identifier ("long long unsigned int"),
11224                         long_long_unsigned_type_node));
11225   pushdecl (build_decl (TYPE_DECL, get_identifier ("short int"),
11226                         short_integer_type_node));
11227   pushdecl (build_decl (TYPE_DECL, get_identifier ("short unsigned int"),
11228                         short_unsigned_type_node));
11229
11230   /* Set the sizetype before we make other types.  This *should* be the
11231      first type we create.  */
11232
11233   set_sizetype
11234     (TREE_TYPE (IDENTIFIER_GLOBAL_VALUE (get_identifier (SIZE_TYPE))));
11235   ffecom_typesize_pointer_
11236     = TREE_INT_CST_LOW (TYPE_SIZE (sizetype)) / BITS_PER_UNIT;
11237
11238   build_common_tree_nodes_2 (0);
11239
11240   /* Define both `signed char' and `unsigned char'.  */
11241   pushdecl (build_decl (TYPE_DECL, get_identifier ("signed char"),
11242                         signed_char_type_node));
11243
11244   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned char"),
11245                         unsigned_char_type_node));
11246
11247   pushdecl (build_decl (TYPE_DECL, get_identifier ("float"),
11248                         float_type_node));
11249   pushdecl (build_decl (TYPE_DECL, get_identifier ("double"),
11250                         double_type_node));
11251   pushdecl (build_decl (TYPE_DECL, get_identifier ("long double"),
11252                         long_double_type_node));
11253
11254   /* For now, override what build_common_tree_nodes has done.  */
11255   complex_integer_type_node = ffecom_make_complex_type_ (integer_type_node);
11256   complex_float_type_node = ffecom_make_complex_type_ (float_type_node);
11257   complex_double_type_node = ffecom_make_complex_type_ (double_type_node);
11258   complex_long_double_type_node
11259     = ffecom_make_complex_type_ (long_double_type_node);
11260
11261   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex int"),
11262                         complex_integer_type_node));
11263   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex float"),
11264                         complex_float_type_node));
11265   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex double"),
11266                         complex_double_type_node));
11267   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex long double"),
11268                         complex_long_double_type_node));
11269
11270   pushdecl (build_decl (TYPE_DECL, get_identifier ("void"),
11271                         void_type_node));
11272   /* We are not going to have real types in C with less than byte alignment,
11273      so we might as well not have any types that claim to have it.  */
11274   TYPE_ALIGN (void_type_node) = BITS_PER_UNIT;
11275   TYPE_USER_ALIGN (void_type_node) = 0;
11276
11277   string_type_node = build_pointer_type (char_type_node);
11278
11279   ffecom_tree_fun_type_void
11280     = build_function_type (void_type_node, NULL_TREE);
11281
11282   ffecom_tree_ptr_to_fun_type_void
11283     = build_pointer_type (ffecom_tree_fun_type_void);
11284
11285   endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE);
11286
11287   float_ftype_float
11288     = build_function_type (float_type_node,
11289                            tree_cons (NULL_TREE, float_type_node, endlink));
11290
11291   double_ftype_double
11292     = build_function_type (double_type_node,
11293                            tree_cons (NULL_TREE, double_type_node, endlink));
11294
11295   ldouble_ftype_ldouble
11296     = build_function_type (long_double_type_node,
11297                            tree_cons (NULL_TREE, long_double_type_node,
11298                                       endlink));
11299
11300   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11301     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11302       {
11303         ffecom_tree_type[i][j] = NULL_TREE;
11304         ffecom_tree_fun_type[i][j] = NULL_TREE;
11305         ffecom_tree_ptr_to_fun_type[i][j] = NULL_TREE;
11306         ffecom_f2c_typecode_[i][j] = -1;
11307       }
11308
11309   /* Set up standard g77 types.  Note that INTEGER and LOGICAL are set
11310      to size FLOAT_TYPE_SIZE because they have to be the same size as
11311      REAL, which also is FLOAT_TYPE_SIZE, according to the standard.
11312      Compiler options and other such stuff that change the ways these
11313      types are set should not affect this particular setup.  */
11314
11315   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1]
11316     = t = make_signed_type (FLOAT_TYPE_SIZE);
11317   pushdecl (build_decl (TYPE_DECL, get_identifier ("integer"),
11318                         t));
11319   type = ffetype_new ();
11320   base_type = type;
11321   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER1,
11322                     type);
11323   ffetype_set_ams (type,
11324                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11325                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11326   ffetype_set_star (base_type,
11327                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11328                     type);
11329   ffetype_set_kind (base_type, 1, type);
11330   ffecom_typesize_integer1_ = ffetype_size (type);
11331   assert (ffetype_size (type) == sizeof (ffetargetInteger1));
11332
11333   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER1]
11334     = t = make_unsigned_type (FLOAT_TYPE_SIZE); /* HOLLERITH means unsigned. */
11335   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned"),
11336                         t));
11337
11338   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER2]
11339     = t = make_signed_type (CHAR_TYPE_SIZE);
11340   pushdecl (build_decl (TYPE_DECL, get_identifier ("byte"),
11341                         t));
11342   type = ffetype_new ();
11343   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER2,
11344                     type);
11345   ffetype_set_ams (type,
11346                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11347                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11348   ffetype_set_star (base_type,
11349                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11350                     type);
11351   ffetype_set_kind (base_type, 3, type);
11352   assert (ffetype_size (type) == sizeof (ffetargetInteger2));
11353
11354   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER2]
11355     = t = make_unsigned_type (CHAR_TYPE_SIZE);
11356   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned byte"),
11357                         t));
11358
11359   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER3]
11360     = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11361   pushdecl (build_decl (TYPE_DECL, get_identifier ("word"),
11362                         t));
11363   type = ffetype_new ();
11364   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER3,
11365                     type);
11366   ffetype_set_ams (type,
11367                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11368                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11369   ffetype_set_star (base_type,
11370                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11371                     type);
11372   ffetype_set_kind (base_type, 6, type);
11373   assert (ffetype_size (type) == sizeof (ffetargetInteger3));
11374
11375   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER3]
11376     = t = make_unsigned_type (CHAR_TYPE_SIZE * 2);
11377   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned word"),
11378                         t));
11379
11380   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER4]
11381     = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11382   pushdecl (build_decl (TYPE_DECL, get_identifier ("integer4"),
11383                         t));
11384   type = ffetype_new ();
11385   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER4,
11386                     type);
11387   ffetype_set_ams (type,
11388                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11389                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11390   ffetype_set_star (base_type,
11391                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11392                     type);
11393   ffetype_set_kind (base_type, 2, type);
11394   assert (ffetype_size (type) == sizeof (ffetargetInteger4));
11395
11396   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER4]
11397     = t = make_unsigned_type (FLOAT_TYPE_SIZE * 2);
11398   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned4"),
11399                         t));
11400
11401 #if 0
11402   if (ffe_is_do_internal_checks ()
11403       && LONG_TYPE_SIZE != FLOAT_TYPE_SIZE
11404       && LONG_TYPE_SIZE != CHAR_TYPE_SIZE
11405       && LONG_TYPE_SIZE != SHORT_TYPE_SIZE
11406       && LONG_TYPE_SIZE != LONG_LONG_TYPE_SIZE)
11407     {
11408       fprintf (stderr, "Sorry, no g77 support for LONG_TYPE_SIZE (%d bits) yet.\n",
11409                LONG_TYPE_SIZE);
11410     }
11411 #endif
11412
11413   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL1]
11414     = t = make_signed_type (FLOAT_TYPE_SIZE);
11415   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical"),
11416                         t));
11417   type = ffetype_new ();
11418   base_type = type;
11419   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL1,
11420                     type);
11421   ffetype_set_ams (type,
11422                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11423                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11424   ffetype_set_star (base_type,
11425                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11426                     type);
11427   ffetype_set_kind (base_type, 1, type);
11428   assert (ffetype_size (type) == sizeof (ffetargetLogical1));
11429
11430   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL2]
11431     = t = make_signed_type (CHAR_TYPE_SIZE);
11432   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical2"),
11433                         t));
11434   type = ffetype_new ();
11435   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL2,
11436                     type);
11437   ffetype_set_ams (type,
11438                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11439                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11440   ffetype_set_star (base_type,
11441                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11442                     type);
11443   ffetype_set_kind (base_type, 3, type);
11444   assert (ffetype_size (type) == sizeof (ffetargetLogical2));
11445
11446   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL3]
11447     = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11448   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical3"),
11449                         t));
11450   type = ffetype_new ();
11451   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL3,
11452                     type);
11453   ffetype_set_ams (type,
11454                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11455                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11456   ffetype_set_star (base_type,
11457                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11458                     type);
11459   ffetype_set_kind (base_type, 6, type);
11460   assert (ffetype_size (type) == sizeof (ffetargetLogical3));
11461
11462   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL4]
11463     = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11464   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical4"),
11465                         t));
11466   type = ffetype_new ();
11467   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL4,
11468                     type);
11469   ffetype_set_ams (type,
11470                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11471                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11472   ffetype_set_star (base_type,
11473                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11474                     type);
11475   ffetype_set_kind (base_type, 2, type);
11476   assert (ffetype_size (type) == sizeof (ffetargetLogical4));
11477
11478   ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11479     = t = make_node (REAL_TYPE);
11480   TYPE_PRECISION (t) = FLOAT_TYPE_SIZE;
11481   pushdecl (build_decl (TYPE_DECL, get_identifier ("real"),
11482                         t));
11483   layout_type (t);
11484   type = ffetype_new ();
11485   base_type = type;
11486   ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL1,
11487                     type);
11488   ffetype_set_ams (type,
11489                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11490                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11491   ffetype_set_star (base_type,
11492                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11493                     type);
11494   ffetype_set_kind (base_type, 1, type);
11495   ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11496     = FFETARGET_f2cTYREAL;
11497   assert (ffetype_size (type) == sizeof (ffetargetReal1));
11498
11499   ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREALDOUBLE]
11500     = t = make_node (REAL_TYPE);
11501   TYPE_PRECISION (t) = FLOAT_TYPE_SIZE * 2;     /* Always twice REAL. */
11502   pushdecl (build_decl (TYPE_DECL, get_identifier ("double precision"),
11503                         t));
11504   layout_type (t);
11505   type = ffetype_new ();
11506   ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE,
11507                     type);
11508   ffetype_set_ams (type,
11509                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11510                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11511   ffetype_set_star (base_type,
11512                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11513                     type);
11514   ffetype_set_kind (base_type, 2, type);
11515   ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]
11516     = FFETARGET_f2cTYDREAL;
11517   assert (ffetype_size (type) == sizeof (ffetargetReal2));
11518
11519   ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11520     = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]);
11521   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex"),
11522                         t));
11523   type = ffetype_new ();
11524   base_type = type;
11525   ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL1,
11526                     type);
11527   ffetype_set_ams (type,
11528                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11529                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11530   ffetype_set_star (base_type,
11531                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11532                     type);
11533   ffetype_set_kind (base_type, 1, type);
11534   ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11535     = FFETARGET_f2cTYCOMPLEX;
11536   assert (ffetype_size (type) == sizeof (ffetargetComplex1));
11537
11538   ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREALDOUBLE]
11539     = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]);
11540   pushdecl (build_decl (TYPE_DECL, get_identifier ("double complex"),
11541                         t));
11542   type = ffetype_new ();
11543   ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREALDOUBLE,
11544                     type);
11545   ffetype_set_ams (type,
11546                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11547                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11548   ffetype_set_star (base_type,
11549                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11550                     type);
11551   ffetype_set_kind (base_type, 2,
11552                     type);
11553   ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL2]
11554     = FFETARGET_f2cTYDCOMPLEX;
11555   assert (ffetype_size (type) == sizeof (ffetargetComplex2));
11556
11557   /* Make function and ptr-to-function types for non-CHARACTER types. */
11558
11559   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11560     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11561       {
11562         if ((t = ffecom_tree_type[i][j]) != NULL_TREE)
11563           {
11564             if (i == FFEINFO_basictypeINTEGER)
11565               {
11566                 /* Figure out the smallest INTEGER type that can hold
11567                    a pointer on this machine. */
11568                 if (GET_MODE_SIZE (TYPE_MODE (t))
11569                     >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
11570                   {
11571                     if ((ffecom_pointer_kind_ == FFEINFO_kindtypeNONE)
11572                         || (GET_MODE_SIZE (TYPE_MODE (ffecom_tree_type[i][ffecom_pointer_kind_]))
11573                             > GET_MODE_SIZE (TYPE_MODE (t))))
11574                       ffecom_pointer_kind_ = j;
11575                   }
11576               }
11577             else if (i == FFEINFO_basictypeCOMPLEX)
11578               t = void_type_node;
11579             /* For f2c compatibility, REAL functions are really
11580                implemented as DOUBLE PRECISION.  */
11581             else if ((i == FFEINFO_basictypeREAL)
11582                      && (j == FFEINFO_kindtypeREAL1))
11583               t = ffecom_tree_type
11584                 [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2];
11585
11586             t = ffecom_tree_fun_type[i][j] = build_function_type (t,
11587                                                                   NULL_TREE);
11588             ffecom_tree_ptr_to_fun_type[i][j] = build_pointer_type (t);
11589           }
11590       }
11591
11592   /* Set up pointer types.  */
11593
11594   if (ffecom_pointer_kind_ == FFEINFO_basictypeNONE)
11595     fatal_error ("no INTEGER type can hold a pointer on this configuration");
11596   else if (0 && ffe_is_do_internal_checks ())
11597     fprintf (stderr, "Pointer type kt=%d\n", ffecom_pointer_kind_);
11598   ffetype_set_kind (ffeinfo_type (FFEINFO_basictypeINTEGER,
11599                                   FFEINFO_kindtypeINTEGERDEFAULT),
11600                     7,
11601                     ffeinfo_type (FFEINFO_basictypeINTEGER,
11602                                   ffecom_pointer_kind_));
11603
11604   if (ffe_is_ugly_assign ())
11605     ffecom_label_kind_ = ffecom_pointer_kind_;  /* Require ASSIGN etc to this. */
11606   else
11607     ffecom_label_kind_ = FFEINFO_kindtypeINTEGERDEFAULT;
11608   if (0 && ffe_is_do_internal_checks ())
11609     fprintf (stderr, "Label type kt=%d\n", ffecom_label_kind_);
11610
11611   ffecom_integer_type_node
11612     = ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1];
11613   ffecom_integer_zero_node = convert (ffecom_integer_type_node,
11614                                       integer_zero_node);
11615   ffecom_integer_one_node = convert (ffecom_integer_type_node,
11616                                      integer_one_node);
11617
11618   /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional.
11619      Turns out that by TYLONG, runtime/libI77/lio.h really means
11620      "whatever size an ftnint is".  For consistency and sanity,
11621      com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen
11622      all are INTEGER, which we also make out of whatever back-end
11623      integer type is FLOAT_TYPE_SIZE bits wide.  This change, from
11624      LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to
11625      accommodate machines like the Alpha.  Note that this suggests
11626      f2c and libf2c are missing a distinction perhaps needed on
11627      some machines between "int" and "long int".  -- burley 0.5.5 950215 */
11628
11629   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, FLOAT_TYPE_SIZE,
11630                             FFETARGET_f2cTYLONG);
11631   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, SHORT_TYPE_SIZE,
11632                             FFETARGET_f2cTYSHORT);
11633   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, CHAR_TYPE_SIZE,
11634                             FFETARGET_f2cTYINT1);
11635   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, LONG_LONG_TYPE_SIZE,
11636                             FFETARGET_f2cTYQUAD);
11637   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, FLOAT_TYPE_SIZE,
11638                             FFETARGET_f2cTYLOGICAL);
11639   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, SHORT_TYPE_SIZE,
11640                             FFETARGET_f2cTYLOGICAL2);
11641   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, CHAR_TYPE_SIZE,
11642                             FFETARGET_f2cTYLOGICAL1);
11643   /* ~~~Not really such a type in libf2c, e.g. I/O support?  */
11644   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, LONG_LONG_TYPE_SIZE,
11645                             FFETARGET_f2cTYQUAD);
11646
11647   /* CHARACTER stuff is all special-cased, so it is not handled in the above
11648      loop.  CHARACTER items are built as arrays of unsigned char.  */
11649
11650   ffecom_tree_type[FFEINFO_basictypeCHARACTER]
11651     [FFEINFO_kindtypeCHARACTER1] = t = char_type_node;
11652   type = ffetype_new ();
11653   base_type = type;
11654   ffeinfo_set_type (FFEINFO_basictypeCHARACTER,
11655                     FFEINFO_kindtypeCHARACTER1,
11656                     type);
11657   ffetype_set_ams (type,
11658                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11659                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11660   ffetype_set_kind (base_type, 1, type);
11661   assert (ffetype_size (type)
11662           == sizeof (((ffetargetCharacter1) { 0, NULL }).text[0]));
11663
11664   ffecom_tree_fun_type[FFEINFO_basictypeCHARACTER]
11665     [FFEINFO_kindtypeCHARACTER1] = ffecom_tree_fun_type_void;
11666   ffecom_tree_ptr_to_fun_type[FFEINFO_basictypeCHARACTER]
11667     [FFEINFO_kindtypeCHARACTER1]
11668     = ffecom_tree_ptr_to_fun_type_void;
11669   ffecom_f2c_typecode_[FFEINFO_basictypeCHARACTER][FFEINFO_kindtypeCHARACTER1]
11670     = FFETARGET_f2cTYCHAR;
11671
11672   ffecom_f2c_typecode_[FFEINFO_basictypeANY][FFEINFO_kindtypeANY]
11673     = 0;
11674
11675   /* Make multi-return-value type and fields. */
11676
11677   ffecom_multi_type_node_ = make_node (UNION_TYPE);
11678
11679   field = NULL_TREE;
11680
11681   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11682     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11683       {
11684         char name[30];
11685
11686         if (ffecom_tree_type[i][j] == NULL_TREE)
11687           continue;             /* Not supported. */
11688         sprintf (&name[0], "bt_%s_kt_%s",
11689                  ffeinfo_basictype_string ((ffeinfoBasictype) i),
11690                  ffeinfo_kindtype_string ((ffeinfoKindtype) j));
11691         ffecom_multi_fields_[i][j] = build_decl (FIELD_DECL,
11692                                                  get_identifier (name),
11693                                                  ffecom_tree_type[i][j]);
11694         DECL_CONTEXT (ffecom_multi_fields_[i][j])
11695           = ffecom_multi_type_node_;
11696         DECL_ALIGN (ffecom_multi_fields_[i][j]) = 0;
11697         DECL_USER_ALIGN (ffecom_multi_fields_[i][j]) = 0;
11698         TREE_CHAIN (ffecom_multi_fields_[i][j]) = field;
11699         field = ffecom_multi_fields_[i][j];
11700       }
11701
11702   TYPE_FIELDS (ffecom_multi_type_node_) = field;
11703   layout_type (ffecom_multi_type_node_);
11704
11705   /* Subroutines usually return integer because they might have alternate
11706      returns. */
11707
11708   ffecom_tree_subr_type
11709     = build_function_type (integer_type_node, NULL_TREE);
11710   ffecom_tree_ptr_to_subr_type
11711     = build_pointer_type (ffecom_tree_subr_type);
11712   ffecom_tree_blockdata_type
11713     = build_function_type (void_type_node, NULL_TREE);
11714
11715   builtin_function ("__builtin_sqrtf", float_ftype_float,
11716                     BUILT_IN_SQRTF, BUILT_IN_NORMAL, "sqrtf");
11717   builtin_function ("__builtin_sqrt", double_ftype_double,
11718                     BUILT_IN_SQRT, BUILT_IN_NORMAL, "sqrt");
11719   builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble,
11720                     BUILT_IN_SQRTL, BUILT_IN_NORMAL, "sqrtl");
11721   builtin_function ("__builtin_sinf", float_ftype_float,
11722                     BUILT_IN_SINF, BUILT_IN_NORMAL, "sinf");
11723   builtin_function ("__builtin_sin", double_ftype_double,
11724                     BUILT_IN_SIN, BUILT_IN_NORMAL, "sin");
11725   builtin_function ("__builtin_sinl", ldouble_ftype_ldouble,
11726                     BUILT_IN_SINL, BUILT_IN_NORMAL, "sinl");
11727   builtin_function ("__builtin_cosf", float_ftype_float,
11728                     BUILT_IN_COSF, BUILT_IN_NORMAL, "cosf");
11729   builtin_function ("__builtin_cos", double_ftype_double,
11730                     BUILT_IN_COS, BUILT_IN_NORMAL, "cos");
11731   builtin_function ("__builtin_cosl", ldouble_ftype_ldouble,
11732                     BUILT_IN_COSL, BUILT_IN_NORMAL, "cosl");
11733
11734   pedantic_lvalues = FALSE;
11735
11736   ffecom_f2c_make_type_ (&ffecom_f2c_integer_type_node,
11737                          FFECOM_f2cINTEGER,
11738                          "integer");
11739   ffecom_f2c_make_type_ (&ffecom_f2c_address_type_node,
11740                          FFECOM_f2cADDRESS,
11741                          "address");
11742   ffecom_f2c_make_type_ (&ffecom_f2c_real_type_node,
11743                          FFECOM_f2cREAL,
11744                          "real");
11745   ffecom_f2c_make_type_ (&ffecom_f2c_doublereal_type_node,
11746                          FFECOM_f2cDOUBLEREAL,
11747                          "doublereal");
11748   ffecom_f2c_make_type_ (&ffecom_f2c_complex_type_node,
11749                          FFECOM_f2cCOMPLEX,
11750                          "complex");
11751   ffecom_f2c_make_type_ (&ffecom_f2c_doublecomplex_type_node,
11752                          FFECOM_f2cDOUBLECOMPLEX,
11753                          "doublecomplex");
11754   ffecom_f2c_make_type_ (&ffecom_f2c_longint_type_node,
11755                          FFECOM_f2cLONGINT,
11756                          "longint");
11757   ffecom_f2c_make_type_ (&ffecom_f2c_logical_type_node,
11758                          FFECOM_f2cLOGICAL,
11759                          "logical");
11760   ffecom_f2c_make_type_ (&ffecom_f2c_flag_type_node,
11761                          FFECOM_f2cFLAG,
11762                          "flag");
11763   ffecom_f2c_make_type_ (&ffecom_f2c_ftnlen_type_node,
11764                          FFECOM_f2cFTNLEN,
11765                          "ftnlen");
11766   ffecom_f2c_make_type_ (&ffecom_f2c_ftnint_type_node,
11767                          FFECOM_f2cFTNINT,
11768                          "ftnint");
11769
11770   ffecom_f2c_ftnlen_zero_node
11771     = convert (ffecom_f2c_ftnlen_type_node, integer_zero_node);
11772
11773   ffecom_f2c_ftnlen_one_node
11774     = convert (ffecom_f2c_ftnlen_type_node, integer_one_node);
11775
11776   ffecom_f2c_ftnlen_two_node = build_int_2 (2, 0);
11777   TREE_TYPE (ffecom_f2c_ftnlen_two_node) = ffecom_integer_type_node;
11778
11779   ffecom_f2c_ptr_to_ftnlen_type_node
11780     = build_pointer_type (ffecom_f2c_ftnlen_type_node);
11781
11782   ffecom_f2c_ptr_to_ftnint_type_node
11783     = build_pointer_type (ffecom_f2c_ftnint_type_node);
11784
11785   ffecom_f2c_ptr_to_integer_type_node
11786     = build_pointer_type (ffecom_f2c_integer_type_node);
11787
11788   ffecom_f2c_ptr_to_real_type_node
11789     = build_pointer_type (ffecom_f2c_real_type_node);
11790
11791   ffecom_float_zero_ = build_real (float_type_node, dconst0);
11792   ffecom_double_zero_ = build_real (double_type_node, dconst0);
11793   {
11794     REAL_VALUE_TYPE point_5;
11795
11796 #ifdef REAL_ARITHMETIC
11797     REAL_ARITHMETIC (point_5, RDIV_EXPR, dconst1, dconst2);
11798 #else
11799     point_5 = .5;
11800 #endif
11801     ffecom_float_half_ = build_real (float_type_node, point_5);
11802     ffecom_double_half_ = build_real (double_type_node, point_5);
11803   }
11804
11805   /* Do "extern int xargc;".  */
11806
11807   ffecom_tree_xargc_ = build_decl (VAR_DECL,
11808                                    get_identifier ("f__xargc"),
11809                                    integer_type_node);
11810   DECL_EXTERNAL (ffecom_tree_xargc_) = 1;
11811   TREE_STATIC (ffecom_tree_xargc_) = 1;
11812   TREE_PUBLIC (ffecom_tree_xargc_) = 1;
11813   ffecom_tree_xargc_ = start_decl (ffecom_tree_xargc_, FALSE);
11814   finish_decl (ffecom_tree_xargc_, NULL_TREE, FALSE);
11815
11816 #if 0   /* This is being fixed, and seems to be working now. */
11817   if ((FLOAT_TYPE_SIZE != 32)
11818       || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))) != 32))
11819     {
11820       warning ("configuration: REAL, INTEGER, and LOGICAL are %d bits wide,",
11821                (int) FLOAT_TYPE_SIZE);
11822       warning ("and pointers are %d bits wide, but g77 doesn't yet work",
11823           (int) TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))));
11824       warning ("properly unless they all are 32 bits wide");
11825       warning ("Please keep this in mind before you report bugs.  g77 should");
11826       warning ("support non-32-bit machines better as of version 0.6");
11827     }
11828 #endif
11829
11830 #if 0   /* Code in ste.c that would crash has been commented out. */
11831   if (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)
11832       < TYPE_PRECISION (string_type_node))
11833     /* I/O will probably crash.  */
11834     warning ("configuration: char * holds %d bits, but ftnlen only %d",
11835              TYPE_PRECISION (string_type_node),
11836              TYPE_PRECISION (ffecom_f2c_ftnlen_type_node));
11837 #endif
11838
11839 #if 0   /* ASSIGN-related stuff has been changed to accommodate this. */
11840   if (TYPE_PRECISION (ffecom_integer_type_node)
11841       < TYPE_PRECISION (string_type_node))
11842     /* ASSIGN 10 TO I will crash.  */
11843     warning ("configuration: char * holds %d bits, but INTEGER only %d --\n\
11844  ASSIGN statement might fail",
11845              TYPE_PRECISION (string_type_node),
11846              TYPE_PRECISION (ffecom_integer_type_node));
11847 #endif
11848 }
11849
11850 /* ffecom_init_2 -- Initialize
11851
11852    ffecom_init_2();  */
11853
11854 void
11855 ffecom_init_2 ()
11856 {
11857   assert (ffecom_outer_function_decl_ == NULL_TREE);
11858   assert (current_function_decl == NULL_TREE);
11859   assert (ffecom_which_entrypoint_decl_ == NULL_TREE);
11860
11861   ffecom_master_arglist_ = NULL;
11862   ++ffecom_num_fns_;
11863   ffecom_primary_entry_ = NULL;
11864   ffecom_is_altreturning_ = FALSE;
11865   ffecom_func_result_ = NULL_TREE;
11866   ffecom_multi_retval_ = NULL_TREE;
11867 }
11868
11869 /* ffecom_list_expr -- Transform list of exprs into gcc tree
11870
11871    tree t;
11872    ffebld expr;  // FFE opITEM list.
11873    tree = ffecom_list_expr(expr);
11874
11875    List of actual args is transformed into corresponding gcc backend list.  */
11876
11877 tree
11878 ffecom_list_expr (ffebld expr)
11879 {
11880   tree list;
11881   tree *plist = &list;
11882   tree trail = NULL_TREE;       /* Append char length args here. */
11883   tree *ptrail = &trail;
11884   tree length;
11885
11886   while (expr != NULL)
11887     {
11888       tree texpr = ffecom_arg_expr (ffebld_head (expr), &length);
11889
11890       if (texpr == error_mark_node)
11891         return error_mark_node;
11892
11893       *plist = build_tree_list (NULL_TREE, texpr);
11894       plist = &TREE_CHAIN (*plist);
11895       expr = ffebld_trail (expr);
11896       if (length != NULL_TREE)
11897         {
11898           *ptrail = build_tree_list (NULL_TREE, length);
11899           ptrail = &TREE_CHAIN (*ptrail);
11900         }
11901     }
11902
11903   *plist = trail;
11904
11905   return list;
11906 }
11907
11908 /* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree
11909
11910    tree t;
11911    ffebld expr;  // FFE opITEM list.
11912    tree = ffecom_list_ptr_to_expr(expr);
11913
11914    List of actual args is transformed into corresponding gcc backend list for
11915    use in calling an external procedure (vs. a statement function).  */
11916
11917 tree
11918 ffecom_list_ptr_to_expr (ffebld expr)
11919 {
11920   tree list;
11921   tree *plist = &list;
11922   tree trail = NULL_TREE;       /* Append char length args here. */
11923   tree *ptrail = &trail;
11924   tree length;
11925
11926   while (expr != NULL)
11927     {
11928       tree texpr = ffecom_arg_ptr_to_expr (ffebld_head (expr), &length);
11929
11930       if (texpr == error_mark_node)
11931         return error_mark_node;
11932
11933       *plist = build_tree_list (NULL_TREE, texpr);
11934       plist = &TREE_CHAIN (*plist);
11935       expr = ffebld_trail (expr);
11936       if (length != NULL_TREE)
11937         {
11938           *ptrail = build_tree_list (NULL_TREE, length);
11939           ptrail = &TREE_CHAIN (*ptrail);
11940         }
11941     }
11942
11943   *plist = trail;
11944
11945   return list;
11946 }
11947
11948 /* Obtain gcc's LABEL_DECL tree for label.  */
11949
11950 tree
11951 ffecom_lookup_label (ffelab label)
11952 {
11953   tree glabel;
11954
11955   if (ffelab_hook (label) == NULL_TREE)
11956     {
11957       char labelname[16];
11958
11959       switch (ffelab_type (label))
11960         {
11961         case FFELAB_typeLOOPEND:
11962         case FFELAB_typeNOTLOOP:
11963         case FFELAB_typeENDIF:
11964           sprintf (labelname, "%" ffelabValue_f "u", ffelab_value (label));
11965           glabel = build_decl (LABEL_DECL, get_identifier (labelname),
11966                                void_type_node);
11967           DECL_CONTEXT (glabel) = current_function_decl;
11968           DECL_MODE (glabel) = VOIDmode;
11969           break;
11970
11971         case FFELAB_typeFORMAT:
11972           glabel = build_decl (VAR_DECL,
11973                                ffecom_get_invented_identifier
11974                                ("__g77_format_%d", (int) ffelab_value (label)),
11975                                build_type_variant (build_array_type
11976                                                    (char_type_node,
11977                                                     NULL_TREE),
11978                                                    1, 0));
11979           TREE_CONSTANT (glabel) = 1;
11980           TREE_STATIC (glabel) = 1;
11981           DECL_CONTEXT (glabel) = current_function_decl;
11982           DECL_INITIAL (glabel) = NULL;
11983           make_decl_rtl (glabel, NULL);
11984           expand_decl (glabel);
11985
11986           ffecom_save_tree_forever (glabel);
11987
11988           break;
11989
11990         case FFELAB_typeANY:
11991           glabel = error_mark_node;
11992           break;
11993
11994         default:
11995           assert ("bad label type" == NULL);
11996           glabel = NULL;
11997           break;
11998         }
11999       ffelab_set_hook (label, glabel);
12000     }
12001   else
12002     {
12003       glabel = ffelab_hook (label);
12004     }
12005
12006   return glabel;
12007 }
12008
12009 /* Stabilizes the arguments.  Don't use this if the lhs and rhs come from
12010    a single source specification (as in the fourth argument of MVBITS).
12011    If the type is NULL_TREE, the type of lhs is used to make the type of
12012    the MODIFY_EXPR.  */
12013
12014 tree
12015 ffecom_modify (tree newtype, tree lhs,
12016                tree rhs)
12017 {
12018   if (lhs == error_mark_node || rhs == error_mark_node)
12019     return error_mark_node;
12020
12021   if (newtype == NULL_TREE)
12022     newtype = TREE_TYPE (lhs);
12023
12024   if (TREE_SIDE_EFFECTS (lhs))
12025     lhs = stabilize_reference (lhs);
12026
12027   return ffecom_2s (MODIFY_EXPR, newtype, lhs, rhs);
12028 }
12029
12030 /* Register source file name.  */
12031
12032 void
12033 ffecom_file (const char *name)
12034 {
12035   ffecom_file_ (name);
12036 }
12037
12038 /* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed
12039
12040    ffestorag st;
12041    ffecom_notify_init_storage(st);
12042
12043    Gets called when all possible units in an aggregate storage area (a LOCAL
12044    with equivalences or a COMMON) have been initialized.  The initialization
12045    info either is in ffestorag_init or, if that is NULL,
12046    ffestorag_accretion:
12047
12048    ffestorag_init may contain an opCONTER or opARRTER.  opCONTER may occur
12049    even for an array if the array is one element in length!
12050
12051    ffestorag_accretion will contain an opACCTER.  It is much like an
12052    opARRTER except it has an ffebit object in it instead of just a size.
12053    The back end can use the info in the ffebit object, if it wants, to
12054    reduce the amount of actual initialization, but in any case it should
12055    kill the ffebit object when done.  Also, set accretion to NULL but
12056    init to a non-NULL value.
12057
12058    After performing initialization, DO NOT set init to NULL, because that'll
12059    tell the front end it is ok for more initialization to happen.  Instead,
12060    set init to an opANY expression or some such thing that you can use to
12061    tell that you've already initialized the object.
12062
12063    27-Oct-91  JCB  1.1
12064       Support two-pass FFE.  */
12065
12066 void
12067 ffecom_notify_init_storage (ffestorag st)
12068 {
12069   ffebld init;                  /* The initialization expression. */
12070
12071   if (ffestorag_init (st) == NULL)
12072     {
12073       init = ffestorag_accretion (st);
12074       assert (init != NULL);
12075       ffestorag_set_accretion (st, NULL);
12076       ffestorag_set_accretes (st, 0);
12077       ffestorag_set_init (st, init);
12078     }
12079 }
12080
12081 /* ffecom_notify_init_symbol -- A symbol is now fully init'ed
12082
12083    ffesymbol s;
12084    ffecom_notify_init_symbol(s);
12085
12086    Gets called when all possible units in a symbol (not placed in COMMON
12087    or involved in EQUIVALENCE, unless it as yet has no ffestorag object)
12088    have been initialized.  The initialization info either is in
12089    ffesymbol_init or, if that is NULL, ffesymbol_accretion:
12090
12091    ffesymbol_init may contain an opCONTER or opARRTER.  opCONTER may occur
12092    even for an array if the array is one element in length!
12093
12094    ffesymbol_accretion will contain an opACCTER.  It is much like an
12095    opARRTER except it has an ffebit object in it instead of just a size.
12096    The back end can use the info in the ffebit object, if it wants, to
12097    reduce the amount of actual initialization, but in any case it should
12098    kill the ffebit object when done.  Also, set accretion to NULL but
12099    init to a non-NULL value.
12100
12101    After performing initialization, DO NOT set init to NULL, because that'll
12102    tell the front end it is ok for more initialization to happen.  Instead,
12103    set init to an opANY expression or some such thing that you can use to
12104    tell that you've already initialized the object.
12105
12106    27-Oct-91  JCB  1.1
12107       Support two-pass FFE.  */
12108
12109 void
12110 ffecom_notify_init_symbol (ffesymbol s)
12111 {
12112   ffebld init;                  /* The initialization expression. */
12113
12114   if (ffesymbol_storage (s) == NULL)
12115     return;                     /* Do nothing until COMMON/EQUIVALENCE
12116                                    possibilities checked. */
12117
12118   if ((ffesymbol_init (s) == NULL)
12119       && ((init = ffesymbol_accretion (s)) != NULL))
12120     {
12121       ffesymbol_set_accretion (s, NULL);
12122       ffesymbol_set_accretes (s, 0);
12123       ffesymbol_set_init (s, init);
12124     }
12125 }
12126
12127 /* ffecom_notify_primary_entry -- Learn which is the primary entry point
12128
12129    ffesymbol s;
12130    ffecom_notify_primary_entry(s);
12131
12132    Gets called when implicit or explicit PROGRAM statement seen or when
12133    FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary
12134    global symbol that serves as the entry point.  */
12135
12136 void
12137 ffecom_notify_primary_entry (ffesymbol s)
12138 {
12139   ffecom_primary_entry_ = s;
12140   ffecom_primary_entry_kind_ = ffesymbol_kind (s);
12141
12142   if ((ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
12143       || (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE))
12144     ffecom_primary_entry_is_proc_ = TRUE;
12145   else
12146     ffecom_primary_entry_is_proc_ = FALSE;
12147
12148   if (!ffe_is_silent ())
12149     {
12150       if (ffecom_primary_entry_kind_ == FFEINFO_kindPROGRAM)
12151         fprintf (stderr, "%s:\n", ffesymbol_text (s));
12152       else
12153         fprintf (stderr, "  %s:\n", ffesymbol_text (s));
12154     }
12155
12156   if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
12157     {
12158       ffebld list;
12159       ffebld arg;
12160
12161       for (list = ffesymbol_dummyargs (s);
12162            list != NULL;
12163            list = ffebld_trail (list))
12164         {
12165           arg = ffebld_head (list);
12166           if (ffebld_op (arg) == FFEBLD_opSTAR)
12167             {
12168               ffecom_is_altreturning_ = TRUE;
12169               break;
12170             }
12171         }
12172     }
12173 }
12174
12175 FILE *
12176 ffecom_open_include (char *name, ffewhereLine l, ffewhereColumn c)
12177 {
12178   return ffecom_open_include_ (name, l, c);
12179 }
12180
12181 /* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front
12182
12183    tree t;
12184    ffebld expr;  // FFE expression.
12185    tree = ffecom_ptr_to_expr(expr);
12186
12187    Like ffecom_expr, but sticks address-of in front of most things.  */
12188
12189 tree
12190 ffecom_ptr_to_expr (ffebld expr)
12191 {
12192   tree item;
12193   ffeinfoBasictype bt;
12194   ffeinfoKindtype kt;
12195   ffesymbol s;
12196
12197   assert (expr != NULL);
12198
12199   switch (ffebld_op (expr))
12200     {
12201     case FFEBLD_opSYMTER:
12202       s = ffebld_symter (expr);
12203       if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
12204         {
12205           ffecomGfrt ix;
12206
12207           ix = ffeintrin_gfrt_indirect (ffebld_symter_implementation (expr));
12208           assert (ix != FFECOM_gfrt);
12209           if ((item = ffecom_gfrt_[ix]) == NULL_TREE)
12210             {
12211               ffecom_make_gfrt_ (ix);
12212               item = ffecom_gfrt_[ix];
12213             }
12214         }
12215       else
12216         {
12217           item = ffesymbol_hook (s).decl_tree;
12218           if (item == NULL_TREE)
12219             {
12220               s = ffecom_sym_transform_ (s);
12221               item = ffesymbol_hook (s).decl_tree;
12222             }
12223         }
12224       assert (item != NULL);
12225       if (item == error_mark_node)
12226         return item;
12227       if (!ffesymbol_hook (s).addr)
12228         item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12229                          item);
12230       return item;
12231
12232     case FFEBLD_opARRAYREF:
12233       return ffecom_arrayref_ (NULL_TREE, expr, 1);
12234
12235     case FFEBLD_opCONTER:
12236
12237       bt = ffeinfo_basictype (ffebld_info (expr));
12238       kt = ffeinfo_kindtype (ffebld_info (expr));
12239
12240       item = ffecom_constantunion (&ffebld_constant_union
12241                                    (ffebld_conter (expr)), bt, kt,
12242                                    ffecom_tree_type[bt][kt]);
12243       if (item == error_mark_node)
12244         return error_mark_node;
12245       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12246                        item);
12247       return item;
12248
12249     case FFEBLD_opANY:
12250       return error_mark_node;
12251
12252     default:
12253       bt = ffeinfo_basictype (ffebld_info (expr));
12254       kt = ffeinfo_kindtype (ffebld_info (expr));
12255
12256       item = ffecom_expr (expr);
12257       if (item == error_mark_node)
12258         return error_mark_node;
12259
12260       /* The back end currently optimizes a bit too zealously for us, in that
12261          we fail JCB001 if the following block of code is omitted.  It checks
12262          to see if the transformed expression is a symbol or array reference,
12263          and encloses it in a SAVE_EXPR if that is the case.  */
12264
12265       STRIP_NOPS (item);
12266       if ((TREE_CODE (item) == VAR_DECL)
12267           || (TREE_CODE (item) == PARM_DECL)
12268           || (TREE_CODE (item) == RESULT_DECL)
12269           || (TREE_CODE (item) == INDIRECT_REF)
12270           || (TREE_CODE (item) == ARRAY_REF)
12271           || (TREE_CODE (item) == COMPONENT_REF)
12272 #ifdef OFFSET_REF
12273           || (TREE_CODE (item) == OFFSET_REF)
12274 #endif
12275           || (TREE_CODE (item) == BUFFER_REF)
12276           || (TREE_CODE (item) == REALPART_EXPR)
12277           || (TREE_CODE (item) == IMAGPART_EXPR))
12278         {
12279           item = ffecom_save_tree (item);
12280         }
12281
12282       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12283                        item);
12284       return item;
12285     }
12286
12287   assert ("fall-through error" == NULL);
12288   return error_mark_node;
12289 }
12290
12291 /* Obtain a temp var with given data type.
12292
12293    size is FFETARGET_charactersizeNONE for a non-CHARACTER type
12294    or >= 0 for a CHARACTER type.
12295
12296    elements is -1 for a scalar or > 0 for an array of type.  */
12297
12298 tree
12299 ffecom_make_tempvar (const char *commentary, tree type,
12300                      ffetargetCharacterSize size, int elements)
12301 {
12302   tree t;
12303   static int mynumber;
12304
12305   assert (current_binding_level->prep_state < 2);
12306
12307   if (type == error_mark_node)
12308     return error_mark_node;
12309
12310   if (size != FFETARGET_charactersizeNONE)
12311     type = build_array_type (type,
12312                              build_range_type (ffecom_f2c_ftnlen_type_node,
12313                                                ffecom_f2c_ftnlen_one_node,
12314                                                build_int_2 (size, 0)));
12315   if (elements != -1)
12316     type = build_array_type (type,
12317                              build_range_type (integer_type_node,
12318                                                integer_zero_node,
12319                                                build_int_2 (elements - 1,
12320                                                             0)));
12321   t = build_decl (VAR_DECL,
12322                   ffecom_get_invented_identifier ("__g77_%s_%d",
12323                                                   commentary,
12324                                                   mynumber++),
12325                   type);
12326
12327   t = start_decl (t, FALSE);
12328   finish_decl (t, NULL_TREE, FALSE);
12329
12330   return t;
12331 }
12332
12333 /* Prepare argument pointer to expression.
12334
12335    Like ffecom_prepare_expr, except for expressions to be evaluated
12336    via ffecom_arg_ptr_to_expr.  */
12337
12338 void
12339 ffecom_prepare_arg_ptr_to_expr (ffebld expr)
12340 {
12341   /* ~~For now, it seems to be the same thing.  */
12342   ffecom_prepare_expr (expr);
12343   return;
12344 }
12345
12346 /* End of preparations.  */
12347
12348 bool
12349 ffecom_prepare_end (void)
12350 {
12351   int prep_state = current_binding_level->prep_state;
12352
12353   assert (prep_state < 2);
12354   current_binding_level->prep_state = 2;
12355
12356   return (prep_state == 1) ? TRUE : FALSE;
12357 }
12358
12359 /* Prepare expression.
12360
12361    This is called before any code is generated for the current block.
12362    It scans the expression, declares any temporaries that might be needed
12363    during evaluation of the expression, and stores those temporaries in
12364    the appropriate "hook" fields of the expression.  `dest', if not NULL,
12365    specifies the destination that ffecom_expr_ will see, in case that
12366    helps avoid generating unused temporaries.
12367
12368    ~~Improve to avoid allocating unused temporaries by taking `dest'
12369    into account vis-a-vis aliasing requirements of complex/character
12370    functions.  */
12371
12372 void
12373 ffecom_prepare_expr_ (ffebld expr, ffebld dest UNUSED)
12374 {
12375   ffeinfoBasictype bt;
12376   ffeinfoKindtype kt;
12377   ffetargetCharacterSize sz;
12378   tree tempvar = NULL_TREE;
12379
12380   assert (current_binding_level->prep_state < 2);
12381
12382   if (! expr)
12383     return;
12384
12385   bt = ffeinfo_basictype (ffebld_info (expr));
12386   kt = ffeinfo_kindtype (ffebld_info (expr));
12387   sz = ffeinfo_size (ffebld_info (expr));
12388
12389   /* Generate whatever temporaries are needed to represent the result
12390      of the expression.  */
12391
12392   if (bt == FFEINFO_basictypeCHARACTER)
12393     {
12394       while (ffebld_op (expr) == FFEBLD_opPAREN)
12395         expr = ffebld_left (expr);
12396     }
12397
12398   switch (ffebld_op (expr))
12399     {
12400     default:
12401       /* Don't make temps for SYMTER, CONTER, etc.  */
12402       if (ffebld_arity (expr) == 0)
12403         break;
12404
12405       switch (bt)
12406         {
12407         case FFEINFO_basictypeCOMPLEX:
12408           if (ffebld_op (expr) == FFEBLD_opFUNCREF)
12409             {
12410               ffesymbol s;
12411
12412               if (ffebld_op (ffebld_left (expr)) != FFEBLD_opSYMTER)
12413                 break;
12414
12415               s = ffebld_symter (ffebld_left (expr));
12416               if (ffesymbol_where (s) == FFEINFO_whereCONSTANT
12417                   || (ffesymbol_where (s) != FFEINFO_whereINTRINSIC
12418                       && ! ffesymbol_is_f2c (s))
12419                   || (ffesymbol_where (s) == FFEINFO_whereINTRINSIC
12420                       && ! ffe_is_f2c_library ()))
12421                 break;
12422             }
12423           else if (ffebld_op (expr) == FFEBLD_opPOWER)
12424             {
12425               /* Requires special treatment.  There's no POW_CC function
12426                  in libg2c, so POW_ZZ is used, which means we always
12427                  need a double-complex temp, not a single-complex.  */
12428               kt = FFEINFO_kindtypeREAL2;
12429             }
12430           else if (ffebld_op (expr) != FFEBLD_opDIVIDE)
12431             /* The other ops don't need temps for complex operands.  */
12432             break;
12433
12434           /* ~~~Avoid making temps for some intrinsics, such as AIMAG(C),
12435              REAL(C).  See 19990325-0.f, routine `check', for cases.  */
12436           tempvar = ffecom_make_tempvar ("complex",
12437                                          ffecom_tree_type
12438                                          [FFEINFO_basictypeCOMPLEX][kt],
12439                                          FFETARGET_charactersizeNONE,
12440                                          -1);
12441           break;
12442
12443         case FFEINFO_basictypeCHARACTER:
12444           if (ffebld_op (expr) != FFEBLD_opFUNCREF)
12445             break;
12446
12447           if (sz == FFETARGET_charactersizeNONE)
12448             /* ~~Kludge alert!  This should someday be fixed. */
12449             sz = 24;
12450
12451           tempvar = ffecom_make_tempvar ("char", char_type_node, sz, -1);
12452           break;
12453
12454         default:
12455           break;
12456         }
12457       break;
12458
12459 #ifdef HAHA
12460     case FFEBLD_opPOWER:
12461       {
12462         tree rtype, ltype;
12463         tree rtmp, ltmp, result;
12464
12465         ltype = ffecom_type_expr (ffebld_left (expr));
12466         rtype = ffecom_type_expr (ffebld_right (expr));
12467
12468         rtmp = ffecom_make_tempvar (rtype, FFETARGET_charactersizeNONE, -1);
12469         ltmp = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
12470         result = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
12471
12472         tempvar = make_tree_vec (3);
12473         TREE_VEC_ELT (tempvar, 0) = rtmp;
12474         TREE_VEC_ELT (tempvar, 1) = ltmp;
12475         TREE_VEC_ELT (tempvar, 2) = result;
12476       }
12477       break;
12478 #endif  /* HAHA */
12479
12480     case FFEBLD_opCONCATENATE:
12481       {
12482         /* This gets special handling, because only one set of temps
12483            is needed for a tree of these -- the tree is treated as
12484            a flattened list of concatenations when generating code.  */
12485
12486         ffecomConcatList_ catlist;
12487         tree ltmp, itmp, result;
12488         int count;
12489         int i;
12490
12491         catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
12492         count = ffecom_concat_list_count_ (catlist);
12493
12494         if (count >= 2)
12495           {
12496             ltmp
12497               = ffecom_make_tempvar ("concat_len",
12498                                      ffecom_f2c_ftnlen_type_node,
12499                                      FFETARGET_charactersizeNONE, count);
12500             itmp
12501               = ffecom_make_tempvar ("concat_item",
12502                                      ffecom_f2c_address_type_node,
12503                                      FFETARGET_charactersizeNONE, count);
12504             result
12505               = ffecom_make_tempvar ("concat_res",
12506                                      char_type_node,
12507                                      ffecom_concat_list_maxlen_ (catlist),
12508                                      -1);
12509
12510             tempvar = make_tree_vec (3);
12511             TREE_VEC_ELT (tempvar, 0) = ltmp;
12512             TREE_VEC_ELT (tempvar, 1) = itmp;
12513             TREE_VEC_ELT (tempvar, 2) = result;
12514           }
12515
12516         for (i = 0; i < count; ++i)
12517           ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist,
12518                                                                     i));
12519
12520         ffecom_concat_list_kill_ (catlist);
12521
12522         if (tempvar)
12523           {
12524             ffebld_nonter_set_hook (expr, tempvar);
12525             current_binding_level->prep_state = 1;
12526           }
12527       }
12528       return;
12529
12530     case FFEBLD_opCONVERT:
12531       if (bt == FFEINFO_basictypeCHARACTER
12532           && ((ffebld_size_known (ffebld_left (expr))
12533                == FFETARGET_charactersizeNONE)
12534               || (ffebld_size_known (ffebld_left (expr)) >= sz)))
12535         tempvar = ffecom_make_tempvar ("convert", char_type_node, sz, -1);
12536       break;
12537     }
12538
12539   if (tempvar)
12540     {
12541       ffebld_nonter_set_hook (expr, tempvar);
12542       current_binding_level->prep_state = 1;
12543     }
12544
12545   /* Prepare subexpressions for this expr.  */
12546
12547   switch (ffebld_op (expr))
12548     {
12549     case FFEBLD_opPERCENT_LOC:
12550       ffecom_prepare_ptr_to_expr (ffebld_left (expr));
12551       break;
12552
12553     case FFEBLD_opPERCENT_VAL:
12554     case FFEBLD_opPERCENT_REF:
12555       ffecom_prepare_expr (ffebld_left (expr));
12556       break;
12557
12558     case FFEBLD_opPERCENT_DESCR:
12559       ffecom_prepare_arg_ptr_to_expr (ffebld_left (expr));
12560       break;
12561
12562     case FFEBLD_opITEM:
12563       {
12564         ffebld item;
12565
12566         for (item = expr;
12567              item != NULL;
12568              item = ffebld_trail (item))
12569           if (ffebld_head (item) != NULL)
12570             ffecom_prepare_expr (ffebld_head (item));
12571       }
12572       break;
12573
12574     default:
12575       /* Need to handle character conversion specially.  */
12576       switch (ffebld_arity (expr))
12577         {
12578         case 2:
12579           ffecom_prepare_expr (ffebld_left (expr));
12580           ffecom_prepare_expr (ffebld_right (expr));
12581           break;
12582
12583         case 1:
12584           ffecom_prepare_expr (ffebld_left (expr));
12585           break;
12586
12587         default:
12588           break;
12589         }
12590     }
12591
12592   return;
12593 }
12594
12595 /* Prepare expression for reading and writing.
12596
12597    Like ffecom_prepare_expr, except for expressions to be evaluated
12598    via ffecom_expr_rw.  */
12599
12600 void
12601 ffecom_prepare_expr_rw (tree type, ffebld expr)
12602 {
12603   /* This is all we support for now.  */
12604   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
12605
12606   /* ~~For now, it seems to be the same thing.  */
12607   ffecom_prepare_expr (expr);
12608   return;
12609 }
12610
12611 /* Prepare expression for writing.
12612
12613    Like ffecom_prepare_expr, except for expressions to be evaluated
12614    via ffecom_expr_w.  */
12615
12616 void
12617 ffecom_prepare_expr_w (tree type, ffebld expr)
12618 {
12619   /* This is all we support for now.  */
12620   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
12621
12622   /* ~~For now, it seems to be the same thing.  */
12623   ffecom_prepare_expr (expr);
12624   return;
12625 }
12626
12627 /* Prepare expression for returning.
12628
12629    Like ffecom_prepare_expr, except for expressions to be evaluated
12630    via ffecom_return_expr.  */
12631
12632 void
12633 ffecom_prepare_return_expr (ffebld expr)
12634 {
12635   assert (current_binding_level->prep_state < 2);
12636
12637   if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE
12638       && ffecom_is_altreturning_
12639       && expr != NULL)
12640     ffecom_prepare_expr (expr);
12641 }
12642
12643 /* Prepare pointer to expression.
12644
12645    Like ffecom_prepare_expr, except for expressions to be evaluated
12646    via ffecom_ptr_to_expr.  */
12647
12648 void
12649 ffecom_prepare_ptr_to_expr (ffebld expr)
12650 {
12651   /* ~~For now, it seems to be the same thing.  */
12652   ffecom_prepare_expr (expr);
12653   return;
12654 }
12655
12656 /* Transform expression into constant pointer-to-expression tree.
12657
12658    If the expression can be transformed into a pointer-to-expression tree
12659    that is constant, that is done, and the tree returned.  Else NULL_TREE
12660    is returned.
12661
12662    That way, a caller can attempt to provide compile-time initialization
12663    of a variable and, if that fails, *then* choose to start a new block
12664    and resort to using temporaries, as appropriate.  */
12665
12666 tree
12667 ffecom_ptr_to_const_expr (ffebld expr)
12668 {
12669   if (! expr)
12670     return integer_zero_node;
12671
12672   if (ffebld_op (expr) == FFEBLD_opANY)
12673     return error_mark_node;
12674
12675   if (ffebld_arity (expr) == 0
12676       && (ffebld_op (expr) != FFEBLD_opSYMTER
12677           || ffebld_where (expr) == FFEINFO_whereCOMMON
12678           || ffebld_where (expr) == FFEINFO_whereGLOBAL
12679           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
12680     {
12681       tree t;
12682
12683       t = ffecom_ptr_to_expr (expr);
12684       assert (TREE_CONSTANT (t));
12685       return t;
12686     }
12687
12688   return NULL_TREE;
12689 }
12690
12691 /* ffecom_return_expr -- Returns return-value expr given alt return expr
12692
12693    tree rtn;  // NULL_TREE means use expand_null_return()
12694    ffebld expr;  // NULL if no alt return expr to RETURN stmt
12695    rtn = ffecom_return_expr(expr);
12696
12697    Based on the program unit type and other info (like return function
12698    type, return master function type when alternate ENTRY points,
12699    whether subroutine has any alternate RETURN points, etc), returns the
12700    appropriate expression to be returned to the caller, or NULL_TREE
12701    meaning no return value or the caller expects it to be returned somewhere
12702    else (which is handled by other parts of this module).  */
12703
12704 tree
12705 ffecom_return_expr (ffebld expr)
12706 {
12707   tree rtn;
12708
12709   switch (ffecom_primary_entry_kind_)
12710     {
12711     case FFEINFO_kindPROGRAM:
12712     case FFEINFO_kindBLOCKDATA:
12713       rtn = NULL_TREE;
12714       break;
12715
12716     case FFEINFO_kindSUBROUTINE:
12717       if (!ffecom_is_altreturning_)
12718         rtn = NULL_TREE;        /* No alt returns, never an expr. */
12719       else if (expr == NULL)
12720         rtn = integer_zero_node;
12721       else
12722         rtn = ffecom_expr (expr);
12723       break;
12724
12725     case FFEINFO_kindFUNCTION:
12726       if ((ffecom_multi_retval_ != NULL_TREE)
12727           || (ffesymbol_basictype (ffecom_primary_entry_)
12728               == FFEINFO_basictypeCHARACTER)
12729           || ((ffesymbol_basictype (ffecom_primary_entry_)
12730                == FFEINFO_basictypeCOMPLEX)
12731               && (ffecom_num_entrypoints_ == 0)
12732               && ffesymbol_is_f2c (ffecom_primary_entry_)))
12733         {                       /* Value is returned by direct assignment
12734                                    into (implicit) dummy. */
12735           rtn = NULL_TREE;
12736           break;
12737         }
12738       rtn = ffecom_func_result_;
12739 #if 0
12740       /* Spurious error if RETURN happens before first reference!  So elide
12741          this code.  In particular, for debugging registry, rtn should always
12742          be non-null after all, but TREE_USED won't be set until we encounter
12743          a reference in the code.  Perfectly okay (but weird) code that,
12744          e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in
12745          this diagnostic for no reason.  Have people use -O -Wuninitialized
12746          and leave it to the back end to find obviously weird cases.  */
12747
12748       /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid
12749          situation; if the return value has never been referenced, it won't
12750          have a tree under 2pass mode. */
12751       if ((rtn == NULL_TREE)
12752           || !TREE_USED (rtn))
12753         {
12754           ffebad_start (FFEBAD_RETURN_VALUE_UNSET);
12755           ffebad_here (0, ffesymbol_where_line (ffecom_primary_entry_),
12756                        ffesymbol_where_column (ffecom_primary_entry_));
12757           ffebad_string (ffesymbol_text (ffesymbol_funcresult
12758                                          (ffecom_primary_entry_)));
12759           ffebad_finish ();
12760         }
12761 #endif
12762       break;
12763
12764     default:
12765       assert ("bad unit kind" == NULL);
12766     case FFEINFO_kindANY:
12767       rtn = error_mark_node;
12768       break;
12769     }
12770
12771   return rtn;
12772 }
12773
12774 /* Do save_expr only if tree is not error_mark_node.  */
12775
12776 tree
12777 ffecom_save_tree (tree t)
12778 {
12779   return save_expr (t);
12780 }
12781
12782 /* Start a compound statement (block).  */
12783
12784 void
12785 ffecom_start_compstmt (void)
12786 {
12787   bison_rule_pushlevel_ ();
12788 }
12789
12790 /* Public entry point for front end to access start_decl.  */
12791
12792 tree
12793 ffecom_start_decl (tree decl, bool is_initialized)
12794 {
12795   DECL_INITIAL (decl) = is_initialized ? error_mark_node : NULL_TREE;
12796   return start_decl (decl, FALSE);
12797 }
12798
12799 /* ffecom_sym_commit -- Symbol's state being committed to reality
12800
12801    ffesymbol s;
12802    ffecom_sym_commit(s);
12803
12804    Does whatever the backend needs when a symbol is committed after having
12805    been backtrackable for a period of time.  */
12806
12807 void
12808 ffecom_sym_commit (ffesymbol s UNUSED)
12809 {
12810   assert (!ffesymbol_retractable ());
12811 }
12812
12813 /* ffecom_sym_end_transition -- Perform end transition on all symbols
12814
12815    ffecom_sym_end_transition();
12816
12817    Does backend-specific stuff and also calls ffest_sym_end_transition
12818    to do the necessary FFE stuff.
12819
12820    Backtracking is never enabled when this fn is called, so don't worry
12821    about it.  */
12822
12823 ffesymbol
12824 ffecom_sym_end_transition (ffesymbol s)
12825 {
12826   ffestorag st;
12827
12828   assert (!ffesymbol_retractable ());
12829
12830   s = ffest_sym_end_transition (s);
12831
12832   if ((ffesymbol_kind (s) == FFEINFO_kindBLOCKDATA)
12833       && (ffesymbol_where (s) == FFEINFO_whereGLOBAL))
12834     {
12835       ffecom_list_blockdata_
12836         = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
12837                                               FFEINTRIN_specNONE,
12838                                               FFEINTRIN_impNONE),
12839                            ffecom_list_blockdata_);
12840     }
12841
12842   /* This is where we finally notice that a symbol has partial initialization
12843      and finalize it. */
12844
12845   if (ffesymbol_accretion (s) != NULL)
12846     {
12847       assert (ffesymbol_init (s) == NULL);
12848       ffecom_notify_init_symbol (s);
12849     }
12850   else if (((st = ffesymbol_storage (s)) != NULL)
12851            && ((st = ffestorag_parent (st)) != NULL)
12852            && (ffestorag_accretion (st) != NULL))
12853     {
12854       assert (ffestorag_init (st) == NULL);
12855       ffecom_notify_init_storage (st);
12856     }
12857
12858   if ((ffesymbol_kind (s) == FFEINFO_kindCOMMON)
12859       && (ffesymbol_where (s) == FFEINFO_whereLOCAL)
12860       && (ffesymbol_storage (s) != NULL))
12861     {
12862       ffecom_list_common_
12863         = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
12864                                               FFEINTRIN_specNONE,
12865                                               FFEINTRIN_impNONE),
12866                            ffecom_list_common_);
12867     }
12868
12869   return s;
12870 }
12871
12872 /* ffecom_sym_exec_transition -- Perform exec transition on all symbols
12873
12874    ffecom_sym_exec_transition();
12875
12876    Does backend-specific stuff and also calls ffest_sym_exec_transition
12877    to do the necessary FFE stuff.
12878
12879    See the long-winded description in ffecom_sym_learned for info
12880    on handling the situation where backtracking is inhibited.  */
12881
12882 ffesymbol
12883 ffecom_sym_exec_transition (ffesymbol s)
12884 {
12885   s = ffest_sym_exec_transition (s);
12886
12887   return s;
12888 }
12889
12890 /* ffecom_sym_learned -- Initial or more info gained on symbol after exec
12891
12892    ffesymbol s;
12893    s = ffecom_sym_learned(s);
12894
12895    Called when a new symbol is seen after the exec transition or when more
12896    info (perhaps) is gained for an UNCERTAIN symbol.  The symbol state when
12897    it arrives here is that all its latest info is updated already, so its
12898    state may be UNCERTAIN or UNDERSTOOD, it might already have the hook
12899    field filled in if its gone through here or exec_transition first, and
12900    so on.
12901
12902    The backend probably wants to check ffesymbol_retractable() to see if
12903    backtracking is in effect.  If so, the FFE's changes to the symbol may
12904    be retracted (undone) or committed (ratified), at which time the
12905    appropriate ffecom_sym_retract or _commit function will be called
12906    for that function.
12907
12908    If the backend has its own backtracking mechanism, great, use it so that
12909    committal is a simple operation.  Though it doesn't make much difference,
12910    I suppose: the reason for tentative symbol evolution in the FFE is to
12911    enable error detection in weird incorrect statements early and to disable
12912    incorrect error detection on a correct statement.  The backend is not
12913    likely to introduce any information that'll get involved in these
12914    considerations, so it is probably just fine that the implementation
12915    model for this fn and for _exec_transition is to not do anything
12916    (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE
12917    and instead wait until ffecom_sym_commit is called (which it never
12918    will be as long as we're using ambiguity-detecting statement analysis in
12919    the FFE, which we are initially to shake out the code, but don't depend
12920    on this), otherwise go ahead and do whatever is needed.
12921
12922    In essence, then, when this fn and _exec_transition get called while
12923    backtracking is enabled, a general mechanism would be to flag which (or
12924    both) of these were called (and in what order? neat question as to what
12925    might happen that I'm too lame to think through right now) and then when
12926    _commit is called reproduce the original calling sequence, if any, for
12927    the two fns (at which point backtracking will, of course, be disabled).  */
12928
12929 ffesymbol
12930 ffecom_sym_learned (ffesymbol s)
12931 {
12932   ffestorag_exec_layout (s);
12933
12934   return s;
12935 }
12936
12937 /* ffecom_sym_retract -- Symbol's state being retracted from reality
12938
12939    ffesymbol s;
12940    ffecom_sym_retract(s);
12941
12942    Does whatever the backend needs when a symbol is retracted after having
12943    been backtrackable for a period of time.  */
12944
12945 void
12946 ffecom_sym_retract (ffesymbol s UNUSED)
12947 {
12948   assert (!ffesymbol_retractable ());
12949
12950 #if 0                           /* GCC doesn't commit any backtrackable sins,
12951                                    so nothing needed here. */
12952   switch (ffesymbol_hook (s).state)
12953     {
12954     case 0:                     /* nothing happened yet. */
12955       break;
12956
12957     case 1:                     /* exec transition happened. */
12958       break;
12959
12960     case 2:                     /* learned happened. */
12961       break;
12962
12963     case 3:                     /* learned then exec. */
12964       break;
12965
12966     case 4:                     /* exec then learned. */
12967       break;
12968
12969     default:
12970       assert ("bad hook state" == NULL);
12971       break;
12972     }
12973 #endif
12974 }
12975
12976 /* Create temporary gcc label.  */
12977
12978 tree
12979 ffecom_temp_label ()
12980 {
12981   tree glabel;
12982   static int mynumber = 0;
12983
12984   glabel = build_decl (LABEL_DECL,
12985                        ffecom_get_invented_identifier ("__g77_label_%d",
12986                                                        mynumber++),
12987                        void_type_node);
12988   DECL_CONTEXT (glabel) = current_function_decl;
12989   DECL_MODE (glabel) = VOIDmode;
12990
12991   return glabel;
12992 }
12993
12994 /* Return an expression that is usable as an arg in a conditional context
12995    (IF, DO WHILE, .NOT., and so on).
12996
12997    Use the one provided for the back end as of >2.6.0.  */
12998
12999 tree
13000 ffecom_truth_value (tree expr)
13001 {
13002   return truthvalue_conversion (expr);
13003 }
13004
13005 /* Return the inversion of a truth value (the inversion of what
13006    ffecom_truth_value builds).
13007
13008    Apparently invert_truthvalue, which is properly in the back end, is
13009    enough for now, so just use it.  */
13010
13011 tree
13012 ffecom_truth_value_invert (tree expr)
13013 {
13014   return invert_truthvalue (ffecom_truth_value (expr));
13015 }
13016
13017 /* Return the tree that is the type of the expression, as would be
13018    returned in TREE_TYPE(ffecom_expr(expr)), without otherwise
13019    transforming the expression, generating temporaries, etc.  */
13020
13021 tree
13022 ffecom_type_expr (ffebld expr)
13023 {
13024   ffeinfoBasictype bt;
13025   ffeinfoKindtype kt;
13026   tree tree_type;
13027
13028   assert (expr != NULL);
13029
13030   bt = ffeinfo_basictype (ffebld_info (expr));
13031   kt = ffeinfo_kindtype (ffebld_info (expr));
13032   tree_type = ffecom_tree_type[bt][kt];
13033
13034   switch (ffebld_op (expr))
13035     {
13036     case FFEBLD_opCONTER:
13037     case FFEBLD_opSYMTER:
13038     case FFEBLD_opARRAYREF:
13039     case FFEBLD_opUPLUS:
13040     case FFEBLD_opPAREN:
13041     case FFEBLD_opUMINUS:
13042     case FFEBLD_opADD:
13043     case FFEBLD_opSUBTRACT:
13044     case FFEBLD_opMULTIPLY:
13045     case FFEBLD_opDIVIDE:
13046     case FFEBLD_opPOWER:
13047     case FFEBLD_opNOT:
13048     case FFEBLD_opFUNCREF:
13049     case FFEBLD_opSUBRREF:
13050     case FFEBLD_opAND:
13051     case FFEBLD_opOR:
13052     case FFEBLD_opXOR:
13053     case FFEBLD_opNEQV:
13054     case FFEBLD_opEQV:
13055     case FFEBLD_opCONVERT:
13056     case FFEBLD_opLT:
13057     case FFEBLD_opLE:
13058     case FFEBLD_opEQ:
13059     case FFEBLD_opNE:
13060     case FFEBLD_opGT:
13061     case FFEBLD_opGE:
13062     case FFEBLD_opPERCENT_LOC:
13063       return tree_type;
13064
13065     case FFEBLD_opACCTER:
13066     case FFEBLD_opARRTER:
13067     case FFEBLD_opITEM:
13068     case FFEBLD_opSTAR:
13069     case FFEBLD_opBOUNDS:
13070     case FFEBLD_opREPEAT:
13071     case FFEBLD_opLABTER:
13072     case FFEBLD_opLABTOK:
13073     case FFEBLD_opIMPDO:
13074     case FFEBLD_opCONCATENATE:
13075     case FFEBLD_opSUBSTR:
13076     default:
13077       assert ("bad op for ffecom_type_expr" == NULL);
13078       /* Fall through. */
13079     case FFEBLD_opANY:
13080       return error_mark_node;
13081     }
13082 }
13083
13084 /* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points
13085
13086    If the PARM_DECL already exists, return it, else create it.  It's an
13087    integer_type_node argument for the master function that implements a
13088    subroutine or function with more than one entrypoint and is bound at
13089    run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for
13090    first ENTRY statement, and so on).  */
13091
13092 tree
13093 ffecom_which_entrypoint_decl ()
13094 {
13095   assert (ffecom_which_entrypoint_decl_ != NULL_TREE);
13096
13097   return ffecom_which_entrypoint_decl_;
13098 }
13099 \f
13100 /* The following sections consists of private and public functions
13101    that have the same names and perform roughly the same functions
13102    as counterparts in the C front end.  Changes in the C front end
13103    might affect how things should be done here.  Only functions
13104    needed by the back end should be public here; the rest should
13105    be private (static in the C sense).  Functions needed by other
13106    g77 front-end modules should be accessed by them via public
13107    ffecom_* names, which should themselves call private versions
13108    in this section so the private versions are easy to recognize
13109    when upgrading to a new gcc and finding interesting changes
13110    in the front end.
13111
13112    Functions named after rule "foo:" in c-parse.y are named
13113    "bison_rule_foo_" so they are easy to find.  */
13114
13115 static void
13116 bison_rule_pushlevel_ ()
13117 {
13118   emit_line_note (input_filename, lineno);
13119   pushlevel (0);
13120   clear_last_expr ();
13121   expand_start_bindings (0);
13122 }
13123
13124 static tree
13125 bison_rule_compstmt_ ()
13126 {
13127   tree t;
13128   int keep = kept_level_p ();
13129
13130   /* Make the temps go away.  */
13131   if (! keep)
13132     current_binding_level->names = NULL_TREE;
13133
13134   emit_line_note (input_filename, lineno);
13135   expand_end_bindings (getdecls (), keep, 0);
13136   t = poplevel (keep, 1, 0);
13137
13138   return t;
13139 }
13140
13141 /* Return a definition for a builtin function named NAME and whose data type
13142    is TYPE.  TYPE should be a function type with argument types.
13143    FUNCTION_CODE tells later passes how to compile calls to this function.
13144    See tree.h for its possible values.
13145
13146    If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
13147    the name to be called if we can't opencode the function.  */
13148
13149 tree
13150 builtin_function (const char *name, tree type, int function_code,
13151                   enum built_in_class class,
13152                   const char *library_name)
13153 {
13154   tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type);
13155   DECL_EXTERNAL (decl) = 1;
13156   TREE_PUBLIC (decl) = 1;
13157   if (library_name)
13158     SET_DECL_ASSEMBLER_NAME (decl, get_identifier (library_name));
13159   make_decl_rtl (decl, NULL);
13160   pushdecl (decl);
13161   DECL_BUILT_IN_CLASS (decl) = class;
13162   DECL_FUNCTION_CODE (decl) = function_code;
13163
13164   return decl;
13165 }
13166
13167 /* Handle when a new declaration NEWDECL
13168    has the same name as an old one OLDDECL
13169    in the same binding contour.
13170    Prints an error message if appropriate.
13171
13172    If safely possible, alter OLDDECL to look like NEWDECL, and return 1.
13173    Otherwise, return 0.  */
13174
13175 static int
13176 duplicate_decls (tree newdecl, tree olddecl)
13177 {
13178   int types_match = 1;
13179   int new_is_definition = (TREE_CODE (newdecl) == FUNCTION_DECL
13180                            && DECL_INITIAL (newdecl) != 0);
13181   tree oldtype = TREE_TYPE (olddecl);
13182   tree newtype = TREE_TYPE (newdecl);
13183
13184   if (olddecl == newdecl)
13185     return 1;
13186
13187   if (TREE_CODE (newtype) == ERROR_MARK
13188       || TREE_CODE (oldtype) == ERROR_MARK)
13189     types_match = 0;
13190
13191   /* New decl is completely inconsistent with the old one =>
13192      tell caller to replace the old one.
13193      This is always an error except in the case of shadowing a builtin.  */
13194   if (TREE_CODE (olddecl) != TREE_CODE (newdecl))
13195     return 0;
13196
13197   /* For real parm decl following a forward decl,
13198      return 1 so old decl will be reused.  */
13199   if (types_match && TREE_CODE (newdecl) == PARM_DECL
13200       && TREE_ASM_WRITTEN (olddecl) && ! TREE_ASM_WRITTEN (newdecl))
13201     return 1;
13202
13203   /* The new declaration is the same kind of object as the old one.
13204      The declarations may partially match.  Print warnings if they don't
13205      match enough.  Ultimately, copy most of the information from the new
13206      decl to the old one, and keep using the old one.  */
13207
13208   if (TREE_CODE (olddecl) == FUNCTION_DECL
13209       && DECL_BUILT_IN (olddecl))
13210     {
13211       /* A function declaration for a built-in function.  */
13212       if (!TREE_PUBLIC (newdecl))
13213         return 0;
13214       else if (!types_match)
13215         {
13216           /* Accept the return type of the new declaration if same modes.  */
13217           tree oldreturntype = TREE_TYPE (TREE_TYPE (olddecl));
13218           tree newreturntype = TREE_TYPE (TREE_TYPE (newdecl));
13219
13220           if (TYPE_MODE (oldreturntype) == TYPE_MODE (newreturntype))
13221             {
13222               /* Function types may be shared, so we can't just modify
13223                  the return type of olddecl's function type.  */
13224               tree newtype
13225                 = build_function_type (newreturntype,
13226                                        TYPE_ARG_TYPES (TREE_TYPE (olddecl)));
13227
13228               types_match = 1;
13229               if (types_match)
13230                 TREE_TYPE (olddecl) = newtype;
13231             }
13232         }
13233       if (!types_match)
13234         return 0;
13235     }
13236   else if (TREE_CODE (olddecl) == FUNCTION_DECL
13237            && DECL_SOURCE_LINE (olddecl) == 0)
13238     {
13239       /* A function declaration for a predeclared function
13240          that isn't actually built in.  */
13241       if (!TREE_PUBLIC (newdecl))
13242         return 0;
13243       else if (!types_match)
13244         {
13245           /* If the types don't match, preserve volatility indication.
13246              Later on, we will discard everything else about the
13247              default declaration.  */
13248           TREE_THIS_VOLATILE (newdecl) |= TREE_THIS_VOLATILE (olddecl);
13249         }
13250     }
13251
13252   /* Copy all the DECL_... slots specified in the new decl
13253      except for any that we copy here from the old type.
13254
13255      Past this point, we don't change OLDTYPE and NEWTYPE
13256      even if we change the types of NEWDECL and OLDDECL.  */
13257
13258   if (types_match)
13259     {
13260       /* Merge the data types specified in the two decls.  */
13261       if (TREE_CODE (newdecl) != FUNCTION_DECL || !DECL_BUILT_IN (olddecl))
13262         TREE_TYPE (newdecl)
13263           = TREE_TYPE (olddecl)
13264             = TREE_TYPE (newdecl);
13265
13266       /* Lay the type out, unless already done.  */
13267       if (oldtype != TREE_TYPE (newdecl))
13268         {
13269           if (TREE_TYPE (newdecl) != error_mark_node)
13270             layout_type (TREE_TYPE (newdecl));
13271           if (TREE_CODE (newdecl) != FUNCTION_DECL
13272               && TREE_CODE (newdecl) != TYPE_DECL
13273               && TREE_CODE (newdecl) != CONST_DECL)
13274             layout_decl (newdecl, 0);
13275         }
13276       else
13277         {
13278           /* Since the type is OLDDECL's, make OLDDECL's size go with.  */
13279           DECL_SIZE (newdecl) = DECL_SIZE (olddecl);
13280           DECL_SIZE_UNIT (newdecl) = DECL_SIZE_UNIT (olddecl);
13281           if (TREE_CODE (olddecl) != FUNCTION_DECL)
13282             if (DECL_ALIGN (olddecl) > DECL_ALIGN (newdecl))
13283               {
13284                 DECL_ALIGN (newdecl) = DECL_ALIGN (olddecl);
13285                 DECL_USER_ALIGN (newdecl) |= DECL_USER_ALIGN (olddecl);
13286               }
13287         }
13288
13289       /* Keep the old rtl since we can safely use it.  */
13290       COPY_DECL_RTL (olddecl, newdecl);
13291
13292       /* Merge the type qualifiers.  */
13293       if (DECL_BUILT_IN_NONANSI (olddecl) && TREE_THIS_VOLATILE (olddecl)
13294           && !TREE_THIS_VOLATILE (newdecl))
13295         TREE_THIS_VOLATILE (olddecl) = 0;
13296       if (TREE_READONLY (newdecl))
13297         TREE_READONLY (olddecl) = 1;
13298       if (TREE_THIS_VOLATILE (newdecl))
13299         {
13300           TREE_THIS_VOLATILE (olddecl) = 1;
13301           if (TREE_CODE (newdecl) == VAR_DECL)
13302             make_var_volatile (newdecl);
13303         }
13304
13305       /* Keep source location of definition rather than declaration.
13306          Likewise, keep decl at outer scope.  */
13307       if ((DECL_INITIAL (newdecl) == 0 && DECL_INITIAL (olddecl) != 0)
13308           || (DECL_CONTEXT (newdecl) != 0 && DECL_CONTEXT (olddecl) == 0))
13309         {
13310           DECL_SOURCE_LINE (newdecl) = DECL_SOURCE_LINE (olddecl);
13311           DECL_SOURCE_FILE (newdecl) = DECL_SOURCE_FILE (olddecl);
13312
13313           if (DECL_CONTEXT (olddecl) == 0
13314               && TREE_CODE (newdecl) != FUNCTION_DECL)
13315             DECL_CONTEXT (newdecl) = 0;
13316         }
13317
13318       /* Merge the unused-warning information.  */
13319       if (DECL_IN_SYSTEM_HEADER (olddecl))
13320         DECL_IN_SYSTEM_HEADER (newdecl) = 1;
13321       else if (DECL_IN_SYSTEM_HEADER (newdecl))
13322         DECL_IN_SYSTEM_HEADER (olddecl) = 1;
13323
13324       /* Merge the initialization information.  */
13325       if (DECL_INITIAL (newdecl) == 0)
13326         DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13327
13328       /* Merge the section attribute.
13329          We want to issue an error if the sections conflict but that must be
13330          done later in decl_attributes since we are called before attributes
13331          are assigned.  */
13332       if (DECL_SECTION_NAME (newdecl) == NULL_TREE)
13333         DECL_SECTION_NAME (newdecl) = DECL_SECTION_NAME (olddecl);
13334
13335       if (TREE_CODE (newdecl) == FUNCTION_DECL)
13336         {
13337           DECL_STATIC_CONSTRUCTOR(newdecl) |= DECL_STATIC_CONSTRUCTOR(olddecl);
13338           DECL_STATIC_DESTRUCTOR (newdecl) |= DECL_STATIC_DESTRUCTOR (olddecl);
13339         }
13340     }
13341   /* If cannot merge, then use the new type and qualifiers,
13342      and don't preserve the old rtl.  */
13343   else
13344     {
13345       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13346       TREE_READONLY (olddecl) = TREE_READONLY (newdecl);
13347       TREE_THIS_VOLATILE (olddecl) = TREE_THIS_VOLATILE (newdecl);
13348       TREE_SIDE_EFFECTS (olddecl) = TREE_SIDE_EFFECTS (newdecl);
13349     }
13350
13351   /* Merge the storage class information.  */
13352   /* For functions, static overrides non-static.  */
13353   if (TREE_CODE (newdecl) == FUNCTION_DECL)
13354     {
13355       TREE_PUBLIC (newdecl) &= TREE_PUBLIC (olddecl);
13356       /* This is since we don't automatically
13357          copy the attributes of NEWDECL into OLDDECL.  */
13358       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13359       /* If this clears `static', clear it in the identifier too.  */
13360       if (! TREE_PUBLIC (olddecl))
13361         TREE_PUBLIC (DECL_NAME (olddecl)) = 0;
13362     }
13363   if (DECL_EXTERNAL (newdecl))
13364     {
13365       TREE_STATIC (newdecl) = TREE_STATIC (olddecl);
13366       DECL_EXTERNAL (newdecl) = DECL_EXTERNAL (olddecl);
13367       /* An extern decl does not override previous storage class.  */
13368       TREE_PUBLIC (newdecl) = TREE_PUBLIC (olddecl);
13369     }
13370   else
13371     {
13372       TREE_STATIC (olddecl) = TREE_STATIC (newdecl);
13373       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13374     }
13375
13376   /* If either decl says `inline', this fn is inline,
13377      unless its definition was passed already.  */
13378   if (DECL_INLINE (newdecl) && DECL_INITIAL (olddecl) == 0)
13379     DECL_INLINE (olddecl) = 1;
13380   DECL_INLINE (newdecl) = DECL_INLINE (olddecl);
13381
13382   /* Get rid of any built-in function if new arg types don't match it
13383      or if we have a function definition.  */
13384   if (TREE_CODE (newdecl) == FUNCTION_DECL
13385       && DECL_BUILT_IN (olddecl)
13386       && (!types_match || new_is_definition))
13387     {
13388       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13389       DECL_BUILT_IN_CLASS (olddecl) = NOT_BUILT_IN;
13390     }
13391
13392   /* If redeclaring a builtin function, and not a definition,
13393      it stays built in.
13394      Also preserve various other info from the definition.  */
13395   if (TREE_CODE (newdecl) == FUNCTION_DECL && !new_is_definition)
13396     {
13397       if (DECL_BUILT_IN (olddecl))
13398         {
13399           DECL_BUILT_IN_CLASS (newdecl) = DECL_BUILT_IN_CLASS (olddecl);
13400           DECL_FUNCTION_CODE (newdecl) = DECL_FUNCTION_CODE (olddecl);
13401         }
13402
13403       DECL_RESULT (newdecl) = DECL_RESULT (olddecl);
13404       DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13405       DECL_SAVED_INSNS (newdecl) = DECL_SAVED_INSNS (olddecl);
13406       DECL_ARGUMENTS (newdecl) = DECL_ARGUMENTS (olddecl);
13407     }
13408
13409   /* Copy most of the decl-specific fields of NEWDECL into OLDDECL.
13410      But preserve olddecl's DECL_UID.  */
13411   {
13412     register unsigned olddecl_uid = DECL_UID (olddecl);
13413
13414     memcpy ((char *) olddecl + sizeof (struct tree_common),
13415             (char *) newdecl + sizeof (struct tree_common),
13416             sizeof (struct tree_decl) - sizeof (struct tree_common));
13417     DECL_UID (olddecl) = olddecl_uid;
13418   }
13419
13420   return 1;
13421 }
13422
13423 /* Finish processing of a declaration;
13424    install its initial value.
13425    If the length of an array type is not known before,
13426    it must be determined now, from the initial value, or it is an error.  */
13427
13428 static void
13429 finish_decl (tree decl, tree init, bool is_top_level)
13430 {
13431   register tree type = TREE_TYPE (decl);
13432   int was_incomplete = (DECL_SIZE (decl) == 0);
13433   bool at_top_level = (current_binding_level == global_binding_level);
13434   bool top_level = is_top_level || at_top_level;
13435
13436   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13437      level anyway.  */
13438   assert (!is_top_level || !at_top_level);
13439
13440   if (TREE_CODE (decl) == PARM_DECL)
13441     assert (init == NULL_TREE);
13442   /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it
13443      overlaps DECL_ARG_TYPE.  */
13444   else if (init == NULL_TREE)
13445     assert (DECL_INITIAL (decl) == NULL_TREE);
13446   else
13447     assert (DECL_INITIAL (decl) == error_mark_node);
13448
13449   if (init != NULL_TREE)
13450     {
13451       if (TREE_CODE (decl) != TYPE_DECL)
13452         DECL_INITIAL (decl) = init;
13453       else
13454         {
13455           /* typedef foo = bar; store the type of bar as the type of foo.  */
13456           TREE_TYPE (decl) = TREE_TYPE (init);
13457           DECL_INITIAL (decl) = init = 0;
13458         }
13459     }
13460
13461   /* Deduce size of array from initialization, if not already known */
13462
13463   if (TREE_CODE (type) == ARRAY_TYPE
13464       && TYPE_DOMAIN (type) == 0
13465       && TREE_CODE (decl) != TYPE_DECL)
13466     {
13467       assert (top_level);
13468       assert (was_incomplete);
13469
13470       layout_decl (decl, 0);
13471     }
13472
13473   if (TREE_CODE (decl) == VAR_DECL)
13474     {
13475       if (DECL_SIZE (decl) == NULL_TREE
13476           && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
13477         layout_decl (decl, 0);
13478
13479       if (DECL_SIZE (decl) == NULL_TREE
13480           && (TREE_STATIC (decl)
13481               ?
13482       /* A static variable with an incomplete type is an error if it is
13483          initialized. Also if it is not file scope. Otherwise, let it
13484          through, but if it is not `extern' then it may cause an error
13485          message later.  */
13486               (DECL_INITIAL (decl) != 0 || DECL_CONTEXT (decl) != 0)
13487               :
13488       /* An automatic variable with an incomplete type is an error.  */
13489               !DECL_EXTERNAL (decl)))
13490         {
13491           assert ("storage size not known" == NULL);
13492           abort ();
13493         }
13494
13495       if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl))
13496           && (DECL_SIZE (decl) != 0)
13497           && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST))
13498         {
13499           assert ("storage size not constant" == NULL);
13500           abort ();
13501         }
13502     }
13503
13504   /* Output the assembler code and/or RTL code for variables and functions,
13505      unless the type is an undefined structure or union. If not, it will get
13506      done when the type is completed.  */
13507
13508   if (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == FUNCTION_DECL)
13509     {
13510       rest_of_decl_compilation (decl, NULL,
13511                                 DECL_CONTEXT (decl) == 0,
13512                                 0);
13513
13514       if (DECL_CONTEXT (decl) != 0)
13515         {
13516           /* Recompute the RTL of a local array now if it used to be an
13517              incomplete type.  */
13518           if (was_incomplete
13519               && !TREE_STATIC (decl) && !DECL_EXTERNAL (decl))
13520             {
13521               /* If we used it already as memory, it must stay in memory.  */
13522               TREE_ADDRESSABLE (decl) = TREE_USED (decl);
13523               /* If it's still incomplete now, no init will save it.  */
13524               if (DECL_SIZE (decl) == 0)
13525                 DECL_INITIAL (decl) = 0;
13526               expand_decl (decl);
13527             }
13528           /* Compute and store the initial value.  */
13529           if (TREE_CODE (decl) != FUNCTION_DECL)
13530             expand_decl_init (decl);
13531         }
13532     }
13533   else if (TREE_CODE (decl) == TYPE_DECL)
13534     {
13535       rest_of_decl_compilation (decl, NULL,
13536                                 DECL_CONTEXT (decl) == 0,
13537                                 0);
13538     }
13539
13540   /* At the end of a declaration, throw away any variable type sizes of types
13541      defined inside that declaration.  There is no use computing them in the
13542      following function definition.  */
13543   if (current_binding_level == global_binding_level)
13544     get_pending_sizes ();
13545 }
13546
13547 /* Finish up a function declaration and compile that function
13548    all the way to assembler language output.  The free the storage
13549    for the function definition.
13550
13551    This is called after parsing the body of the function definition.
13552
13553    NESTED is nonzero if the function being finished is nested in another.  */
13554
13555 static void
13556 finish_function (int nested)
13557 {
13558   register tree fndecl = current_function_decl;
13559
13560   assert (fndecl != NULL_TREE);
13561   if (TREE_CODE (fndecl) != ERROR_MARK)
13562     {
13563       if (nested)
13564         assert (DECL_CONTEXT (fndecl) != NULL_TREE);
13565       else
13566         assert (DECL_CONTEXT (fndecl) == NULL_TREE);
13567     }
13568
13569 /*  TREE_READONLY (fndecl) = 1;
13570     This caused &foo to be of type ptr-to-const-function
13571     which then got a warning when stored in a ptr-to-function variable.  */
13572
13573   poplevel (1, 0, 1);
13574
13575   if (TREE_CODE (fndecl) != ERROR_MARK)
13576     {
13577       BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
13578
13579       /* Must mark the RESULT_DECL as being in this function.  */
13580
13581       DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl;
13582
13583       /* Obey `register' declarations if `setjmp' is called in this fn.  */
13584       /* Generate rtl for function exit.  */
13585       expand_function_end (input_filename, lineno, 0);
13586
13587       /* If this is a nested function, protect the local variables in the stack
13588          above us from being collected while we're compiling this function.  */
13589       if (nested)
13590         ggc_push_context ();
13591
13592       /* Run the optimizers and output the assembler code for this function.  */
13593       rest_of_compilation (fndecl);
13594
13595       /* Undo the GC context switch.  */
13596       if (nested)
13597         ggc_pop_context ();
13598     }
13599
13600   if (TREE_CODE (fndecl) != ERROR_MARK
13601       && !nested
13602       && DECL_SAVED_INSNS (fndecl) == 0)
13603     {
13604       /* Stop pointing to the local nodes about to be freed.  */
13605       /* But DECL_INITIAL must remain nonzero so we know this was an actual
13606          function definition.  */
13607       /* For a nested function, this is done in pop_f_function_context.  */
13608       /* If rest_of_compilation set this to 0, leave it 0.  */
13609       if (DECL_INITIAL (fndecl) != 0)
13610         DECL_INITIAL (fndecl) = error_mark_node;
13611       DECL_ARGUMENTS (fndecl) = 0;
13612     }
13613
13614   if (!nested)
13615     {
13616       /* Let the error reporting routines know that we're outside a function.
13617          For a nested function, this value is used in pop_c_function_context
13618          and then reset via pop_function_context.  */
13619       ffecom_outer_function_decl_ = current_function_decl = NULL;
13620     }
13621 }
13622
13623 /* Plug-in replacement for identifying the name of a decl and, for a
13624    function, what we call it in diagnostics.  For now, "program unit"
13625    should suffice, since it's a bit of a hassle to figure out which
13626    of several kinds of things it is.  Note that it could conceivably
13627    be a statement function, which probably isn't really a program unit
13628    per se, but if that comes up, it should be easy to check (being a
13629    nested function and all).  */
13630
13631 static const char *
13632 lang_printable_name (tree decl, int v)
13633 {
13634   /* Just to keep GCC quiet about the unused variable.
13635      In theory, differing values of V should produce different
13636      output.  */
13637   switch (v)
13638     {
13639     default:
13640       if (TREE_CODE (decl) == ERROR_MARK)
13641         return "erroneous code";
13642       return IDENTIFIER_POINTER (DECL_NAME (decl));
13643     }
13644 }
13645
13646 /* g77's function to print out name of current function that caused
13647    an error.  */
13648
13649 static void
13650 lang_print_error_function (diagnostic_context *context __attribute__((unused)),
13651                            const char *file)
13652 {
13653   static ffeglobal last_g = NULL;
13654   static ffesymbol last_s = NULL;
13655   ffeglobal g;
13656   ffesymbol s;
13657   const char *kind;
13658
13659   if ((ffecom_primary_entry_ == NULL)
13660       || (ffesymbol_global (ffecom_primary_entry_) == NULL))
13661     {
13662       g = NULL;
13663       s = NULL;
13664       kind = NULL;
13665     }
13666   else
13667     {
13668       g = ffesymbol_global (ffecom_primary_entry_);
13669       if (ffecom_nested_entry_ == NULL)
13670         {
13671           s = ffecom_primary_entry_;
13672           switch (ffesymbol_kind (s))
13673             {
13674             case FFEINFO_kindFUNCTION:
13675               kind = "function";
13676               break;
13677
13678             case FFEINFO_kindSUBROUTINE:
13679               kind = "subroutine";
13680               break;
13681
13682             case FFEINFO_kindPROGRAM:
13683               kind = "program";
13684               break;
13685
13686             case FFEINFO_kindBLOCKDATA:
13687               kind = "block-data";
13688               break;
13689
13690             default:
13691               kind = ffeinfo_kind_message (ffesymbol_kind (s));
13692               break;
13693             }
13694         }
13695       else
13696         {
13697           s = ffecom_nested_entry_;
13698           kind = "statement function";
13699         }
13700     }
13701
13702   if ((last_g != g) || (last_s != s))
13703     {
13704       if (file)
13705         fprintf (stderr, "%s: ", file);
13706
13707       if (s == NULL)
13708         fprintf (stderr, "Outside of any program unit:\n");
13709       else
13710         {
13711           const char *name = ffesymbol_text (s);
13712
13713           fprintf (stderr, "In %s `%s':\n", kind, name);
13714         }
13715
13716       last_g = g;
13717       last_s = s;
13718     }
13719 }
13720
13721 /* Similar to `lookup_name' but look only at current binding level.  */
13722
13723 static tree
13724 lookup_name_current_level (tree name)
13725 {
13726   register tree t;
13727
13728   if (current_binding_level == global_binding_level)
13729     return IDENTIFIER_GLOBAL_VALUE (name);
13730
13731   if (IDENTIFIER_LOCAL_VALUE (name) == 0)
13732     return 0;
13733
13734   for (t = current_binding_level->names; t; t = TREE_CHAIN (t))
13735     if (DECL_NAME (t) == name)
13736       break;
13737
13738   return t;
13739 }
13740
13741 /* Create a new `struct binding_level'.  */
13742
13743 static struct binding_level *
13744 make_binding_level ()
13745 {
13746   /* NOSTRICT */
13747   return (struct binding_level *) xmalloc (sizeof (struct binding_level));
13748 }
13749
13750 /* Save and restore the variables in this file and elsewhere
13751    that keep track of the progress of compilation of the current function.
13752    Used for nested functions.  */
13753
13754 struct f_function
13755 {
13756   struct f_function *next;
13757   tree named_labels;
13758   tree shadowed_labels;
13759   struct binding_level *binding_level;
13760 };
13761
13762 struct f_function *f_function_chain;
13763
13764 /* Restore the variables used during compilation of a C function.  */
13765
13766 static void
13767 pop_f_function_context ()
13768 {
13769   struct f_function *p = f_function_chain;
13770   tree link;
13771
13772   /* Bring back all the labels that were shadowed.  */
13773   for (link = shadowed_labels; link; link = TREE_CHAIN (link))
13774     if (DECL_NAME (TREE_VALUE (link)) != 0)
13775       IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link)))
13776         = TREE_VALUE (link);
13777
13778   if (current_function_decl != error_mark_node
13779       && DECL_SAVED_INSNS (current_function_decl) == 0)
13780     {
13781       /* Stop pointing to the local nodes about to be freed.  */
13782       /* But DECL_INITIAL must remain nonzero so we know this was an actual
13783          function definition.  */
13784       DECL_INITIAL (current_function_decl) = error_mark_node;
13785       DECL_ARGUMENTS (current_function_decl) = 0;
13786     }
13787
13788   pop_function_context ();
13789
13790   f_function_chain = p->next;
13791
13792   named_labels = p->named_labels;
13793   shadowed_labels = p->shadowed_labels;
13794   current_binding_level = p->binding_level;
13795
13796   free (p);
13797 }
13798
13799 /* Save and reinitialize the variables
13800    used during compilation of a C function.  */
13801
13802 static void
13803 push_f_function_context ()
13804 {
13805   struct f_function *p
13806   = (struct f_function *) xmalloc (sizeof (struct f_function));
13807
13808   push_function_context ();
13809
13810   p->next = f_function_chain;
13811   f_function_chain = p;
13812
13813   p->named_labels = named_labels;
13814   p->shadowed_labels = shadowed_labels;
13815   p->binding_level = current_binding_level;
13816 }
13817
13818 static void
13819 push_parm_decl (tree parm)
13820 {
13821   int old_immediate_size_expand = immediate_size_expand;
13822
13823   /* Don't try computing parm sizes now -- wait till fn is called.  */
13824
13825   immediate_size_expand = 0;
13826
13827   /* Fill in arg stuff.  */
13828
13829   DECL_ARG_TYPE (parm) = TREE_TYPE (parm);
13830   DECL_ARG_TYPE_AS_WRITTEN (parm) = TREE_TYPE (parm);
13831   TREE_READONLY (parm) = 1;     /* All implementation args are read-only. */
13832
13833   parm = pushdecl (parm);
13834
13835   immediate_size_expand = old_immediate_size_expand;
13836
13837   finish_decl (parm, NULL_TREE, FALSE);
13838 }
13839
13840 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate.  */
13841
13842 static tree
13843 pushdecl_top_level (x)
13844      tree x;
13845 {
13846   register tree t;
13847   register struct binding_level *b = current_binding_level;
13848   register tree f = current_function_decl;
13849
13850   current_binding_level = global_binding_level;
13851   current_function_decl = NULL_TREE;
13852   t = pushdecl (x);
13853   current_binding_level = b;
13854   current_function_decl = f;
13855   return t;
13856 }
13857
13858 /* Store the list of declarations of the current level.
13859    This is done for the parameter declarations of a function being defined,
13860    after they are modified in the light of any missing parameters.  */
13861
13862 static tree
13863 storedecls (decls)
13864      tree decls;
13865 {
13866   return current_binding_level->names = decls;
13867 }
13868
13869 /* Store the parameter declarations into the current function declaration.
13870    This is called after parsing the parameter declarations, before
13871    digesting the body of the function.
13872
13873    For an old-style definition, modify the function's type
13874    to specify at least the number of arguments.  */
13875
13876 static void
13877 store_parm_decls (int is_main_program UNUSED)
13878 {
13879   register tree fndecl = current_function_decl;
13880
13881   if (fndecl == error_mark_node)
13882     return;
13883
13884   /* This is a chain of PARM_DECLs from old-style parm declarations.  */
13885   DECL_ARGUMENTS (fndecl) = storedecls (nreverse (getdecls ()));
13886
13887   /* Initialize the RTL code for the function.  */
13888
13889   init_function_start (fndecl, input_filename, lineno);
13890
13891   /* Set up parameters and prepare for return, for the function.  */
13892
13893   expand_function_start (fndecl, 0);
13894 }
13895
13896 static tree
13897 start_decl (tree decl, bool is_top_level)
13898 {
13899   register tree tem;
13900   bool at_top_level = (current_binding_level == global_binding_level);
13901   bool top_level = is_top_level || at_top_level;
13902
13903   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13904      level anyway.  */
13905   assert (!is_top_level || !at_top_level);
13906
13907   if (DECL_INITIAL (decl) != NULL_TREE)
13908     {
13909       assert (DECL_INITIAL (decl) == error_mark_node);
13910       assert (!DECL_EXTERNAL (decl));
13911     }
13912   else if (top_level)
13913     assert ((TREE_STATIC (decl) == 1) || DECL_EXTERNAL (decl) == 1);
13914
13915   /* For Fortran, we by default put things in .common when possible.  */
13916   DECL_COMMON (decl) = 1;
13917
13918   /* Add this decl to the current binding level. TEM may equal DECL or it may
13919      be a previous decl of the same name.  */
13920   if (is_top_level)
13921     tem = pushdecl_top_level (decl);
13922   else
13923     tem = pushdecl (decl);
13924
13925   /* For a local variable, define the RTL now.  */
13926   if (!top_level
13927   /* But not if this is a duplicate decl and we preserved the rtl from the
13928      previous one (which may or may not happen).  */
13929       && !DECL_RTL_SET_P (tem))
13930     {
13931       if (TYPE_SIZE (TREE_TYPE (tem)) != 0)
13932         expand_decl (tem);
13933       else if (TREE_CODE (TREE_TYPE (tem)) == ARRAY_TYPE
13934                && DECL_INITIAL (tem) != 0)
13935         expand_decl (tem);
13936     }
13937
13938   return tem;
13939 }
13940
13941 /* Create the FUNCTION_DECL for a function definition.
13942    DECLSPECS and DECLARATOR are the parts of the declaration;
13943    they describe the function's name and the type it returns,
13944    but twisted together in a fashion that parallels the syntax of C.
13945
13946    This function creates a binding context for the function body
13947    as well as setting up the FUNCTION_DECL in current_function_decl.
13948
13949    Returns 1 on success.  If the DECLARATOR is not suitable for a function
13950    (it defines a datum instead), we return 0, which tells
13951    yyparse to report a parse error.
13952
13953    NESTED is nonzero for a function nested within another function.  */
13954
13955 static void
13956 start_function (tree name, tree type, int nested, int public)
13957 {
13958   tree decl1;
13959   tree restype;
13960   int old_immediate_size_expand = immediate_size_expand;
13961
13962   named_labels = 0;
13963   shadowed_labels = 0;
13964
13965   /* Don't expand any sizes in the return type of the function.  */
13966   immediate_size_expand = 0;
13967
13968   if (nested)
13969     {
13970       assert (!public);
13971       assert (current_function_decl != NULL_TREE);
13972       assert (DECL_CONTEXT (current_function_decl) == NULL_TREE);
13973     }
13974   else
13975     {
13976       assert (current_function_decl == NULL_TREE);
13977     }
13978
13979   if (TREE_CODE (type) == ERROR_MARK)
13980     decl1 = current_function_decl = error_mark_node;
13981   else
13982     {
13983       decl1 = build_decl (FUNCTION_DECL,
13984                           name,
13985                           type);
13986       TREE_PUBLIC (decl1) = public ? 1 : 0;
13987       if (nested)
13988         DECL_INLINE (decl1) = 1;
13989       TREE_STATIC (decl1) = 1;
13990       DECL_EXTERNAL (decl1) = 0;
13991
13992       announce_function (decl1);
13993
13994       /* Make the init_value nonzero so pushdecl knows this is not tentative.
13995          error_mark_node is replaced below (in poplevel) with the BLOCK.  */
13996       DECL_INITIAL (decl1) = error_mark_node;
13997
13998       /* Record the decl so that the function name is defined. If we already have
13999          a decl for this name, and it is a FUNCTION_DECL, use the old decl.  */
14000
14001       current_function_decl = pushdecl (decl1);
14002     }
14003
14004   if (!nested)
14005     ffecom_outer_function_decl_ = current_function_decl;
14006
14007   pushlevel (0);
14008   current_binding_level->prep_state = 2;
14009
14010   if (TREE_CODE (current_function_decl) != ERROR_MARK)
14011     {
14012       make_decl_rtl (current_function_decl, NULL);
14013
14014       restype = TREE_TYPE (TREE_TYPE (current_function_decl));
14015       DECL_RESULT (current_function_decl)
14016         = build_decl (RESULT_DECL, NULL_TREE, restype);
14017     }
14018
14019   if (!nested && (TREE_CODE (current_function_decl) != ERROR_MARK))
14020     TREE_ADDRESSABLE (current_function_decl) = 1;
14021
14022   immediate_size_expand = old_immediate_size_expand;
14023 }
14024 \f
14025 /* Here are the public functions the GNU back end needs.  */
14026
14027 tree
14028 convert (type, expr)
14029      tree type, expr;
14030 {
14031   register tree e = expr;
14032   register enum tree_code code = TREE_CODE (type);
14033
14034   if (type == TREE_TYPE (e)
14035       || TREE_CODE (e) == ERROR_MARK)
14036     return e;
14037   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
14038     return fold (build1 (NOP_EXPR, type, e));
14039   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
14040       || code == ERROR_MARK)
14041     return error_mark_node;
14042   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
14043     {
14044       assert ("void value not ignored as it ought to be" == NULL);
14045       return error_mark_node;
14046     }
14047   if (code == VOID_TYPE)
14048     return build1 (CONVERT_EXPR, type, e);
14049   if ((code != RECORD_TYPE)
14050       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
14051     e = ffecom_1 (REALPART_EXPR, TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e))),
14052                   e);
14053   if (code == INTEGER_TYPE || code == ENUMERAL_TYPE)
14054     return fold (convert_to_integer (type, e));
14055   if (code == POINTER_TYPE)
14056     return fold (convert_to_pointer (type, e));
14057   if (code == REAL_TYPE)
14058     return fold (convert_to_real (type, e));
14059   if (code == COMPLEX_TYPE)
14060     return fold (convert_to_complex (type, e));
14061   if (code == RECORD_TYPE)
14062     return fold (ffecom_convert_to_complex_ (type, e));
14063
14064   assert ("conversion to non-scalar type requested" == NULL);
14065   return error_mark_node;
14066 }
14067
14068 /* integrate_decl_tree calls this function, but since we don't use the
14069    DECL_LANG_SPECIFIC field, this is a no-op.  */
14070
14071 void
14072 copy_lang_decl (node)
14073      tree node UNUSED;
14074 {
14075 }
14076
14077 /* Return the list of declarations of the current level.
14078    Note that this list is in reverse order unless/until
14079    you nreverse it; and when you do nreverse it, you must
14080    store the result back using `storedecls' or you will lose.  */
14081
14082 tree
14083 getdecls ()
14084 {
14085   return current_binding_level->names;
14086 }
14087
14088 /* Nonzero if we are currently in the global binding level.  */
14089
14090 int
14091 global_bindings_p ()
14092 {
14093   return current_binding_level == global_binding_level;
14094 }
14095
14096 /* Print an error message for invalid use of an incomplete type.
14097    VALUE is the expression that was used (or 0 if that isn't known)
14098    and TYPE is the type that was invalid.  */
14099
14100 void
14101 incomplete_type_error (value, type)
14102      tree value UNUSED;
14103      tree type;
14104 {
14105   if (TREE_CODE (type) == ERROR_MARK)
14106     return;
14107
14108   assert ("incomplete type?!?" == NULL);
14109 }
14110
14111 /* Mark ARG for GC.  */
14112 static void
14113 mark_binding_level (void *arg)
14114 {
14115   struct binding_level *level = *(struct binding_level **) arg;
14116
14117   while (level)
14118     {
14119       ggc_mark_tree (level->names);
14120       ggc_mark_tree (level->blocks);
14121       ggc_mark_tree (level->this_block);
14122       level = level->level_chain;
14123     }
14124 }
14125
14126 static void
14127 ffecom_init_decl_processing ()
14128 {
14129   static tree *const tree_roots[] = {
14130     &current_function_decl,
14131     &string_type_node,
14132     &ffecom_tree_fun_type_void,
14133     &ffecom_integer_zero_node,
14134     &ffecom_integer_one_node,
14135     &ffecom_tree_subr_type,
14136     &ffecom_tree_ptr_to_subr_type,
14137     &ffecom_tree_blockdata_type,
14138     &ffecom_tree_xargc_,
14139     &ffecom_f2c_integer_type_node,
14140     &ffecom_f2c_ptr_to_integer_type_node,
14141     &ffecom_f2c_address_type_node,
14142     &ffecom_f2c_real_type_node,
14143     &ffecom_f2c_ptr_to_real_type_node,
14144     &ffecom_f2c_doublereal_type_node,
14145     &ffecom_f2c_complex_type_node,
14146     &ffecom_f2c_doublecomplex_type_node,
14147     &ffecom_f2c_longint_type_node,
14148     &ffecom_f2c_logical_type_node,
14149     &ffecom_f2c_flag_type_node,
14150     &ffecom_f2c_ftnlen_type_node,
14151     &ffecom_f2c_ftnlen_zero_node,
14152     &ffecom_f2c_ftnlen_one_node,
14153     &ffecom_f2c_ftnlen_two_node,
14154     &ffecom_f2c_ptr_to_ftnlen_type_node,
14155     &ffecom_f2c_ftnint_type_node,
14156     &ffecom_f2c_ptr_to_ftnint_type_node,
14157     &ffecom_outer_function_decl_,
14158     &ffecom_previous_function_decl_,
14159     &ffecom_which_entrypoint_decl_,
14160     &ffecom_float_zero_,
14161     &ffecom_float_half_,
14162     &ffecom_double_zero_,
14163     &ffecom_double_half_,
14164     &ffecom_func_result_,
14165     &ffecom_func_length_,
14166     &ffecom_multi_type_node_,
14167     &ffecom_multi_retval_,
14168     &named_labels,
14169     &shadowed_labels
14170   };
14171   size_t i;
14172
14173   malloc_init ();
14174
14175   /* Record our roots.  */
14176   for (i = 0; i < ARRAY_SIZE (tree_roots); i++)
14177     ggc_add_tree_root (tree_roots[i], 1);
14178   ggc_add_tree_root (&ffecom_tree_type[0][0],
14179                      FFEINFO_basictype*FFEINFO_kindtype);
14180   ggc_add_tree_root (&ffecom_tree_fun_type[0][0],
14181                      FFEINFO_basictype*FFEINFO_kindtype);
14182   ggc_add_tree_root (&ffecom_tree_ptr_to_fun_type[0][0],
14183                      FFEINFO_basictype*FFEINFO_kindtype);
14184   ggc_add_tree_root (ffecom_gfrt_, FFECOM_gfrt);
14185   ggc_add_root (&current_binding_level, 1, sizeof current_binding_level,
14186                 mark_binding_level);
14187   ggc_add_root (&free_binding_level, 1, sizeof current_binding_level,
14188                 mark_binding_level);
14189   ggc_add_root (&tracker_head, 1, sizeof tracker_head, mark_tracker_head);
14190
14191   ffe_init_0 ();
14192 }
14193
14194 /* Delete the node BLOCK from the current binding level.
14195    This is used for the block inside a stmt expr ({...})
14196    so that the block can be reinserted where appropriate.  */
14197
14198 static void
14199 delete_block (block)
14200      tree block;
14201 {
14202   tree t;
14203   if (current_binding_level->blocks == block)
14204     current_binding_level->blocks = TREE_CHAIN (block);
14205   for (t = current_binding_level->blocks; t;)
14206     {
14207       if (TREE_CHAIN (t) == block)
14208         TREE_CHAIN (t) = TREE_CHAIN (block);
14209       else
14210         t = TREE_CHAIN (t);
14211     }
14212   TREE_CHAIN (block) = NULL;
14213   /* Clear TREE_USED which is always set by poplevel.
14214      The flag is set again if insert_block is called.  */
14215   TREE_USED (block) = 0;
14216 }
14217
14218 void
14219 insert_block (block)
14220      tree block;
14221 {
14222   TREE_USED (block) = 1;
14223   current_binding_level->blocks
14224     = chainon (current_binding_level->blocks, block);
14225 }
14226
14227 /* Each front end provides its own.  */
14228 static const char *ffe_init PARAMS ((const char *));
14229 static void ffe_finish PARAMS ((void));
14230 static void ffe_init_options PARAMS ((void));
14231 static void ffe_print_identifier PARAMS ((FILE *, tree, int));
14232
14233 #undef  LANG_HOOKS_NAME
14234 #define LANG_HOOKS_NAME                 "GNU F77"
14235 #undef  LANG_HOOKS_INIT
14236 #define LANG_HOOKS_INIT                 ffe_init
14237 #undef  LANG_HOOKS_FINISH
14238 #define LANG_HOOKS_FINISH               ffe_finish
14239 #undef  LANG_HOOKS_INIT_OPTIONS
14240 #define LANG_HOOKS_INIT_OPTIONS         ffe_init_options
14241 #undef  LANG_HOOKS_DECODE_OPTION
14242 #define LANG_HOOKS_DECODE_OPTION        ffe_decode_option
14243 #undef  LANG_HOOKS_PRINT_IDENTIFIER
14244 #define LANG_HOOKS_PRINT_IDENTIFIER     ffe_print_identifier
14245
14246 /* We do not wish to use alias-set based aliasing at all.  Used in the
14247    extreme (every object with its own set, with equivalences recorded) it
14248    might be helpful, but there are problems when it comes to inlining.  We
14249    get on ok with flag_argument_noalias, and alias-set aliasing does
14250    currently limit how stack slots can be reused, which is a lose.  */
14251 #undef LANG_HOOKS_GET_ALIAS_SET
14252 #define LANG_HOOKS_GET_ALIAS_SET hook_get_alias_set_0
14253
14254 const struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER;
14255
14256 static const char *
14257 ffe_init (filename)
14258      const char *filename;
14259 {
14260   /* Open input file.  */
14261   if (filename == 0 || !strcmp (filename, "-"))
14262     {
14263       finput = stdin;
14264       filename = "stdin";
14265     }
14266   else
14267     finput = fopen (filename, "r");
14268   if (finput == 0)
14269     fatal_io_error ("can't open %s", filename);
14270
14271 #ifdef IO_BUFFER_SIZE
14272   setvbuf (finput, (char *) xmalloc (IO_BUFFER_SIZE), _IOFBF, IO_BUFFER_SIZE);
14273 #endif
14274
14275   ffecom_init_decl_processing ();
14276   decl_printable_name = lang_printable_name;
14277   print_error_function = lang_print_error_function;
14278
14279   /* If the file is output from cpp, it should contain a first line
14280      `# 1 "real-filename"', and the current design of gcc (toplev.c
14281      in particular and the way it sets up information relied on by
14282      INCLUDE) requires that we read this now, and store the
14283      "real-filename" info in master_input_filename.  Ask the lexer
14284      to try doing this.  */
14285   ffelex_hash_kludge (finput);
14286
14287   /* FIXME: The ffelex_hash_kludge code needs to be cleaned up to
14288      return the new file name.  */
14289   if (main_input_filename)
14290     filename = main_input_filename;
14291
14292   return filename;
14293 }
14294
14295 static void
14296 ffe_finish ()
14297 {
14298   ffe_terminate_0 ();
14299
14300   if (ffe_is_ffedebug ())
14301     malloc_pool_display (malloc_pool_image ());
14302
14303   fclose (finput);
14304 }
14305
14306 static void
14307 ffe_init_options ()
14308 {
14309   /* Set default options for Fortran.  */
14310   flag_move_all_movables = 1;
14311   flag_reduce_all_givs = 1;
14312   flag_argument_noalias = 2;
14313   flag_merge_constants = 2;
14314   flag_errno_math = 0;
14315   flag_complex_divide_method = 1;
14316 }
14317
14318 int
14319 mark_addressable (exp)
14320      tree exp;
14321 {
14322   register tree x = exp;
14323   while (1)
14324     switch (TREE_CODE (x))
14325       {
14326       case ADDR_EXPR:
14327       case COMPONENT_REF:
14328       case ARRAY_REF:
14329         x = TREE_OPERAND (x, 0);
14330         break;
14331
14332       case CONSTRUCTOR:
14333         TREE_ADDRESSABLE (x) = 1;
14334         return 1;
14335
14336       case VAR_DECL:
14337       case CONST_DECL:
14338       case PARM_DECL:
14339       case RESULT_DECL:
14340         if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x)
14341             && DECL_NONLOCAL (x))
14342           {
14343             if (TREE_PUBLIC (x))
14344               {
14345                 assert ("address of global register var requested" == NULL);
14346                 return 0;
14347               }
14348             assert ("address of register variable requested" == NULL);
14349           }
14350         else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x))
14351           {
14352             if (TREE_PUBLIC (x))
14353               {
14354                 assert ("address of global register var requested" == NULL);
14355                 return 0;
14356               }
14357             assert ("address of register var requested" == NULL);
14358           }
14359         put_var_into_stack (x);
14360
14361         /* drops in */
14362       case FUNCTION_DECL:
14363         TREE_ADDRESSABLE (x) = 1;
14364 #if 0                           /* poplevel deals with this now.  */
14365         if (DECL_CONTEXT (x) == 0)
14366           TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x)) = 1;
14367 #endif
14368
14369       default:
14370         return 1;
14371       }
14372 }
14373
14374 /* If DECL has a cleanup, build and return that cleanup here.
14375    This is a callback called by expand_expr.  */
14376
14377 tree
14378 maybe_build_cleanup (decl)
14379      tree decl UNUSED;
14380 {
14381   /* There are no cleanups in Fortran.  */
14382   return NULL_TREE;
14383 }
14384
14385 /* Exit a binding level.
14386    Pop the level off, and restore the state of the identifier-decl mappings
14387    that were in effect when this level was entered.
14388
14389    If KEEP is nonzero, this level had explicit declarations, so
14390    and create a "block" (a BLOCK node) for the level
14391    to record its declarations and subblocks for symbol table output.
14392
14393    If FUNCTIONBODY is nonzero, this level is the body of a function,
14394    so create a block as if KEEP were set and also clear out all
14395    label names.
14396
14397    If REVERSE is nonzero, reverse the order of decls before putting
14398    them into the BLOCK.  */
14399
14400 tree
14401 poplevel (keep, reverse, functionbody)
14402      int keep;
14403      int reverse;
14404      int functionbody;
14405 {
14406   register tree link;
14407   /* The chain of decls was accumulated in reverse order.
14408      Put it into forward order, just for cleanliness.  */
14409   tree decls;
14410   tree subblocks = current_binding_level->blocks;
14411   tree block = 0;
14412   tree decl;
14413   int block_previously_created;
14414
14415   /* Get the decls in the order they were written.
14416      Usually current_binding_level->names is in reverse order.
14417      But parameter decls were previously put in forward order.  */
14418
14419   if (reverse)
14420     current_binding_level->names
14421       = decls = nreverse (current_binding_level->names);
14422   else
14423     decls = current_binding_level->names;
14424
14425   /* Output any nested inline functions within this block
14426      if they weren't already output.  */
14427
14428   for (decl = decls; decl; decl = TREE_CHAIN (decl))
14429     if (TREE_CODE (decl) == FUNCTION_DECL
14430         && ! TREE_ASM_WRITTEN (decl)
14431         && DECL_INITIAL (decl) != 0
14432         && TREE_ADDRESSABLE (decl))
14433       {
14434         /* If this decl was copied from a file-scope decl
14435            on account of a block-scope extern decl,
14436            propagate TREE_ADDRESSABLE to the file-scope decl.
14437
14438            DECL_ABSTRACT_ORIGIN can be set to itself if warn_return_type is
14439            true, since then the decl goes through save_for_inline_copying.  */
14440         if (DECL_ABSTRACT_ORIGIN (decl) != 0
14441             && DECL_ABSTRACT_ORIGIN (decl) != decl)
14442           TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl)) = 1;
14443         else if (DECL_SAVED_INSNS (decl) != 0)
14444           {
14445             push_function_context ();
14446             output_inline_function (decl);
14447             pop_function_context ();
14448           }
14449       }
14450
14451   /* If there were any declarations or structure tags in that level,
14452      or if this level is a function body,
14453      create a BLOCK to record them for the life of this function.  */
14454
14455   block = 0;
14456   block_previously_created = (current_binding_level->this_block != 0);
14457   if (block_previously_created)
14458     block = current_binding_level->this_block;
14459   else if (keep || functionbody)
14460     block = make_node (BLOCK);
14461   if (block != 0)
14462     {
14463       BLOCK_VARS (block) = decls;
14464       BLOCK_SUBBLOCKS (block) = subblocks;
14465     }
14466
14467   /* In each subblock, record that this is its superior.  */
14468
14469   for (link = subblocks; link; link = TREE_CHAIN (link))
14470     BLOCK_SUPERCONTEXT (link) = block;
14471
14472   /* Clear out the meanings of the local variables of this level.  */
14473
14474   for (link = decls; link; link = TREE_CHAIN (link))
14475     {
14476       if (DECL_NAME (link) != 0)
14477         {
14478           /* If the ident. was used or addressed via a local extern decl,
14479              don't forget that fact.  */
14480           if (DECL_EXTERNAL (link))
14481             {
14482               if (TREE_USED (link))
14483                 TREE_USED (DECL_NAME (link)) = 1;
14484               if (TREE_ADDRESSABLE (link))
14485                 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (link)) = 1;
14486             }
14487           IDENTIFIER_LOCAL_VALUE (DECL_NAME (link)) = 0;
14488         }
14489     }
14490
14491   /* If the level being exited is the top level of a function,
14492      check over all the labels, and clear out the current
14493      (function local) meanings of their names.  */
14494
14495   if (functionbody)
14496     {
14497       /* If this is the top level block of a function,
14498          the vars are the function's parameters.
14499          Don't leave them in the BLOCK because they are
14500          found in the FUNCTION_DECL instead.  */
14501
14502       BLOCK_VARS (block) = 0;
14503     }
14504
14505   /* Pop the current level, and free the structure for reuse.  */
14506
14507   {
14508     register struct binding_level *level = current_binding_level;
14509     current_binding_level = current_binding_level->level_chain;
14510
14511     level->level_chain = free_binding_level;
14512     free_binding_level = level;
14513   }
14514
14515   /* Dispose of the block that we just made inside some higher level.  */
14516   if (functionbody
14517       && current_function_decl != error_mark_node)
14518     DECL_INITIAL (current_function_decl) = block;
14519   else if (block)
14520     {
14521       if (!block_previously_created)
14522         current_binding_level->blocks
14523           = chainon (current_binding_level->blocks, block);
14524     }
14525   /* If we did not make a block for the level just exited,
14526      any blocks made for inner levels
14527      (since they cannot be recorded as subblocks in that level)
14528      must be carried forward so they will later become subblocks
14529      of something else.  */
14530   else if (subblocks)
14531     current_binding_level->blocks
14532       = chainon (current_binding_level->blocks, subblocks);
14533
14534   if (block)
14535     TREE_USED (block) = 1;
14536   return block;
14537 }
14538
14539 static void
14540 ffe_print_identifier (file, node, indent)
14541      FILE *file;
14542      tree node;
14543      int indent;
14544 {
14545   print_node (file, "global", IDENTIFIER_GLOBAL_VALUE (node), indent + 4);
14546   print_node (file, "local", IDENTIFIER_LOCAL_VALUE (node), indent + 4);
14547 }
14548
14549 /* Record a decl-node X as belonging to the current lexical scope.
14550    Check for errors (such as an incompatible declaration for the same
14551    name already seen in the same scope).
14552
14553    Returns either X or an old decl for the same name.
14554    If an old decl is returned, it may have been smashed
14555    to agree with what X says.  */
14556
14557 tree
14558 pushdecl (x)
14559      tree x;
14560 {
14561   register tree t;
14562   register tree name = DECL_NAME (x);
14563   register struct binding_level *b = current_binding_level;
14564
14565   if ((TREE_CODE (x) == FUNCTION_DECL)
14566       && (DECL_INITIAL (x) == 0)
14567       && DECL_EXTERNAL (x))
14568     DECL_CONTEXT (x) = NULL_TREE;
14569   else
14570     DECL_CONTEXT (x) = current_function_decl;
14571
14572   if (name)
14573     {
14574       if (IDENTIFIER_INVENTED (name))
14575         {
14576           DECL_ARTIFICIAL (x) = 1;
14577           DECL_IN_SYSTEM_HEADER (x) = 1;
14578         }
14579
14580       t = lookup_name_current_level (name);
14581
14582       assert ((t == NULL_TREE) || (DECL_CONTEXT (x) == NULL_TREE));
14583
14584       /* Don't push non-parms onto list for parms until we understand
14585          why we're doing this and whether it works.  */
14586
14587       assert ((b == global_binding_level)
14588               || !ffecom_transform_only_dummies_
14589               || TREE_CODE (x) == PARM_DECL);
14590
14591       if ((t != NULL_TREE) && duplicate_decls (x, t))
14592         return t;
14593
14594       /* If we are processing a typedef statement, generate a whole new
14595          ..._TYPE node (which will be just an variant of the existing
14596          ..._TYPE node with identical properties) and then install the
14597          TYPE_DECL node generated to represent the typedef name as the
14598          TYPE_NAME of this brand new (duplicate) ..._TYPE node.
14599
14600          The whole point here is to end up with a situation where each and every
14601          ..._TYPE node the compiler creates will be uniquely associated with
14602          AT MOST one node representing a typedef name. This way, even though
14603          the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL
14604          (i.e. "typedef name") nodes very early on, later parts of the
14605          compiler can always do the reverse translation and get back the
14606          corresponding typedef name.  For example, given:
14607
14608          typedef struct S MY_TYPE; MY_TYPE object;
14609
14610          Later parts of the compiler might only know that `object' was of type
14611          `struct S' if it were not for code just below.  With this code
14612          however, later parts of the compiler see something like:
14613
14614          struct S' == struct S typedef struct S' MY_TYPE; struct S' object;
14615
14616          And they can then deduce (from the node for type struct S') that the
14617          original object declaration was:
14618
14619          MY_TYPE object;
14620
14621          Being able to do this is important for proper support of protoize, and
14622          also for generating precise symbolic debugging information which
14623          takes full account of the programmer's (typedef) vocabulary.
14624
14625          Obviously, we don't want to generate a duplicate ..._TYPE node if the
14626          TYPE_DECL node that we are now processing really represents a
14627          standard built-in type.
14628
14629          Since all standard types are effectively declared at line zero in the
14630          source file, we can easily check to see if we are working on a
14631          standard type by checking the current value of lineno.  */
14632
14633       if (TREE_CODE (x) == TYPE_DECL)
14634         {
14635           if (DECL_SOURCE_LINE (x) == 0)
14636             {
14637               if (TYPE_NAME (TREE_TYPE (x)) == 0)
14638                 TYPE_NAME (TREE_TYPE (x)) = x;
14639             }
14640           else if (TREE_TYPE (x) != error_mark_node)
14641             {
14642               tree tt = TREE_TYPE (x);
14643
14644               tt = build_type_copy (tt);
14645               TYPE_NAME (tt) = x;
14646               TREE_TYPE (x) = tt;
14647             }
14648         }
14649
14650       /* This name is new in its binding level. Install the new declaration
14651          and return it.  */
14652       if (b == global_binding_level)
14653         IDENTIFIER_GLOBAL_VALUE (name) = x;
14654       else
14655         IDENTIFIER_LOCAL_VALUE (name) = x;
14656     }
14657
14658   /* Put decls on list in reverse order. We will reverse them later if
14659      necessary.  */
14660   TREE_CHAIN (x) = b->names;
14661   b->names = x;
14662
14663   return x;
14664 }
14665
14666 /* Nonzero if the current level needs to have a BLOCK made.  */
14667
14668 static int
14669 kept_level_p ()
14670 {
14671   tree decl;
14672
14673   for (decl = current_binding_level->names;
14674        decl;
14675        decl = TREE_CHAIN (decl))
14676     {
14677       if (TREE_USED (decl) || TREE_CODE (decl) != VAR_DECL
14678           || (DECL_NAME (decl) && ! DECL_ARTIFICIAL (decl)))
14679         /* Currently, there aren't supposed to be non-artificial names
14680            at other than the top block for a function -- they're
14681            believed to always be temps.  But it's wise to check anyway.  */
14682         return 1;
14683     }
14684   return 0;
14685 }
14686
14687 /* Enter a new binding level.
14688    If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
14689    not for that of tags.  */
14690
14691 void
14692 pushlevel (tag_transparent)
14693      int tag_transparent;
14694 {
14695   register struct binding_level *newlevel = NULL_BINDING_LEVEL;
14696
14697   assert (! tag_transparent);
14698
14699   if (current_binding_level == global_binding_level)
14700     {
14701       named_labels = 0;
14702     }
14703
14704   /* Reuse or create a struct for this binding level.  */
14705
14706   if (free_binding_level)
14707     {
14708       newlevel = free_binding_level;
14709       free_binding_level = free_binding_level->level_chain;
14710     }
14711   else
14712     {
14713       newlevel = make_binding_level ();
14714     }
14715
14716   /* Add this level to the front of the chain (stack) of levels that
14717      are active.  */
14718
14719   *newlevel = clear_binding_level;
14720   newlevel->level_chain = current_binding_level;
14721   current_binding_level = newlevel;
14722 }
14723
14724 /* Set the BLOCK node for the innermost scope
14725    (the one we are currently in).  */
14726
14727 void
14728 set_block (block)
14729      register tree block;
14730 {
14731   current_binding_level->this_block = block;
14732   current_binding_level->names = chainon (current_binding_level->names,
14733                                           BLOCK_VARS (block));
14734   current_binding_level->blocks = chainon (current_binding_level->blocks,
14735                                            BLOCK_SUBBLOCKS (block));
14736 }
14737
14738 tree
14739 signed_or_unsigned_type (unsignedp, type)
14740      int unsignedp;
14741      tree type;
14742 {
14743   tree type2;
14744
14745   if (! INTEGRAL_TYPE_P (type))
14746     return type;
14747   if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node))
14748     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
14749   if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node))
14750     return unsignedp ? unsigned_type_node : integer_type_node;
14751   if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node))
14752     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
14753   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node))
14754     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
14755   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node))
14756     return (unsignedp ? long_long_unsigned_type_node
14757             : long_long_integer_type_node);
14758
14759   type2 = type_for_size (TYPE_PRECISION (type), unsignedp);
14760   if (type2 == NULL_TREE)
14761     return type;
14762
14763   return type2;
14764 }
14765
14766 tree
14767 signed_type (type)
14768      tree type;
14769 {
14770   tree type1 = TYPE_MAIN_VARIANT (type);
14771   ffeinfoKindtype kt;
14772   tree type2;
14773
14774   if (type1 == unsigned_char_type_node || type1 == char_type_node)
14775     return signed_char_type_node;
14776   if (type1 == unsigned_type_node)
14777     return integer_type_node;
14778   if (type1 == short_unsigned_type_node)
14779     return short_integer_type_node;
14780   if (type1 == long_unsigned_type_node)
14781     return long_integer_type_node;
14782   if (type1 == long_long_unsigned_type_node)
14783     return long_long_integer_type_node;
14784 #if 0   /* gcc/c-* files only */
14785   if (type1 == unsigned_intDI_type_node)
14786     return intDI_type_node;
14787   if (type1 == unsigned_intSI_type_node)
14788     return intSI_type_node;
14789   if (type1 == unsigned_intHI_type_node)
14790     return intHI_type_node;
14791   if (type1 == unsigned_intQI_type_node)
14792     return intQI_type_node;
14793 #endif
14794
14795   type2 = type_for_size (TYPE_PRECISION (type1), 0);
14796   if (type2 != NULL_TREE)
14797     return type2;
14798
14799   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
14800     {
14801       type2 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
14802
14803       if (type1 == type2)
14804         return ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
14805     }
14806
14807   return type;
14808 }
14809
14810 /* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
14811    or validate its data type for an `if' or `while' statement or ?..: exp.
14812
14813    This preparation consists of taking the ordinary
14814    representation of an expression expr and producing a valid tree
14815    boolean expression describing whether expr is nonzero.  We could
14816    simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
14817    but we optimize comparisons, &&, ||, and !.
14818
14819    The resulting type should always be `integer_type_node'.  */
14820
14821 tree
14822 truthvalue_conversion (expr)
14823      tree expr;
14824 {
14825   if (TREE_CODE (expr) == ERROR_MARK)
14826     return expr;
14827
14828 #if 0 /* This appears to be wrong for C++.  */
14829   /* These really should return error_mark_node after 2.4 is stable.
14830      But not all callers handle ERROR_MARK properly.  */
14831   switch (TREE_CODE (TREE_TYPE (expr)))
14832     {
14833     case RECORD_TYPE:
14834       error ("struct type value used where scalar is required");
14835       return integer_zero_node;
14836
14837     case UNION_TYPE:
14838       error ("union type value used where scalar is required");
14839       return integer_zero_node;
14840
14841     case ARRAY_TYPE:
14842       error ("array type value used where scalar is required");
14843       return integer_zero_node;
14844
14845     default:
14846       break;
14847     }
14848 #endif /* 0 */
14849
14850   switch (TREE_CODE (expr))
14851     {
14852       /* It is simpler and generates better code to have only TRUTH_*_EXPR
14853          or comparison expressions as truth values at this level.  */
14854 #if 0
14855     case COMPONENT_REF:
14856       /* A one-bit unsigned bit-field is already acceptable.  */
14857       if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr, 1)))
14858           && TREE_UNSIGNED (TREE_OPERAND (expr, 1)))
14859         return expr;
14860       break;
14861 #endif
14862
14863     case EQ_EXPR:
14864       /* It is simpler and generates better code to have only TRUTH_*_EXPR
14865          or comparison expressions as truth values at this level.  */
14866 #if 0
14867       if (integer_zerop (TREE_OPERAND (expr, 1)))
14868         return build_unary_op (TRUTH_NOT_EXPR, TREE_OPERAND (expr, 0), 0);
14869 #endif
14870     case NE_EXPR: case LE_EXPR: case GE_EXPR: case LT_EXPR: case GT_EXPR:
14871     case TRUTH_ANDIF_EXPR:
14872     case TRUTH_ORIF_EXPR:
14873     case TRUTH_AND_EXPR:
14874     case TRUTH_OR_EXPR:
14875     case TRUTH_XOR_EXPR:
14876       TREE_TYPE (expr) = integer_type_node;
14877       return expr;
14878
14879     case ERROR_MARK:
14880       return expr;
14881
14882     case INTEGER_CST:
14883       return integer_zerop (expr) ? integer_zero_node : integer_one_node;
14884
14885     case REAL_CST:
14886       return real_zerop (expr) ? integer_zero_node : integer_one_node;
14887
14888     case ADDR_EXPR:
14889       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 0)))
14890         return build (COMPOUND_EXPR, integer_type_node,
14891                       TREE_OPERAND (expr, 0), integer_one_node);
14892       else
14893         return integer_one_node;
14894
14895     case COMPLEX_EXPR:
14896       return ffecom_2 ((TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1))
14897                         ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
14898                        integer_type_node,
14899                        truthvalue_conversion (TREE_OPERAND (expr, 0)),
14900                        truthvalue_conversion (TREE_OPERAND (expr, 1)));
14901
14902     case NEGATE_EXPR:
14903     case ABS_EXPR:
14904     case FLOAT_EXPR:
14905     case FFS_EXPR:
14906       /* These don't change whether an object is non-zero or zero.  */
14907       return truthvalue_conversion (TREE_OPERAND (expr, 0));
14908
14909     case LROTATE_EXPR:
14910     case RROTATE_EXPR:
14911       /* These don't change whether an object is zero or non-zero, but
14912          we can't ignore them if their second arg has side-effects.  */
14913       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1)))
14914         return build (COMPOUND_EXPR, integer_type_node, TREE_OPERAND (expr, 1),
14915                       truthvalue_conversion (TREE_OPERAND (expr, 0)));
14916       else
14917         return truthvalue_conversion (TREE_OPERAND (expr, 0));
14918
14919     case COND_EXPR:
14920       /* Distribute the conversion into the arms of a COND_EXPR.  */
14921       return fold (build (COND_EXPR, integer_type_node, TREE_OPERAND (expr, 0),
14922                           truthvalue_conversion (TREE_OPERAND (expr, 1)),
14923                           truthvalue_conversion (TREE_OPERAND (expr, 2))));
14924
14925     case CONVERT_EXPR:
14926       /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
14927          since that affects how `default_conversion' will behave.  */
14928       if (TREE_CODE (TREE_TYPE (expr)) == REFERENCE_TYPE
14929           || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) == REFERENCE_TYPE)
14930         break;
14931       /* fall through... */
14932     case NOP_EXPR:
14933       /* If this is widening the argument, we can ignore it.  */
14934       if (TYPE_PRECISION (TREE_TYPE (expr))
14935           >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr, 0))))
14936         return truthvalue_conversion (TREE_OPERAND (expr, 0));
14937       break;
14938
14939     case MINUS_EXPR:
14940       /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize
14941          this case.  */
14942       if (TARGET_FLOAT_FORMAT == IEEE_FLOAT_FORMAT
14943           && TREE_CODE (TREE_TYPE (expr)) == REAL_TYPE)
14944         break;
14945       /* fall through... */
14946     case BIT_XOR_EXPR:
14947       /* This and MINUS_EXPR can be changed into a comparison of the
14948          two objects.  */
14949       if (TREE_TYPE (TREE_OPERAND (expr, 0))
14950           == TREE_TYPE (TREE_OPERAND (expr, 1)))
14951         return ffecom_2 (NE_EXPR, integer_type_node,
14952                          TREE_OPERAND (expr, 0),
14953                          TREE_OPERAND (expr, 1));
14954       return ffecom_2 (NE_EXPR, integer_type_node,
14955                        TREE_OPERAND (expr, 0),
14956                        fold (build1 (NOP_EXPR,
14957                                      TREE_TYPE (TREE_OPERAND (expr, 0)),
14958                                      TREE_OPERAND (expr, 1))));
14959
14960     case BIT_AND_EXPR:
14961       if (integer_onep (TREE_OPERAND (expr, 1)))
14962         return expr;
14963       break;
14964
14965     case MODIFY_EXPR:
14966 #if 0                           /* No such thing in Fortran. */
14967       if (warn_parentheses && C_EXP_ORIGINAL_CODE (expr) == MODIFY_EXPR)
14968         warning ("suggest parentheses around assignment used as truth value");
14969 #endif
14970       break;
14971
14972     default:
14973       break;
14974     }
14975
14976   if (TREE_CODE (TREE_TYPE (expr)) == COMPLEX_TYPE)
14977     return (ffecom_2
14978             ((TREE_SIDE_EFFECTS (expr)
14979               ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
14980              integer_type_node,
14981              truthvalue_conversion (ffecom_1 (REALPART_EXPR,
14982                                               TREE_TYPE (TREE_TYPE (expr)),
14983                                               expr)),
14984              truthvalue_conversion (ffecom_1 (IMAGPART_EXPR,
14985                                               TREE_TYPE (TREE_TYPE (expr)),
14986                                               expr))));
14987
14988   return ffecom_2 (NE_EXPR, integer_type_node,
14989                    expr,
14990                    convert (TREE_TYPE (expr), integer_zero_node));
14991 }
14992
14993 tree
14994 type_for_mode (mode, unsignedp)
14995      enum machine_mode mode;
14996      int unsignedp;
14997 {
14998   int i;
14999   int j;
15000   tree t;
15001
15002   if (mode == TYPE_MODE (integer_type_node))
15003     return unsignedp ? unsigned_type_node : integer_type_node;
15004
15005   if (mode == TYPE_MODE (signed_char_type_node))
15006     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15007
15008   if (mode == TYPE_MODE (short_integer_type_node))
15009     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15010
15011   if (mode == TYPE_MODE (long_integer_type_node))
15012     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15013
15014   if (mode == TYPE_MODE (long_long_integer_type_node))
15015     return unsignedp ? long_long_unsigned_type_node : long_long_integer_type_node;
15016
15017 #if HOST_BITS_PER_WIDE_INT >= 64
15018   if (mode == TYPE_MODE (intTI_type_node))
15019     return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
15020 #endif
15021
15022   if (mode == TYPE_MODE (float_type_node))
15023     return float_type_node;
15024
15025   if (mode == TYPE_MODE (double_type_node))
15026     return double_type_node;
15027
15028   if (mode == TYPE_MODE (build_pointer_type (char_type_node)))
15029     return build_pointer_type (char_type_node);
15030
15031   if (mode == TYPE_MODE (build_pointer_type (integer_type_node)))
15032     return build_pointer_type (integer_type_node);
15033
15034   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
15035     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
15036       {
15037         if (((t = ffecom_tree_type[i][j]) != NULL_TREE)
15038             && (mode == TYPE_MODE (t)))
15039           {
15040             if ((i == FFEINFO_basictypeINTEGER) && unsignedp)
15041               return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][j];
15042             else
15043               return t;
15044           }
15045       }
15046
15047   return 0;
15048 }
15049
15050 tree
15051 type_for_size (bits, unsignedp)
15052      unsigned bits;
15053      int unsignedp;
15054 {
15055   ffeinfoKindtype kt;
15056   tree type_node;
15057
15058   if (bits == TYPE_PRECISION (integer_type_node))
15059     return unsignedp ? unsigned_type_node : integer_type_node;
15060
15061   if (bits == TYPE_PRECISION (signed_char_type_node))
15062     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15063
15064   if (bits == TYPE_PRECISION (short_integer_type_node))
15065     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15066
15067   if (bits == TYPE_PRECISION (long_integer_type_node))
15068     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15069
15070   if (bits == TYPE_PRECISION (long_long_integer_type_node))
15071     return (unsignedp ? long_long_unsigned_type_node
15072             : long_long_integer_type_node);
15073
15074   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15075     {
15076       type_node = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15077
15078       if ((type_node != NULL_TREE) && (bits == TYPE_PRECISION (type_node)))
15079         return unsignedp ? ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]
15080           : type_node;
15081     }
15082
15083   return 0;
15084 }
15085
15086 tree
15087 unsigned_type (type)
15088      tree type;
15089 {
15090   tree type1 = TYPE_MAIN_VARIANT (type);
15091   ffeinfoKindtype kt;
15092   tree type2;
15093
15094   if (type1 == signed_char_type_node || type1 == char_type_node)
15095     return unsigned_char_type_node;
15096   if (type1 == integer_type_node)
15097     return unsigned_type_node;
15098   if (type1 == short_integer_type_node)
15099     return short_unsigned_type_node;
15100   if (type1 == long_integer_type_node)
15101     return long_unsigned_type_node;
15102   if (type1 == long_long_integer_type_node)
15103     return long_long_unsigned_type_node;
15104 #if 0   /* gcc/c-* files only */
15105   if (type1 == intDI_type_node)
15106     return unsigned_intDI_type_node;
15107   if (type1 == intSI_type_node)
15108     return unsigned_intSI_type_node;
15109   if (type1 == intHI_type_node)
15110     return unsigned_intHI_type_node;
15111   if (type1 == intQI_type_node)
15112     return unsigned_intQI_type_node;
15113 #endif
15114
15115   type2 = type_for_size (TYPE_PRECISION (type1), 1);
15116   if (type2 != NULL_TREE)
15117     return type2;
15118
15119   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15120     {
15121       type2 = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15122
15123       if (type1 == type2)
15124         return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
15125     }
15126
15127   return type;
15128 }
15129
15130 void
15131 lang_mark_tree (t)
15132      union tree_node *t ATTRIBUTE_UNUSED;
15133 {
15134   if (TREE_CODE (t) == IDENTIFIER_NODE)
15135     {
15136       struct lang_identifier *i = (struct lang_identifier *) t;
15137       ggc_mark_tree (IDENTIFIER_GLOBAL_VALUE (i));
15138       ggc_mark_tree (IDENTIFIER_LOCAL_VALUE (i));
15139       ggc_mark_tree (IDENTIFIER_LABEL_VALUE (i));
15140     }
15141   else if (TYPE_P (t) && TYPE_LANG_SPECIFIC (t))
15142     ggc_mark (TYPE_LANG_SPECIFIC (t));
15143 }
15144 \f
15145 /* From gcc/cccp.c, the code to handle -I.  */
15146
15147 /* Skip leading "./" from a directory name.
15148    This may yield the empty string, which represents the current directory.  */
15149
15150 static const char *
15151 skip_redundant_dir_prefix (const char *dir)
15152 {
15153   while (dir[0] == '.' && dir[1] == '/')
15154     for (dir += 2; *dir == '/'; dir++)
15155       continue;
15156   if (dir[0] == '.' && !dir[1])
15157     dir++;
15158   return dir;
15159 }
15160
15161 /* The file_name_map structure holds a mapping of file names for a
15162    particular directory.  This mapping is read from the file named
15163    FILE_NAME_MAP_FILE in that directory.  Such a file can be used to
15164    map filenames on a file system with severe filename restrictions,
15165    such as DOS.  The format of the file name map file is just a series
15166    of lines with two tokens on each line.  The first token is the name
15167    to map, and the second token is the actual name to use.  */
15168
15169 struct file_name_map
15170 {
15171   struct file_name_map *map_next;
15172   char *map_from;
15173   char *map_to;
15174 };
15175
15176 #define FILE_NAME_MAP_FILE "header.gcc"
15177
15178 /* Current maximum length of directory names in the search path
15179    for include files.  (Altered as we get more of them.)  */
15180
15181 static int max_include_len = 0;
15182
15183 struct file_name_list
15184   {
15185     struct file_name_list *next;
15186     char *fname;
15187     /* Mapping of file names for this directory.  */
15188     struct file_name_map *name_map;
15189     /* Non-zero if name_map is valid.  */
15190     int got_name_map;
15191   };
15192
15193 static struct file_name_list *include = NULL;   /* First dir to search */
15194 static struct file_name_list *last_include = NULL;      /* Last in chain */
15195
15196 /* I/O buffer structure.
15197    The `fname' field is nonzero for source files and #include files
15198    and for the dummy text used for -D and -U.
15199    It is zero for rescanning results of macro expansion
15200    and for expanding macro arguments.  */
15201 #define INPUT_STACK_MAX 400
15202 static struct file_buf {
15203   const char *fname;
15204   /* Filename specified with #line command.  */
15205   const char *nominal_fname;
15206   /* Record where in the search path this file was found.
15207      For #include_next.  */
15208   struct file_name_list *dir;
15209   ffewhereLine line;
15210   ffewhereColumn column;
15211 } instack[INPUT_STACK_MAX];
15212
15213 static int last_error_tick = 0;    /* Incremented each time we print it.  */
15214 static int input_file_stack_tick = 0;  /* Incremented when status changes.  */
15215
15216 /* Current nesting level of input sources.
15217    `instack[indepth]' is the level currently being read.  */
15218 static int indepth = -1;
15219
15220 typedef struct file_buf FILE_BUF;
15221
15222 /* Nonzero means -I- has been seen,
15223    so don't look for #include "foo" the source-file directory.  */
15224 static int ignore_srcdir;
15225
15226 #ifndef INCLUDE_LEN_FUDGE
15227 #define INCLUDE_LEN_FUDGE 0
15228 #endif
15229
15230 static void append_include_chain (struct file_name_list *first,
15231                                   struct file_name_list *last);
15232 static FILE *open_include_file (char *filename,
15233                                 struct file_name_list *searchptr);
15234 static void print_containing_files (ffebadSeverity sev);
15235 static char *read_filename_string (int ch, FILE *f);
15236 static struct file_name_map *read_name_map (const char *dirname);
15237
15238 /* Append a chain of `struct file_name_list's
15239    to the end of the main include chain.
15240    FIRST is the beginning of the chain to append, and LAST is the end.  */
15241
15242 static void
15243 append_include_chain (first, last)
15244      struct file_name_list *first, *last;
15245 {
15246   struct file_name_list *dir;
15247
15248   if (!first || !last)
15249     return;
15250
15251   if (include == 0)
15252     include = first;
15253   else
15254     last_include->next = first;
15255
15256   for (dir = first; ; dir = dir->next) {
15257     int len = strlen (dir->fname) + INCLUDE_LEN_FUDGE;
15258     if (len > max_include_len)
15259       max_include_len = len;
15260     if (dir == last)
15261       break;
15262   }
15263
15264   last->next = NULL;
15265   last_include = last;
15266 }
15267
15268 /* Try to open include file FILENAME.  SEARCHPTR is the directory
15269    being tried from the include file search path.  This function maps
15270    filenames on file systems based on information read by
15271    read_name_map.  */
15272
15273 static FILE *
15274 open_include_file (filename, searchptr)
15275      char *filename;
15276      struct file_name_list *searchptr;
15277 {
15278   register struct file_name_map *map;
15279   register char *from;
15280   char *p, *dir;
15281
15282   if (searchptr && ! searchptr->got_name_map)
15283     {
15284       searchptr->name_map = read_name_map (searchptr->fname
15285                                            ? searchptr->fname : ".");
15286       searchptr->got_name_map = 1;
15287     }
15288
15289   /* First check the mapping for the directory we are using.  */
15290   if (searchptr && searchptr->name_map)
15291     {
15292       from = filename;
15293       if (searchptr->fname)
15294         from += strlen (searchptr->fname) + 1;
15295       for (map = searchptr->name_map; map; map = map->map_next)
15296         {
15297           if (! strcmp (map->map_from, from))
15298             {
15299               /* Found a match.  */
15300               return fopen (map->map_to, "r");
15301             }
15302         }
15303     }
15304
15305   /* Try to find a mapping file for the particular directory we are
15306      looking in.  Thus #include <sys/types.h> will look up sys/types.h
15307      in /usr/include/header.gcc and look up types.h in
15308      /usr/include/sys/header.gcc.  */
15309   p = strrchr (filename, '/');
15310 #ifdef DIR_SEPARATOR
15311   if (! p) p = strrchr (filename, DIR_SEPARATOR);
15312   else {
15313     char *tmp = strrchr (filename, DIR_SEPARATOR);
15314     if (tmp != NULL && tmp > p) p = tmp;
15315   }
15316 #endif
15317   if (! p)
15318     p = filename;
15319   if (searchptr
15320       && searchptr->fname
15321       && strlen (searchptr->fname) == (size_t) (p - filename)
15322       && ! strncmp (searchptr->fname, filename, (int) (p - filename)))
15323     {
15324       /* FILENAME is in SEARCHPTR, which we've already checked.  */
15325       return fopen (filename, "r");
15326     }
15327
15328   if (p == filename)
15329     {
15330       from = filename;
15331       map = read_name_map (".");
15332     }
15333   else
15334     {
15335       dir = (char *) xmalloc (p - filename + 1);
15336       memcpy (dir, filename, p - filename);
15337       dir[p - filename] = '\0';
15338       from = p + 1;
15339       map = read_name_map (dir);
15340       free (dir);
15341     }
15342   for (; map; map = map->map_next)
15343     if (! strcmp (map->map_from, from))
15344       return fopen (map->map_to, "r");
15345
15346   return fopen (filename, "r");
15347 }
15348
15349 /* Print the file names and line numbers of the #include
15350    commands which led to the current file.  */
15351
15352 static void
15353 print_containing_files (ffebadSeverity sev)
15354 {
15355   FILE_BUF *ip = NULL;
15356   int i;
15357   int first = 1;
15358   const char *str1;
15359   const char *str2;
15360
15361   /* If stack of files hasn't changed since we last printed
15362      this info, don't repeat it.  */
15363   if (last_error_tick == input_file_stack_tick)
15364     return;
15365
15366   for (i = indepth; i >= 0; i--)
15367     if (instack[i].fname != NULL) {
15368       ip = &instack[i];
15369       break;
15370     }
15371
15372   /* Give up if we don't find a source file.  */
15373   if (ip == NULL)
15374     return;
15375
15376   /* Find the other, outer source files.  */
15377   for (i--; i >= 0; i--)
15378     if (instack[i].fname != NULL)
15379       {
15380         ip = &instack[i];
15381         if (first)
15382           {
15383             first = 0;
15384             str1 = "In file included";
15385           }
15386         else
15387           {
15388             str1 = "...          ...";
15389           }
15390
15391         if (i == 1)
15392           str2 = ":";
15393         else
15394           str2 = "";
15395
15396         ffebad_start_msg ("%A from %B at %0%C", sev);
15397         ffebad_here (0, ip->line, ip->column);
15398         ffebad_string (str1);
15399         ffebad_string (ip->nominal_fname);
15400         ffebad_string (str2);
15401         ffebad_finish ();
15402       }
15403
15404   /* Record we have printed the status as of this time.  */
15405   last_error_tick = input_file_stack_tick;
15406 }
15407
15408 /* Read a space delimited string of unlimited length from a stdio
15409    file.  */
15410
15411 static char *
15412 read_filename_string (ch, f)
15413      int ch;
15414      FILE *f;
15415 {
15416   char *alloc, *set;
15417   int len;
15418
15419   len = 20;
15420   set = alloc = xmalloc (len + 1);
15421   if (! ISSPACE (ch))
15422     {
15423       *set++ = ch;
15424       while ((ch = getc (f)) != EOF && ! ISSPACE (ch))
15425         {
15426           if (set - alloc == len)
15427             {
15428               len *= 2;
15429               alloc = xrealloc (alloc, len + 1);
15430               set = alloc + len / 2;
15431             }
15432           *set++ = ch;
15433         }
15434     }
15435   *set = '\0';
15436   ungetc (ch, f);
15437   return alloc;
15438 }
15439
15440 /* Read the file name map file for DIRNAME.  */
15441
15442 static struct file_name_map *
15443 read_name_map (dirname)
15444      const char *dirname;
15445 {
15446   /* This structure holds a linked list of file name maps, one per
15447      directory.  */
15448   struct file_name_map_list
15449     {
15450       struct file_name_map_list *map_list_next;
15451       char *map_list_name;
15452       struct file_name_map *map_list_map;
15453     };
15454   static struct file_name_map_list *map_list;
15455   register struct file_name_map_list *map_list_ptr;
15456   char *name;
15457   FILE *f;
15458   size_t dirlen;
15459   int separator_needed;
15460
15461   dirname = skip_redundant_dir_prefix (dirname);
15462
15463   for (map_list_ptr = map_list; map_list_ptr;
15464        map_list_ptr = map_list_ptr->map_list_next)
15465     if (! strcmp (map_list_ptr->map_list_name, dirname))
15466       return map_list_ptr->map_list_map;
15467
15468   map_list_ptr = ((struct file_name_map_list *)
15469                   xmalloc (sizeof (struct file_name_map_list)));
15470   map_list_ptr->map_list_name = xstrdup (dirname);
15471   map_list_ptr->map_list_map = NULL;
15472
15473   dirlen = strlen (dirname);
15474   separator_needed = dirlen != 0 && dirname[dirlen - 1] != '/';
15475   name = (char *) xmalloc (dirlen + strlen (FILE_NAME_MAP_FILE) + 2);
15476   strcpy (name, dirname);
15477   name[dirlen] = '/';
15478   strcpy (name + dirlen + separator_needed, FILE_NAME_MAP_FILE);
15479   f = fopen (name, "r");
15480   free (name);
15481   if (!f)
15482     map_list_ptr->map_list_map = NULL;
15483   else
15484     {
15485       int ch;
15486
15487       while ((ch = getc (f)) != EOF)
15488         {
15489           char *from, *to;
15490           struct file_name_map *ptr;
15491
15492           if (ISSPACE (ch))
15493             continue;
15494           from = read_filename_string (ch, f);
15495           while ((ch = getc (f)) != EOF && ISSPACE (ch) && ch != '\n')
15496             ;
15497           to = read_filename_string (ch, f);
15498
15499           ptr = ((struct file_name_map *)
15500                  xmalloc (sizeof (struct file_name_map)));
15501           ptr->map_from = from;
15502
15503           /* Make the real filename absolute.  */
15504           if (*to == '/')
15505             ptr->map_to = to;
15506           else
15507             {
15508               ptr->map_to = xmalloc (dirlen + strlen (to) + 2);
15509               strcpy (ptr->map_to, dirname);
15510               ptr->map_to[dirlen] = '/';
15511               strcpy (ptr->map_to + dirlen + separator_needed, to);
15512               free (to);
15513             }
15514
15515           ptr->map_next = map_list_ptr->map_list_map;
15516           map_list_ptr->map_list_map = ptr;
15517
15518           while ((ch = getc (f)) != '\n')
15519             if (ch == EOF)
15520               break;
15521         }
15522       fclose (f);
15523     }
15524
15525   map_list_ptr->map_list_next = map_list;
15526   map_list = map_list_ptr;
15527
15528   return map_list_ptr->map_list_map;
15529 }
15530
15531 static void
15532 ffecom_file_ (const char *name)
15533 {
15534   FILE_BUF *fp;
15535
15536   /* Do partial setup of input buffer for the sake of generating
15537      early #line directives (when -g is in effect).  */
15538
15539   fp = &instack[++indepth];
15540   memset ((char *) fp, 0, sizeof (FILE_BUF));
15541   if (name == NULL)
15542     name = "";
15543   fp->nominal_fname = fp->fname = name;
15544 }
15545
15546 static void
15547 ffecom_close_include_ (FILE *f)
15548 {
15549   fclose (f);
15550
15551   indepth--;
15552   input_file_stack_tick++;
15553
15554   ffewhere_line_kill (instack[indepth].line);
15555   ffewhere_column_kill (instack[indepth].column);
15556 }
15557
15558 static int
15559 ffecom_decode_include_option_ (char *spec)
15560 {
15561   struct file_name_list *dirtmp;
15562
15563   if (! ignore_srcdir && !strcmp (spec, "-"))
15564     ignore_srcdir = 1;
15565   else
15566     {
15567       dirtmp = (struct file_name_list *)
15568         xmalloc (sizeof (struct file_name_list));
15569       dirtmp->next = 0;         /* New one goes on the end */
15570       dirtmp->fname = spec;
15571       dirtmp->got_name_map = 0;
15572       if (spec[0] == 0)
15573         error ("directory name must immediately follow -I");
15574       else
15575         append_include_chain (dirtmp, dirtmp);
15576     }
15577   return 1;
15578 }
15579
15580 /* Open INCLUDEd file.  */
15581
15582 static FILE *
15583 ffecom_open_include_ (char *name, ffewhereLine l, ffewhereColumn c)
15584 {
15585   char *fbeg = name;
15586   size_t flen = strlen (fbeg);
15587   struct file_name_list *search_start = include; /* Chain of dirs to search */
15588   struct file_name_list dsp[1]; /* First in chain, if #include "..." */
15589   struct file_name_list *searchptr = 0;
15590   char *fname;          /* Dynamically allocated fname buffer */
15591   FILE *f;
15592   FILE_BUF *fp;
15593
15594   if (flen == 0)
15595     return NULL;
15596
15597   dsp[0].fname = NULL;
15598
15599   /* If -I- was specified, don't search current dir, only spec'd ones. */
15600   if (!ignore_srcdir)
15601     {
15602       for (fp = &instack[indepth]; fp >= instack; fp--)
15603         {
15604           int n;
15605           char *ep;
15606           const char *nam;
15607
15608           if ((nam = fp->nominal_fname) != NULL)
15609             {
15610               /* Found a named file.  Figure out dir of the file,
15611                  and put it in front of the search list.  */
15612               dsp[0].next = search_start;
15613               search_start = dsp;
15614 #ifndef VMS
15615               ep = strrchr (nam, '/');
15616 #ifdef DIR_SEPARATOR
15617             if (ep == NULL) ep = strrchr (nam, DIR_SEPARATOR);
15618             else {
15619               char *tmp = strrchr (nam, DIR_SEPARATOR);
15620               if (tmp != NULL && tmp > ep) ep = tmp;
15621             }
15622 #endif
15623 #else                           /* VMS */
15624               ep = strrchr (nam, ']');
15625               if (ep == NULL) ep = strrchr (nam, '>');
15626               if (ep == NULL) ep = strrchr (nam, ':');
15627               if (ep != NULL) ep++;
15628 #endif                          /* VMS */
15629               if (ep != NULL)
15630                 {
15631                   n = ep - nam;
15632                   dsp[0].fname = (char *) xmalloc (n + 1);
15633                   strncpy (dsp[0].fname, nam, n);
15634                   dsp[0].fname[n] = '\0';
15635                   if (n + INCLUDE_LEN_FUDGE > max_include_len)
15636                     max_include_len = n + INCLUDE_LEN_FUDGE;
15637                 }
15638               else
15639                 dsp[0].fname = NULL; /* Current directory */
15640               dsp[0].got_name_map = 0;
15641               break;
15642             }
15643         }
15644     }
15645
15646   /* Allocate this permanently, because it gets stored in the definitions
15647      of macros.  */
15648   fname = xmalloc (max_include_len + flen + 4);
15649   /* + 2 above for slash and terminating null.  */
15650   /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED
15651      for g77 yet).  */
15652
15653   /* If specified file name is absolute, just open it.  */
15654
15655   if (*fbeg == '/'
15656 #ifdef DIR_SEPARATOR
15657       || *fbeg == DIR_SEPARATOR
15658 #endif
15659       )
15660     {
15661       strncpy (fname, (char *) fbeg, flen);
15662       fname[flen] = 0;
15663       f = open_include_file (fname, NULL);
15664     }
15665   else
15666     {
15667       f = NULL;
15668
15669       /* Search directory path, trying to open the file.
15670          Copy each filename tried into FNAME.  */
15671
15672       for (searchptr = search_start; searchptr; searchptr = searchptr->next)
15673         {
15674           if (searchptr->fname)
15675             {
15676               /* The empty string in a search path is ignored.
15677                  This makes it possible to turn off entirely
15678                  a standard piece of the list.  */
15679               if (searchptr->fname[0] == 0)
15680                 continue;
15681               strcpy (fname, skip_redundant_dir_prefix (searchptr->fname));
15682               if (fname[0] && fname[strlen (fname) - 1] != '/')
15683                 strcat (fname, "/");
15684               fname[strlen (fname) + flen] = 0;
15685             }
15686           else
15687             fname[0] = 0;
15688
15689           strncat (fname, fbeg, flen);
15690 #ifdef VMS
15691           /* Change this 1/2 Unix 1/2 VMS file specification into a
15692              full VMS file specification */
15693           if (searchptr->fname && (searchptr->fname[0] != 0))
15694             {
15695               /* Fix up the filename */
15696               hack_vms_include_specification (fname);
15697             }
15698           else
15699             {
15700               /* This is a normal VMS filespec, so use it unchanged.  */
15701               strncpy (fname, (char *) fbeg, flen);
15702               fname[flen] = 0;
15703 #if 0   /* Not for g77.  */
15704               /* if it's '#include filename', add the missing .h */
15705               if (strchr (fname, '.') == NULL)
15706                 strcat (fname, ".h");
15707 #endif
15708             }
15709 #endif /* VMS */
15710           f = open_include_file (fname, searchptr);
15711 #ifdef EACCES
15712           if (f == NULL && errno == EACCES)
15713             {
15714               print_containing_files (FFEBAD_severityWARNING);
15715               ffebad_start_msg ("At %0, INCLUDE file %A exists, but is not readable",
15716                                 FFEBAD_severityWARNING);
15717               ffebad_string (fname);
15718               ffebad_here (0, l, c);
15719               ffebad_finish ();
15720             }
15721 #endif
15722           if (f != NULL)
15723             break;
15724         }
15725     }
15726
15727   if (f == NULL)
15728     {
15729       /* A file that was not found.  */
15730
15731       strncpy (fname, (char *) fbeg, flen);
15732       fname[flen] = 0;
15733       print_containing_files (ffebad_severity (FFEBAD_OPEN_INCLUDE));
15734       ffebad_start (FFEBAD_OPEN_INCLUDE);
15735       ffebad_here (0, l, c);
15736       ffebad_string (fname);
15737       ffebad_finish ();
15738     }
15739
15740   if (dsp[0].fname != NULL)
15741     free (dsp[0].fname);
15742
15743   if (f == NULL)
15744     return NULL;
15745
15746   if (indepth >= (INPUT_STACK_MAX - 1))
15747     {
15748       print_containing_files (FFEBAD_severityFATAL);
15749       ffebad_start_msg ("At %0, INCLUDE nesting too deep",
15750                         FFEBAD_severityFATAL);
15751       ffebad_string (fname);
15752       ffebad_here (0, l, c);
15753       ffebad_finish ();
15754       return NULL;
15755     }
15756
15757   instack[indepth].line = ffewhere_line_use (l);
15758   instack[indepth].column = ffewhere_column_use (c);
15759
15760   fp = &instack[indepth + 1];
15761   memset ((char *) fp, 0, sizeof (FILE_BUF));
15762   fp->nominal_fname = fp->fname = fname;
15763   fp->dir = searchptr;
15764
15765   indepth++;
15766   input_file_stack_tick++;
15767
15768   return f;
15769 }
15770
15771 /**INDENT* (Do not reformat this comment even with -fca option.)
15772    Data-gathering files: Given the source file listed below, compiled with
15773    f2c I obtained the output file listed after that, and from the output
15774    file I derived the above code.
15775
15776 -------- (begin input file to f2c)
15777         implicit none
15778         character*10 A1,A2
15779         complex C1,C2
15780         integer I1,I2
15781         real R1,R2
15782         double precision D1,D2
15783 C
15784         call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2)
15785 c /
15786         call fooI(I1/I2)
15787         call fooR(R1/I1)
15788         call fooD(D1/I1)
15789         call fooC(C1/I1)
15790         call fooR(R1/R2)
15791         call fooD(R1/D1)
15792         call fooD(D1/D2)
15793         call fooD(D1/R1)
15794         call fooC(C1/C2)
15795         call fooC(C1/R1)
15796         call fooZ(C1/D1)
15797 c **
15798         call fooI(I1**I2)
15799         call fooR(R1**I1)
15800         call fooD(D1**I1)
15801         call fooC(C1**I1)
15802         call fooR(R1**R2)
15803         call fooD(R1**D1)
15804         call fooD(D1**D2)
15805         call fooD(D1**R1)
15806         call fooC(C1**C2)
15807         call fooC(C1**R1)
15808         call fooZ(C1**D1)
15809 c FFEINTRIN_impABS
15810         call fooR(ABS(R1))
15811 c FFEINTRIN_impACOS
15812         call fooR(ACOS(R1))
15813 c FFEINTRIN_impAIMAG
15814         call fooR(AIMAG(C1))
15815 c FFEINTRIN_impAINT
15816         call fooR(AINT(R1))
15817 c FFEINTRIN_impALOG
15818         call fooR(ALOG(R1))
15819 c FFEINTRIN_impALOG10
15820         call fooR(ALOG10(R1))
15821 c FFEINTRIN_impAMAX0
15822         call fooR(AMAX0(I1,I2))
15823 c FFEINTRIN_impAMAX1
15824         call fooR(AMAX1(R1,R2))
15825 c FFEINTRIN_impAMIN0
15826         call fooR(AMIN0(I1,I2))
15827 c FFEINTRIN_impAMIN1
15828         call fooR(AMIN1(R1,R2))
15829 c FFEINTRIN_impAMOD
15830         call fooR(AMOD(R1,R2))
15831 c FFEINTRIN_impANINT
15832         call fooR(ANINT(R1))
15833 c FFEINTRIN_impASIN
15834         call fooR(ASIN(R1))
15835 c FFEINTRIN_impATAN
15836         call fooR(ATAN(R1))
15837 c FFEINTRIN_impATAN2
15838         call fooR(ATAN2(R1,R2))
15839 c FFEINTRIN_impCABS
15840         call fooR(CABS(C1))
15841 c FFEINTRIN_impCCOS
15842         call fooC(CCOS(C1))
15843 c FFEINTRIN_impCEXP
15844         call fooC(CEXP(C1))
15845 c FFEINTRIN_impCHAR
15846         call fooA(CHAR(I1))
15847 c FFEINTRIN_impCLOG
15848         call fooC(CLOG(C1))
15849 c FFEINTRIN_impCONJG
15850         call fooC(CONJG(C1))
15851 c FFEINTRIN_impCOS
15852         call fooR(COS(R1))
15853 c FFEINTRIN_impCOSH
15854         call fooR(COSH(R1))
15855 c FFEINTRIN_impCSIN
15856         call fooC(CSIN(C1))
15857 c FFEINTRIN_impCSQRT
15858         call fooC(CSQRT(C1))
15859 c FFEINTRIN_impDABS
15860         call fooD(DABS(D1))
15861 c FFEINTRIN_impDACOS
15862         call fooD(DACOS(D1))
15863 c FFEINTRIN_impDASIN
15864         call fooD(DASIN(D1))
15865 c FFEINTRIN_impDATAN
15866         call fooD(DATAN(D1))
15867 c FFEINTRIN_impDATAN2
15868         call fooD(DATAN2(D1,D2))
15869 c FFEINTRIN_impDCOS
15870         call fooD(DCOS(D1))
15871 c FFEINTRIN_impDCOSH
15872         call fooD(DCOSH(D1))
15873 c FFEINTRIN_impDDIM
15874         call fooD(DDIM(D1,D2))
15875 c FFEINTRIN_impDEXP
15876         call fooD(DEXP(D1))
15877 c FFEINTRIN_impDIM
15878         call fooR(DIM(R1,R2))
15879 c FFEINTRIN_impDINT
15880         call fooD(DINT(D1))
15881 c FFEINTRIN_impDLOG
15882         call fooD(DLOG(D1))
15883 c FFEINTRIN_impDLOG10
15884         call fooD(DLOG10(D1))
15885 c FFEINTRIN_impDMAX1
15886         call fooD(DMAX1(D1,D2))
15887 c FFEINTRIN_impDMIN1
15888         call fooD(DMIN1(D1,D2))
15889 c FFEINTRIN_impDMOD
15890         call fooD(DMOD(D1,D2))
15891 c FFEINTRIN_impDNINT
15892         call fooD(DNINT(D1))
15893 c FFEINTRIN_impDPROD
15894         call fooD(DPROD(R1,R2))
15895 c FFEINTRIN_impDSIGN
15896         call fooD(DSIGN(D1,D2))
15897 c FFEINTRIN_impDSIN
15898         call fooD(DSIN(D1))
15899 c FFEINTRIN_impDSINH
15900         call fooD(DSINH(D1))
15901 c FFEINTRIN_impDSQRT
15902         call fooD(DSQRT(D1))
15903 c FFEINTRIN_impDTAN
15904         call fooD(DTAN(D1))
15905 c FFEINTRIN_impDTANH
15906         call fooD(DTANH(D1))
15907 c FFEINTRIN_impEXP
15908         call fooR(EXP(R1))
15909 c FFEINTRIN_impIABS
15910         call fooI(IABS(I1))
15911 c FFEINTRIN_impICHAR
15912         call fooI(ICHAR(A1))
15913 c FFEINTRIN_impIDIM
15914         call fooI(IDIM(I1,I2))
15915 c FFEINTRIN_impIDNINT
15916         call fooI(IDNINT(D1))
15917 c FFEINTRIN_impINDEX
15918         call fooI(INDEX(A1,A2))
15919 c FFEINTRIN_impISIGN
15920         call fooI(ISIGN(I1,I2))
15921 c FFEINTRIN_impLEN
15922         call fooI(LEN(A1))
15923 c FFEINTRIN_impLGE
15924         call fooL(LGE(A1,A2))
15925 c FFEINTRIN_impLGT
15926         call fooL(LGT(A1,A2))
15927 c FFEINTRIN_impLLE
15928         call fooL(LLE(A1,A2))
15929 c FFEINTRIN_impLLT
15930         call fooL(LLT(A1,A2))
15931 c FFEINTRIN_impMAX0
15932         call fooI(MAX0(I1,I2))
15933 c FFEINTRIN_impMAX1
15934         call fooI(MAX1(R1,R2))
15935 c FFEINTRIN_impMIN0
15936         call fooI(MIN0(I1,I2))
15937 c FFEINTRIN_impMIN1
15938         call fooI(MIN1(R1,R2))
15939 c FFEINTRIN_impMOD
15940         call fooI(MOD(I1,I2))
15941 c FFEINTRIN_impNINT
15942         call fooI(NINT(R1))
15943 c FFEINTRIN_impSIGN
15944         call fooR(SIGN(R1,R2))
15945 c FFEINTRIN_impSIN
15946         call fooR(SIN(R1))
15947 c FFEINTRIN_impSINH
15948         call fooR(SINH(R1))
15949 c FFEINTRIN_impSQRT
15950         call fooR(SQRT(R1))
15951 c FFEINTRIN_impTAN
15952         call fooR(TAN(R1))
15953 c FFEINTRIN_impTANH
15954         call fooR(TANH(R1))
15955 c FFEINTRIN_imp_CMPLX_C
15956         call fooC(cmplx(C1,C2))
15957 c FFEINTRIN_imp_CMPLX_D
15958         call fooZ(cmplx(D1,D2))
15959 c FFEINTRIN_imp_CMPLX_I
15960         call fooC(cmplx(I1,I2))
15961 c FFEINTRIN_imp_CMPLX_R
15962         call fooC(cmplx(R1,R2))
15963 c FFEINTRIN_imp_DBLE_C
15964         call fooD(dble(C1))
15965 c FFEINTRIN_imp_DBLE_D
15966         call fooD(dble(D1))
15967 c FFEINTRIN_imp_DBLE_I
15968         call fooD(dble(I1))
15969 c FFEINTRIN_imp_DBLE_R
15970         call fooD(dble(R1))
15971 c FFEINTRIN_imp_INT_C
15972         call fooI(int(C1))
15973 c FFEINTRIN_imp_INT_D
15974         call fooI(int(D1))
15975 c FFEINTRIN_imp_INT_I
15976         call fooI(int(I1))
15977 c FFEINTRIN_imp_INT_R
15978         call fooI(int(R1))
15979 c FFEINTRIN_imp_REAL_C
15980         call fooR(real(C1))
15981 c FFEINTRIN_imp_REAL_D
15982         call fooR(real(D1))
15983 c FFEINTRIN_imp_REAL_I
15984         call fooR(real(I1))
15985 c FFEINTRIN_imp_REAL_R
15986         call fooR(real(R1))
15987 c
15988 c FFEINTRIN_imp_INT_D:
15989 c
15990 c FFEINTRIN_specIDINT
15991         call fooI(IDINT(D1))
15992 c
15993 c FFEINTRIN_imp_INT_R:
15994 c
15995 c FFEINTRIN_specIFIX
15996         call fooI(IFIX(R1))
15997 c FFEINTRIN_specINT
15998         call fooI(INT(R1))
15999 c
16000 c FFEINTRIN_imp_REAL_D:
16001 c
16002 c FFEINTRIN_specSNGL
16003         call fooR(SNGL(D1))
16004 c
16005 c FFEINTRIN_imp_REAL_I:
16006 c
16007 c FFEINTRIN_specFLOAT
16008         call fooR(FLOAT(I1))
16009 c FFEINTRIN_specREAL
16010         call fooR(REAL(I1))
16011 c
16012         end
16013 -------- (end input file to f2c)
16014
16015 -------- (begin output from providing above input file as input to:
16016 --------  `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
16017 --------     -e "s:^#.*$::g"')
16018
16019 //  -- translated by f2c (version 19950223).
16020    You must link the resulting object file with the libraries:
16021         -lf2c -lm   (in that order)
16022 //
16023
16024
16025 // f2c.h  --  Standard Fortran to C header file //
16026
16027 ///  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
16028
16029         - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
16030
16031
16032
16033
16034 // F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems //
16035 // we assume short, float are OK //
16036 typedef long int // long int // integer;
16037 typedef char *address;
16038 typedef short int shortint;
16039 typedef float real;
16040 typedef double doublereal;
16041 typedef struct { real r, i; } complex;
16042 typedef struct { doublereal r, i; } doublecomplex;
16043 typedef long int // long int // logical;
16044 typedef short int shortlogical;
16045 typedef char logical1;
16046 typedef char integer1;
16047 // typedef long long longint; // // system-dependent //
16048
16049
16050
16051
16052 // Extern is for use with -E //
16053
16054
16055
16056
16057 // I/O stuff //
16058
16059
16060
16061
16062
16063
16064
16065
16066 typedef long int // int or long int // flag;
16067 typedef long int // int or long int // ftnlen;
16068 typedef long int // int or long int // ftnint;
16069
16070
16071 //external read, write//
16072 typedef struct
16073 {       flag cierr;
16074         ftnint ciunit;
16075         flag ciend;
16076         char *cifmt;
16077         ftnint cirec;
16078 } cilist;
16079
16080 //internal read, write//
16081 typedef struct
16082 {       flag icierr;
16083         char *iciunit;
16084         flag iciend;
16085         char *icifmt;
16086         ftnint icirlen;
16087         ftnint icirnum;
16088 } icilist;
16089
16090 //open//
16091 typedef struct
16092 {       flag oerr;
16093         ftnint ounit;
16094         char *ofnm;
16095         ftnlen ofnmlen;
16096         char *osta;
16097         char *oacc;
16098         char *ofm;
16099         ftnint orl;
16100         char *oblnk;
16101 } olist;
16102
16103 //close//
16104 typedef struct
16105 {       flag cerr;
16106         ftnint cunit;
16107         char *csta;
16108 } cllist;
16109
16110 //rewind, backspace, endfile//
16111 typedef struct
16112 {       flag aerr;
16113         ftnint aunit;
16114 } alist;
16115
16116 // inquire //
16117 typedef struct
16118 {       flag inerr;
16119         ftnint inunit;
16120         char *infile;
16121         ftnlen infilen;
16122         ftnint  *inex;  //parameters in standard's order//
16123         ftnint  *inopen;
16124         ftnint  *innum;
16125         ftnint  *innamed;
16126         char    *inname;
16127         ftnlen  innamlen;
16128         char    *inacc;
16129         ftnlen  inacclen;
16130         char    *inseq;
16131         ftnlen  inseqlen;
16132         char    *indir;
16133         ftnlen  indirlen;
16134         char    *infmt;
16135         ftnlen  infmtlen;
16136         char    *inform;
16137         ftnint  informlen;
16138         char    *inunf;
16139         ftnlen  inunflen;
16140         ftnint  *inrecl;
16141         ftnint  *innrec;
16142         char    *inblank;
16143         ftnlen  inblanklen;
16144 } inlist;
16145
16146
16147
16148 union Multitype {       // for multiple entry points //
16149         integer1 g;
16150         shortint h;
16151         integer i;
16152         // longint j; //
16153         real r;
16154         doublereal d;
16155         complex c;
16156         doublecomplex z;
16157         };
16158
16159 typedef union Multitype Multitype;
16160
16161 typedef long Long;      // No longer used; formerly in Namelist //
16162
16163 struct Vardesc {        // for Namelist //
16164         char *name;
16165         char *addr;
16166         ftnlen *dims;
16167         int  type;
16168         };
16169 typedef struct Vardesc Vardesc;
16170
16171 struct Namelist {
16172         char *name;
16173         Vardesc **vars;
16174         int nvars;
16175         };
16176 typedef struct Namelist Namelist;
16177
16178
16179
16180
16181
16182
16183
16184
16185 // procedure parameter types for -A and -C++ //
16186
16187
16188
16189
16190 typedef int // Unknown procedure type // (*U_fp)();
16191 typedef shortint (*J_fp)();
16192 typedef integer (*I_fp)();
16193 typedef real (*R_fp)();
16194 typedef doublereal (*D_fp)(), (*E_fp)();
16195 typedef // Complex // void  (*C_fp)();
16196 typedef // Double Complex // void  (*Z_fp)();
16197 typedef logical (*L_fp)();
16198 typedef shortlogical (*K_fp)();
16199 typedef // Character // void  (*H_fp)();
16200 typedef // Subroutine // int (*S_fp)();
16201
16202 // E_fp is for real functions when -R is not specified //
16203 typedef void  C_f;      // complex function //
16204 typedef void  H_f;      // character function //
16205 typedef void  Z_f;      // double complex function //
16206 typedef doublereal E_f; // real function with -R not specified //
16207
16208 // undef any lower-case symbols that your C compiler predefines, e.g.: //
16209
16210
16211 // (No such symbols should be defined in a strict ANSI C compiler.
16212    We can avoid trouble with f2c-translated code by using
16213    gcc -ansi [-traditional].) //
16214
16215
16216
16217
16218
16219
16220
16221
16222
16223
16224
16225
16226
16227
16228
16229
16230
16231
16232
16233
16234
16235
16236
16237 // Main program // MAIN__()
16238 {
16239     // System generated locals //
16240     integer i__1;
16241     real r__1, r__2;
16242     doublereal d__1, d__2;
16243     complex q__1;
16244     doublecomplex z__1, z__2, z__3;
16245     logical L__1;
16246     char ch__1[1];
16247
16248     // Builtin functions //
16249     void c_div();
16250     integer pow_ii();
16251     double pow_ri(), pow_di();
16252     void pow_ci();
16253     double pow_dd();
16254     void pow_zz();
16255     double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
16256             asin(), atan(), atan2(), c_abs();
16257     void c_cos(), c_exp(), c_log(), r_cnjg();
16258     double cos(), cosh();
16259     void c_sin(), c_sqrt();
16260     double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
16261             d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
16262     integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
16263     logical l_ge(), l_gt(), l_le(), l_lt();
16264     integer i_nint();
16265     double r_sign();
16266
16267     // Local variables //
16268     extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
16269             fool_(), fooz_(), getem_();
16270     static char a1[10], a2[10];
16271     static complex c1, c2;
16272     static doublereal d1, d2;
16273     static integer i1, i2;
16274     static real r1, r2;
16275
16276
16277     getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L);
16278 // / //
16279     i__1 = i1 / i2;
16280     fooi_(&i__1);
16281     r__1 = r1 / i1;
16282     foor_(&r__1);
16283     d__1 = d1 / i1;
16284     food_(&d__1);
16285     d__1 = (doublereal) i1;
16286     q__1.r = c1.r / d__1, q__1.i = c1.i / d__1;
16287     fooc_(&q__1);
16288     r__1 = r1 / r2;
16289     foor_(&r__1);
16290     d__1 = r1 / d1;
16291     food_(&d__1);
16292     d__1 = d1 / d2;
16293     food_(&d__1);
16294     d__1 = d1 / r1;
16295     food_(&d__1);
16296     c_div(&q__1, &c1, &c2);
16297     fooc_(&q__1);
16298     q__1.r = c1.r / r1, q__1.i = c1.i / r1;
16299     fooc_(&q__1);
16300     z__1.r = c1.r / d1, z__1.i = c1.i / d1;
16301     fooz_(&z__1);
16302 // ** //
16303     i__1 = pow_ii(&i1, &i2);
16304     fooi_(&i__1);
16305     r__1 = pow_ri(&r1, &i1);
16306     foor_(&r__1);
16307     d__1 = pow_di(&d1, &i1);
16308     food_(&d__1);
16309     pow_ci(&q__1, &c1, &i1);
16310     fooc_(&q__1);
16311     d__1 = (doublereal) r1;
16312     d__2 = (doublereal) r2;
16313     r__1 = pow_dd(&d__1, &d__2);
16314     foor_(&r__1);
16315     d__2 = (doublereal) r1;
16316     d__1 = pow_dd(&d__2, &d1);
16317     food_(&d__1);
16318     d__1 = pow_dd(&d1, &d2);
16319     food_(&d__1);
16320     d__2 = (doublereal) r1;
16321     d__1 = pow_dd(&d1, &d__2);
16322     food_(&d__1);
16323     z__2.r = c1.r, z__2.i = c1.i;
16324     z__3.r = c2.r, z__3.i = c2.i;
16325     pow_zz(&z__1, &z__2, &z__3);
16326     q__1.r = z__1.r, q__1.i = z__1.i;
16327     fooc_(&q__1);
16328     z__2.r = c1.r, z__2.i = c1.i;
16329     z__3.r = r1, z__3.i = 0.;
16330     pow_zz(&z__1, &z__2, &z__3);
16331     q__1.r = z__1.r, q__1.i = z__1.i;
16332     fooc_(&q__1);
16333     z__2.r = c1.r, z__2.i = c1.i;
16334     z__3.r = d1, z__3.i = 0.;
16335     pow_zz(&z__1, &z__2, &z__3);
16336     fooz_(&z__1);
16337 // FFEINTRIN_impABS //
16338     r__1 = (doublereal)((  r1  ) >= 0 ? (  r1  ) : -(  r1  ))  ;
16339     foor_(&r__1);
16340 // FFEINTRIN_impACOS //
16341     r__1 = acos(r1);
16342     foor_(&r__1);
16343 // FFEINTRIN_impAIMAG //
16344     r__1 = r_imag(&c1);
16345     foor_(&r__1);
16346 // FFEINTRIN_impAINT //
16347     r__1 = r_int(&r1);
16348     foor_(&r__1);
16349 // FFEINTRIN_impALOG //
16350     r__1 = log(r1);
16351     foor_(&r__1);
16352 // FFEINTRIN_impALOG10 //
16353     r__1 = r_lg10(&r1);
16354     foor_(&r__1);
16355 // FFEINTRIN_impAMAX0 //
16356     r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16357     foor_(&r__1);
16358 // FFEINTRIN_impAMAX1 //
16359     r__1 = (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16360     foor_(&r__1);
16361 // FFEINTRIN_impAMIN0 //
16362     r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16363     foor_(&r__1);
16364 // FFEINTRIN_impAMIN1 //
16365     r__1 = (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16366     foor_(&r__1);
16367 // FFEINTRIN_impAMOD //
16368     r__1 = r_mod(&r1, &r2);
16369     foor_(&r__1);
16370 // FFEINTRIN_impANINT //
16371     r__1 = r_nint(&r1);
16372     foor_(&r__1);
16373 // FFEINTRIN_impASIN //
16374     r__1 = asin(r1);
16375     foor_(&r__1);
16376 // FFEINTRIN_impATAN //
16377     r__1 = atan(r1);
16378     foor_(&r__1);
16379 // FFEINTRIN_impATAN2 //
16380     r__1 = atan2(r1, r2);
16381     foor_(&r__1);
16382 // FFEINTRIN_impCABS //
16383     r__1 = c_abs(&c1);
16384     foor_(&r__1);
16385 // FFEINTRIN_impCCOS //
16386     c_cos(&q__1, &c1);
16387     fooc_(&q__1);
16388 // FFEINTRIN_impCEXP //
16389     c_exp(&q__1, &c1);
16390     fooc_(&q__1);
16391 // FFEINTRIN_impCHAR //
16392     *(unsigned char *)&ch__1[0] = i1;
16393     fooa_(ch__1, 1L);
16394 // FFEINTRIN_impCLOG //
16395     c_log(&q__1, &c1);
16396     fooc_(&q__1);
16397 // FFEINTRIN_impCONJG //
16398     r_cnjg(&q__1, &c1);
16399     fooc_(&q__1);
16400 // FFEINTRIN_impCOS //
16401     r__1 = cos(r1);
16402     foor_(&r__1);
16403 // FFEINTRIN_impCOSH //
16404     r__1 = cosh(r1);
16405     foor_(&r__1);
16406 // FFEINTRIN_impCSIN //
16407     c_sin(&q__1, &c1);
16408     fooc_(&q__1);
16409 // FFEINTRIN_impCSQRT //
16410     c_sqrt(&q__1, &c1);
16411     fooc_(&q__1);
16412 // FFEINTRIN_impDABS //
16413     d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ;
16414     food_(&d__1);
16415 // FFEINTRIN_impDACOS //
16416     d__1 = acos(d1);
16417     food_(&d__1);
16418 // FFEINTRIN_impDASIN //
16419     d__1 = asin(d1);
16420     food_(&d__1);
16421 // FFEINTRIN_impDATAN //
16422     d__1 = atan(d1);
16423     food_(&d__1);
16424 // FFEINTRIN_impDATAN2 //
16425     d__1 = atan2(d1, d2);
16426     food_(&d__1);
16427 // FFEINTRIN_impDCOS //
16428     d__1 = cos(d1);
16429     food_(&d__1);
16430 // FFEINTRIN_impDCOSH //
16431     d__1 = cosh(d1);
16432     food_(&d__1);
16433 // FFEINTRIN_impDDIM //
16434     d__1 = d_dim(&d1, &d2);
16435     food_(&d__1);
16436 // FFEINTRIN_impDEXP //
16437     d__1 = exp(d1);
16438     food_(&d__1);
16439 // FFEINTRIN_impDIM //
16440     r__1 = r_dim(&r1, &r2);
16441     foor_(&r__1);
16442 // FFEINTRIN_impDINT //
16443     d__1 = d_int(&d1);
16444     food_(&d__1);
16445 // FFEINTRIN_impDLOG //
16446     d__1 = log(d1);
16447     food_(&d__1);
16448 // FFEINTRIN_impDLOG10 //
16449     d__1 = d_lg10(&d1);
16450     food_(&d__1);
16451 // FFEINTRIN_impDMAX1 //
16452     d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ;
16453     food_(&d__1);
16454 // FFEINTRIN_impDMIN1 //
16455     d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ;
16456     food_(&d__1);
16457 // FFEINTRIN_impDMOD //
16458     d__1 = d_mod(&d1, &d2);
16459     food_(&d__1);
16460 // FFEINTRIN_impDNINT //
16461     d__1 = d_nint(&d1);
16462     food_(&d__1);
16463 // FFEINTRIN_impDPROD //
16464     d__1 = (doublereal) r1 * r2;
16465     food_(&d__1);
16466 // FFEINTRIN_impDSIGN //
16467     d__1 = d_sign(&d1, &d2);
16468     food_(&d__1);
16469 // FFEINTRIN_impDSIN //
16470     d__1 = sin(d1);
16471     food_(&d__1);
16472 // FFEINTRIN_impDSINH //
16473     d__1 = sinh(d1);
16474     food_(&d__1);
16475 // FFEINTRIN_impDSQRT //
16476     d__1 = sqrt(d1);
16477     food_(&d__1);
16478 // FFEINTRIN_impDTAN //
16479     d__1 = tan(d1);
16480     food_(&d__1);
16481 // FFEINTRIN_impDTANH //
16482     d__1 = tanh(d1);
16483     food_(&d__1);
16484 // FFEINTRIN_impEXP //
16485     r__1 = exp(r1);
16486     foor_(&r__1);
16487 // FFEINTRIN_impIABS //
16488     i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ;
16489     fooi_(&i__1);
16490 // FFEINTRIN_impICHAR //
16491     i__1 = *(unsigned char *)a1;
16492     fooi_(&i__1);
16493 // FFEINTRIN_impIDIM //
16494     i__1 = i_dim(&i1, &i2);
16495     fooi_(&i__1);
16496 // FFEINTRIN_impIDNINT //
16497     i__1 = i_dnnt(&d1);
16498     fooi_(&i__1);
16499 // FFEINTRIN_impINDEX //
16500     i__1 = i_indx(a1, a2, 10L, 10L);
16501     fooi_(&i__1);
16502 // FFEINTRIN_impISIGN //
16503     i__1 = i_sign(&i1, &i2);
16504     fooi_(&i__1);
16505 // FFEINTRIN_impLEN //
16506     i__1 = i_len(a1, 10L);
16507     fooi_(&i__1);
16508 // FFEINTRIN_impLGE //
16509     L__1 = l_ge(a1, a2, 10L, 10L);
16510     fool_(&L__1);
16511 // FFEINTRIN_impLGT //
16512     L__1 = l_gt(a1, a2, 10L, 10L);
16513     fool_(&L__1);
16514 // FFEINTRIN_impLLE //
16515     L__1 = l_le(a1, a2, 10L, 10L);
16516     fool_(&L__1);
16517 // FFEINTRIN_impLLT //
16518     L__1 = l_lt(a1, a2, 10L, 10L);
16519     fool_(&L__1);
16520 // FFEINTRIN_impMAX0 //
16521     i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16522     fooi_(&i__1);
16523 // FFEINTRIN_impMAX1 //
16524     i__1 = (integer) (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16525     fooi_(&i__1);
16526 // FFEINTRIN_impMIN0 //
16527     i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16528     fooi_(&i__1);
16529 // FFEINTRIN_impMIN1 //
16530     i__1 = (integer) (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16531     fooi_(&i__1);
16532 // FFEINTRIN_impMOD //
16533     i__1 = i1 % i2;
16534     fooi_(&i__1);
16535 // FFEINTRIN_impNINT //
16536     i__1 = i_nint(&r1);
16537     fooi_(&i__1);
16538 // FFEINTRIN_impSIGN //
16539     r__1 = r_sign(&r1, &r2);
16540     foor_(&r__1);
16541 // FFEINTRIN_impSIN //
16542     r__1 = sin(r1);
16543     foor_(&r__1);
16544 // FFEINTRIN_impSINH //
16545     r__1 = sinh(r1);
16546     foor_(&r__1);
16547 // FFEINTRIN_impSQRT //
16548     r__1 = sqrt(r1);
16549     foor_(&r__1);
16550 // FFEINTRIN_impTAN //
16551     r__1 = tan(r1);
16552     foor_(&r__1);
16553 // FFEINTRIN_impTANH //
16554     r__1 = tanh(r1);
16555     foor_(&r__1);
16556 // FFEINTRIN_imp_CMPLX_C //
16557     r__1 = c1.r;
16558     r__2 = c2.r;
16559     q__1.r = r__1, q__1.i = r__2;
16560     fooc_(&q__1);
16561 // FFEINTRIN_imp_CMPLX_D //
16562     z__1.r = d1, z__1.i = d2;
16563     fooz_(&z__1);
16564 // FFEINTRIN_imp_CMPLX_I //
16565     r__1 = (real) i1;
16566     r__2 = (real) i2;
16567     q__1.r = r__1, q__1.i = r__2;
16568     fooc_(&q__1);
16569 // FFEINTRIN_imp_CMPLX_R //
16570     q__1.r = r1, q__1.i = r2;
16571     fooc_(&q__1);
16572 // FFEINTRIN_imp_DBLE_C //
16573     d__1 = (doublereal) c1.r;
16574     food_(&d__1);
16575 // FFEINTRIN_imp_DBLE_D //
16576     d__1 = d1;
16577     food_(&d__1);
16578 // FFEINTRIN_imp_DBLE_I //
16579     d__1 = (doublereal) i1;
16580     food_(&d__1);
16581 // FFEINTRIN_imp_DBLE_R //
16582     d__1 = (doublereal) r1;
16583     food_(&d__1);
16584 // FFEINTRIN_imp_INT_C //
16585     i__1 = (integer) c1.r;
16586     fooi_(&i__1);
16587 // FFEINTRIN_imp_INT_D //
16588     i__1 = (integer) d1;
16589     fooi_(&i__1);
16590 // FFEINTRIN_imp_INT_I //
16591     i__1 = i1;
16592     fooi_(&i__1);
16593 // FFEINTRIN_imp_INT_R //
16594     i__1 = (integer) r1;
16595     fooi_(&i__1);
16596 // FFEINTRIN_imp_REAL_C //
16597     r__1 = c1.r;
16598     foor_(&r__1);
16599 // FFEINTRIN_imp_REAL_D //
16600     r__1 = (real) d1;
16601     foor_(&r__1);
16602 // FFEINTRIN_imp_REAL_I //
16603     r__1 = (real) i1;
16604     foor_(&r__1);
16605 // FFEINTRIN_imp_REAL_R //
16606     r__1 = r1;
16607     foor_(&r__1);
16608
16609 // FFEINTRIN_imp_INT_D: //
16610
16611 // FFEINTRIN_specIDINT //
16612     i__1 = (integer) d1;
16613     fooi_(&i__1);
16614
16615 // FFEINTRIN_imp_INT_R: //
16616
16617 // FFEINTRIN_specIFIX //
16618     i__1 = (integer) r1;
16619     fooi_(&i__1);
16620 // FFEINTRIN_specINT //
16621     i__1 = (integer) r1;
16622     fooi_(&i__1);
16623
16624 // FFEINTRIN_imp_REAL_D: //
16625
16626 // FFEINTRIN_specSNGL //
16627     r__1 = (real) d1;
16628     foor_(&r__1);
16629
16630 // FFEINTRIN_imp_REAL_I: //
16631
16632 // FFEINTRIN_specFLOAT //
16633     r__1 = (real) i1;
16634     foor_(&r__1);
16635 // FFEINTRIN_specREAL //
16636     r__1 = (real) i1;
16637     foor_(&r__1);
16638
16639 } // MAIN__ //
16640
16641 -------- (end output file from f2c)
16642
16643 */